;;; swank-fuzzy.lisp --- fuzzy symbol completion ;; ;; Authors: Brian Downing ;; Tobias C. Rittweiler ;; and others ;; ;; License: Public Domain ;; (in-package :swank) (eval-when (:compile-toplevel :load-toplevel :execute) (swank-require :swank-util) (swank-require :swank-c-p-c)) (defvar *fuzzy-duplicate-symbol-filter* :nearest-package "Specifies how fuzzy-matching handles \"duplicate\" symbols. Possible values are :NEAREST-PACKAGE, :HOME-PACKAGE, :ALL, or a custom function. See Fuzzy Completion in the manual for details.") (export '*fuzzy-duplicate-symbol-filter*) ;;; For nomenclature of the fuzzy completion section, please read ;;; through the following docstring. (defslimefun fuzzy-completions (string default-package-name &key limit time-limit-in-msec) "Returns a list of two values: An (optionally limited to LIMIT best results) list of fuzzy completions for a symbol designator STRING. The list will be sorted by score, most likely match first. A flag that indicates whether or not TIME-LIMIT-IN-MSEC has been exhausted during computation. If that parameter's value is NIL or 0, no time limit is assumed. The main result is a list of completion objects, where a completion object is: (COMPLETED-STRING SCORE (&rest CHUNKS) CLASSIFICATION-STRING) where a CHUNK is a description of a matched substring: (OFFSET SUBSTRING) and FLAGS is short string describing properties of the symbol (see SYMBOL-CLASSIFICATION-STRING). E.g., completing \"mvb\" in a package that uses COMMON-LISP would return something like: ((\"multiple-value-bind\" 26.588236 ((0 \"m\") (9 \"v\") (15 \"b\")) (:FBOUNDP :MACRO)) ...) If STRING is package qualified the result list will also be qualified. If string is non-qualified the result strings are also not qualified and are considered relative to DEFAULT-PACKAGE-NAME. Which symbols are candidates for matching depends on the symbol designator's format. The cases are as follows: FOO - Symbols accessible in the buffer package. PKG:FOO - Symbols external in package PKG. PKG::FOO - Symbols accessible in package PKG." ;; For Emacs we allow both NIL and 0 as value of TIME-LIMIT-IN-MSEC ;; to denote an infinite time limit. Internally, we only use NIL for ;; that purpose, to be able to distinguish between "no time limit ;; alltogether" and "current time limit already exhausted." So we've ;; got to canonicalize its value at first: (let* ((no-time-limit-p (or (not time-limit-in-msec) (zerop time-limit-in-msec))) (time-limit (if no-time-limit-p nil time-limit-in-msec))) (multiple-value-bind (completion-set interrupted-p) (fuzzy-completion-set string default-package-name :limit limit :time-limit-in-msec time-limit) ;; We may send this as elisp [] arrays to spare a coerce here, ;; but then the network serialization were slower by handling arrays. ;; Instead we limit the number of completions that is transferred ;; (the limit is set from Emacs.) (list (coerce completion-set 'list) interrupted-p)))) ;;; A Fuzzy Matching -- Not to be confused with a fuzzy completion ;;; object that will be sent back to Emacs, as described above. (defstruct (fuzzy-matching (:conc-name fuzzy-matching.) (:predicate fuzzy-matching-p) (:constructor make-fuzzy-matching (symbol package-name score package-chunks symbol-chunks &key (symbol-p t)))) symbol ; The symbol that has been found to match. symbol-p ; To deffirentiate between completeing ; package: and package:nil package-name ; The name of the package where SYMBOL was found in. ; (This is not necessarily the same as the home-package ; of SYMBOL, because the SYMBOL can be internal to ; lots of packages; also think of package nicknames.) score ; The higher the better SYMBOL is a match. package-chunks ; Chunks pertaining to the package identifier of SYMBOL. symbol-chunks) ; Chunks pertaining to SYMBOL's name. (defun %fuzzy-extract-matching-info (fuzzy-matching user-input-string) (multiple-value-bind (_ user-package-name __ input-internal-p) (parse-completion-arguments user-input-string nil) (declare (ignore _ __)) (with-struct (fuzzy-matching. score symbol package-name package-chunks symbol-chunks symbol-p) fuzzy-matching (let (symbol-name real-package-name internal-p) (cond (symbol-p ; symbol fuzzy matching? (setf symbol-name (symbol-name symbol)) (setf internal-p input-internal-p) (setf real-package-name (cond ((keywordp symbol) "") ((not user-package-name) nil) (t package-name)))) (t ; package fuzzy matching? (setf symbol-name "") (setf real-package-name package-name) ;; If no explicit package name was given by the user ;; (e.g. input was "asdf"), we want to append only ;; one colon ":" to the package names. (setf internal-p (if user-package-name input-internal-p nil)))) (values symbol-name real-package-name (if user-package-name internal-p nil) (completion-output-symbol-converter user-input-string) (completion-output-package-converter user-input-string)))))) (defun fuzzy-format-matching (fuzzy-matching user-input-string) "Returns the completion (\"foo:bar\") that's represented by FUZZY-MATCHING." (multiple-value-bind (symbol-name package-name internal-p symbol-converter package-converter) (%fuzzy-extract-matching-info fuzzy-matching user-input-string) (setq symbol-name (and symbol-name (funcall symbol-converter symbol-name))) (setq package-name (and package-name (funcall package-converter package-name))) (let ((result (untokenize-symbol package-name internal-p symbol-name))) ;; We return the length of the possibly added prefix as second value. (values result (search symbol-name result))))) (defun fuzzy-convert-matching-for-emacs (fuzzy-matching user-input-string) "Converts a result from the fuzzy completion core into something that emacs is expecting. Converts symbols to strings, fixes case issues, and adds information (as a string) describing if the symbol is bound, fbound, a class, a macro, a generic-function, a special-operator, or a package." (with-struct (fuzzy-matching. symbol score package-chunks symbol-chunks symbol-p) fuzzy-matching (multiple-value-bind (name added-length) (fuzzy-format-matching fuzzy-matching user-input-string) (list name (format nil "~,2f" score) (append package-chunks (mapcar (lambda (chunk) ;; Fix up chunk positions to account for possible ;; added package identifier. (let ((offset (first chunk)) (string (second chunk))) (list (+ added-length offset) string))) symbol-chunks)) (if symbol-p (symbol-classification-string symbol) "-------p"))))) (defun fuzzy-completion-set (string default-package-name &key limit time-limit-in-msec) "Returns two values: an array of completion objects, sorted by their score, that is how well they are a match for STRING according to the fuzzy completion algorithm. If LIMIT is set, only the top LIMIT results will be returned. Additionally, a flag is returned that indicates whether or not TIME-LIMIT-IN-MSEC was exhausted." (check-type limit (or null (integer 0 #.(1- most-positive-fixnum)))) (check-type time-limit-in-msec (or null (integer 0 #.(1- most-positive-fixnum)))) (multiple-value-bind (matchings interrupted-p) (fuzzy-generate-matchings string default-package-name time-limit-in-msec) (when (and limit (> limit 0) (< limit (length matchings))) (if (array-has-fill-pointer-p matchings) (setf (fill-pointer matchings) limit) (setf matchings (make-array limit :displaced-to matchings)))) (map-into matchings #'(lambda (m) (fuzzy-convert-matching-for-emacs m string)) matchings) (values matchings interrupted-p))) (defun fuzzy-generate-matchings (string default-package-name time-limit-in-msec) "Does all the hard work for FUZZY-COMPLETION-SET. If TIME-LIMIT-IN-MSEC is NIL, an infinite time limit is assumed." (multiple-value-bind (parsed-symbol-name parsed-package-name package internal-p) (parse-completion-arguments string default-package-name) (flet ((fix-up (matchings parent-package-matching) ;; The components of each matching in MATCHINGS have been computed ;; relatively to PARENT-PACKAGE-MATCHING. Make them absolute. (let* ((p parent-package-matching) (p.name (fuzzy-matching.package-name p)) (p.score (fuzzy-matching.score p)) (p.chunks (fuzzy-matching.package-chunks p))) (map-into matchings (lambda (m) (let ((m.score (fuzzy-matching.score m))) (setf (fuzzy-matching.package-name m) p.name) (setf (fuzzy-matching.package-chunks m) p.chunks) (setf (fuzzy-matching.score m) (if (equal parsed-symbol-name "") ;; Make package matchings be sorted before all ;; the relative symbol matchings while preserving ;; over all orderness. (/ p.score 100) (+ p.score m.score))) m)) matchings))) (find-symbols (designator package time-limit &optional filter) (fuzzy-find-matching-symbols designator package :time-limit-in-msec time-limit :external-only (not internal-p) :filter (or filter #'identity))) (find-packages (designator time-limit) (fuzzy-find-matching-packages designator :time-limit-in-msec time-limit)) (maybe-find-local-package (name) (or (find-locally-nicknamed-package name *buffer-package*) (find-package name)))) (let ((time-limit time-limit-in-msec) (symbols) (packages) (results) (dedup-table (make-hash-table :test #'equal))) (cond ((not parsed-package-name) ; E.g. STRING = "asd" ;; We don't know if user is searching for a package or a symbol ;; within his current package. So we try to find either. (setf (values packages time-limit) (find-packages parsed-symbol-name time-limit)) (setf (values symbols time-limit) (find-symbols parsed-symbol-name package time-limit))) ((string= parsed-package-name "") ; E.g. STRING = ":" or ":foo" (setf (values symbols time-limit) (find-symbols parsed-symbol-name package time-limit))) (t ; E.g. STRING = "asd:" or "asd:foo" ;; Find fuzzy matchings of the denoted package identifier part. ;; After that, find matchings for the denoted symbol identifier ;; relative to all the packages found. (multiple-value-bind (symbol-packages rest-time-limit) (find-packages parsed-package-name time-limit-in-msec) ;; We want to traverse the found packages in the order of ;; their score, since those with higher score presumably ;; represent better choices. (This is important because some ;; packages may never be looked at if time limit exhausts ;; during traversal.) (setf symbol-packages (sort symbol-packages #'fuzzy-matching-greaterp)) (loop for package-matching across symbol-packages for package = (maybe-find-local-package (fuzzy-matching.package-name package-matching)) while (or (not time-limit) (> rest-time-limit 0)) do (multiple-value-bind (matchings remaining-time) ;; The duplication filter removes all those symbols ;; which are present in more than one package ;; match. See *FUZZY-DUPLICATE-SYMBOL-FILTER* (find-symbols parsed-symbol-name package rest-time-limit (%make-duplicate-symbols-filter package-matching symbol-packages dedup-table)) (setf matchings (fix-up matchings package-matching)) (setf symbols (concatenate 'vector symbols matchings)) (setf rest-time-limit remaining-time) (let ((guessed-sort-duration (%guess-sort-duration (length symbols)))) (when (and rest-time-limit (<= rest-time-limit guessed-sort-duration)) (decf rest-time-limit guessed-sort-duration) (loop-finish)))) finally (setf time-limit rest-time-limit) (when (equal parsed-symbol-name "") ; E.g. STRING = "asd:" (setf packages symbol-packages)))))) ;; Sort by score; thing with equal score, sort alphabetically. ;; (Especially useful when PARSED-SYMBOL-NAME is empty, and all ;; possible completions are to be returned.) (setf results (concatenate 'vector symbols packages)) (setf results (sort results #'fuzzy-matching-greaterp)) (values results (and time-limit (<= time-limit 0))))))) (defun %guess-sort-duration (length) ;; These numbers are pretty much arbitrary, except that they're ;; vaguely correct on my machine with SBCL. Yes, this is an ugly ;; kludge, but it's better than before (where this didn't exist at ;; all, which essentially meant, that this was taken to be 0.) (if (zerop length) 0 (let ((comparasions (* 3.8 (* length (log length 2))))) (* 1000 (* comparasions (expt 10 -7)))))) ; msecs (defun %make-duplicate-symbols-filter (current-package-matching fuzzy-package-matchings dedup-table) ;; Returns a filter function based on *FUZZY-DUPLICATE-SYMBOL-FILTER*. (case *fuzzy-duplicate-symbol-filter* (:home-package ;; Return a filter function that takes a symbol, and which returns T ;; if and only if /no/ matching in FUZZY-PACKAGE-MATCHINGS represents ;; the home-package of the symbol passed. (let ((packages (mapcar #'(lambda (m) (find-package (fuzzy-matching.package-name m))) (remove current-package-matching (coerce fuzzy-package-matchings 'list))))) #'(lambda (symbol) (not (member (symbol-package symbol) packages))))) (:nearest-package ;; Keep only the first occurence of the symbol. #'(lambda (symbol) (unless (gethash (symbol-name symbol) dedup-table) (setf (gethash (symbol-name symbol) dedup-table) t)))) (:all ;; No filter #'identity) (t (typecase *fuzzy-duplicate-symbol-filter* (function ;; Custom filter (funcall *fuzzy-duplicate-symbol-filter* (fuzzy-matching.package-name current-package-matching) (map 'list #'fuzzy-matching.package-name fuzzy-package-matchings) dedup-table)) (t ;; Bad filter value (warn "bad *FUZZY-DUPLICATE-SYMBOL-FILTER* value: ~s" *fuzzy-duplicate-symbol-filter*) #'identity))))) (defun fuzzy-matching-greaterp (m1 m2) "Returns T if fuzzy-matching M1 should be sorted before M2. Basically just the scores of the two matchings are compared, and the match with higher score wins. For the case that the score is equal, the one which comes alphabetically first wins." (declare (type fuzzy-matching m1 m2)) (let ((score1 (fuzzy-matching.score m1)) (score2 (fuzzy-matching.score m2))) (cond ((> score1 score2) t) ((< score1 score2) nil) ; total order (t (let ((name1 (symbol-name (fuzzy-matching.symbol m1))) (name2 (symbol-name (fuzzy-matching.symbol m2)))) (string< name1 name2)))))) (declaim (ftype (function () (integer 0)) get-real-time-msecs)) (defun get-real-time-in-msecs () (let ((units-per-msec (max 1 (floor internal-time-units-per-second 1000)))) (values (floor (get-internal-real-time) units-per-msec)))) (defun fuzzy-find-matching-symbols (string package &key (filter #'identity) external-only time-limit-in-msec) "Returns two values: a vector of fuzzy matchings for matching symbols in PACKAGE, using the fuzzy completion algorithm, and the remaining time limit. Only those symbols are considered of which FILTER does return T. If EXTERNAL-ONLY is true, only external symbols are considered. A TIME-LIMIT-IN-MSEC of NIL is considered no limit; if it's zero or negative, perform a NOP." (let ((time-limit-p (and time-limit-in-msec t)) (time-limit (or time-limit-in-msec 0)) (rtime-at-start (get-real-time-in-msecs)) (package-name (package-name package)) (count 0)) (declare (type boolean time-limit-p)) (declare (type integer time-limit rtime-at-start)) (declare (type (integer 0 #.(1- most-positive-fixnum)) count)) (flet ((recompute-remaining-time (old-remaining-time) (cond ((not time-limit-p) ;; propagate NIL back as infinite time limit (values nil nil)) ((> count 0) ; ease up on getting internal time like crazy (setf count (mod (1+ count) 128)) (values nil old-remaining-time)) (t (let* ((elapsed-time (- (get-real-time-in-msecs) rtime-at-start)) (remaining (- time-limit elapsed-time))) (values (<= remaining 0) remaining))))) (perform-fuzzy-match (string symbol-name) (let* ((converter (completion-output-symbol-converter string)) (converted-symbol-name (funcall converter symbol-name))) (compute-highest-scoring-completion string converted-symbol-name)))) (let ((completions (make-array 256 :adjustable t :fill-pointer 0)) (rest-time-limit time-limit)) (do-symbols* (symbol package) (multiple-value-bind (exhausted? remaining-time) (recompute-remaining-time rest-time-limit) (setf rest-time-limit remaining-time) (cond (exhausted? (return)) ((not (and (or (not external-only) (symbol-external-p symbol package)) (funcall filter symbol)))) ((string= "" string) ; "" matches always (vector-push-extend (make-fuzzy-matching symbol package-name 0.0 '() '()) completions)) (t (multiple-value-bind (match-result score) (perform-fuzzy-match string (symbol-name symbol)) (when match-result (vector-push-extend (make-fuzzy-matching symbol package-name score '() match-result) completions))))))) (values completions rest-time-limit))))) (defun fuzzy-find-matching-packages (name &key time-limit-in-msec) "Returns a vector of fuzzy matchings for each package that is similiar to NAME, and the remaining time limit. Cf. FUZZY-FIND-MATCHING-SYMBOLS." (let ((time-limit-p (and time-limit-in-msec t)) (time-limit (or time-limit-in-msec 0)) (rtime-at-start (get-real-time-in-msecs)) (converter (completion-output-package-converter name)) (completions (make-array 32 :adjustable t :fill-pointer 0))) (declare (type boolean time-limit-p)) (declare (type integer time-limit rtime-at-start)) (declare (type function converter)) (flet ((match-package (names) (loop with max-pkg-name = "" with max-result = nil with max-score = 0 for package-name in names for converted-name = (funcall converter package-name) do (multiple-value-bind (result score) (compute-highest-scoring-completion name converted-name) (when (and result (> score max-score)) (setf max-pkg-name package-name) (setf max-result result) (setf max-score score))) finally (when max-result (vector-push-extend (make-fuzzy-matching nil max-pkg-name max-score max-result '() :symbol-p nil) completions))))) (cond ((and time-limit-p (<= time-limit 0)) (values #() time-limit)) (t (loop for (nick) in (package-local-nicknames *buffer-package*) do (match-package (list nick))) (loop for package in (list-all-packages) do ;; Find best-matching package-nickname: (match-package (package-names package)) finally (return (values completions (and time-limit-p (let ((elapsed-time (- (get-real-time-in-msecs) rtime-at-start))) (- time-limit elapsed-time))))))))))) (defslimefun fuzzy-completion-selected (original-string completion) "This function is called by Slime when a fuzzy completion is selected by the user. It is for future expansion to make testing, say, a machine learning algorithm for completion scoring easier. ORIGINAL-STRING is the string the user completed from, and COMPLETION is the completion object (see docstring for SWANK:FUZZY-COMPLETIONS) corresponding to the completion that the user selected." (declare (ignore original-string completion)) nil) ;;;;; Fuzzy completion core (defparameter *fuzzy-recursion-soft-limit* 30 "This is a soft limit for recursion in RECURSIVELY-COMPUTE-MOST-COMPLETIONS. Without this limit, completing a string such as \"ZZZZZZ\" with a symbol named \"ZZZZZZZZZZZZZZZZZZZZZZZ\" will result in explosive recursion to find all the ways it can match. Most natural language searches and symbols do not have this problem -- this is only here as a safeguard.") (declaim (fixnum *fuzzy-recursion-soft-limit*)) (defvar *all-chunks* '()) (declaim (type list *all-chunks*)) (defun compute-highest-scoring-completion (short full) "Finds the highest scoring way to complete the abbreviation SHORT onto the string FULL, using CHAR= as a equality function for letters. Returns two values: The first being the completion chunks of the highest scorer, and the second being the score." (let* ((scored-results (mapcar #'(lambda (result) (cons (score-completion result short full) result)) (compute-most-completions short full))) (winner (first (sort scored-results #'> :key #'first)))) (values (rest winner) (first winner)))) (defun compute-most-completions (short full) "Finds most possible ways to complete FULL with the letters in SHORT. Calls RECURSIVELY-COMPUTE-MOST-COMPLETIONS recursively. Returns a list of (&rest CHUNKS), where each CHUNKS is a description of how a completion matches." (let ((*all-chunks* nil)) (recursively-compute-most-completions short full 0 0 nil nil nil t) *all-chunks*)) (defun recursively-compute-most-completions (short full short-index initial-full-index chunks current-chunk current-chunk-pos recurse-p) "Recursively (if RECURSE-P is true) find /most/ possible ways to fuzzily map the letters in SHORT onto FULL, using CHAR= to determine if two letters match. A chunk is a list of elements that have matched consecutively. When consecutive matches stop, it is coerced into a string, paired with the starting position of the chunk, and pushed onto CHUNKS. Whenever a letter matches, if RECURSE-P is true, RECURSIVELY-COMPUTE-MOST-COMPLETIONS calls itself with a position one index ahead, to find other possibly higher scoring possibilities. If there are less than *FUZZY-RECURSION-SOFT-LIMIT* results in *ALL-CHUNKS* currently, this call will also recurse. Once a word has been completely matched, the chunks are pushed onto the special variable *ALL-CHUNKS* and the function returns." (declare (optimize speed) (type fixnum short-index initial-full-index) (type list current-chunk) (simple-string short full)) (flet ((short-cur () "Returns the next letter from the abbreviation, or NIL if all have been used." (if (= short-index (length short)) nil (aref short short-index))) (add-to-chunk (char pos) "Adds the CHAR at POS in FULL to the current chunk, marking the start position if it is empty." (unless current-chunk (setf current-chunk-pos pos)) (push char current-chunk)) (collect-chunk () "Collects the current chunk to CHUNKS and prepares for a new chunk." (when current-chunk (let ((current-chunk-as-string (nreverse (make-array (length current-chunk) :element-type 'character :initial-contents current-chunk)))) (push (list current-chunk-pos current-chunk-as-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) (char= cur-char (short-cur))) (progn (when recurse-p ;; Try other possibilities, limiting insanely deep ;; recursion somewhat. (recursively-compute-most-completions short full 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)))) ;;;;; Fuzzy completion scoring (defvar *fuzzy-completion-symbol-prefixes* "*+-%&?<" "Letters that are likely to be at the beginning of a symbol. Letters found after one of these prefixes will be scored as if they were at the beginning of ths symbol.") (defvar *fuzzy-completion-symbol-suffixes* "*+->" "Letters that are likely to be at the end of a symbol. Letters found before one of these suffixes will be scored as if they were at the end of the symbol.") (defvar *fuzzy-completion-word-separators* "-/." "Letters that separate different words in symbols. Letters after one of these symbols will be scores more highly than other letters.") (defun score-completion (completion short full) "Scores the completion chunks COMPLETION as a completion from the abbreviation SHORT to the full string FULL. COMPLETION is a list like: ((0 \"mul\") (9 \"v\") (15 \"b\")) Which, if SHORT were \"mulvb\" and full were \"multiple-value-bind\", would indicate that it completed as such (completed letters capitalized): MULtiple-Value-Bind Letters are given scores based on their position in the string. Letters at the beginning of a string or after a prefix letter at the beginning of a string are scored highest. Letters after a word separator such as #\- are scored next highest. Letters at the end of a string or before a suffix letter at the end of a string are scored medium, and letters anywhere else are scored low. If a letter is directly after another matched letter, and its intrinsic value in that position is less than a percentage of the previous letter's value, it will use that percentage instead. Finally, a small scaling factor is applied to favor shorter matches, all other things being equal." (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-percentage-of-previous (base-score pos chunk-pos) (if (zerop chunk-pos) base-score (max base-score (+ (* (score-char (1- pos) (1- chunk-pos)) 0.85) (expt 1.2 chunk-pos))))) (score-char (pos chunk-pos) (score-or-percentage-of-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)) (score-chunk (chunk) (loop for chunk-pos below (length (second chunk)) for pos from (first chunk) summing (score-char pos chunk-pos)))) (let* ((chunk-scores (mapcar #'score-chunk completion)) (length-score (/ 10.0 (1+ (- (length full) (length short)))))) (values (+ (reduce #'+ chunk-scores) length-score) (list (mapcar #'list chunk-scores completion) length-score))))) (defun highlight-completion (completion full) "Given a chunk definition COMPLETION and the string FULL, HIGHLIGHT-COMPLETION will create a string that demonstrates where the completion matched in the string. Matches will be capitalized, while the rest of the string will be lower-case." (let ((highlit (nstring-downcase (copy-seq full)))) (dolist (chunk completion) (setf highlit (nstring-upcase highlit :start (first chunk) :end (+ (first chunk) (length (second chunk)))))) highlit)) (defun format-fuzzy-completion-set (winners) "Given a list of completion objects such as on returned by FUZZY-COMPLETION-SET, format the list into user-readable output for interactive debugging purpose." (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)))) (provide :swank-fuzzy)