Klimi's new dotfiles with stow.
選択できるのは25トピックまでです。 トピックは、先頭が英数字で、英数字とダッシュ('-')を使用した35文字以内のものにしてください。

706 行
33 KiB

  1. ;;; swank-fuzzy.lisp --- fuzzy symbol completion
  2. ;;
  3. ;; Authors: Brian Downing <bdowning@lavos.net>
  4. ;; Tobias C. Rittweiler <tcr@freebits.de>
  5. ;; and others
  6. ;;
  7. ;; License: Public Domain
  8. ;;
  9. (in-package :swank)
  10. (eval-when (:compile-toplevel :load-toplevel :execute)
  11. (swank-require :swank-util)
  12. (swank-require :swank-c-p-c))
  13. (defvar *fuzzy-duplicate-symbol-filter* :nearest-package
  14. "Specifies how fuzzy-matching handles \"duplicate\" symbols.
  15. Possible values are :NEAREST-PACKAGE, :HOME-PACKAGE, :ALL, or a custom
  16. function. See Fuzzy Completion in the manual for details.")
  17. (export '*fuzzy-duplicate-symbol-filter*)
  18. ;;; For nomenclature of the fuzzy completion section, please read
  19. ;;; through the following docstring.
  20. (defslimefun fuzzy-completions (string default-package-name
  21. &key limit time-limit-in-msec)
  22. "Returns a list of two values:
  23. An (optionally limited to LIMIT best results) list of fuzzy
  24. completions for a symbol designator STRING. The list will be
  25. sorted by score, most likely match first.
  26. A flag that indicates whether or not TIME-LIMIT-IN-MSEC has
  27. been exhausted during computation. If that parameter's value is
  28. NIL or 0, no time limit is assumed.
  29. The main result is a list of completion objects, where a completion
  30. object is:
  31. (COMPLETED-STRING SCORE (&rest CHUNKS) CLASSIFICATION-STRING)
  32. where a CHUNK is a description of a matched substring:
  33. (OFFSET SUBSTRING)
  34. and FLAGS is short string describing properties of the symbol (see
  35. SYMBOL-CLASSIFICATION-STRING).
  36. E.g., completing \"mvb\" in a package that uses COMMON-LISP would
  37. return something like:
  38. ((\"multiple-value-bind\" 26.588236 ((0 \"m\") (9 \"v\") (15 \"b\"))
  39. (:FBOUNDP :MACRO))
  40. ...)
  41. If STRING is package qualified the result list will also be
  42. qualified. If string is non-qualified the result strings are
  43. also not qualified and are considered relative to
  44. DEFAULT-PACKAGE-NAME.
  45. Which symbols are candidates for matching depends on the symbol
  46. designator's format. The cases are as follows:
  47. FOO - Symbols accessible in the buffer package.
  48. PKG:FOO - Symbols external in package PKG.
  49. PKG::FOO - Symbols accessible in package PKG."
  50. ;; For Emacs we allow both NIL and 0 as value of TIME-LIMIT-IN-MSEC
  51. ;; to denote an infinite time limit. Internally, we only use NIL for
  52. ;; that purpose, to be able to distinguish between "no time limit
  53. ;; alltogether" and "current time limit already exhausted." So we've
  54. ;; got to canonicalize its value at first:
  55. (let* ((no-time-limit-p (or (not time-limit-in-msec)
  56. (zerop time-limit-in-msec)))
  57. (time-limit (if no-time-limit-p nil time-limit-in-msec)))
  58. (multiple-value-bind (completion-set interrupted-p)
  59. (fuzzy-completion-set string default-package-name :limit limit
  60. :time-limit-in-msec time-limit)
  61. ;; We may send this as elisp [] arrays to spare a coerce here,
  62. ;; but then the network serialization were slower by handling arrays.
  63. ;; Instead we limit the number of completions that is transferred
  64. ;; (the limit is set from Emacs.)
  65. (list (coerce completion-set 'list) interrupted-p))))
  66. ;;; A Fuzzy Matching -- Not to be confused with a fuzzy completion
  67. ;;; object that will be sent back to Emacs, as described above.
  68. (defstruct (fuzzy-matching (:conc-name fuzzy-matching.)
  69. (:predicate fuzzy-matching-p)
  70. (:constructor make-fuzzy-matching
  71. (symbol package-name score package-chunks
  72. symbol-chunks &key (symbol-p t))))
  73. symbol ; The symbol that has been found to match.
  74. symbol-p ; To deffirentiate between completeing
  75. ; package: and package:nil
  76. package-name ; The name of the package where SYMBOL was found in.
  77. ; (This is not necessarily the same as the home-package
  78. ; of SYMBOL, because the SYMBOL can be internal to
  79. ; lots of packages; also think of package nicknames.)
  80. score ; The higher the better SYMBOL is a match.
  81. package-chunks ; Chunks pertaining to the package identifier of SYMBOL.
  82. symbol-chunks) ; Chunks pertaining to SYMBOL's name.
  83. (defun %fuzzy-extract-matching-info (fuzzy-matching user-input-string)
  84. (multiple-value-bind (_ user-package-name __ input-internal-p)
  85. (parse-completion-arguments user-input-string nil)
  86. (declare (ignore _ __))
  87. (with-struct (fuzzy-matching. score symbol package-name package-chunks
  88. symbol-chunks symbol-p)
  89. fuzzy-matching
  90. (let (symbol-name real-package-name internal-p)
  91. (cond (symbol-p ; symbol fuzzy matching?
  92. (setf symbol-name (symbol-name symbol))
  93. (setf internal-p input-internal-p)
  94. (setf real-package-name (cond ((keywordp symbol) "")
  95. ((not user-package-name) nil)
  96. (t package-name))))
  97. (t ; package fuzzy matching?
  98. (setf symbol-name "")
  99. (setf real-package-name package-name)
  100. ;; If no explicit package name was given by the user
  101. ;; (e.g. input was "asdf"), we want to append only
  102. ;; one colon ":" to the package names.
  103. (setf internal-p (if user-package-name input-internal-p nil))))
  104. (values symbol-name
  105. real-package-name
  106. (if user-package-name internal-p nil)
  107. (completion-output-symbol-converter user-input-string)
  108. (completion-output-package-converter user-input-string))))))
  109. (defun fuzzy-format-matching (fuzzy-matching user-input-string)
  110. "Returns the completion (\"foo:bar\") that's represented by FUZZY-MATCHING."
  111. (multiple-value-bind (symbol-name package-name internal-p
  112. symbol-converter package-converter)
  113. (%fuzzy-extract-matching-info fuzzy-matching user-input-string)
  114. (setq symbol-name (and symbol-name
  115. (funcall symbol-converter symbol-name)))
  116. (setq package-name (and package-name
  117. (funcall package-converter package-name)))
  118. (let ((result (untokenize-symbol package-name internal-p symbol-name)))
  119. ;; We return the length of the possibly added prefix as second value.
  120. (values result (search symbol-name result)))))
  121. (defun fuzzy-convert-matching-for-emacs (fuzzy-matching user-input-string)
  122. "Converts a result from the fuzzy completion core into something
  123. that emacs is expecting. Converts symbols to strings, fixes case
  124. issues, and adds information (as a string) describing if the symbol is
  125. bound, fbound, a class, a macro, a generic-function, a
  126. special-operator, or a package."
  127. (with-struct (fuzzy-matching. symbol score package-chunks symbol-chunks
  128. symbol-p)
  129. fuzzy-matching
  130. (multiple-value-bind (name added-length)
  131. (fuzzy-format-matching fuzzy-matching user-input-string)
  132. (list name
  133. (format nil "~,2f" score)
  134. (append package-chunks
  135. (mapcar (lambda (chunk)
  136. ;; Fix up chunk positions to account for possible
  137. ;; added package identifier.
  138. (let ((offset (first chunk))
  139. (string (second chunk)))
  140. (list (+ added-length offset) string)))
  141. symbol-chunks))
  142. (if symbol-p
  143. (symbol-classification-string symbol)
  144. "-------p")))))
  145. (defun fuzzy-completion-set (string default-package-name
  146. &key limit time-limit-in-msec)
  147. "Returns two values: an array of completion objects, sorted by
  148. their score, that is how well they are a match for STRING
  149. according to the fuzzy completion algorithm. If LIMIT is set,
  150. only the top LIMIT results will be returned. Additionally, a flag
  151. is returned that indicates whether or not TIME-LIMIT-IN-MSEC was
  152. exhausted."
  153. (check-type limit (or null (integer 0 #.(1- most-positive-fixnum))))
  154. (check-type time-limit-in-msec
  155. (or null (integer 0 #.(1- most-positive-fixnum))))
  156. (multiple-value-bind (matchings interrupted-p)
  157. (fuzzy-generate-matchings string default-package-name time-limit-in-msec)
  158. (when (and limit
  159. (> limit 0)
  160. (< limit (length matchings)))
  161. (if (array-has-fill-pointer-p matchings)
  162. (setf (fill-pointer matchings) limit)
  163. (setf matchings (make-array limit :displaced-to matchings))))
  164. (map-into matchings #'(lambda (m)
  165. (fuzzy-convert-matching-for-emacs m string))
  166. matchings)
  167. (values matchings interrupted-p)))
  168. (defun fuzzy-generate-matchings (string default-package-name
  169. time-limit-in-msec)
  170. "Does all the hard work for FUZZY-COMPLETION-SET. If
  171. TIME-LIMIT-IN-MSEC is NIL, an infinite time limit is assumed."
  172. (multiple-value-bind (parsed-symbol-name parsed-package-name
  173. package internal-p)
  174. (parse-completion-arguments string default-package-name)
  175. (flet ((fix-up (matchings parent-package-matching)
  176. ;; The components of each matching in MATCHINGS have been computed
  177. ;; relatively to PARENT-PACKAGE-MATCHING. Make them absolute.
  178. (let* ((p parent-package-matching)
  179. (p.name (fuzzy-matching.package-name p))
  180. (p.score (fuzzy-matching.score p))
  181. (p.chunks (fuzzy-matching.package-chunks p)))
  182. (map-into
  183. matchings
  184. (lambda (m)
  185. (let ((m.score (fuzzy-matching.score m)))
  186. (setf (fuzzy-matching.package-name m) p.name)
  187. (setf (fuzzy-matching.package-chunks m) p.chunks)
  188. (setf (fuzzy-matching.score m)
  189. (if (equal parsed-symbol-name "")
  190. ;; Make package matchings be sorted before all
  191. ;; the relative symbol matchings while preserving
  192. ;; over all orderness.
  193. (/ p.score 100)
  194. (+ p.score m.score)))
  195. m))
  196. matchings)))
  197. (find-symbols (designator package time-limit &optional filter)
  198. (fuzzy-find-matching-symbols designator package
  199. :time-limit-in-msec time-limit
  200. :external-only (not internal-p)
  201. :filter (or filter #'identity)))
  202. (find-packages (designator time-limit)
  203. (fuzzy-find-matching-packages designator
  204. :time-limit-in-msec time-limit))
  205. (maybe-find-local-package (name)
  206. (or (find-locally-nicknamed-package name *buffer-package*)
  207. (find-package name))))
  208. (let ((time-limit time-limit-in-msec) (symbols) (packages) (results)
  209. (dedup-table (make-hash-table :test #'equal)))
  210. (cond ((not parsed-package-name) ; E.g. STRING = "asd"
  211. ;; We don't know if user is searching for a package or a symbol
  212. ;; within his current package. So we try to find either.
  213. (setf (values packages time-limit)
  214. (find-packages parsed-symbol-name time-limit))
  215. (setf (values symbols time-limit)
  216. (find-symbols parsed-symbol-name package time-limit)))
  217. ((string= parsed-package-name "") ; E.g. STRING = ":" or ":foo"
  218. (setf (values symbols time-limit)
  219. (find-symbols parsed-symbol-name package time-limit)))
  220. (t ; E.g. STRING = "asd:" or "asd:foo"
  221. ;; Find fuzzy matchings of the denoted package identifier part.
  222. ;; After that, find matchings for the denoted symbol identifier
  223. ;; relative to all the packages found.
  224. (multiple-value-bind (symbol-packages rest-time-limit)
  225. (find-packages parsed-package-name time-limit-in-msec)
  226. ;; We want to traverse the found packages in the order of
  227. ;; their score, since those with higher score presumably
  228. ;; represent better choices. (This is important because some
  229. ;; packages may never be looked at if time limit exhausts
  230. ;; during traversal.)
  231. (setf symbol-packages
  232. (sort symbol-packages #'fuzzy-matching-greaterp))
  233. (loop
  234. for package-matching across symbol-packages
  235. for package = (maybe-find-local-package
  236. (fuzzy-matching.package-name
  237. package-matching))
  238. while (or (not time-limit) (> rest-time-limit 0)) do
  239. (multiple-value-bind (matchings remaining-time)
  240. ;; The duplication filter removes all those symbols
  241. ;; which are present in more than one package
  242. ;; match. See *FUZZY-DUPLICATE-SYMBOL-FILTER*
  243. (find-symbols parsed-symbol-name package rest-time-limit
  244. (%make-duplicate-symbols-filter
  245. package-matching symbol-packages dedup-table))
  246. (setf matchings (fix-up matchings package-matching))
  247. (setf symbols (concatenate 'vector symbols matchings))
  248. (setf rest-time-limit remaining-time)
  249. (let ((guessed-sort-duration
  250. (%guess-sort-duration (length symbols))))
  251. (when (and rest-time-limit
  252. (<= rest-time-limit guessed-sort-duration))
  253. (decf rest-time-limit guessed-sort-duration)
  254. (loop-finish))))
  255. finally
  256. (setf time-limit rest-time-limit)
  257. (when (equal parsed-symbol-name "") ; E.g. STRING = "asd:"
  258. (setf packages symbol-packages))))))
  259. ;; Sort by score; thing with equal score, sort alphabetically.
  260. ;; (Especially useful when PARSED-SYMBOL-NAME is empty, and all
  261. ;; possible completions are to be returned.)
  262. (setf results (concatenate 'vector symbols packages))
  263. (setf results (sort results #'fuzzy-matching-greaterp))
  264. (values results (and time-limit (<= time-limit 0)))))))
  265. (defun %guess-sort-duration (length)
  266. ;; These numbers are pretty much arbitrary, except that they're
  267. ;; vaguely correct on my machine with SBCL. Yes, this is an ugly
  268. ;; kludge, but it's better than before (where this didn't exist at
  269. ;; all, which essentially meant, that this was taken to be 0.)
  270. (if (zerop length)
  271. 0
  272. (let ((comparasions (* 3.8 (* length (log length 2)))))
  273. (* 1000 (* comparasions (expt 10 -7)))))) ; msecs
  274. (defun %make-duplicate-symbols-filter (current-package-matching fuzzy-package-matchings dedup-table)
  275. ;; Returns a filter function based on *FUZZY-DUPLICATE-SYMBOL-FILTER*.
  276. (case *fuzzy-duplicate-symbol-filter*
  277. (:home-package
  278. ;; Return a filter function that takes a symbol, and which returns T
  279. ;; if and only if /no/ matching in FUZZY-PACKAGE-MATCHINGS represents
  280. ;; the home-package of the symbol passed.
  281. (let ((packages (mapcar #'(lambda (m)
  282. (find-package (fuzzy-matching.package-name m)))
  283. (remove current-package-matching
  284. (coerce fuzzy-package-matchings 'list)))))
  285. #'(lambda (symbol)
  286. (not (member (symbol-package symbol) packages)))))
  287. (:nearest-package
  288. ;; Keep only the first occurence of the symbol.
  289. #'(lambda (symbol)
  290. (unless (gethash (symbol-name symbol) dedup-table)
  291. (setf (gethash (symbol-name symbol) dedup-table) t))))
  292. (:all
  293. ;; No filter
  294. #'identity)
  295. (t
  296. (typecase *fuzzy-duplicate-symbol-filter*
  297. (function
  298. ;; Custom filter
  299. (funcall *fuzzy-duplicate-symbol-filter*
  300. (fuzzy-matching.package-name current-package-matching)
  301. (map 'list #'fuzzy-matching.package-name fuzzy-package-matchings)
  302. dedup-table))
  303. (t
  304. ;; Bad filter value
  305. (warn "bad *FUZZY-DUPLICATE-SYMBOL-FILTER* value: ~s"
  306. *fuzzy-duplicate-symbol-filter*)
  307. #'identity)))))
  308. (defun fuzzy-matching-greaterp (m1 m2)
  309. "Returns T if fuzzy-matching M1 should be sorted before M2.
  310. Basically just the scores of the two matchings are compared, and
  311. the match with higher score wins. For the case that the score is
  312. equal, the one which comes alphabetically first wins."
  313. (declare (type fuzzy-matching m1 m2))
  314. (let ((score1 (fuzzy-matching.score m1))
  315. (score2 (fuzzy-matching.score m2)))
  316. (cond ((> score1 score2) t)
  317. ((< score1 score2) nil) ; total order
  318. (t
  319. (let ((name1 (symbol-name (fuzzy-matching.symbol m1)))
  320. (name2 (symbol-name (fuzzy-matching.symbol m2))))
  321. (string< name1 name2))))))
  322. (declaim (ftype (function () (integer 0)) get-real-time-msecs))
  323. (defun get-real-time-in-msecs ()
  324. (let ((units-per-msec (max 1 (floor internal-time-units-per-second 1000))))
  325. (values (floor (get-internal-real-time) units-per-msec))))
  326. (defun fuzzy-find-matching-symbols
  327. (string package &key (filter #'identity) external-only time-limit-in-msec)
  328. "Returns two values: a vector of fuzzy matchings for matching
  329. symbols in PACKAGE, using the fuzzy completion algorithm, and the
  330. remaining time limit.
  331. Only those symbols are considered of which FILTER does return T.
  332. If EXTERNAL-ONLY is true, only external symbols are considered. A
  333. TIME-LIMIT-IN-MSEC of NIL is considered no limit; if it's zero or
  334. negative, perform a NOP."
  335. (let ((time-limit-p (and time-limit-in-msec t))
  336. (time-limit (or time-limit-in-msec 0))
  337. (rtime-at-start (get-real-time-in-msecs))
  338. (package-name (package-name package))
  339. (count 0))
  340. (declare (type boolean time-limit-p))
  341. (declare (type integer time-limit rtime-at-start))
  342. (declare (type (integer 0 #.(1- most-positive-fixnum)) count))
  343. (flet ((recompute-remaining-time (old-remaining-time)
  344. (cond ((not time-limit-p)
  345. ;; propagate NIL back as infinite time limit
  346. (values nil nil))
  347. ((> count 0) ; ease up on getting internal time like crazy
  348. (setf count (mod (1+ count) 128))
  349. (values nil old-remaining-time))
  350. (t (let* ((elapsed-time (- (get-real-time-in-msecs)
  351. rtime-at-start))
  352. (remaining (- time-limit elapsed-time)))
  353. (values (<= remaining 0) remaining)))))
  354. (perform-fuzzy-match (string symbol-name)
  355. (let* ((converter (completion-output-symbol-converter string))
  356. (converted-symbol-name (funcall converter symbol-name)))
  357. (compute-highest-scoring-completion string
  358. converted-symbol-name))))
  359. (let ((completions (make-array 256 :adjustable t :fill-pointer 0))
  360. (rest-time-limit time-limit))
  361. (do-symbols* (symbol package)
  362. (multiple-value-bind (exhausted? remaining-time)
  363. (recompute-remaining-time rest-time-limit)
  364. (setf rest-time-limit remaining-time)
  365. (cond (exhausted? (return))
  366. ((not (and (or (not external-only)
  367. (symbol-external-p symbol package))
  368. (funcall filter symbol))))
  369. ((string= "" string) ; "" matches always
  370. (vector-push-extend
  371. (make-fuzzy-matching symbol package-name
  372. 0.0 '() '())
  373. completions))
  374. (t
  375. (multiple-value-bind (match-result score)
  376. (perform-fuzzy-match string (symbol-name symbol))
  377. (when match-result
  378. (vector-push-extend
  379. (make-fuzzy-matching symbol package-name score
  380. '() match-result)
  381. completions)))))))
  382. (values completions rest-time-limit)))))
  383. (defun fuzzy-find-matching-packages (name &key time-limit-in-msec)
  384. "Returns a vector of fuzzy matchings for each package that is
  385. similiar to NAME, and the remaining time limit.
  386. Cf. FUZZY-FIND-MATCHING-SYMBOLS."
  387. (let ((time-limit-p (and time-limit-in-msec t))
  388. (time-limit (or time-limit-in-msec 0))
  389. (rtime-at-start (get-real-time-in-msecs))
  390. (converter (completion-output-package-converter name))
  391. (completions (make-array 32 :adjustable t :fill-pointer 0)))
  392. (declare (type boolean time-limit-p))
  393. (declare (type integer time-limit rtime-at-start))
  394. (declare (type function converter))
  395. (flet ((match-package (names)
  396. (loop with max-pkg-name = ""
  397. with max-result = nil
  398. with max-score = 0
  399. for package-name in names
  400. for converted-name = (funcall converter package-name)
  401. do
  402. (multiple-value-bind (result score)
  403. (compute-highest-scoring-completion name
  404. converted-name)
  405. (when (and result (> score max-score))
  406. (setf max-pkg-name package-name)
  407. (setf max-result result)
  408. (setf max-score score)))
  409. finally
  410. (when max-result
  411. (vector-push-extend
  412. (make-fuzzy-matching nil max-pkg-name
  413. max-score max-result '()
  414. :symbol-p nil)
  415. completions)))))
  416. (cond ((and time-limit-p (<= time-limit 0))
  417. (values #() time-limit))
  418. (t
  419. (loop for (nick) in (package-local-nicknames *buffer-package*)
  420. do
  421. (match-package (list nick)))
  422. (loop for package in (list-all-packages)
  423. do
  424. ;; Find best-matching package-nickname:
  425. (match-package (package-names package))
  426. finally
  427. (return
  428. (values completions
  429. (and time-limit-p
  430. (let ((elapsed-time (- (get-real-time-in-msecs)
  431. rtime-at-start)))
  432. (- time-limit elapsed-time)))))))))))
  433. (defslimefun fuzzy-completion-selected (original-string completion)
  434. "This function is called by Slime when a fuzzy completion is
  435. selected by the user. It is for future expansion to make
  436. testing, say, a machine learning algorithm for completion scoring
  437. easier.
  438. ORIGINAL-STRING is the string the user completed from, and
  439. COMPLETION is the completion object (see docstring for
  440. SWANK:FUZZY-COMPLETIONS) corresponding to the completion that the
  441. user selected."
  442. (declare (ignore original-string completion))
  443. nil)
  444. ;;;;; Fuzzy completion core
  445. (defparameter *fuzzy-recursion-soft-limit* 30
  446. "This is a soft limit for recursion in
  447. RECURSIVELY-COMPUTE-MOST-COMPLETIONS. Without this limit,
  448. completing a string such as \"ZZZZZZ\" with a symbol named
  449. \"ZZZZZZZZZZZZZZZZZZZZZZZ\" will result in explosive recursion to
  450. find all the ways it can match.
  451. Most natural language searches and symbols do not have this
  452. problem -- this is only here as a safeguard.")
  453. (declaim (fixnum *fuzzy-recursion-soft-limit*))
  454. (defvar *all-chunks* '())
  455. (declaim (type list *all-chunks*))
  456. (defun compute-highest-scoring-completion (short full)
  457. "Finds the highest scoring way to complete the abbreviation
  458. SHORT onto the string FULL, using CHAR= as a equality function for
  459. letters. Returns two values: The first being the completion
  460. chunks of the highest scorer, and the second being the score."
  461. (let* ((scored-results
  462. (mapcar #'(lambda (result)
  463. (cons (score-completion result short full) result))
  464. (compute-most-completions short full)))
  465. (winner (first (sort scored-results #'> :key #'first))))
  466. (values (rest winner) (first winner))))
  467. (defun compute-most-completions (short full)
  468. "Finds most possible ways to complete FULL with the letters in SHORT.
  469. Calls RECURSIVELY-COMPUTE-MOST-COMPLETIONS recursively. Returns
  470. a list of (&rest CHUNKS), where each CHUNKS is a description of
  471. how a completion matches."
  472. (let ((*all-chunks* nil))
  473. (recursively-compute-most-completions short full 0 0 nil nil nil t)
  474. *all-chunks*))
  475. (defun recursively-compute-most-completions
  476. (short full
  477. short-index initial-full-index
  478. chunks current-chunk current-chunk-pos
  479. recurse-p)
  480. "Recursively (if RECURSE-P is true) find /most/ possible ways
  481. to fuzzily map the letters in SHORT onto FULL, using CHAR= to
  482. determine if two letters match.
  483. A chunk is a list of elements that have matched consecutively.
  484. When consecutive matches stop, it is coerced into a string,
  485. paired with the starting position of the chunk, and pushed onto
  486. CHUNKS.
  487. Whenever a letter matches, if RECURSE-P is true,
  488. RECURSIVELY-COMPUTE-MOST-COMPLETIONS calls itself with a position
  489. one index ahead, to find other possibly higher scoring
  490. possibilities. If there are less than
  491. *FUZZY-RECURSION-SOFT-LIMIT* results in *ALL-CHUNKS* currently,
  492. this call will also recurse.
  493. Once a word has been completely matched, the chunks are pushed
  494. onto the special variable *ALL-CHUNKS* and the function returns."
  495. (declare (optimize speed)
  496. (type fixnum short-index initial-full-index)
  497. (type list current-chunk)
  498. (simple-string short full))
  499. (flet ((short-cur ()
  500. "Returns the next letter from the abbreviation, or NIL
  501. if all have been used."
  502. (if (= short-index (length short))
  503. nil
  504. (aref short short-index)))
  505. (add-to-chunk (char pos)
  506. "Adds the CHAR at POS in FULL to the current chunk,
  507. marking the start position if it is empty."
  508. (unless current-chunk
  509. (setf current-chunk-pos pos))
  510. (push char current-chunk))
  511. (collect-chunk ()
  512. "Collects the current chunk to CHUNKS and prepares for
  513. a new chunk."
  514. (when current-chunk
  515. (let ((current-chunk-as-string
  516. (nreverse
  517. (make-array (length current-chunk)
  518. :element-type 'character
  519. :initial-contents current-chunk))))
  520. (push (list current-chunk-pos current-chunk-as-string) chunks)
  521. (setf current-chunk nil
  522. current-chunk-pos nil)))))
  523. ;; If there's an outstanding chunk coming in collect it. Since
  524. ;; we're recursively called on skipping an input character, the
  525. ;; chunk can't possibly continue on.
  526. (when current-chunk (collect-chunk))
  527. (do ((pos initial-full-index (1+ pos)))
  528. ((= pos (length full)))
  529. (let ((cur-char (aref full pos)))
  530. (if (and (short-cur)
  531. (char= cur-char (short-cur)))
  532. (progn
  533. (when recurse-p
  534. ;; Try other possibilities, limiting insanely deep
  535. ;; recursion somewhat.
  536. (recursively-compute-most-completions
  537. short full short-index (1+ pos)
  538. chunks current-chunk current-chunk-pos
  539. (not (> (length *all-chunks*)
  540. *fuzzy-recursion-soft-limit*))))
  541. (incf short-index)
  542. (add-to-chunk cur-char pos))
  543. (collect-chunk))))
  544. (collect-chunk)
  545. ;; If we've exhausted the short characters we have a match.
  546. (if (short-cur)
  547. nil
  548. (let ((rev-chunks (reverse chunks)))
  549. (push rev-chunks *all-chunks*)
  550. rev-chunks))))
  551. ;;;;; Fuzzy completion scoring
  552. (defvar *fuzzy-completion-symbol-prefixes* "*+-%&?<"
  553. "Letters that are likely to be at the beginning of a symbol.
  554. Letters found after one of these prefixes will be scored as if
  555. they were at the beginning of ths symbol.")
  556. (defvar *fuzzy-completion-symbol-suffixes* "*+->"
  557. "Letters that are likely to be at the end of a symbol.
  558. Letters found before one of these suffixes will be scored as if
  559. they were at the end of the symbol.")
  560. (defvar *fuzzy-completion-word-separators* "-/."
  561. "Letters that separate different words in symbols. Letters
  562. after one of these symbols will be scores more highly than other
  563. letters.")
  564. (defun score-completion (completion short full)
  565. "Scores the completion chunks COMPLETION as a completion from
  566. the abbreviation SHORT to the full string FULL. COMPLETION is a
  567. list like:
  568. ((0 \"mul\") (9 \"v\") (15 \"b\"))
  569. Which, if SHORT were \"mulvb\" and full were \"multiple-value-bind\",
  570. would indicate that it completed as such (completed letters
  571. capitalized):
  572. MULtiple-Value-Bind
  573. Letters are given scores based on their position in the string.
  574. Letters at the beginning of a string or after a prefix letter at
  575. the beginning of a string are scored highest. Letters after a
  576. word separator such as #\- are scored next highest. Letters at
  577. the end of a string or before a suffix letter at the end of a
  578. string are scored medium, and letters anywhere else are scored
  579. low.
  580. If a letter is directly after another matched letter, and its
  581. intrinsic value in that position is less than a percentage of the
  582. previous letter's value, it will use that percentage instead.
  583. Finally, a small scaling factor is applied to favor shorter
  584. matches, all other things being equal."
  585. (labels ((at-beginning-p (pos)
  586. (= pos 0))
  587. (after-prefix-p (pos)
  588. (and (= pos 1)
  589. (find (aref full 0) *fuzzy-completion-symbol-prefixes*)))
  590. (word-separator-p (pos)
  591. (find (aref full pos) *fuzzy-completion-word-separators*))
  592. (after-word-separator-p (pos)
  593. (find (aref full (1- pos)) *fuzzy-completion-word-separators*))
  594. (at-end-p (pos)
  595. (= pos (1- (length full))))
  596. (before-suffix-p (pos)
  597. (and (= pos (- (length full) 2))
  598. (find (aref full (1- (length full)))
  599. *fuzzy-completion-symbol-suffixes*)))
  600. (score-or-percentage-of-previous (base-score pos chunk-pos)
  601. (if (zerop chunk-pos)
  602. base-score
  603. (max base-score
  604. (+ (* (score-char (1- pos) (1- chunk-pos)) 0.85)
  605. (expt 1.2 chunk-pos)))))
  606. (score-char (pos chunk-pos)
  607. (score-or-percentage-of-previous
  608. (cond ((at-beginning-p pos) 10)
  609. ((after-prefix-p pos) 10)
  610. ((word-separator-p pos) 1)
  611. ((after-word-separator-p pos) 8)
  612. ((at-end-p pos) 6)
  613. ((before-suffix-p pos) 6)
  614. (t 1))
  615. pos chunk-pos))
  616. (score-chunk (chunk)
  617. (loop for chunk-pos below (length (second chunk))
  618. for pos from (first chunk)
  619. summing (score-char pos chunk-pos))))
  620. (let* ((chunk-scores (mapcar #'score-chunk completion))
  621. (length-score (/ 10.0 (1+ (- (length full) (length short))))))
  622. (values
  623. (+ (reduce #'+ chunk-scores) length-score)
  624. (list (mapcar #'list chunk-scores completion) length-score)))))
  625. (defun highlight-completion (completion full)
  626. "Given a chunk definition COMPLETION and the string FULL,
  627. HIGHLIGHT-COMPLETION will create a string that demonstrates where
  628. the completion matched in the string. Matches will be
  629. capitalized, while the rest of the string will be lower-case."
  630. (let ((highlit (nstring-downcase (copy-seq full))))
  631. (dolist (chunk completion)
  632. (setf highlit (nstring-upcase highlit
  633. :start (first chunk)
  634. :end (+ (first chunk)
  635. (length (second chunk))))))
  636. highlit))
  637. (defun format-fuzzy-completion-set (winners)
  638. "Given a list of completion objects such as on returned by
  639. FUZZY-COMPLETION-SET, format the list into user-readable output
  640. for interactive debugging purpose."
  641. (let ((max-len
  642. (loop for winner in winners maximizing (length (first winner)))))
  643. (loop for (sym score result) in winners do
  644. (format t "~&~VA score ~8,2F ~A"
  645. max-len (highlight-completion result sym) score result))))
  646. (provide :swank-fuzzy)