diff options
Diffstat (limited to 'lisp/emacs-lisp/avl-tree.el')
| -rw-r--r-- | lisp/emacs-lisp/avl-tree.el | 717 |
1 files changed, 457 insertions, 260 deletions
diff --git a/lisp/emacs-lisp/avl-tree.el b/lisp/emacs-lisp/avl-tree.el index 63774bc229f..e8b7a1f9a8b 100644 --- a/lisp/emacs-lisp/avl-tree.el +++ b/lisp/emacs-lisp/avl-tree.el @@ -1,13 +1,14 @@ ;;; avl-tree.el --- balanced binary trees, AVL-trees -;; Copyright (C) 1995, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1995, 2007-2011 Free Software Foundation, Inc. ;; Author: Per Cederqvist <ceder@lysator.liu.se> -;; Inge Wallin <inge@lysator.liu.se> -;; Thomas Bellman <bellman@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. -(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)) @@ -86,272 +75,304 @@ 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)) + + ;; ---------------------------------------------------------------- -;; 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.") + -(defun avl-tree--del-balance2 (node branch) +;; 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-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-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) - ;; 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 (SHRUNK . DATA), where SHRUNK is t if the +height of the tree has shrunk and nil otherwise, and DATA 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-balance1 root branch))) + (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-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) + (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)))) + )))))) - ((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. +(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) + ;; 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--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)) +(defun avl-tree--do-enter (cmpfun root branch data &optional updatefun) + "Enter DATA in BRANCH of ROOT node. +\(See `avl-tree-enter' for UPDATEFUN). - ;; 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. +Return cons cell (GREW . DATA), where GREW is t if height +of tree ROOT has grown and nil otherwise, and DATA 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-balance2 root branch))) + (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-balance1 root branch))) + (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 + )))) ;; ---------------------------------------------------------------- -(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 +381,40 @@ NODE is the node, and BRANCH is the branch. (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. +;; 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. @@ -373,53 +424,142 @@ NODE is the node, and BRANCH is the branch. "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) +(defun avl-tree-enter (tree data &optional updatefun) + "Insert DATA into the avl tree TREE. + +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)) - 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." + (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))))) + 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. + +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-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." @@ -445,26 +585,83 @@ 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) "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 ;;; avl-tree.el ends here |