red-black-trees.lisp

   1 (in-package :trees)
   2
   3 (declaim (inline redp blackp redden blacken))
   4 (defun redp (node) (eq (color node) :red))
   5 (defun blackp (node) (eq (color node) :black))
   6 (defun redden (node) (setf (color node) :red))
   7 (defun blacken (node) (setf (color node) :black))
   8
   9 (defun red-black-rebalance/insert (tree direction-stack)
  10   (loop with stack = direction-stack
  11      for parent = (caar stack)
  12      for pp = (caadr stack)
  13      until (or (null parent) (null pp) (blackp parent))
  14      do (macrolet ((frob (ppfun opp r1 r2)
  15                      `(let ((y (,opp pp)))
  16                         (cond
  17                           ((and (not (null y)) (redp y))
  18                            (blacken parent)
  19                            (blacken y)
  20                            (redden pp)
  21                            (pop stack)
  22                            (pop stack))
  23                           (t
  24                            (let ((x pp))
  25                              (cond
  26                                ((eq (cdar stack) ',ppfun)
  27                                 (setf y parent))
  28                                (t
  29                                 (let ((x parent))
  30                                   (setf y (,opp x)
  31                                         (,ppfun pp) (,r1 x)))))
  32                              (redden x)
  33                              (blacken y)
  34                              (,r2 x)
  35                              (let ((ppp (caddr stack)))
  36                                (if (null ppp)
  37                                    (setf (root tree) y)
  38                                    (insert-child-for-stack-entry ppp y))
  39                                (loop-finish))))))))
  40           (if (eq (cdadr stack) 'left)
  41               (frob left right rotate-left rotate-right)
  42               (frob right left rotate-right rotate-left)))
  43      finally (progn
  44                (blacken (root tree))
  45                (return (values)))))
  46
  47 (defun red-black-rebalance/delete (tree node replacement new-stack)
  48   (unless (null (right node))
  49     (rotatef (color replacement) (color node)))
  50   (when (and (blackp node) new-stack)
  51     (loop while new-stack
  52        do
  53        (symbol-macrolet ((tos (car new-stack))
  54                          (tos-node (car tos))
  55                          (tos-dir (cdr tos))
  56                          (poptop (cadr new-stack))
  57                          (poptop-node (car poptop))
  58                          (poptop-dir (cdr poptop)))
  59          #+nil (format *trace-output* "processing ~A~%" tos)
  60          (let ((x (funcall tos-dir tos-node)))
  61            #+nil (format *trace-output* "z's ~A child is ~A~%" tos-dir x)
  62            (when (and x (redp x))
  63              (blacken x)
  64              (loop-finish))
  65            (macrolet ((frob (rf1 rf2 op1 op2)
  66                         `(let ((w (,op1 tos-node)))
  67                            #+nil(format *trace-output* "w is ~A~%" w)
  68                            (when (redp w)
  69                              (blacken w)
  70                              (redden tos-node)
  71                              (let ((r (,rf2 tos-node)))
  72                                #+nil (format *trace-output* "1 inserting ~A into ~A~%" r poptop)
  73                                (if (null (cdr new-stack))
  74                                    (setf (root tree) r)
  75                                    (insert-child-for-stack-entry poptop r)))
  76                              (push (cons tos-node tos-dir) new-stack)
  77                              (setf tos-dir ',op2
  78                                    poptop-node w)
  79                              (setf w (,op1 tos-node))
  80                              #+nil (format *trace-output* "w is now ~A~%" w)
  81                              (assert w)
  82                              (assert (blackp w)))
  83                            (cond
  84                              ((let ((s1 (,op1 w))
  85                                     (s2 (,op2 w)))
  86                                 (and (or (null s1) (blackp s1))
  87                                      (or (null s2) (blackp s2))))
  88                               #+NIL (format *trace-output* "red'ing ~A~%" w)
  89                               (redden w))
  90                              (t
  91                               (when (let ((r (,op1 w)))
  92                                       (or (null r) (blackp r)))
  93                                 #+nil (format *trace-output* "converting cases~%")
  94                                 (assert (redp (,op2 w)))
  95                                 (blacken (,op2 w))
  96                                 (redden w)
  97                                 (let ((y (,rf1 w)))
  98                                   (insert-child-for-stack-entry (cons tos-node ',op1) y)
  99                                   (assert tos-node)
 100                                   (setf w (,op1 tos-node))
 101                                   #+nil (format *trace-output* "w has become ~A~%" w)
 102                                   (assert (eq y w))))
 103                               #+NIL (format *trace-output* "handling case 3?~%")
 104                               (setf (color w) (color tos-node))
 105                               (blacken tos-node)
 106                               (blacken (,op1 w))
 107                               (let ((r (,rf2 tos-node)))
 108                                 #+NIL (format *trace-output* "2 inserting ~A into ~A~%" r poptop)
 109                                 (if (null (cdr new-stack))
 110                                     (setf (root tree) r)
 111                                     (insert-child-for-stack-entry poptop r))
 112                                 (loop-finish)))))))
 113              (case tos-dir
 114                (left (frob rotate-right rotate-left right left))
 115                (right (frob rotate-left rotate-right left right)))
 116              (pop new-stack))))))
 117   (let ((root (root tree)))
 118     (when root
 119       (blacken root))))
 120
 121 (unless (assoc :red-black *binary-tree-info*)
 122   (push (list :red-black
 123               #'make-red-black-node
 124               #'red-black-rebalance/insert
 125               #'red-black-rebalance/delete)
 126         *binary-tree-info*))