-;;; avl-tree.el --- balanced binary trees, AVL-trees
-
-;; Copyright (C) 1995, 2007 Free Software Foundation, Inc.
-
-;; Author: Per Cederqvist <ceder@lysator.liu.se>
-;; Inge Wallin <inge@lysator.liu.se>
-;; Thomas Bellman <bellman@lysator.liu.se>
-;; Maintainer: FSF
-;; Created: 10 May 1991
-;; Keywords: extensions, data structures
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 3, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
-
-;;; Commentary:
-
-;; This file combines elib-node.el and avltree.el from Elib.
-;;
-;; * Comments from elib-node.el
-;; A node is implemented as an array with three elements, using
-;; (elt node 0) as the left pointer
-;; (elt node 1) as the right pointer
-;; (elt node 2) as the data
-;;
-;; Some types of trees, e.g. AVL trees, need bigger nodes, but
-;; as long as the first three parts are the left pointer, the
-;; right pointer and the data field, these macros can be used.
-;;
-;; * Comments from avltree.el
-;; An AVL tree is a nearly-perfect balanced binary tree. A tree
-;; consists of two cons cells, the first one holding the tag
-;; 'AVL-TREE in the car cell, and the second one having the tree
-;; in the car and the compare function in the cdr cell. The tree has
-;; a dummy node as its root with the real tree in the left pointer.
-;;
-;; Each node of the tree consists of one data element, one left
-;; sub-tree and one right sub-tree. Each node also has a balance
-;; count, which is the difference in depth of the left and right
-;; sub-trees.
-
-;;; Code:
-
-(defmacro elib-node-left (node)
- ;; Return the left pointer of NODE.
- `(aref ,node 0))
-
-(defmacro elib-node-right (node)
- ;; Return the right pointer of NODE.
- `(aref ,node 1))
-
-(defmacro elib-node-data (node)
- ;; Return the data of NODE.
- `(aref ,node 2))
-
-(defmacro elib-node-set-left (node newleft)
- ;; Set the left pointer of NODE to NEWLEFT.
- `(aset ,node 0 ,newleft))
-
-(defmacro elib-node-set-right (node newright)
- ;; Set the right pointer of NODE to NEWRIGHT.
- `(aset ,node 1 ,newright))
-
-(defmacro elib-node-set-data (node newdata)
- ;; Set the data of NODE to NEWDATA.
- `(aset ,node 2 ,newdata))
-
-(defmacro elib-node-branch (node branch)
- ;; Get value of a branch of a node.
- ;;
- ;; NODE is the node, and BRANCH is the branch.
- ;; 0 for left pointer, 1 for right pointer and 2 for the data."
- `(aref ,node ,branch))
-
-(defmacro elib-node-set-branch (node branch newval)
- ;; Set value of a branch of a node.
- ;;
- ;; NODE is the node, and BRANCH is the branch.
- ;; 0 for left pointer, 1 for the right pointer and 2 for the data.
- ;; NEWVAL is new value of the branch."
- `(aset ,node ,branch ,newval))
-
-;;; ================================================================
-;;; Functions and macros handling an AVL tree node.
-
-(defmacro elib-avl-node-create (left right data balance)
- ;; Create and return an avl-tree node.
- `(vector ,left ,right ,data ,balance))
-
-(defmacro elib-avl-node-balance (node)
- ;; Return the balance field of a node.
- `(aref ,node 3))
-
-(defmacro elib-avl-node-set-balance (node newbal)
- ;; Set the balance field of a node.
- `(aset ,node 3 ,newbal))
-
-\f
-;;; ================================================================
-;;; Internal functions for use in the AVL tree package
-
-;;;
-;;; The functions and macros in this section all start with `elib-avl-'.
-;;;
-
-(defmacro elib-avl-root (tree)
- ;; Return the root node for an avl-tree. INTERNAL USE ONLY.
- `(elib-node-left (car (cdr ,tree))))
-
-(defmacro elib-avl-dummyroot (tree)
- ;; Return the dummy node of an avl-tree. INTERNAL USE ONLY.
- `(car (cdr ,tree)))
-
-(defmacro elib-avl-cmpfun (tree)
- ;; Return the compare function of AVL tree TREE. INTERNAL USE ONLY.
- `(cdr (cdr ,tree)))
-
-;; ----------------------------------------------------------------
-;; Deleting data
-
-(defun elib-avl-del-balance1 (node branch)
- ;; Rebalance a tree and return t if the height of the tree has shrunk.
- (let* ((br (elib-node-branch node branch))
- p1
- b1
- p2
- b2
- result)
- (cond
- ((< (elib-avl-node-balance br) 0)
- (elib-avl-node-set-balance br 0)
- t)
-
- ((= (elib-avl-node-balance br) 0)
- (elib-avl-node-set-balance br +1)
- nil)
-
- (t
- ;; Rebalance.
- (setq p1 (elib-node-right br)
- b1 (elib-avl-node-balance p1))
- (if (>= b1 0)
- ;; Single RR rotation.
- (progn
- (elib-node-set-right br (elib-node-left p1))
- (elib-node-set-left p1 br)
- (if (= 0 b1)
- (progn
- (elib-avl-node-set-balance br +1)
- (elib-avl-node-set-balance p1 -1)
- (setq result nil))
- (elib-avl-node-set-balance br 0)
- (elib-avl-node-set-balance p1 0)
- (setq result t))
- (elib-node-set-branch node branch p1)
- result)
-
- ;; Double RL rotation.
- (setq p2 (elib-node-left p1)
- b2 (elib-avl-node-balance p2))
- (elib-node-set-left p1 (elib-node-right p2))
- (elib-node-set-right p2 p1)
- (elib-node-set-right br (elib-node-left p2))
- (elib-node-set-left p2 br)
- (if (> b2 0)
- (elib-avl-node-set-balance br -1)
- (elib-avl-node-set-balance br 0))
- (if (< b2 0)
- (elib-avl-node-set-balance p1 +1)
- (elib-avl-node-set-balance p1 0))
- (elib-node-set-branch node branch p2)
- (elib-avl-node-set-balance p2 0)
- t)))))
-
-(defun elib-avl-del-balance2 (node branch)
- (let* ((br (elib-node-branch node branch))
- p1
- b1
- p2
- b2
- result)
- (cond
- ((> (elib-avl-node-balance br) 0)
- (elib-avl-node-set-balance br 0)
- t)
-
- ((= (elib-avl-node-balance br) 0)
- (elib-avl-node-set-balance br -1)
- nil)
-
- (t
- ;; Rebalance.
- (setq p1 (elib-node-left br)
- b1 (elib-avl-node-balance p1))
- (if (<= b1 0)
- ;; Single LL rotation.
- (progn
- (elib-node-set-left br (elib-node-right p1))
- (elib-node-set-right p1 br)
- (if (= 0 b1)
- (progn
- (elib-avl-node-set-balance br -1)
- (elib-avl-node-set-balance p1 +1)
- (setq result nil))
- (elib-avl-node-set-balance br 0)
- (elib-avl-node-set-balance p1 0)
- (setq result t))
- (elib-node-set-branch node branch p1)
- result)
-
- ;; Double LR rotation.
- (setq p2 (elib-node-right p1)
- b2 (elib-avl-node-balance p2))
- (elib-node-set-right p1 (elib-node-left p2))
- (elib-node-set-left p2 p1)
- (elib-node-set-left br (elib-node-right p2))
- (elib-node-set-right p2 br)
- (if (< b2 0)
- (elib-avl-node-set-balance br +1)
- (elib-avl-node-set-balance br 0))
- (if (> b2 0)
- (elib-avl-node-set-balance p1 -1)
- (elib-avl-node-set-balance p1 0))
- (elib-node-set-branch node branch p2)
- (elib-avl-node-set-balance p2 0)
- t)))))
-
-(defun elib-avl-do-del-internal (node branch q)
-
- (let* ((br (elib-node-branch node branch)))
- (if (elib-node-right br)
- (if (elib-avl-do-del-internal br +1 q)
- (elib-avl-del-balance2 node branch))
- (elib-node-set-data q (elib-node-data br))
- (elib-node-set-branch node branch
- (elib-node-left br))
- t)))
-
-(defun elib-avl-do-delete (cmpfun root branch data)
- ;; Return t if the height of the tree has shrunk.
- (let* ((br (elib-node-branch root branch)))
- (cond
- ((null br)
- nil)
-
- ((funcall cmpfun data (elib-node-data br))
- (if (elib-avl-do-delete cmpfun br 0 data)
- (elib-avl-del-balance1 root branch)))
-
- ((funcall cmpfun (elib-node-data br) data)
- (if (elib-avl-do-delete cmpfun br 1 data)
- (elib-avl-del-balance2 root branch)))
-
- (t
- ;; Found it. Let's delete it.
- (cond
- ((null (elib-node-right br))
- (elib-node-set-branch root branch (elib-node-left br))
- t)
-
- ((null (elib-node-left br))
- (elib-node-set-branch root branch (elib-node-right br))
- t)
-
- (t
- (if (elib-avl-do-del-internal br 0 br)
- (elib-avl-del-balance1 root branch))))))))
-
-;; ----------------------------------------------------------------
-;; Entering data
-
-(defun elib-avl-enter-balance1 (node branch)
- ;; Rebalance a tree and return t if the height of the tree has grown.
- (let* ((br (elib-node-branch node branch))
- p1
- p2
- b2
- result)
- (cond
- ((< (elib-avl-node-balance br) 0)
- (elib-avl-node-set-balance br 0)
- nil)
-
- ((= (elib-avl-node-balance br) 0)
- (elib-avl-node-set-balance br +1)
- t)
-
- (t
- ;; Tree has grown => Rebalance.
- (setq p1 (elib-node-right br))
- (if (> (elib-avl-node-balance p1) 0)
- ;; Single RR rotation.
- (progn
- (elib-node-set-right br (elib-node-left p1))
- (elib-node-set-left p1 br)
- (elib-avl-node-set-balance br 0)
- (elib-node-set-branch node branch p1))
-
- ;; Double RL rotation.
- (setq p2 (elib-node-left p1)
- b2 (elib-avl-node-balance p2))
- (elib-node-set-left p1 (elib-node-right p2))
- (elib-node-set-right p2 p1)
- (elib-node-set-right br (elib-node-left p2))
- (elib-node-set-left p2 br)
- (if (> b2 0)
- (elib-avl-node-set-balance br -1)
- (elib-avl-node-set-balance br 0))
- (if (< b2 0)
- (elib-avl-node-set-balance p1 +1)
- (elib-avl-node-set-balance p1 0))
- (elib-node-set-branch node branch p2))
- (elib-avl-node-set-balance (elib-node-branch node branch) 0)
- nil))))
-
-(defun elib-avl-enter-balance2 (node branch)
- ;; Return t if the tree has grown.
- (let* ((br (elib-node-branch node branch))
- p1
- p2
- b2)
- (cond
- ((> (elib-avl-node-balance br) 0)
- (elib-avl-node-set-balance br 0)
- nil)
-
- ((= (elib-avl-node-balance br) 0)
- (elib-avl-node-set-balance br -1)
- t)
-
- (t
- ;; Balance was -1 => Rebalance.
- (setq p1 (elib-node-left br))
- (if (< (elib-avl-node-balance p1) 0)
- ;; Single LL rotation.
- (progn
- (elib-node-set-left br (elib-node-right p1))
- (elib-node-set-right p1 br)
- (elib-avl-node-set-balance br 0)
- (elib-node-set-branch node branch p1))
-
- ;; Double LR rotation.
- (setq p2 (elib-node-right p1)
- b2 (elib-avl-node-balance p2))
- (elib-node-set-right p1 (elib-node-left p2))
- (elib-node-set-left p2 p1)
- (elib-node-set-left br (elib-node-right p2))
- (elib-node-set-right p2 br)
- (if (< b2 0)
- (elib-avl-node-set-balance br +1)
- (elib-avl-node-set-balance br 0))
- (if (> b2 0)
- (elib-avl-node-set-balance p1 -1)
- (elib-avl-node-set-balance p1 0))
- (elib-node-set-branch node branch p2))
- (elib-avl-node-set-balance (elib-node-branch node branch) 0)
- nil))))
-
-(defun elib-avl-do-enter (cmpfun root branch data)
- ;; Return t if height of tree ROOT has grown. INTERNAL USE ONLY.
- (let ((br (elib-node-branch root branch)))
- (cond
- ((null br)
- ;; Data not in tree, insert it.
- (elib-node-set-branch root branch
- (elib-avl-node-create nil nil data 0))
- t)
-
- ((funcall cmpfun data (elib-node-data br))
- (and (elib-avl-do-enter cmpfun
- br
- 0 data)
- (elib-avl-enter-balance2 root branch)))
-
- ((funcall cmpfun (elib-node-data br) data)
- (and (elib-avl-do-enter cmpfun
- br
- 1 data)
- (elib-avl-enter-balance1 root branch)))
-
- (t
- (elib-node-set-data br data)
- nil))))
-
-;; ----------------------------------------------------------------
-
-(defun elib-avl-mapc (map-function root)
- ;; Apply MAP-FUNCTION to all nodes in the tree starting with ROOT.
- ;; The function is applied in-order.
- ;;
- ;; Note: MAP-FUNCTION is applied to the node and not to the data itself.
- ;; INTERNAL USE ONLY.
- (let ((node root)
- (stack nil)
- (go-left t))
- (push nil stack)
- (while node
- (if (and go-left
- (elib-node-left node))
- ;; Do the left subtree first.
- (progn
- (push node stack)
- (setq node (elib-node-left node)))
- ;; Apply the function...
- (funcall map-function node)
- ;; and do the right subtree.
- (if (elib-node-right node)
- (setq node (elib-node-right node)
- go-left t)
- (setq node (pop stack)
- go-left nil))))))
-
-(defun elib-avl-do-copy (root)
- ;; Copy the tree with ROOT as root.
- ;; Highly recursive. INTERNAL USE ONLY.
- (if (null root)
- nil
- (elib-avl-node-create (elib-avl-do-copy (elib-node-left root))
- (elib-avl-do-copy (elib-node-right root))
- (elib-node-data root)
- (elib-avl-node-balance root))))
-
-\f
-;;; ================================================================
-;;; The public functions which operate on AVL trees.
-
-(defun avl-tree-create (compare-function)
- "Create an empty avl tree.
-COMPARE-FUNCTION is a function which takes two arguments, A and B,
-and returns non-nil if A is less than B, and nil otherwise."
- (cons 'AVL-TREE
- (cons (elib-avl-node-create nil nil nil 0)
- compare-function)))
-
-(defun avl-tree-p (obj)
- "Return t if OBJ is an avl tree, nil otherwise."
- (eq (car-safe obj) 'AVL-TREE))
-
-(defun avl-tree-compare-function (tree)
- "Return the comparision function for the avl tree TREE."
- (elib-avl-cmpfun tree))
-
-(defun avl-tree-empty (tree)
- "Return t if TREE is emtpy, otherwise return nil."
- (null (elib-avl-root tree)))
-
-(defun avl-tree-enter (tree data)
- "In the avl tree TREE insert DATA.
-Return DATA."
- (elib-avl-do-enter (elib-avl-cmpfun tree)
- (elib-avl-dummyroot tree)
- 0
- data)
- data)
-
-(defun avl-tree-delete (tree data)
- "From the avl tree TREE, delete DATA.
-Return the element in TREE which matched DATA, nil if no element matched."
- (elib-avl-do-delete (elib-avl-cmpfun tree)
- (elib-avl-dummyroot tree)
- 0
- data))
-
-(defun avl-tree-member (tree data)
- "Return the element in the avl tree TREE which matches DATA.
-Matching uses the compare function previously specified in `avl-tree-create'
-when TREE was created.
-
-If there is no such element in the tree, the value is nil."
- (let ((node (elib-avl-root tree))
- (compare-function (elib-avl-cmpfun tree))
- found)
- (while (and node
- (not found))
- (cond
- ((funcall compare-function data (elib-node-data node))
- (setq node (elib-node-left node)))
- ((funcall compare-function (elib-node-data node) data)
- (setq node (elib-node-right node)))
- (t
- (setq found t))))
-
- (if node
- (elib-node-data node)
- nil)))
-
-(defun avl-tree-map (__map-function__ tree)
- "Apply MAP-FUNCTION to all elements in the avl tree TREE."
- (elib-avl-mapc
- (function (lambda (node)
- (elib-node-set-data node
- (funcall __map-function__
- (elib-node-data node)))))
- (elib-avl-root tree)))
-
-(defun avl-tree-first (tree)
- "Return the first element in TREE, or nil if TREE is empty."
- (let ((node (elib-avl-root tree)))
- (if node
- (progn
- (while (elib-node-left node)
- (setq node (elib-node-left node)))
- (elib-node-data node))
- nil)))
-
-(defun avl-tree-last (tree)
- "Return the last element in TREE, or nil if TREE is empty."
- (let ((node (elib-avl-root tree)))
- (if node
- (progn
- (while (elib-node-right node)
- (setq node (elib-node-right node)))
- (elib-node-data node))
- nil)))
-
-(defun avl-tree-copy (tree)
- "Return a copy of the avl tree TREE."
- (let ((new-tree (avl-tree-create
- (elib-avl-cmpfun tree))))
- (elib-node-set-left (elib-avl-dummyroot new-tree)
- (elib-avl-do-copy (elib-avl-root tree)))
- new-tree))
-
-(defun avl-tree-flatten (tree)
- "Return a sorted list containing all elements of TREE."
- (nreverse
- (let ((treelist nil))
- (elib-avl-mapc (function (lambda (node)
- (setq treelist (cons (elib-node-data node)
- treelist))))
- (elib-avl-root tree))
- treelist)))
-
-(defun avl-tree-size (tree)
- "Return the number of elements in TREE."
- (let ((treesize 0))
- (elib-avl-mapc (function (lambda (data)
- (setq treesize (1+ treesize))
- data))
- (elib-avl-root tree))
- treesize))
-
-(defun avl-tree-clear (tree)
- "Clear the avl tree TREE."
- (elib-node-set-left (elib-avl-dummyroot tree) nil))
-
-(provide 'avl-tree)
-
-;; arch-tag: 47e26701-43c9-4222-bd79-739eac6357a9
-;;; avl-tree.el ends here
+;;; avl-tree.el --- balanced binary trees, AVL-trees
+
+;; Copyright (C) 1995, 2007, 2008 Free Software Foundation, Inc.
+
+;; Author: Per Cederqvist <ceder@lysator.liu.se>
+;; Inge Wallin <inge@lysator.liu.se>
+;; Thomas Bellman <bellman@lysator.liu.se>
+;; Maintainer: FSF
+;; Created: 10 May 1991
+;; Keywords: extensions, data structures
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; An AVL tree is a nearly-perfect balanced binary tree. A tree consists of
+;; two elements, the root node and the compare function. The actual tree
+;; has a dummy node as its root with the real root in the left pointer.
+;;
+;; Each node of the tree consists of one data element, one left
+;; sub-tree and one right sub-tree. Each node also has a balance
+;; count, which is the difference in depth of the left and right
+;; sub-trees.
+;;
+;; The functions with names of the form "avl-tree--" are intended for
+;; internal use only.
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+;; ================================================================
+;;; Functions and macros handling an AVL tree node.
+
+(defstruct (avl-tree--node
+ ;; We force a representation without tag so it matches the
+ ;; pre-defstruct representation. Also we use the underlying
+ ;; representation in the implementation of avl-tree--node-branch.
+ (:type vector)
+ (:constructor nil)
+ (:constructor avl-tree--node-create (left right data balance))
+ (:copier nil))
+ left right data balance)
+
+(defalias 'avl-tree--node-branch 'aref
+ ;; This implementation is efficient but breaks the defstruct abstraction.
+ ;; An alternative could be
+ ;; (funcall (aref [avl-tree-left avl-tree-right avl-tree-data] branch) node)
+ "Get value of a branch of a node.
+
+NODE is the node, and BRANCH is the branch.
+0 for left pointer, 1 for right pointer and 2 for the data.\"
+\(fn node branch)")
+;; The funcall/aref trick doesn't work for the setf method, unless we try
+;; and access the underlying setter function, but this wouldn't be
+;; portable either.
+(defsetf avl-tree--node-branch aset)
+
+\f
+;; ================================================================
+;;; Internal functions for use in the AVL tree package
+
+(defstruct (avl-tree-
+ ;; A tagged list is the pre-defstruct representation.
+ ;; (:type list)
+ :named
+ (:constructor nil)
+ (:constructor avl-tree-create (cmpfun))
+ (:predicate avl-tree-p)
+ (:copier nil))
+ (dummyroot (avl-tree--node-create nil nil nil 0))
+ cmpfun)
+
+(defmacro avl-tree--root (tree)
+ ;; Return the root node for an avl-tree. INTERNAL USE ONLY.
+ `(avl-tree--node-left (avl-tree--dummyroot tree)))
+(defsetf avl-tree--root (tree) (node)
+ `(setf (avl-tree--node-left (avl-tree--dummyroot ,tree)) ,node))
+
+;; ----------------------------------------------------------------
+;; Deleting data
+
+(defun avl-tree--del-balance1 (node branch)
+ ;; Rebalance a tree and return t if the height of the tree has shrunk.
+ (let ((br (avl-tree--node-branch node branch))
+ p1 b1 p2 b2 result)
+ (cond
+ ((< (avl-tree--node-balance br) 0)
+ (setf (avl-tree--node-balance br) 0)
+ t)
+
+ ((= (avl-tree--node-balance br) 0)
+ (setf (avl-tree--node-balance br) +1)
+ nil)
+
+ (t
+ ;; Rebalance.
+ (setq p1 (avl-tree--node-right br)
+ b1 (avl-tree--node-balance p1))
+ (if (>= b1 0)
+ ;; Single RR rotation.
+ (progn
+ (setf (avl-tree--node-right br) (avl-tree--node-left p1))
+ (setf (avl-tree--node-left p1) br)
+ (if (= 0 b1)
+ (progn
+ (setf (avl-tree--node-balance br) +1)
+ (setf (avl-tree--node-balance p1) -1)
+ (setq result nil))
+ (setf (avl-tree--node-balance br) 0)
+ (setf (avl-tree--node-balance p1) 0)
+ (setq result t))
+ (setf (avl-tree--node-branch node branch) p1)
+ result)
+
+ ;; Double RL rotation.
+ (setq p2 (avl-tree--node-left p1)
+ b2 (avl-tree--node-balance p2))
+ (setf (avl-tree--node-left p1) (avl-tree--node-right p2))
+ (setf (avl-tree--node-right p2) p1)
+ (setf (avl-tree--node-right br) (avl-tree--node-left p2))
+ (setf (avl-tree--node-left p2) br)
+ (setf (avl-tree--node-balance br) (if (> b2 0) -1 0))
+ (setf (avl-tree--node-balance p1) (if (< b2 0) +1 0))
+ (setf (avl-tree--node-branch node branch) p2)
+ (setf (avl-tree--node-balance p2) 0)
+ t)))))
+
+(defun avl-tree--del-balance2 (node branch)
+ (let ((br (avl-tree--node-branch node branch))
+ p1 b1 p2 b2 result)
+ (cond
+ ((> (avl-tree--node-balance br) 0)
+ (setf (avl-tree--node-balance br) 0)
+ t)
+
+ ((= (avl-tree--node-balance br) 0)
+ (setf (avl-tree--node-balance br) -1)
+ nil)
+
+ (t
+ ;; Rebalance.
+ (setq p1 (avl-tree--node-left br)
+ b1 (avl-tree--node-balance p1))
+ (if (<= b1 0)
+ ;; Single LL rotation.
+ (progn
+ (setf (avl-tree--node-left br) (avl-tree--node-right p1))
+ (setf (avl-tree--node-right p1) br)
+ (if (= 0 b1)
+ (progn
+ (setf (avl-tree--node-balance br) -1)
+ (setf (avl-tree--node-balance p1) +1)
+ (setq result nil))
+ (setf (avl-tree--node-balance br) 0)
+ (setf (avl-tree--node-balance p1) 0)
+ (setq result t))
+ (setf (avl-tree--node-branch node branch) p1)
+ result)
+
+ ;; Double LR rotation.
+ (setq p2 (avl-tree--node-right p1)
+ b2 (avl-tree--node-balance p2))
+ (setf (avl-tree--node-right p1) (avl-tree--node-left p2))
+ (setf (avl-tree--node-left p2) p1)
+ (setf (avl-tree--node-left br) (avl-tree--node-right p2))
+ (setf (avl-tree--node-right p2) br)
+ (setf (avl-tree--node-balance br) (if (< b2 0) +1 0))
+ (setf (avl-tree--node-balance p1) (if (> b2 0) -1 0))
+ (setf (avl-tree--node-branch node branch) p2)
+ (setf (avl-tree--node-balance p2) 0)
+ t)))))
+
+(defun avl-tree--do-del-internal (node branch q)
+ (let ((br (avl-tree--node-branch node branch)))
+ (if (avl-tree--node-right br)
+ (if (avl-tree--do-del-internal br +1 q)
+ (avl-tree--del-balance2 node branch))
+ (setf (avl-tree--node-data q) (avl-tree--node-data br))
+ (setf (avl-tree--node-branch node branch)
+ (avl-tree--node-left br))
+ t)))
+
+(defun avl-tree--do-delete (cmpfun root branch data)
+ ;; Return t if the height of the tree has shrunk.
+ (let ((br (avl-tree--node-branch root branch)))
+ (cond
+ ((null br)
+ nil)
+
+ ((funcall cmpfun data (avl-tree--node-data br))
+ (if (avl-tree--do-delete cmpfun br 0 data)
+ (avl-tree--del-balance1 root branch)))
+
+ ((funcall cmpfun (avl-tree--node-data br) data)
+ (if (avl-tree--do-delete cmpfun br 1 data)
+ (avl-tree--del-balance2 root branch)))
+
+ (t
+ ;; Found it. Let's delete it.
+ (cond
+ ((null (avl-tree--node-right br))
+ (setf (avl-tree--node-branch root branch) (avl-tree--node-left br))
+ t)
+
+ ((null (avl-tree--node-left br))
+ (setf (avl-tree--node-branch root branch) (avl-tree--node-right br))
+ t)
+
+ (t
+ (if (avl-tree--do-del-internal br 0 br)
+ (avl-tree--del-balance1 root branch))))))))
+
+;; ----------------------------------------------------------------
+;; Entering data
+
+(defun avl-tree--enter-balance1 (node branch)
+ ;; Rebalance a tree and return t if the height of the tree has grown.
+ (let ((br (avl-tree--node-branch node branch))
+ p1 p2 b2 result)
+ (cond
+ ((< (avl-tree--node-balance br) 0)
+ (setf (avl-tree--node-balance br) 0)
+ nil)
+
+ ((= (avl-tree--node-balance br) 0)
+ (setf (avl-tree--node-balance br) +1)
+ t)
+
+ (t
+ ;; Tree has grown => Rebalance.
+ (setq p1 (avl-tree--node-right br))
+ (if (> (avl-tree--node-balance p1) 0)
+ ;; Single RR rotation.
+ (progn
+ (setf (avl-tree--node-right br) (avl-tree--node-left p1))
+ (setf (avl-tree--node-left p1) br)
+ (setf (avl-tree--node-balance br) 0)
+ (setf (avl-tree--node-branch node branch) p1))
+
+ ;; Double RL rotation.
+ (setq p2 (avl-tree--node-left p1)
+ b2 (avl-tree--node-balance p2))
+ (setf (avl-tree--node-left p1) (avl-tree--node-right p2))
+ (setf (avl-tree--node-right p2) p1)
+ (setf (avl-tree--node-right br) (avl-tree--node-left p2))
+ (setf (avl-tree--node-left p2) br)
+ (setf (avl-tree--node-balance br) (if (> b2 0) -1 0))
+ (setf (avl-tree--node-balance p1) (if (< b2 0) +1 0))
+ (setf (avl-tree--node-branch node branch) p2))
+ (setf (avl-tree--node-balance (avl-tree--node-branch node branch)) 0)
+ nil))))
+
+(defun avl-tree--enter-balance2 (node branch)
+ ;; Return t if the tree has grown.
+ (let ((br (avl-tree--node-branch node branch))
+ p1 p2 b2)
+ (cond
+ ((> (avl-tree--node-balance br) 0)
+ (setf (avl-tree--node-balance br) 0)
+ nil)
+
+ ((= (avl-tree--node-balance br) 0)
+ (setf (avl-tree--node-balance br) -1)
+ t)
+
+ (t
+ ;; Balance was -1 => Rebalance.
+ (setq p1 (avl-tree--node-left br))
+ (if (< (avl-tree--node-balance p1) 0)
+ ;; Single LL rotation.
+ (progn
+ (setf (avl-tree--node-left br) (avl-tree--node-right p1))
+ (setf (avl-tree--node-right p1) br)
+ (setf (avl-tree--node-balance br) 0)
+ (setf (avl-tree--node-branch node branch) p1))
+
+ ;; Double LR rotation.
+ (setq p2 (avl-tree--node-right p1)
+ b2 (avl-tree--node-balance p2))
+ (setf (avl-tree--node-right p1) (avl-tree--node-left p2))
+ (setf (avl-tree--node-left p2) p1)
+ (setf (avl-tree--node-left br) (avl-tree--node-right p2))
+ (setf (avl-tree--node-right p2) br)
+ (setf (avl-tree--node-balance br) (if (< b2 0) +1 0))
+ (setf (avl-tree--node-balance p1) (if (> b2 0) -1 0))
+ (setf (avl-tree--node-branch node branch) p2))
+ (setf (avl-tree--node-balance (avl-tree--node-branch node branch)) 0)
+ nil))))
+
+(defun avl-tree--do-enter (cmpfun root branch data)
+ ;; Return t if height of tree ROOT has grown. INTERNAL USE ONLY.
+ (let ((br (avl-tree--node-branch root branch)))
+ (cond
+ ((null br)
+ ;; Data not in tree, insert it.
+ (setf (avl-tree--node-branch root branch)
+ (avl-tree--node-create nil nil data 0))
+ t)
+
+ ((funcall cmpfun data (avl-tree--node-data br))
+ (and (avl-tree--do-enter cmpfun br 0 data)
+ (avl-tree--enter-balance2 root branch)))
+
+ ((funcall cmpfun (avl-tree--node-data br) data)
+ (and (avl-tree--do-enter cmpfun br 1 data)
+ (avl-tree--enter-balance1 root branch)))
+
+ (t
+ (setf (avl-tree--node-data br) data)
+ nil))))
+
+;; ----------------------------------------------------------------
+
+(defun avl-tree--mapc (map-function root)
+ ;; Apply MAP-FUNCTION to all nodes in the tree starting with ROOT.
+ ;; The function is applied in-order.
+ ;;
+ ;; Note: MAP-FUNCTION is applied to the node and not to the data itself.
+ ;; INTERNAL USE ONLY.
+ (let ((node root)
+ (stack nil)
+ (go-left t))
+ (push nil stack)
+ (while node
+ (if (and go-left
+ (avl-tree--node-left node))
+ ;; Do the left subtree first.
+ (progn
+ (push node stack)
+ (setq node (avl-tree--node-left node)))
+ ;; Apply the function...
+ (funcall map-function node)
+ ;; and do the right subtree.
+ (setq node (if (setq go-left (avl-tree--node-right node))
+ (avl-tree--node-right node)
+ (pop stack)))))))
+
+(defun avl-tree--do-copy (root)
+ ;; Copy the avl tree with ROOT as root.
+ ;; Highly recursive. INTERNAL USE ONLY.
+ (if (null root)
+ nil
+ (avl-tree--node-create
+ (avl-tree--do-copy (avl-tree--node-left root))
+ (avl-tree--do-copy (avl-tree--node-right root))
+ (avl-tree--node-data root)
+ (avl-tree--node-balance root))))
+
+\f
+;; ================================================================
+;;; The public functions which operate on AVL trees.
+
+(defalias 'avl-tree-compare-function 'avl-tree--cmpfun
+ "Return the comparison function for the avl tree TREE.
+
+\(fn TREE)")
+
+(defun avl-tree-empty (tree)
+ "Return t if avl tree TREE is emtpy, otherwise return nil."
+ (null (avl-tree--root tree)))
+
+(defun avl-tree-enter (tree data)
+ "In the avl tree TREE insert DATA.
+Return DATA."
+ (avl-tree--do-enter (avl-tree--cmpfun tree)
+ (avl-tree--dummyroot tree)
+ 0
+ data)
+ data)
+
+(defun avl-tree-delete (tree data)
+ "From the avl tree TREE, delete DATA.
+Return the element in TREE which matched DATA,
+nil if no element matched."
+ (avl-tree--do-delete (avl-tree--cmpfun tree)
+ (avl-tree--dummyroot tree)
+ 0
+ data))
+
+(defun avl-tree-member (tree data)
+ "Return the element in the avl tree TREE which matches DATA.
+Matching uses the compare function previously specified in
+`avl-tree-create' when TREE was created.
+
+If there is no such element in the tree, the value is nil."
+ (let ((node (avl-tree--root tree))
+ (compare-function (avl-tree--cmpfun tree))
+ found)
+ (while (and node
+ (not found))
+ (cond
+ ((funcall compare-function data (avl-tree--node-data node))
+ (setq node (avl-tree--node-left node)))
+ ((funcall compare-function (avl-tree--node-data node) data)
+ (setq node (avl-tree--node-right node)))
+ (t
+ (setq found t))))
+ (if node
+ (avl-tree--node-data node)
+ nil)))
+
+(defun avl-tree-map (__map-function__ tree)
+ "Apply __MAP-FUNCTION__ to all elements in the avl tree TREE."
+ (avl-tree--mapc
+ (lambda (node)
+ (setf (avl-tree--node-data node)
+ (funcall __map-function__ (avl-tree--node-data node))))
+ (avl-tree--root tree)))
+
+(defun avl-tree-first (tree)
+ "Return the first element in TREE, or nil if TREE is empty."
+ (let ((node (avl-tree--root tree)))
+ (when node
+ (while (avl-tree--node-left node)
+ (setq node (avl-tree--node-left node)))
+ (avl-tree--node-data node))))
+
+(defun avl-tree-last (tree)
+ "Return the last element in TREE, or nil if TREE is empty."
+ (let ((node (avl-tree--root tree)))
+ (when node
+ (while (avl-tree--node-right node)
+ (setq node (avl-tree--node-right node)))
+ (avl-tree--node-data node))))
+
+(defun avl-tree-copy (tree)
+ "Return a copy of the avl tree TREE."
+ (let ((new-tree (avl-tree-create (avl-tree--cmpfun tree))))
+ (setf (avl-tree--root new-tree) (avl-tree--do-copy (avl-tree--root tree)))
+ new-tree))
+
+(defun avl-tree-flatten (tree)
+ "Return a sorted list containing all elements of TREE."
+ (nreverse
+ (let ((treelist nil))
+ (avl-tree--mapc
+ (lambda (node) (push (avl-tree--node-data node) treelist))
+ (avl-tree--root tree))
+ treelist)))
+
+(defun avl-tree-size (tree)
+ "Return the number of elements in TREE."
+ (let ((treesize 0))
+ (avl-tree--mapc
+ (lambda (data) (setq treesize (1+ treesize)))
+ (avl-tree--root tree))
+ treesize))
+
+(defun avl-tree-clear (tree)
+ "Clear the avl tree TREE."
+ (setf (avl-tree--root tree) nil))
+
+(provide 'avl-tree)
+
+;; arch-tag: 47e26701-43c9-4222-bd79-739eac6357a9
+;;; avl-tree.el ends here
HCoop / bpt / emacs.git / blobdiff