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))
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)
17 ((and (not (null y)) (redp y))
26 ((eq (cdar stack) ',ppfun)
31 (,ppfun pp) (,r1 x)))))
35 (let ((ppp (caddr stack)))
38 (insert-child-for-stack-entry ppp y))
40 (if (eq (cdadr stack) 'left)
41 (frob left right rotate-left rotate-right)
42 (frob right left rotate-right rotate-left)))
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)
53 (symbol-macrolet ((tos (car new-stack))
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))
65 (macrolet ((frob (rf1 rf2 op1 op2)
66 `(let ((w (,op1 tos-node)))
67 #+nil(format *trace-output* "w is ~A~%" w)
71 (let ((r (,rf2 tos-node)))
72 #+nil (format *trace-output* "1 inserting ~A into ~A~%" r poptop)
73 (if (null (cdr new-stack))
75 (insert-child-for-stack-entry poptop r)))
76 (push (cons tos-node tos-dir) new-stack)
79 (setf w (,op1 tos-node))
80 #+nil (format *trace-output* "w is now ~A~%" w)
86 (and (or (null s1) (blackp s1))
87 (or (null s2) (blackp s2))))
88 #+NIL (format *trace-output* "red'ing ~A~%" w)
91 (when (let ((r (,op1 w)))
92 (or (null r) (blackp r)))
93 #+nil (format *trace-output* "converting cases~%")
94 (assert (redp (,op2 w)))
98 (insert-child-for-stack-entry (cons tos-node ',op1) y)
100 (setf w (,op1 tos-node))
101 #+nil (format *trace-output* "w has become ~A~%" w)
103 #+NIL (format *trace-output* "handling case 3?~%")
104 (setf (color w) (color tos-node))
107 (let ((r (,rf2 tos-node)))
108 #+NIL (format *trace-output* "2 inserting ~A into ~A~%" r poptop)
109 (if (null (cdr new-stack))
111 (insert-child-for-stack-entry poptop r))
114 (left (frob rotate-right rotate-left right left))
115 (right (frob rotate-left rotate-right left right)))
117 (let ((root (root tree)))
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)