avl-trees.lisp

   1 (in-package :trees)
   2
   3 (defun update-balance-factors (tree direction-stack)
   4   (loop with y = (root tree)
   5      with parent = nil
   6      with tail = nil
   7      with reversed-stack = (nreverse direction-stack)
   8      for x on reversed-stack
   9      and xp = nil then (car x)
  10      do (let ((node (caar x)))
  11           (when (not (zerop (balance-info node)))
  12             (setf y node parent xp tail x)))
  13      finally
  14        (return
  15          ;; If TAIL is NIL, then we have an entire path of nodes with
  16          ;; zero balance factors and the whole path needs to be
  17          ;; adjusted.
  18          (dolist (p (if (null tail)
  19                         reversed-stack
  20                         tail)
  21                   (values y parent))
  22            (let ((node (car p)))
  23              (if (eq (cdr p) 'left)
  24                  (decf (balance-info node))
  25                  (incf (balance-info node))))))))
  26
  27 (defun avl-rebalance/insert (tree direction-stack)
  28   (when direction-stack
  29     (multiple-value-bind (y parent-entry)
  30         (update-balance-factors tree direction-stack)
  31       (case (balance-info y)
  32         (#.+avl-falls-left+
  33          (let ((x (left y)) w)
  34            (ecase (balance-info x)
  35              (#.+avl-leans-left+
  36               (setf w (rotate-right y)
  37                     (balance-info x) +avl-equal+
  38                     (balance-info y) +avl-equal+))
  39              (#.+avl-leans-right+
  40               (setf (left y) (rotate-left x)
  41                     w (rotate-right y))
  42               (case (balance-info w)
  43                 (#.+avl-leans-left+
  44                  (setf (balance-info x) 0
  45                        (balance-info y) +avl-leans-right+))
  46                 (#.+avl-equal+
  47                  (setf (balance-info x) 0
  48                        (balance-info y) 0))
  49                 (#.+avl-leans-right+
  50                  (setf (balance-info x) +avl-leans-left+
  51                        (balance-info y) 0)))
  52               (setf (balance-info w) +avl-equal+)))
  53            (set-root-or-entry-child tree parent-entry w)))
  54         (#.+avl-falls-right+
  55          (let ((x (right y)) w)
  56            (ecase (balance-info x)
  57              (#.+avl-leans-right+
  58               (setf w (rotate-left y)
  59                     (balance-info x) +avl-equal+
  60                     (balance-info y) +avl-equal+))
  61              (#.+avl-leans-left+
  62               (setf (right y) (rotate-right x)
  63                     w (rotate-left y))
  64               (case (balance-info w)
  65                 (#.+avl-leans-right+
  66                  (setf (balance-info x) 0
  67                        (balance-info y) +avl-leans-left+))
  68                 (#.+avl-equal+
  69                  (setf (balance-info x) 0
  70                        (balance-info y) 0))
  71                 (#.+avl-leans-left+
  72                  (setf (balance-info x) +avl-leans-right+
  73                        (balance-info y) 0)))
  74               (setf (balance-info w) +avl-equal+)))
  75            (set-root-or-entry-child tree parent-entry w)))))))
  76
  77 (defun avl-rebalance/delete (tree node replacement stack)
  78   (loop
  79      initially (unless (and (null (right node))
  80                             (eq replacement (left node)))
  81                  (setf (balance-info replacement) (balance-info node)))
  82      for (top . rest) on stack
  83      do (let ((y (car top))
  84               (direction (cdr top)))
  85           (macrolet ((frob (dir opp r1 r2)
  86                        (flet ((ifleft (dir f1 f2)
  87                                 (if (eq dir 'left)
  88                                     f1
  89                                     f2))
  90                               (leftinfo (dir a)
  91                                 (if (eq dir 'left) a (- a))))
  92                          `(progn
  93                             (,(ifleft dir 'incf 'decf) (balance-info y))
  94                             (case (balance-info y)
  95                               (,(leftinfo dir +avl-leans-right+)
  96                                (loop-finish))
  97                               (,(leftinfo dir +avl-falls-right+)
  98                                (let ((x (,opp y)))
  99                                  (case (balance-info x)
 100                                    (,(leftinfo dir +avl-leans-left+)
 101                                     (let ((w (,dir x)))
 102                                       (setf (,opp y) (,r1 x))
 103                                       (let ((r (,r2 y)))
 104                                         (assert (eq w r))
 105                                         (case (balance-info w)
 106                                           (,(leftinfo dir +avl-leans-right+)
 107                                            (setf (balance-info x) +avl-equal+
 108                                                  (balance-info y) ,(leftinfo dir +avl-leans-left+)))
 109                                           (,(leftinfo dir +avl-equal+)
 110                                            (setf (balance-info x) +avl-equal+
 111                                                  (balance-info y) +avl-equal+))
 112                                           (,(leftinfo dir +avl-leans-left+)
 113                                            (setf (balance-info x) ,(leftinfo dir +avl-leans-right+)
 114                                                  (balance-info y) +avl-equal+)))
 115                                         (setf (balance-info w) 0)
 116                                         (set-root-or-entry-child tree (first rest) w))))
 117                                    (t
 118                                     (let ((r (,r2 y)))
 119                                       (set-root-or-entry-child tree (first rest) r)
 120                                       (cond
 121                                         ((= (balance-info x) +avl-equal+)
 122                                          (setf (balance-info x) ,(leftinfo dir +avl-leans-left+)
 123                                                (balance-info y) ,(leftinfo dir +avl-leans-right+))
 124                                          (loop-finish))
 125                                         (t
 126                                          (setf (balance-info x) +avl-equal+
 127                                                (balance-info y) +avl-equal+)))))))))))))
 128             (case direction
 129               (left (frob left right rotate-right rotate-left))
 130               (right (frob right left rotate-left rotate-right)))))))
 131
 132 (unless (assoc :avl *binary-tree-info*)
 133   (push (list :avl
 134               #'make-avl-node
 135               #'avl-rebalance/insert
 136               #'avl-rebalance/delete)
 137         *binary-tree-info*))