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

[abaine at common-lisp.net]

Author: abaine
Date: Tue Jun 12 10:11:16 2007
New Revision: 7

Modified:
   trunk/funds/src/trees/avl-tree.lisp
Log:
avl insertion now seems to work.

Modified: trunk/funds/src/trees/avl-tree.lisp
==============================================================================
--- trunk/funds/src/trees/avl-tree.lisp	(original)
+++ trunk/funds/src/trees/avl-tree.lisp	Tue Jun 12 10:11:16 2007
@@ -8,60 +8,79 @@
   left
   right)
 
-(defun make-avl ()
+(defun make-avl-tree ()
   nil)
 
 (defun avl-insert (tree key value)
-  (cond ((null tree) (make-avl :height 1
-			       :key key
-			       :value value
-			       :left nil
-			       :right nil))
-	((< key (avl-key tree)) (left-insert tree))
-	(t (right-insert tree))))
+  (cond ((avl-empty tree) (make-avl :height 1
+				    :key key
+				    :value value
+				    :left nil
+				    :right nil))
+	((< key (avl-key tree)) (left-insert tree key value))
+	(t (right-insert tree key value))))
+
+(defun avl-empty (tree)
+  (null tree))
 
 (defun left-insert (tree key value)
-  (let* ((left (avl-insert (avl-left tree)))
-	 (right (avl-right tree)))
+  (let ((left (avl-insert (avl-left tree) key value))
+	(right (avl-right tree)))
     (if (imbalanced left right)
 	(if (left-heavy left)
 	    (right-rotate left tree right)
-	    (right-rotate (left-rotate left (avl-left left) ) 
+	    (right-rotate (left-rotate (avl-left left)
+				       left
+				       (avl-right left))
 			  tree 
-			  right)
-	    ())
+			  right))
 	(make-avl :height (parent-height left right)
 		  :key (avl-key tree)
 		  :value (avl-value tree)
 		  :left left
 		  :right right))))
 
-(defun right-rotate (b c t3)
-  (let ((a (avl-left b))
-	(new-c (make-avl :height (avl-height c); not sure if this needs to be recalculated
-			 :key (avl-key c)
-			 :value (avl-value c)
-			 :left (avl-right b)
-			 :right t3)))
-    (make-avl :height (parent-height a new-c)
-	      :key (avl-key b)
-	      :value (avl-value b)
-	      :left a
-	      :right new-c)))
+(defun right-insert (tree key value)
+  (let ((right (avl-insert (avl-right tree) key value))
+	(left (avl-left tree)))
+    (if (imbalanced left right)
+	(if (right-heavy right)
+	    (left-rotate left tree right)
+	    (left-rotate (right-rotate (avl-right right)
+				       right
+				       (avl-left right))))
+	(make-avl :height (parent-height left right)
+		  :key (avl-key tree)
+		  :value (avl-value tree)
+		  :left left
+		  :right right))))
 
 (defun left-rotate (t0 a b)
   (let ((c (avl-right b))
-	(new-a (make-avl :height (avl-height a)
+	(new-a (make-avl :height (1- (avl-height a)) ; re-calculate?
 			 :key (avl-key a)
 			 :value (avl-value a)
 			 :left t0
 			 :right (avl-left b))))
-    (make-avl :height (parent-height (new-a) c)
+    (make-avl :height (1+ (avl-height new-a))
 	      :key (avl-key b)
 	      :value (avl-value b)
 	      :left new-a
 	      :right c)))
 
+(defun right-rotate (b c t3)
+  (let ((a (avl-left b))
+	(new-c (make-avl :height (1- (avl-height c)); re-calculate?
+			 :key (avl-key c)
+			 :value (avl-value c)
+			 :left (avl-right b)
+			 :right t3)))
+    (make-avl :height (1+ (avl-height new-c)) ; re-calculate?
+	      :key (avl-key b)
+	      :value (avl-value b)
+	      :left a
+	      :right new-c)))
+
 (defun imbalanced (left right)
   (> (abs (- (height right) (height left)))
      1))
@@ -72,9 +91,6 @@
 (defun right-heavy (tree)
   (> (balance-factor tree) 0))
 
-(defun right-insert (tree key value)
-  ())
-
 (defun balance-factor (tree)
   (- (height (avl-right tree))
      (height (avl-left tree))))
@@ -83,3 +99,8 @@
   (if (null tree)
       0
       (avl-height tree)))
+
+(defun parent-height (left right)
+  (let ((a (height left))
+	(b (height right)))
+    (1+ (if (> a b) a b))))