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   (loop
  47      for start = 0 then (1+ x)
  48      for x = (position 1 bitvector :start start)
  49      while x
  50      do (assert (trees:find x tree))
  51      finally (return t)))
  52
  53 (defun check-selection (tree bitvector)
  54   (unless (zerop (trees:size tree))
  55     (loop for start = 0 then (1+ x)
  56        for x = (position 1 bitvector :start start)
  57        for i from 0
  58        while x
  59        do (assert (= x (trees:select tree i)))
  60        finally (return t))))
  61
  62 (defun check-forward-position-t (tree bitvector)
  63   (loop for start = 0 then (1+ x)
  64      for x = (position 1 bitvector :start start)
  65      for i from 0
  66      while x
  67      do (assert (= i (trees:position x tree)))
  68      finally (return t)))
  69
  70 (defun check-forward-position-nil (tree bitvector)
  71   (loop for start = 0 then (1+ x)
  72      for x = (position 0 bitvector :start start)
  73      while x
  74      do (assert (eq (trees:position x tree) nil))
  75      finally (return t)))
  76
  77 (defun check-backward-position-t (tree bitvector)
  78   (loop for end = nil then x
  79      for x = (position 1 bitvector :from-end t :end end)
  80      for i downfrom (1- (trees:size tree))
  81      while x
  82      do (assert (= i (trees:position x tree)))
  83      finally (return t)))
  84
  85 (defun check-backward-position-nil (tree bitvector)
  86   (loop for end = nil then x
  87      for x = (position 0 bitvector :from-end t :end end)
  88      while x
  89      do (assert (eq (trees:position x tree :from-end t) nil))
  90      finally (return t)))
  91
  92 (defun check-forward-iteration (tree bitvector)
  93   (loop with iter = (trees::make-iterator tree :forwardp t)
  94      for start = 0 then (1+ x)
  95      for x = (position 1 bitvector :start start)
  96      for z = (funcall iter)
  97      while x
  98      do (assert (= (trees::datum z) x))
  99      finally (return t)))
 100
 101 (defun check-backward-iteration (tree bitvector)
 102   (loop with iter = (trees::make-iterator tree :forwardp nil)
 103      for end = nil then y
 104      for y = (position 1 bitvector :from-end t :end end)
 105      for w = (funcall iter)
 106      while y
 107      do (assert (= y (trees::datum w)))
 108      finally (return t)))
 109
 110 (defun check-dotree (tree bitvector)
 111   (let ((new (bit-xor bitvector bitvector)))
 112     (trees:dotree (x tree)
 113       (setf (aref new x) 1))
 114     (assert (not (mismatch new bitvector)))
 115     t))
 116
 117 (defun check-reduce (tree bitvector)
 118   (loop with tree-sum = (trees:reduce tree #'+)
 119      for start = 0 then (1+ x)
 120      for x = (position 1 bitvector :start start)
 121      while x
 122      sum x into sum
 123      finally
 124        (assert (= tree-sum sum))
 125        (return t)))
 126
 127 (defun check-reduce-from-end (tree bitvector)
 128   (loop with tree-diff = (trees:reduce tree #'- :initial-value 0 :from-end t)
 129      for start = 0 then (1+ x)
 130      for x = (position 1 bitvector :start start)
 131      while x
 132      collect x into list
 133      finally
 134        (assert (= tree-diff (reduce #'- list :initial-value 0 :from-end t)))
 135        (return t)))
 136
 137 (defparameter *tree-checkers*
 138   (list #'check-equivalency
 139         #'check-selection
 140         #'check-forward-position-t
 141         #'check-forward-position-nil
 142         #'check-backward-position-t
 143         #'check-backward-position-nil
 144         #'check-forward-iteration
 145         #'check-backward-iteration
 146         #'check-dotree
 147         #'check-reduce
 148         #'check-reduce-from-end))
 149
 150 (defun build-random-tree (tree-type upper-bound
 151                           &key (delete *building-uses-delete*)
 152                           trace)
 153   (when (> upper-bound +max-upper-bound+)
 154     (error "upper bound ~A is too large" upper-bound))
 155   (let ((*execution-trace* (when trace (make-trace-buffer))))
 156     (loop with tree = (make-integer-tree tree-type)
 157        with bitvector of-type simple-bit-vector = (make-bitset upper-bound)
 158        with size = 0
 159        with insert-count = 0
 160        with delete-count = 0
 161        with insert-limit = (truncate upper-bound 2)
 162        with delete-limit = (if delete (truncate upper-bound 2) 0)
 163        with validatep = *validate-while-building*
 164        until (and (>= insert-count insert-limit)
 165                   (>= delete-count delete-limit))
 166        do (let ((element (random upper-bound))
 167                 (which (if delete (random 2) 0)))
 168             (case which
 169               (0                        ; insert
 170                (multiple-value-bind (key insertedp) (trees:insert element tree)
 171                  (cond
 172                    (insertedp
 173                     (when trace (add-trace-action which element))
 174                     (assert (= 0 (aref bitvector element)))
 175                     (setf (aref bitvector element) 1)
 176                     (incf size)
 177                     (incf insert-count))
 178                    (t
 179                     (assert (= 1 (aref bitvector element)))))
 180                  (assert (= key element))
 181                  (assert (trees:find element tree))))
 182               (1                        ; delete
 183                (multiple-value-bind (data successp) (trees:delete element tree)
 184                  (cond
 185                    (successp
 186                     (when trace (add-trace-action which element))
 187                     (assert (= element data))
 188                     (assert (= (aref bitvector element) 1))
 189                     (setf (aref bitvector element) 0)
 190                     (decf size)
 191                     (incf delete-count))
 192                    (t
 193                     (assert (= (aref bitvector element) 0))))
 194                  (assert (not (trees:find element tree))))))
 195             (when validatep
 196               (assert (validate-tree tree)))
 197             (assert (= size (trees:size tree))))
 198        finally (check-equivalency tree bitvector)
 199          (validate-tree tree)
 200          (return (values tree bitvector (+ insert-count delete-count))))))
 201
 202 (defun build-tree-from-trace (tree-type trace maker insert delete printer)
 203   (loop with tree = (funcall maker tree-type)
 204      for action across trace
 205      for i from 0
 206      do (funcall (if (insert-action-p action) insert delete)
 207                  (action-element action) tree)
 208        (when *print-while-building*
 209          (format *trace-output* "step ~D: ~A ~D~%" i
 210                  (if (insert-action-p action) "insert" "delete")
 211                  (action-element action))
 212          (funcall printer tree *trace-output*))
 213      finally (return tree)))
 214
 215 (defun build-new-tree-from-trace (tree-type trace)
 216   (build-tree-from-trace tree-type trace
 217                          #'make-integer-tree
 218                          #'trees:insert
 219                          #'trees:delete
 220                          #'trees::pprint-tree))
 221
 222 (defun build-and-compare (tree-type deletionp)
 223   (handler-bind ((error #'(lambda (c)
 224                             (assert *execution-trace*)
 225                             (setf *saved-trace* *execution-trace*)
 226                             (let ((*print-while-building* t))
 227                               (build-new-tree-from-trace tree-type *execution-trace*))
 228                             (continue c))))
 229     (build-random-tree tree-type 200 :delete deletionp :trace t)))
 230
 231 (defun build-and-run-checkers (tree-kind)
 232   (flet ((build-and-run (x)
 233            (let ((*let-pred-determine-equivalency* x))
 234              (multiple-value-bind (tree bitvector count)
 235                  (build-random-tree tree-kind 200 :delete t)
 236                (declare (ignore count))
 237                (dolist (test *tree-checkers* t)
 238                  (funcall (the function test) tree bitvector))))))
 239     (handler-case
 240         (loop repeat 1000 always (and (build-and-run t) (build-and-run nil)))
 241       (error (c) c)
 242       (:no-error (value) value))))
 243
 244 (rtest:deftest :normal (build-and-run-checkers :normal) t)
 245
 246 (rtest:deftest :avl (build-and-run-checkers :avl) t)
 247
 248 (rtest:deftest :red-black (build-and-run-checkers :red-black) t)
 249
 250 (rtest:deftest :aa (build-and-run-checkers :aa) t)