Author: abaine Date: Wed Jul 4 22:59:25 2007 New Revision: 56
Added: trunk/funds/src/trees/binary-tree.lisp Log: Added binary-tree.lisp.
Added: trunk/funds/src/trees/binary-tree.lisp ============================================================================== --- (empty file) +++ trunk/funds/src/trees/binary-tree.lisp Wed Jul 4 22:59:25 2007 @@ -0,0 +1,83 @@ + +(in-package :funds) + +(defstruct bt + key + value + left + right) + +(defun make-empty-bt () + nil) + +(defun bt-empty-p (tree) + (null tree)) + +(defun bt-insert (tree key value &key (order #'<) (test #'eql)) + (cond ((bt-empty-p tree) (make-bt :key key + :value value + :left (make-empty-bt) + :right (make-empty-bt))) + ((funcall test key (bt-key tree)) (make-bt :key key + :value value + :left (bt-left tree) + :right (bt-right tree))) + + ((funcall order key (bt-key tree)) + (make-bt :key (bt-key tree) + :value (bt-value tree) + :left (bt-insert (bt-left tree) key value :order order :test test) + :right (bt-right tree))) + (t (make-bt :key (bt-key tree) + :value (bt-value tree) + :left (bt-left tree) + :right (bt-insert (bt-right tree)key value :order order :test test))))) + +(defun bt-find (tree key &key (order #'<) (test #'eql)) + (cond ((bt-empty-p tree) (values nil nil)) + ((funcall test key (bt-key tree)) (values (bt-value tree) t)) + ((funcall order key (bt-key tree)) (bt-find (bt-left tree) key + :order order + :test test)) + (t (bt-find (bt-right tree) key + :order order + :test test)))) + +(defun bt-remove (tree key &key (order #'<) (test #'eql)) + (cond ((bt-empty-p tree) tree) + ((funcall test key (bt-key tree)) (remove-root tree :order order :test test)) + ((funcall order key (bt-key tree)) (make-bt :key (bt-key tree) + :value (bt-value tree) + :left (bt-remove (bt-left tree) key + :order order + :test test) + :right (bt-right tree))) + (t (make-bt :key (bt-key tree) + :value (bt-value tree) + :left (bt-left tree) + :right (bt-remove (bt-right tree) key + :order order + :test test))))) + +(defun remove-root (tree &key order test) + (cond ((bt-empty-p (bt-left tree)) (bt-right tree)) + ((bt-empty-p (bt-right tree)) (bt-left tree)) + (t (let* ((next (next-in-order (bt-right tree) order)) + (k (bt-key next))) + (make-bt :key k + :value (bt-value next) + :left (bt-left tree) + :right (bt-remove (bt-right tree) k + :order order + :test test)))))) + +(defun bt->alist (tree) + (if (bt-empty-p tree) nil + (append (bt->alist (bt-left tree)) + (cons (cons (bt-key tree) (bt-value tree)) + (bt->alist (bt-right tree)))))) + +(defun next-in-order (tree order) + (if (bt-empty-p (bt-left tree)) + tree + (next-in-order (bt-left tree) order))) \ No newline at end of file