1 ;;; avl-tree.el --- balanced binary trees, AVL-trees
3 ;; Copyright (C) 1995, 2007, 2008 Free Software Foundation, Inc.
5 ;; Author: Per Cederqvist <ceder@lysator.liu.se>
6 ;; Inge Wallin <inge@lysator.liu.se>
7 ;; Thomas Bellman <bellman@lysator.liu.se>
9 ;; Created: 10 May 1991
10 ;; Keywords: extensions, data structures
12 ;; This file is part of GNU Emacs.
14 ;; GNU Emacs is free software; you can redistribute it and/or modify
15 ;; it under the terms of the GNU General Public License as published by
16 ;; the Free Software Foundation; either version 3, or (at your option)
19 ;; GNU Emacs is distributed in the hope that it will be useful,
20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 ;; GNU General Public License for more details.
24 ;; You should have received a copy of the GNU General Public License
25 ;; along with GNU Emacs; see the file COPYING. If not, write to the
26 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
27 ;; Boston, MA 02110-1301, USA.
31 ;; An AVL tree is a nearly-perfect balanced binary tree. A tree consists of
32 ;; two elements, the root node and the compare function. The actual tree
33 ;; has a dummy node as its root with the real root in the left pointer.
35 ;; Each node of the tree consists of one data element, one left
36 ;; sub-tree and one right sub-tree. Each node also has a balance
37 ;; count, which is the difference in depth of the left and right
40 ;; The functions with names of the form "avl-tree--" are intended for
45 (eval-when-compile (require 'cl
))
47 ;; ================================================================
48 ;;; Functions and macros handling an AVL tree node.
50 (defstruct (avl-tree--node
51 ;; We force a representation without tag so it matches the
52 ;; pre-defstruct representation. Also we use the underlying
53 ;; representation in the implementation of avl-tree--node-branch.
56 (:constructor avl-tree--node-create
(left right data balance
))
58 left right data balance
)
60 (defalias 'avl-tree--node-branch
'aref
61 ;; This implementation is efficient but breaks the defstruct abstraction.
62 ;; An alternative could be
63 ;; (funcall (aref [avl-tree-left avl-tree-right avl-tree-data] branch) node)
64 "Get value of a branch of a node.
66 NODE is the node, and BRANCH is the branch.
67 0 for left pointer, 1 for right pointer and 2 for the data.\"
69 ;; The funcall/aref trick doesn't work for the setf method, unless we try
70 ;; and access the underlying setter function, but this wouldn't be
72 (defsetf avl-tree--node-branch aset
)
75 ;; ================================================================
76 ;;; Internal functions for use in the AVL tree package
79 ;; A tagged list is the pre-defstruct representation.
83 (:constructor avl-tree-create
(cmpfun))
84 (:predicate avl-tree-p
)
86 (dummyroot (avl-tree--node-create nil nil nil
0))
89 (defmacro avl-tree--root
(tree)
90 ;; Return the root node for an avl-tree. INTERNAL USE ONLY.
91 `(avl-tree--node-left (avl-tree--dummyroot tree
)))
92 (defsetf avl-tree--root
(tree) (node)
93 `(setf (avl-tree--node-left (avl-tree--dummyroot ,tree
)) ,node
))
95 ;; ----------------------------------------------------------------
98 (defun avl-tree--del-balance1 (node branch
)
99 ;; Rebalance a tree and return t if the height of the tree has shrunk.
100 (let ((br (avl-tree--node-branch node branch
))
103 ((< (avl-tree--node-balance br
) 0)
104 (setf (avl-tree--node-balance br
) 0)
107 ((= (avl-tree--node-balance br
) 0)
108 (setf (avl-tree--node-balance br
) +1)
113 (setq p1
(avl-tree--node-right br
)
114 b1
(avl-tree--node-balance p1
))
116 ;; Single RR rotation.
118 (setf (avl-tree--node-right br
) (avl-tree--node-left p1
))
119 (setf (avl-tree--node-left p1
) br
)
122 (setf (avl-tree--node-balance br
) +1)
123 (setf (avl-tree--node-balance p1
) -
1)
125 (setf (avl-tree--node-balance br
) 0)
126 (setf (avl-tree--node-balance p1
) 0)
128 (setf (avl-tree--node-branch node branch
) p1
)
131 ;; Double RL rotation.
132 (setq p2
(avl-tree--node-left p1
)
133 b2
(avl-tree--node-balance p2
))
134 (setf (avl-tree--node-left p1
) (avl-tree--node-right p2
))
135 (setf (avl-tree--node-right p2
) p1
)
136 (setf (avl-tree--node-right br
) (avl-tree--node-left p2
))
137 (setf (avl-tree--node-left p2
) br
)
138 (setf (avl-tree--node-balance br
) (if (> b2
0) -
1 0))
139 (setf (avl-tree--node-balance p1
) (if (< b2
0) +1 0))
140 (setf (avl-tree--node-branch node branch
) p2
)
141 (setf (avl-tree--node-balance p2
) 0)
144 (defun avl-tree--del-balance2 (node branch
)
145 (let ((br (avl-tree--node-branch node branch
))
148 ((> (avl-tree--node-balance br
) 0)
149 (setf (avl-tree--node-balance br
) 0)
152 ((= (avl-tree--node-balance br
) 0)
153 (setf (avl-tree--node-balance br
) -
1)
158 (setq p1
(avl-tree--node-left br
)
159 b1
(avl-tree--node-balance p1
))
161 ;; Single LL rotation.
163 (setf (avl-tree--node-left br
) (avl-tree--node-right p1
))
164 (setf (avl-tree--node-right p1
) br
)
167 (setf (avl-tree--node-balance br
) -
1)
168 (setf (avl-tree--node-balance p1
) +1)
170 (setf (avl-tree--node-balance br
) 0)
171 (setf (avl-tree--node-balance p1
) 0)
173 (setf (avl-tree--node-branch node branch
) p1
)
176 ;; Double LR rotation.
177 (setq p2
(avl-tree--node-right p1
)
178 b2
(avl-tree--node-balance p2
))
179 (setf (avl-tree--node-right p1
) (avl-tree--node-left p2
))
180 (setf (avl-tree--node-left p2
) p1
)
181 (setf (avl-tree--node-left br
) (avl-tree--node-right p2
))
182 (setf (avl-tree--node-right p2
) br
)
183 (setf (avl-tree--node-balance br
) (if (< b2
0) +1 0))
184 (setf (avl-tree--node-balance p1
) (if (> b2
0) -
1 0))
185 (setf (avl-tree--node-branch node branch
) p2
)
186 (setf (avl-tree--node-balance p2
) 0)
189 (defun avl-tree--do-del-internal (node branch q
)
190 (let ((br (avl-tree--node-branch node branch
)))
191 (if (avl-tree--node-right br
)
192 (if (avl-tree--do-del-internal br
+1 q
)
193 (avl-tree--del-balance2 node branch
))
194 (setf (avl-tree--node-data q
) (avl-tree--node-data br
))
195 (setf (avl-tree--node-branch node branch
)
196 (avl-tree--node-left br
))
199 (defun avl-tree--do-delete (cmpfun root branch data
)
200 ;; Return t if the height of the tree has shrunk.
201 (let ((br (avl-tree--node-branch root branch
)))
206 ((funcall cmpfun data
(avl-tree--node-data br
))
207 (if (avl-tree--do-delete cmpfun br
0 data
)
208 (avl-tree--del-balance1 root branch
)))
210 ((funcall cmpfun
(avl-tree--node-data br
) data
)
211 (if (avl-tree--do-delete cmpfun br
1 data
)
212 (avl-tree--del-balance2 root branch
)))
215 ;; Found it. Let's delete it.
217 ((null (avl-tree--node-right br
))
218 (setf (avl-tree--node-branch root branch
) (avl-tree--node-left br
))
221 ((null (avl-tree--node-left br
))
222 (setf (avl-tree--node-branch root branch
) (avl-tree--node-right br
))
226 (if (avl-tree--do-del-internal br
0 br
)
227 (avl-tree--del-balance1 root branch
))))))))
229 ;; ----------------------------------------------------------------
232 (defun avl-tree--enter-balance1 (node branch
)
233 ;; Rebalance a tree and return t if the height of the tree has grown.
234 (let ((br (avl-tree--node-branch node branch
))
237 ((< (avl-tree--node-balance br
) 0)
238 (setf (avl-tree--node-balance br
) 0)
241 ((= (avl-tree--node-balance br
) 0)
242 (setf (avl-tree--node-balance br
) +1)
246 ;; Tree has grown => Rebalance.
247 (setq p1
(avl-tree--node-right br
))
248 (if (> (avl-tree--node-balance p1
) 0)
249 ;; Single RR rotation.
251 (setf (avl-tree--node-right br
) (avl-tree--node-left p1
))
252 (setf (avl-tree--node-left p1
) br
)
253 (setf (avl-tree--node-balance br
) 0)
254 (setf (avl-tree--node-branch node branch
) p1
))
256 ;; Double RL rotation.
257 (setq p2
(avl-tree--node-left p1
)
258 b2
(avl-tree--node-balance p2
))
259 (setf (avl-tree--node-left p1
) (avl-tree--node-right p2
))
260 (setf (avl-tree--node-right p2
) p1
)
261 (setf (avl-tree--node-right br
) (avl-tree--node-left p2
))
262 (setf (avl-tree--node-left p2
) br
)
263 (setf (avl-tree--node-balance br
) (if (> b2
0) -
1 0))
264 (setf (avl-tree--node-balance p1
) (if (< b2
0) +1 0))
265 (setf (avl-tree--node-branch node branch
) p2
))
266 (setf (avl-tree--node-balance (avl-tree--node-branch node branch
)) 0)
269 (defun avl-tree--enter-balance2 (node branch
)
270 ;; Return t if the tree has grown.
271 (let ((br (avl-tree--node-branch node branch
))
274 ((> (avl-tree--node-balance br
) 0)
275 (setf (avl-tree--node-balance br
) 0)
278 ((= (avl-tree--node-balance br
) 0)
279 (setf (avl-tree--node-balance br
) -
1)
283 ;; Balance was -1 => Rebalance.
284 (setq p1
(avl-tree--node-left br
))
285 (if (< (avl-tree--node-balance p1
) 0)
286 ;; Single LL rotation.
288 (setf (avl-tree--node-left br
) (avl-tree--node-right p1
))
289 (setf (avl-tree--node-right p1
) br
)
290 (setf (avl-tree--node-balance br
) 0)
291 (setf (avl-tree--node-branch node branch
) p1
))
293 ;; Double LR rotation.
294 (setq p2
(avl-tree--node-right p1
)
295 b2
(avl-tree--node-balance p2
))
296 (setf (avl-tree--node-right p1
) (avl-tree--node-left p2
))
297 (setf (avl-tree--node-left p2
) p1
)
298 (setf (avl-tree--node-left br
) (avl-tree--node-right p2
))
299 (setf (avl-tree--node-right p2
) br
)
300 (setf (avl-tree--node-balance br
) (if (< b2
0) +1 0))
301 (setf (avl-tree--node-balance p1
) (if (> b2
0) -
1 0))
302 (setf (avl-tree--node-branch node branch
) p2
))
303 (setf (avl-tree--node-balance (avl-tree--node-branch node branch
)) 0)
306 (defun avl-tree--do-enter (cmpfun root branch data
)
307 ;; Return t if height of tree ROOT has grown. INTERNAL USE ONLY.
308 (let ((br (avl-tree--node-branch root branch
)))
311 ;; Data not in tree, insert it.
312 (setf (avl-tree--node-branch root branch
)
313 (avl-tree--node-create nil nil data
0))
316 ((funcall cmpfun data
(avl-tree--node-data br
))
317 (and (avl-tree--do-enter cmpfun br
0 data
)
318 (avl-tree--enter-balance2 root branch
)))
320 ((funcall cmpfun
(avl-tree--node-data br
) data
)
321 (and (avl-tree--do-enter cmpfun br
1 data
)
322 (avl-tree--enter-balance1 root branch
)))
325 (setf (avl-tree--node-data br
) data
)
328 ;; ----------------------------------------------------------------
330 (defun avl-tree--mapc (map-function root
)
331 ;; Apply MAP-FUNCTION to all nodes in the tree starting with ROOT.
332 ;; The function is applied in-order.
334 ;; Note: MAP-FUNCTION is applied to the node and not to the data itself.
335 ;; INTERNAL USE ONLY.
342 (avl-tree--node-left node
))
343 ;; Do the left subtree first.
346 (setq node
(avl-tree--node-left node
)))
347 ;; Apply the function...
348 (funcall map-function node
)
349 ;; and do the right subtree.
350 (setq node
(if (setq go-left
(avl-tree--node-right node
))
351 (avl-tree--node-right node
)
354 (defun avl-tree--do-copy (root)
355 ;; Copy the avl tree with ROOT as root.
356 ;; Highly recursive. INTERNAL USE ONLY.
359 (avl-tree--node-create
360 (avl-tree--do-copy (avl-tree--node-left root
))
361 (avl-tree--do-copy (avl-tree--node-right root
))
362 (avl-tree--node-data root
)
363 (avl-tree--node-balance root
))))
366 ;; ================================================================
367 ;;; The public functions which operate on AVL trees.
369 (defalias 'avl-tree-compare-function
'avl-tree--cmpfun
370 "Return the comparison function for the avl tree TREE.
374 (defun avl-tree-empty (tree)
375 "Return t if avl tree TREE is emtpy, otherwise return nil."
376 (null (avl-tree--root tree
)))
378 (defun avl-tree-enter (tree data
)
379 "In the avl tree TREE insert DATA.
381 (avl-tree--do-enter (avl-tree--cmpfun tree
)
382 (avl-tree--dummyroot tree
)
387 (defun avl-tree-delete (tree data
)
388 "From the avl tree TREE, delete DATA.
389 Return the element in TREE which matched DATA,
390 nil if no element matched."
391 (avl-tree--do-delete (avl-tree--cmpfun tree
)
392 (avl-tree--dummyroot tree
)
396 (defun avl-tree-member (tree data
)
397 "Return the element in the avl tree TREE which matches DATA.
398 Matching uses the compare function previously specified in
399 `avl-tree-create' when TREE was created.
401 If there is no such element in the tree, the value is nil."
402 (let ((node (avl-tree--root tree
))
403 (compare-function (avl-tree--cmpfun tree
))
408 ((funcall compare-function data
(avl-tree--node-data node
))
409 (setq node
(avl-tree--node-left node
)))
410 ((funcall compare-function
(avl-tree--node-data node
) data
)
411 (setq node
(avl-tree--node-right node
)))
415 (avl-tree--node-data node
)
418 (defun avl-tree-map (__map-function__ tree
)
419 "Apply __MAP-FUNCTION__ to all elements in the avl tree TREE."
422 (setf (avl-tree--node-data node
)
423 (funcall __map-function__
(avl-tree--node-data node
))))
424 (avl-tree--root tree
)))
426 (defun avl-tree-first (tree)
427 "Return the first element in TREE, or nil if TREE is empty."
428 (let ((node (avl-tree--root tree
)))
430 (while (avl-tree--node-left node
)
431 (setq node
(avl-tree--node-left node
)))
432 (avl-tree--node-data node
))))
434 (defun avl-tree-last (tree)
435 "Return the last element in TREE, or nil if TREE is empty."
436 (let ((node (avl-tree--root tree
)))
438 (while (avl-tree--node-right node
)
439 (setq node
(avl-tree--node-right node
)))
440 (avl-tree--node-data node
))))
442 (defun avl-tree-copy (tree)
443 "Return a copy of the avl tree TREE."
444 (let ((new-tree (avl-tree-create (avl-tree--cmpfun tree
))))
445 (setf (avl-tree--root new-tree
) (avl-tree--do-copy (avl-tree--root tree
)))
448 (defun avl-tree-flatten (tree)
449 "Return a sorted list containing all elements of TREE."
451 (let ((treelist nil
))
453 (lambda (node) (push (avl-tree--node-data node
) treelist
))
454 (avl-tree--root tree
))
457 (defun avl-tree-size (tree)
458 "Return the number of elements in TREE."
461 (lambda (data) (setq treesize
(1+ treesize
)))
462 (avl-tree--root tree
))
465 (defun avl-tree-clear (tree)
466 "Clear the avl tree TREE."
467 (setf (avl-tree--root tree
) nil
))
471 ;; arch-tag: 47e26701-43c9-4222-bd79-739eac6357a9
472 ;;; avl-tree.el ends here