diff --git a/tests/avltree.pure.lisp b/tests/avltree.pure.lisp index bd60df591..d75d81f14 100644 --- a/tests/avltree.pure.lisp +++ b/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-find-inexact (n-nodes n-iterations) - (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)))))))))) +(defun test-avlfind-inexact (n-nodes n-iterations) + (bbtree-test:test-find-inexact-macro avl-insert avl-find<= avl-find>= avlnode-key)) -(test-util:with-test (:name :find-inexact) - (loop for n-nodes from 1 to 20 - do (test-find-inexact n-nodes - (case n-nodes - (1 1) - (2 4) - (3 10) - (t 100))))) +(test-util:with-test (:name :avl-find-inexact) + (bbtree-test:exercise-find-inexact 'test-avlfind-inexact)) diff --git a/tests/bbtree-test-util.lisp b/tests/bbtree-test-util.lisp new file mode 100644 index 000000000..2c60e8fce --- /dev/null +++ b/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))))) + diff --git a/tests/input-manifest.lisp-expr b/tests/input-manifest.lisp-expr index 58920b552..86dda2b09 100644 --- a/tests/input-manifest.lisp-expr +++ b/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") diff --git a/tests/redblack.pure.lisp b/tests/redblack.pure.lisp index 11a979f2b..f5a4f2c1d 100644 --- a/tests/redblack.pure.lisp +++ b/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))