emacs-elpa-diffs
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[elpa] externals/trie a402c27 021/111: Implemented wildcard searches!


From: Stefan Monnier
Subject: [elpa] externals/trie a402c27 021/111: Implemented wildcard searches!
Date: Mon, 14 Dec 2020 11:35:12 -0500 (EST)

branch: externals/trie
commit a402c27d0b6b6f44d3335c8002a083059fb39c80
Author: Toby Cubitt <toby-predictive@dr-qubit.org>
Commit: tsc25 <toby-predictive@dr-qubit.org>

    Implemented wildcard searches!
---
 trie.el | 770 ++++++++++++++++++++++++++++++++++++++++++++--------------------
 1 file changed, 530 insertions(+), 240 deletions(-)

diff --git a/trie.el b/trie.el
index d815dfa..ce39ae6 100644
--- a/trie.el
+++ b/trie.el
@@ -218,6 +218,18 @@ If START or END is negative, it counts from the end."
               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 (el (i 0))
+    (catch 'found
+      (while (setq el (nth i list))
+        (when (equal item el) (throw 'found i))
+        (setq i (1+ i))
+        nil))))
+
+
 (defsubst trie--seq-append (seq el)
   "Append EL to the end of sequence SEQ."
   (cond
@@ -226,6 +238,15 @@ If START or END is negative, it counts from the end."
    ((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))))
+
+
 
 ;;; ================================================================
 ;;;     Internal functions only for use within the trie package
@@ -358,34 +379,33 @@ If START or END is negative, it counts from the end."
            (trie--p (trie--node-subtree ,node)))))
 
 
-(defun trie--node-find (trie sequence)
-  ;; Returns the node corresponding to SEQUENCE, or nil if none found.
-  (let ((node (trie--root trie))
-       (len (length sequence))
+(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 SEQUENCE or run out of trie
+    ;; descend trie until we find SEQ or run out of trie
     (while (and node (< (incf i) len))
       (setq node
-           (funcall (trie--lookupfun trie)
+           (funcall lookupfun
                     (trie--node-subtree node)
-                    (trie--node-create-dummy (elt sequence i))
+                    (trie--node-create-dummy (elt seq i))
                     nil)))
     node))
 
 
-(defmacro trie--find-data-node (node trie)
+(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 (trie--lookupfun ,trie)
+  `(funcall ,lookupfun
            (trie--node-subtree ,node)
            (trie--node-create-dummy trie--terminator)
            nil))
 
 
-(defmacro trie--find-data (node trie)
+(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 ,trie)))
+  `(let ((node (trie--find-data-node ,node ,lookupfun)))
      (when node (trie--node-data node))))
 
 
@@ -448,7 +468,8 @@ If START or END is negative, it counts from the end."
                   (trie--comparison-function trie)
                   (not reverse)))))
     (dolist (pfx prefix)
-      (when (setq node (trie--node-find trie pfx))
+      (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))
@@ -495,18 +516,26 @@ If START or END is negative, it counts from the end."
   "Transform TRIE to print form."
   (when (trie--transform-for-print trie)
     (if (trie--print-form trie)
-       (error "Trie has already been transformed to print-form")
-      (setf (trie--print-form trie) t)
-      (funcall (trie--transform-for-print trie) 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))
-       (error "Trie is not in print-form")
-      (setf (trie--print-form trie) nil)
-      (funcall (trie--transform-from-read trie) 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)
@@ -662,10 +691,8 @@ functions must *never* bind any variables with names 
commencing \"--\".")
 
 (defun trie-empty (trie)
   "Return t if the TRIE is empty, nil otherwise."
-  (if (trie--print-form trie)
-      (error "Attempt to operate on trie that is in print-form")
-    (funcall (trie--emptyfun trie)
-            (trie--node-subtree (trie--root trie)))))
+  (trie-transform-from-read-warn trie)
+  (funcall (trie--emptyfun trie) (trie--node-subtree (trie--root trie))))
 
 
 (defun trie-construct-sortfun (cmpfun &optional reverse)
@@ -710,39 +737,41 @@ Returns the new association of KEY.
 
 Note: to avoid nasty dynamic scoping bugs, UPDATEFUN must *not*
 bind any variables with names commencing \"--\"."
-  (if (trie--print-form trie)
-      (error "Attempt to operate on trie that is in print-form")
-    ;; 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.
+
+  ;; 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-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
+                         (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
 
 
 
@@ -762,18 +791,19 @@ 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 \"--\"."
-  (if (trie--print-form trie)
-      (error "Attempt to operate on trie that is in print-form")
-    (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))))))
+  ;; 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
@@ -834,23 +864,24 @@ 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.)"
-  (if (trie--print-form trie)
-      (error "Attempt to operate on trie that is in print-form")
-    ;; find node corresponding to key, then find data node, then return data
-    (let (node)
-      (or (and (setq node (trie--node-find trie key))
-              (trie--find-data node trie))
-         nilflag))))
+  ;; 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."
-  (if (trie--print-form trie)
-      (error "Attempt to operate on trie that is in print-form")
-    (let ((flag '(nil)))
-      (not (eq flag (trie-member trie key flag))))))
+  ;; convert trie from print-form if necessary
+  (trie-transform-from-read-warn trie)
+  (let ((flag '(nil)))
+    (not (eq flag (trie-member trie key flag)))))
 
 
 
@@ -937,17 +968,18 @@ REVERSE is non-nil.
 
 Note: to avoid nasty dynamic scoping bugs, FUNCTION must *not*
 bind any variables with names commencing \"--\"."
-  (if (trie--print-form trie)
-      (error "Attempt to operate on trie that is in print-form")
-    (let ((--trie-map--function function)) ; try to 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))))
+  ;; convert from print-form if necessary
+  (trie-transform-from-read-warn trie)
+  ;; map FUNCTION over TRIE
+  (let ((--trie-map--function function)) ; try to 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)
@@ -965,16 +997,17 @@ REVERSE is non-nil.
 
 Note: to avoid nasty dynamic scoping bugs, FUNCTION must *not*
 bind any variables with names commencing \"--\"."
-  (if (trie--print-form trie)
-      (error "Attempt to operate on trie that is in print-form")
-    (let ((--trie-mapc--function function)) ; try to 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))))
+  ;; convert from print-form if necessary
+  (trie-transform-from-read-warn trie)
+  ;; map FUNCTION over TRIE
+  (let ((--trie-mapc--function function)) ; try to 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)
@@ -996,22 +1029,23 @@ 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 \"--\"."
-  (if (trie--print-form trie)
-      (error "Attempt to operate on trie that is in print-form")
-    (let ((--trie-mapf--function function) ; try to 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)))
+  ;; 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) ; try to 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)
@@ -1037,9 +1071,10 @@ is more efficient.
 
 Note: to avoid nasty dynamic scoping bugs, FUNCTION must *not*
 bind any variables with names commencing \"--\"."
-  (if (trie--print-form trie)
-      (error "Attempt to operate on trie that is in print-form")
-    (nreverse (trie-mapf function 'cons trie type reverse))))
+  ;; 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)))
 
 
 
@@ -1078,44 +1113,6 @@ is better to use one of those instead."
       stack))))
 
 
-(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. (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."
-  (cond
-   ((trie--print-form trie)
-    (error "Attempt to operate on trie that is in print-form"))
-   ((not (functionp (trie--stack-createfun trie)))
-    (error "Trie type does not support stack operations"))
-   (t
-    (let ((stack (trie--completion-stack-create trie prefix reverse)))
-      (trie--stack-repopulate stack)
-      stack))))
-
-
 (defun trie-stack-pop (trie-stack)
   "Pop the first element from TRIE-STACK.
 Returns nil if the stack is empty."
@@ -1156,82 +1153,141 @@ from the stack. Returns nil if the stack is empty."
 
 
 ;; ----------------------------------------------------------------
-;;                         Completing
+;;                   Advanced query-building macros
 
 ;; Implementation Note
 ;; -------------------
-;; For completions ranked in anything other than lexical order, we use a
-;; partial heap-sort to find the k=MAXNUM highest ranked completions among the
-;; n possibile completions. This has worst-case time complexity O(n log k),
-;; and is both simple and elegant. An optimal algorithm (e.g. partial
-;; quick-sort where the irrelevant partition is discarded 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--complete-construct-accumulator (maxnum filter)
+;; 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 where the
+;; irrelevant partition is discarded 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)
   ;; Does what it says on the tin! | sed -e 's/on/in/' -e 's/tin/macro name/'
   `(cond
     ((and ,filter ,maxnum)
      (lambda (node seq)
        (let ((data (trie--node-data node)))
         (when (funcall ,filter seq data)
-          (aset trie--complete-accumulate 0
+          (aset trie--accumulate 0
                 (cons (cons seq data)
-                      (aref trie--complete-accumulate 0)))
-          (and (>= (length (aref trie--complete-accumulate 0)) ,maxnum)
+                      (aref trie--accumulate 0)))
+          (and (>= (length (aref trie--accumulate 0)) ,maxnum)
                (throw 'trie-complete--done nil))))))
     ((and (not ,filter) ,maxnum)
      (lambda (node seq)
        (let ((data (trie--node-data node)))
-        (aset trie--complete-accumulate 0
+        (aset trie--accumulate 0
               (cons (cons seq data)
-                    (aref trie--complete-accumulate 0)))
-        (and (>= (length (aref trie--complete-accumulate 0)) ,maxnum)
+                    (aref trie--accumulate 0)))
+        (and (>= (length (aref trie--accumulate 0)) ,maxnum)
              (throw 'trie-complete--done nil)))))
     ((and ,filter (not ,maxnum))
      (lambda (node seq)
        (let ((data (trie--node-data node)))
         (when (funcall ,filter seq data)
-          (aset trie--complete-accumulate 0
+          (aset trie--accumulate 0
                 (cons (cons seq data)
-                      (aref trie--complete-accumulate 0)))))))
+                      (aref trie--accumulate 0)))))))
     ((and (not ,filter) (not ,maxnum))
      (lambda (node seq)
        (let ((data (trie--node-data node)))
-        (aset trie--complete-accumulate 0
+        (aset trie--accumulate 0
               (cons (cons seq data)
-                    (aref trie--complete-accumulate 0))))))))
+                    (aref trie--accumulate 0))))))))
 
 
-(defmacro trie--complete-construct-ranked-accumulator (maxnum filter)
+(defmacro trie--construct-ranked-accumulator (maxnum filter)
   ;; Does what it says on the tin! | sed -e 's/on/in/' -e 's/tin/macro name/'
   `(cond
     ((and ,filter ,maxnum)
      (lambda (node seq)
        (let ((data (trie--node-data node)))
         (when (funcall ,filter seq data)
-          (heap-add trie--complete-accumulate (cons seq data))
-          (and (> (heap-size trie--complete-accumulate) ,maxnum)
-               (heap-delete-root trie--complete-accumulate))))))
+          (heap-add trie--accumulate (cons seq data))
+          (and (> (heap-size trie--accumulate) ,maxnum)
+               (heap-delete-root trie--accumulate))))))
     ((and ,filter (not ,maxnum))
      (lambda (node seq)
        (let ((data (trie--node-data node)))
         (when (funcall ,filter seq data)
-          (heap-add trie--complete-accumulate (cons seq data))))))
+          (heap-add trie--accumulate (cons seq data))))))
     ((and (not ,filter) ,maxnum)
      (lambda (node seq)
        (let ((data (trie--node-data node)))
-        (heap-add trie--complete-accumulate (cons seq data))
-        (and (> (heap-size trie--complete-accumulate) ,maxnum)
-             (heap-delete-root trie--complete-accumulate)))))
+        (heap-add trie--accumulate (cons seq data))
+        (and (> (heap-size trie--accumulate) ,maxnum)
+             (heap-delete-root trie--accumulate)))))
     ((and (not ,filter) (not ,maxnum))
      (lambda (node seq)
        (let ((data (trie--node-data node)))
-        (heap-add trie--complete-accumulate (cons seq data)))))))
+        (heap-add trie--accumulate (cons seq data)))))))
+
+
 
+(defmacro trie--accumulate-results
+  (rankfun maxnum reverse filter 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. 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.
 
+  `(let* ((--trie-accumulate--rankfun ,rankfun)  ; dynamic-scoping bug 
avoidance
+         ;; 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 ,filter)
+            (trie--construct-accumulator ,maxnum ,filter))))
+
+     ;; accumulate results
+     (catch 'trie-complete--done ,@body)
+
+     ;; return list of completions
+     (cond
+      ;; extract completions from heap for ranked query
+      (,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))
+            (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)
   "Return an alist containing all completions of PREFIX in TRIE
@@ -1266,63 +1322,297 @@ 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."
 
-  (if (trie--print-form trie)
-      (error "Attempt to operate on trie that is in print-form")
+  ;; 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)
+    (trie--accumulate-results
+     rankfun maxnum reverse filter accumulator nil
+     (mapc (lambda (pfx)
+            (setq node (trie--node-find (trie--root trie) pfx
+                                        (trie--lookupfun trie)))
+            (when node
+              (trie--mapc accumulator (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. (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."
+  (cond
+   ((trie--print-form trie)
+    (error "Attempt to operate on trie that is in print-form"))
+   ((not (functionp (trie--stack-createfun trie)))
+    (error "Trie type does not support stack operations"))
+   (t
+    (let ((stack (trie--completion-stack-create trie prefix reverse)))
+      (trie--stack-repopulate stack)
+      stack))))
+
+
+
+;; ----------------------------------------------------------------
+;;                         Completing
+
+(defun trie-wildcard-search (trie pattern
+                                 &optional rankfun maxnum reverse filter)
+  "blah"
+
+  ;; 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 pattern)
+         (and (listp pattern) (not (sequencep (car pattern)))))
+      (setq pattern (list pattern))
+    ;; sort list of patterns if sorting completions lexically
+    (when (null rankfun)
+      (setq pattern
+           (sort pattern (trie-construct-sortfun
+                         (trie--comparison-function trie))))))
+
+  ;; accumulate pattern matches
+  (declare (special accumulator))
+  (let (duplicates
+       (initseq (cond ((stringp (car pattern)) "")
+                      ((listp (car pattern)) ())
+                      (t []))))
+    ;; check for * wildcards in pattern
+    (setq pattern
+         (mapcar (lambda (pat)
+                   ;; convert pattern to list
+                   (setq pat (append pat nil))
+                   (let ((pos (trie--position ?* pat)))
+                     ;; if *'s appear in middle, have to sort manually
+                     (when (and (null rankfun) pos
+                                (not (= pos (1- (length pat)))))
+                       (setq rankfun
+                             `(lambda (a b)
+                                (,(trie-construct-sortfun
+                                   (trie--comparison-function trie)
+                                   reverse)
+                                 (car a) (car b)))))
+                     ;; if pattern contains multiple *'s, might get dups
+                     (when (and pos
+                                (trie--position
+                                 ?* (trie--subseq pat (1+ pos))))
+                       (setq duplicates t)))
+                   ;; return pattern converted to list
+                   pat)
+                 pattern))
+
+    (trie--accumulate-results
+     rankfun maxnum reverse filter accumulator duplicates
+     (mapc (lambda (pat)
+            (trie--do-wildcard-search
+             (trie--root trie)
+             initseq pat rankfun maxnum reverse
+             (trie--comparison-function trie)
+             (trie--lookupfun trie)
+             (trie--mapfun trie)))
+          pattern))))
+
+
+
+(defun trie--do-wildcard-search (node seq pattern
+                                     rankfun maxnum reverse
+                                     cmpfun lookupfun mapfun)
+  ;; Perform wildcard search for PATTERN starting at NODE which corresponds to
+  ;; SEQ. RANKFUN, MAXNUM and REVERSE should be passed through from query
+  ;; function, CMPFUN, LOOKUPFUN and MAPFUN should be corresponding trie
+  ;; functions (note that CMPFUN should be the trie--comparison-function,
+  ;; *not* the trie--cmpfun)
+  (declare (special accumulator))
+
+  ;; if pattern is null, accumulate data from current node
+  (if (null pattern)
+      (when (setq node (trie--find-data-node node lookupfun))
+       (funcall accumulator node seq))
+
+    ;; otherwise, extract first pattern element and act on it
+    (setq pattern (trie--parse-wildcard-pattern pattern))
+    (let ((el (car pattern)))
+      (setq pattern (cdr pattern))
 
-    (let (node
-         (trie--complete-accumulate
-          (if rankfun
-              (heap-create  ; heap order is inverse of rank order
-               (if reverse
-                   `(lambda (a b) (,rankfun a b))
-                 `(lambda (a b) (not (,rankfun a b))))
-               (when maxnum (1+ maxnum)))
-            (make-vector 1 nil)))
-         accumulator)
-
-      ;; 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))))))
-
-      ;; construct function to accumulate completions
-      (if rankfun
-         (setq accumulator
-               (trie--complete-construct-ranked-accumulator maxnum filter))
-       (setq accumulator
-             (trie--complete-construct-accumulator maxnum filter)))
-
-      ;; accumulate completions
-      (catch 'trie-complete--done
-       (mapc (lambda (pfx)
-               (setq node (trie--node-find trie pfx))
-               (when node
-                 (trie--mapc accumulator (trie--mapfun trie) node pfx
-                             (if maxnum reverse (not reverse)))))
-             prefix))
-
-      ;; return list of completions
       (cond
-       ;; extract completions from heap for ranked query
-       (rankfun
-       (let (completions)
-         (while (not (heap-empty trie--complete-accumulate))
-           (push (heap-delete-root trie--complete-accumulate) completions))
-         completions))
-       ;; reverse result list if MAXNUM supplied
-       (maxnum (nreverse (aref trie--complete-accumulate 0)))
-       ;; otherwise, just return list
-       (t (aref trie--complete-accumulate 0)))
-      )))
+       ;; terminal *: accumulate everything below current node
+       ((and (null pattern) (eq el ?*))
+       (trie--mapc accumulator mapfun node seq
+                   (if maxnum reverse (not reverse))))
+
+       ;; * wildcard: map over all nodes immediately below current one, with
+       ;;             and without using up the *
+       ((eq el ?*)
+       (funcall mapfun
+                (lambda (node)
+                  ;; skip data nodes (terminal * dealt with above)
+                  (unless (trie--node-data-p node)
+                    ;; using up *
+                    (trie--do-wildcard-search
+                     node (trie--seq-append seq (trie--node-split node))
+                     pattern rankfun maxnum reverse
+                     cmpfun lookupfun mapfun)
+                    ;; not using up *
+                    (trie--do-wildcard-search
+                     node (trie--seq-append seq (trie--node-split node))
+                     (cons ?* pattern) rankfun maxnum reverse
+                     cmpfun lookupfun mapfun)))
+                (trie--node-subtree node)))
+
+       ;; fixed string: descend to corresponding node
+       ((vectorp el)
+       (when (setq node (trie--node-find node el lookupfun))
+         (trie--do-wildcard-search node (trie--seq-concat seq el)
+                                   pattern rankfun maxnum reverse
+                                   cmpfun lookupfun mapfun)))
+
+       ;; ? wildcard: map over all child nodes
+       ((eq el ??)
+       (funcall mapfun
+                (lambda (node)
+                  ;; skip data nodes (note: if we wanted to implement a "0 or
+                  ;; 1" wildcard, would need to accumulate these instead)
+                  (unless (trie--node-data-p node)
+                    (trie--do-wildcard-search
+                     node (trie--seq-append seq (trie--node-split node))
+                     pattern rankfun maxnum reverse
+                     cmpfun lookupfun mapfun)
+                    ))
+                (trie--node-subtree node)
+                (if maxnum reverse (not reverse))))
+
+       ;; character alternative: descend to corresponding nodes in turn
+       ((and (listp el) (not (eq (car el) ?^)))
+       (let (n)
+         (mapc
+          (lambda (c)
+            (when (setq n (funcall lookupfun (trie--node-subtree node)
+                                   (trie--node-create-dummy c)))
+              (trie--do-wildcard-search n (trie--seq-append seq c)
+                                        pattern rankfun maxnum reverse
+                                        cmpfun lookupfun mapfun)))
+          (if rankfun el
+            (sort el (if (or (and maxnum reverse)  ; no xnor in Elisp!
+                             (and (not maxnum) (not reverse)))
+                         (lambda (a b) (not (funcall cmpfun a b)))
+                       cmpfun))))))
+
+       ;; negated character alternative: map over all child nodes, skipping
+       ;; excluded ones
+       ((and (listp el) (eq (car el) ?^))
+       (pop el)
+       (funcall mapfun
+                (lambda (node)
+                  ;; skip data nodes (note: if we wanted to implement a "0 or
+                  ;; 1" wildcard, would need to accumulate these instead)
+                  (unless (or (trie--node-data-p node)
+                              (catch 'excluded
+                                (dolist (c el)
+                                  (when (eq c (trie--node-split node))
+                                    (throw 'excluded t)))))
+                    (trie--do-wildcard-search
+                     node (trie--seq-append seq (trie--node-split node))
+                     pattern rankfun maxnum reverse
+                     cmpfun lookupfun mapfun)
+                    ))
+                (trie--node-subtree node)
+                (if maxnum reverse (not reverse))))
+       )
+    )))
+
+
+
+(defun trie--parse-wildcard-pattern (pattern)
+  ;; Extract first pattern element from PATTERN (a list), and return it consed
+  ;; with remainder of pattern.
+  (let ((el (pop pattern)))
+    (cond
+     ;; *: drop any following *'s
+     ((eq el ?*)
+      (while (eq (car pattern) ?*) (pop pattern)))
+
+     ;; [: gobble up to closing ]
+     ((eq el ?\[)
+      ;; character alternatives are stored in lists
+      (setq el ())
+      ;; gobble ] appearing straight after [
+      (when (eq (car pattern) ?\]) (push (pop pattern) el))
+      (while (not (eq (car pattern) ?\]))
+       (push (pop pattern) el)
+       (unless pattern
+         (error "Syntax error in trie-wildcard-search pattern:\
+ missing \"]\"")))
+      (pop pattern)  ; dump closing ]
+      (setq el (nreverse el)))
+
+     ;; ?: nothing to gobble
+     ((eq el ??))
+
+     ;; ]: syntax error (always gobbled when parsing [)
+     ((eq el ?\])
+      (error "Syntax error in trie-wildcard-search pattern:\
+ missing \"[\""))
+
+     ;; anything else, gobble up to first special character
+     (t
+      (push el pattern)
+      (setq el nil)
+      (while (and pattern
+                 (not (or (eq (car pattern) ?\[) (eq (car pattern) ?\])
+                          (eq (car pattern) ?*) (eq (car pattern) ??))))
+       ;; \: dump \ and gobble next character
+       (when (eq (car pattern) ?\\)
+         (pop pattern)
+         (unless pattern
+           (error "Syntax error in trie-wildcard-search pattern:\
+ missing character after \"\\\"")))
+       (push (pop pattern) el))
+      ;; fixed strings are stored in vectors
+      (setq el (vconcat (nreverse el)))))
+
+    ;; return cons containing first element and remaining pattern
+    (cons el pattern)))
 
 
 



reply via email to

[Prev in Thread] Current Thread [Next in Thread]