3 (unless (assoc :normal *binary-tree-info*)
4 (push (list :normal #'make-tree-node nil nil) *binary-tree-info*))
9 (declaim (inline rotate-left rotate-right))
10 (defun rotate-left (node)
11 (let ((c (right node)))
12 (setf (right node) (left c)
14 (incf (rank c) (rank node))
16 (defun rotate-right (node)
17 (let ((c (left node)))
18 (setf (left node) (right c)
20 (decf (rank node) (rank c))
23 (defun update-ranks (direction-stack insertedp)
24 (dolist (x direction-stack (values))
25 (let ((direction (cdr x)))
26 (when (eq direction 'left)
29 (decf (rank (car x))))))))
31 (declaim (inline insert-child-for-stack-entry set-root-or-entry-child))
32 (defun insert-child-for-stack-entry (entry child)
33 (declare (type cons entry))
34 (if (eq (cdr entry) 'left)
35 (setf (left (car entry)) child)
36 (setf (right (car entry)) child)))
38 (defun set-root-or-entry-child (tree entry child)
40 (setf (root tree) child)
41 (insert-child-for-stack-entry entry child)))
43 ;;; Locates the place where we should place ITEM in TREE. Returns two
44 ;;; values: whether we should insert and a stack of nodes visited and
45 ;;; the direction we traveled from each node. The newly-created node
46 ;;; should be a child of the node of the first entry on the stack.
47 (defun find-insertion-point (tree item-key)
48 (let ((pred (pred tree))
51 (declare (type function pred test key))
52 (do ((node (root tree))
53 (direction-stack nil))
55 (values nil direction-stack item-key))
56 (declare (type (or null tree-node) node))
57 (let ((node-key (funcall key (datum node))))
59 ((funcall test node-key item-key)
60 (return-from find-insertion-point (values node direction-stack node-key)))
61 ((funcall pred item-key node-key)
62 (push (cons node 'left) direction-stack)
63 (setf node (left node)))
65 (push (cons node 'right) direction-stack)
66 (setf node (right node))))))))
68 (defun insert (item tree)
69 "Attempt to insert ITEM into TREE. ITEM must be of a suitable type
70 for TREE's key function, and the key returned from calling said function
71 must be of a suitable type for TREE's comparison and equality functions.
72 Returns two values; the first is the key of ITEM and the second
73 indicates whether ITEM was inserted or not."
74 (declare (type binary-tree tree))
75 (multiple-value-bind (presentp direction-stack item-key)
76 (find-insertion-point tree (funcall (key tree) item))
78 (update-ranks direction-stack t)
80 (let ((new-node (funcall (nodegen tree) item)))
81 (declare (type tree-node new-node))
82 (incf (modcount tree))
85 (insert-child-for-stack-entry (first direction-stack) new-node))
87 (setf (root tree) new-node)))
88 (let ((rebalancer (rebalance/insert tree)))
90 (funcall rebalancer tree direction-stack)))))
91 (values item-key (null presentp))))
93 (declaim (inline lower-bound-node-with-path))
94 (defun lower-bound-node-with-path (key tree pathp)
95 (let ((pred (pred tree))
97 (declare (type function pred %key))
98 (labels ((locate-node (node candidate path)
100 ((null node) (values candidate path))
101 ((funcall pred key (funcall %key (datum node)))
102 (locate-node (left node) candidate
104 (cons (cons node 'left) path))))
106 (locate-node (right node) node
108 (cons (cons node 'right) path)))))))
109 (locate-node (root tree) nil nil))))
110 (declaim (notinline lower-bound-node-with-path))
112 (defun lower-bound-node (key tree)
113 "Return the node in TREE possessing a key which is equal to or
115 (lower-bound-node-with-path key tree nil))
117 (defun lower-bound (key tree)
118 "Return the item in TREE possessing a key which is equal to or less
119 than KEY. Returns NIL if there is no such item."
120 (let ((node (lower-bound-node key tree)))
121 (and node (datum node))))
123 (declaim (inline upper-bound-node-with-path))
124 (defun upper-bound-node-with-path (key tree pathp)
125 (let ((pred (pred tree))
127 (declare (type function pred %key))
128 (labels ((locate-node (node candidate path)
130 ((null node) (values candidate path))
131 ((funcall pred key (funcall %key (datum node)))
132 (locate-node (left node) node
133 (when pathp (cons (cons node 'left) path))))
135 (locate-node (right node) candidate
136 (when pathp (cons (cons node 'right) path)))))))
137 (locate-node (the tree-node (root tree)) nil nil))))
138 (declaim (notinline upper-bound-node-with-path))
140 (defun upper-bound-node (key tree)
141 "Return the node in TREE possessing a key which is equal to or greater
143 (upper-bound-node-with-path key tree nil))
145 (defun upper-bound (key tree)
146 "Return the item in TREE possessing a key which is equal to or
147 greater than KEY. Returns NIL if there is no such item."
148 (let ((node (upper-bound-node key tree)))
149 (and node (datum node))))
151 (defun find-node-with-key (tree key)
152 "Find the node in TREE with key KEY. Might return the null node if no
153 such node can be found."
154 (let ((node (lower-bound-node key tree)))
156 (funcall (test tree) key (funcall (key tree) (datum node)))
159 (defun find (key tree)
160 "Find the item in TREE whose key is KEY and returns the associated item
161 and T as multiple values, or returns NIL and NIL if no such item exists."
162 (let ((node (find-node-with-key tree key)))
164 (values (datum node) t)
167 (defun delete-node (tree node direction-stack)
169 (update-ranks direction-stack nil)
170 (let ((parent (caar direction-stack))
171 (direction (cdar direction-stack)))
172 (flet ((move-node (x)
175 (if (eq direction 'left)
176 (setf (left parent) x)
177 (setf (right parent) x)))
179 (let ((r (right node)))
182 (values (move-node (left node)) direction-stack))
184 (setf (left r) (left node)
185 (rank r) (rank node))
186 (values (move-node r)
187 (cons (cons r 'right) direction-stack)))
189 ;; find NODE's in-order successor
190 (let ((placeholder (cons nil 'right))
191 (parent (first direction-stack)))
192 (push placeholder direction-stack)
194 (push (cons r 'left) direction-stack)
195 (let ((succ (left r)))
196 (when (null (left succ))
198 ;; move SUCC into NODE's place
199 (setf (left r) (right succ)
200 (left succ) (left node)
201 (right succ) (right node)
202 (rank succ) (rank node))
204 (setf (root tree) succ)
205 (insert-child-for-stack-entry parent succ))
206 (setf (car placeholder) succ)
207 (return-from delete-node (values (move-node succ) direction-stack)))
209 (setf r succ))))))))))
211 (defun delete (key tree)
212 "Attempt to remove the item with KEY from TREE.
213 Returns the item and T as multiple values on success, NIL and NIL on
215 (declare (type binary-tree tree))
216 (multiple-value-bind (node direction-stack item-key)
217 (find-insertion-point tree key)
218 (declare (ignore item-key))
220 (multiple-value-bind (replacement new-stack)
221 (delete-node tree node direction-stack)
222 (incf (modcount tree))
223 (let ((rebalancer (rebalance/delete tree)))
225 (funcall rebalancer tree node replacement new-stack)))
226 (values (datum node) t))
229 (defun minimum-node (root)
230 (do ((node root (left node))
232 ((eq node nil) parent)))
234 (defun minimum (tree)
235 "Return the item with the minimum key in TREE. It is an error to ask
236 for the minimum item of an empty tree."
237 (if (zerop (size tree))
239 (datum (minimum-node (root tree)))))
241 (defun maximum-node (root)
242 (do ((node root (right node))
244 ((eq node nil) parent)))
246 (defun maximum (tree)
247 "Return the item with the maximum key in TREE. It is an error to ask
248 for the maximum item of an empty tree."
249 (if (zerop (size tree))
251 (datum (maximum-node (root tree)))))
253 (defun select-node-with-path (tree k pathp)
254 (labels ((select-loop (node k path)
255 (let ((rank (1- (rank node))))
257 ((= k rank) (values node path))
258 ((< k rank) (select-loop (left node) k
260 (cons (cons node 'left) path))))
261 (t (select-loop (right node) (- k rank 1)
263 (cons (cons node 'right) path))))))))
266 (>= k (size tree))) (error "Invalid index value"))
267 (t (select-loop (root tree) k nil)))))
269 (defun select-node (tree k)
270 (select-node-with-path tree k nil))
272 (defun select (tree k)
273 "Return the Kth item (zero-based) in TREE."
274 (datum (select-node tree k)))