From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Toby Cubitt Newsgroups: gmane.emacs.bugs Subject: bug#5024: avl-tree.el enhancements Date: Mon, 23 Nov 2009 16:59:08 +0000 Message-ID: <20091123165908.GC31081@c3po> References: <20091123000123.GA7647@c3po> <20091123094431.GA31081@c3po> Reply-To: Toby Cubitt , 5024@emacsbugs.donarmstrong.com NNTP-Posting-Host: lo.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="Y5rl02BVI9TCfPar" X-Trace: ger.gmane.org 1258997141 31741 80.91.229.12 (23 Nov 2009 17:25:41 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Mon, 23 Nov 2009 17:25:41 +0000 (UTC) Cc: bug-gnu-emacs@gnu.org To: Stefan Monnier Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Mon Nov 23 18:25:28 2009 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane.org Original-Received: from lists.gnu.org ([199.232.76.165]) by lo.gmane.org with esmtp (Exim 4.50) id 1NCcfE-0003vk-91 for geb-bug-gnu-emacs@m.gmane.org; Mon, 23 Nov 2009 18:25:25 +0100 Original-Received: from localhost ([127.0.0.1]:54691 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1NCcfD-0008Ej-IT for geb-bug-gnu-emacs@m.gmane.org; Mon, 23 Nov 2009 12:25:23 -0500 Original-Received: from mailman by lists.gnu.org with tmda-scanned (Exim 4.43) id 1NCcNz-00010u-Tl for bug-gnu-emacs@gnu.org; Mon, 23 Nov 2009 12:07:36 -0500 Original-Received: from exim by lists.gnu.org with spam-scanned (Exim 4.43) id 1NCcNu-0000xX-Sy for bug-gnu-emacs@gnu.org; Mon, 23 Nov 2009 12:07:35 -0500 Original-Received: from [199.232.76.173] (port=47424 helo=monty-python.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1NCcNu-0000x9-Gb for bug-gnu-emacs@gnu.org; Mon, 23 Nov 2009 12:07:30 -0500 Original-Received: from rzlab.ucr.edu ([138.23.92.77]:34739) by monty-python.gnu.org with esmtps (TLS-1.0:DHE_RSA_AES_256_CBC_SHA1:32) (Exim 4.60) (envelope-from ) id 1NCcNp-0003og-Qe for bug-gnu-emacs@gnu.org; Mon, 23 Nov 2009 12:07:30 -0500 Original-Received: from rzlab.ucr.edu (rzlab.ucr.edu [127.0.0.1]) by rzlab.ucr.edu (8.14.3/8.14.3/Debian-5) with ESMTP id nANH7LCk032097; Mon, 23 Nov 2009 09:07:22 -0800 Original-Received: (from debbugs@localhost) by rzlab.ucr.edu (8.14.3/8.14.3/Submit) id nANH05CS030742; Mon, 23 Nov 2009 09:00:05 -0800 Resent-Date: Mon, 23 Nov 2009 09:00:05 -0800 X-Loop: owner@emacsbugs.donarmstrong.com Resent-From: Toby Cubitt Resent-To: bug-submit-list@donarmstrong.com Resent-CC: Emacs Bugs 2Resent-Date: Mon, 23 Nov 2009 17:00:04 +0000 Resent-Message-ID: Resent-Sender: owner@emacsbugs.donarmstrong.com X-Emacs-PR-Message: report 5024 X-Emacs-PR-Package: emacs X-Emacs-PR-Keywords: Original-Received: via spool by submit@emacsbugs.donarmstrong.com id=B.125899518330239 (code B ref -1); Mon, 23 Nov 2009 17:00:04 +0000 Original-Received: (at submit) by emacsbugs.donarmstrong.com; 23 Nov 2009 16:53:03 +0000 X-Spam-Bayes: score:0.5 Bayes not run. spammytokens:Tokens not available. hammytokens:Tokens not available. Original-Received: from lists.gnu.org (lists.gnu.org [199.232.76.165]) by rzlab.ucr.edu (8.14.3/8.14.3/Debian-5) with ESMTP id nANGqxN0030232 for ; Mon, 23 Nov 2009 08:53:00 -0800 Original-Received: from mailman by lists.gnu.org with tmda-scanned (Exim 4.43) id 1NCc9q-0008Dy-Bo for bug-gnu-emacs@gnu.org; Mon, 23 Nov 2009 11:52:58 -0500 Original-Received: from exim by lists.gnu.org with spam-scanned (Exim 4.43) id 1NCc9l-0008Br-SM for bug-gnu-emacs@gnu.org; Mon, 23 Nov 2009 11:52:58 -0500 Original-Received: from [199.232.76.173] (port=34560 helo=monty-python.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1NCc9l-0008Bj-My for bug-gnu-emacs@gnu.org; Mon, 23 Nov 2009 11:52:53 -0500 Original-Received: from mail.geekisp.com ([216.168.135.169]:42773 helo=starfish.geekisp.com) by monty-python.gnu.org with esmtps (TLS-1.0:DHE_RSA_AES_256_CBC_SHA1:32) (Exim 4.60) (envelope-from ) id 1NCc9k-0001ho-OB for bug-gnu-emacs@gnu.org; Mon, 23 Nov 2009 11:52:53 -0500 Original-Received: (qmail 11132 invoked by uid 1003); 23 Nov 2009 16:52:51 -0000 Original-Received: from c3po (localhost.geekisp.com [127.0.0.1]) by localhost.geekisp.com (tmda-ofmipd) with ESMTP; Mon, 23 Nov 2009 11:52:41 -0500 Content-Disposition: inline In-Reply-To: User-Agent: Mutt/1.5.20 (2009-06-14) X-Delivery-Agent: TMDA/1.1.11 (Ladyburn) X-Primary-Address: toby@dr-qubit.org X-detected-operating-system: by monty-python.gnu.org: OpenBSD 3.0-3.9 X-detected-operating-system: by monty-python.gnu.org: GNU/Linux 2.6 (newer, 2) Resent-Date: Mon, 23 Nov 2009 12:07:35 -0500 X-BeenThere: bug-gnu-emacs@gnu.org X-Mailman-Version: 2.1.5 Precedence: list List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Original-Sender: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Xref: news.gmane.org gmane.emacs.bugs:32852 Archived-At: --Y5rl02BVI9TCfPar Content-Type: text/plain; charset=us-ascii Content-Disposition: inline On Mon, Nov 23, 2009 at 09:58:08AM -0500, Stefan Monnier wrote: > >> Hmm... using integers for "direction" isn't pretty. I see it mostly > >> comes from its use in avl-tree--node-branch. I guess we'll have to live > >> with it for now... > > > Exactly -- it stems from avl-tree--node-branch (which isn't my code). > > The comment after its definition (also not mine) explains the reason > > for it. I can't think of an efficient way to avoid this. > > I know. I wrote the comment ;-) :-) > > I personally find the fact that internal library functions aren't > > documented to be a useful form of documentation in itself: it tells me > > that the function definitely shouldn't be used outside of the library. > > That's what the "--" is for in avl-tree--del-balance. It's also much > better because you don't need to check "does this function have > a docstring" to figure out whether it's internal or not. I see. I wasn't aware that the "--" convention was widely followed for internal library functions (at least, widely enough to be understood). In that case, you're of course right. Is this convention documented anywhere? Should it be? I can't find it mentioned anywhere in Appendix D of Emacs Lisp Manual... > > If you still insist on making one or other or both of these into > > docstrings, I'll make the necessary changes to the patches. > > Please do, thank you. I've fixed this in the new versions of the patches (attached). Since my changes touch a lot of functions in avl-tree.el, I've gone through and changed as many comments to docstrings as I can (I think I've caught all of them, in fact). > >> Why exactly do you remove the \(fn TREE) thingy at the end? > > > It seemed to be a strange documentation convention followed only by > > avl-tree.el, and inconsistently at that. It's redundant, and as far as I > > know isn't used anywhere else in Emacs, because "C-h f " > > already automatically shows the function's calling convention. > > It's a trick that can be used to *change* the calling > convention displayed. So it's not used/needed often. But here, for > example, it's used to change (avl-tree-compare-function CL-X) into > (avl-tree-compare-function TREE), so the docstring (which refers to > TREE) makes more sense. > Sometimes it's used to hide some internal arguments. > It's also used systematically in autoloaded definitions so as to provide > the calling convention before the function is loaded. Always good to learn something new about Emacs :) I've reverted this change in the attached patches. Now I'll have to go back through my other Elisp code to see if this trick would be useful! > >> Overall, looks good. Please provide a ChangeLog entry for it as well. > > > Errrmmmm...do you mean a ChangeLog entry in the avl-tree.el file itself? > > If so, I already did! :) > > No, an entry in the format used by the ChangeLog file. > See http://www.gnu.org/prep/standards/standards.html#Change-Logs Ah, OK. I've attached a ChangeLog file with the entries for these changes. I've tried to follow the guidelines in the link, but you'd better check and let me know if they're OK. Toby --Y5rl02BVI9TCfPar Content-Type: text/plain; charset=us-ascii Content-Disposition: attachment; filename="avl-tree.el_ChangeLog" 2009-11-23 * avl-tree.el (avl-tree--switch-dir, avl-tree--dir-to-sign) (avl-tree--sign-to-dir): New functions * avl-tree.el (avl-tree--del-balance1, avl-tree--del-balance2): Replaced with avl-tree--del-balance * avl-tree.el (avl-tree--del-balance): New function * avl-tree.el (avl-tree--do-del-internal): Use avl-tree--del-balance * avl-tree.el (avl-tree--do-delete, avl-tree-delete): New args TEST and NILFLAG * avl-tree.el (avl-tree--enter-balance1) (avl-tree--enter-balance2): Replaced with avl-tree--enter-balance * avl-tree.el (avl-tree--enter-balance): New function * avl-tree.el (avl-tree--do-enter, avl-tree-enter): New arg UPDATEFUN * avl-tree.el (avl-tree-member): New arg NILFLAG * avl-tree.el (avl-tree-member-p): New function * avl-tree.el (avl-tree--mapc): New arg DIR; modified all callers * avl-tree.el (avl-tree-map): Use DIR arg of avl-tree--mapc * avl-tree.el (avl-tree-mapc, avl-tree-mapf, avl-tree-mapcar): New functions * avl-tree.el (avl-tree--stack): New struct * avl-tree.el (avl-tree-stack, avl-tree-stack-p) (avl-tree-stack-pop, avl-tree-stack-first, avl-tree-stack-empty-p) (avl-tree--stack-create, avl-tree--stack-repopulate): New functions --Y5rl02BVI9TCfPar Content-Type: text/plain; charset=us-ascii Content-Disposition: attachment; filename="avl-tree.el.1.diff" --- avl-tree.el 2009-11-23 15:47:52.000000000 +0000 +++ avl-tree1.el 2009-11-23 15:42:54.000000000 +0000 @@ -3,11 +3,13 @@ ;; Copyright (C) 1995, 2007, 2008, 2009 Free Software Foundation, Inc. ;; Author: Per Cederqvist -;; Inge Wallin -;; Thomas Bellman +;; Inge Wallin +;; Thomas Bellman +;; modified by Toby Cubitt +;; Version: 0.1 ;; Maintainer: FSF ;; Created: 10 May 1991 -;; Keywords: extensions, data structures +;; Keywords: extensions, data structures, AVL, tree ;; This file is part of GNU Emacs. @@ -24,174 +26,190 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see . -;;; 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. +;;; Commentary: +;; +;; 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. + +;;; Change log: +;; +;; Version 0.1 +;; * simplified rebalancing code +;; * added optional direction argument to `avl-tree-map' + + ;;; 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. +;; ================================================================ +;;; Internal functions and macros for use in the AVL tree package -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)) 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))) + `(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 +;; Functions and macros handling an AVL tree node. -(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) +(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) - ((= (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))))) +(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) + -(defun avl-tree--del-balance2 (node branch) + +;; ---------------------------------------------------------------- +;; 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-balance (node branch dir) + "Rebalance a tree after deleting +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-left br) + (setq p1 (avl-tree--node-branch br opp) b1 (avl-tree--node-balance p1)) - (if (<= b1 0) - ;; Single LL rotation. + (if (<= (* sgn b1) 0) + ;; Single rotation. (progn - (setf (avl-tree--node-left br) (avl-tree--node-right p1)) - (setf (avl-tree--node-right 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) - - ;; 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)) ; height has changed + + ;; 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 +221,79 @@ ((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 +308,11 @@ ((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 +320,38 @@ ;; ---------------------------------------------------------------- -(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 +360,17 @@ (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 +384,9 @@ "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 +405,31 @@ 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 +455,18 @@ (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) --Y5rl02BVI9TCfPar Content-Type: text/plain; charset=us-ascii Content-Disposition: attachment; filename="avl-tree.el.2.diff" --- avl-tree1.el 2009-11-23 15:42:54.000000000 +0000 +++ avl-tree2.el 2009-11-23 15:54:52.000000000 +0000 @@ -6,7 +6,7 @@ ;; Inge Wallin ;; Thomas Bellman ;; modified by Toby Cubitt -;; Version: 0.1 +;; Version: 0.2 ;; Maintainer: FSF ;; Created: 10 May 1991 ;; Keywords: extensions, data structures, AVL, tree @@ -54,6 +54,13 @@ ;;; Change log: ;; +;; Version 0.2 +;; * added new optional arguments to `avl-tree-member', `avl-tree-enter' +;; and `avl-tree-delete' +;; * added `avl-tree-member-p', `avl-tree-mapc', `avl-tree-mapcar', +;; `avl-tree-mapf', `avl-tree-stack', `avl-tree-stack-pop' and +;; `avl-tree-stack-first' functions +;; ;; Version 0.1 ;; * simplified rebalancing code ;; * added optional direction argument to `avl-tree-map' @@ -212,36 +219,52 @@ (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. +(defun avl-tree--do-delete (cmpfun root branch data test nilflag) + "Delete DATA from BRANCH of node ROOT. +\(See `avl-tree-delete' for TEST and NILFLAG). + +Return cons cell ( . ), where is t if the +height of the tree has shrunk and nil otherwise, and is +the releted data." (let ((br (avl-tree--node-branch root branch))) (cond + ;; DATA not in tree. ((null br) - nil) + (cons nil nilflag)) ((funcall cmpfun data (avl-tree--node-data br)) - (if (avl-tree--do-delete cmpfun br 0 data) - (avl-tree--del-balance root branch 0))) + (let ((ret (avl-tree--do-delete cmpfun br 0 data test nilflag))) + (cons (if (car ret) (avl-tree--del-balance root branch 0)) + (cdr ret)))) ((funcall cmpfun (avl-tree--node-data br) data) - (if (avl-tree--do-delete cmpfun br 1 data) - (avl-tree--del-balance root branch 1))) + (let ((ret (avl-tree--do-delete cmpfun br 1 data test nilflag))) + (cons (if (car ret) (avl-tree--del-balance root branch 1)) + (cdr ret)))) + + (t ; Found it. + ;; if it fails TEST, do nothing + (if (and test (not (funcall test (avl-tree--node-data br)))) + (cons nil nilflag) + (cond + ((null (avl-tree--node-right br)) + (setf (avl-tree--node-branch root branch) + (avl-tree--node-left br)) + (cons t (avl-tree--node-data br))) + + ((null (avl-tree--node-left br)) + (setf (avl-tree--node-branch root branch) + (avl-tree--node-right br)) + (cons t (avl-tree--node-data br))) + + (t + (if (avl-tree--do-del-internal br 0 br) + (cons (avl-tree--del-balance root branch 0) + (avl-tree--node-data br)) + (cons nil (avl-tree--node-data br)))) + )))))) + - (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-balance root branch 0)))))))) ;; ---------------------------------------------------------------- ;; Entering data @@ -296,30 +319,47 @@ (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. +(defun avl-tree--do-enter (cmpfun root branch data &optional updatefun) + "Enter DATA in BRANCH of ROOT node. +\(See `avl-tree-enter' for UPDATEFUN). + +Return cons cell ( . ), where is t if height +of tree ROOT has grown and nil otherwise, and is the +inserted data." (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) + (cons t data)) ((funcall cmpfun data (avl-tree--node-data br)) - (and (avl-tree--do-enter cmpfun br 0 data) - (avl-tree--enter-balance root branch 0))) + (let ((ret (avl-tree--do-enter cmpfun br 0 data updatefun))) + (cons (and (car ret) (avl-tree--enter-balance root branch 0)) + (cdr ret)))) ((funcall cmpfun (avl-tree--node-data br) data) - (and (avl-tree--do-enter cmpfun br 1 data) - (avl-tree--enter-balance root branch 1))) + (let ((ret (avl-tree--do-enter cmpfun br 1 data updatefun))) + (cons (and (car ret) (avl-tree--enter-balance root branch 1)) + (cdr ret)))) + ;; Data already in tree, update it. (t - (setf (avl-tree--node-data br) data) - nil)))) + (let ((newdata + (if updatefun + (funcall updatefun data (avl-tree--node-data br)) + data))) + (if (or (funcall cmpfun newdata data) + (funcall cmpfun data newdata)) + (error "avl-tree-enter:\ + updated data does not match existing data")) + (setf (avl-tree--node-data br) newdata) + (cons nil newdata)) ; return value + )))) -;; ---------------------------------------------------------------- +;; ---------------------------------------------------------------- ;;; INTERNAL USE ONLY (defun avl-tree--mapc (map-function root dir) @@ -360,6 +400,30 @@ (avl-tree--node-data root) (avl-tree--node-balance root)))) +(defstruct (avl-tree--stack + (:constructor nil) + (:constructor avl-tree--stack-create + (tree &optional reverse + &aux + (store + (if (avl-tree-empty tree) + nil + (list (avl-tree--root tree)))))) + (:copier nil)) + reverse store) + +(defalias 'avl-tree-stack-p 'avl-tree--stack-p + "Return t if argument is an avl-tree-stack, nil otherwise.") + +(defun avl-tree--stack-repopulate (stack) + ;; Recursively push children of the node at the head of STACK onto the + ;; front of the STACK, until a leaf is reached. + (let ((node (car (avl-tree--stack-store stack))) + (dir (if (avl-tree--stack-reverse stack) 1 0))) + (when node ; check for emtpy stack + (while (setq node (avl-tree--node-branch node dir)) + (push node (avl-tree--stack-store stack)))))) + ;; ================================================================ ;;; The public functions which operate on AVL trees. @@ -380,30 +444,56 @@ "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-enter (tree data &optional updatefun) + "Insert DATA into the avl tree TREE. -(defun avl-tree-member (tree data) +If an element that matches DATA (according to the tree's +comparison function, see `avl-tree-create') already exists in +TREE, it will be replaced by DATA by default. + +If UPDATEFUN is supplied and an element matching DATA already +exists in TREE, UPDATEFUN is called with two arguments: DATA, and +the matching element. Its return value replaces the existing +element. This value *must* itself match DATA (and hence the +pre-existing data), or an error will occur. + +Returns the new data." + (cdr (avl-tree--do-enter (avl-tree--cmpfun tree) + (avl-tree--dummyroot tree) + 0 data updatefun))) + +(defun avl-tree-delete (tree data &optional test nilflag) + "Delete the element matching DATA from the avl tree TREE. +Matching uses the comparison function previously specified in +`avl-tree-create' when TREE was created. + +Returns the deleted element, or nil if no matching element was +found. + +Optional argument NILFLAG specifies a value to return instead of +nil if nothing was deleted, so that this case can be +distinguished from the case of a successfully deleted null +element. + +If supplied, TEST specifies a test that a matching element must +pass before it is deleted. If a matching element is found, it is +passed as an argument to TEST, and is deleted only if the return +value is non-nil." + (cdr (avl-tree--do-delete (avl-tree--cmpfun tree) + (avl-tree--dummyroot tree) + 0 data test nilflag))) + + +(defun avl-tree-member (tree data &optional nilflag) "Return the element in the avl tree TREE which matches DATA. -Matching uses the compare function previously specified in +Matching uses the comparison function previously specified in `avl-tree-create' when TREE was created. -If there is no such element in the tree, the value is nil." +If there is no such element in the tree, nil is +returned. Optional argument NILFLAG specifies a value to return +instead of nil in this case. This allows non-existent elements to +be distinguished from a null element. (See also +`avl-tree-member-p', which does this for you.)" (let ((node (avl-tree--root tree)) (compare-function (avl-tree--cmpfun tree))) (catch 'found @@ -414,7 +504,16 @@ ((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))) + nilflag))) + + +(defun avl-tree-member-p (tree data) + "Return t if an element matching DATA exists in the avl tree TREE, +otherwise return nil. Matching uses the comparison function +previously specified in `avl-tree-create' when TREE was created." + (let ((flag '(nil))) + (not (eq (avl-tree-member tree data flag) flag)))) + (defun avl-tree-map (__map-function__ tree &optional reverse) "Modify all elements in the avl tree TREE by applying FUNCTION. @@ -431,6 +530,57 @@ (avl-tree--root tree) (if reverse 1 0))) + +(defun avl-tree-mapc (__map-function__ tree &optional reverse) + "Apply FUNCTION to all elements in avl tree TREE, +for side-effect only. + +FUNCTION is applied to the elements in ascending order, or +descending order if REVERSE is non-nil." + (avl-tree--mapc + (lambda (node) + (funcall __map-function__ (avl-tree--node-data node))) + (avl-tree--root tree) + (if reverse 1 0))) + + +(defun avl-tree-mapf + (__map-function__ combinator tree &optional reverse) + "Apply FUNCTION to all elements in avl tree TREE, +and combine the results using COMBINATOR. + +The FUNCTION is applied and the results are combined in ascending +order, or descending order if REVERSE is non-nil." + (let (avl-tree-mapf--accumulate) + (avl-tree--mapc + (lambda (node) + (setq avl-tree-mapf--accumulate + (funcall combinator + (funcall __map-function__ + (avl-tree--node-data node)) + avl-tree-mapf--accumulate))) + (avl-tree--root tree) + (if reverse 0 1)) + (nreverse avl-tree-mapf--accumulate))) + + +(defun avl-tree-mapcar (__map-function__ tree &optional reverse) + "Apply FUNCTION to all elements in avl tree TREE, +and make a list of the results. + +The FUNCTION is applied and the list constructed in ascending +order, or descending order if REVERSE is non-nil. + +Note that if you don't care about the order in which FUNCTION is +applied, just that the resulting list is in the correct order, +then + + (avl-tree-mapf function 'cons tree (not reverse)) + +is more efficient." + (nreverse (avl-tree-mapf __map-function__ 'cons tree reverse))) + + (defun avl-tree-first (tree) "Return the first element in TREE, or nil if TREE is empty." (let ((node (avl-tree--root tree))) @@ -473,6 +623,65 @@ "Clear the avl tree TREE." (setf (avl-tree--root tree) nil)) + +(defun avl-tree-stack (tree &optional reverse) + "Return an object that behaves like a sorted stack +of all elements of TREE. + +If REVERSE is non-nil, the stack is sorted in reverse order. +\(See also `avl-tree-stack-pop'\). + +Note that any modification to TREE *immediately* invalidates all +avl-tree-stacks created before the modification (in particular, +calling `avl-tree-stack-pop' will give unpredictable results). + +Operations on these objects are significantly more efficient than +constructing a real stack with `avl-tree-flatten' and using +standard stack functions. As such, they can be useful in +implementing efficient algorithms of AVL trees. However, in cases +where mapping functions `avl-tree-mapc', `avl-tree-mapcar' or +`avl-tree-mapf' would be sufficient, it is better to use one of +those instead." + (let ((stack (avl-tree--stack-create tree reverse))) + (avl-tree--stack-repopulate stack) + stack)) + + +(defun avl-tree-stack-pop (avl-tree-stack &optional nilflag) + "Pop the first element from AVL-TREE-STACK. +\(See also `avl-tree-stack'\). + +Returns nil if the stack is empty, or NILFLAG if specified. (The +latter allows an empty stack to be distinguished from a null +element stored in the AVL tree.)" + (let (node next) + (if (not (setq node (pop (avl-tree--stack-store avl-tree-stack)))) + nilflag + (when (setq next + (avl-tree--node-branch + node + (if (avl-tree--stack-reverse avl-tree-stack) 0 1))) + (push next (avl-tree--stack-store avl-tree-stack)) + (avl-tree--stack-repopulate avl-tree-stack)) + (avl-tree--node-data node)))) + + +(defun avl-tree-stack-first (avl-tree-stack &optional nilflag) + "Return the first element of AVL-TREE-STACK, without removing it +from the stack. + +Returns nil if the stack is empty, or NILFLAG if specified. (The +latter allows an empty stack to be distinguished from a null +element stored in the AVL tree.)" + (or (car (avl-tree--stack-store avl-tree-stack)) + nilflag)) + + +(defun avl-tree-stack-empty-p (avl-tree-stack) + "Return t if AVL-TREE-STACK is empty, nil otherwise." + (null (avl-tree--stack-store avl-tree-stack))) + + (provide 'avl-tree) ;; arch-tag: 47e26701-43c9-4222-bd79-739eac6357a9 --Y5rl02BVI9TCfPar--