Index: slime.el
===================================================================
RCS file: /project/slime/cvsroot/slime/slime.el,v
retrieving revision 1.314
diff -u -r1.314 slime.el
--- slime.el	16 Jun 2004 00:13:42 -0000	1.314
+++ slime.el	16 Jun 2004 07:28:26 -0000
@@ -346,6 +346,7 @@
 
 Programming aids:
 \\[slime-complete-symbol]	- Complete the Lisp symbol at point. (Also M-TAB.)
+\\[slime-fuzzy-complete-symbol]	- Fuzzily completes text at point to a Lisp symbol.
 \\[slime-macroexpand-1]	- Macroexpand once.
 \\[slime-macroexpand-all]	- Macroexpand all.
 
@@ -476,6 +477,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)
@@ -568,6 +570,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"
@@ -3803,6 +3806,251 @@
   (slime-eval `(swank:simple-completions ,prefix 
                                          ,(or (slime-find-buffer-package)
                                               (slime-buffer-package)))))
+
+
+;;; Fuzzy completion
+
+(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-text nil)
+(defvar slime-fuzzy-completion-current-text nil)
+(defvar slime-fuzzy-completion-current-completion nil)
+
+(define-derived-mode slime-fuzzy-completions-mode 
+  fundamental-mode "Fuzzy Completions"
+  "Major mode for presenting fuzzy completion results.
+
+\\<slime-fuzzy-completions-map>
+\\{slime-fuzzy-completions-map}"
+  (use-local-map slime-fuzzy-completions-map))
+
+(defvar slime-fuzzy-completions-map nil 
+  "Keymap for slime-fuzzy-completions-mode.")
+(setq slime-fuzzy-completions-map
+  (let* ((map (make-sparse-keymap)))
+
+    (define-key map "q" 'slime-fuzzy-completion-abort)
+    (define-key map "\r" 'slime-fuzzy-completion-select)
+
+    (define-key map "n" 'slime-fuzzy-completion-next)
+    (define-key map "\M-n" 'slime-fuzzy-completion-next)
+
+    (define-key map "p" 'slime-fuzzy-completion-prev)
+    (define-key map "\M-p" 'slime-fuzzy-completion-prev)
+
+    (define-key map [mouse-2] 'slime-fuzzy-completion-click)
+
+    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 ()
+  "Fuzzily completes the abbreviation at point into a 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-choices-buffer completion-set beg end)))
+      )))
+
+
+(defun get-slime-fuzzy-completions-buffer ()
+  (get-buffer-create "*Fuzzy Completions*"))
+
+(defun slime-fuzzy-completions-explanation ()
+  (insert 
+   "Click <mouse-2> on a completion to select it.
+In this buffer, type n and p to navigate between completions.
+Type RET to select the completion near point.  Type q to abort.
+\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))
+      (put-text-property start (point) 'mouse-face 'highlight)
+      (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-click (event)
+  (interactive "e")
+  (save-excursion
+    (with-current-buffer (window-buffer (posn-window (event-end event)))
+      (save-excursion
+        (goto-char (posn-point (event-end event)))
+        (when (get-text-property (point) 'mouse-face)
+          (slime-fuzzy-completion-insert-from-point)
+          (slime-fuzzy-completion-select))))))
+
+(defun slime-fuzzy-completion-insert (text)
+  (with-current-buffer slime-fuzzy-completion-buffer
+    (when (not (string-equal slime-fuzzy-completion-current 
+                             (buffer-substring slime-fuzzy-completion-start
+                                               slime-fuzzy-completion-end)))
+      (slime-fuzzy-completion-done)
+      ;; Not an error, we may be in the post-command-hook.
+      (beep)
+      (message "Target buffer has been modified!"))
+    (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)))
+    (setq slime-fuzzy-completion-current text)
+    (goto-char slime-fuzzy-completion-end)))
+
+(defun slime-fuzzy-completion-choices-buffer (completions start end)
+  (remove-hook 'window-configuration-change-hook
+               'slime-fuzzy-completion-window-configuration-change)
+  (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-current slime-fuzzy-completion-original)
+  (setq slime-fuzzy-completion-buffer (current-buffer))
+  (set-buffer (get-slime-fuzzy-completions-buffer))
+  (setq buffer-read-only nil)
+  (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-completion-first (point))
+    (dolist (completion completions)
+      (slime-fuzzy-insert-completion-choice completion max-length))
+    (setq buffer-read-only t))
+  (setq slime-fuzzy-completion-current-completion
+        (caar completions))
+  (slime-fuzzy-completion-insert (caar completions))
+  (goto-char slime-fuzzy-completion-first)
+  (slime-fuzzy-completion-save-window-configuration)
+  (pop-to-buffer (current-buffer))
+  (make-local-variable 'post-command-hook)
+  (add-hook 'post-command-hook
+            'slime-fuzzy-completion-post-command-hook))
+
+(defun slime-fuzzy-completion-insert-from-point ()
+  (with-current-buffer (get-slime-fuzzy-completions-buffer)
+    (let ((current-completion (get-text-property (point) 'completion)))
+      (when (and current-completion
+                 (not (eq slime-fuzzy-completion-current-completion 
+                          current-completion)))
+        (slime-fuzzy-completion-insert 
+         (first (get-text-property (point) 'completion)))
+        (setq slime-fuzzy-completion-current-completion
+              current-completion)))))
+
+(defun slime-fuzzy-completion-post-command-hook ()
+  (condition-case err
+      (when slime-fuzzy-completion-buffer
+        (slime-fuzzy-completion-insert-from-point))
+    (error
+     ;; Because this is called on the post-command-hook, we mustn't let
+     ;; errors propagate.
+     (message "Error in slime-fuzzy-completion-post-command-hook: %S" err))))
+
+(defun slime-fuzzy-completion-next ()
+  (interactive)
+  (goto-char 
+   (next-single-char-property-change (point) 'completion)))
+
+(defun slime-fuzzy-completion-prev ()
+  (interactive)
+  (goto-char (previous-single-char-property-change 
+              (point) 'completion
+              nil slime-fuzzy-completion-first)))
+
+(defun slime-fuzzy-completion-abort ()
+  (interactive)
+  (when slime-fuzzy-completion-buffer
+    (slime-fuzzy-completion-insert slime-fuzzy-completion-original)
+    (slime-fuzzy-completion-done)))
+
+(defun slime-fuzzy-completion-select ()
+  (interactive)
+  (when slime-fuzzy-completion-buffer
+    (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 ()
+  (set-buffer slime-fuzzy-completion-buffer)
+  (remove-hook 'post-command-hook
+               'slime-fuzzy-completion-post-command-hook)
+  (slime-fuzzy-completion-maybe-restore-window-configuration)
+  (pop-to-buffer slime-fuzzy-completion-buffer)
+  (goto-char slime-fuzzy-completion-end)
+  (setq slime-fuzzy-completion-buffer nil))
+
+(defun slime-fuzzy-completion-save-window-configuration ()
+  (setq slime-fuzzy-completion-window-configuration 
+        (current-window-configuration))
+  (setq slime-fuzzy-completion-window-configuration-change-count 0)
+  (run-with-timer 
+   0.5 nil 'slime-fuzzy-completion-window-configuration-change-add-hook))
+
+(defun slime-fuzzy-completion-maybe-restore-window-configuration ()
+  (remove-hook 'window-configuration-change-hook
+               'slime-fuzzy-completion-window-configuration-change)
+  (when slime-fuzzy-completion-window-configuration
+    (set-window-configuration slime-fuzzy-completion-window-configuration)
+    (setq slime-fuzzy-completion-window-configuration nil)))
+
+(defun slime-fuzzy-completion-window-configuration-change-add-hook ()
+  (remove-hook 'post-command-hook
+               'slime-fuzzy-completion-window-configuration-change-add-hook)
+  (add-hook 'window-configuration-change-hook
+            'slime-fuzzy-completion-window-configuration-change))
+
+(defun slime-fuzzy-completion-window-configuration-change ()
+  (remove-hook 'window-configuration-change-hook
+               'slime-fuzzy-completion-window-configuration-change)
+  (setq slime-fuzzy-completion-window-configuration nil))
 
 
 ;;; Interpreting Elisp symbols as CL symbols (package qualifiers)
Index: swank.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank.lisp,v
retrieving revision 1.190
diff -u -r1.190 swank.lisp
--- swank.lisp	12 Jun 2004 12:21:13 -0000	1.190
+++ swank.lisp	16 Jun 2004 07:28:33 -0000
@@ -1418,14 +1418,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)
@@ -1484,6 +1486,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.  
 
@@ -1512,6 +1580,12 @@
                                         #'prefix-match-p)))
     (list completion-set (longest-common-prefix completion-set))))
 
+(defslimefun fuzzy-completions (string default-package-name &optional limit)
+  "Return an (optionally limited) list of fuzzy completions for
+a symbol designator STRING.  The list will be sorted by score,
+most likely match first."
+  (fuzzy-completion-set string default-package-name limit))
+
 (defun tokenize-symbol-designator (string)
   "Parse STRING as a symbol designator.
 Return three values:
@@ -1533,6 +1607,149 @@
     (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-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))))
+                      (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)))
+               (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
 
