Download
(defsubst FM-string-to-char-list (string)
"Return the character list of STRING.
If STRING is already a list, this function just returns STRING."
(if (listp string) string (mapcar 'identity string)))
(defsubst FM-strings-to-char-lists (strings)
"Return the character lists of STRINGS.
See `FM-string-to-char-list'."
(mapcar 'FM-string-to-char-list strings))
(defsubst FM-char-list-to-string (charlist)
"Return the string of CHARLIST.
If CHARLIST is not a list, this function just returns CHARLIST."
(if (listp charlist) (mapconcat 'char-to-string charlist "") charlist))
(defsubst FM-char-lists-to-strings (charlists)
"Return the strings of CHARLISTS.
See `FM-char-list-to-string'."
(mapcar 'FM-char-list-to-string charlists))
(defsubst FM-strstr-intern (string1 string2)
"Find first occurrence of a prefix of STRING1 in STRING2.
Returns a cons pair of the length of the substring and the offset into STRING2,
or nil if no match is found.
STRING1 and STRING2 are character lists."
(let ((char1 (car string1))
(offset 0) len)
(while (and string2 (/= char1 (car string2)))
(setq offset (1+ offset) string2 (cdr string2)))
(if (null string2)
nil
(setq string1 (cdr string1) string2 (cdr string2) len 1)
(while (and string1 string2 (= (car string1) (car string2)))
(setq len (1+ len) string1 (cdr string1) string2 (cdr string2)))
(cons len offset))))
(defsubst FM-matchiness-intern (string1 string2)
"Return the fuzziness between STRING1 and STRING2.
STRING1 and STRING2 are character lists."
(let ((fuzz 0) len offset s1 s2 c1)
(while (and string1 string2)
(setq c1 (car string1) s2 string2 offset 0)
(while (and s2 (/= c1 (car s2)))
(setq offset (1+ offset) s2 (cdr s2)))
(if (null s2)
(setq string1 (cdr string1))
(setq s1 (cdr string1) len 1)
(while (and s1 (setq s2 (cdr s2)) (= (car s1) (car s2)))
(setq len (1+ len) s1 (cdr s1)))
(if (< len offset)
(setq string1 (cdr string1))
(setq fuzz (+ fuzz len) string1 s1 string2 s2))))
fuzz))
(defun FM-lessiness (string string1 string2)
"Return non-nil if STRING1 is \"less\" than STRING2, based on STRING.
Comparison is based on the simularity:
- Between STRING and STRING1 and STRING2 (`FM-matchiness-intern').
- Between STRING and prefix length in STRING1 and STRING2 (`FM-strstr-intern').
- Between the length of STRING and STRING1 and STRING2.
- The offset of the first occurrence of a prefix in STRING1 and STRING2.
STRING, STRING1 and STRING2 can be character lists."
(let* ((string (FM-string-to-char-list string))
(string1 (FM-string-to-char-list string1))
(string2 (FM-string-to-char-list string2))
(fuzz1 (FM-matchiness-intern string string1))
(fuzz2 (FM-matchiness-intern string string2)))
(if (/= fuzz1 fuzz2)
(> fuzz1 fuzz2)
(let ((strstr1 (FM-strstr-intern string string1))
(strstr2 (FM-strstr-intern string string2)))
(cond ((or (null strstr1) (null strstr2)))
((/= (cdr strstr1) (cdr strstr2))
(< (cdr strstr1) (cdr strstr2)))
((/= (length string1) (length string2))
(< (length string1) (length string2)))
(t (> (car strstr1) (car strstr2))))))))
(defun FM-matchiness (string1 string2)
"Return the fuzziness between STRING1 and STRING2.
This provides a gauge of the number of characters of STRING1 in STRING2.
STRING1 and STRING2 can be character lists."
(FM-matchiness-intern (FM-string-to-char-list string1)
(FM-string-to-char-list string2)))
(defun FM-closeness (string1 string2)
"Return the closeness between STRING1 and STRING2.
This provides a gauge of the similarity of STRING1 and STRING2.
STRING1 and STRING2 can be character lists."
(- (FM-matchiness-intern (FM-string-to-char-list string1)
(FM-string-to-char-list string2))
(abs (- (length string1) (length string2)))))
(defun FM-all-fuzzy-matches (string strings)
"Return most fuzzy matches to STRING in STRINGS.
Each element of STRINGS is tested to see if it fuzzily matches STRING.
The value is a list of all the strings from STRINGS that most fuzzily match.
The strings are fuzzily matched using `FM-matchiness'.
The list of fuzzy matches is sorted using `FM-fuzzy-sort'.
STRING and elements of STRINGS can be character lists."
(let* ((string (FM-string-to-char-list string))
(strings (FM-strings-to-char-lists strings))
(bestfuzz (FM-matchiness-intern string (car strings)))
(matches (list (car strings)))
(strings (cdr strings))
thisfuzz)
(while strings
(setq thisfuzz (FM-matchiness-intern string (car strings)))
(cond ((= bestfuzz thisfuzz)
(setq matches (cons (car strings) matches)))
((< bestfuzz thisfuzz)
(setq bestfuzz thisfuzz
matches (list (car strings)))))
(setq strings (cdr strings)))
(and (not (zerop bestfuzz)) (FM-fuzzy-sort string matches))))
(defun FM-all-close-matches (string strings)
"Return most close matches to STRING in STRINGS.
Each element of STRINGS is tested to see if it closely matches STRING.
The value is a list of all the strings from STRINGS that most closely match.
The strings are fuzzily matched using `FM-closeness'.
The list of close matches is sorted using `FM-fuzzy-sort'.
STRING and elements of STRINGS can be character lists."
(let* ((bestfuzz (FM-closeness string (car strings)))
(matches (list (car strings)))
(strings (cdr strings))
thisfuzz)
(while strings
(setq thisfuzz (FM-closeness string (car strings)))
(cond ((= bestfuzz thisfuzz)
(setq matches (cons (car strings) matches)))
((< bestfuzz thisfuzz)
(setq bestfuzz thisfuzz
matches (list (car strings)))))
(setq strings (cdr strings)))
(FM-fuzzy-sort string matches)))
(defun FM-map-fuzzy-matches (string strings)
"Return list of fuzzy matches to STRING in STRINGS.
Each element of the returned list is a cons pair of the form (string . fuzz)
where fuzz is the fuzzy match of string to STRING. See `FM-matchiness'.
STRING and elements of STRINGS can be character lists."
(let ((string (FM-string-to-char-list string)))
(mapcar (function (lambda (str) (cons str (FM-matchiness string str))))
strings)))
(defun FM-map-close-matches (string strings)
"Return list of close matches to STRING in STRINGS.
Each element of the returned list is a cons pair of the form (string . close)
where close is the close match of string to STRING. See `FM-closeness'.
STRING and elements of STRINGS can be character lists."
(let ((string (FM-string-to-char-list string)))
(mapcar (function (lambda (str) (cons str (FM-closeness string str))))
strings)))
(defun FM-max-matchiness (string strings)
"Return the maximum fuzzy matchiness of STRING in STRINGS.
STRING and elements of STRINGS can be character lists."
(let ((string (FM-string-to-char-list string)))
(apply 'max (mapcar (function (lambda (str) (FM-matchiness string str)))
strings))))
(defun FM-max-closeness (string strings)
"Return the maximum closeness of STRING in STRINGS.
STRING and elements of STRINGS can be character lists."
(let ((string (FM-string-to-char-list string)))
(apply 'max (mapcar (function (lambda (str) (FM-closeness string str)))
strings))))
(defun FM-fuzzy-sort (string strings)
"Return STRINGS fuzzily sorted based on STRING.
Sorting is done using `FM-lessiness' as predicate.
STRING and elements of STRINGS can be character lists."
(let ((string (FM-string-to-char-list string))
(strings (FM-strings-to-char-lists strings)))
(FM-char-lists-to-strings
(sort strings (function (lambda (string1 string2)
(FM-lessiness string string1 string2)))))))
(defun FM-offer-corrections (item candidates &optional prompt-p)
"Offer corrections for ITEM from CANDIDATES. Maybe replace ITEM.
If PROMPT-P is non-nil and there is only one candidate, ask the user before
replacing ITEM. Replacement is performed by `replace-match'.
If more than one correction exists, call `FM-list-candidates' to display them.
Returns: nil if no correction was inserted.
`sole' if corrected with the only correction match.
`correct' if the only correction match is identical to ITEM.
`listed' if a completion listing was shown."
(interactive
(let* ((symb (FM-symbol-name-before-point))
(cands (and (not (string= "" symb))
(FM-all-fuzzy-matches
symb (all-completions (substring symb 0 1) obarray)))))
(list symb cands current-prefix-arg)))
(cond ((null candidates)
(if (string= "" item)
(message "No symbol before point to complete")
(message "No candidates for `%s'" item))
nil)
((> (length candidates) 1)
(FM-list-candidates candidates)
'listed)
(t
(let ((candidate (car candidates)))
(cond ((string= item candidate)
(message "Replacement is the same as `%s'" item)
'correct)
((or (null prompt-p)
(y-or-n-p (format "Replace `%s' with `%s' " item candidate)))
(replace-match candidate t t)
(message "Replaced %s with %s" item candidate)
'sole)
(t
nil))))))
(defun FM-symbol-name-before-point ()
"Return the symbol name before point or an empty string if no symbol."
(save-excursion
(let* ((sym-chars "a-zA-Z0-9:_=<>/+-")
(sym (concat "[" sym-chars "]"))
(non-sym (concat "[^" sym-chars "]")) (limit (point)))
(when (re-search-backward non-sym nil 'move) (forward-char 1))
(if (or (eolp) (looking-at non-sym))
""
(re-search-forward (concat sym "+") limit)
(buffer-substring-no-properties (match-beginning 0) (match-end 0))))))
(defun FM-list-candidates (candidates)
"List in help buffer CANDIDATES."
(let ((conf (current-window-configuration)) (buf " *Candidates*"))
(with-output-to-temp-buffer buf
(display-completion-list candidates)
(set-buffer buf)
(forward-line 3)
(while (search-backward "completion" nil 'move)
(replace-match "candidate")))))
(defun lisp-spell-symbol (prompt)
"Perform spell checking on Lisp symbol preceding point.
With prefix arg(s) and only one candidate, ask the user before replacing.
With double prefix arg (\\[universal-argument] \\[universal-argument]), use \
`FM-all-fuzzy-matches' rather than
`FM-all-close-matches' to find Lisp symbol candidates. This is useful if the
Lisp symbol stub is only partially complete.
To minimize matching effort and results, the first character of the
symbol is assumed to be correct. See also `FM-offer-corrections'."
(interactive "p")
(let ((symbol (FM-symbol-name-before-point)))
(if (string= "" symbol)
(message "Not after a symbol")
(let ((symbols (all-completions (substring symbol 0 1) obarray))
(fuzzy-matcher (if (= prompt 16)
'FM-all-fuzzy-matches
'FM-all-close-matches)))
(message "Checking symbol `%s'" symbol)
(FM-offer-corrections symbol
(funcall fuzzy-matcher symbol symbols)
(/= prompt 1))))))
(provide 'fuzzy-match)