tree-test.lisp

   1 (in-package :trees-tests)
   2
   3 (defconstant +max-upper-bound+ (expt 2 15))
   4
   5 (defvar *execution-trace*)
   6 (defvar *saved-trace*)
   7 (defvar *print-while-building* nil)
   8 (defvar *validate-while-building* nil)
   9 (defvar *building-uses-delete* nil)
  10 (defvar *let-pred-determine-equivalency* nil)
  11
  12 (defun make-integer-tree (tree-kind)
  13   ;; Use explicit lambdes to make SBCL emit calls to GENERIC assembly
  14   ;; procedures, rather than the full functions; the GENERIC versions
  15   ;; will be faster, as they contain early outs for fixnums.
  16   (trees:make-binary-tree tree-kind #'(lambda (x y)
  17                                          (< x y))
  18                            :key #'identity
  19                            :test (unless *let-pred-determine-equivalency*
  20                                    #'(lambda (x y) (= x y)))))
  21
  22 (defun make-bitset (upper-bound)
  23   (make-array upper-bound :element-type 'bit :initial-element 0))
  24
  25 (defun make-trace-buffer (&optional (size 400))
  26   (make-array size :element-type '(unsigned-byte 16)
  27               :fill-pointer 0
  28               :adjustable t))
  29
  30 (defun add-trace-action (insertp element)
  31   (vector-push-extend (dpb insertp (byte 1 15) element) *execution-trace*))
  32
  33 (defun insert-action-p (bits)
  34   (not (logbitp 15 bits)))
  35
  36 (defun action-element (bits)
  37   (ldb (byte 15 0) bits))
  38
  39 (defun test-with-randomly-built-tree (kind test &optional (size 200))
  40   (multiple-value-bind (tree bitvector count)
  41       (build-random-tree kind size :delete t)
  42     (declare (ignore count))
  43     (funcall test tree bitvector)))
  44
  45 (defun check-equivalency (tree bitvector)
  46   (declare (type simple-bit-vector bitvector))
  47   (loop
  48      for start = 0 then (1+ x)
  49      for x = (position 1 bitvector :start start)
  50      while x
  51      do (assert (trees:find x tree))
  52      finally (return t)))
  53
  54 (defun check-selection (tree bitvector)
  55   (declare (type simple-bit-vector bitvector))
  56   (unless (zerop (trees:size tree))
  57     (loop for start = 0 then (1+ x)
  58        for x = (position 1 bitvector :start start)
  59        for i from 0
  60        while x
  61        do (assert (= x (trees:select tree i)))
  62        finally (return t))))
  63
  64 (defun check-forward-position-t (tree bitvector)
  65   (declare (type simple-bit-vector bitvector))
  66   (loop for start = 0 then (1+ x)
  67      for x = (position 1 bitvector :start start)
  68      for i from 0
  69      while x
  70      do (assert (= i (trees:position x tree)))
  71      finally (return t)))
  72
  73 (defun check-forward-position-nil (tree bitvector)
  74   (declare (type simple-bit-vector bitvector))
  75   (loop for start = 0 then (1+ x)
  76      for x = (position 0 bitvector :start start)
  77      while x
  78      do (assert (eq (trees:position x tree) nil))
  79      finally (return t)))
  80
  81 (defun check-backward-position-t (tree bitvector)
  82   (declare (type simple-bit-vector bitvector))
  83   (loop for end = nil then x
  84      for x = (position 1 bitvector :from-end t :end end)
  85      for i downfrom (1- (trees:size tree))
  86      while x
  87      do (assert (= i (trees:position x tree)))
  88      finally (return t)))
  89
  90 (defun check-backward-position-nil (tree bitvector)
  91   (declare (type simple-bit-vector bitvector))
  92   (loop for end = nil then x
  93      for x = (position 0 bitvector :from-end t :end end)
  94      while x
  95      do (assert (eq (trees:position x tree :from-end t) nil))
  96      finally (return t)))
  97
  98 (defun check-forward-iteration (tree bitvector)
  99   (declare (type simple-bit-vector bitvector))
 100   (loop with iter = (trees::make-iterator tree :forwardp t)
 101      for start = 0 then (1+ x)
 102      for x = (position 1 bitvector :start start)
 103      for z = (funcall iter)
 104      while x
 105      do (assert (= (trees::datum z) x))
 106      finally (return t)))
 107
 108 (defun check-backward-iteration (tree bitvector)
 109   (declare (type simple-bit-vector bitvector))
 110   (loop with iter = (trees::make-iterator tree :forwardp nil)
 111      for end = nil then y
 112      for y = (position 1 bitvector :from-end t :end end)
 113      for w = (funcall iter)
 114      while y
 115      do (assert (= y (trees::datum w)))
 116      finally (return t)))
 117
 118 (defun check-dotree (tree bitvector)
 119   (declare (type simple-bit-vector bitvector))
 120   (let ((new (bit-xor bitvector bitvector)))
 121     (trees:dotree (x tree)
 122       (setf (aref new x) 1))
 123     (assert (not (mismatch new bitvector)))
 124     t))
 125
 126 (defun check-reduce (tree bitvector)
 127   (declare (type simple-bit-vector bitvector))
 128   (loop with tree-sum = (trees:reduce tree #'+)
 129      for start = 0 then (1+ x)
 130      for x = (position 1 bitvector :start start)
 131      while x
 132      sum x into sum
 133      finally
 134        (assert (= tree-sum sum))
 135        (return t)))
 136
 137 (defun check-reduce-from-end (tree bitvector)
 138   (declare (type simple-bit-vector bitvector))
 139   (loop with tree-diff = (trees:reduce tree #'- :initial-value 0 :from-end t)
 140      for start = 0 then (1+ x)
 141      for x = (position 1 bitvector :start start)
 142      while x
 143      collect x into list
 144      finally
 145        (assert (= tree-diff (reduce #'- list :initial-value 0 :from-end t)))
 146        (return t)))
 147
 148 (defparameter *tree-checkers*
 149   (list #'check-equivalency
 150         #'check-selection
 151         #'check-forward-position-t
 152         #'check-forward-position-nil
 153         #'check-backward-position-t
 154         #'check-backward-position-nil
 155         #'check-forward-iteration
 156         #'check-backward-iteration
 157         #'check-dotree
 158         #'check-reduce
 159         #'check-reduce-from-end))
 160
 161 (defun build-random-tree (tree-type upper-bound
 162                           &key (delete *building-uses-delete*)
 163                           trace)
 164   (when (> upper-bound +max-upper-bound+)
 165     (error "upper bound ~A is too large" upper-bound))
 166   (let ((*execution-trace* (when trace (make-trace-buffer))))
 167     (loop with tree = (make-integer-tree tree-type)
 168        with bitvector of-type simple-bit-vector = (make-bitset upper-bound)
 169        with size = 0
 170        with insert-count = 0
 171        with delete-count = 0
 172        with insert-limit = (truncate upper-bound 2)
 173        with delete-limit = (if delete (truncate upper-bound 2) 0)
 174        with validatep = *validate-while-building*
 175        until (and (>= insert-count insert-limit)
 176                   (>= delete-count delete-limit))
 177        do (let ((element (random upper-bound))
 178                 (which (if delete (random 2) 0)))
 179             (case which
 180               (0                        ; insert
 181                (multiple-value-bind (key insertedp) (trees:insert element tree)
 182                  (cond
 183                    (insertedp
 184                     (when trace (add-trace-action which element))
 185                     (assert (= 0 (aref bitvector element)))
 186                     (setf (aref bitvector element) 1)
 187                     (incf size)
 188                     (incf insert-count))
 189                    (t
 190                     (assert (= 1 (aref bitvector element)))))
 191                  (assert (= key element))
 192                  (assert (trees:find element tree))))
 193               (1                        ; delete
 194                (multiple-value-bind (data successp) (trees:delete element tree)
 195                  (cond
 196                    (successp
 197                     (when trace (add-trace-action which element))
 198                     (assert (= element data))
 199                     (assert (= (aref bitvector element) 1))
 200                     (setf (aref bitvector element) 0)
 201                     (decf size)
 202                     (incf delete-count))
 203                    (t
 204                     (assert (= (aref bitvector element) 0))))
 205                  (assert (not (trees:find element tree))))))
 206             (when validatep
 207               (assert (validate-tree tree)))
 208             (assert (= size (trees:size tree))))
 209        finally (check-equivalency tree bitvector)
 210          (validate-tree tree)
 211          (return (values tree bitvector (+ insert-count delete-count))))))
 212
 213 (defun build-tree-from-trace (tree-type trace maker insert delete printer)
 214   (loop with tree = (funcall maker tree-type)
 215      for action across trace
 216      for i from 0
 217      do (funcall (if (insert-action-p action) insert delete)
 218                  (action-element action) tree)
 219        (when *print-while-building*
 220          (format *trace-output* "step ~D: ~A ~D~%" i
 221                  (if (insert-action-p action) "insert" "delete")
 222                  (action-element action))
 223          (funcall printer tree *trace-output*))
 224      finally (return tree)))
 225
 226 (defun build-new-tree-from-trace (tree-type trace)
 227   (build-tree-from-trace tree-type trace
 228                          #'make-integer-tree
 229                          #'trees:insert
 230                          #'trees:delete
 231                          #'trees::pprint-tree))
 232
 233 (defun build-and-compare (tree-type deletionp)
 234   (handler-bind ((error #'(lambda (c)
 235                             (assert *execution-trace*)
 236                             (setf *saved-trace* *execution-trace*)
 237                             (let ((*print-while-building* t))
 238                               (build-new-tree-from-trace tree-type *execution-trace*))
 239                             (continue c))))
 240     (build-random-tree tree-type 200 :delete deletionp :trace t)))
 241
 242 (defun build-and-run-checkers (tree-kind)
 243   (flet ((build-and-run (x)
 244            (let ((*let-pred-determine-equivalency* x))
 245              (multiple-value-bind (tree bitvector count)
 246                  (build-random-tree tree-kind 200 :delete t)
 247                (declare (ignore count))
 248                (dolist (test *tree-checkers* t)
 249                  (funcall (the function test) tree bitvector))))))
 250     (handler-case
 251         (loop repeat 1000 always (and (build-and-run t) (build-and-run nil)))
 252       (error (c) c)
 253       (:no-error (value) value))))
 254
 255 (rtest:deftest :normal (build-and-run-checkers :normal) t)
 256
 257 (rtest:deftest :avl (build-and-run-checkers :avl) t)
 258
 259 (rtest:deftest :red-black (build-and-run-checkers :red-black) t)
 260
 261 (rtest:deftest :aa (build-and-run-checkers :aa) t)