home *** CD-ROM | disk | FTP | other *** search
/ SGI Developer Toolbox 6.1 / SGI Developer Toolbox 6.1 - Disc 4.iso / public / GNU / emacs.inst / emacs19.idb / usr / gnu / lib / emacs / site-lisp / fuzzy-match.el.z / fuzzy-match.el
Encoding:
Text File  |  1994-08-02  |  10.1 KB  |  281 lines
  1. ;;; fuzzy-match.el --- fuzzy matching
  2.  
  3. ;; Copyright (C) 1993 Simon Marshall.
  4.  
  5. ;; Author: Simon Marshall <s.marshall@dcs.hull.ac.uk>
  6. ;; Keywords: matching strings
  7. ;; Version: 1.00
  8.  
  9. ;; This file is not part of GNU Emacs.
  10.  
  11. ;; GNU Emacs is free software; you can redistribute it and/or modify
  12. ;; it under the terms of the GNU General Public License as published by
  13. ;; the Free Software Foundation; either version 2, or (at your option)
  14. ;; any later version.
  15.  
  16. ;; GNU Emacs is distributed in the hope that it will be useful,
  17. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19. ;; GNU General Public License for more details.
  20.  
  21. ;; You should have received a copy of the GNU General Public License
  22. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  23. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  24.  
  25. ;;; Commentary:
  26.  
  27. ;;; This is fuzzy software.  Use it at your own risk.
  28.  
  29. ;;; Please send me bug reports, bug fixes, and extensions, so that I can
  30. ;;; merge them into the master source.
  31. ;;;     - Simon Marshall (s.marshall@dcs.hull.ac.uk)
  32.  
  33. (defsubst FM-string-to-char-list (string)
  34.   "Return the character list of STRING.
  35. If STRING is already a list, this function just returns STRING."
  36.   (if (listp string)
  37.       string
  38.     (mapcar (function (lambda (char) char)) string)))
  39.  
  40. (defsubst FM-strings-to-char-lists (strings)
  41.   "Return the character lists of STRINGS.
  42. See `FM-string-to-char-list'."
  43.  (mapcar (function (lambda (string) (FM-string-to-char-list string)))
  44.      strings))
  45.  
  46. (defsubst FM-char-list-to-string (charlist)
  47.   "Return the string of CHARLIST.
  48. If CHARLIST is not a list, this function just returns CHARLIST."
  49.   (if (listp charlist)
  50.       (mapconcat (function (lambda (char) (char-to-string char))) charlist "")
  51.     charlist))
  52.  
  53. (defsubst FM-char-lists-to-strings (charlists)
  54.   "Return the strings of CHARLISTS.
  55. See `FM-char-list-to-string'."
  56.   (mapcar (function (lambda (charlist) (FM-char-list-to-string charlist)))
  57.       charlists))
  58.  
  59.  
  60. (defsubst FM-strstr-intern (string1 string2)
  61.   "Find first occurrence of a prefix of STRING1 in STRING2.
  62. Returns a cons pair of the length of the substring and the offset into STRING2,
  63. or nil if no match is found.
  64. STRING1 and STRING2 are character lists."
  65.   (let ((char1 (car string1))
  66.     (offset 0) (len 1))
  67.     (while (and string2 (/= char1 (car string2)))
  68.       (setq offset (1+ offset) string2 (cdr string2)))
  69.     (if (null string2)
  70.     nil
  71.       (setq string1 (cdr string1) string2 (cdr string2))
  72.       (while (and string1 string2 (= (car string1) (car string2)))
  73.     (setq len (1+ len) string1 (cdr string1) string2 (cdr string2)))
  74.       (cons len offset))))
  75.  
  76.  
  77. (defsubst FM-matchiness-intern (string1 string2)
  78.   "Return the fuzziness between STRING1 and STRING2.
  79. STRING1 and STRING2 are character lists."
  80.   (let* ((fuzz 0) match len)
  81.     (while (and string1 string2)
  82.       (setq match (FM-strstr-intern string1 string2))
  83.       (if (or (null match) (< (car match) (cdr match)))
  84.       (setq string1 (cdr string1))
  85.     (setq len (car match)
  86.           fuzz (+ fuzz len)
  87.           string1 (nthcdr len string1)
  88.           string2 (nthcdr (+ len (cdr match)) string2))))
  89.     fuzz))
  90.  
  91.  
  92. (defun FM-string-prefix (string1 string2)
  93.   "Return length of prefix of STRING1 that starts STRING2.
  94. STRING1 and STRING2 can be character lists."
  95.   (let ((string1 (FM-string-to-char-list string1))
  96.     (string2 (FM-string-to-char-list string2))
  97.     (prefix 0))
  98.     (while (and string1 string2 (= (car string1) (car string2)))
  99.       (setq prefix (1+ prefix)
  100.         string1 (cdr string1)
  101.         string2 (cdr string2)))
  102.     prefix))
  103.  
  104.  
  105. (defun FM-lessiness (string string1 string2)
  106.   "Return non-nil if STRING1 is \"less\" than STRING2, based on STRING.
  107. Comparison is based on the simularity between STRING, and the length of STRING1
  108. and STRING2.  The closer the start of a string to STRING, the better.  If they
  109. both share the same substring, the comparision is based on length.
  110. STRING, STRING1 and STRING2 can be character lists."
  111.   (let* ((prefix1 (FM-string-prefix string string1))
  112.      (prefix2 (FM-string-prefix string string2)))
  113.     (if (/= prefix1 prefix2)
  114.     (> prefix1 prefix2)
  115.       (< (length string1) (length string2)))))
  116.  
  117. ;;; Useful functions...
  118.  
  119. (defun FM-matchiness (string1 string2)
  120.   "Return the fuzziness between STRING1 and STRING2.
  121. STRING1 and STRING2 can be character lists."
  122.   (FM-matchiness-intern (FM-string-to-char-list string1)
  123.             (FM-string-to-char-list string2)))
  124.  
  125.  
  126. (defun FM-all-fuzzy-matches (string strings)
  127.   "Return most fuzzy matches to STRING in STRINGS.
  128. Each element of STRINGS is tested to see if it fuzzily matches STRING.
  129. The value is a list of all the strings from STRINGS that most fuzzily match.
  130. The list of fuzzy matches is sorted using `FM-lessiness' as predicate.
  131. STRING and elements of STRINGS can be character lists."
  132.   (let* ((string (FM-string-to-char-list string))
  133.      (strings (FM-strings-to-char-lists strings))
  134.      (bestfuzz (FM-matchiness-intern string (car strings)))
  135.      (matches (list (car strings)))
  136.      (strings (cdr strings))
  137.      thisfuzz)
  138.     (while strings
  139.       (setq thisfuzz (FM-matchiness-intern string (car strings)))
  140.       (cond ((= bestfuzz thisfuzz)
  141.          (setq matches (cons (car strings) matches)))
  142.         ((< bestfuzz thisfuzz)
  143.          (setq bestfuzz thisfuzz
  144.            matches (list (car strings)))))
  145.       (setq strings (cdr strings)))
  146.     (FM-char-lists-to-strings
  147.      (sort matches (function (lambda (string1 string2)
  148.                    (FM-lessiness string string1 string2)))))))
  149.  
  150.  
  151. (defun FM-lisp-symbol (string)
  152.   "Return a list of fuzzy matches for the lisp symbol STRING.
  153. STRING can be a character list.
  154. This function is slow, since it checks each symbol in `obarray' in lisp.
  155. See also `FM-lisp-symbol-quick' and `FM-all-fuzzy-matches'."
  156.   (FM-all-fuzzy-matches string (all-completions "" obarray)))
  157.  
  158.  
  159. (defun FM-lisp-symbol-quick (string)
  160.   "Return a list of fuzzy matches for the lisp symbol STRING.
  161. STRING can be a character list.
  162. This function cheats, since it reduces the number of lisp code tests by using
  163. only those symbols from `obarray' that begin with the same substring as STRING.
  164. This means that the fewer correct letters at the beginning of STRING, the
  165. longer this function will take, and if the incorrect letters match some valid
  166. symbol, the wrong symbols will be matched.
  167. See also `FM-lisp-symbol', `FM-all-fuzzy-matches', and `all-completions'."
  168.   (let* ((string (FM-char-list-to-string string))
  169.      (len (length string)) (end len)
  170.      (completions (all-completions string obarray)))
  171.     (while (and (> end 0) (null completions))
  172.       (setq end (1- end)
  173.         completions (all-completions (substring string 0 end) obarray)))
  174.     (FM-all-fuzzy-matches string completions)))
  175.  
  176.  
  177. (defun FM-replace-by-matched-lisp-symbol ()
  178.   "Replace lisp symbol before point with best fuzzy match."
  179.   (interactive)
  180.   (let ((sym (FM-lisp-symbol-at-point)))
  181.     (replace-match (car (FM-lisp-symbol-quick sym)) t t)))
  182.  
  183.  
  184. (defun FM-list-lisp-symbols ()
  185.   "List in help buffer fuzzy matches to lisp symbol before point."
  186.   (interactive)
  187.   (let ((sym (FM-lisp-symbol-at-point)))
  188.     (FM-dynamic-list-matches (FM-lisp-symbol-quick sym))))
  189.  
  190.  
  191. (defun FM-pathname (pathname)
  192.   (let ((fmpath "")
  193.     (start 0) end partpath fmpartpath)
  194.     (while start
  195.       (setq end (string-match "/" pathname (1+ start))
  196.         partpath (substring pathname start end)
  197.         fmpartpath (concat fmpath partpath)
  198.         fmpath (if (file-exists-p fmpartpath)
  199.                fmpartpath
  200.              (car (FM-all-fuzzy-matches
  201.                fmpartpath (directory-files fmpath t))))
  202.         start end))
  203.     fmpath))
  204.  
  205.     
  206. (defun FM-replace-by-matched-filename ()
  207.   "Replace filename before point with best fuzzy match."
  208.   (interactive)
  209.   (let ((path (FM-pathname-at-point)))
  210.     (replace-match (save-match-data (FM-pathname path)) t t)))
  211.  
  212.  
  213. (defun FM-replace-by-matched-command ()
  214.   "Replace command name before point with best fuzzy match."
  215.   (interactive)
  216.   (let* ((command (file-name-nondirectory (FM-pathname-at-point)))
  217.      (stub (substring command 0 1))
  218.      (paths (cdr (reverse exec-path)))
  219.      (ignored-extensions
  220.       (mapconcat (function (lambda (x) (concat (regexp-quote x) "$")))
  221.              completion-ignored-extensions "\\|"))
  222.      path cmd cmds commands)
  223.     (save-match-data
  224.       (while paths
  225.     (setq path (file-name-as-directory (car paths)) paths (cdr paths)
  226.           cmds (and (file-accessible-directory-p path)
  227.             (file-name-all-completions stub path)))
  228.     (while cmds
  229.       (setq cmd (car cmds) cmds (cdr cmds))
  230.       (if (and (not (member cmd commands))
  231.            (not (string-match ignored-extensions cmd))
  232.            (not (file-directory-p (concat path cmd)))
  233.            (file-executable-p (concat path cmd)))
  234.           (setq commands (cons cmd commands))))))
  235.     (replace-match (car (FM-all-fuzzy-matches command commands)) t t)))
  236.  
  237. ;;; Plundered from comint.el.
  238.  
  239. (defun FM-pathname-at-point ()
  240.   "Return the expanded filename at point, or signal an error.
  241. Environment variables are substituted."
  242.   (save-excursion
  243.     (if (re-search-backward "[^~/A-Za-z0-9_.$#,={}()-]" nil 'move)
  244.     (forward-char 1))
  245.     ;; Anchor the search forwards.
  246.     (if (not (looking-at "[~/A-Za-z0-9_.$#,={}()-]")) (error ""))
  247.     (re-search-forward "[~/A-Za-z0-9_.$#,={}()-]+")
  248.     (expand-file-name
  249.      (substitute-in-file-name
  250.       (buffer-substring (match-beginning 0) (match-end 0))))))
  251.  
  252. (defun FM-lisp-symbol-at-point ()
  253.   "Return the lisp symbol at point, or signal an error."
  254.   (save-excursion
  255.     (if (re-search-backward "[^A-Za-z0-9_.$#,=-]" nil 'move)
  256.     (forward-char 1))
  257.     ;; Anchor the search forwards.
  258.     (if (not (looking-at "[A-Za-z0-9_.$#,=-]")) (error ""))
  259.     (re-search-forward "[~/A-Za-z0-9_.$#,=-]+")
  260.     (buffer-substring (match-beginning 0) (match-end 0))))
  261.  
  262. (defun FM-dynamic-list-matches (matches)
  263.   "List in help buffer MATCHES.
  264. Typing SPC flushes the help buffer."
  265.   (let ((conf (current-window-configuration))
  266.     (match-buffer " *Matches*"))
  267.     (with-output-to-temp-buffer match-buffer
  268.       (display-completion-list matches)
  269.       (set-buffer match-buffer)
  270.     (forward-line 3)
  271.     (while (search-backward "completion" nil 'move)
  272.       (replace-match "candidate")))
  273.     (sit-for 0)
  274.     (message "Hit space to flush")
  275.     (let ((ch (read-event)))
  276.       (if (eq ch ?\ )
  277.       (set-window-configuration conf)
  278.     (setq unread-command-events (list ch))))))
  279.  
  280. ;;; fuzzy-match.el ends here
  281.