aa-trees.lisp

   1 (in-package :trees)
   2
   3 (declaim (inline level*))
   4 (defun level* (x) (if x (level x) 0))
   5
   6 (defun skew (node)
   7   (let ((x (left node)))
   8     (when (= (level* x) (level node))
   9       (setf node (rotate-right node)))
  10     node))
  11
  12 (defun split (node)
  13   (let ((x (right node)))
  14     (when (= (if x
  15                  (level* (right x))
  16                  0)
  17              (level node))
  18       (setf node (rotate-left node))
  19       (incf (level node)))
  20     node))
  21
  22 (defun aa-rebalance/insert (tree direction-stack)
  23   (when direction-stack
  24     (loop with new-child = (split (skew (caar direction-stack)))
  25        for x in (cdr direction-stack)
  26        for node = (car x)
  27        do (insert-child-for-stack-entry x new-child)
  28        (setf new-child (split (skew node)))
  29        finally (setf (root tree) new-child))))
  30
  31 (defun aa-rebalance/delete (tree node replacement stack)
  32   ;; This is what I get for trying to do things without sentinels.
  33   (loop initially (when replacement
  34                     (setf (level replacement) (level node)))
  35      for (x . rest) on stack
  36      do (let* ((node (car x))
  37                (y (left node))
  38                (z (right node)))
  39           (when (let ((level (1- (level node))))
  40                   (or (< (level* y) level)
  41                       (< (level* z) level)))
  42             (decf (level node))
  43             (when (> (level* z) (level node))
  44               (setf (level z) (level node)))
  45             (let ((n (skew node)))
  46               (set-root-or-entry-child tree (car rest) n)
  47               (when (right n)
  48                 (setf (right n) (skew (right n))))
  49               (let ((m (right n)))
  50                 (when (and m (right m))
  51                   (setf (right m) (skew (right m)))))
  52               (setf n (split n))
  53               (set-root-or-entry-child tree (car rest) n)
  54               (when (right n)
  55                 (setf (right n) (split (right n)))))))))
  56
  57 (unless (assoc :aa *binary-tree-info*)
  58   (push (list :aa
  59               #'make-aa-node
  60               #'aa-rebalance/insert
  61               #'aa-rebalance/delete)
  62         *binary-tree-info*))