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

[abaine at common-lisp.net]

Author: abaine
Date: Mon Jun 11 17:58:22 2007
New Revision: 6

Modified:
   trunk/funds/src/trees/avl-tree.lisp
Log:
Initial version of avl-tree.lisp

Modified: trunk/funds/src/trees/avl-tree.lisp
==============================================================================
--- trunk/funds/src/trees/avl-tree.lisp	(original)
+++ trunk/funds/src/trees/avl-tree.lisp	Mon Jun 11 17:58:22 2007
@@ -0,0 +1,85 @@
+
+(in-package :funds)
+
+(defstruct avl
+  height
+  key
+  value
+  left
+  right)
+
+(defun make-avl ()
+  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))))
+
+(defun left-insert (tree key value)
+  (let* ((left (avl-insert (avl-left tree)))
+	 (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) ) 
+			  tree 
+			  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 left-rotate (t0 a b)
+  (let ((c (avl-right b))
+	(new-a (make-avl :height (avl-height a)
+			 :key (avl-key a)
+			 :value (avl-value a)
+			 :left t0
+			 :right (avl-left b))))
+    (make-avl :height (parent-height (new-a) c)
+	      :key (avl-key b)
+	      :value (avl-value b)
+	      :left new-a
+	      :right c)))
+
+(defun imbalanced (left right)
+  (> (abs (- (height right) (height left)))
+     1))
+
+(defun left-heavy (tree)
+  (< (balance-factor tree) 0))
+
+(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))))
+
+(defun height (tree)
+  (if (null tree)
+      0
+      (avl-height tree)))