1 ;;; avl-tree.el --- balanced binary trees, AVL-trees -*- lexical-binding:t -*-
3 ;; Copyright (C) 1995, 2007-2017 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>
8 ;; Toby Cubitt <toby-predictive@dr-qubit.org>
9 ;; Maintainer: emacs-devel@gnu.org
10 ;; Created: 10 May 1991
11 ;; Keywords: extensions, data structures, AVL, tree
13 ;; This file is part of GNU Emacs.
15 ;; GNU Emacs is free software: you can redistribute it and/or modify
16 ;; it under the terms of the GNU General Public License as published by
17 ;; the Free Software Foundation, either version 3 of the License, or
18 ;; (at your option) any later version.
20 ;; GNU Emacs is distributed in the hope that it will be useful,
21 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
23 ;; GNU General Public License for more details.
25 ;; You should have received a copy of the GNU General Public License
26 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
30 ;; An AVL tree is a self-balancing binary tree. As such, inserting,
31 ;; deleting, and retrieving data from an AVL tree containing n elements
32 ;; is O(log n). It is somewhat more rigidly balanced than other
33 ;; self-balancing binary trees (such as red-black trees and AA trees),
34 ;; making insertion slightly slower, deletion somewhat slower, and
35 ;; retrieval somewhat faster (the asymptotic scaling is of course the
36 ;; same for all types). Thus it may be a good choice when the tree will
37 ;; be relatively static, i.e. data will be retrieved more often than
40 ;; Internally, a tree consists of two elements, the root node and the
41 ;; comparison function. The actual tree has a dummy node as its root
42 ;; with the real root in the left pointer, which allows the root node to
43 ;; be treated on a par with all other nodes.
45 ;; Each node of the tree consists of one data element, one left
46 ;; sub-tree, one right sub-tree, and a balance count. The latter is the
47 ;; difference in depth of the left and right sub-trees.
49 ;; The functions with names of the form "avl-tree--" are intended for
54 (eval-when-compile (require 'cl-lib
))
58 ;; ================================================================
59 ;;; Internal functions and macros for use in the AVL tree package
62 ;; ----------------------------------------------------------------
63 ;; Functions and macros handling an AVL tree.
65 (cl-defstruct (avl-tree-
66 ;; A tagged list is the pre-defstruct representation.
70 (:constructor avl-tree--create
(cmpfun))
71 (:predicate avl-tree-p
)
73 (dummyroot (avl-tree--node-create nil nil nil
0))
76 (defmacro avl-tree--root
(tree)
77 ;; Return the root node for an AVL tree. INTERNAL USE ONLY.
78 `(avl-tree--node-left (avl-tree--dummyroot ,tree
)))
80 ;; ----------------------------------------------------------------
81 ;; Functions and macros handling an AVL tree node.
83 (cl-defstruct (avl-tree--node
84 ;; We force a representation without tag so it matches the
85 ;; pre-defstruct representation. Also we use the underlying
86 ;; representation in the implementation of
87 ;; avl-tree--node-branch.
90 (:constructor avl-tree--node-create
(left right data balance
))
92 left right data balance
)
95 (defalias 'avl-tree--node-branch
#'aref
96 ;; This implementation is efficient but breaks the defstruct
97 ;; abstraction. An alternative could be (funcall (aref [avl-tree-left
98 ;; avl-tree-right avl-tree-data] branch) node)
99 "Get value of a branch of a node.
100 NODE is the node, and BRANCH is the branch.
101 0 for left pointer, 1 for right pointer and 2 for the data.
105 ;; The funcall/aref trick wouldn't work for the setf method, unless we
106 ;; tried to access the underlying setter function, but this wouldn't be
108 (gv-define-simple-setter avl-tree--node-branch aset
)
112 ;; ----------------------------------------------------------------
113 ;; Convenience macros
115 (defmacro avl-tree--switch-dir
(dir)
116 "Return opposite direction to DIR (0 = left, 1 = right)."
119 (defmacro avl-tree--dir-to-sign
(dir)
120 "Convert direction (0,1) to sign factor (-1,+1)."
123 (defmacro avl-tree--sign-to-dir
(dir)
124 "Convert sign factor (-x,+x) to direction (0,1)."
125 `(if (< ,dir
0) 0 1))
128 ;; ----------------------------------------------------------------
131 (defun avl-tree--del-balance (node branch dir
)
132 "Rebalance a tree after deleting a node.
133 The deletion was done from the left (DIR=0) or right (DIR=1) sub-tree of the
134 left (BRANCH=0) or right (BRANCH=1) child of NODE.
135 Return t if the height of the tree has shrunk."
136 ;; (or is it vice-versa for BRANCH?)
137 (let ((br (avl-tree--node-branch node branch
))
138 ;; opposite direction: 0,1 -> 1,0
139 (opp (avl-tree--switch-dir dir
))
140 ;; direction 0,1 -> sign factor -1,+1
141 (sgn (avl-tree--dir-to-sign dir
))
144 ((> (* sgn
(avl-tree--node-balance br
)) 0)
145 (setf (avl-tree--node-balance br
) 0)
148 ((= (avl-tree--node-balance br
) 0)
149 (setf (avl-tree--node-balance br
) (- sgn
))
154 (setq p1
(avl-tree--node-branch br opp
)
155 b1
(avl-tree--node-balance p1
))
156 (if (<= (* sgn b1
) 0)
159 (setf (avl-tree--node-branch br opp
)
160 (avl-tree--node-branch p1 dir
)
161 (avl-tree--node-branch p1 dir
) br
162 (avl-tree--node-branch node branch
) p1
)
165 (setf (avl-tree--node-balance br
) (- sgn
)
166 (avl-tree--node-balance p1
) sgn
)
167 nil
) ; height hasn't changed
168 (setf (avl-tree--node-balance br
) 0)
169 (setf (avl-tree--node-balance p1
) 0)
170 t
)) ; height has changed
173 (setf p2
(avl-tree--node-branch p1 dir
)
174 b2
(avl-tree--node-balance p2
)
175 (avl-tree--node-branch p1 dir
)
176 (avl-tree--node-branch p2 opp
)
177 (avl-tree--node-branch p2 opp
) p1
178 (avl-tree--node-branch br opp
)
179 (avl-tree--node-branch p2 dir
)
180 (avl-tree--node-branch p2 dir
) br
181 (avl-tree--node-balance br
)
182 (if (< (* sgn b2
) 0) sgn
0)
183 (avl-tree--node-balance p1
)
184 (if (> (* sgn b2
) 0) (- sgn
) 0)
185 (avl-tree--node-branch node branch
) p2
186 (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-balance node branch
1))
194 (setf (avl-tree--node-data q
) (avl-tree--node-data br
)
195 (avl-tree--node-branch node branch
)
196 (avl-tree--node-left br
))
199 (defun avl-tree--do-delete (cmpfun root branch data test nilflag
)
200 "Delete DATA from BRANCH of node ROOT.
201 \(See `avl-tree-delete' for TEST and NILFLAG).
203 Return cons cell (SHRUNK . DATA), where SHRUNK is t if the
204 height of the tree has shrunk and nil otherwise, and DATA is
206 (let ((br (avl-tree--node-branch root branch
)))
212 ((funcall cmpfun data
(avl-tree--node-data br
))
213 (let ((ret (avl-tree--do-delete cmpfun br
0 data test nilflag
)))
214 (cons (if (car ret
) (avl-tree--del-balance root branch
0))
217 ((funcall cmpfun
(avl-tree--node-data br
) data
)
218 (let ((ret (avl-tree--do-delete cmpfun br
1 data test nilflag
)))
219 (cons (if (car ret
) (avl-tree--del-balance root branch
1))
223 ;; if it fails TEST, do nothing
224 (if (and test
(not (funcall test
(avl-tree--node-data br
))))
227 ((null (avl-tree--node-right br
))
228 (setf (avl-tree--node-branch root branch
)
229 (avl-tree--node-left br
))
230 (cons t
(avl-tree--node-data br
)))
232 ((null (avl-tree--node-left br
))
233 (setf (avl-tree--node-branch root branch
)
234 (avl-tree--node-right br
))
235 (cons t
(avl-tree--node-data br
)))
238 (if (avl-tree--do-del-internal br
0 br
)
239 (cons (avl-tree--del-balance root branch
0)
240 (avl-tree--node-data br
))
241 (cons nil
(avl-tree--node-data br
))))
246 ;; ----------------------------------------------------------------
249 (defun avl-tree--enter-balance (node branch dir
)
250 "Rebalance tree after an insertion
251 into the left (DIR=0) or right (DIR=1) sub-tree of the
252 left (BRANCH=0) or right (BRANCH=1) child of NODE.
253 Return t if the height of the tree has grown."
254 (let ((br (avl-tree--node-branch node branch
))
255 ;; opposite direction: 0,1 -> 1,0
256 (opp (avl-tree--switch-dir dir
))
257 ;; direction 0,1 -> sign factor -1,+1
258 (sgn (avl-tree--dir-to-sign dir
))
261 ((< (* sgn
(avl-tree--node-balance br
)) 0)
262 (setf (avl-tree--node-balance br
) 0)
265 ((= (avl-tree--node-balance br
) 0)
266 (setf (avl-tree--node-balance br
) sgn
)
270 ;; Tree has grown => Rebalance.
271 (setq p1
(avl-tree--node-branch br dir
))
272 (if (> (* sgn
(avl-tree--node-balance p1
)) 0)
275 (setf (avl-tree--node-branch br dir
)
276 (avl-tree--node-branch p1 opp
))
277 (setf (avl-tree--node-branch p1 opp
) br
)
278 (setf (avl-tree--node-balance br
) 0)
279 (setf (avl-tree--node-branch node branch
) p1
))
282 (setf p2
(avl-tree--node-branch p1 opp
)
283 b2
(avl-tree--node-balance p2
)
284 (avl-tree--node-branch p1 opp
)
285 (avl-tree--node-branch p2 dir
)
286 (avl-tree--node-branch p2 dir
) p1
287 (avl-tree--node-branch br dir
)
288 (avl-tree--node-branch p2 opp
)
289 (avl-tree--node-branch p2 opp
) br
290 (avl-tree--node-balance br
)
291 (if (> (* sgn b2
) 0) (- sgn
) 0)
292 (avl-tree--node-balance p1
)
293 (if (< (* sgn b2
) 0) sgn
0)
294 (avl-tree--node-branch node branch
) p2
))
295 (setf (avl-tree--node-balance
296 (avl-tree--node-branch node branch
))
300 (defun avl-tree--do-enter (cmpfun root branch data
&optional updatefun
)
301 "Enter DATA in BRANCH of ROOT node.
302 \(See `avl-tree-enter' for UPDATEFUN).
304 Return cons cell (GREW . DATA), where GREW is t if height
305 of tree ROOT has grown and nil otherwise, and DATA is the
307 (let ((br (avl-tree--node-branch root branch
)))
310 ;; Data not in tree, insert it.
311 (setf (avl-tree--node-branch root branch
)
312 (avl-tree--node-create nil nil data
0))
315 ((funcall cmpfun data
(avl-tree--node-data br
))
316 (let ((ret (avl-tree--do-enter cmpfun br
0 data updatefun
)))
317 (cons (and (car ret
) (avl-tree--enter-balance root branch
0))
320 ((funcall cmpfun
(avl-tree--node-data br
) data
)
321 (let ((ret (avl-tree--do-enter cmpfun br
1 data updatefun
)))
322 (cons (and (car ret
) (avl-tree--enter-balance root branch
1))
325 ;; Data already in tree, update it.
329 (funcall updatefun data
(avl-tree--node-data br
))
331 (if (or (funcall cmpfun newdata data
)
332 (funcall cmpfun data newdata
))
333 (error "avl-tree-enter:\
334 updated data does not match existing data"))
335 (setf (avl-tree--node-data br
) newdata
)
336 (cons nil newdata
)) ; return value
339 (defun avl-tree--check (tree)
340 "Check the tree's balance."
341 (avl-tree--check-node (avl-tree--root tree
)))
342 (defun avl-tree--check-node (node)
344 (let ((dl (avl-tree--check-node (avl-tree--node-left node
)))
345 (dr (avl-tree--check-node (avl-tree--node-right node
))))
346 (cl-assert (= (- dr dl
) (avl-tree--node-balance node
)))
349 ;; ----------------------------------------------------------------
352 ;;; INTERNAL USE ONLY
353 (defun avl-tree--mapc (map-function root dir
)
354 "Apply MAP-FUNCTION to all nodes in the tree starting with ROOT.
355 The function is applied in-order, either ascending (DIR=0) or
358 Note: MAP-FUNCTION is applied to the node and not to the data
366 (avl-tree--node-branch node dir
))
367 ;; Do the DIR subtree first.
370 (setq node
(avl-tree--node-branch node dir
)))
371 ;; Apply the function...
372 (funcall map-function node
)
373 ;; and do the opposite subtree.
374 (setq node
(if (setq go-dir
(avl-tree--node-branch
375 node
(avl-tree--switch-dir dir
)))
376 (avl-tree--node-branch
377 node
(avl-tree--switch-dir dir
))
380 ;;; INTERNAL USE ONLY
381 (defun avl-tree--do-copy (root)
382 "Copy the AVL tree with ROOT as root. Highly recursive."
385 (avl-tree--node-create
386 (avl-tree--do-copy (avl-tree--node-left root
))
387 (avl-tree--do-copy (avl-tree--node-right root
))
388 (avl-tree--node-data root
)
389 (avl-tree--node-balance root
))))
391 (cl-defstruct (avl-tree--stack
393 (:constructor avl-tree--stack-create
394 (tree &optional reverse
397 (if (avl-tree-empty tree
)
399 (list (avl-tree--root tree
))))))
403 (defalias 'avl-tree-stack-p
#'avl-tree--stack-p
404 "Return t if OBJ is an avl-tree-stack, nil otherwise.
407 (defun avl-tree--stack-repopulate (stack)
408 ;; Recursively push children of the node at the head of STACK onto the
409 ;; front of the STACK, until a leaf is reached.
410 (let ((node (car (avl-tree--stack-store stack
)))
411 (dir (if (avl-tree--stack-reverse stack
) 1 0)))
412 (when node
; check for empty stack
413 (while (setq node
(avl-tree--node-branch node dir
))
414 (push node
(avl-tree--stack-store stack
))))))
417 ;; ================================================================
418 ;;; The public functions which operate on AVL trees.
420 ;; define public alias for constructors so that we can set docstring
421 (defalias 'avl-tree-create
#'avl-tree--create
422 "Create an empty AVL tree.
423 COMPARE-FUNCTION is a function which takes two arguments, A and B,
424 and returns non-nil if A is less than B, and nil otherwise.
425 \n(fn COMPARE-FUNCTION)")
427 (defalias 'avl-tree-compare-function
#'avl-tree--cmpfun
428 "Return the comparison function for the AVL tree TREE.
431 (defun avl-tree-empty (tree)
432 "Return t if AVL tree TREE is empty, otherwise return nil."
433 (null (avl-tree--root tree
)))
435 (defun avl-tree-enter (tree data
&optional updatefun
)
436 "Insert DATA into the AVL tree TREE.
438 If an element that matches DATA (according to the tree's
439 comparison function, see `avl-tree-create') already exists in
440 TREE, it will be replaced by DATA by default.
442 If UPDATEFUN is supplied and an element matching DATA already
443 exists in TREE, UPDATEFUN is called with two arguments: DATA, and
444 the matching element. Its return value replaces the existing
445 element. This value *must* itself match DATA (and hence the
446 pre-existing data), or an error will occur.
448 Returns the new data."
449 (cdr (avl-tree--do-enter (avl-tree--cmpfun tree
)
450 (avl-tree--dummyroot tree
)
453 (defun avl-tree-delete (tree data
&optional test nilflag
)
454 "Delete the element matching DATA from the AVL tree TREE.
455 Matching uses the comparison function previously specified in
456 `avl-tree-create' when TREE was created.
458 Returns the deleted element, or nil if no matching element was
461 Optional argument NILFLAG specifies a value to return instead of
462 nil if nothing was deleted, so that this case can be
463 distinguished from the case of a successfully deleted null
466 If supplied, TEST specifies a test that a matching element must
467 pass before it is deleted. If a matching element is found, it is
468 passed as an argument to TEST, and is deleted only if the return
470 (cdr (avl-tree--do-delete (avl-tree--cmpfun tree
)
471 (avl-tree--dummyroot tree
)
472 0 data test nilflag
)))
475 (defun avl-tree-member (tree data
&optional nilflag
)
476 "Return the element in the AVL tree TREE which matches DATA.
477 Matching uses the comparison function previously specified in
478 `avl-tree-create' when TREE was created.
480 If there is no such element in the tree, nil is
481 returned. Optional argument NILFLAG specifies a value to return
482 instead of nil in this case. This allows non-existent elements to
483 be distinguished from a null element. (See also
484 `avl-tree-member-p', which does this for you.)"
485 (let ((node (avl-tree--root tree
))
486 (compare-function (avl-tree--cmpfun tree
)))
490 ((funcall compare-function data
(avl-tree--node-data node
))
491 (setq node
(avl-tree--node-left node
)))
492 ((funcall compare-function
(avl-tree--node-data node
) data
)
493 (setq node
(avl-tree--node-right node
)))
494 (t (throw 'found
(avl-tree--node-data node
)))))
498 (defun avl-tree-member-p (tree data
)
499 "Return t if an element matching DATA exists in the AVL tree TREE.
500 Otherwise return nil. Matching uses the comparison function
501 previously specified in `avl-tree-create' when TREE was created."
503 (not (eq (avl-tree-member tree data flag
) flag
))))
506 (defun avl-tree-map (fun tree
&optional reverse
)
507 "Modify all elements in the AVL tree TREE by applying FUNCTION.
509 Each element is replaced by the return value of FUNCTION applied
512 FUNCTION is applied to the elements in ascending order, or
513 descending order if REVERSE is non-nil."
516 (setf (avl-tree--node-data node
)
517 (funcall fun
(avl-tree--node-data node
))))
518 (avl-tree--root tree
)
522 (defun avl-tree-mapc (fun tree
&optional reverse
)
523 "Apply FUNCTION to all elements in AVL tree TREE,
524 for side-effect only.
526 FUNCTION is applied to the elements in ascending order, or
527 descending order if REVERSE is non-nil."
530 (funcall fun
(avl-tree--node-data node
)))
531 (avl-tree--root tree
)
536 (fun combinator tree
&optional reverse
)
537 "Apply FUNCTION to all elements in AVL tree TREE,
538 and combine the results using COMBINATOR.
540 The FUNCTION is applied and the results are combined in ascending
541 order, or descending order if REVERSE is non-nil."
542 (let (avl-tree-mapf--accumulate)
545 (setq avl-tree-mapf--accumulate
548 (avl-tree--node-data node
))
549 avl-tree-mapf--accumulate
)))
550 (avl-tree--root tree
)
552 (nreverse avl-tree-mapf--accumulate
)))
555 (defun avl-tree-mapcar (fun tree
&optional reverse
)
556 "Apply FUNCTION to all elements in AVL tree TREE,
557 and make a list of the results.
559 The FUNCTION is applied and the list constructed in ascending
560 order, or descending order if REVERSE is non-nil.
562 Note that if you don't care about the order in which FUNCTION is
563 applied, just that the resulting list is in the correct order,
566 (avl-tree-mapf function \\='cons tree (not reverse))
569 (nreverse (avl-tree-mapf fun
'cons tree reverse
)))
572 (defun avl-tree-first (tree)
573 "Return the first element in TREE, or nil if TREE is empty."
574 (let ((node (avl-tree--root tree
)))
576 (while (avl-tree--node-left node
)
577 (setq node
(avl-tree--node-left node
)))
578 (avl-tree--node-data node
))))
580 (defun avl-tree-last (tree)
581 "Return the last element in TREE, or nil if TREE is empty."
582 (let ((node (avl-tree--root tree
)))
584 (while (avl-tree--node-right node
)
585 (setq node
(avl-tree--node-right node
)))
586 (avl-tree--node-data node
))))
588 (defun avl-tree-copy (tree)
589 "Return a copy of the AVL tree TREE."
590 (let ((new-tree (avl-tree-create (avl-tree--cmpfun tree
))))
591 (setf (avl-tree--root new-tree
) (avl-tree--do-copy (avl-tree--root tree
)))
594 (defun avl-tree-flatten (tree)
595 "Return a sorted list containing all elements of TREE."
596 (let ((treelist nil
))
598 (lambda (node) (push (avl-tree--node-data node
) treelist
))
599 (avl-tree--root tree
) 1)
602 (defun avl-tree-size (tree)
603 "Return the number of elements in TREE."
606 (lambda (_) (setq treesize
(1+ treesize
)))
607 (avl-tree--root tree
) 0)
610 (defun avl-tree-clear (tree)
611 "Clear the AVL tree TREE."
612 (setf (avl-tree--root tree
) nil
))
615 (defun avl-tree-stack (tree &optional reverse
)
616 "Return an object that behaves like a sorted stack
617 of all elements of TREE.
619 If REVERSE is non-nil, the stack is sorted in reverse order.
620 \(See also `avl-tree-stack-pop').
622 Note that any modification to TREE *immediately* invalidates all
623 avl-tree-stacks created before the modification (in particular,
624 calling `avl-tree-stack-pop' will give unpredictable results).
626 Operations on these objects are significantly more efficient than
627 constructing a real stack with `avl-tree-flatten' and using
628 standard stack functions. As such, they can be useful in
629 implementing efficient algorithms of AVL trees. However, in cases
630 where mapping functions `avl-tree-mapc', `avl-tree-mapcar' or
631 `avl-tree-mapf' would be sufficient, it is better to use one of
633 (let ((stack (avl-tree--stack-create tree reverse
)))
634 (avl-tree--stack-repopulate stack
)
638 (defun avl-tree-stack-pop (avl-tree-stack &optional nilflag
)
639 "Pop the first element from AVL-TREE-STACK.
640 \(See also `avl-tree-stack').
642 Returns nil if the stack is empty, or NILFLAG if specified.
643 \(The latter allows an empty stack to be distinguished from
644 a null element stored in the AVL tree.)"
646 (if (not (setq node
(pop (avl-tree--stack-store avl-tree-stack
))))
649 (avl-tree--node-branch
651 (if (avl-tree--stack-reverse avl-tree-stack
) 0 1)))
652 (push next
(avl-tree--stack-store avl-tree-stack
))
653 (avl-tree--stack-repopulate avl-tree-stack
))
654 (avl-tree--node-data node
))))
657 (defun avl-tree-stack-first (avl-tree-stack &optional nilflag
)
658 "Return the first element of AVL-TREE-STACK, without removing it
661 Returns nil if the stack is empty, or NILFLAG if specified.
662 \(The latter allows an empty stack to be distinguished from
663 a null element stored in the AVL tree.)"
664 (or (car (avl-tree--stack-store avl-tree-stack
))
668 (defun avl-tree-stack-empty-p (avl-tree-stack)
669 "Return t if AVL-TREE-STACK is empty, nil otherwise."
670 (null (avl-tree--stack-store avl-tree-stack
)))
675 ;;; avl-tree.el ends here