Mercurial > emacs
view lisp/emacs-lisp/avl-tree.el @ 109024:f24aeaefbe37
Fix occasional recentering under scroll-conservatively.
xdisp.c (try_scrolling): Compute the limit for searching point
in forward scroll from scroll_max, instead of an arbitrary limit
of 10 screen lines. See
http://lists.gnu.org/archive/html/emacs-devel/2010-06/msg00766.html and
http://lists.gnu.org/archive/html/emacs-devel/2010-06/msg00773.html for
details.
author | Eli Zaretskii <eliz@gnu.org> |
---|---|
date | Sat, 19 Jun 2010 12:40:15 +0300 |
parents | 1d1d5d9bd884 |
children | 376148b31b5e |
line wrap: on
line source
;;; avl-tree.el --- balanced binary trees, AVL-trees ;; Copyright (C) 1995, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ;; Author: Per Cederqvist <ceder@lysator.liu.se> ;; Inge Wallin <inge@lysator.liu.se> ;; Thomas Bellman <bellman@lysator.liu.se> ;; Maintainer: FSF ;; Created: 10 May 1991 ;; Keywords: extensions, data structures ;; This file is part of GNU Emacs. ;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: ;; An AVL tree is a nearly-perfect balanced binary tree. A tree consists of ;; two elements, the root node and the compare function. The actual tree ;; has a dummy node as its root with the real root in the left pointer. ;; ;; Each node of the tree consists of one data element, one left ;; sub-tree and one right sub-tree. Each node also has a balance ;; count, which is the difference in depth of the left and right ;; sub-trees. ;; ;; The functions with names of the form "avl-tree--" are intended for ;; internal use only. ;;; Code: (eval-when-compile (require 'cl)) ;; ================================================================ ;;; Functions and macros handling an AVL tree node. (defstruct (avl-tree--node ;; We force a representation without tag so it matches the ;; pre-defstruct representation. Also we use the underlying ;; representation in the implementation of avl-tree--node-branch. (:type vector) (:constructor nil) (:constructor avl-tree--node-create (left right data balance)) (:copier nil)) left right data balance) (defalias 'avl-tree--node-branch 'aref ;; This implementation is efficient but breaks the defstruct abstraction. ;; An alternative could be ;; (funcall (aref [avl-tree-left avl-tree-right avl-tree-data] branch) node) "Get value of a branch of a node. NODE is the node, and BRANCH is the branch. 0 for left pointer, 1 for right pointer and 2 for the data.\" \(fn node branch)") ;; The funcall/aref trick doesn't work for the setf method, unless we try ;; and access the underlying setter function, but this wouldn't be ;; portable either. (defsetf avl-tree--node-branch aset) ;; ================================================================ ;;; Internal functions for use in the AVL tree package (defstruct (avl-tree- ;; A tagged list is the pre-defstruct representation. ;; (:type list) :named (:constructor nil) (:constructor avl-tree-create (cmpfun)) (:predicate avl-tree-p) (:copier nil)) (dummyroot (avl-tree--node-create nil nil nil 0)) cmpfun) (defmacro avl-tree--root (tree) ;; Return the root node for an avl-tree. INTERNAL USE ONLY. `(avl-tree--node-left (avl-tree--dummyroot tree))) (defsetf avl-tree--root (tree) (node) `(setf (avl-tree--node-left (avl-tree--dummyroot ,tree)) ,node)) ;; ---------------------------------------------------------------- ;; Deleting data (defun avl-tree--del-balance1 (node branch) ;; Rebalance a tree and return t if the height of the tree has shrunk. (let ((br (avl-tree--node-branch node branch)) p1 b1 p2 b2 result) (cond ((< (avl-tree--node-balance br) 0) (setf (avl-tree--node-balance br) 0) t) ((= (avl-tree--node-balance br) 0) (setf (avl-tree--node-balance br) +1) nil) (t ;; Rebalance. (setq p1 (avl-tree--node-right br) b1 (avl-tree--node-balance p1)) (if (>= b1 0) ;; Single RR rotation. (progn (setf (avl-tree--node-right br) (avl-tree--node-left p1)) (setf (avl-tree--node-left p1) br) (if (= 0 b1) (progn (setf (avl-tree--node-balance br) +1) (setf (avl-tree--node-balance p1) -1) (setq result nil)) (setf (avl-tree--node-balance br) 0) (setf (avl-tree--node-balance p1) 0) (setq result t)) (setf (avl-tree--node-branch node branch) p1) result) ;; Double RL rotation. (setq p2 (avl-tree--node-left p1) b2 (avl-tree--node-balance p2)) (setf (avl-tree--node-left p1) (avl-tree--node-right p2)) (setf (avl-tree--node-right p2) p1) (setf (avl-tree--node-right br) (avl-tree--node-left p2)) (setf (avl-tree--node-left p2) br) (setf (avl-tree--node-balance br) (if (> b2 0) -1 0)) (setf (avl-tree--node-balance p1) (if (< b2 0) +1 0)) (setf (avl-tree--node-branch node branch) p2) (setf (avl-tree--node-balance p2) 0) t))))) (defun avl-tree--del-balance2 (node branch) (let ((br (avl-tree--node-branch node branch)) p1 b1 p2 b2 result) (cond ((> (avl-tree--node-balance br) 0) (setf (avl-tree--node-balance br) 0) t) ((= (avl-tree--node-balance br) 0) (setf (avl-tree--node-balance br) -1) nil) (t ;; Rebalance. (setq p1 (avl-tree--node-left br) b1 (avl-tree--node-balance p1)) (if (<= b1 0) ;; Single LL rotation. (progn (setf (avl-tree--node-left br) (avl-tree--node-right p1)) (setf (avl-tree--node-right p1) br) (if (= 0 b1) (progn (setf (avl-tree--node-balance br) -1) (setf (avl-tree--node-balance p1) +1) (setq result nil)) (setf (avl-tree--node-balance br) 0) (setf (avl-tree--node-balance p1) 0) (setq result t)) (setf (avl-tree--node-branch node branch) p1) result) ;; Double LR rotation. (setq p2 (avl-tree--node-right p1) b2 (avl-tree--node-balance p2)) (setf (avl-tree--node-right p1) (avl-tree--node-left p2)) (setf (avl-tree--node-left p2) p1) (setf (avl-tree--node-left br) (avl-tree--node-right p2)) (setf (avl-tree--node-right p2) br) (setf (avl-tree--node-balance br) (if (< b2 0) +1 0)) (setf (avl-tree--node-balance p1) (if (> b2 0) -1 0)) (setf (avl-tree--node-branch node branch) p2) (setf (avl-tree--node-balance p2) 0) t))))) (defun avl-tree--do-del-internal (node branch q) (let ((br (avl-tree--node-branch node branch))) (if (avl-tree--node-right br) (if (avl-tree--do-del-internal br +1 q) (avl-tree--del-balance2 node branch)) (setf (avl-tree--node-data q) (avl-tree--node-data br)) (setf (avl-tree--node-branch node branch) (avl-tree--node-left br)) t))) (defun avl-tree--do-delete (cmpfun root branch data) ;; Return t if the height of the tree has shrunk. (let ((br (avl-tree--node-branch root branch))) (cond ((null br) nil) ((funcall cmpfun data (avl-tree--node-data br)) (if (avl-tree--do-delete cmpfun br 0 data) (avl-tree--del-balance1 root branch))) ((funcall cmpfun (avl-tree--node-data br) data) (if (avl-tree--do-delete cmpfun br 1 data) (avl-tree--del-balance2 root branch))) (t ;; Found it. Let's delete it. (cond ((null (avl-tree--node-right br)) (setf (avl-tree--node-branch root branch) (avl-tree--node-left br)) t) ((null (avl-tree--node-left br)) (setf (avl-tree--node-branch root branch) (avl-tree--node-right br)) t) (t (if (avl-tree--do-del-internal br 0 br) (avl-tree--del-balance1 root branch)))))))) ;; ---------------------------------------------------------------- ;; Entering data (defun avl-tree--enter-balance1 (node branch) ;; Rebalance a tree and return t if the height of the tree has grown. (let ((br (avl-tree--node-branch node branch)) p1 p2 b2 result) (cond ((< (avl-tree--node-balance br) 0) (setf (avl-tree--node-balance br) 0) nil) ((= (avl-tree--node-balance br) 0) (setf (avl-tree--node-balance br) +1) t) (t ;; Tree has grown => Rebalance. (setq p1 (avl-tree--node-right br)) (if (> (avl-tree--node-balance p1) 0) ;; Single RR rotation. (progn (setf (avl-tree--node-right br) (avl-tree--node-left p1)) (setf (avl-tree--node-left p1) br) (setf (avl-tree--node-balance br) 0) (setf (avl-tree--node-branch node branch) p1)) ;; Double RL rotation. (setq p2 (avl-tree--node-left p1) b2 (avl-tree--node-balance p2)) (setf (avl-tree--node-left p1) (avl-tree--node-right p2)) (setf (avl-tree--node-right p2) p1) (setf (avl-tree--node-right br) (avl-tree--node-left p2)) (setf (avl-tree--node-left p2) br) (setf (avl-tree--node-balance br) (if (> b2 0) -1 0)) (setf (avl-tree--node-balance p1) (if (< b2 0) +1 0)) (setf (avl-tree--node-branch node branch) p2)) (setf (avl-tree--node-balance (avl-tree--node-branch node branch)) 0) nil)))) (defun avl-tree--enter-balance2 (node branch) ;; Return t if the tree has grown. (let ((br (avl-tree--node-branch node branch)) p1 p2 b2) (cond ((> (avl-tree--node-balance br) 0) (setf (avl-tree--node-balance br) 0) nil) ((= (avl-tree--node-balance br) 0) (setf (avl-tree--node-balance br) -1) t) (t ;; Balance was -1 => Rebalance. (setq p1 (avl-tree--node-left br)) (if (< (avl-tree--node-balance p1) 0) ;; Single LL rotation. (progn (setf (avl-tree--node-left br) (avl-tree--node-right p1)) (setf (avl-tree--node-right p1) br) (setf (avl-tree--node-balance br) 0) (setf (avl-tree--node-branch node branch) p1)) ;; Double LR rotation. (setq p2 (avl-tree--node-right p1) b2 (avl-tree--node-balance p2)) (setf (avl-tree--node-right p1) (avl-tree--node-left p2)) (setf (avl-tree--node-left p2) p1) (setf (avl-tree--node-left br) (avl-tree--node-right p2)) (setf (avl-tree--node-right p2) br) (setf (avl-tree--node-balance br) (if (< b2 0) +1 0)) (setf (avl-tree--node-balance p1) (if (> b2 0) -1 0)) (setf (avl-tree--node-branch node branch) p2)) (setf (avl-tree--node-balance (avl-tree--node-branch node branch)) 0) nil)))) (defun avl-tree--do-enter (cmpfun root branch data) ;; Return t if height of tree ROOT has grown. INTERNAL USE ONLY. (let ((br (avl-tree--node-branch root branch))) (cond ((null br) ;; Data not in tree, insert it. (setf (avl-tree--node-branch root branch) (avl-tree--node-create nil nil data 0)) t) ((funcall cmpfun data (avl-tree--node-data br)) (and (avl-tree--do-enter cmpfun br 0 data) (avl-tree--enter-balance2 root branch))) ((funcall cmpfun (avl-tree--node-data br) data) (and (avl-tree--do-enter cmpfun br 1 data) (avl-tree--enter-balance1 root branch))) (t (setf (avl-tree--node-data br) data) nil)))) ;; ---------------------------------------------------------------- (defun avl-tree--mapc (map-function root) ;; Apply MAP-FUNCTION to all nodes in the tree starting with ROOT. ;; The function is applied in-order. ;; ;; Note: MAP-FUNCTION is applied to the node and not to the data itself. ;; INTERNAL USE ONLY. (let ((node root) (stack nil) (go-left t)) (push nil stack) (while node (if (and go-left (avl-tree--node-left node)) ;; Do the left subtree first. (progn (push node stack) (setq node (avl-tree--node-left node))) ;; Apply the function... (funcall map-function node) ;; and do the right subtree. (setq node (if (setq go-left (avl-tree--node-right node)) (avl-tree--node-right node) (pop stack))))))) (defun avl-tree--do-copy (root) ;; Copy the avl tree with ROOT as root. ;; Highly recursive. INTERNAL USE ONLY. (if (null root) nil (avl-tree--node-create (avl-tree--do-copy (avl-tree--node-left root)) (avl-tree--do-copy (avl-tree--node-right root)) (avl-tree--node-data root) (avl-tree--node-balance root)))) ;; ================================================================ ;;; The public functions which operate on AVL trees. (defalias 'avl-tree-compare-function 'avl-tree--cmpfun "Return the comparison function for the avl tree TREE. \(fn TREE)") (defun avl-tree-empty (tree) "Return t if avl tree TREE is emtpy, otherwise return nil." (null (avl-tree--root tree))) (defun avl-tree-enter (tree data) "In the avl tree TREE insert DATA. Return DATA." (avl-tree--do-enter (avl-tree--cmpfun tree) (avl-tree--dummyroot tree) 0 data) data) (defun avl-tree-delete (tree data) "From the avl tree TREE, delete DATA. Return the element in TREE which matched DATA, nil if no element matched." (avl-tree--do-delete (avl-tree--cmpfun tree) (avl-tree--dummyroot tree) 0 data)) (defun avl-tree-member (tree data) "Return the element in the avl tree TREE which matches DATA. Matching uses the compare function previously specified in `avl-tree-create' when TREE was created. If there is no such element in the tree, the value is nil." (let ((node (avl-tree--root tree)) (compare-function (avl-tree--cmpfun tree)) found) (while (and node (not found)) (cond ((funcall compare-function data (avl-tree--node-data node)) (setq node (avl-tree--node-left node))) ((funcall compare-function (avl-tree--node-data node) data) (setq node (avl-tree--node-right node))) (t (setq found t)))) (if node (avl-tree--node-data node) nil))) (defun avl-tree-map (__map-function__ tree) "Apply __MAP-FUNCTION__ to all elements in the avl tree TREE." (avl-tree--mapc (lambda (node) (setf (avl-tree--node-data node) (funcall __map-function__ (avl-tree--node-data node)))) (avl-tree--root tree))) (defun avl-tree-first (tree) "Return the first element in TREE, or nil if TREE is empty." (let ((node (avl-tree--root tree))) (when node (while (avl-tree--node-left node) (setq node (avl-tree--node-left node))) (avl-tree--node-data node)))) (defun avl-tree-last (tree) "Return the last element in TREE, or nil if TREE is empty." (let ((node (avl-tree--root tree))) (when node (while (avl-tree--node-right node) (setq node (avl-tree--node-right node))) (avl-tree--node-data node)))) (defun avl-tree-copy (tree) "Return a copy of the avl tree TREE." (let ((new-tree (avl-tree-create (avl-tree--cmpfun tree)))) (setf (avl-tree--root new-tree) (avl-tree--do-copy (avl-tree--root tree))) new-tree)) (defun avl-tree-flatten (tree) "Return a sorted list containing all elements of TREE." (nreverse (let ((treelist nil)) (avl-tree--mapc (lambda (node) (push (avl-tree--node-data node) treelist)) (avl-tree--root tree)) treelist))) (defun avl-tree-size (tree) "Return the number of elements in TREE." (let ((treesize 0)) (avl-tree--mapc (lambda (data) (setq treesize (1+ treesize))) (avl-tree--root tree)) treesize)) (defun avl-tree-clear (tree) "Clear the avl tree TREE." (setf (avl-tree--root tree) nil)) (provide 'avl-tree) ;; arch-tag: 47e26701-43c9-4222-bd79-739eac6357a9 ;;; avl-tree.el ends here