view lisp/emacs-lisp/avl-tree.el @ 110410:f2e111723c3a

Merge changes made in Gnus trunk. Reimplement nnimap, and do tweaks to the rest of the code to support that. * gnus-int.el (gnus-finish-retrieve-group-infos) (gnus-retrieve-group-data-early): New functions. * gnus-range.el (gnus-range-nconcat): New function. * gnus-start.el (gnus-get-unread-articles): Support early retrieval of data. (gnus-read-active-for-groups): Support finishing the early retrieval of data. * gnus-sum.el (gnus-summary-move-article): Pass the move-to group name if the move is internal, so that nnimap can do fast internal moves. * gnus.el (gnus-article-special-mark-lists): Add uid/active tuples, for nnimap usage. * nnimap.el: Rewritten. * nnmail.el (nnmail-inhibit-default-split-group): New internal variable to allow the mail splitting to not return a default group. This is useful for nnimap, which will leave unmatched mail in the inbox. * utf7.el (utf7-encode): Autoload. Implement shell connection. * nnimap.el (nnimap-open-shell-stream): New function. (nnimap-open-connection): Use it. Get the number of lines by using BODYSTRUCTURE. (nnimap-transform-headers): Get the number of lines in each message. (nnimap-retrieve-headers): Query for BODYSTRUCTURE so that we get the number of lines. Not all servers return UIDNEXT. Work past this problem. Remove junk from end of file. Fix typo in "bogus" section. Make capabilties be case-insensitive. Require cl when compiling. Don't bug out if the LIST command doesn't have any parameters. 2010-09-17 Knut Anders Hatlen <[e-mail]> (tiny change) * nnimap.el (nnimap-get-groups): Don't bug out if the LIST command doesn't have any parameters. (mm-text-html-renderer): Document gnus-article-html. 2010-09-17 Julien Danjou <[e-mail]> (tiny fix) * mm-decode.el (mm-text-html-renderer): Document gnus-article-html. * dgnushack.el: Define netrc-credentials. If the user doesn't have a /etc/services, supply some sensible port defaults. Have `unseen-or-unread' select an unread unseen article first. (nntp-open-server): Return whether the open was successful or not. Throughout all files, replace (save-excursion (set-buffer ...)) with (with-current-buffer ... ). Save result so that it doesn't say "failed" all the time. Add ~/.authinfo to the default, since that's probably most useful for users. Don't use the "finish" method when we're reading from the agent. Add some more nnimap-relevant agent stuff to nnagent.el. * nnimap.el (nnimap-with-process-buffer): Removed. Revert one line that was changed by mistake in the last checkin. (nnimap-open-connection): Don't error out when we can't make a connection nnimap-related changes to avoid bugging out if we can't contact a server. * gnus-start.el (gnus-get-unread-articles): Don't try to scan groups from methods that are denied. * nnimap.el (nnimap-possibly-change-group): Return nil if we can't log in. (nnimap-finish-retrieve-group-infos): Make sure we're not waiting for nothing. * gnus-sum.el (gnus-select-newsgroup): Indent.

;;; avl-tree.el --- balanced binary trees, AVL-trees

;; Copyright (C) 1995, 2007, 2008, 2009, 2010  Free Software Foundation, Inc.

;; Author: Per Cederqvist <[e-mail]>
;;	Inge Wallin <[e-mail]>
;;	Thomas Bellman <[e-mail]>
;; 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