tests/redblack.pure.lisp

   1 ;;;; Tests
   2
   3 (let ((*evaluator-mode* :compile)) (load "../src/code/redblack.lisp"))
   4
   5 (add-package-local-nickname "REDBLACK" "SB-RBTREE.MAP")
   6 (use-package 'sb-int)
   7 (import 'sb-rbtree::(red black))
   8 (import 'redblack::(redp blackp
   9                     color-of left right
  10                     node-key node-value data
  11                     find= find<=))
  12 (load "bbtree-test-util.lisp")
  13
  14 (defmacro define-verifier (name package
  15                            key-decoder sentinel-min sentinel-max)
  16 `(defun ,name (root print)
  17   (unless root
  18      (return-from ,name))
  19   ;; Pick new names or else: "Lock on package SB-RBTREE.MAP violated when
  20   ;; binding NODE-KEY as a local function while in package TEST.." etc
  21   (flet ((key (x) (,key-decoder (,(intern "NODE-KEY" package) x)))
  22          (*left (x) (,(intern "LEFT" package) x))
  23          (*right (x) (,(intern "RIGHT" package) x))
  24          (*redp (x) (,(intern "REDP" package) x))
  25          (*blackp (x) (,(intern "BLACKP" package) x))
  26          (*color-of (x) (,(intern "COLOR-OF" package) x)))
  27   (declare (inline node-key left right redp blackp color-of))
  28   ;; Binary search tree invariant
  29   (named-let recurse ((node root) (min ,sentinel-min) (max ,sentinel-max))
  30     (assert (< min (key node) max))
  31     ;; every descendant to the left has a key strictly less than this key
  32     (awhen (*left node) (recurse it min (key node)))
  33     ;; every descendant to the right has a key strictly more than this key
  34     (awhen (*right node) (recurse it (key node) max)))
  35   ;; Red/black tree invariants
  36   (assert (eq (*color-of root) 'black))
  37   (let ((h (make-hash-table :test #'eq))
  38         (count-red 0)
  39         (count-black 0)
  40         (count-nil 0))
  41     (setf (gethash nil h) 0)
  42     (labels ((black-height (node)
  43                (or (gethash node h)
  44                    (setf (gethash node h)
  45                          (let ((l (black-height (*left node)))
  46                                (r (black-height (*right node))))
  47                            (assert (= l r))
  48                            (if (eq (*color-of node) 'black) (1+ l) l))))))
  49       ;; Child colors and black height
  50       (named-let recurse ((node root))
  51         (ecase (*color-of node)
  52           (red (incf count-red))
  53           (black (incf count-black)))
  54         ;; If a node is red then both its children are black
  55         (when (*redp node)
  56           (awhen (*left node)  (assert (*blackp it)))
  57           (awhen (*right node) (assert (*blackp it))))
  58         (acond ((*left node) (recurse it)) (t (incf count-nil)))
  59         (acond ((*right node) (recurse it)) (t (incf count-nil))))
  60       (when print
  61         (format t "red=~3d black=~3d nil=~3d black-height = ~3d~%"
  62                 count-red count-black count-nil
  63                 (black-height root))))))
  64 ))
  65 (define-verifier verify-invariants "SB-RBTREE.MAP"
  66    identity most-negative-fixnum most-positive-fixnum)
  67 (define-verifier verify-invariants-word "SB-RBTREE.WORD"
  68    sb-kernel:get-lisp-obj-address 0 sb-ext:most-positive-word)
  69 (compile 'verify-invariants)
  70 (compile 'verify-invariants-word)
  71
  72 (defun random-integer-seq (n &aux seq)
  73   (let ((a (make-array n :fill-pointer n)))
  74     (dotimes (i n) (setf (aref a i) i))
  75     (dotimes (i n seq)
  76       (let* ((random-index (random (length a)))
  77              (item (aref a random-index)))
  78         (push item seq)
  79         (setf (aref a random-index) (aref a (1- (length a))))
  80         (decf (fill-pointer a))))))
  81
  82 (defun buildtree (n &optional verify &aux tree inserted-so-far)
  83   (dolist (item (random-integer-seq n))
  84     (setq tree (redblack:insert tree item (- item)))
  85     (push item inserted-so-far)
  86     (when verify
  87       (verify-invariants tree t)
  88       (dolist (k inserted-so-far)
  89         (assert (eql (node-value (find= k tree)) (- k))))))
  90   tree)
  91
  92 (defun inorder-traverse (tree)
  93   (collect ((items))
  94     (named-let recurse ((node tree))
  95       (awhen (left node) (recurse it))
  96       (items (data node))
  97       (awhen (right node) (recurse it)))
  98     (items)))
  99
 100 (with-test (:name :redblack-basic-insertion)
 101   (let* ((n 1000)
 102          (tree (buildtree n)))
 103     (let ((list (inorder-traverse tree)))
 104       (dotimes (i n)
 105         (let ((item (pop list)))
 106           (assert (eql (car item) i))
 107           (assert (eql (cdr item) (- i))))))
 108     (let ((original-tree tree) strings)
 109       ;; Change some nodes
 110       (dotimes (i 50)
 111         (let ((v (random n)))
 112           (push v strings)
 113           (setq tree (redblack:insert tree v (format nil "str~d" v)))))
 114       ;; Find everything again
 115       (dotimes (i n)
 116         (let ((v (node-value (find= i tree))))
 117           (if (member i strings)
 118               (assert (string= v (format nil "str~d" i)))
 119               (assert (eql v (- i))))))
 120       ;; Nodes are immutable, so the original tree is unchanged
 121       (dotimes (i n)
 122         (assert (= (node-value (find= i original-tree)) (- i)))))))
 123
 124 (defun tree-count (tree)
 125   (labels ((recurse (tree)
 126              (+ 1
 127                 (acond ((left tree) (tree-count it)) (t 0))
 128                 (acond ((right tree) (tree-count it)) (t 0)))))
 129     (if tree (recurse tree) 0)))
 130
 131 (defun test-deletion (tree n-trials &optional print)
 132   (let* ((keys (mapcar 'car (inorder-traverse tree)))
 133          (n (length keys)))
 134     (dotimes (i n-trials)
 135       (let ((deletion-sequence (shuffle keys))
 136             (tree tree)
 137             (n n))
 138         (case print
 139           (:verbose
 140            (format t "deletion sequence:~%~s~%" deletion-sequence))
 141           ((t)
 142            (format t "~aTrial ~d" #\return (1+ i))
 143            (force-output)))
 144         (loop
 145           (when (null deletion-sequence) (return))
 146           (let ((item (pop deletion-sequence)))
 147             (setq tree (redblack:delete item tree))
 148             (decf n)
 149             (assert (= (tree-count tree) n))
 150             (verify-invariants tree nil)
 151             (dolist (item (cdr deletion-sequence))
 152               ;; ensure that everything not deleted is found
 153               (assert (= (node-value (find= item tree))
 154                          (- item))))))))))
 155
 156
 157 (with-test (:name :redblack-basic-deletion)
 158   (let* ((n 500)
 159          (tree (buildtree n)))
 160     (test-deletion tree 5)))
 161
 162 (defun code-as-fixnum (c)
 163   (sb-kernel:make-lisp-obj
 164    (logandc2 (sb-kernel:get-lisp-obj-address c) sb-vm:lowtag-mask)))
 165 (compile 'code-as-fixnum)
 166
 167 (with-test (:name :redblack-codeblob-tree)
 168   (let (tree list)
 169     (format t "~&Insertion ...") (force-output)
 170     ;; 32-bit tends to exhaust the heap if performing insertion inside
 171     ;; MAP-CODE-OBJECTS because of disabled GC. So collect first, then insert.
 172     ;; It's the invariant checker that's a memory hog-
 173     ;; this would only cons 8MiB without the checker.
 174     (sb-vm:map-code-objects
 175      (lambda (x)
 176        (when (= (sb-kernel:generation-of x) sb-vm:+pseudo-static-generation+)
 177          (push (code-as-fixnum x) list))))
 178     (progn ; time
 179     (dolist (x list)
 180       (setq tree (sb-rbtree.word:insert tree x))
 181       ;; speed up insertion by checking invariants only once in while
 182       (when (zerop (random 6)) (verify-invariants-word tree nil))))
 183     (format t "~&Deletion ...") (force-output)
 184     (let* ((rs (make-random-state t))
 185            (tests (let ((*random-state* rs)) (shuffle list)))
 186            (n (length tests)))
 187       (loop
 188        (let ((subseq (subseq tests 0 (min 10 n))))
 189          (decf n (length subseq))
 190          ;; assert that all items in subseq are present
 191          (dolist (x subseq) (assert (sb-rbtree.word:find= x tree)))
 192          ;; delete them
 193          (dolist (x subseq) (setq tree (sb-rbtree.word:delete x tree)))
 194          (verify-invariants-word tree nil)
 195          ;; now they're not found
 196          (dolist (x subseq) (assert (not (sb-rbtree.word:find= x tree))))
 197          (when (null (setq tests (nthcdr (length subseq) tests)))
 198            (return)))))))
 199
 200 (defun test-randomly (&optional (n 10) print &aux (trial 0))
 201   (loop repeat n do
 202     (when print
 203       (format t "trial ~d~%" (incf trial)))
 204     (let ((tree)
 205           (list)
 206           (size 0))
 207       (loop
 208         (if (or (null tree) (< (random 100) 65))
 209             ;; insert
 210             (let ((r (random (ash 1 16))))
 211               (unless (find= r tree)
 212                 (setq tree (redblack:insert tree r (- r)))
 213                 (verify-invariants tree nil)
 214                 (push r list)
 215                 (when (= (incf size) 2000) (return))
 216                 ;;(format t " +~d" r)
 217                 (when print (format t "+") (force-output))
 218                 ))
 219             (let ((key-to-remove (nth (random (length list)) list)))
 220               (aver key-to-remove)
 221               (setq tree (redblack:delete key-to-remove tree))
 222               (setq list (cl:delete key-to-remove list))
 223               ;;(format t " -~d" key-to-remove)
 224               (when print (format t "-") (force-output))
 225               (verify-invariants tree nil)
 226               (dolist (item list)
 227                 (assert (= (node-value (find= item tree)) (- item))))
 228               (decf size))))
 229       ;(print *cases*)
 230       ;(terpri)
 231       (loop while tree
 232             do (setq tree (redblack:delete (node-key tree) tree))
 233                (verify-invariants tree nil)))))
 234
 235 (with-test (:name :redblack-random-test)
 236   (test-randomly 5))
 237
 238 (with-test (:name :redblack-find-less-eql)
 239   (let ((tree nil))
 240     ;; insert keys 0, 10, 20, ..., 1000
 241     (dotimes (i 101)
 242       (setq tree (redblack:insert tree (* i 10) i)))
 243     (loop for key from -10 to 1100
 244           do
 245        (let ((found (find<= key tree)))
 246          (cond ((not found)
 247                 (assert (< key 0)))
 248                ((>= key 1000)
 249                 (assert (= (node-key found) 1000)))
 250                (t
 251                 (assert (= (node-key found)
 252                            (* (floor key 10) 10)))))))))
 253
 254 (defun big-tree (&optional (n 100000))
 255   (let ((tree nil))
 256     (dotimes (i n tree)
 257       (setq tree (redblack:insert tree i (- i))))))
 258
 259 ;;; 2.2 seconds to insert 10,000 items
 260 ;;; 9.1 seconds to insert 20,000 items
 261 (defun try-avl (n-items &aux tree)
 262   (dotimes (i n-items)
 263     (setq tree (sb-thread::avl-insert tree i i)))
 264   tree)
 265 ;; .016 seconds to insert 10,000 items
 266 ;; .024 seconds to insert 20,000 items
 267 (defun try-rb (n-items &aux tree)
 268   (dotimes (i n-items)
 269     (setq tree (redblack:insert tree i i)))
 270   tree)
 271
 272 (defun test-rb-find-inexact (n-nodes n-iterations)
 273   (bbtree-test:test-find-inexact-macro redblack:insert
 274                                        find<= redblack:find>= node-key))
 275
 276 (test-util:with-test (:name :rb-find-inexact)
 277   (bbtree-test:exercise-find-inexact 'test-rb-find-inexact))