256 lines
8.2 KiB
EmacsLisp
256 lines
8.2 KiB
EmacsLisp
|
;;; fuzzy.el --- Fuzzy matching utilities
|
|||
|
|
|
|||
|
|
;; Copyright (C) 2010 Tomohiro Matsuyama
|
|||
|
|
|
|||
|
|
;; Author: Tomohiro Matsuyama <m2ym.pub@gmail.com>
|
|||
|
|
;; Keywords: convenience
|
|||
|
|
|
|||
|
|
;; This program is free software; you can redistribute it and/or modify
|
|||
|
|
;; it under the terms of the GNU General Public License as published by
|
|||
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
|||
|
|
;; (at your option) any later version.
|
|||
|
|
|
|||
|
|
;; This program is distributed in the hope that it will be useful,
|
|||
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|||
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|||
|
|
;; GNU General Public License for more details.
|
|||
|
|
|
|||
|
|
;; You should have received a copy of the GNU General Public License
|
|||
|
|
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
|||
|
|
|
|||
|
|
;;; Commentary:
|
|||
|
|
|
|||
|
|
;;
|
|||
|
|
|
|||
|
|
;;; Code:
|
|||
|
|
|
|||
|
|
(eval-when-compile
|
|||
|
|
(require 'cl))
|
|||
|
|
(require 'regexp-opt)
|
|||
|
|
|
|||
|
|
(defgroup fuzzy nil
|
|||
|
|
"Fuzzy matching utilities."
|
|||
|
|
:group 'convenience
|
|||
|
|
:prefix "fuzzy-")
|
|||
|
|
|
|||
|
|
(defcustom fuzzy-accept-error-rate 0.10
|
|||
|
|
"Error threshold."
|
|||
|
|
:group 'fuzzy)
|
|||
|
|
|
|||
|
|
(defvar fuzzy-accept-length-difference 2)
|
|||
|
|
|
|||
|
|
(defvar fuzzy-regexp-some-char (format "\\w\\{0,%s\\}" fuzzy-accept-length-difference))
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
;;; Functions
|
|||
|
|
|
|||
|
|
(defun fuzzy-reverse-string (string)
|
|||
|
|
(apply 'string (nreverse (append string nil))))
|
|||
|
|
|
|||
|
|
(defun fuzzy-regexp-compile (string)
|
|||
|
|
(labels ((oddp (n) (eq (logand n 1) 1))
|
|||
|
|
(evenp (n) (eq (logand n 1) 0))
|
|||
|
|
(opt (n) (regexp-opt-charset (append (substring string
|
|||
|
|
(max 0 (- n 1))
|
|||
|
|
(min (length string) (+ n 2))) nil))))
|
|||
|
|
(concat
|
|||
|
|
"\\("
|
|||
|
|
(loop for i below (length string)
|
|||
|
|
for c = (if (evenp i) (opt i) fuzzy-regexp-some-char)
|
|||
|
|
concat c)
|
|||
|
|
"\\|"
|
|||
|
|
(loop for i below (length string)
|
|||
|
|
for c = (if (oddp i) (opt i) fuzzy-regexp-some-char)
|
|||
|
|
concat c)
|
|||
|
|
"\\)")))
|
|||
|
|
|
|||
|
|
(defalias 'fuzzy-edit-distance 'fuzzy-jaro-winkler-distance)
|
|||
|
|
|
|||
|
|
(defun fuzzy-jaro-winkler-distance (s1 s2)
|
|||
|
|
"http://en.wikipedia.org/wiki/Jaro-Winkler_distance"
|
|||
|
|
(let* ((l1 (length s1))
|
|||
|
|
(l2 (length s2))
|
|||
|
|
(r (max 1 (1- (/ (max l1 l2) 2))))
|
|||
|
|
(m 0)
|
|||
|
|
(tr 0)
|
|||
|
|
(p 0)
|
|||
|
|
cs1 cs2)
|
|||
|
|
(loop with seen = (make-vector l2 nil)
|
|||
|
|
for i below l1
|
|||
|
|
for c1 = (aref s1 i) do
|
|||
|
|
(loop for j from (max 0 (- i r)) below (min l2 (+ i r))
|
|||
|
|
for c2 = (aref s2 j)
|
|||
|
|
if (and (char-equal c1 c2)
|
|||
|
|
(null (aref seen j))) do
|
|||
|
|
(push c1 cs1)
|
|||
|
|
(aset seen j c2)
|
|||
|
|
(incf m)
|
|||
|
|
and return nil)
|
|||
|
|
finally
|
|||
|
|
(setq cs1 (nreverse cs1)
|
|||
|
|
cs2 (loop for i below l2
|
|||
|
|
for c = (aref seen i)
|
|||
|
|
if c collect c)))
|
|||
|
|
(loop for c1 in cs1
|
|||
|
|
for c2 in cs2
|
|||
|
|
if (not (char-equal c1 c2)) do
|
|||
|
|
(incf tr))
|
|||
|
|
(loop for i below (min m 5)
|
|||
|
|
for c1 across s1
|
|||
|
|
for c2 across s2
|
|||
|
|
while (char-equal c1 c2) do
|
|||
|
|
(incf p))
|
|||
|
|
(if (eq m 0)
|
|||
|
|
0.0
|
|||
|
|
(setq m (float m))
|
|||
|
|
(let* ((dj (/ (+ (/ m l1) (/ m l2) (/ (- m (/ tr 2)) m)) 3))
|
|||
|
|
(dw (+ dj (* p 0.1 (- 1 dj)))))
|
|||
|
|
dw))))
|
|||
|
|
|
|||
|
|
;; this function should be compiled
|
|||
|
|
(byte-compile 'fuzzy-jaro-winkler-distance)
|
|||
|
|
|
|||
|
|
(defun fuzzy-match (s1 s2 &optional function)
|
|||
|
|
(or function (setq function 'fuzzy-edit-distance))
|
|||
|
|
(and (<= (abs (- (length s1) (length s2)))
|
|||
|
|
fuzzy-accept-length-difference)
|
|||
|
|
(>= (funcall function s1 s2)
|
|||
|
|
(- 1 fuzzy-accept-error-rate))))
|
|||
|
|
|
|||
|
|
(defun fuzzy-all-completions (string collection)
|
|||
|
|
"all-completions family with fuzzy matching."
|
|||
|
|
(loop with length = (length string)
|
|||
|
|
for str in collection
|
|||
|
|
for s = (substring str 0 (min (length str)
|
|||
|
|
(+ length fuzzy-accept-length-difference)))
|
|||
|
|
if (fuzzy-match string s)
|
|||
|
|
collect str))
|
|||
|
|
|
|||
|
|
|
|||
|
|
|
|||
|
|
;;; Search and Incremental Search
|
|||
|
|
|
|||
|
|
(defvar fuzzy-search-cache nil)
|
|||
|
|
(defvar fuzzy-search-cache-string nil)
|
|||
|
|
|
|||
|
|
(defun fuzzy-search-cache-activate ()
|
|||
|
|
(setq fuzzy-search-cache (make-hash-table))
|
|||
|
|
(setq fuzzy-search-cache-string nil))
|
|||
|
|
|
|||
|
|
(defun fuzzy-search-cache-deactive ()
|
|||
|
|
(setq fuzzy-search-cache nil)
|
|||
|
|
(setq fuzzy-search-cache-string nil))
|
|||
|
|
|
|||
|
|
(defun fuzzy-search-edit-distance (s1 s2)
|
|||
|
|
(or (and fuzzy-search-cache
|
|||
|
|
(cond
|
|||
|
|
((null fuzzy-search-cache-string)
|
|||
|
|
(setq fuzzy-search-cache-string s1)
|
|||
|
|
nil)
|
|||
|
|
((not (equal fuzzy-search-cache-string s1))
|
|||
|
|
(setq fuzzy-search-cache-string s1)
|
|||
|
|
(clrhash fuzzy-search-cache)
|
|||
|
|
nil)
|
|||
|
|
(t))
|
|||
|
|
(gethash s2 fuzzy-search-cache))
|
|||
|
|
(let ((d (fuzzy-edit-distance s1 s2)))
|
|||
|
|
(if fuzzy-search-cache
|
|||
|
|
(puthash s2 d fuzzy-search-cache))
|
|||
|
|
d)))
|
|||
|
|
|
|||
|
|
(defun fuzzy-search-match (s1 s2)
|
|||
|
|
(fuzzy-match s1 s2 'fuzzy-search-edit-distance))
|
|||
|
|
|
|||
|
|
(defun fuzzy-search-forward (string &optional bound noerror count)
|
|||
|
|
(let* ((regexp (fuzzy-regexp-compile string))
|
|||
|
|
match-data)
|
|||
|
|
(save-excursion
|
|||
|
|
(while (and (null match-data)
|
|||
|
|
(re-search-forward regexp bound t))
|
|||
|
|
(if (fuzzy-search-match string (match-string 1))
|
|||
|
|
(setq match-data (match-data))
|
|||
|
|
(goto-char (1+ (match-beginning 1))))))
|
|||
|
|
(when match-data
|
|||
|
|
(store-match-data match-data)
|
|||
|
|
(goto-char (match-end 1)))))
|
|||
|
|
|
|||
|
|
(defun fuzzy-search-backward (string &optional bound noerror count)
|
|||
|
|
(let* ((regexp (fuzzy-regexp-compile string))
|
|||
|
|
match-data begin end)
|
|||
|
|
(save-excursion
|
|||
|
|
(while (and (null match-data)
|
|||
|
|
(re-search-backward regexp bound t))
|
|||
|
|
(setq begin (match-beginning 1)
|
|||
|
|
end (match-end 1))
|
|||
|
|
(store-match-data nil)
|
|||
|
|
(goto-char (max (point-min) (- begin (* (length string) 2))))
|
|||
|
|
(while (re-search-forward regexp end t)
|
|||
|
|
(if (fuzzy-search-match string (match-string 1))
|
|||
|
|
(setq match-data (match-data))
|
|||
|
|
(goto-char (1+ (match-beginning 1)))))
|
|||
|
|
(unless match-data
|
|||
|
|
(goto-char begin)))
|
|||
|
|
(if match-data
|
|||
|
|
(progn
|
|||
|
|
(store-match-data match-data)
|
|||
|
|
(goto-char (match-beginning 1)))
|
|||
|
|
(store-match-data nil)))))
|
|||
|
|
|
|||
|
|
(defvar fuzzy-isearch nil)
|
|||
|
|
(defvar fuzzy-isearch-failed-count 0)
|
|||
|
|
(defvar fuzzy-isearch-enabled 'on-failed)
|
|||
|
|
(defvar fuzzy-isearch-original-search-fun nil)
|
|||
|
|
(defvar fuzzy-isearch-prefix "[FUZZY] ")
|
|||
|
|
|
|||
|
|
(defun fuzzy-isearch-activate ()
|
|||
|
|
(setq fuzzy-isearch t)
|
|||
|
|
(setq fuzzy-isearch-failed-count 0)
|
|||
|
|
(fuzzy-search-cache-activate))
|
|||
|
|
|
|||
|
|
(defun fuzzy-isearch-deactivate ()
|
|||
|
|
(setq fuzzy-isearch nil)
|
|||
|
|
(setq fuzzy-isearch-failed-count 0)
|
|||
|
|
(fuzzy-search-cache-deactive))
|
|||
|
|
|
|||
|
|
(defun fuzzy-isearch ()
|
|||
|
|
(cond (isearch-word
|
|||
|
|
(if isearch-forward 'word-search-forward 'word-search-backward))
|
|||
|
|
(isearch-regexp
|
|||
|
|
(if isearch-forward 're-search-forward 're-search-backward))
|
|||
|
|
((or fuzzy-isearch
|
|||
|
|
(eq fuzzy-isearch-enabled 'always)
|
|||
|
|
(and (eq fuzzy-isearch-enabled 'on-failed)
|
|||
|
|
(null isearch-success)
|
|||
|
|
isearch-wrapped
|
|||
|
|
(> (setq fuzzy-isearch-failed-count (1+ fuzzy-isearch-failed-count))
|
|||
|
|
1)))
|
|||
|
|
(unless fuzzy-isearch
|
|||
|
|
;(goto-char isearch-opoint)
|
|||
|
|
(fuzzy-isearch-activate))
|
|||
|
|
(if isearch-forward 'fuzzy-search-forward 'fuzzy-search-backward))
|
|||
|
|
(t
|
|||
|
|
(if isearch-forward 'search-forward 'search-backward))))
|
|||
|
|
|
|||
|
|
(defun fuzzy-isearch-end-hook ()
|
|||
|
|
(fuzzy-isearch-deactivate))
|
|||
|
|
|
|||
|
|
(defun turn-on-fuzzy-isearch ()
|
|||
|
|
(interactive)
|
|||
|
|
(setq fuzzy-isearch-original-search-fun isearch-search-fun-function)
|
|||
|
|
(setq isearch-search-fun-function 'fuzzy-isearch)
|
|||
|
|
(add-hook 'isearch-mode-end-hook 'fuzzy-isearch-end-hook))
|
|||
|
|
|
|||
|
|
(defun turn-off-fuzzy-isearch ()
|
|||
|
|
(interactive)
|
|||
|
|
(setq isearch-search-fun-function fuzzy-isearch-original-search-fun)
|
|||
|
|
(remove-hook 'isearch-mode-end-hook 'fuzzy-isearch-end-hook))
|
|||
|
|
|
|||
|
|
(defadvice isearch-message-prefix (after fuzzy-isearch-message-prefix activate)
|
|||
|
|
(if fuzzy-isearch
|
|||
|
|
(setq ad-return-value (concat fuzzy-isearch-prefix ad-return-value))
|
|||
|
|
ad-return-value))
|
|||
|
|
|
|||
|
|
(provide 'fuzzy)
|
|||
|
|
;;; fuzzy.el ends here
|