validate.lisp

   1 (in-package :trees-tests)
   2
   3 (defun validate-tree (tree)
   4   (validate-tree* (trees::root tree)))
   5
   6 (defgeneric validate-tree* (root)
   7   (:method-combination and))
   8
   9 (defmethod validate-tree* and (root)
  10   (labels ((verify (root)
  11              (unless root
  12                (return-from verify (values 0 0)))
  13              (let ((rank (trees::rank root)))
  14                (unless (>= rank 1)
  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)))))))
  24     (verify root)
  25     t))
  26
  27 (defmethod validate-tree* and ((root trees::red-black-tree-node))
  28   (when root
  29     (unless (trees::blackp root)
  30       (error "tree has non-black root!")))
  31   (labels ((verify (root)
  32              (unless root
  33                (return-from verify 0))
  34              (let ((left (trees::left root))
  35                    (right (trees::right root)))
  36                (when (trees::redp root)
  37                  (when (let ((x left))
  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))))))
  49     (verify root)
  50     t))
  51
  52 (defmethod validate-tree* and ((root trees::avl-tree-node))
  53   (labels ((verify (root)
  54              (unless 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)))))
  64     (verify root)
  65     t))
  66
  67 (defmethod validate-tree* and ((root trees::aa-tree-node))
  68   (labels ((verify (root)
  69              (unless 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))
  75                  (unless (= level 1)
  76                    (error "leaf node ~A has invalid level" root)))
  77                (when (and left right)
  78                  (unless (> level 1)
  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))
  84                (verify left)
  85                (verify right))))
  86     (verify root)
  87     t))