[funds-cvs] r36 - trunk/funds/tests/trees

[abaine at common-lisp.net]

Author: abaine
Date: Wed Jun 20 18:28:06 2007
New Revision: 36

Modified:
   trunk/funds/tests/trees/avl-tree-test.lisp
Log:
Modified tests to include keyword arguments to avl-insert.

Modified: trunk/funds/tests/trees/avl-tree-test.lisp
==============================================================================
--- trunk/funds/tests/trees/avl-tree-test.lisp	(original)
+++ trunk/funds/tests/trees/avl-tree-test.lisp	Wed Jun 20 18:28:06 2007
@@ -1,17 +1,19 @@
 
 (in-package :funds.tests.trees)
 
-(defun random-tree ()
-  (reduce #'(lambda (tr v)
-	    (avl-insert tr v v))
-	  (loop for i below 20 collect (random 10))
-	  :initial-value (empty-avl-tree)))
+(defun random-tree (&key (test #'eql) (order #'<))
+  (print (reduce #'(lambda (tr v)
+	    (avl-insert  tr v v :test test :order order))
+	  (loop for i below 40 collect (random 20))
+	  :initial-value (empty-avl-tree))))
 
-(defmacro assert-avl-valid (tree)
+(defconstant +never-equal+ #'(lambda (a b) (declare (ignore a b)) nil))
+
+(defmacro assert-avl-valid (tree &key (order #'<))
   `(progn
     (assert-true (height-correct-p ,tree) ,tree)
     (assert-true (balanced-p ,tree) ,tree)
-    (assert-true (ordered-p ,tree) ,tree)))
+    (assert-true (ordered-p ,tree :order ,order) ,tree)))
 
 (define-test test-avl-empty-p
   (assert-true (avl-empty-p (empty-avl-tree)))
@@ -49,7 +51,7 @@
 		    (avl-height (avl-right tree)))
 	      2))))
 
-(defun ordered-p (tree &optional (less-than #'<))
+(defun ordered-p (tree &key (order #'<))
   "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:
@@ -64,10 +66,10 @@
       (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)
+	       (not (funcall order (avl-key tree)
 			     (greatest-key (avl-left tree)))))
 	   (or (avl-empty-p (avl-right tree))
-	       (not (funcall less-than (least-key (avl-right tree))
+	       (not (funcall order (least-key (avl-right tree))
 			     (avl-key tree)))))))
 
 (defun least-key (tree)