1 (in-package :trees-tests)
3 (defun validate-tree (tree)
4 (validate-tree* (trees::root tree)))
6 (defgeneric validate-tree* (root)
7 (:method-combination and))
9 (defmethod validate-tree* and (root)
10 (labels ((verify (root)
12 (return-from verify (values 0 0)))
13 (let ((rank (trees::rank root)))
15 (error "node ~A has invalid rank" root))
16 (multiple-value-bind (left-rank left-size) (verify (trees::left root))
17 (declare (ignore left-rank))
18 (unless (= rank (1+ left-size))
19 (error "node ~A has invalid rank left-wise: ~D" root left-size))
20 (multiple-value-bind (right-rank right-size)
21 (verify (trees::right root))
22 (declare (ignore right-rank))
23 (values rank (+ 1 left-size right-size)))))))
27 (defmethod validate-tree* and ((root trees::red-black-tree-node))
29 (unless (trees::blackp root)
30 (error "tree has non-black root!")))
31 (labels ((verify (root)
33 (return-from verify 0))
34 (let ((left (trees::left root))
35 (right (trees::right root)))
36 (when (trees::redp root)
38 (and x (trees::redp x)))
39 (error "red node ~A has red left child ~A~%" root left))
40 (when (let ((x right))
41 (and x (trees::redp x)))
42 (error "red node ~A has red right child ~A~%" root right)))
43 (let ((left-bh (verify left))
44 (right-bh (verify right)))
45 (unless (= left-bh right-bh)
46 (error "node ~A has different black-heights: ~D/~D~%"
47 root left-bh right-bh))
48 (+ left-bh (if (trees::blackp root) 1 0))))))
52 (defmethod validate-tree* and ((root trees::avl-tree-node))
53 (labels ((verify (root)
55 (return-from verify 0))
56 (unless (<= -1 (trees::balance-info root) 1)
57 (error "out-of-range balance factor for ~A" root))
58 (let ((left-height (verify (trees::left root)))
59 (right-height (verify (trees::right root))))
60 (when (/= (- right-height left-height) (trees::balance-info root))
61 (error "node ~A has different sub-heights: ~D/~D"
62 root left-height right-height))
63 (1+ (max left-height right-height)))))
67 (defmethod validate-tree* and ((root trees::aa-tree-node))
68 (labels ((verify (root)
70 (return-from verify 0))
71 (let ((level (trees::level root))
72 (left (trees::left root))
73 (right (trees::right root)))
74 (when (and (null left) (null right))
76 (error "leaf node ~A has invalid level" root)))
77 (when (and left right)
79 (error "non-leaf node ~A has invalid level" root)))
80 (unless (< (trees::level* left) level)
81 (error "left node ~A has invalid level wrt ~A" left root))
82 (unless (<= (trees::level* right) level)
83 (error "right node ~A has invalid level wrt ~A" right root))