1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
|
;;; radix-tree.el --- A simple library of radix trees -*- lexical-binding: t; -*-
;; Copyright (C) 2016-2022 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords:
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; NOTE: This is a modified version of radix-tree that comes builtin
;; with emacs. It allows different compare functions and type. One use
;; is to build a radix tree of list of string, e.g. from a filesystem
;; hierarchy.
;; There are many different options for how to represent radix trees
;; in Elisp. Here I chose a very simple one. A radix-tree can be either:
;; - a node, of the form ((PREFIX . PTREE) . RTREE) where PREFIX is a string
;; meaning that everything that starts with PREFIX is in PTREE,
;; and everything else in RTREE. It also has the property that
;; everything that starts with the first letter of PREFIX but not with
;; that whole PREFIX is not in RTREE (i.e. is not in the tree at all).
;; - anything else is taken as the value to associate with the empty string.
;; So every node is basically an (improper) alist where each mapping applies
;; to a different leading letter.
;;
;; The main downside of this representation is that the lookup operation
;; is slower because each level of the tree is an alist rather than some kind
;; of array, so every level's lookup is O(N) rather than O(1). We could easily
;; solve this by using char-tables instead of alists, but that would make every
;; level take up a lot more memory, and it would make the resulting
;; data structure harder to read (by a human) when printed out.
;;; Code:
(defvar radix-tree-compare-function 'compare-strings)
(defvar radix-tree-type 'string)
(defun radix-tree--insert (tree key val i)
(pcase tree
(`((,prefix . ,ptree) . ,rtree)
(let* ((ni (+ i (length prefix)))
(cmp (funcall radix-tree-compare-function prefix nil nil key i ni)))
(if (eq t cmp)
(let ((nptree (radix-tree--insert ptree key val ni)))
`((,prefix . ,nptree) . ,rtree))
(let ((n (if (< cmp 0) (- -1 cmp) (- cmp 1))))
(if (zerop n)
(let ((nrtree (radix-tree--insert rtree key val i)))
`((,prefix . ,ptree) . ,nrtree))
(let* ((nprefix (substring prefix 0 n))
(kprefix (substring key (+ i n)))
(pprefix (substring prefix n))
(ktree (if (equal kprefix "") val
`((,kprefix . ,val)))))
`((,nprefix
. ((,pprefix . ,ptree) . ,ktree))
. ,rtree)))))))
(_
(if (= (length key) i) val
(let ((prefix (substring key i)))
`((,prefix . ,val) . ,tree))))))
(defun radix-tree--remove (tree key i)
(pcase tree
(`((,prefix . ,ptree) . ,rtree)
(let* ((ni (+ i (length prefix)))
(cmp (funcall radix-tree-compare-function prefix nil nil key i ni)))
(if (eq t cmp)
(pcase (radix-tree--remove ptree key ni)
('nil rtree)
(`((,pprefix . ,pptree))
`((,(seq-concatenate radix-tree-type prefix pprefix) . ,pptree) .
,rtree))
(nptree `((,prefix . ,nptree) . ,rtree)))
(let ((n (if (< cmp 0) (- -1 cmp) (- cmp 1))))
(if (zerop n)
(let ((nrtree (radix-tree--remove rtree key i)))
`((,prefix . ,ptree) . ,nrtree))
tree)))))
(_
(if (= (length key) i) nil tree))))
(defun radix-tree--lookup (tree string i)
(pcase tree
(`((,prefix . ,ptree) . ,rtree)
(let* ((ni (+ i (length prefix)))
(cmp (funcall radix-tree-compare-function prefix nil nil string i ni)))
(if (eq t cmp)
(radix-tree--lookup ptree string ni)
(let ((n (if (< cmp 0) (- -1 cmp) (- cmp 1))))
(if (zerop n)
(radix-tree--lookup rtree string i)
(+ i n))))))
(val
(if (and val (equal (length string) i))
(if (integerp val) `(t . ,val) val)
i))))
;; (defun radix-tree--trim (tree string i)
;; (if (= i (length string))
;; tree
;; (pcase tree
;; (`((,prefix . ,ptree) . ,rtree)
;; (let* ((ni (+ i (length prefix)))
;; (cmp (funcall radix-tree-compare-function prefix nil nil string i ni))
;; ;; FIXME: We could compute nrtree more efficiently
;; ;; whenever cmp is not -1 or 1.
;; (nrtree (radix-tree--trim rtree string i)))
;; (if (eq t cmp)
;; (pcase (radix-tree--trim ptree string ni)
;; (`nil nrtree)
;; (`((,pprefix . ,pptree))
;; `((,(concat prefix pprefix) . ,pptree) . ,nrtree))
;; (nptree `((,prefix . ,nptree) . ,nrtree)))
;; (let ((n (if (< cmp 0) (- -1 cmp) (- cmp 1))))
;; (cond
;; ((equal (+ n i) (length string))
;; `((,prefix . ,ptree) . ,nrtree))
;; (t nrtree))))))
;; (val val))))
(defun radix-tree--prefixes (tree string i prefixes)
(pcase tree
(`((,prefix . ,ptree) . ,rtree)
(let* ((ni (+ i (length prefix)))
(cmp (funcall radix-tree-compare-function prefix nil nil string i ni))
;; FIXME: We could compute prefixes more efficiently
;; whenever cmp is not -1 or 1.
(prefixes (radix-tree--prefixes rtree string i prefixes)))
(if (eq t cmp)
(radix-tree--prefixes ptree string ni prefixes)
prefixes)))
(val
(if (null val)
prefixes
(cons (cons (substring string 0 i)
(if (eq (car-safe val) t) (cdr val) val))
prefixes)))))
(defun radix-tree--subtree (tree string i)
(if (equal (length string) i) tree
(pcase tree
(`((,prefix . ,ptree) . ,rtree)
(let* ((ni (+ i (length prefix)))
(cmp (funcall radix-tree-compare-function prefix nil nil string i ni)))
(if (eq t cmp)
(radix-tree--subtree ptree string ni)
(let ((n (if (< cmp 0) (- -1 cmp) (- cmp 1))))
(cond
((zerop n) (radix-tree--subtree rtree string i))
((equal (+ n i) (length string))
(let ((nprefix (substring prefix n)))
`((,nprefix . ,ptree))))
(t nil))))))
(_ nil))))
;;; Entry points
(defconst radix-tree-empty nil
"The empty radix-tree.")
(defun radix-tree-insert (tree key val)
"Insert a mapping from KEY to VAL in radix TREE."
(when (consp val) (setq val `(t . ,val)))
(if val (radix-tree--insert tree key val 0)
(radix-tree--remove tree key 0)))
(defun radix-tree-lookup (tree key)
"Return the value associated to KEY in radix TREE.
If not found, return nil."
(pcase (radix-tree--lookup tree key 0)
(`(t . ,val) val)
((pred numberp) nil)
(val val)))
(defun radix-tree-subtree (tree string)
"Return the subtree of TREE rooted at the prefix STRING."
(radix-tree--subtree tree string 0))
;; (defun radix-tree-trim (tree string)
;; "Return a TREE which only holds entries \"related\" to STRING.
;; \"Related\" is here defined as entries where there's a `string-prefix-p' relation
;; between STRING and the key."
;; (radix-tree-trim tree string 0))
(defun radix-tree-prefixes (tree string)
"Return an alist of all bindings in TREE for prefixes of STRING."
(radix-tree--prefixes tree string 0 nil))
(pcase-defmacro radix-tree-leaf (vpat)
"Pattern which matches a radix-tree leaf.
The pattern VPAT is matched against the leaf's carried value."
;; We used to use `(pred atom)', but `pcase' doesn't understand that
;; `atom' is equivalent to the negation of `consp' and hence generates
;; suboptimal code.
`(or `(t . ,,vpat) (and (pred (not consp)) ,vpat)))
(defun radix-tree-iter-subtrees (tree fun)
"Apply FUN to every immediate subtree of radix TREE.
FUN is called with two arguments: PREFIX and SUBTREE.
You can test if SUBTREE is a leaf (and extract its value) with the
pcase pattern (radix-tree-leaf PAT)."
(while tree
(pcase tree
(`((,prefix . ,ptree) . ,rtree)
(funcall fun prefix ptree)
(setq tree rtree))
(_ (funcall fun "" tree)
(setq tree nil)))))
(defun radix-tree-iter-mappings (tree fun &optional prefix)
"Apply FUN to every mapping in TREE.
FUN is called with two arguments: KEY and VAL.
PREFIX is only used internally."
(radix-tree-iter-subtrees
tree
(lambda (p s)
(let ((nprefix (seq-concatenate radix-tree-type prefix p)))
(pcase s
((radix-tree-leaf v) (funcall fun nprefix v))
(_ (radix-tree-iter-mappings s fun nprefix)))))))
;; (defun radix-tree->alist (tree)
;; (let ((al nil))
;; (radix-tree-iter-mappings tree (lambda (p v) (push (cons p v) al)))
;; al))
(defun radix-tree-count (tree)
(let ((i 0))
(radix-tree-iter-mappings tree (lambda (_k _v) (setq i (1+ i))))
i))
(declare-function map-apply "map" (function map))
(defun radix-tree-from-map (map)
;; Aka (cl-defmethod map-into (map (type (eql 'radix-tree)))) ...)
(require 'map)
(let ((rt nil))
(map-apply (lambda (k v) (setq rt (radix-tree-insert rt k v))) map)
rt))
(provide 'radix-tree)
;;; radix-tree.el ends here
|
