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

[abaine at common-lisp.net]

Author: abaine
Date: Tue Jul  3 16:18:23 2007
New Revision: 47

Modified:
   trunk/funds/src/trees/avl-tree.lisp
Log:
Refactored left and right-insert out of program.

Modified: trunk/funds/src/trees/avl-tree.lisp
==============================================================================
--- trunk/funds/src/trees/avl-tree.lisp	(original)
+++ trunk/funds/src/trees/avl-tree.lisp	Tue Jul  3 16:18:23 2007
@@ -3,7 +3,6 @@
 
 ;;;; Public Interface
 
-
 (defun empty-avl-tree ()
   "An empty AVL Tree."
   nil)
@@ -30,8 +29,12 @@
 						      :value value
 						      :left (avl-left tree)
 						      :right (avl-right tree)))
-	((funcall order key (avl-key tree)) (left-insert tree key value test order))
-	(t (right-insert tree key value test order))))
+; ((funcall order key (avl-key tree)) (left-insert tree key value test order))
+; (t (right-insert tree key value test order))
+	(t (funcall (if (funcall order key (avl-key tree))
+			#'left-insert
+			#'right-insert)
+		    tree key value test order))))
 
 (defun avl-find-value (tree key &key (order #'<) (test #'eql))
   "The value associated with the given key in the given AVL Tree.  The function
@@ -63,44 +66,90 @@
   "The AVL tree that results when the given key-value pair is inserted
 into left sub-tree of the given AVL tree.  Only non-empty avl-trees 
 should be supplied as arguments."
-  (let ((left (avl-insert (avl-left tree) key value :test test :order order))
-	(right (avl-right tree)))
-    (if (imbalanced left right)
-	(if (left-heavy left)
-	    (right-rotate right tree left)
-	    (right-rotate right
-			  tree 
-			  (left-rotate (avl-left left)
-				       left
-				       (avl-right left))))
-	(make-avl :ht (parent-height left right)
-		  :key (avl-key tree)
-		  :value (avl-value tree)
-		  :left left
-		  :right right))))
+;;   (let ((left (avl-insert (avl-left tree) key value :test test :order order))
+;; 	(right (avl-right tree)))
+;;     (if (imbalanced left right)
+;; 	(if (left-heavy left)
+;; 	    (right-rotate right tree left)
+;; 	    (right-rotate right
+;; 			  tree 
+;; 			  (left-rotate (avl-left left)
+;; 				       left
+;; 				       (avl-right left))))
+;; 	(make-avl :ht (parent-height left right)
+;; 		  :key (avl-key tree)
+;; 		  :value (avl-value tree)
+;; 		  :left left
+;; :right right)))
+  (side-insert tree key value test order :side :left))
 
 (defun right-insert (tree key value test order)
   "The AVL tree that results when the given key-value pair is inserted
 into the right sub-tree of the given AVL tree.  Only non-empty avl-trees
 should be supplied as the tree argument."
-  (let ((right (avl-insert (avl-right tree) key value :test test :order order))
-	(left (avl-left tree)))
-    (if (imbalanced left right)
-	(if (right-heavy right)
-	    (left-rotate left tree right)
-	    (left-rotate left
-			 tree
-			 (right-rotate (avl-right right)
-				       right
-				       (avl-left right))))
-	(make-avl :ht (parent-height left right)
-		  :key (avl-key tree)
-		  :value (avl-value tree)
-		  :left left
-		  :right right))))
+;;   (let ((right (avl-insert (avl-right tree) key value :test test :order order))
+;; 	(left (avl-left tree)))
+;;     (if (imbalanced left right)
+;; 	(if (right-heavy right)
+;; 	    (left-rotate left tree right)
+;; 	    (left-rotate left
+;; 			 tree
+;; 			 (right-rotate (avl-right right)
+;; 				       right
+;; 				       (avl-left right))))
+;; 	(make-avl :ht (parent-height left right)
+;; 		  :key (avl-key tree)
+;; 		  :value (avl-value tree)
+;; 		  :left left
+;; 		  :right right)))
+  (side-insert tree key value test order :side :right)
+)
+
+(defun side-insert (tree key value test order &key side)
+  (let ((out (avl-insert (funcall (side-accessor side) tree) key value :test test :order order))
+	(in (funcall (other-side-accessor side) tree)))
+    (if (balanced out in) 
+	(make-avl :ht (parent-height out in)
+				    :key (avl-key tree)
+				    :value (avl-value tree)
+				    side out
+				    (other-side side) in)
+	(funcall (other-side-rotator side) 
+		 in 
+		 tree
+		 (if (funcall (side-heavy-predicate side) out)
+		     out
+		     (funcall (side-rotator side)
+			      (funcall (side-accessor side) out)
+			      out
+			      (funcall (other-side-accessor side) out)))))))
+
+
 
 ;;;; Rotation Functions
 
+(defun left-p (side)
+  (eq side :left))
+
+(defun other-side (side)
+  (if (left-p side) :right :left))
+
+(defun side-accessor (side)
+  (if (left-p side) #'avl-left #'avl-right))
+
+(defun other-side-accessor (side)
+  (side-accessor (other-side side)))
+
+(defun side-rotator (side)
+  (if (left-p side) #'left-rotate #'right-rotate))
+
+(defun other-side-rotator (side)
+  (side-rotator (other-side side)))
+
+(defun side-heavy-predicate (side)
+  (if (left-p side) #'left-heavy #'right-heavy))
+
+
 (defun left-rotate (t0 a b)
   (rotate t0 a b :direction :left))
 
@@ -108,11 +157,10 @@
   (rotate t3 c b :direction :right))
 
 (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))
+  (let* ((outside-accessor (other-side-accessor direction))
+	 (inside-accessor (side-accessor direction))
+	 (inside-init-key direction)
+	 (outside-init-key (other-side direction))
 	 (new-outside (funcall outside-accessor outside))
 	 (new-inside (make-avl :ht (1- (avl-height root))
 			       :key (avl-key root)
@@ -127,6 +175,9 @@
 
 ;;;; AVL Tree utility functions
 
+(defun avl-balanced-p (tree)
+  (< -2 (balance-factor tree) 2))
+
 (defun imbalanced (left right)
   "Whether the heights of the given sub-trees differ,
 in their absolute values, by more than one."