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."