(in-package :binary-trees)

(defmethod make-binary-tree-node ((tree aa-tree) item)
  (let ((null-node (sentinel-node tree)))
    (make-instance 'aa-tree-node
                   :left null-node
                   :right null-node
                   :parent null-node
                   :datum item)))

(defmethod make-binary-tree ((type (eql :aa)) &key compfun eqfun keyfun)
  (let* ((sentinel-node (make-sentinel-node 'aa-tree-node '(:level 0))))
    (make-instance 'aa-tree
                   :compfun compfun
                   :eqfun eqfun
                   :keyfun keyfun
                   :sentinel-node sentinel-node
                   :root-node sentinel-node)))

(defun skew (tree node)
  (if (= (level (left node)) (level node))
      (rotate-right tree node)
      node))

(defun split (tree node)
  (if (= (level (right (right node))) (level node))
      (let ((new-root (rotate-left tree node)))
        (incf (level new-root))
        new-root)
      node))

(defmethod insert-at-node ((tree aa-tree) item parent direction-stack)
  (let ((new-node (insert-node tree parent (first direction-stack) item)))
    ;; INSERT-NODE here is useful only for its side effect
    (declare (ignore new-node))
    (do ((node parent (parent node)))
        ((null-node-p node tree)
         (values))
      (skew tree node)
      (split tree node))))

(defmethod tree-delete-nonempty ((tree aa-tree) deleted child low-subtree)
  ;; rebalance everything
  (do ((node child (parent node)))
      ((null-node-p node tree) t)
    (when (or (< (level (left node)) (1- (level node)))
              (< (level (right node)) (1- (level node))))
      (decf (level node))
      (when (> (level (right node)) (level node))
        (setf (level (right node)) (level node)))
      (skew tree node)
      (skew tree (right node))
      (skew tree (right (right node)))
      (split tree node)
      (split tree node))))