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

[abaine at common-lisp.net]

Author: abaine
Date: Thu Aug  2 15:40:23 2007
New Revision: 111

Modified:
   trunk/funds/src/trees/avl.lisp
Log:
Totally changed balance function
so that it doesn't require the creation of intermediate nodes.

Modified: trunk/funds/src/trees/avl.lisp
==============================================================================
--- trunk/funds/src/trees/avl.lisp	(original)
+++ trunk/funds/src/trees/avl.lisp	Thu Aug  2 15:40:23 2007
@@ -33,24 +33,26 @@
 (defun balanced-p (t1 t2)
   (< -2 (height-difference t1 t2) 2))
 
-(defun balance (inside root outside &key heavy-side)
-  (let ((other-side (other-side heavy-side)))
-    (if (balanced-p inside outside) 
-	(stitch-avl-tree :root root
-			  heavy-side outside
-			  other-side inside)
-	(rotate inside root
-		(if (heavier-p outside :side other-side)
-		    (rotate (tree-child outside :side heavy-side)
-			    outside
-			    (tree-child outside :side other-side)
-			    :side heavy-side)
-		    outside)
-		:side other-side))))
+(defun balance (key value left right)
+  (let ((height-difference (- (tree-height left) (tree-height right))))
+    (if (< -2 height-difference 2)
+	(stitch-avl-tree :key key :value value :left left :right right)
+	(let* ((heavy-side (if (plusp height-difference) :left :right))
+	       (other-side (other-side heavy-side))
+	       (inside (if (left-p heavy-side) right left))
+	       (outside (if (left-p heavy-side) left right)))
+	  (rotate inside key value
+		  (if (heavier-p outside :side other-side)
+		      (rotate (tree-child outside :side heavy-side)
+			      (bt-key outside) (bt-value outside)
+			      (tree-child outside :side other-side)
+			      :side heavy-side)
+		      outside)
+		  :side other-side)))))
 
-(defun rotate (inside root outside &key side)
+(defun rotate (inside root-key root-value outside &key side)
   (let* ((t1 (tree-child outside :side side))
-	 (new-inside (stitch-avl-tree :root root
+	 (new-inside (stitch-avl-tree :key root-key :value root-value
 				       side inside
 				       (other-side side) t1))
 	 (new-outside (tree-child outside :side (other-side side))))