[funds-cvs] r56 - trunk/funds/src/trees

[abaine at common-lisp.net]

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