(in-package :trees-tests)

(defun validate-tree (tree)
  (validate-tree* (trees::root tree)))

(defgeneric validate-tree* (root)
  (:method-combination and))

(defmethod validate-tree* and (root)
  (labels ((verify (root)
             (unless root
               (return-from verify (values 0 0)))
             (let ((rank (trees::rank root)))
               (unless (>= rank 1)
                 (error "node ~A has invalid rank" root))
               (multiple-value-bind (left-rank left-size) (verify (trees::left root))
                 (declare (ignore left-rank))
                 (unless (= rank (1+ left-size))
                   (error "node ~A has invalid rank left-wise: ~D" root left-size))
                 (multiple-value-bind (right-rank right-size)
                     (verify (trees::right root))
                   (declare (ignore right-rank))
                   (values rank (+ 1 left-size right-size)))))))
    (verify root)
    t))

(defmethod validate-tree* and ((root trees::red-black-tree-node))
  (when root
    (unless (trees::blackp root)
      (error "tree has non-black root!")))
  (labels ((verify (root)
             (unless root
               (return-from verify 0))
             (let ((left (trees::left root))
                   (right (trees::right root)))
               (when (trees::redp root)
                 (when (let ((x left))
                         (and x (trees::redp x)))
                   (error "red node ~A has red left child ~A~%" root left))
                 (when (let ((x right))
                         (and x (trees::redp x)))
                   (error "red node ~A has red right child ~A~%" root right)))
               (let ((left-bh (verify left))
                     (right-bh (verify right)))
                 (unless (= left-bh right-bh)
                   (error "node ~A has different black-heights: ~D/~D~%"
                          root left-bh right-bh))
                 (+ left-bh (if (trees::blackp root) 1 0))))))
    (verify root)
    t))

(defmethod validate-tree* and ((root trees::avl-tree-node))
  (labels ((verify (root)
             (unless root
               (return-from verify 0))
             (unless (<= -1 (trees::balance-info root) 1)
               (error "out-of-range balance factor for ~A" root))
             (let ((left-height (verify (trees::left root)))
                   (right-height (verify (trees::right root))))
               (when (/= (- right-height left-height) (trees::balance-info root))
                 (error "node ~A has different sub-heights: ~D/~D"
                        root left-height right-height))
               (1+ (max left-height right-height)))))
    (verify root)
    t))

(defmethod validate-tree* and ((root trees::aa-tree-node))
  (labels ((verify (root)
             (unless root
               (return-from verify 0))
             (let ((level (trees::level root))
                   (left (trees::left root))
                   (right (trees::right root)))
               (when (and (null left) (null right))
                 (unless (= level 1)
                   (error "leaf node ~A has invalid level" root)))
               (when (and left right)
                 (unless (> level 1)
                   (error "non-leaf node ~A has invalid level" root)))
               (unless (< (trees::level* left) level)
                 (error "left node ~A has invalid level wrt ~A" left root))
               (unless (<= (trees::level* right) level)
                 (error "right node ~A has invalid level wrt ~A" right root))
               (verify left)
               (verify right))))
    (verify root)
    t))