Improve and fix BBtree tests

Don't use 0 as a key

tests/avltree.pure.lisp

@@ -1,3 +1,4 @@
+(load "bbtree-test-util.lisp")
 (use-package "SB-INT")
 
 #-sb-thread (invoke-restart 'run-tests::skip-file) ;; some of the symbols below disappear
@@ -100,57 +101,8 @@ node [shape=record];~%")
   (random-operations 10 10 nil)
   (random-operations 10 200 nil))
 
-;; TOD: perform this test on the red-black trees as well.
+(defun test-avlfind-inexact (n-nodes n-iterations)
-(defun test-find-inexact (n-nodes n-iterations)
+  (bbtree-test:test-find-inexact-macro avl-insert avl-find<= avl-find>= avlnode-key))
-  (let (integers)
-    ;; Generate N random integers
-    (dotimes (i n-nodes)
-      (loop
-        (let ((val (random 1000)))
-          (unless (member val integers)
-            (push val integers)
-            (return)))))
-    (setq integers (coerce integers 'vector))
-    (dotimes (i n-iterations)
-      ;; Try many different shuffles of the insertion order because each
-      ;; potentially yields a different tree.
-      (test-util:shuffle integers)
-      ;; Convert a tree
-      (let ((tree nil))
-        (dotimes (i (length integers))
-          (setq tree (avl-insert tree (svref integers i) (svref integers i))))
-        (setq integers (sort integers #'<))
-        (dotimes (i (length integers))
-          (let ((this (svref integers i))
-                (pred (if (> i 0) (svref integers (1- i))))
-                (succ (if (< i (1- (length integers))) (svref integers (1+ i)))))
-            ;; THIS should be found exactly
-            (let ((answer (avl-find<= this tree)))
-              (assert (eql (avlnode-key answer) this)))
-            (let ((answer (avl-find>= this tree)))
-              (assert (eql (avlnode-key answer) this)))
-            ;; find this node by a smaller key using FIND>=
-            (unless (eql pred (1- this))
-              (assert (eql (avlnode-key (avl-find>= (1- this) tree)) this)))
-            ;; find this node by a larger key using FIND<=
-            (unless (eql succ (1+ this))
-              (assert (eql (avlnode-key (avl-find<= (1+ this) tree)) this)))
-            ;; check the boundary case of FIND<= and/or find the predecessor
-            (let ((answer (avl-find<= (1- this) tree)))
-              (if pred
-                  (assert (eql (avlnode-key answer) pred))
-                  (assert (not answer))))
-            ;; check the boundary case of FIND>= and/or find the successor
-            (let ((answer (avl-find>= (1+ this) tree)))
-              (if succ
-                  (assert (eql (avlnode-key answer) succ))
-                  (assert (not answer))))))))))
 
-(test-util:with-test (:name :find-inexact)
+(test-util:with-test (:name :avl-find-inexact)
-  (loop for n-nodes from 1 to 20
+  (bbtree-test:exercise-find-inexact 'test-avlfind-inexact))
-        do (test-find-inexact n-nodes
-                              (case n-nodes
-                                (1 1)
-                                (2 4)
-                                (3 10)
-                                (t 100)))))

tests/bbtree-test-util.lisp

@@ -0,0 +1,62 @@
+
+(defpackage "BBTREE-TEST"
+  (:use :cl)
+  (:export #:test-find-inexact-macro
+           #:exercise-find-inexact))
+
+;;;; Tests of two different kinds of balanced binary trees
+
+(defmacro bbtree-test:test-find-inexact-macro (insertion-fun find<=-fun find>=-fun node-key)
+  `(let (integers)
+     ;; Generate N random integers
+     (dotimes (i n-nodes)
+       (loop
+         (let ((val (+ 5 (random 1000))))
+           (unless (member val integers)
+             (push val integers)
+             (return)))))
+     (setq integers (coerce integers 'vector))
+     (dotimes (i n-iterations)
+       ;; Try many different shuffles of the insertion order because each
+       ;; potentially yields a different tree.
+       (test-util:shuffle integers)
+       ;; Convert a tree
+       (let ((tree nil))
+         (dotimes (i (length integers))
+           (setq tree (,insertion-fun tree (svref integers i) (svref integers i))))
+         (setq integers (sort integers #'<))
+         (dotimes (i (length integers))
+           (let ((this (svref integers i))
+                 (pred (if (> i 0) (svref integers (1- i))))
+                 (succ (if (< i (1- (length integers))) (svref integers (1+ i)))))
+             ;; THIS should be found exactly
+             (let ((answer (,find<=-fun this tree)))
+               (assert (eql (,node-key answer) this)))
+             (let ((answer (,find>=-fun this tree)))
+               (assert (eql (,node-key answer) this)))
+             ;; find this node by a smaller key using FIND>=
+             (unless (eql pred (1- this))
+               (assert (eql (,node-key (,find>=-fun (1- this) tree)) this)))
+             ;; find this node by a larger key using FIND<=
+             (unless (eql succ (1+ this))
+               (assert (eql (,node-key (,find<=-fun (1+ this) tree)) this)))
+             ;; check the boundary case of FIND<= and/or find the predecessor
+             (let ((answer (,find<=-fun (1- this) tree)))
+               (if pred
+                   (assert (eql (,node-key answer) pred))
+                   (assert (not answer))))
+             ;; check the boundary case of FIND>= and/or find the successor
+             (let ((answer (,find>=-fun (1+ this) tree)))
+               (if succ
+                   (assert (eql (,node-key answer) succ))
+                   (assert (not answer))))))))))
+
+(defun bbtree-test:exercise-find-inexact (fun)
+  (loop for n-nodes from 1 to 20
+        do (funcall fun  n-nodes
+                    (case n-nodes
+                      (1 1)
+                      (2 4)
+                      (3 10)
+                      (t 100)))))
+

tests/input-manifest.lisp-expr

@@ -1,6 +1,7 @@
 (("aprof.impure.lisp"
   "src/code/aprof.lisp"
   "src/code/shaketree.lisp")
+ ("avltree.pure.lisp" "bbtree-test-util.lisp")
  ("bit-vector.impure.lisp" "contrib/sb-posix.fasl")
  ("case.pure.lisp" "tests/case-test.lisp")
  ("chill.test.sh"
@@ -53,6 +54,7 @@
  ("octets.pure.lisp"
   "tests/data/compile-file-pos.lisp"
   "tests/data/compile-file-pos-utf16be.lisp")
+ ("redblack.pure.lisp" "bbtree-test-util.lisp")
  ("run-program.impure.lisp" "contrib/sb-posix.fasl")
  ("signals.impure.lisp" "contrib/sb-posix.fasl")
  ("stream.impure.lisp" "contrib/sb-posix.fasl")

tests/redblack.pure.lisp

@@ -6,6 +6,7 @@
                     color-of left right
                     node-key node-value data
                     find= find<=))
+(load "bbtree-test-util.lisp")
 
 (defun verify-invariants (root print)
   (unless root
@@ -211,3 +212,10 @@
   (dotimes (i n-items)
     (setq tree (redblack:insert tree i i)))
   tree)
+
+(defun test-rb-find-inexact (n-nodes n-iterations)
+  (bbtree-test:test-find-inexact-macro redblack:insert
+                                       find<= redblack:find>= node-key))
+
+(test-util:with-test (:name :rb-find-inexact)
+  (bbtree-test:exercise-find-inexact 'test-rb-find-inexact))