mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-12-29 11:02:01 +00:00
Code Issues Releases Activity

* lisp/emacs-lisp/avl-tree.el (avl-tree--del-balance): Rename from

Browse Source 
avl-tree--del-balance1 and make it work both ways.
(avl-tree--del-balance2): Remove.
(avl-tree--enter-balance): Rename from avl-tree--enter-balance1 and
make it work both ways.
(avl-tree--enter-balance2): Remove.
(avl-tree--switch-dir, avl-tree--dir-to-sign, avl-tree--sign-to-dir):
New macros.
(avl-tree--mapc, avl-tree-map): Add direction argument.
This commit is contained in:
Toby Cubitt 2011-05-27 16:58:19 -03:00 committed by Stefan Monnier
parent 18480f8fc0
commit 3769ddcf1e
2 changed files with 230 additions and 222 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
lisp/ChangeLog
View File

@ -1,3 +1,15 @@
2009-11-23 Toby Cubitt <toby-predictive@dr-qubit.org>
* emacs-lisp/avl-tree.el (avl-tree--del-balance): Rename from
avl-tree--del-balance1 and make it work both ways.
(avl-tree--del-balance2): Remove.
(avl-tree--enter-balance): Rename from avl-tree--enter-balance1 and
make it work both ways.
(avl-tree--enter-balance2): Remove.
(avl-tree--switch-dir, avl-tree--dir-to-sign, avl-tree--sign-to-dir):
New macros.
(avl-tree--mapc, avl-tree-map): Add direction argument.
2011-05-27 David Michael <fedora.dm0@gmail.com>
* files.el (interpreter-mode-alist): Add rbash (bug#8745).

410
lisp/emacs-lisp/avl-tree.el
View File

@ -5,9 +5,10 @@
;; Author: Per Cederqvist <ceder@lysator.liu.se>
;; Inge Wallin <inge@lysator.liu.se>
;; Thomas Bellman <bellman@lysator.liu.se>
;; Toby Cubitt <toby-predictive@dr-qubit.org>
;; Maintainer: FSF
;; Created: 10 May 1991
;; Keywords: extensions, data structures
;; Keywords: extensions, data structures, AVL, tree
;; This file is part of GNU Emacs.
@ -26,14 +27,24 @@
;;; 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.
;; An AVL tree is a self-balancing binary tree. As such, inserting,
;; deleting, and retrieving data from an AVL tree containing n elements
;; is O(log n). It is somewhat more rigidly balanced than other
;; self-balancing binary trees (such as red-black trees and AA trees),
;; making insertion slighty slower, deletion somewhat slower, and
;; retrieval somewhat faster (the asymptotic scaling is of course the
;; same for all types). Thus it may be a good choice when the tree will
;; be relatively static, i.e. data will be retrieved more often than
;; they are modified.
;;
;; Internally, a tree consists of two elements, the root node and the
;; comparison function. The actual tree has a dummy node as its root
;; with the real root in the left pointer, which allows the root node to
;; be treated on a par with all other nodes.
;;
;; 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.
;; sub-tree, one right sub-tree, and a balance count. The latter 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.
@ -42,43 +53,21 @@
(eval-when-compile (require 'cl))
;; ================================================================
;;; Functions and macros handling an AVL tree node.
;;; Internal functions and macros for use in the AVL tree package
(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)
;; ================================================================
;;; Internal functions for use in the AVL tree package
;; ----------------------------------------------------------------
;; Functions and macros handling an AVL tree.
(defstruct (avl-tree-
;; A tagged list is the pre-defstruct representation.
;; (:type list)
:named
(:constructor nil)
(:constructor avl-tree-create (cmpfun))
(:constructor avl-tree--create (cmpfun))
(:predicate avl-tree-p)
(:copier nil))
(dummyroot (avl-tree--node-create nil nil nil 0))
@ -86,111 +75,128 @@ NODE is the node, and BRANCH is the branch.
(defmacro avl-tree--root (tree)
;; Return the root node for an avl-tree. INTERNAL USE ONLY.
`(avl-tree--node-left (avl-tree--dummyroot tree)))
`(avl-tree--node-left (avl-tree--dummyroot ,tree)))
(defsetf avl-tree--root (tree) (node)
`(setf (avl-tree--node-left (avl-tree--dummyroot ,tree)) ,node))
;; ----------------------------------------------------------------
;; 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.")
;; The funcall/aref trick wouldn't work for the setf method, unless we
;; tried to access the underlying setter function, but this wouldn't be
;; portable either.
(defsetf avl-tree--node-branch aset)
;; ----------------------------------------------------------------
;; Convenience macros
(defmacro avl-tree--switch-dir (dir)
"Return opposite direction to DIR (0 = left, 1 = right)."
`(- 1 ,dir))
(defmacro avl-tree--dir-to-sign (dir)
"Convert direction (0,1) to sign factor (-1,+1)."
`(1- (* 2 ,dir)))
(defmacro avl-tree--sign-to-dir (dir)
"Convert sign factor (-x,+x) to direction (0,1)."
`(if (< ,dir 0) 0 1))
;; ----------------------------------------------------------------
;; Deleting data
(defun avl-tree--del-balance1 (node branch)
;; Rebalance a tree and return t if the height of the tree has shrunk.
(defun avl-tree--del-balance (node branch dir)
"Rebalance a tree after deleting a node.
The deletion was done from the left (DIR=0) or right (DIR=1) sub-tree of the
left (BRANCH=0) or right (BRANCH=1) child of NODE.
Return t if the height of the tree has shrunk."
;; (or is it vice-versa for BRANCH?)
(let ((br (avl-tree--node-branch node branch))
p1 b1 p2 b2 result)
;; opposite direction: 0,1 -> 1,0
(opp (avl-tree--switch-dir dir))
;; direction 0,1 -> sign factor -1,+1
(sgn (avl-tree--dir-to-sign dir))
p1 b1 p2 b2)
(cond
((< (avl-tree--node-balance br) 0)
((> (* sgn (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)
(setf (avl-tree--node-balance br) (- sgn))
nil)
(t
;; Rebalance.
(setq p1 (avl-tree--node-right br)
(setq p1 (avl-tree--node-branch br opp)
b1 (avl-tree--node-balance p1))
(if (>= b1 0)
;; Single RR rotation.
(if (<= (* sgn b1) 0)
;; Single rotation.
(progn
(setf (avl-tree--node-right br) (avl-tree--node-left p1))
(setf (avl-tree--node-left p1) br)
(setf (avl-tree--node-branch br opp)
(avl-tree--node-branch p1 dir)
(avl-tree--node-branch p1 dir) br
(avl-tree--node-branch node branch) p1)
(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) (- sgn)
(avl-tree--node-balance p1) sgn)
nil) ; height hasn't changed
(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)
t)) ; height has changed
;; 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)
;; Double rotation.
(setf p2 (avl-tree--node-branch p1 dir)
b2 (avl-tree--node-balance p2)
(avl-tree--node-branch p1 dir)
(avl-tree--node-branch p2 opp)
(avl-tree--node-branch p2 opp) p1
(avl-tree--node-branch br opp)
(avl-tree--node-branch p2 dir)
(avl-tree--node-branch p2 dir) br
(avl-tree--node-balance br)
(if (< (* sgn b2) 0) sgn 0)
(avl-tree--node-balance p1)
(if (> (* sgn b2) 0) (- sgn) 0)
(avl-tree--node-branch node branch) p2
(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)
(if (avl-tree--do-del-internal br 1 q)
(avl-tree--del-balance node branch 1))
(setf (avl-tree--node-data q) (avl-tree--node-data br)
(avl-tree--node-branch node branch)
(avl-tree--node-left br))
t)))
@ -203,11 +209,11 @@ NODE is the node, and BRANCH is the branch.
((funcall cmpfun data (avl-tree--node-data br))
(if (avl-tree--do-delete cmpfun br 0 data)
(avl-tree--del-balance1 root branch)))
(avl-tree--del-balance root branch 0)))
((funcall cmpfun (avl-tree--node-data br) data)
(if (avl-tree--do-delete cmpfun br 1 data)
(avl-tree--del-balance2 root branch)))
(avl-tree--del-balance root branch 1)))
(t
;; Found it. Let's delete it.
@ -217,88 +223,65 @@ NODE is the node, and BRANCH is the branch.
t)
((null (avl-tree--node-left br))
(setf (avl-tree--node-branch root branch) (avl-tree--node-right 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))))))))
(avl-tree--del-balance root branch 0))))))))
;; ----------------------------------------------------------------
;; Entering data
(defun avl-tree--enter-balance1 (node branch)
;; Rebalance a tree and return t if the height of the tree has grown.
(defun avl-tree--enter-balance (node branch dir)
"Rebalance tree after an insertion
into the left (DIR=0) or right (DIR=1) sub-tree of the
left (BRANCH=0) or right (BRANCH=1) child of NODE.
Return t if the height of the tree has grown."
(let ((br (avl-tree--node-branch node branch))
;; opposite direction: 0,1 -> 1,0
(opp (avl-tree--switch-dir dir))
;; direction 0,1 -> sign factor -1,+1
(sgn (avl-tree--dir-to-sign dir))
p1 p2 b2 result)
(cond
((< (avl-tree--node-balance br) 0)
((< (* sgn (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)
(setf (avl-tree--node-balance br) sgn)
t)
(t
;; Tree has grown => Rebalance.
(setq p1 (avl-tree--node-right br))
(if (> (avl-tree--node-balance p1) 0)
;; Single RR rotation.
(setq p1 (avl-tree--node-branch br dir))
(if (> (* sgn (avl-tree--node-balance p1)) 0)
;; Single rotation.
(progn
(setf (avl-tree--node-right br) (avl-tree--node-left p1))
(setf (avl-tree--node-left p1) br)
(setf (avl-tree--node-branch br dir)
(avl-tree--node-branch p1 opp))
(setf (avl-tree--node-branch p1 opp) 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)
;; Double rotation.
(setf p2 (avl-tree--node-branch p1 opp)
b2 (avl-tree--node-balance p2)
(avl-tree--node-branch p1 opp)
(avl-tree--node-branch p2 dir)
(avl-tree--node-branch p2 dir) p1
(avl-tree--node-branch br dir)
(avl-tree--node-branch p2 opp)
(avl-tree--node-branch p2 opp) br
(avl-tree--node-balance br)
(if (> (* sgn b2) 0) (- sgn) 0)
(avl-tree--node-balance p1)
(if (< (* sgn b2) 0) sgn 0)
(avl-tree--node-branch node branch) p2
(avl-tree--node-balance
(avl-tree--node-branch node branch)) 0))
nil))))
(defun avl-tree--do-enter (cmpfun root branch data)
@ -313,11 +296,11 @@ NODE is the node, and BRANCH is the branch.
((funcall cmpfun data (avl-tree--node-data br))
(and (avl-tree--do-enter cmpfun br 0 data)
(avl-tree--enter-balance2 root branch)))
(avl-tree--enter-balance root branch 0)))
((funcall cmpfun (avl-tree--node-data br) data)
(and (avl-tree--do-enter cmpfun br 1 data)
(avl-tree--enter-balance1 root branch)))
(avl-tree--enter-balance root branch 1)))
(t
(setf (avl-tree--node-data br) data)
@ -325,33 +308,38 @@ NODE is the node, and BRANCH is the branch.
;; ----------------------------------------------------------------
(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.
;;; INTERNAL USE ONLY
(defun avl-tree--mapc (map-function root dir)
"Apply MAP-FUNCTION to all nodes in the tree starting with ROOT.
The function is applied in-order, either ascending (DIR=0) or
descending (DIR=1).
Note: MAP-FUNCTION is applied to the node and not to the data
itself."
(let ((node root)
(stack nil)
(go-left t))
(go-dir t))
(push nil stack)
(while node
(if (and go-left
(avl-tree--node-left node))
;; Do the left subtree first.
(if (and go-dir
(avl-tree--node-branch node dir))
;; Do the DIR subtree first.
(progn
(push node stack)
(setq node (avl-tree--node-left node)))
(setq node (avl-tree--node-branch node dir)))
;; 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)
;; and do the opposite subtree.
(setq node (if (setq go-dir (avl-tree--node-branch
node (avl-tree--switch-dir dir)))
(avl-tree--node-branch
node (avl-tree--switch-dir dir))
(pop stack)))))))
;;; INTERNAL USE ONLY
(defun avl-tree--do-copy (root)
;; Copy the avl tree with ROOT as root.
;; Highly recursive. INTERNAL USE ONLY.
"Copy the avl tree with ROOT as root. Highly recursive."
(if (null root)
nil
(avl-tree--node-create
@ -360,10 +348,16 @@ NODE is the node, and BRANCH is the branch.
(avl-tree--node-data root)
(avl-tree--node-balance root))))
;; ================================================================
;;; The public functions which operate on AVL trees.
;; define public alias for constructors so that we can set docstring
(defalias 'avl-tree-create 'avl-tree--create
"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.")
(defalias 'avl-tree-compare-function 'avl-tree--cmpfun
"Return the comparison function for the avl tree TREE.
@ -398,28 +392,31 @@ Matching uses the compare function previously specified in
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))
(compare-function (avl-tree--cmpfun tree)))
(catch 'found
(while node
(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)
(t (throw 'found (avl-tree--node-data node)))))
nil)))
(defun avl-tree-map (__map-function__ tree)
"Apply __MAP-FUNCTION__ to all elements in the avl tree TREE."
(defun avl-tree-map (__map-function__ tree &optional reverse)
"Modify all elements in the avl tree TREE by applying FUNCTION.
Each element is replaced by the return value of FUNCTION applied
to that element.
FUNCTION is applied to the elements in ascending order, or
descending order if REVERSE is non-nil."
(avl-tree--mapc
(lambda (node)
(setf (avl-tree--node-data node)
(funcall __map-function__ (avl-tree--node-data node))))
(avl-tree--root tree)))
(avl-tree--root tree)
(if reverse 1 0)))
(defun avl-tree-first (tree)
"Return the first element in TREE, or nil if TREE is empty."
@ -445,19 +442,18 @@ If there is no such element in the tree, the value is nil."
(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)))
(avl-tree--root tree) 1)
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))
(avl-tree--root tree) 0)
treesize))
(defun avl-tree-clear (tree)