[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[ELPA-diffs] /srv/bzr/emacs/elpa r206: Add trie.el
|
From: |
Toby S. Cubitt |
|
Subject: |
[ELPA-diffs] /srv/bzr/emacs/elpa r206: Add trie.el |
|
Date: |
Sun, 29 Apr 2012 13:45:19 +0200 |
|
User-agent: |
Bazaar (2.3.1) |
------------------------------------------------------------
revno: 206
committer: Toby S. Cubitt <address@hidden>
branch nick: elpa
timestamp: Sun 2012-04-29 13:45:19 +0200
message:
Add trie.el
added:
packages/trie/
packages/trie/trie.el
=== added directory 'packages/trie'
=== added file 'packages/trie/trie.el'
--- a/packages/trie/trie.el 1970-01-01 00:00:00 +0000
+++ b/packages/trie/trie.el 2012-04-29 11:45:19 +0000
@@ -0,0 +1,1951 @@
+;;; trie.el --- trie package
+
+
+;; Copyright (C) 2008-2010, 2012 Free Software Foundation, Inc
+
+;; Author: Toby Cubitt <address@hidden>
+;; Version: 0.2.5
+;; Keywords: extensions, matching, data structures
+;; trie, ternary search tree, tree, completion, regexp
+;; Package-Requires: ((emacs "24.1") (tNFA "0.1.1") (heap "0.3"))
+;; URL: http://www.dr-qubit.org/emacs.php
+;; Repository: http://www.dr-qubit.org/git/predictive.git
+
+;; This file is part of 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:
+;;
+;; Quick Overview
+;; --------------
+;; A trie is a data structure used to store keys that are ordered sequences of
+;; elements (vectors, lists or strings in Elisp; strings are by far the most
+;; common), in such a way that both storage and retrieval are space- and
+;; time-efficient. But, more importantly, a variety of more advanced queries
+;; can also be performed efficiently: for example, returning all strings with
+;; a given prefix, searching for keys matching a given wildcard pattern or
+;; regular expression, or searching for all keys that match any of the above
+;; to within a given Lewenstein distance (though this last is not yet
+;; implemented in this package - code contributions welcome!).
+;;
+;; You create a trie using `make-trie', create an association using
+;; `trie-insert', retrieve an association using `trie-lookup', and map over a
+;; trie using `trie-map', `trie-mapc', `trie-mapcar', or `trie-mapf'. You can
+;; find completions of a prefix sequence using `trie-complete', or search for
+;; keys matching a regular expression using `trie-regexp-search'. Using
+;; `trie-stack', you can create an object that allows the contents of the trie
+;; to be used like a stack, useful for building other algorithms on top of
+;; tries; `trie-stack-pop' pops elements off the stack one-by-one, in
+;; "lexical" order, whilst `trie-stack-push' pushes things onto the
+;; stack. Similarly, `trie-complete-stack', and `trie-regexp-stack' create
+;; "lexically-ordered" stacks of query results.
+;;
+;; Note that there are two uses for a trie: as a lookup table, in which case
+;; only the presence or absence of a key in the trie is significant, or as an
+;; associative array, in which case each key carries some associated
+;; data. Libraries for other data structure often only implement lookup
+;; tables, leaving it up to you to implement an associative array on top of
+;; this (by storing key+data pairs in the data structure's keys, then defining
+;; a comparison function that only compares the key part). For a trie,
+;; however, the underlying data structures naturally support associative
+;; arrays at no extra cost, so this package does the opposite: it implements
+;; associative arrays, and leaves it up to you to use them as lookup tables if
+;; you so desire.
+;;
+;;
+;; Different Types of Trie
+;; -----------------------
+;; There are numerous ways to implement trie data structures internally, each
+;; with its own time- and space-efficiency trade-offs. By viewing a trie as a
+;; tree whose nodes are themselves lookup tables for key elements, this
+;; package is able to support all types of trie in a uniform manner. This
+;; relies on there existing (or you writing!) an Elisp implementation of the
+;; corresponding type of lookup table. The best type of trie to use will
+;; depend on what trade-offs are appropriate for your particular
+;; application. The following gives an overview of the advantages and
+;; disadvantages of various types of trie. (Not all of the underlying lookup
+;; tables have been implemented in Elisp yet, so using some of the trie types
+;; described below would require writing the missing Elisp package!)
+;;
+;;
+;; One of the most effective all-round implementations of a trie is a ternary
+;; search tree, which can be viewed as a tree of binary trees. If basic binary
+;; search trees are used for the nodes of the trie, we get a standard ternary
+;; search tree. If self-balancing binary trees are used (e.g. AVL or red-black
+;; trees), we get a self-balancing ternary search tree. If splay trees are
+;; used, we get yet another self-organising variant of a ternary search
+;; tree. All ternary search trees have, in common, good space-efficiency. The
+;; time-efficiency of the various trie operations is also good, assuming the
+;; underlying binary trees are balanced. Under that assumption, all variants
+;; of ternary search trees described below have the same asymptotic
+;; time-complexity for all trie operations.
+;;
+;; Self-balancing trees ensure the underlying binary trees are always close to
+;; perfectly balanced, with the usual trade-offs between the different the
+;; types of self-balancing binary tree: AVL trees are slightly more efficient
+;; for lookup operations than red-black trees, at a cost of slightly less
+;; efficienct insertion operations, and less efficient deletion
+;; operations. Splay trees give good average-case complexity and are simpler
+;; to implement than AVL or red-black trees (which can mean they're faster in
+;; practice!), at the expense of poor worst-case complexity.
+;;
+;; If your tries are going to be static (i.e. created once and rarely
+;; modified), then using perfectly balanced binary search trees might be
+;; appropriate. Perfectly balancing the binary trees is very inefficient, but
+;; it only has to be when the trie is first created or modified. Lookup
+;; operations will then be as efficient as possible for ternary search trees,
+;; and the implementation will also be simpler (so probably faster) than a
+;; self-balancing tree, without the space and time overhead required to keep
+;; track of rebalancing.
+;;
+;; On the other hand, adding data to a binary search tree in a random order
+;; usually results in a reasonably balanced tree. If this is the likely
+;; scenario, using a basic binary tree without bothering to balance it at all
+;; might be quite efficient, and, being even simpler to implement, could be
+;; quite fast overall.
+;;
+;;
+;; A digital trie is a different implementation of a trie, which can be viewed
+;; as a tree of arrays, and has different space- and time-complexities than a
+;; ternary search tree. Roughly speaking, a digital trie has worse
+;; space-complexity, but better time-complexity. Using hash tables instead of
+;; arrays for the nodes gives something similar to a digital trie, potentially
+;; with better space-complexity and the same amortised time-complexity, but at
+;; the expense of occasional significant inefficiency when inserting and
+;; deleting (whenever a hash table has to be resized). Indeed, an array can be
+;; viewed as a perfect hash table, but as such it requires the number of
+;; possible values to be known in advance.
+;;
+;; Finally, if you really need optimal efficiency from your trie, you could
+;; even write a custom type of underlying lookup table, optimised for your
+;; specific needs.
+;;
+;; This package uses the AVL tree package avl-tree.el, the tagged NFA package
+;; tNFA.el, and the heap package heap.el.
+
+
+;;; Change Log:
+;;
+;; Version 0.2.5
+;; * removed `trie--avl-transform-for-print' and
+;; `trie--avl-transform-from-read', since Emacs has supported printing and
+;; reading circular data structures for a long time now, rendering these
+;; transormers obsolete (note that `print-circle' *must* be enabled now when
+;; printing an avl trie)
+;;
+;; Version 0.2.4
+;; * minor bug-fix to `trie--edebug-pretty-print' to print "nil" instead
+;; of "()"
+;;
+;; Version 0.2.3
+;; * bug-fix in `trie--edebug-pretty-print'
+;;
+;; Version 0.2.2
+;; * added `edebug-prin1' and `edebug-prin1-to-string' advice to prevent
+;; edebug hanging whilst printing large tries
+;;
+;; Version 0.2.1
+;; * bug-fix to result accumulation in `trie--do-regexp-search'
+;;
+;; Version 0.2
+;; * Replaced wildcard searches with regexp searches, using the tNFA.el tagged
+;; non-deterministic finite state automata library. This is both more
+;; general *and* more efficient.
+;; * bug fix in `trie--do-regexp-search'
+;;
+;; Version 0.1
+;; * Initial release (complete rewrite from scratch of tstree.el!)
+;; * Ternary search trees are now implemented as a tree of avl trees, which
+;; has numerous advantages: self-balancing trees guarantee O(log n)
+;; complexity regardless of how the tree is built; deletion is now done
+;; properly.
+;; * Unlike tstree.el, trie.el is general enough to implement all sorts of
+;; tries, not just ternary search trees (though these remain the default).
+;; * Up to "tstree"->"trie" renaming, many functions are drop-in replacements
+;; for tstree.el functions. However, insertion and rank functions are no
+;; longer stored in the data structure, so corresponidng arguments are no
+;; longer optional. A single `trie-complete' function now deals with sorting
+;; completions in both lexical or arbitrary order, the ranking function
+;; being passed as an optional argument in the latter case. And functions
+;; can no longer operate over multiple data structures at once; i.e. they no
+;; longer accept lists of trees as arguments. (These features belong in
+;; higher level libraries, and the efficiency loss is negligible.)
+;; * `trie-wildcard-search' implements efficient shell-glob-like wildcard
+;; searches of tries!
+
+
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+(require 'avl-tree)
+(require 'heap)
+(require 'tNFA)
+
+
+
+;;; ================================================================
+;;; Pre-defined trie types
+
+(defconst trie--types '(avl))
+
+
+;; --- avl-tree ---
+(put 'avl :trie-createfun
+ (lambda (cmpfun seq) (avl-tree-create cmpfun)))
+(put 'avl :trie-insertfun 'avl-tree-enter)
+(put 'avl :trie-deletefun 'avl-tree-delete)
+(put 'avl :trie-lookupfun 'avl-tree-member)
+(put 'avl :trie-mapfun 'avl-tree-mapc)
+(put 'avl :trie-emptyfun 'avl-tree-empty)
+(put 'avl :trie-stack-createfun 'avl-tree-stack)
+(put 'avl :trie-stack-popfun 'avl-tree-stack-pop)
+(put 'avl :trie-stack-emptyfun 'avl-tree-stack-empty-p)
+
+
+
+;;; ================================================================
+;;; Internal utility functions and macros
+
+;;; ----------------------------------------------------------------
+;;; Functions and macros for handling a trie.
+
+;; symbol used to denote a trie leaf node
+(defconst trie--terminator '--trie--terminator)
+
+(defstruct
+ (trie-
+ :named
+ (:constructor nil)
+ (:constructor trie--create
+ (comparison-function &optional (type 'avl)
+ &aux
+ (dummy
+ (or (memq type trie--types)
+ (error "trie--create: unknown trie TYPE, %s" type)))
+ (createfun (get type :trie-createfun))
+ (insertfun (get type :trie-insertfun))
+ (deletefun (get type :trie-deletefun))
+ (lookupfun (get type :trie-lookupfun))
+ (mapfun (get type :trie-mapfun))
+ (emptyfun (get type :trie-emptyfun))
+ (stack-createfun (get type :trie-stack-createfun))
+ (stack-popfun (get type :trie-stack-popfun))
+ (stack-emptyfun (get type :trie-stack-emptyfun))
+ (transform-for-print (get type :trie-transform-for-print))
+ (transform-from-read (get type :trie-transform-from-read))
+ (cmpfun (trie--wrap-cmpfun comparison-function))
+ (root (trie--node-create-root createfun cmpfun))
+ ))
+ (:constructor trie--create-custom
+ (comparison-function
+ &key
+ (createfun 'avl-tree-create-bare)
+ (insertfun 'avl-tree-enter)
+ (deletefun 'avl-tree-delete)
+ (lookupfun 'avl-tree-member)
+ (mapfun 'avl-tree-mapc)
+ (emptyfun 'avl-tree-empty)
+ (stack-createfun 'avl-tree-stack)
+ (stack-popfun 'avl-tree-stack-pop)
+ (stack-emptyfun 'avl-tree-stack-empty-p)
+ (transform-for-print nil)
+ (transform-from-read nil)
+ &aux
+ (cmpfun (trie--wrap-cmpfun comparison-function))
+ (root (trie--node-create-root createfun cmpfun))
+ ))
+ (:copier nil))
+ root comparison-function cmpfun
+ createfun insertfun deletefun lookupfun mapfun emptyfun
+ stack-createfun stack-popfun stack-emptyfun
+ transform-for-print transform-from-read print-form)
+
+
+(defun trie--wrap-cmpfun (cmpfun)
+ ;; wrap CMPFUN for use in a subtree
+ `(lambda (a b)
+ (setq a (trie--node-split a)
+ b (trie--node-split b))
+ (cond ((eq a trie--terminator)
+ (if (eq b trie--terminator) nil t))
+ ((eq b trie--terminator) nil)
+ (t (,cmpfun a b)))))
+
+
+(defun trie--construct-equality-function (comparison-function)
+ ;; create equality function from trie comparison function
+ `(lambda (a b)
+ (and (not (,comparison-function a b))
+ (not (,comparison-function b a)))))
+
+
+
+;;; ----------------------------------------------------------------
+;;; Functions and macros for handling a trie node.
+
+(defstruct
+ (trie--node
+ (:type vector)
+ (:constructor nil)
+ (:constructor trie--node-create
+ (split seq trie
+ &aux (subtree (funcall (trie--createfun trie)
+ (trie--cmpfun trie) seq))))
+ (:constructor trie--node-create-data
+ (data &aux (split trie--terminator) (subtree data)))
+ (:constructor trie--node-create-dummy
+ (split &aux (subtree nil)))
+ (:constructor trie--node-create-root
+ (createfun cmpfun
+ &aux
+ (split nil)
+ (subtree (funcall createfun cmpfun []))))
+ (:copier nil))
+ split subtree)
+
+;; data is stored in the subtree cell of a terminal node
+(defalias 'trie--node-data 'trie--node-subtree)
+
+(defsetf trie--node-data (node) `(setf (trie--node-subtree ,node)))
+
+(defmacro trie--node-data-p (node)
+ ;; Return t if NODE is a data node, nil otherwise.
+ `(eq (trie--node-split ,node) trie--terminator))
+
+(defmacro trie--node-p (node)
+ ;; Return t if NODE is a TRIE trie--node, nil otherwise. Have to
+ ;; define this ourselves, because we created a defstruct without any
+ ;; identifying tags (i.e. (:type vector)) for efficiency, but this
+ ;; means we can only perform a rudimentary and very unreliable test.
+ `(and (vectorp ,node) (= (length ,node) 2)))
+
+
+(defun trie--node-find (node seq lookupfun)
+ ;; Returns the node below NODE corresponding to SEQ, or nil if none
+ ;; found.
+ (let ((len (length seq))
+ (i -1))
+ ;; descend trie until we find SEQ or run out of trie
+ (while (and node (< (incf i) len))
+ (setq node
+ (funcall lookupfun
+ (trie--node-subtree node)
+ (trie--node-create-dummy (elt seq i))
+ nil)))
+ node))
+
+
+(defmacro trie--find-data-node (node lookupfun)
+ ;; Return data node from NODE's subtree, or nil if NODE has no data
+ ;; node in its subtree.
+ `(funcall ,lookupfun
+ (trie--node-subtree ,node)
+ (trie--node-create-dummy trie--terminator)
+ nil))
+
+
+(defmacro trie--find-data (node lookupfun)
+ ;; Return data associated with sequence corresponding to NODE, or nil
+ ;; if sequence has no associated data.
+ `(let ((node (trie--find-data-node ,node ,lookupfun)))
+ (when node (trie--node-data node))))
+
+
+
+;;; ----------------------------------------------------------------
+;;; print/read transformation functions
+
+(defun trie-transform-for-print (trie)
+ "Transform TRIE to print form."
+ (when (trie--transform-for-print trie)
+ (if (trie--print-form trie)
+ (warn "Trie has already been transformed to print-form")
+ (funcall (trie--transform-for-print trie) trie)
+ (setf (trie--print-form trie) t))))
+
+
+(defun trie-transform-from-read (trie)
+ "Transform TRIE from print form."
+ (when (trie--transform-from-read trie)
+ (if (not (trie--print-form trie))
+ (warn "Trie is not in print-form")
+ (funcall (trie--transform-from-read trie) trie)
+ (setf (trie--print-form trie) nil))))
+
+
+(defmacro trie-transform-from-read-warn (trie)
+ "Transform TRIE from print form, with warning."
+ `(when (trie--print-form ,trie)
+ (warn (concat "Attempt to operate on trie in print-form;\
+ converting to normal form"))
+ (trie-transform-from-read ,trie)))
+
+
+(defun trie--avl-transform-for-print (trie)
+ ;; transform avl-tree based TRIE to print form.
+ (trie-mapc-internal
+ (lambda (avl seq) (setf (avl-tree--cmpfun avl) nil))
+ trie))
+
+
+(defun trie--avl-transform-from-read (trie)
+ ;; transform avl-tree based TRIE from print form."
+ (let ((--trie-avl-transform--cmpfun (trie--cmpfun trie)))
+ (trie-mapc-internal
+ (lambda (avl seq)
+ (setf (avl-tree--cmpfun avl) --trie-avl-transform--cmpfun))
+ trie)))
+
+
+
+;;; ----------------------------------------------------------------
+;;; Replacements for CL functions
+
+;; copied from cl-extra.el
+(defun trie--subseq (seq start &optional end)
+ "Return the subsequence of SEQ from START to END.
+If END is omitted, it defaults to the length of the sequence.
+If START or END is negative, it counts from the end."
+ (if (stringp seq) (substring seq start end)
+ (let (len)
+ (and end (< end 0) (setq end (+ end (setq len (length seq)))))
+ (when (< start 0)
+ (setq start (+ start (or len (setq len (length seq))))))
+ (cond ((listp seq)
+ (if (> start 0) (setq seq (nthcdr start seq)))
+ (if end
+ (let ((res nil))
+ (while (>= (setq end (1- end)) start)
+ (push (pop seq) res))
+ (nreverse res))
+ (copy-sequence seq)))
+ (t
+ (or end (setq end (or len (length seq))))
+ (let ((res (make-vector (max (- end start) 0) nil))
+ (i 0))
+ (while (< start end)
+ (aset res i (aref seq start))
+ (setq i (1+ i) start (1+ start)))
+ res))))))
+
+
+(defun trie--position (item list)
+ "Find the first occurrence of ITEM in LIST.
+Return the index of the matching item, or nil of not found.
+Comparison is done with 'equal."
+ (let ((i 0))
+ (catch 'found
+ (while (progn
+ (when (equal item (car list)) (throw 'found i))
+ (setq i (1+ i))
+ (setq list (cdr list))))
+ nil)))
+
+
+(defsubst trie--seq-append (seq el)
+ "Append EL to the end of sequence SEQ."
+ (cond
+ ((stringp seq) (concat seq (string el)))
+ ((vectorp seq) (vconcat seq (vector el)))
+ ((listp seq) (append seq (list el)))))
+
+
+(defsubst trie--seq-concat (seq &rest sequences)
+ "Concatenate SEQ and SEQUENCES, and make the result the same
+type of sequence as SEQ."
+ (cond
+ ((stringp seq) (apply 'concat seq sequences))
+ ((vectorp seq) (apply 'vconcat seq sequences))
+ ((listp seq) (apply 'append seq sequences))))
+
+
+
+
+;;; ================================================================
+;;; Basic trie operations
+
+;;;###autoload
+(defalias 'make-trie 'trie--create
+ "Return a new trie that uses comparison function COMPARISON-FUNCTION.
+
+A trie stores sequences (strings, vectors or lists) along with
+associated data. COMPARISON-FUNCTEION should accept two
+arguments, each being an element of such a sequence, and return t
+if the first is strictly smaller than the second.
+
+The optional argument TYPE specifies the type of trie to
+create. However, the only one that is currently implemented is
+the default, so this argument is useless for now.
+
+(See also `make-trie-custom'.)")
+
+
+;;;###autoload
+(defalias 'trie-create 'make-trie)
+
+
+;;;###autoload
+(defalias 'make-trie-custom 'trie--create-custom
+ "Return a new trie that uses comparison function COMPARISON-FUNCTION.
+
+A trie stores sequences (strings, vectors or lists) along with
+associated data. COMPARISON-FUNCTION should accept two arguments,
+each being an element of such a sequence, and return t if the
+first is strictly smaller than the second.
+
+The remaining keyword arguments: :CREATEFUN, :INSERTFUN, :DELETEFUN,
+:LOOKUPFUN, :MAPFUN, :EMPTYFUN, :STACK-CREATEFUN, :STACK-POPFUN,
+:STACK-EMPTYFUN, :TRANSFORM-FOR-PRINT and :TRANSFORM-FROM-READ
+determine the type of trie that is created.
+
+CREATEFUN is called as follows:
+
+ (CREATEFUN COMPARISON-FUNCTION SEQ)
+
+and should return a data structure (\"ARRAY\") that can be used
+as an associative array, where two elements A and B are equal if
+the following is non-nil:
+
+ (and (COMPARISON-FUNCTION b a)
+ (COMPARISON-FUNCTION b a))
+
+The SEQ argument is a vector containing the sequence that will
+correspond to the newly created array in the trie. For most types
+of trie, this value is ignored. It is passed to CREATEFUN only in
+order to allow the creation of \"hybrid\" trie structures, in
+which different types of associative array are used in different
+parts of the trie. For example, the type of associative array
+could be chosen based on the depth in the trie, given by \(length
+SEQ\). (Note that all the other functions described below must be
+able to correctly handle *any* of the types of associate array
+that might be created by CREATEFUN.)
+
+INSERTFUN, DELETEFUN, LOOKUPFUN, MAPFUN and EMPTYFUN should
+insert, delete, lookup, map over, and check-if-there-exist-any
+elements in an associative array. They are called as follows:
+
+ (INSERTFUN array element &optional updatefun)
+ (DELETEFUN array element &optional predicate nilflag)
+ (LOOKUPFUN array element &optional nilflag)
+ (MAPFUN function array &optional reverse)
+ (EMPTYFUN array)
+
+INSERTFUN should insert ELEMENT into ARRAY and return the new
+element, which will be ELEMENT itself unless UPDATEFUN is
+specified. In that case, if and only if an element matching
+ELEMENT already exists in the associative array, INSERTFUN should
+instead pass ELEMENT and the matching element as arguments to
+UPDATEFUN, replace the matching element with the return value,
+and return that return value.
+
+DELETEFUN should delete the element in the associative array that
+matches ELEMENT, and return the deleted element. However, if
+PREDICATE is specified and a matching element exists in ARRAY,
+DELETEFUN should first pass the matching element as an argument
+to PREDICATE before deleting, and should only delete the element
+if PREDICATE returns non-nil. DELETEFUN should return NILFLAG if
+no element was deleted (either becuase no matching element was
+found, or because TESTFUN returned nil).
+
+LOOKUPFUN should return the element from the associative array
+that matches ELEMENT, or NILFLAG if no matching element exists.
+
+MAPFUN should map FUNCTION over all elements in the order defined by
+COMPARISON-FUNCTION, or in reverse order if REVERSE is non-nil.
+
+
+STACK-CREATEFUN, STACK-POPFUN and STACK-EMPTYFUN should allow the
+associative array to be used as a stack. STACK-CREATEFUN is
+called as follows:
+
+ (STACK-CREATEFUN array)
+
+and should return a data structure (\"STACK\") that behaves like
+a sorted stack of all elements in the associative array. I.e.
+successive calls to
+
+ (STACK-POPFUN stack)
+
+should return elements from the associative array in the order
+defined by COMPARISON-FUNCTION, and
+
+ (STACK-EMPTYFUN stack)
+
+should return non-nil if the stack is empty, nil otherwise.
+
+The stack functions are optional, in that all trie operations
+other than the stack-related ones will work correctly. However,
+any code that makes use of trie-stacks will complain if supplied
+with this type of trie.
+
+
+The :TRANSFORM-FOR-PRINT and :TRANSFORM-FROM-READ arguments are
+optional. If supplied, they can be used to transform the trie
+into a format suitable for passing to Elisp's `print'
+functions (typically used to persistently store the trie by
+writing it to file), and transform from that format back to the
+original usable form.
+
+
+Warning: to avoid nasty dynamic scoping bugs, the supplied
+functions must *never* bind any variables with names commencing
+\"--\".")
+
+
+;;;###autoload
+(defalias 'trie-create-custom 'make-trie-custom)
+
+
+
+(defalias 'trie-comparison-function 'trie--comparison-function
+ "Return the comparison function for TRIE.")
+
+
+(defalias 'trie-p 'trie--p
+ "Return t if argument is a trie, nil otherwise.")
+
+
+(defun trie-empty (trie)
+ "Return t if the TRIE is empty, nil otherwise."
+ (trie-transform-from-read-warn trie)
+ (funcall (trie--emptyfun trie)
+ (trie--node-subtree (trie--root trie))))
+
+
+(defun trie-construct-sortfun (cmpfun &optional reverse)
+ "Construct function to compare key sequences, based on a CMPFUN
+that compares individual elements of the sequence. Order is
+reversed if REVERSE is non-nil."
+ (if reverse
+ `(lambda (a b)
+ (let (cmp)
+ (catch 'compared
+ (dotimes (i (min (length a) (length b)))
+ (cond ((,cmpfun (elt b i) (elt a i))
+ (throw 'compared t))
+ ((,cmpfun (elt a i) (elt b i))
+ (throw 'compared nil))))
+ (< (length a) (length b)))))
+ `(lambda (a b)
+ (let (cmp)
+ (catch 'compared
+ (dotimes (i (min (length a) (length b)))
+ (cond ((,cmpfun (elt a i) (elt b i))
+ (throw 'compared t))
+ ((,cmpfun (elt b i) (elt a i))
+ (throw 'compared nil))))
+ (< (length a) (length b)))))))
+
+
+
+;; ----------------------------------------------------------------
+;; Inserting data
+
+(defun trie-insert (trie key &optional data updatefun)
+ "Associate DATA with KEY in TRIE.
+
+If KEY already exists in TRIE, then DATA replaces the existing
+association, unless UPDATEFUN is supplied. Note that if DATA is
+*not* supplied, this means that the existing association of KEY
+will be replaced by nil.
+
+If UPDATEFUN is supplied and KEY already exists in TRIE,
+UPDATEFUN is called with two arguments: DATA and the existing
+association of KEY. Its return value becomes the new association
+for KEY.
+
+Returns the new association of KEY.
+
+Note: to avoid nasty dynamic scoping bugs, UPDATEFUN must *not*
+bind any variables with names commencing \"--\"."
+
+ ;; convert trie from print-form if necessary
+ (trie-transform-from-read-warn trie)
+
+ ;; absurd variable names are an attempt to avoid dynamic scoping bugs
+ (let ((--trie-insert--updatefun updatefun)
+ --trie-insert--old-node-flag
+ (node (trie--root trie))
+ (len (length key))
+ (i -1))
+ ;; Descend trie, adding nodes for non-existent elements of KEY. The
+ ;; update function passed to `trie--insertfun' ensures that existing
+ ;; nodes are left intact.
+ (while (< (incf i) len)
+ (setq --trie-insert--old-node-flag nil)
+ (setq node (funcall (trie--insertfun trie)
+ (trie--node-subtree node)
+ (trie--node-create (elt key i) key trie)
+ (lambda (a b)
+ (setq --trie-insert--old-node-flag t) b))))
+ ;; Create or update data node.
+ (setq node (funcall (trie--insertfun trie)
+ (trie--node-subtree node)
+ (trie--node-create-data data)
+ ;; if using existing data node, wrap UPDATEFUN
+ ;; if any was supplied
+ (when (and --trie-insert--old-node-flag
+ --trie-insert--updatefun)
+ (lambda (new old)
+ (setf (trie--node-data old)
+ (funcall --trie-insert--updatefun
+ (trie--node-data new)
+ (trie--node-data old)))
+ old))))
+ (trie--node-data node))) ; return new data
+
+
+
+;; ----------------------------------------------------------------
+;; Deleting data
+
+(defun trie-delete (trie key &optional test)
+ "Delete KEY and its associated data from TRIE.
+
+If KEY was deleted, a cons cell containing KEY and its
+association is returned. Returns nil if KEY does not exist in
+TRIE.
+
+If TEST is supplied, it should be a function that accepts two
+arguments: the key being deleted, and its associated data. The
+key will then only be deleted if TEST returns non-nil.
+
+Note: to avoid nasty dynamic scoping bugs, TEST must *not* bind
+any variables with names commencing \"--\"."
+ ;; convert trie from print-form if necessary
+ (trie-transform-from-read-warn trie)
+ ;; set up deletion (real work is done by `trie--do-delete'
+ (let (--trie-deleted--node
+ (--trie-delete--key key))
+ (declare (special --trie-deleted--node)
+ (special --trie-delete--key))
+ (trie--do-delete (trie--root trie) key test
+ (trie--deletefun trie)
+ (trie--emptyfun trie)
+ (trie--cmpfun trie))
+ (when --trie-deleted--node
+ (cons key (trie--node-data --trie-deleted--node)))))
+
+
+(defun trie--do-delete (node --trie--do-delete--seq
+ --trie--do-delete--test
+ --trie--do-delete--deletefun
+ --trie--do-delete--emptyfun
+ --trie--do-delete--cmpfun)
+ ;; Delete --TRIE--DO-DELETE--SEQ starting from trie node NODE, and
+ ;; return non-nil if we deleted a node. If --TRIE--DO-DELETE--TEST is
+ ;; supplied, it is called with two arguments, the key being deleted
+ ;; and the associated data, and the deletion is only carried out if it
+ ;; returns non-nil.
+
+ ;; The absurd argument names are to lessen the likelihood of dynamical
+ ;; scoping bugs caused by a supplied function binding a variable with
+ ;; the same name as one of the arguments, which would cause a nasty
+ ;; bug when the lambda's (below) are called.
+ (declare (special --trie-deleted--node)
+ (special --trie-delete--key))
+ ;; if --TRIE--DO-DELETE--SEQ is empty, try to delete data node and
+ ;; return non-nil if we did (return value of
+ ;; --TRIE--DO-DELETE--DELETEFUN is the deleted data, which is always
+ ;; non-nil for a trie)
+ (if (= (length --trie--do-delete--seq) 0)
+ (setq --trie-deleted--node
+ (funcall --trie--do-delete--deletefun
+ (trie--node-subtree node)
+ (trie--node-create-dummy trie--terminator)
+ (when --trie--do-delete--test
+ (lambda (n)
+ (funcall --trie--do-delete--test
+ --trie-delete--key (trie--node-data n))))
+ nil))
+ ;; otherwise, delete on down (return value of
+ ;; --TRIE--DO-DELETE--DELETEFUN is the deleted data, which is always
+ ;; non-nil for a trie)
+ (funcall --trie--do-delete--deletefun
+ (trie--node-subtree node)
+ (trie--node-create-dummy (elt --trie--do-delete--seq 0))
+ (lambda (n)
+ (and (trie--do-delete
+ n (trie--subseq --trie--do-delete--seq 1)
+ --trie--do-delete--test
+ --trie--do-delete--deletefun
+ --trie--do-delete--emptyfun
+ --trie--do-delete--cmpfun)
+ (funcall --trie--do-delete--emptyfun
+ (trie--node-subtree n))))
+ nil)))
+
+
+
+;; ----------------------------------------------------------------
+;; Retrieving data
+
+(defun trie-lookup (trie key &optional nilflag)
+ "Return the data associated with KEY in the TRIE,
+or nil if KEY does not exist in TRIE.
+
+Optional argument NILFLAG specifies a value to return instead of
+nil if KEY does not exist in TRIE. This allows a non-existent KEY
+to be distinguished from an element with a null association. (See
+also `trie-member-p', which does this for you.)"
+ ;; convert trie from print-form if necessary
+ (trie-transform-from-read-warn trie)
+ ;; find node corresponding to key, then find data node, then return
+ ;; data
+ (let (node)
+ (or (and (setq node (trie--node-find (trie--root trie) key
+ (trie--lookupfun trie)))
+ (trie--find-data node (trie--lookupfun trie)))
+ nilflag)))
+
+(defalias 'trie-member 'trie-lookup)
+
+
+(defun trie-member-p (trie key)
+ "Return t if KEY exists in TRIE, nil otherwise."
+ ;; convert trie from print-form if necessary
+ (trie-transform-from-read-warn trie)
+ (let ((flag '(nil)))
+ (not (eq flag (trie-member trie key flag)))))
+
+
+
+
+;;; ================================================================
+;;; Mapping over tries
+
+(defun trie--mapc (--trie--mapc--function --trie--mapc--mapfun
+ --trie--mapc--root --trie--mapc--seq
+ &optional --trie--mapc--reverse)
+ ;; Apply TRIE--MAPC--FUNCTION to all elements in a trie beneath
+ ;; TRIE--MAPC--ROOT, which should correspond to the sequence
+ ;; TRIE--MAPC--SEQ. TRIE--MAPC--FUNCTION is passed two arguments: the
+ ;; trie node itself and the sequence it corresponds to. It is applied
+ ;; in ascending order, or descending order if TRIE--MAPC--REVERSE is
+ ;; non-nil.
+
+ ;; The absurd argument names are to lessen the likelihood of dynamical
+ ;; scoping bugs caused by a supplied function binding a variable with
+ ;; the same name as one of the arguments.
+ (funcall
+ --trie--mapc--mapfun
+ (lambda (--trie--mapc--node)
+ ;; data node: apply function
+ (if (trie--node-data-p --trie--mapc--node)
+ (funcall --trie--mapc--function
+ --trie--mapc--node
+ --trie--mapc--seq)
+ ;; internal node: append split value to seq and keep descending
+ (trie--mapc --trie--mapc--function
+ --trie--mapc--mapfun
+ --trie--mapc--node
+ (trie--seq-append
+ (copy-sequence --trie--mapc--seq)
+ (trie--node-split --trie--mapc--node))
+ --trie--mapc--reverse)))
+ ;; --TRIE--MAPC--MAPFUN target
+ (trie--node-subtree --trie--mapc--root)
+ --trie--mapc--reverse))
+
+
+(defun trie-mapc-internal (function trie &optional type)
+ "Apply FUNCTION to all internal associative arrays within TRIE.
+FUNCTION is passed two arguments: an associative array, and the
+sequence it corresponds to.
+
+Optional argument TYPE (one of the symbols vector, lisp or
+string) sets the type of sequence passed to FUNCTION. Defaults to
+vector."
+ (trie--mapc-internal function (trie--mapfun trie) (trie--root trie)
+ (cond ((eq type 'string) "")
+ ((eq type 'lisp) ())
+ (t []))))
+
+
+(defun trie--mapc-internal (--trie--mapc-internal--function
+ --trie--mapc-internal--mapfun
+ --trie--mapc-internal--root
+ --trie--mapc-internal--seq)
+ (funcall
+ --trie--mapc-internal--mapfun
+ (lambda (--trie--mapc-internal--node)
+ ;; data node
+ (unless (trie--node-data-p --trie--mapc-internal--node)
+ (funcall --trie--mapc-internal--function
+ (trie--node-subtree --trie--mapc-internal--node)
+ --trie--mapc-internal--seq)
+ (trie--mapc-internal
+ --trie--mapc-internal--function
+ --trie--mapc-internal--mapfun
+ --trie--mapc-internal--node
+ (trie--seq-append
+ (copy-sequence --trie--mapc-internal--seq)
+ (trie--node-split --trie--mapc-internal--node)))))
+ (trie--node-subtree --trie--mapc-internal--root)))
+
+
+(defun trie-map (function trie &optional type reverse)
+ "Modify all elements in TRIE by applying FUNCTION to them.
+
+FUNCTION should take two arguments: a sequence stored in the trie
+and its associated data. Its return value replaces the existing
+data.
+
+Optional argument TYPE (one of the symbols vector, lisp or
+string) sets the type of sequence passed to FUNCTION. Defaults to
+vector.
+
+FUNCTION is applied in ascending order, or descending order if
+REVERSE is non-nil.
+
+Note: to avoid nasty dynamic scoping bugs, FUNCTION must *not*
+bind any variables with names commencing \"--\"."
+ ;; convert from print-form if necessary
+ (trie-transform-from-read-warn trie)
+ ;; map FUNCTION over TRIE
+ (let ((--trie-map--function function)) ; avoid dynamic scoping bugs
+ (trie--mapc
+ (lambda (node seq)
+ (setf (trie--node-data node)
+ (funcall --trie-map--function seq (trie--node-data node))))
+ (trie--mapfun trie)
+ (trie--root trie)
+ (cond ((eq type 'string) "") ((eq type 'lisp) ()) (t []))
+ reverse)))
+
+
+(defun trie-mapc (function trie &optional type reverse)
+ "Apply FUNCTION to all elements in TRIE for side effect only.
+
+FUNCTION should take two arguments: a sequence stored in the trie
+and its associated data.
+
+Optional argument TYPE (one of the symbols vector, lisp or
+string) sets the type of sequence passed to FUNCTION. Defaults to
+vector.
+
+FUNCTION is applied in ascending order, or descending order if
+REVERSE is non-nil.
+
+Note: to avoid nasty dynamic scoping bugs, FUNCTION must *not*
+bind any variables with names commencing \"--\"."
+ ;; convert from print-form if necessary
+ (trie-transform-from-read-warn trie)
+ ;; map FUNCTION over TRIE
+ (let ((--trie-mapc--function function)) ; avoid dynamic scoping bugs
+ (trie--mapc
+ (lambda (node seq)
+ (funcall --trie-mapc--function seq (trie--node-data node)))
+ (trie--mapfun trie)
+ (trie--root trie)
+ (cond ((eq type 'string) "") ((eq type 'lisp) ()) (t []))
+ reverse)))
+
+
+(defun trie-mapf (function combinator trie &optional type reverse)
+ "Apply FUNCTION to all elements in TRIE, and combine the results
+using COMBINATOR.
+
+FUNCTION should take two arguments: a sequence stored in the
+trie, and its associated data.
+
+Optional argument TYPE (one of the symbols vector, lisp or
+string; defaults to vector) sets the type of sequence passed to
+FUNCTION. If TYPE is 'string, it must be possible to apply the
+function `string' to the individual elements of key sequences
+stored in TRIE.
+
+The FUNCTION is applied and the results combined in ascending
+order, or descending order if REVERSE is non-nil.
+
+Note: to avoid nasty dynamic scoping bugs, FUNCTION and
+COMBINATOR must *not* bind any variables with names
+commencing \"--\"."
+ ;; convert from print-form if necessary
+ (trie-transform-from-read-warn trie)
+ ;; map FUNCTION over TRIE, combining results with COMBINATOR
+ (let ((--trie-mapf--function function) ; avoid dynamic scoping bugs
+ --trie-mapf--accumulate)
+ (trie--mapc
+ (lambda (node seq)
+ (setq --trie-mapf--accumulate
+ (funcall combinator
+ (funcall --trie-mapf--function
+ seq (trie--node-data node))
+ --trie-mapf--accumulate)))
+ (trie--mapfun trie)
+ (trie--root trie)
+ (cond ((eq type 'string) "") ((eq type 'lisp) ()) (t []))
+ reverse)
+ --trie-mapf--accumulate))
+
+
+(defun trie-mapcar (function trie &optional type reverse)
+ "Apply FUNCTION to all elements in TRIE,
+and make a list of the results.
+
+FUNCTION should take two arguments: a sequence stored in the trie
+and its associated data.
+
+Optional argument TYPE (one of the symbols vector, lisp or
+string) sets the type of sequence passed to FUNCTION. Defaults to
+vector.
+
+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
+
+ (trie-mapf function 'cons trie type (not reverse))
+
+is more efficient.
+
+Note: to avoid nasty dynamic scoping bugs, FUNCTION must *not*
+bind any variables with names commencing \"--\"."
+ ;; convert from print-form if necessary
+ (trie-transform-from-read-warn trie)
+ ;; map FUNCTION over TRIE and accumulate in a list
+ (nreverse (trie-mapf function 'cons trie type reverse)))
+
+
+
+
+;;; ================================================================
+;;; Using tries as stacks
+
+(defstruct (trie--stack
+ (:constructor nil)
+ (:constructor
+ trie--stack-create
+ (trie
+ &optional
+ (type 'vector)
+ reverse
+ &aux
+ (comparison-function (trie--comparison-function trie))
+ (lookupfun (trie--lookupfun trie))
+ (stack-createfun (trie--stack-createfun trie))
+ (stack-popfun (trie--stack-popfun trie))
+ (stack-emptyfun (trie--stack-emptyfun trie))
+ (repopulatefun 'trie--stack-repopulate)
+ (store
+ (if (trie-empty trie)
+ nil
+ (trie--stack-repopulate
+ (list (cons
+ (cond ((eq type 'list) ())
+ ((eq type 'string) "")
+ (t []))
+ (funcall
+ stack-createfun
+ (trie--node-subtree (trie--root trie))
+ reverse)))
+ reverse
+ comparison-function lookupfun
+ stack-createfun stack-popfun stack-emptyfun)))
+ (pushed '())
+ ))
+ (:constructor
+ trie--completion-stack-create
+ (trie prefix
+ &optional
+ reverse
+ &aux
+ (comparison-function (trie--comparison-function trie))
+ (lookupfun (trie--lookupfun trie))
+ (stack-createfun (trie--stack-createfun trie))
+ (stack-popfun (trie--stack-popfun trie))
+ (stack-emptyfun (trie--stack-emptyfun trie))
+ (repopulatefun 'trie--stack-repopulate)
+ (store (trie--completion-stack-construct-store
+ trie prefix reverse))
+ (pushed '())
+ ))
+ (:constructor
+ trie--regexp-stack-create
+ (trie regexp
+ &optional
+ reverse
+ &aux
+ (comparison-function (trie--comparison-function trie))
+ (lookupfun (trie--lookupfun trie))
+ (stack-createfun (trie--stack-createfun trie))
+ (stack-popfun (trie--stack-popfun trie))
+ (stack-emptyfun (trie--stack-emptyfun trie))
+ (repopulatefun 'trie--regexp-stack-repopulate)
+ (store (trie--regexp-stack-construct-store
+ trie regexp reverse))
+ (pushed '())
+ ))
+ (:copier nil))
+ reverse comparison-function lookupfun
+ stack-createfun stack-popfun stack-emptyfun
+ repopulatefun store pushed)
+
+
+(defun trie-stack (trie &optional type reverse)
+ "Return an object that allows TRIE to be accessed as a stack.
+
+The stack is sorted in \"lexical\" order, i.e. the order defined
+by the trie's comparison function, or in reverse order if REVERSE
+is non-nil. Calling `trie-stack-pop' pops the top element (a key
+and its associated data) from the stack.
+
+Optional argument TYPE (one of the symbols vector, lisp or
+string) sets the type of sequence used for the keys.
+
+Note that any modification to TRIE *immediately* invalidates all
+trie-stacks created before the modification (in particular,
+calling `trie-stack-pop' will give unpredictable results).
+
+Operations on trie-stacks are significantly more efficient than
+constructing a real stack from the trie and using standard stack
+functions. As such, they can be useful in implementing efficient
+algorithms on tries. However, in cases where mapping functions
+`trie-mapc', `trie-mapcar' or `trie-mapf' would be sufficient, it
+is better to use one of those instead."
+ ;; convert trie from print-form if necessary
+ (trie-transform-from-read-warn trie)
+ ;; if stack functions aren't defined for trie type, throw error
+ (if (not (functionp (trie--stack-createfun trie)))
+ (error "Trie type does not support stack operations")
+ ;; otherwise, create and initialise a stack
+ (trie--stack-create trie type reverse)))
+
+
+(defun trie-stack-pop (trie-stack &optional nilflag)
+ "Pop the first element from TRIE-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 trie.)"
+ ;; return nilflag if stack is empty
+ (if (trie-stack-empty-p trie-stack)
+ nilflag
+ ;; if elements have been pushed onto the stack, pop those first
+ (if (trie--stack-pushed trie-stack)
+ (pop (trie--stack-pushed trie-stack))
+ ;; otherwise, pop first element from trie-stack and repopulate it
+ (prog1
+ (pop (trie--stack-store trie-stack))
+ (setf (trie--stack-store trie-stack)
+ (funcall (trie--stack-repopulatefun trie-stack)
+ (trie--stack-store trie-stack)
+ (trie--stack-reverse trie-stack)
+ (trie--stack-comparison-function trie-stack)
+ (trie--stack-lookupfun trie-stack)
+ (trie--stack-stack-createfun trie-stack)
+ (trie--stack-stack-popfun trie-stack)
+ (trie--stack-stack-emptyfun trie-stack)))))))
+
+
+(defun trie-stack-push (element trie-stack)
+ "Push ELEMENT onto TRIE-STACK."
+ (push element (trie--stack-pushed trie-stack)))
+
+
+(defun trie-stack-first (trie-stack &optional nilflag)
+ "Return the first element from TRIE-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 trie.)"
+ ;; return nilflag if stack is empty
+ (if (trie-stack-empty-p trie-stack)
+ nilflag
+ ;; if elements have been pushed onto the stack, return first of
+ ;; those
+ (if (trie--stack-pushed trie-stack)
+ (car (trie--stack-pushed trie-stack))
+ ;; otherwise, return first element from trie-stack
+ (car (trie--stack-store trie-stack)))))
+
+
+(defalias 'trie-stack-p 'trie--stack-p
+ "Return t if argument is a trie-stack, nil otherwise.")
+
+
+(defun trie-stack-empty-p (trie-stack)
+ "Return t if TRIE-STACK is empty, nil otherwise."
+ (and (null (trie--stack-store trie-stack))
+ (null (trie--stack-pushed trie-stack))))
+
+
+(defun trie--stack-repopulate
+ (store reverse comparison-function lookupfun
+ stack-createfun stack-popfun stack-emptyfun)
+ ;; Recursively push children of the node at the head of STORE onto the
+ ;; front of STORE, until a data node is reached.
+
+ ;; nothing to do if stack is empty
+ (when store
+ (let ((node (funcall stack-popfun (cdar store)))
+ (seq (caar store)))
+ (when (funcall stack-emptyfun (cdar store))
+ ;; (pop store) here produces irritating compiler warnings
+ (setq store (cdr store)))
+
+ (while (not (trie--node-data-p node))
+ (push
+ (cons (trie--seq-append seq (trie--node-split node))
+ (funcall stack-createfun
+ (trie--node-subtree node) reverse))
+ store)
+ (setq node (funcall stack-popfun (cdar store))
+ seq (caar store))
+ (when (funcall stack-emptyfun (cdar store))
+ ;; (pop store) here produces irritating compiler warnings
+ (setq store (cdr store))))
+
+ (push (cons seq (trie--node-data node)) store))))
+
+
+
+
+;; ================================================================
+;; Query-building utility macros
+
+;; Implementation Note
+;; -------------------
+;; For queries ranked in anything other than lexical order, we use a
+;; partial heap-sort to find the k=MAXNUM highest ranked matches among
+;; the n possibile matches. This has worst-case time complexity
+;; O(n log k), and is both simple and elegant. An optimal algorithm
+;; (e.g. partial quick-sort discarding the irrelevant partition at each
+;; step) would have complexity O(n + k log k), but is probably not worth
+;; the extra coding effort, and would have worse space complexity unless
+;; coded to work "in-place", which would be highly non-trivial. (I
+;; haven't done any benchmarking, though, so feel free to do so and let
+;; me know the results!)
+
+(defmacro trie--construct-accumulator (maxnum filter resultfun)
+ ;; Does what it says on the tin! | sed -e 's/tin/macro name/'
+ `(cond
+ ;; filter, maxnum, resultfun
+ ((and ,filter ,maxnum ,resultfun)
+ (lambda (seq data)
+ (when (funcall ,filter seq data)
+ (aset trie--accumulate 0
+ (cons (funcall ,resultfun seq data)
+ (aref trie--accumulate 0)))
+ (and (>= (length (aref trie--accumulate 0)) ,maxnum)
+ (throw 'trie-accumulate--done nil)))))
+ ;; filter, maxnum, !resultfun
+ ((and ,filter ,maxnum (not ,resultfun))
+ (lambda (seq data)
+ (when (funcall ,filter seq data)
+ (aset trie--accumulate 0
+ (cons (cons seq data)
+ (aref trie--accumulate 0)))
+ (and (>= (length (aref trie--accumulate 0)) ,maxnum)
+ (throw 'trie-accumulate--done nil)))))
+ ;; filter, !maxnum, resultfun
+ ((and ,filter (not ,maxnum) ,resultfun)
+ (lambda (seq data)
+ (when (funcall ,filter seq data)
+ (aset trie--accumulate 0
+ (cons (funcall ,resultfun seq data)
+ (aref trie--accumulate 0))))))
+ ;; filter, !maxnum, !resultfun
+ ((and ,filter (not ,maxnum) (not ,resultfun))
+ (lambda (seq data)
+ (when (funcall ,filter seq data)
+ (aset trie--accumulate 0
+ (cons (cons seq data)
+ (aref trie--accumulate 0))))))
+ ;; !filter, maxnum, resultfun
+ ((and (not ,filter) ,maxnum ,resultfun)
+ (lambda (seq data)
+ (aset trie--accumulate 0
+ (cons (funcall ,resultfun seq data)
+ (aref trie--accumulate 0)))
+ (and (>= (length (aref trie--accumulate 0)) ,maxnum)
+ (throw 'trie-accumulate--done nil))))
+ ;; !filter, maxnum, !resultfun
+ ((and (not ,filter) ,maxnum (not ,resultfun))
+ (lambda (seq data)
+ (aset trie--accumulate 0
+ (cons (cons seq data)
+ (aref trie--accumulate 0)))
+ (and (>= (length (aref trie--accumulate 0)) ,maxnum)
+ (throw 'trie-accumulate--done nil))))
+ ;; !filter, !maxnum, resultfun
+ ((and (not ,filter) (not ,maxnum) ,resultfun)
+ (lambda (seq data)
+ (aset trie--accumulate 0
+ (cons (funcall ,resultfun seq data)
+ (aref trie--accumulate 0)))))
+ ;; !filter, !maxnum, !resultfun
+ ((and (not ,filter) (not ,maxnum) (not ,resultfun))
+ (lambda (seq data)
+ (aset trie--accumulate 0
+ (cons (cons seq data)
+ (aref trie--accumulate 0)))))
+ ))
+
+
+
+(defmacro trie--construct-ranked-accumulator (maxnum filter)
+ ;; Does what it says on the tin! | sed -e 's/tin/macro name/'
+ `(cond
+ ;; filter, maxnum
+ ((and ,filter ,maxnum)
+ (lambda (seq data)
+ (when (funcall ,filter seq data)
+ (heap-add trie--accumulate (cons seq data))
+ (and (> (heap-size trie--accumulate) ,maxnum)
+ (heap-delete-root trie--accumulate)))))
+ ;; filter, !maxnum
+ ((and ,filter (not ,maxnum))
+ (lambda (seq data)
+ (when (funcall ,filter seq data)
+ (heap-add trie--accumulate (cons seq data)))))
+ ;; !filter, maxnum
+ ((and (not ,filter) ,maxnum)
+ (lambda (seq data)
+ (heap-add trie--accumulate (cons seq data))
+ (and (> (heap-size trie--accumulate) ,maxnum)
+ (heap-delete-root trie--accumulate))))
+ ;; !filter, !maxnum
+ ((and (not ,filter) (not ,maxnum))
+ (lambda (seq data)
+ (heap-add trie--accumulate (cons seq data))))))
+
+
+
+(defmacro trie--accumulate-results
+ (rankfun maxnum reverse filter resultfun accfun duplicates &rest body)
+ ;; Accumulate results of running BODY code, and return them in
+ ;; appropriate order. BODY should call ACCFUN to accumulate a result,
+ ;; passing it two arguments: a trie data node, and the corresponding
+ ;; sequence. BODY can throw 'trie-accumulate--done to terminate the
+ ;; accumulation and return the results. A non-null DUPLICATES flag
+ ;; signals that the accumulated results might contain duplicates,
+ ;; which should be deleted. Note that DUPLICATES is ignored if RANKFUN
+ ;; is null. The other arguments should be passed straight through from
+ ;; the query function.
+
+ ;; rename functions to help avoid dynamic-scoping bugs
+ `(let* ((--trie-accumulate--rankfun ,rankfun)
+ (--trie-accumulate--filter ,filter)
+ (--trie-accumulate--resultfun ,resultfun)
+ ;; construct structure in which to accumulate results
+ (trie--accumulate
+ (if ,rankfun
+ (heap-create ; heap order is inverse of rank order
+ (if ,reverse
+ (lambda (a b)
+ (funcall --trie-accumulate--rankfun a b))
+ (lambda (a b)
+ (not (funcall --trie-accumulate--rankfun a b))))
+ (when ,maxnum (1+ ,maxnum)))
+ (make-vector 1 nil)))
+ ;; construct function to accumulate completions
+ (,accfun
+ (if ,rankfun
+ (trie--construct-ranked-accumulator
+ ,maxnum --trie-accumulate--filter)
+ (trie--construct-accumulator
+ ,maxnum --trie-accumulate--filter
+ --trie-accumulate--resultfun))))
+
+ ;; accumulate results
+ (catch 'trie-accumulate--done ,@body)
+
+ ;; return list of completions
+ (cond
+ ;; for a ranked query, extract completions from heap
+ (,rankfun
+ (let (completions)
+ ;; check for and delete duplicates if flag is set
+ (if ,duplicates
+ (while (not (heap-empty trie--accumulate))
+ (if (equal (car (heap-root trie--accumulate))
+ (caar completions))
+ (heap-delete-root trie--accumulate)
+ (push (heap-delete-root trie--accumulate)
+ completions)))
+ ;; skip duplicate checking if flag is not set
+ (while (not (heap-empty trie--accumulate))
+ (if ,resultfun
+ (let ((res (heap-delete-root trie--accumulate)))
+ (push (funcall ,resultfun (car res) (cdr res))
+ completions))
+ (push (heap-delete-root trie--accumulate)
+ completions))))
+ completions))
+
+ ;; for lexical query, reverse result list if MAXNUM supplied
+ (,maxnum (nreverse (aref trie--accumulate 0)))
+ ;; otherwise, just return list
+ (t (aref trie--accumulate 0)))))
+
+
+
+
+;; ================================================================
+;; Completing
+
+(defun trie-complete
+ (trie prefix &optional rankfun maxnum reverse filter resultfun)
+ "Return an alist containing all completions of PREFIX in TRIE
+along with their associated data, in the order defined by
+RANKFUN, defaulting to \"lexical\" order (i.e. the order defined
+by the trie's comparison function). If REVERSE is non-nil, the
+completions are sorted in the reverse order. Returns nil if no
+completions are found.
+
+PREFIX must be a sequence (vector, list or string) containing
+elements of the type used to reference data in the trie. (If
+PREFIX is a string, it must be possible to apply `string' to
+individual elements of the sequences stored in the trie.) The
+completions returned in the alist will be sequences of the same
+type as KEY. If PREFIX is a list of sequences, completions of all
+sequences in the list are included in the returned alist. All
+sequences in the list must be of the same type.
+
+The optional integer argument MAXNUM limits the results to the
+first MAXNUM completions. Otherwise, all completions are
+returned.
+
+If specified, RANKFUN must accept two arguments, both cons
+cells. The car contains a sequence from the trie (of the same
+type as PREFIX), the cdr contains its associated data. It should
+return non-nil if first argument is ranked strictly higher than
+the second, nil otherwise.
+
+The FILTER argument sets a filter function for the
+completions. If supplied, it is called for each possible
+completion with two arguments: the completion, and its associated
+data. If the filter function returns nil, the completion is not
+included in the results, and does not count towards MAXNUM.
+
+RESULTFUN defines a function used to process results before
+adding them to the final result list. If specified, it should
+accept two arguments: a key and its associated data. It's return
+value is what gets added to the final result list, instead of the
+default key-data cons cell."
+
+ ;; convert trie from print-form if necessary
+ (trie-transform-from-read-warn trie)
+ ;; wrap prefix in a list if necessary
+ ;; FIXME: the test for a list of prefixes, below, will fail if the
+ ;; PREFIX sequence is a list, and the elements of PREFIX are
+ ;; themselves lists (there might be no easy way to fully fix
+ ;; this...)
+ (if (or (atom prefix)
+ (and (listp prefix) (not (sequencep (car prefix)))))
+ (setq prefix (list prefix))
+ ;; sort list of prefixes if sorting completions lexically
+ (when (null rankfun)
+ (setq prefix
+ (sort prefix (trie-construct-sortfun
+ (trie--comparison-function trie))))))
+
+ ;; accumulate completions
+ (let (node)
+ (declare (special accumulator))
+ (trie--accumulate-results
+ rankfun maxnum reverse filter resultfun accumulator nil
+ (mapc (lambda (pfx)
+ (setq node (trie--node-find (trie--root trie) pfx
+ (trie--lookupfun trie)))
+ (when node
+ (trie--mapc
+ (lambda (node seq)
+ (funcall accumulator seq (trie--node-data node)))
+ (trie--mapfun trie) node pfx
+ (if maxnum reverse (not reverse)))))
+ prefix))
+ ))
+
+
+
+(defun trie-complete-stack (trie prefix &optional reverse)
+ "Return an object that allows completions of PREFIX to be accessed
+as if they were a stack.
+
+The stack is sorted in \"lexical\" order, i.e. the order defined
+by TRIE's comparison function, or in reverse order if REVERSE is
+non-nil. Calling `trie-stack-pop' pops the top element (a key and
+its associated data) from the stack.
+
+PREFIX must be a sequence (vector, list or string) that forms the
+initial part of a TRIE key, or a list of such sequences. (If
+PREFIX is a string, it must be possible to apply `string' to
+individual elements of TRIE keys.) The completions returned in
+the alist will be sequences of the same type as KEY. If PREFIX is
+a list of sequences, completions of all sequences in the list are
+included in the stack. All sequences in the list must be of the
+same type.
+
+Note that any modification to TRIE *immediately* invalidates all
+trie-stacks created before the modification (in particular,
+calling `trie-stack-pop' will give unpredictable results).
+
+Operations on trie-stacks are significantly more efficient than
+constructing a real stack from completions of PREFIX in TRIE and
+using standard stack functions. As such, they can be useful in
+implementing efficient algorithms on tries. However, in cases
+where `trie-complete' or `trie-complete-ordered' is sufficient,
+it is better to use one of those instead."
+ ;; convert trie from print-form if necessary
+ (trie-transform-from-read-warn trie)
+ ;; if stack functions aren't defined for trie type, throw error
+ (if (not (functionp (trie--stack-createfun trie)))
+ (error "Trie type does not support stack operations")
+ ;; otherwise, create and initialise a stack
+ (trie--completion-stack-create trie prefix reverse)))
+
+
+(defun trie--completion-stack-construct-store (trie prefix reverse)
+ ;; Construct store for completion stack based on TRIE.
+ (let (store node)
+ (if (or (atom prefix)
+ (and (listp prefix)
+ (not (sequencep (car prefix)))))
+ (setq prefix (list prefix))
+ (setq prefix
+ (sort prefix
+ (trie-construct-sortfun
+ (trie--comparison-function trie)
+ (not reverse)))))
+ (dolist (pfx prefix)
+ (when (setq node (trie--node-find (trie--root trie) pfx
+ (trie--lookupfun trie)))
+ (push (cons pfx (funcall (trie--stack-createfun trie)
+ (trie--node-subtree node)
+ reverse))
+ store)))
+ (trie--stack-repopulate
+ store reverse
+ (trie--comparison-function trie)
+ (trie--lookupfun trie)
+ (trie--stack-createfun trie)
+ (trie--stack-popfun trie)
+ (trie--stack-emptyfun trie))))
+
+
+
+
+;; ================================================================
+;; Regexp search
+
+(defun trie-regexp-search
+ (trie regexp &optional rankfun maxnum reverse filter resultfun type)
+ "Return an alist containing all matches for REGEXP in TRIE
+along with their associated data, in the order defined by
+RANKFUN, defauling to \"lexical\" order (i.e. the order defined
+by the trie's comparison function). If REVERSE is non-nil, the
+completions are sorted in the reverse order. Returns nil if no
+completions are found.
+
+REGEXP is a regular expression, but it need not necessarily be a
+string. It must be a sequence (vector, list of string) whose
+elements are either elements of the same type as elements of the
+trie keys (which behave as literals in the regexp), or any of the
+usual regexp special characters and backslash constructs. If
+REGEXP is a string, it must be possible to apply `string' to
+individual elements of the keys stored in the trie. The matches
+returned in the alist will be sequences of the same type as KEY.
+
+Only a subset of the full Emacs regular expression syntax is
+supported. There is no support for regexp constructs that are
+only meaningful for strings (character ranges and character
+classes inside character alternatives, and syntax-related
+backslash constructs). Back-references and non-greedy postfix
+operators are not supported, so `?' after a postfix operator
+loses its special meaning. Also, matches are always anchored, so
+`$' and `^' lose their special meanings (use `.*' at the
+beginning and end of the regexp to get an unanchored match).
+
+If the regexp contains any non-shy grouping constructs, subgroup
+match data is included in the results. In this case, the car of
+each match is no longer just a key. Instead, it is a list whose
+first element is the matching key, and whose remaining elements
+are cons cells whose cars and cdrs give the start and end indices
+of the elements that matched the corresponding groups, in order.
+
+The optional integer argument MAXNUM limits the results to the
+first MAXNUM matches. Otherwise, all matches are returned.
+
+If specified, RANKFUN must accept two arguments, both cons
+cells. The car contains a sequence from the trie (of the same
+type as PREFIX), the cdr contains its associated data. It should
+return non-nil if first argument is ranked strictly higher than
+the second, nil otherwise.
+
+The FILTER argument sets a filter function for the matches. If
+supplied, it is called for each possible match with two
+arguments: the matching key, and its associated data. If the
+filter function returns nil, the match is not included in the
+results, and does not count towards MAXNUM.
+
+RESULTFUN defines a function used to process results before
+adding them to the final result list. If specified, it should
+accept two arguments: a key and its associated data. It's return
+value is what gets added to the final result list, instead of the
+default key-data cons cell."
+
+ ;; convert trie from print-form if necessary
+ (trie-transform-from-read-warn trie)
+
+ ;; massage rankfun to cope with grouping data
+ ;; FIXME: could skip this if REGEXP contains no grouping constructs
+ (when rankfun
+ (setq rankfun
+ `(lambda (a b)
+ ;; if car of argument contains a key+group list rather than
+ ;; a straight key, remove group list
+ ;; FIXME: the test for straight key, below, will fail if
+ ;; the key is a list, and the first element of the
+ ;; key is itself a list (there might be no easy way
+ ;; to fully fix this...)
+ (unless (or (atom (car a))
+ (and (listp (car a))
+ (not (sequencep (caar a)))))
+ (setq a (cons (caar a) (cdr a))))
+ (unless (or (atom (car b))
+ (and (listp (car b))
+ (not (sequencep (caar b)))))
+ (setq b (cons (caar b) (cdr b))))
+ ;; call rankfun on massaged arguments
+ (,rankfun a b))))
+
+ ;; accumulate completions
+ (declare (special accumulator))
+ (trie--accumulate-results
+ rankfun maxnum reverse filter resultfun accumulator nil
+ (trie--do-regexp-search
+ (trie--root trie)
+ (tNFA-from-regexp regexp :test (trie--construct-equality-function
+ (trie--comparison-function trie)))
+ (cond ((stringp regexp) "") ((listp regexp) ()) (t [])) 0
+ (or (and maxnum reverse) (and (not maxnum) (not reverse)))
+ (trie--comparison-function trie)
+ (trie--lookupfun trie)
+ (trie--mapfun trie))))
+
+
+
+(defun trie--do-regexp-search
+ (--trie--regexp-search--node tNFA seq pos reverse
+ comparison-function lookupfun mapfun)
+ ;; Search everything below the node --TRIE--REGEXP-SEARCH-NODE for
+ ;; matches to the regexp encoded in tNFA. SEQ is the sequence
+ ;; corresponding to NODE, POS is it's length. REVERSE is the usual
+ ;; query argument, and the remaining arguments are the corresponding
+ ;; trie functions.
+ (declare (special accumulator))
+
+ ;; if NFA has matched and we're accumulating in normal order, check if
+ ;; trie contains current string
+ (when (and (not reverse) (tNFA-match-p tNFA))
+ (let (node groups)
+ (when (setq node (trie--find-data-node
+ --trie--regexp-search--node lookupfun))
+ (setq groups (tNFA-group-data tNFA))
+ (funcall accumulator
+ (if groups (cons seq groups) seq)
+ (trie--node-data node)))))
+
+ (cond
+ ;; ;; data node
+ ;; ((trie--node-data-p --trie--regexp-search--node)
+ ;; (when (tNFA-match-p tNFA)
+ ;; (let ((groups (tNFA-group-data tNFA)))
+ ;; (funcall accumulator
+ ;; (if groups (cons seq groups) seq)
+ ;; (trie--node-data --trie--regexp-search--node)))))
+
+ ;; wildcard transition: map over all nodes in subtree
+ ((tNFA-wildcard-p tNFA)
+ (let (state groups)
+ (funcall mapfun
+ (lambda (node)
+ (unless (trie--node-data-p node)
+ ;; (when (tNFA-match-p tNFA)
+ ;; (setq groups (tNFA-group-data tNFA))
+ ;; (funcall accumulator
+ ;; (if groups (cons seq groups) seq)
+ ;; (trie--node-data node)))
+ (when (setq state (tNFA-next-state
+ tNFA (trie--node-split node) pos))
+ (trie--do-regexp-search
+ node state
+ (trie--seq-append seq (trie--node-split node))
+ (1+ pos) reverse comparison-function
+ lookupfun mapfun))))
+ (trie--node-subtree --trie--regexp-search--node)
+ reverse)))
+
+ (t ;; no wildcard transition: loop over all transitions
+ (let (node state)
+ (dolist (chr (sort (tNFA-transitions tNFA)
+ (if reverse
+ `(lambda (a b) (,comparison-function b a))
+ comparison-function)))
+ (when (and (setq node (trie--node-find
+ --trie--regexp-search--node
+ (vector chr) lookupfun))
+ (setq state (tNFA-next-state tNFA chr pos)))
+ (trie--do-regexp-search
+ node state (trie--seq-append seq chr) (1+ pos)
+ reverse comparison-function lookupfun mapfun))))))
+
+ ;; if NFA has matched and we're accumulating in reverse order, check if
+ ;; trie contains current string
+ (when (and reverse (tNFA-match-p tNFA))
+ (let (node groups)
+ (when (setq node (trie--find-data-node
+ --trie--regexp-search--node lookupfun))
+ (setq groups (tNFA-group-data tNFA))
+ (funcall accumulator
+ (if groups (cons seq groups) seq)
+ (trie--node-data node))))))
+
+
+
+(defun trie-regexp-stack (trie regexp &optional reverse)
+ "Return an object that allows matches to REGEXP to be accessed
+as if they were a stack.
+
+The stack is sorted in \"lexical\" order, i.e. the order defined
+by TRIE's comparison function, or in reverse order if REVERSE is
+non-nil. Calling `trie-stack-pop' pops the top element (a cons
+cell containing a key and its associated data) from the stack.
+
+REGEXP is a regular expression, but it need not necessarily be a
+string. It must be a sequence (vector, list of string) whose
+elements are either elements of the same type as elements of the
+trie keys (which behave as literals in the regexp), or any of the
+usual regexp special characters and backslash constructs. If
+REGEXP is a string, it must be possible to apply `string' to
+individual elements of the keys stored in the trie. The matches
+returned in the alist will be sequences of the same type as KEY.
+
+Back-references and non-greedy postfix operators are *not*
+supported, and the matches are always anchored, so `$' and `^'
+lose their special meanings.
+
+If the regexp contains any non-shy grouping constructs, subgroup
+match data is included in the results. In this case, the car of
+each match (as returned by a call to `trie-stack-pop' is no
+longer just a key. Instead, it is a list whose first element is
+the matching key, and whose remaining elements are cons cells
+whose cars and cdrs give the start and end indices of the
+elements that matched the corresponding groups, in order."
+
+ ;; convert trie from print-form if necessary
+ (trie-transform-from-read-warn trie)
+ ;; if stack functions aren't defined for trie type, throw error
+ (if (not (functionp (trie--stack-createfun trie)))
+ (error "Trie type does not support stack operations")
+ ;; otherwise, create and initialise a regexp stack
+ (trie--regexp-stack-create trie regexp reverse)))
+
+
+(defun trie--regexp-stack-construct-store
+ (trie regexp &optional reverse)
+ ;; Construct store for regexp stack based on TRIE.
+ (let ((seq (cond ((stringp regexp) "") ((listp regexp) ()) (t [])))
+ store)
+ (push (list seq (trie--root trie)
+ (tNFA-from-regexp
+ regexp :test (trie--construct-equality-function
+ (trie--comparison-function trie)))
+ 0)
+ store)
+ (trie--regexp-stack-repopulate
+ store reverse
+ (trie--comparison-function trie)
+ (trie--lookupfun trie)
+ (trie--stack-createfun trie)
+ (trie--stack-popfun trie)
+ (trie--stack-emptyfun trie))))
+
+
+(defun trie--regexp-stack-repopulate
+ (store reverse comparison-function lookupfun
+ stack-createfun stack-popfun stack-emptyfun)
+ ;; Recursively push matching children of the node at the head of STORE
+ ;; onto STORE, until a data node is reached. REVERSE is the usual
+ ;; query argument, and the remaining arguments are the corresponding
+ ;; trie functions.
+ (let (state seq node pos groups n s)
+ (while
+ (progn
+ (setq pos (pop store)
+ seq (nth 0 pos)
+ node (nth 1 pos)
+ state (nth 2 pos)
+ pos (nth 3 pos))
+ (cond
+ ;; if stack is empty, we're done
+ ((null node) nil)
+
+ ;; if stack element is a trie node...
+ ((trie--node-p node)
+ (cond
+ ;; matching data node: add data to the stack and we're done
+ ((trie--node-data-p node)
+ (when (tNFA-match-p state)
+ (setq groups (tNFA-group-data state))
+ (push (cons (if groups (cons groups seq) seq)
+ (trie--node-data node))
+ store))
+ nil) ; return nil to exit loop
+
+ ;; wildcard transition: add new node stack
+ ((tNFA-wildcard-p state)
+ (push (list seq
+ (funcall stack-createfun
+ (trie--node-subtree node) reverse)
+ state pos)
+ store))
+
+ (t ;; non-wildcard transition: add all possible next nodes
+ (dolist (chr (sort (tNFA-transitions state)
+ (if reverse
+ comparison-function
+ `(lambda (a b)
+ (,comparison-function b a)))))
+ (when (and (setq n (trie--node-find
+ node (vector chr) lookupfun))
+ (setq s (tNFA-next-state state chr pos)))
+ (push (list (trie--seq-append seq chr) n s (1+ pos))
+ store)))
+ t))) ; return t to keep looping
+
+ ;; otherwise, stack element is a node stack...
+ (t
+ ;; if node stack is empty, dump it and keep repopulating
+ (if (funcall stack-emptyfun node)
+ t ; return t to keep looping
+ ;; otherwise, add node stack back, and add next node from
+ ;; stack
+ (push (list seq node state pos) store)
+ (setq node (funcall stack-popfun node)
+ state (tNFA-next-state state
+ (trie--node-split node) pos))
+ (when state
+ ;; matching data node: add data to the stack and we're
+ ;; done
+ (if (trie--node-data-p node)
+ (progn
+ (push (cons seq (trie--node-data node)) store)
+ nil) ; return nil to exit loop
+ ;; normal node: add it to the stack and keep
+ ;; repopulating
+ (push (list
+ (trie--seq-append seq (trie--node-split node))
+ node state (1+ pos))
+ store)))))
+ ))))
+ store)
+
+
+
+;; ----------------------------------------------------------------
+;; Pretty-print tries during edebug
+
+;; Note:
+;; -----
+
+;; We advise the `edebug-prin1' and `edebug-prin1-to-string' functions
+;; (actually, aliases) so that they print "#<trie>" instead of the full
+;; print form for tries.
+;;
+;; This is because, if left to its own devices, edebug hangs for ages
+;; whilst printing large tries, and you either have to wait for a *very*
+;; long time for it to finish, or kill Emacs entirely. (Even C-g C-g
+;; fails!)
+;;
+;; We do this also for lists of tries, since those occur quite often,
+;; but not for other sequence types or deeper nested structures, to keep
+;; the implementation as simple as possible.
+;;
+;; Since the print form of a trie is practically incomprehensible
+;; anyway, we don't lose much by doing this. If you *really* want to
+;; print tries in full whilst edebugging, despite this warning, disable
+;; the advice.
+;;
+;; FIXME: We could use `cedet-edebug-prin1-extensions' instead of advice
+;; when `cedet-edebug' is loaded, though I believe the current
+;; implementation still works in that case.
+
+
+(eval-when-compile
+ (require 'edebug)
+ (require 'advice))
+
+
+(defun trie--edebug-pretty-print (object)
+ (cond
+ ((trie-p object) "#<trie>")
+ ((null object) "nil")
+ ((let ((tlist object) (test t))
+ (while (or (trie-p (car-safe tlist))
+ (and tlist (setq test nil)))
+ (setq tlist (cdr tlist)))
+ test)
+ (concat "(" (mapconcat (lambda (dummy) "#<trie>") object " ") ")"))
+ ;; ((vectorp object)
+ ;; (let ((pretty "[") (len (length object)))
+ ;; (dotimes (i (1- len))
+ ;; (setq pretty
+ ;; (concat pretty
+ ;; (if (trie-p (aref object i))
+ ;; "#<trie>" (prin1-to-string (aref object i))) " ")))
+ ;; (concat pretty
+ ;; (if (trie-p (aref object (1- len)))
+ ;; "#<trie>" (prin1-to-string (aref object (1- len))))
+ ;; "]")))
+ ))
+
+
+(when (fboundp 'ad-define-subr-args)
+ (ad-define-subr-args 'edebug-prin1 '(object &optional printcharfun)))
+
+(defadvice edebug-prin1
+ (around trie activate compile preactivate)
+ (let ((pretty (trie--edebug-pretty-print object)))
+ (if pretty
+ (progn
+ (prin1 pretty printcharfun)
+ (setq ad-return-value pretty))
+ ad-do-it)))
+
+
+(when (fboundp 'ad-define-subr-args)
+ (ad-define-subr-args 'edebug-prin1-to-string '(object &optional noescape)))
+
+(defadvice edebug-prin1-to-string
+ (around trie activate compile preactivate)
+ (let ((pretty (trie--edebug-pretty-print object)))
+ (if pretty
+ (setq ad-return-value pretty)
+ ad-do-it)))
+
+
+
+(provide 'trie)
+
+;;; trie.el ends here
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [ELPA-diffs] /srv/bzr/emacs/elpa r206: Add trie.el,
Toby S. Cubitt <=