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

[abaine at common-lisp.net]

Author: abaine
Date: Mon Jul  2 21:02:07 2007
New Revision: 45

Modified:
   trunk/funds/src/trees/avl-tree.lisp
Log:
Began to refactor side-symmetric code left-rotate and right-rotate.

Modified: trunk/funds/src/trees/avl-tree.lisp
==============================================================================
--- trunk/funds/src/trees/avl-tree.lisp	(original)
+++ trunk/funds/src/trees/avl-tree.lisp	Mon Jul  2 21:02:07 2007
@@ -67,12 +67,12 @@
 	(right (avl-right tree)))
     (if (imbalanced left right)
 	(if (left-heavy left)
-	    (right-rotate left tree right)
-	    (right-rotate (left-rotate (avl-left left)
-				       left
-				       (avl-right left))
+	    (right-rotate right tree left)
+	    (right-rotate right
 			  tree 
-			  right))
+			  (left-rotate (avl-left left)
+				       left
+				       (avl-right left))))
 	(make-avl :ht (parent-height left right)
 		  :key (avl-key tree)
 		  :value (avl-value tree)
@@ -90,9 +90,9 @@
 	    (left-rotate left tree right)
 	    (left-rotate left
 			 tree
-			 (right-rotate (avl-left right)
+			 (right-rotate (avl-right right)
 				       right
-				       (avl-right right))))
+				       (avl-left right))))
 	(make-avl :ht (parent-height left right)
 		  :key (avl-key tree)
 		  :value (avl-value tree)
@@ -114,7 +114,7 @@
 	      :left new-a
 	      :right c)))
 
-(defun right-rotate (b c t3)
+(defun right-rotate (t3 c b)
   (let ((a (avl-left b))
 	(new-c (make-avl :ht (1- (avl-ht c)); re-calculate?
 			 :key (avl-key c)
@@ -127,6 +127,32 @@
 	      :left a
 	      :right new-c)))
 
+(defun rotate (inside root outside &key direction)
+  (let* ((left-p (eq direction :left))
+	 (outside-accessor (if left-p
+			       #'avl-right
+			       #'avl-left))
+	 (inside-accessor (if left-p
+			      #'avl-left
+			      #'avl-right))
+	 (inside-init-key (if left-p
+			      :left
+			      :right))
+	 (outside-init-key (if left-p
+			       :right
+			       :left))
+	 (new-outside (funcall outside-accessor outside))
+	 (new-inside (make-avl :ht (1- (avl-height root))
+			       :key (avl-key root)
+			       :value (avl-value root)
+			       inside-init-key inside
+			       outside-init-key (funcall inside-accessor outside))))
+    (make-avl :ht (1+ (avl-height new-outside))
+	      :key (avl-key outside)
+	      :value (avl-value outside)
+	      inside-init-key new-inside
+	      outside-init-key new-outside)))
+
 ;;;; AVL Tree utility functions
 
 (defun imbalanced (left right)