3 ;;; Andersson tree implementation
5 ;;; (c) 2006 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This program is free software; you can redistribute it and/or modify
11 ;;; it under the terms of the GNU General Public License as published by
12 ;;; the Free Software Foundation; either version 2 of the License, or
13 ;;; (at your option) any later version.
15 ;;; This program is distributed in the hope that it will be useful,
16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;;; GNU General Public License for more details.
20 ;;; You should have received a copy of the GNU General Public License
21 ;;; along with this program; if not, write to the Free Software Foundation,
22 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
24 ;;;--------------------------------------------------------------------------
28 (:use #:common-lisp #:mdw.base))
29 (in-package #:aa-tree)
31 ;;;--------------------------------------------------------------------------
32 ;;; The underlying implementation.
34 (deftype stack-pointer () '(integer 0 255))
39 (:constructor make-tree-node
40 (key &optional data level left right)))
41 "Structure representing a node in an Andersson tree."
42 (left nil :type (or null tree-node))
43 (right nil :type (or null tree-node))
44 (level 0 :type stack-pointer)
48 (deftype tree-node () 'simple-vector)
50 (export '(make-aa-tree aa-tree aa-tree-p aa-tree-key<))
53 (:constructor make-aa-tree
56 (key< (functionify key<-name))))
58 "Structure representing an Andersson tree."
59 (root nil :type (or null tree-node))
60 (stack (make-array 32) :type simple-vector)
61 (key< (slot-uninitialized) :read-only t :type (function (t t) t)))
63 (declaim (inline skew split))
66 "Implements the `skew' operation on a tree node, eliminating left-pointing
67 internal pointers by applying right-rotation. Returns the replacement
69 (declare (type tree-node node))
70 (let ((left (node-left node)))
71 (when (and left (= (node-level node) (node-level left)))
72 (shiftf (node-left node) (node-right left) node left))
76 "Implements the `split' operation on a tree node, eliminating overly-large
77 pseudo-nodes by applying left-rotation. Returns the replacement node."
78 (declare (type tree-node node))
79 (let* ((right (node-right node))
80 (rright (and right (node-right right))))
81 (when (and rright (= (node-level node) (node-level rright)))
82 (shiftf (node-right node) (node-left right) node right)
83 (incf (node-level node)))
86 (defun get-tree-stack (tree)
87 "Return the current stack for the TREE. This is used to remember the path
88 taken during a search in tree, so we can fix it up afterwards. Keeping
89 just one stack for the tree saves on consing; it's not safe to do
90 simultaneous destructive operations on a tree anyway, so this is a
91 reasonable thing to do. This function ensures that the stack attached to
92 the tree is actually large enough before returning it."
93 (declare (type aa-tree tree))
94 (let* ((root (tree-root tree))
95 (want (* 4 (+ (if root (node-level root) 0) 2)))
96 (stack (tree-stack tree))
97 (size (array-dimension (tree-stack tree) 0)))
100 (do ((need (ash size 1) (ash need 1)))
101 ((>= need want) (setf (tree-stack tree) (make-array need)))))))
104 (defun getaa (tree key &optional default)
105 "Look up the given KEY in an Andersson TREE; if the KEY was found, return
106 the corresponding data and t, otherwise return DEFAULT and nil."
107 (declare (type aa-tree tree))
108 (let ((key< (tree-key< tree))
109 (node (tree-root tree))
112 (declare (type (function (t t) t) key<)
113 (type (or null tree-node) node candidate))
116 (declare (inline key<))
118 (let ((node-key (node-key node)))
119 (if (key< key node-key)
120 (setf node (node-left node))
122 candidate-key node-key
123 node (node-right node)))))
124 ((and candidate (not (key< candidate-key key)))
125 (return (values (node-data candidate) t)))
127 (return (values default nil))))))))
129 (defun tree-probe (tree key)
130 "Do a search in an Andersson TREE for the KEY, returning three values. The
131 second and third are a stack of alternating nodes and direction bits, and
132 a stack pointer (empty, ascending), which together describe the path from
133 the tree root to the successor of the sought-for node. The first is
134 either the sought-for node itself, or nil if it wasn't there."
135 (declare (type aa-tree tree))
136 (let ((key< (tree-key< tree))
137 (stack (get-tree-stack tree))
141 (declare (type (function (t t) t) key<)
142 (type simple-vector stack)
143 (type stack-pointer sp)
144 (type (or null tree-node) candidate))
145 (flet ((pathpush (v i)
146 (setf (svref stack sp) v
147 (svref stack (1+ sp)) i)
151 (declare (inline pathpush key<))
152 (let ((node (tree-root tree)))
153 (loop (when (null node)
155 (let* ((node-key (node-key node))
156 (dir (cond ((key< key node-key) 0)
157 (t (setf candidate node
158 candidate-key node-key)
161 (setf node (svref node dir)))))
162 (values (if (and candidate (not (key< candidate-key key)))
168 (defun fixup-insert (tree stack sp node)
169 "TREE is an Andersson tree, STACK and SP are the values from a failed call
170 to tree-probe, and NODE is a newly-created node. Insert the NODE into
171 the tree, fix up its balance."
172 (declare (type aa-tree tree)
173 (type simple-vector stack)
174 (type stack-pointer sp)
175 (type tree-node node))
176 (loop (when (zerop sp)
179 (let ((parent (svref stack sp))
180 (dir (svref stack (1+ sp))))
181 (setf (svref parent dir) node
183 (setf node (split (skew node))))
184 (setf (tree-root tree) node))
186 (defun (setf getaa) (data tree key &optional ignore)
187 "Inserts a new node with the given KEY into an Andersson TREE, if there
188 wasn't one already. Returns two values: the requested node, and either t
189 if the node was inserted, or nil if it was already there."
190 (declare (type aa-tree tree)
192 (multiple-value-bind (node stack sp) (tree-probe tree key)
193 (cond (node (setf (node-data node) data))
194 (t (fixup-insert tree stack sp (make-tree-node key data)) data))))
197 (defun updateaa (tree key func)
198 "Search TREE for an item with the given KEY. If it was found, call FUNC
199 with arguments of the node's data and t, and store its result as the
200 node's new data. If it was absent, call FUNC with arguments nil and nil,
201 and make a new node with the KEY and return value. The FUNC can escape to
202 prevent the node being created (though this is probably not useful)."
203 (declare (type aa-tree tree))
204 (multiple-value-bind (node stack sp) (tree-probe tree key)
205 (cond (node (setf (node-data node) (funcall func (node-data node) t)))
206 (t (let ((data (funcall func nil nil)))
207 (fixup-insert tree stack sp (make-tree-node key data))
211 (defun remaa (tree key)
212 "Deletes the node with the given KEY from an Andersson TREE. Returns t if
213 the node was found and deleted, or nil if it wasn't there to begin with."
214 (declare (type aa-tree tree))
215 (multiple-value-bind (candidate stack sp) (tree-probe tree key)
218 (let ((node (svref stack sp)))
220 ;; Unsplice the candidate node from the tree, leaving node as its
222 (if (eq candidate node)
224 (setf (node-key candidate) (node-key node)
225 (node-data candidate) (node-data node)
226 node (node-right node)))
228 ;; Now wander back up the tree, fixing it as we go.
229 (loop (when (zerop sp)
232 (let ((parent (svref stack sp))
233 (dir (svref stack (1+ sp))))
234 (setf (svref parent dir) node
237 ;; If there's a level difference between this node and its
238 ;; children, bring it (and, if it exists, its right
239 ;; counterpart) down one level.
240 (let ((level-1 (1- (node-level node)))
241 (left (node-left node))
242 (right (node-right node)))
243 (when (flet ((level (node)
244 (if node (node-level node) -1)))
245 (declare (inline level))
246 (or (< (level left) level-1)
247 (< (level right) level-1)))
248 (setf (node-level node) level-1)
249 (when (and right (> (node-level right) level-1))
250 (setf (node-level right) level-1))
252 ;; Now we must fix up the balancing rules. Apparently
253 ;; three skews and two splits suffice.
254 (setf node (skew node))
255 (let ((right (node-right node)))
257 (setf right (skew right)
258 (node-right node) right)
259 (let ((rright (node-right right)))
261 (setf (node-right right) (skew rright))))))
262 (setf node (split node))
263 (let ((right (node-right node)))
264 (when right (setf (node-right node) (split right)))))))
266 ;; Store the new root.
267 (setf (tree-root tree) node)))))
269 (export 'aa-tree-iterator)
270 (defun aa-tree-iterator (tree)
271 "Returns a tree iterator function for TREE. The function returns three
272 values. For each node in the tree, it returns t, the key and the value;
273 then, it returns nil three times."
274 (let ((root (tree-root tree)))
276 (lambda () (values nil nil nil))
277 (let ((stack (make-array (* 2 (1+ (node-level root)))))
279 (flet ((pushleft (node)
280 (do ((node node (node-left node)))
282 (setf (svref stack sp) node)
286 (cond ((zerop sp) (values nil nil nil))
287 (t (let ((node (svref stack (decf sp))))
288 (pushleft (node-right node))
289 (values t (node-key node) (node-data node)))))))))))
292 (defun mapaa (func tree)
293 "Apply FUNC to each key and value in the TREE."
294 (labels ((walk (node)
296 (walk (node-left node))
297 (funcall func (node-key node) (node-data node))
298 (walk (node-right node)))))
299 (walk (tree-root tree))
303 (defmacro doaa ((key value tree &optional result) &body body)
304 "Iterate over the items of TREE; for each one, bind KEY to its key and
305 VALUE to the associated data, and evaluate BODY, which is an implicit
306 tagbody. Finally, return RESULT. Either KEY or VALUE (or both!) may be
307 nil to indicate `don't care'."
308 (with-parsed-body (body decls) body
310 (unless key (setf key (gensym "KEY")) (push key ignores))
311 (unless value (setf value (gensym "VALUE")) (push value ignores))
313 (mapaa (lambda (,key ,value)
315 ,@(and ignores `((declare (ignore ,@ignores))))
320 ;;;--------------------------------------------------------------------------
324 (defun tree-print (tree &optional (stream *standard-output*))
325 "Print a TREE to an output STREAM in a comprehesible way."
326 (labels ((walk (depth node)
328 (walk (1+ depth) (node-left node))
329 (format stream "~v@T~A: ~S => ~S~%"
334 (walk (1+ depth) (node-right node)))))
335 (walk 0 (tree-root tree))))
337 (defun tree-build (key< &rest items)
338 "Return a new tree sorted according to KEY<, containing the given ITEMS."
339 (let ((tree (make-aa-tree key<)))
341 (setf (getaa tree item) nil))
345 (defun test-iterator (tree)
346 (let ((iter (aa-tree-iterator tree)))
347 (mapaa (lambda (key value)
348 (multiple-value-bind (iwin ikey ivalue) (funcall iter)
351 (eql value ivalue)))))
353 (assert (null (nth-value 0 (funcall iter))))))
356 (defun tree-check (tree)
357 "Checks the invariants on a TREE."
358 (let ((key< (tree-key< tree)))
359 (labels ((check (node)
362 (let ((key (node-key node))
363 (level (node-level node))
364 (left (node-left node))
365 (right (node-right node)))
366 (multiple-value-bind (lmin lmax) (check left)
367 (multiple-value-bind (rmin rmax) (check right)
368 (assert (or (null lmax) (funcall key< lmax key)))
369 (assert (or (null rmin) (funcall key< key rmin)))
370 (assert (if (null left)
372 (= (node-level left) (- level 1))))
373 (assert (if (null right)
375 (let ((rright (node-right right)))
376 (or (= (node-level right) (- level 1))
377 (and (= (node-level right) level)
379 (= (node-level rright)
381 (values (or lmin key) (or rmax key))))))))
382 (check (tree-root tree)))))
385 (defun test (&key (state (make-random-state))
389 (let ((in (make-array 0 :element-type 'string
390 :adjustable t :fill-pointer 0))
391 (out (make-array 0 :element-type 'string
392 :adjustable t :fill-pointer 0))
393 (tree (make-aa-tree #'string<)))
395 ;; Slurp in the word list
396 (with-open-file (dict #p"/usr/share/dict/words")
397 (loop for line = (read-line dict nil)
398 while (and line (not (eql items 0)))
399 do (vector-push-extend line out)
400 when items do (decf items)))
403 (vector-push-extend w v))
405 (let ((n (1- (length v))))
406 (setf (aref v i) (aref v n))
407 (decf (fill-pointer v))))
409 (let* ((i (random (length out) state))
411 (setf (getaa tree w) nil)
414 (when (>= verbose 2) (format t "insert ~A~%" w))))
416 (let* ((i (random (length in) state))
421 (when (>= verbose 2) (format t "remove ~A~%" w))))
423 (when (>= verbose 2) (format t "check...~%"))
426 (loop with i = (aa-tree-iterator tree)
428 for (win key value) = (multiple-value-list (funcall i))
429 do (assert (eq w (and win key)))
431 finally (assert (null (nth-value 0 (funcall i)))))))
432 (loop with prob = (if count (/ count 100) 1000)
434 when count do (decf count)
435 do (case (random prob state)
436 (0 (check) (when (= verbose 1) (write-char #\?)))
437 (t (if (< (random (+ (length in) (length out)) state)
440 (when (= verbose 1) (write-char #\+)))
442 (when (= verbose 1) (write-char #\-))))))
446 ;;;----- That's all, folks --------------------------------------------------