[funds-cvs] r14 - trunk/funds/src/trees/tests

[abaine at common-lisp.net]

Author: abaine
Date: Fri Jun 15 13:57:14 2007
New Revision: 14

Modified:
   trunk/funds/src/trees/tests/avl-tree-test.lisp
Log:
Wrote unit tests for insert and empty

Modified: trunk/funds/src/trees/tests/avl-tree-test.lisp
==============================================================================
--- trunk/funds/src/trees/tests/avl-tree-test.lisp	(original)
+++ trunk/funds/src/trees/tests/avl-tree-test.lisp	Fri Jun 15 13:57:14 2007
@@ -4,29 +4,80 @@
 (defun random-tree ()
   (reduce #'(lambda (tr v)
 	    (avl-insert tr v v))
-	  (loop for i below 100 collect (random 10000))
+	  (loop for i below 20 collect (random 10))
 	  :initial-value (empty-avl-tree)))
 
-(define-test empty-avl-tree
-  (assert-true (avl-empty-p (empty-avl-tree)))
-  (assert-equal 0 (avl-height (empty-avl-tree))))
-
+(defmacro assert-avl-valid (tree)
+  `(progn
+    (assert-true (height-correct-p ,tree) ,tree)
+    (assert-true (balanced-p ,tree) ,tree)
+    (assert-true (ordered-p ,tree) ,tree)))
 
-(define-test avl-insert
-  (assert-true (balanced (random-tree))))
+(define-test test-avl-empty-p
+  (assert-true (avl-empty-p (empty-avl-tree)))
+  (assert-avl-valid (empty-avl-tree)))
 
-(defun balanced (tree)
+(define-test test-avl-insert
+  (let ((tree (random-tree)))
+    (assert-avl-valid tree)))
+
+(defun height-correct-p (tree)
+  "Whether (avl-height tree) returns the correct height of the given 
+AVL Tree.  The height is correct if (a) the tree is empty and zero
+is returned or (b) each of the following is true:
+    1.  the height of the left sub-tree is correct;
+    2.  the height of the right sub-tree is correct;
+    3.  the height of the given tree is 1 more than the greater
+        of the heights of the left and right sub-trees."
+  (if (avl-empty-p tree)
+      (zerop (avl-height tree))
+      (and (height-correct-p (avl-left tree))
+	   (height-correct-p (avl-right tree))
+	   (let* ((a (avl-height (avl-left tree)))
+		  (b (avl-height (avl-right tree)))
+		  (c (if (> a b) a b))) 
+	     (eql (1+ c) (avl-height tree))))))
+
+(defun balanced-p (tree)
+  "Whether the given AVL Tree is properly balanced.  To be balanced,
+the tree must be either (a) empty or (b) have left and right sub-trees
+that differ in height by no more than 1."
   (or (avl-empty-p tree)
-      (and (balanced (avl-left tree))
-	   (balanced (avl-right tree))
+      (and (balanced-p (avl-left tree))
+	   (balanced-p (avl-right tree))
 	   (< -2 (- (avl-height (avl-left tree))
 		    (avl-height (avl-right tree)))
 	      2))))
 
-
-(defun root-height-correct (tree)
-  (let* ((a (avl-height (avl-left tree)))
-	 (b (avl-height (avl-right tree)))
-	 (c (if (> a b) a b))) 
-    (eql (1+ c) (avl-height tree))))
-
+(defun ordered-p (tree &optional (less-than #'<))
+  "Whether this AVL tree is properly ordered.  To be ordered,
+the tree must be either (a) empty or (b) satisfy each of the following 
+requirements:
+
+    1.  the left sub-tree is properly ordered;
+    2.  the right sub-tree is properly ordered; 
+    3.  every key in the left sub-tree is less than
+        the root key; and
+    4.  every key in the right sub-tree is not less
+        than the root key."
+  (or (avl-empty-p tree)
+      (and (ordered-p (avl-left tree))
+	   (ordered-p (avl-right tree))
+	   (or (avl-empty-p (avl-left tree))
+	       (not (funcall less-than (avl-key tree)
+			     (greatest-key (avl-left tree)))))
+	   (or (avl-empty-p (avl-right tree))
+	       (not (funcall less-than (least-key (avl-right tree))
+			     (avl-key tree)))))))
+
+(defun least-key (tree)
+  "The least key in a properly ordered AVL tree."
+  (if (avl-empty-p (avl-left tree))
+      (avl-key tree)
+      (least-key (avl-left tree))))
+
+(defun greatest-key (tree)
+  "The greatest key in a properly ordered AVL tree."
+  (if (avl-empty-p (avl-right tree))
+      (avl-key tree)
+      (greatest-key (avl-right tree))))