diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 64dd2af280a..2b6e0dc41f9 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,15 @@ +2009-11-23 Toby Cubitt + + * 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 * files.el (interpreter-mode-alist): Add rbash (bug#8745). diff --git a/lisp/emacs-lisp/avl-tree.el b/lisp/emacs-lisp/avl-tree.el index 0a637da0bc1..82585fd4322 100644 --- a/lisp/emacs-lisp/avl-tree.el +++ b/lisp/emacs-lisp/avl-tree.el @@ -3,11 +3,12 @@ ;; Copyright (C) 1995, 2007-2011 Free Software Foundation, Inc. ;; Author: Per Cederqvist -;; Inge Wallin -;; Thomas Bellman +;; Inge Wallin +;; Thomas Bellman +;; Toby Cubitt ;; 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,112 +75,129 @@ 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) - (avl-tree--node-left br)) + (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))) (defun avl-tree--do-delete (cmpfun root branch data) @@ -203,102 +209,79 @@ 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. (cond ((null (avl-tree--node-right br)) - (setf (avl-tree--node-branch root branch) (avl-tree--node-left br)) - t) + (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) + (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)))))))) + (if (avl-tree--do-del-internal br 0 br) + (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. @@ -377,9 +371,9 @@ NODE is the node, and BRANCH is the branch. "In the avl tree TREE insert DATA. Return DATA." (avl-tree--do-enter (avl-tree--cmpfun tree) - (avl-tree--dummyroot tree) - 0 - data) + (avl-tree--dummyroot tree) + 0 + data) data) (defun avl-tree-delete (tree data) @@ -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)) - (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) + (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 (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)