[slime-devel] Fuzzy completion
Brian Downing
bdowning at lavos.net
Fri Jun 11 08:24:20 UTC 2004
Hello Slime developers,
For the past while, I've been using a Mac OS X program called
Quicksilver, which is sort of a multi-purpose quick access tool. It
features a fuzzy completion algorithm that I've quite grown to like.
For example I can hit Command-Space and type "liswp<return>", and it
will match and launch "LISpWorks Personal".
I decided I wanted to add something like this (only better :) to Slime,
to go alongside the existing completion algorithm. It can't really be a
replacement as they are good at different things. The existing one is
good for incrementally typing and completing a symbol. The fuzzy one is
good for typing a short version of the symbol, running the completer,
and then picking the right result, which hopefully scored at or near the
top.
While I've attached a patch, this is more a request for comments than a
request to commit the code. As I'll discuss, the Emacs interface is
incredibly lacking, mostly on account of this being my first time using
elisp for anything but configuration. It's very ugly. Also, the
completion core code in Swank should be cleaned up - it still looks
somewhat hacky. Finally, everything needs documentation.
The elisp code has some chunks from isearch.el. Since they are both
GPL, I figured this is okay. Besides, it will probably change anyway.
:)
----------------------------------------------------------------------
The low level core of the algorithm are implemented in Swank, just like
the old completer. The interface looks very similar:
; SLIME 2004-06-10
CL-USER> (setq *print-pretty* t)
T
CL-USER> (swank::completions "m-v-" "CL-USER")
(("multiple-value-bind"
"multiple-value-call"
"multiple-value-list"
"multiple-value-prog1"
"multiple-value-setq"
"multiple-values-limit")
"multiple-value-")
CL-USER> (swank::fuzzy-completions "mvb" "CL-USER")
(("multiple-value-bind" 26.588236 ((0 "m") (9 "v") (15 "b")))
("most-negative-double-float" 12.416667 ((0 "m") (11 "v") (17 "b")))
("most-positive-double-float" 12.416667 ((0 "m") (11 "v") (17 "b")))
("named-variable" 10.833333 ((2 "m") (6 "v") (11 "b")))
("*compile-verbose*" 10.666667 ((3 "m") (9 "v") (12 "b")))
("environment-variable" 10.555555 ((7 "m") (12 "v") (17 "b")))
("remove-symbol-profiler" 3.5 ((2 "m") (4 "v") (10 "b"))))
The return value is obviously a bit more complicated. :) The fields are
(completion score chunks), where "chunks" are a description of where the
completion matched.
There's a convenience function in Swank that is not used by the Emacs
interface to print this information in a human readable form. I used
this to tune the scoring algorithm. This shows a little more clearly
how the algorithm matches:
CL-USER> (swank::format-fuzzy-completions
(swank::fuzzy-completions "mvb" "CL-USER"))
Multiple-Value-Bind score 26.59 ((0 m) (9 v) (15 b))
Most-negatiVe-douBle-float score 12.42 ((0 m) (11 v) (17 b))
Most-positiVe-douBle-float score 12.42 ((0 m) (11 v) (17 b))
naMed-VariaBle score 10.83 ((2 m) (6 v) (11 b))
*coMpile-VerBose* score 10.67 ((3 m) (9 v) (12 b))
environMent-VariaBle score 10.56 ((7 m) (12 v) (17 b))
reMoVe-symBol-profiler score 3.50 ((2 m) (4 v) (10 b))
NIL
Here are some more examples, which might show why I think something like
this can be useful. (There is an optional third argument to
swank::fuzzy-completions, limit. This limits the number of results,
which is important for this completer since completing, say, "a" will
match many, many symbols. This isn't currently used from Emacs
however.)
CL-USER> (swank::format-fuzzy-completions
(swank::fuzzy-completions "stdout" "CL-USER" 5))
*STanDard-OUtpuT* score 34.83 ((1 st) (5 d) (10 ou) (15 t))
moST-negative-DOUble-floaT score 22.48 ((2 st) (14 dou) (25 t))
moST-positive-DOUble-floaT score 22.48 ((2 st) (14 dou) (25 t))
leaST-positive-DOUble-floaT score 22.45 ((3 st) (15 dou) (26 t))
leaST-negative-DOUble-floaT score 22.45 ((3 st) (15 dou) (26 t))
NIL
CL-USER> (swank::format-fuzzy-completions
(swank::fuzzy-completions "prp" "CL-USER" 5))
*PRint-Pretty* score 23.83 ((1 pr) (7 p))
PRint-Profile-list score 23.62 ((0 pr) (6 p))
*PRint-Pprint-dispatch* score 23.48 ((1 pr) (7 p))
*step-PRint-Pretty* score 20.59 ((6 pr) (12 p))
*trace-PRint-Pretty* score 20.56 ((7 pr) (13 p))
NIL
CL-USER> (swank::format-fuzzy-completions
(swank::fuzzy-completions "norm-df" "CL-USER" 5))
least-positive-NORMalized-Double-Float score 32.31 ((15 norm) ...)
least-negative-NORMalized-Double-Float score 32.31 ((15 norm) ...)
NIL
CL-USER> (swank::format-fuzzy-completions
(swank::fuzzy-completions "udc" "CL-USER" 1))
Update-instance-for-Different-Class score 26.30 ((0 u) (20 d) (30 c))
NIL
CL-USER> (swank::format-fuzzy-completions
(swank::fuzzy-completions "urc" "CL-USER" 1))
Update-instance-for-Redefined-Class score 26.30 ((0 u) (20 r) (30 c))
NIL
Despite being expensive (it tries all combinations of matches up to a
relatively high cutoff per symbol to maximize the score) and not
optimized at all, the completion speed doesn't seem bad at all on
compiled Lisps on my 500mhz Powerbook. I haven't tried it on
interpreted Lisps, but I imagine it wouldn't be too fun.
There are some scoring configuration parameters in swank.lisp that are
mostly self-explanitory. Adjust to fit your own symbol naming schemes;
these seemed to be the five-minute opinion of #lisp. Some way to set
these from Emacs would probably be nice in the future.
(defparameter *fuzzy-completion-symbol-prefixes* "*+-%&?<")
(defparameter *fuzzy-completion-symbol-suffixes* "*+->")
(defparameter *fuzzy-completion-word-separators* "-/.")
The scoring algorithm is currently completely static. It would probably
be a nifty project to implement some machine learning on it.
----------------------------------------------------------------------
Now, the Emacs interface. Well, it kind of sucks. I bound
slime-fuzzy-complete-symbol to C-c M-i in the Slime map. The problem is
that since the first letters of the short form aren't necessarily the
first letters of the matches, the existing Emacs completion system will
fail miserably with this algorithm.
What I did was, if there was more than one completion, pop up a window
with the results (formatted nicely like above, but with a bold face
instead of upcasing). Point starts on the highest scoring result, and
the result is immediately placed into the Lisp buffer in place of the
short form. Then the user can hit 'n' and 'p' to navigate the list of
completions. As they do, the replacement is updated. To pick a
completion and keep it, hit Return. To abort and revert to the short
form, hit almost anything else. It is a recursive edit, like isearch,
so doing anything else in Emacs will abort the completion. It's also
implemented very poorly.
I don't really like this, but I'm not sure what a better option is. If
you have the completion buffer come up normally, it will have embedded
state from the Lisp source buffer. If the Lisp source buffer changes
before a completion is picked, it may modify the wrong position. And
again, it can't really work like the (stateless) normal completion.
----------------------------------------------------------------------
So anyway, I'd appreciate it if people could try it out. If anyone has
good interface ideas (or even better, would implement them :) I'd like
to hear them, since I'm not so happy with what I've got.
Thanks,
-bcd
--
*** Brian Downing <bdowning at lavos dot net>
-------------- next part --------------
Index: slime.el
===================================================================
RCS file: /project/slime/cvsroot/slime/slime.el,v
retrieving revision 1.312
diff -u -r1.312 slime.el
--- slime.el 10 Jun 2004 17:34:07 -0000 1.312
+++ slime.el 11 Jun 2004 08:05:00 -0000
@@ -344,6 +344,7 @@
Programming aids:
\\[slime-complete-symbol] - Complete the Lisp symbol at point. (Also M-TAB.)
+\\[slime-fuzzy-complete-symbol] - Fuzzily complete the Lisp symbol at point. (NEEDS INTERFACE WORK)
\\[slime-macroexpand-1] - Macroexpand once.
\\[slime-macroexpand-all] - Macroexpand all.
@@ -474,6 +475,7 @@
;; Editing/navigating
("\M-\C-i" slime-complete-symbol :inferior t)
("\C-i" slime-complete-symbol :prefixed t :inferior t)
+ ("\M-i" slime-fuzzy-complete-symbol :prefixed t :inferior t)
("\M-." slime-edit-definition :inferior t :sldb t)
("\M-," slime-pop-find-definition-stack :inferior t :sldb t)
("\C-q" slime-close-parens-at-point :prefixed t :inferior t)
@@ -566,6 +568,7 @@
[ "Edit Definition..." slime-edit-definition ,C ]
[ "Return From Definition" slime-pop-find-definition-stack ,C ]
[ "Complete Symbol" slime-complete-symbol ,C ]
+ [ "Fuzzy Complete Symbol" slime-fuzzy-complete-symbol ,C ]
[ "Show REPL" slime-switch-to-output-buffer ,C ]
"--"
("Evaluation"
@@ -3795,6 +3798,201 @@
(slime-eval `(swank:simple-completions ,prefix
,(or (slime-find-buffer-package)
(slime-buffer-package)))))
+
+
+;;; Fuzzy completion (FIX ME, PLEASE)
+
+(defvar slime-fuzzy-completion-minor-mode nil)
+(make-variable-buffer-local 'slime-fuzzy-completion-minor-mode)
+
+(define-derived-mode slime-fuzzy-completions-mode
+ fundamental-mode "Fuzzy Completions"
+ "Bleh."
+ )
+
+(or (assq 'slime-fuzzy-completion-minor-mode minor-mode-alist)
+ (nconc minor-mode-alist
+ (list '(slime-fuzzy-completion-minor-mode
+ slime-fuzzy-completion-minor-mode))))
+
+(defvar slime-fuzzy-completion-mode-map nil "It's a keymap!")
+(setq slime-fuzzy-completion-mode-map
+ (let* ((i 0)
+ (map (make-keymap)))
+
+ (define-key map [t] 'slime-fuzzy-completion-abort)
+
+ ;; Single-byte printing chars are undefined by default.
+ (setq i ?\ )
+ (while (< i 256)
+ (define-key map (vector i) 'undefined)
+ (setq i (1+ i)))
+
+ (define-key map "\C-g" 'slime-fuzzy-completion-abort)
+ (define-key map "q" 'slime-fuzzy-completion-abort)
+ (define-key map "\r" 'slime-fuzzy-completion-exit)
+ (define-key map [return] 'slime-fuzzy-completion-exit)
+ (define-key map "\e" 'slime-fuzzy-completion-abort)
+ (define-key map [escape] 'slime-fuzzy-completion-abort)
+
+ (define-key map "n" 'slime-fuzzy-completion-next)
+ (define-key map "p" 'slime-fuzzy-completion-prev)
+
+ ;; Pass frame events transparently so they won't exit the search.
+ ;; In particular, if we have more than one display open, then a
+ ;; switch-frame might be generated by someone typing at another keyboard.
+ (define-key map [switch-frame] nil)
+ (define-key map [delete-frame] nil)
+ (define-key map [iconify-frame] nil)
+ (define-key map [make-frame-visible] nil)
+ (define-key map [mouse-movement] nil)
+
+ map))
+
+(defun slime-fuzzy-completions (prefix &optional default-package)
+ (let ((prefix (etypecase prefix
+ (symbol (symbol-name prefix))
+ (string prefix))))
+ (slime-eval `(swank:fuzzy-completions ,prefix
+ ,(or default-package
+ (slime-find-buffer-package)
+ (slime-buffer-package))))))
+
+(defun* slime-fuzzy-complete-symbol ()
+ (interactive)
+ (when (save-excursion (re-search-backward "\"[^ \t\n]+\\=" nil t))
+ (return-from slime-fuzzy-complete-symbol
+ (comint-dynamic-complete-as-filename)))
+ (let* ((end (move-marker (make-marker) (slime-symbol-end-pos)))
+ (beg (move-marker (make-marker) (slime-symbol-start-pos)))
+ (prefix (buffer-substring-no-properties beg end))
+ (completion-set (slime-fuzzy-completions prefix)))
+ (if (null completion-set)
+ (progn (slime-minibuffer-respecting-message
+ "Can't find completion for \"%s\"" prefix)
+ (ding)
+ (slime-complete-restore-window-configuration))
+ (goto-char end)
+ (cond ((= (length completion-set) 1)
+ (insert-and-inherit (caar completion-set))
+ (delete-region beg end)
+ (goto-char (+ beg (length (caar completion-set))))
+ (slime-minibuffer-respecting-message "Sole completion"))
+ ;; Incomplete
+ (t
+ (slime-minibuffer-respecting-message "Complete but not unique")
+ (slime-fuzzy-completion-minor-mode completion-set beg end)))
+ )))
+
+(defvar slime-fuzzy-completion-buffer nil)
+(defvar slime-fuzzy-completion-window-configuration nil)
+(defvar slime-fuzzy-completion-first nil)
+(defvar slime-fuzzy-completion-start nil)
+(defvar slime-fuzzy-completion-end nil)
+(defvar slime-fuzzy-completion-original nil)
+
+(defun get-slime-fuzzy-completions-buffer ()
+ (get-buffer-create "*Fuzzy Completions*"))
+
+(defun slime-fuzzy-completions-explanation ()
+ (insert "Craptastical interface! Please FIX ME!
+Hit n and p to select a completion, RET to keep it, and q (or just
+about anything else) to abort.\n\n"))
+
+(defun slime-fuzzy-insert-completion-choice (completion max-length)
+ (let ((start (point))
+ (symbol (first completion))
+ (score (second completion))
+ (chunks (third completion)))
+ (insert symbol)
+ (let ((end (point)))
+ (dolist (chunk chunks)
+ (put-text-property (+ start (first chunk))
+ (+ start (first chunk)
+ (length (second chunk)))
+ 'face 'bold))
+ (dotimes (i (- max-length (- end start)))
+ (insert " "))
+ (insert (format " %8.2f" score))
+ (insert "\n")
+ (put-text-property start (point) 'completion completion)
+ )))
+
+(defun slime-fuzzy-completion-insert (text)
+ (with-current-buffer slime-fuzzy-completion-buffer
+ (goto-char slime-fuzzy-completion-end)
+ (insert-and-inherit text)
+ (delete-region slime-fuzzy-completion-start slime-fuzzy-completion-end)
+ (setq slime-fuzzy-completion-end (+ slime-fuzzy-completion-start
+ (length text)))
+ (goto-char slime-fuzzy-completion-end)))
+
+(defun slime-fuzzy-completion-minor-mode (completions start end)
+ (setq slime-fuzzy-completion-minor-mode " Fuzzy")
+ (setq slime-fuzzy-completion-start start)
+ (setq slime-fuzzy-completion-end end)
+ (setq slime-fuzzy-completion-original (buffer-substring start end))
+ (setq slime-fuzzy-completion-buffer (current-buffer))
+ (setq slime-fuzzy-completion-window-configuration (current-window-configuration))
+ (add-hook 'mouse-leave-buffer-hook 'slime-fuzzy-completion-exit)
+ (with-current-buffer (get-slime-fuzzy-completions-buffer)
+ (erase-buffer)
+ (slime-fuzzy-completions-mode)
+ (slime-fuzzy-completions-explanation)
+ (let ((max-length 12))
+ (dolist (completion completions)
+ (setf max-length (max max-length (length (first completion)))))
+ (insert "Completion:")
+ (dotimes (i (- max-length 10)) (insert " "))
+ (insert "Score:\n")
+ (dotimes (i max-length) (insert "-"))
+ (insert " --------\n")
+ (setq slime-fuzzy-completions-first (point))
+ (dolist (completion completions)
+ (slime-fuzzy-insert-completion-choice completion max-length)))
+ (slime-fuzzy-completion-insert (caar completions))
+ (goto-char slime-fuzzy-completions-first)
+ (pop-to-buffer (current-buffer))
+ (setq overriding-local-map slime-fuzzy-completion-mode-map)
+ )
+ (recursive-edit))
+
+(defun slime-fuzzy-completion-next ()
+ (interactive)
+ (goto-char
+ (next-single-char-property-change (point) 'completion))
+ (slime-fuzzy-completion-insert
+ (first (get-text-property (point) 'completion))))
+
+(defun slime-fuzzy-completion-prev ()
+ (interactive)
+ (goto-char (previous-single-char-property-change
+ (point) 'completion
+ nil slime-fuzzy-completions-first))
+ (slime-fuzzy-completion-insert
+ (first (get-text-property (point) 'completion))))
+
+(defun slime-fuzzy-completion-abort ()
+ (interactive)
+ (slime-fuzzy-completion-insert slime-fuzzy-completion-original)
+ (slime-fuzzy-completion-done))
+
+(defun slime-fuzzy-completion-exit ()
+ (interactive)
+ (with-current-buffer (get-slime-fuzzy-completions-buffer)
+ (slime-fuzzy-completion-insert
+ (first (get-text-property (point) 'completion))))
+ (slime-fuzzy-completion-done))
+
+(defun slime-fuzzy-completion-done ()
+ (remove-hook 'mouse-leave-buffer-hook 'slime-fuzzy-completion-exit)
+ (set-buffer slime-fuzzy-completion-buffer)
+ (setq overriding-local-map nil)
+ (setq slime-fuzzy-completion-minor-mode nil)
+ (set-window-configuration slime-fuzzy-completion-window-configuration)
+ (setq slime-fuzzy-completion-window-configuration nil)
+ (setq slime-fuzzy-completion-buffer nil)
+ (exit-recursive-edit))
;;; Interpreting Elisp symbols as CL symbols (package qualifiers)
Index: swank.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank.lisp,v
retrieving revision 1.189
diff -u -r1.189 swank.lisp
--- swank.lisp 10 Jun 2004 17:51:33 -0000 1.189
+++ swank.lisp 11 Jun 2004 08:05:02 -0000
@@ -1415,14 +1415,16 @@
(let ((package (carefully-find-package package-name default-package-name)))
(values name package-name package internal-p))))
+(defun format-completion-result (string internal-p package-name)
+ (let ((prefix (cond (internal-p (format nil "~A::" package-name))
+ (package-name (format nil "~A:" package-name))
+ (t ""))))
+ (values (concatenate 'string prefix string)
+ (length prefix))))
+
(defun format-completion-set (strings internal-p package-name)
(mapcar (lambda (string)
- (cond (internal-p
- (format nil "~A::~A" package-name string))
- (package-name
- (format nil "~A:~A" package-name string))
- (t
- (format nil "~A" string))))
+ (format-completion-result string internal-p package-name))
(sort strings #'string<)))
(defun output-case-converter (input)
@@ -1481,6 +1483,72 @@
(nconc (mapcar #'symbol-name symbols) packs))))
(format-completion-set strings internal-p package-name))))
+(defun fuzzy-find-matching-symbols (string package external)
+ (let ((completions '())
+ (converter (output-case-converter string)))
+ (flet ((symbol-match (symbol)
+ (and (or (not external)
+ (symbol-external-p symbol package))
+ (compute-highest-scoring-completion
+ string (funcall converter (symbol-name symbol)) #'char=))))
+ (do-symbols (symbol package)
+ (multiple-value-bind (result score) (symbol-match symbol)
+ (when result
+ (push (list symbol score result) completions)))))
+ (remove-duplicates completions :key #'first)))
+
+(defun fuzzy-find-matching-packages (name)
+ (let ((converter (output-case-converter name)))
+ (loop for package in (list-all-packages)
+ for package-name = (concatenate 'string
+ (funcall converter
+ (package-name package))
+ ":")
+ for (result score) = (multiple-value-list
+ (compute-highest-scoring-completion
+ name package-name #'char=))
+ if result collect (list package-name score result))))
+
+(defun fuzzy-completion-set (string default-package-name &optional limit)
+ (declare (type simple-base-string string))
+ (multiple-value-bind (name package-name package internal-p)
+ (parse-completion-arguments string default-package-name)
+ (let* ((symbols (and package
+ (fuzzy-find-matching-symbols name
+ package
+ (and (not internal-p)
+ package-name))))
+ (packs (and (not package-name)
+ (fuzzy-find-matching-packages name)))
+ (converter (output-case-converter name))
+ (results
+ (sort (mapcar
+ #'(lambda (result)
+ (destructuring-bind (symbol-or-name score chunks) result
+ (multiple-value-bind (name added-length)
+ (format-completion-result
+ (funcall converter
+ (if (symbolp symbol-or-name)
+ (symbol-name symbol-or-name)
+ symbol-or-name))
+ internal-p package-name)
+ (list name score
+ (mapcar
+ #'(lambda (chunk)
+ ;; fix up chunk positions to
+ ;; account for possible added
+ ;; package identifier
+ (list (+ added-length (first chunk))
+ (second chunk)))
+ chunks)))))
+ (nconc symbols packs))
+ #'> :key #'second)))
+ (when (and limit
+ (> limit 0)
+ (< limit (length results)))
+ (setf (cdr (nthcdr (1- limit) results)) nil))
+ results)))
+
(defslimefun completions (string default-package-name)
"Return a list of completions for a symbol designator STRING.
@@ -1509,6 +1577,10 @@
#'prefix-match-p)))
(list completion-set (longest-common-prefix completion-set))))
+(defslimefun fuzzy-completions (string default-package-name &optional limit)
+ "FIXME"
+ (fuzzy-completion-set string default-package-name limit))
+
(defun tokenize-symbol-designator (string)
"Parse STRING as a symbol designator.
Return three values:
@@ -1530,6 +1602,147 @@
(declare (ignore _))
(eq status :external)))
+;;; Fuzzy completion core
+
+(defparameter *fuzzy-recursion-soft-limit* 30)
+
+(defun recursively-compute-most-completions
+ (short full test
+ short-index initial-full-index
+ chunks current-chunk current-chunk-pos
+ recurse-p)
+ (declare (special *all-chunks*))
+ (flet ((short-cur ()
+ (if (= short-index (length short))
+ nil
+ (aref short short-index)))
+ (add-to-chunk (char pos)
+ (unless current-chunk
+ (setf current-chunk-pos pos))
+ (push char current-chunk))
+ (collect-chunk ()
+ (when current-chunk
+ (push (list current-chunk-pos
+ (coerce (reverse current-chunk) 'string)) chunks)
+ (setf current-chunk nil
+ current-chunk-pos nil))))
+ ;; If there's an outstanding chunk coming in collect it. Since
+ ;; we're recursively called on skipping an input character, the
+ ;; chunk can't possibly continue on.
+ (when current-chunk (collect-chunk))
+ (do ((pos initial-full-index (1+ pos)))
+ ((= pos (length full)))
+ (let ((cur-char (aref full pos)))
+ (if (and (short-cur)
+ (funcall test cur-char (short-cur)))
+ (progn
+ (when recurse-p
+ ;; Try other possibilities, limiting insanely deep
+ ;; recursion somewhat.
+ (recursively-compute-most-completions
+ short full test short-index (1+ pos)
+ chunks current-chunk current-chunk-pos
+ (not (> (length *all-chunks*)
+ *fuzzy-recursion-soft-limit*))))
+ (incf short-index)
+ (add-to-chunk cur-char pos))
+ (collect-chunk))))
+ (collect-chunk)
+ ;; If we've exhausted the short characters we have a match.
+ (if (short-cur)
+ nil
+ (let ((rev-chunks (reverse chunks)))
+ (push rev-chunks *all-chunks*)
+ rev-chunks))))
+
+(defun compute-most-completions (short full test)
+ (let ((*all-chunks* nil))
+ (declare (special *all-chunks*))
+ (recursively-compute-most-completions short full test 0 0 nil nil nil t)
+ *all-chunks*))
+
+(defun compute-completion (short full test)
+ (let ((*all-chunks* nil))
+ (declare (special *all-chunks*))
+ (recursively-compute-most-completions short full test 0 0 nil nil nil nil)
+ *all-chunks*))
+
+(defparameter *fuzzy-completion-symbol-prefixes* "*+-%&?<")
+(defparameter *fuzzy-completion-symbol-suffixes* "*+->")
+(defparameter *fuzzy-completion-word-separators* "-/.")
+
+(defun score-completion (completion short full)
+ (flet ((score-chunk (chunk)
+ (let ((initial-pos (first chunk))
+ (str (second chunk)))
+ (labels ((at-beginning-p (pos)
+ (= pos 0))
+ (after-prefix-p (pos)
+ (and (= pos 1)
+ (find (aref full 0)
+ *fuzzy-completion-symbol-prefixes*)))
+ (word-separator-p (pos)
+ (find (aref full pos)
+ *fuzzy-completion-word-separators*))
+ (after-word-separator-p (pos)
+ (find (aref full (1- pos))
+ *fuzzy-completion-word-separators*))
+ (at-end-p (pos)
+ (= pos (1- (length full))))
+ (before-suffix-p (pos)
+ (and (= pos (- (length full) 2))
+ (find (aref full (1- (length full)))
+ *fuzzy-completion-symbol-suffixes*)))
+ (score-or-half-previous (base-score pos chunk-pos)
+ (if (zerop chunk-pos)
+ base-score
+ (max base-score
+ (/ (score-char (1- pos) (1- chunk-pos)) 2))))
+ (score-char (pos chunk-pos)
+ (score-or-half-previous
+ (cond ((at-beginning-p pos) 10)
+ ((after-prefix-p pos) 10)
+ ((word-separator-p pos) 1)
+ ((after-word-separator-p pos) 8)
+ ((at-end-p pos) 6)
+ ((before-suffix-p pos) 6)
+ (t 1))
+ pos chunk-pos)))
+ (loop for chunk-pos below (length str)
+ for pos from initial-pos
+ summing (score-char pos chunk-pos))))))
+ (let* ((chunk-scores (mapcar #'score-chunk completion))
+ (length-score
+ (/ 10 (coerce (1+ (- (length full) (length short)))
+ 'single-float))))
+ (values
+ (+ (apply #'+ chunk-scores) length-score)
+ (list (mapcar #'list chunk-scores completion) length-score)))))
+
+(defun compute-highest-scoring-completion (short full test)
+ (let* ((scored-results
+ (mapcar #'(lambda (result)
+ (cons (score-completion result short full) result))
+ (compute-most-completions short full test)))
+ (winner (first (sort scored-results #'> :key #'first))))
+ (values (rest winner) (first winner))))
+
+(defun highlight-completion (completion full)
+ (let ((highlit (string-downcase full)))
+ (dolist (chunk completion)
+ (setf highlit (string-upcase highlit
+ :start (first chunk)
+ :end (+ (first chunk)
+ (length (second chunk))))))
+ highlit))
+
+(defun format-fuzzy-completions (winners)
+ (let ((max-len
+ (loop for winner in winners maximizing (length (first winner)))))
+ (loop for (sym score result) in winners do
+ (format t "~&~VA score ~8,2F ~A"
+ max-len (highlight-completion result sym) score result))))
+
;;;;; Subword-word matching
More information about the slime-devel
mailing list