-
-
Notifications
You must be signed in to change notification settings - Fork 1
/
flx.lisp
306 lines (279 loc) · 12.1 KB
/
flx.lisp
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
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
(defpackage flx
(:use cl)
(:export score))
(in-package :flx)
(defvar word-separators '(#\Space #\- #\_ #\: #\. #\/ #\\)
"List of characters that act as word separators in flx.")
(defun memq (elt list)
"Mimic `memq' function."
(member elt list :test #'eq))
;; Do we need more word separators than ST?
(defun word-p (char)
"Check if CHAR is a word character."
(and char
(not (memq char word-separators))))
(defun capital-p (char)
"Check if CHAR is an uppercase character."
(and char
(word-p char)
(equal char (string-upcase char))))
(defun boundary-p (last-char char)
"Check if LAST-CHAR is the end of a word and CHAR the start of the next.
This function is camel-case aware."
(or (null last-char)
(and (not (capital-p last-char))
(capital-p char))
(and (not (word-p last-char))
(word-p char))))
(defun inc-vec (vec &optional inc beg end)
"Increment each element in VEC between BEG and END by INC.
INC defaults to 1. BEG defaults to 0 and is inclusive.
END is not inclusive and defaults to the length of VEC."
(or inc
(setq inc 1))
(or beg
(setq beg 0))
(or end
(setq end (length vec)))
(loop while (< beg end)
do (incf (aref vec beg) inc)
(incf beg))
vec)
(defun get-hash-for-string (str heatmap-func)
"Return hash-table for string where keys are characters.
Value is a sorted list of indexes for character occurrences."
(let* ((res (make-hash-table :test 'eq :size 32))
(str-len (length str))
down-char)
(loop for index from (1- str-len) downto 0
for char = (aref str index)
do (progn
;; simulate `case-fold-search'
(if (capital-p char)
(progn
(push index (gethash char res))
(setq down-char (string-downcase char)))
(setq down-char char))
(push index (gethash down-char res))))
(setf (gethash 'heatmap res) (funcall heatmap-func str))
res))
;; So we store one fixnum per character. Is this too memory inefficient?
(defun get-heatmap-str (str &optional group-separator)
"Generate the heatmap vector of string.
See documentation for logic."
(let* ((str-len (length str))
(str-last-index (1- str-len))
;; ++++ base
(scores (make-array str-len :initial-element -35))
(penalty-lead #\.)
(groups-alist (list (list -1 0))))
;; ++++ final char bonus
(incf (aref scores str-last-index) 1)
;; Establish baseline mapping
(loop for char across str
for index from 0
with last-char = nil
with group-word-count = 0
do (progn
(let ((effective-last-char
;; before we find any words, all separaters are
;; considered words of length 1. This is so "foo/__ab"
;; gets penalized compared to "foo/ab".
(if (zerop group-word-count) nil last-char)))
(when (boundary-p effective-last-char char)
(setf (cdr (cdar groups-alist))
(cons index (cddar groups-alist))))
(when (and (not (word-p last-char))
(word-p char))
(incf group-word-count)))
;; ++++ -45 penalize extension
(when (eq last-char penalty-lead)
(incf (aref scores index) -45))
(when (eq group-separator char)
(setf (car (cdar groups-alist)) group-word-count)
(setq group-word-count 0)
(push (nconc (list index group-word-count)) groups-alist))
(if (= index str-last-index)
(setf (car (cdar groups-alist)) group-word-count)
(setq last-char char))))
(let* ((group-count (length groups-alist))
(separator-count (1- group-count)))
;; ++++ slash group-count penalty
(unless (zerop separator-count)
(inc-vec scores (* -2 group-count)))
;; score each group further
(loop for group in groups-alist
for index from separator-count downto 0
with last-group-limit = nil
with basepath-found = nil
do (let ((group-start (car group))
(word-count (cadr group))
;; this is the number of effective word groups
(words-length (length (cddr group)))
basepath-p)
(when (and (not (zerop words-length))
(not basepath-found))
(setq basepath-found t)
(setq basepath-p t))
(let (num)
(setq num
(if basepath-p
(+ 35
;; ++++ basepath separator-count boosts
(if (> separator-count 1)
(1- separator-count)
0)
;; ++++ basepath word count penalty
(- word-count))
;; ++++ non-basepath penalties
(if (= index 0)
-3
(+ -5 (1- index)))))
(inc-vec scores num (1+ group-start) last-group-limit))
(loop for word in (cddr group)
for word-index from (1- words-length) downto 0
with last-word = (or last-group-limit
str-len)
do (progn
(incf (aref scores word)
;; ++++ beg word bonus AND
85)
(loop for index from word below last-word
for char-i from 0
do (incf (aref scores index)
(-
;; ++++ word order penalty
(* -3 word-index)
;; ++++ char order penalty
char-i)))
(setq last-word word)))
(setq last-group-limit (1+ group-start)))))
scores))
(defun bigger-sublist (sorted-list val)
"Return sublist bigger than VAL from sorted SORTED-LIST.
If VAL is nil, return entire list."
(if val
(loop for sub on sorted-list
do (when (> (car sub) val)
(return sub)))
sorted-list))
(defun process-cache (str cache)
"Get calculated heatmap from cache, add it if necessary."
(let ((res (when cache
(gethash str cache))))
(or res
(progn
(setq res (get-hash-for-string
str
(or (and cache (gethash 'heatmap-func cache))
'get-heatmap-str)))
(when cache
(setf (gethash str res) cache))
res))))
(defun find-best-match (str-info
heatmap
greater-than
query
query-length
q-index
match-cache)
"Recursively compute the best match for a string, passed as STR-INFO and
HEATMAP, according to QUERY.
This function uses MATCH-CACHE to memoize its return values.
For other parameters, see `score'"
;; Here, we use a simple N'ary hashing scheme
;; You could use (/ hash-key query-length) to get greater-than
;; Or, (mod hash-key query-length) to get q-index
;; We use this instead of a cons key for the sake of efficiency
(let* ((hash-key (+ q-index
(* (or greater-than 0)
query-length)))
(hash-value (gethash hash-key match-cache)))
(if hash-value
;; Here, we use the value 'no-match to distinguish a cache miss
;; from a nil (i.e. non-matching) return value
(if (eq hash-value 'no-match)
nil
hash-value)
(let ((indexes (bigger-sublist
(gethash (aref query q-index) str-info)
greater-than))
(match)
(temp-score)
(best-score most-negative-fixnum))
;; Matches are of the form:
;; ((match_indexes) . (score . contiguous-count))
(if (>= q-index (1- query-length))
;; At the tail end of the recursion, simply
;; generate all possible matches with their scores
;; and return the list to parent.
(setq match (mapcar (lambda (index)
(cons (list index)
(cons (aref heatmap index) 0)))
indexes))
(dolist (index indexes)
(dolist (elem (find-best-match str-info
heatmap
index
query
query-length
(1+ q-index)
match-cache))
(setq temp-score
(if (= (1- (caar elem)) index)
(+ (cadr elem)
(aref heatmap index)
;; boost contiguous matches
(* (min (cddr elem)
3)
15)
60)
(+ (cadr elem)
(aref heatmap index))))
;; We only care about the optimal match, so only
;; forward the match with the best score to parent
(when (> temp-score best-score)
(setq best-score temp-score
match (list (cons (cons index (car elem))
(cons temp-score
(if (= (1- (caar elem))
index)
(1+ (cddr elem))
0)))))))))
;; Calls are cached to avoid exponential time complexity
;; (puthash hash-key
;; (if match match 'no-match)
;; match-cache)
;;(setf (gethash hash-key (if match match 'no-match)) match-cache)
match))))
(defun score (str query &optional cache)
"Return best score matching QUERY against STR."
(unless (or (zerop (length query))
(zerop (length str)))
(let*
((str-info (process-cache str cache))
(heatmap (gethash 'heatmap str-info))
(query-length (length query))
(full-match-boost (and (< 1 query-length)
(< query-length 5)))
;; Dynamic Programming table for memoizing find-best-match
(match-cache (make-hash-table :test 'eql :size 10))
(optimal-match (find-best-match str-info
heatmap
nil
query
query-length
0
match-cache)))
;; Postprocess candidate
(and optimal-match
(cons
;; This is the computed score, adjusted to boost the scores
;; of exact matches.
(if (and full-match-boost
(= (length (caar optimal-match))
(length str)))
(+ (cadar optimal-match) 10000)
(cadar optimal-match))
;; This is the list of match positions
(caar optimal-match))))))