Index: slime.el
===================================================================
RCS file: /project/slime/cvsroot/slime/slime.el,v
retrieving revision 1.312
diff -u -r1.312 slime.el
--- slime.el	10 Jun 2004 17:34:07 -0000	1.312
+++ slime.el	11 Jun 2004 08:05:00 -0000
@@ -344,6 +344,7 @@
 
 Programming aids:
 \\[slime-complete-symbol]	- Complete the Lisp symbol at point. (Also M-TAB.)
+\\[slime-fuzzy-complete-symbol]	- Fuzzily complete the Lisp symbol at point. (NEEDS INTERFACE WORK)
 \\[slime-macroexpand-1]	- Macroexpand once.
 \\[slime-macroexpand-all]	- Macroexpand all.
 
@@ -474,6 +475,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)
@@ -566,6 +568,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"
@@ -3795,6 +3798,201 @@
   (slime-eval `(swank:simple-completions ,prefix 
                                          ,(or (slime-find-buffer-package)
                                               (slime-buffer-package)))))
+
+
+;;; Fuzzy completion (FIX ME, PLEASE)
+
+(defvar slime-fuzzy-completion-minor-mode nil)
+(make-variable-buffer-local 'slime-fuzzy-completion-minor-mode)
+
+(define-derived-mode slime-fuzzy-completions-mode 
+  fundamental-mode "Fuzzy Completions"
+  "Bleh."
+  )
+
+(or (assq 'slime-fuzzy-completion-minor-mode minor-mode-alist)
+    (nconc minor-mode-alist
+           (list '(slime-fuzzy-completion-minor-mode 
+                   slime-fuzzy-completion-minor-mode))))
+
+(defvar slime-fuzzy-completion-mode-map nil "It's a keymap!")
+(setq slime-fuzzy-completion-mode-map
+  (let* ((i 0)
+         (map (make-keymap)))
+
+    (define-key map [t] 'slime-fuzzy-completion-abort)
+
+    ;; Single-byte printing chars are undefined by default.
+    (setq i ?\ )
+    (while (< i 256)
+      (define-key map (vector i) 'undefined)
+      (setq i (1+ i)))
+
+    (define-key map "\C-g" 'slime-fuzzy-completion-abort)
+    (define-key map "q" 'slime-fuzzy-completion-abort)
+    (define-key map "\r" 'slime-fuzzy-completion-exit)
+    (define-key map [return] 'slime-fuzzy-completion-exit)
+    (define-key map "\e" 'slime-fuzzy-completion-abort)
+    (define-key map [escape] 'slime-fuzzy-completion-abort)
+
+    (define-key map "n" 'slime-fuzzy-completion-next)
+    (define-key map "p" 'slime-fuzzy-completion-prev)
+
+    ;; Pass frame events transparently so they won't exit the search.
+    ;; In particular, if we have more than one display open, then a
+    ;; switch-frame might be generated by someone typing at another keyboard.
+    (define-key map [switch-frame] nil)
+    (define-key map [delete-frame] nil)
+    (define-key map [iconify-frame] nil)
+    (define-key map [make-frame-visible] nil)
+    (define-key map [mouse-movement] nil)
+
+    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 ()
+  (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-minor-mode completion-set beg end)))
+      )))
+
+(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 nil)
+
+(defun get-slime-fuzzy-completions-buffer ()
+  (get-buffer-create "*Fuzzy Completions*"))
+
+(defun slime-fuzzy-completions-explanation ()
+  (insert "Craptastical interface!  Please FIX ME!
+Hit n and p to select a completion, RET to keep it, and q (or just
+about anything else) to abort.\n\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))
+      (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-insert (text)
+  (with-current-buffer slime-fuzzy-completion-buffer
+    (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)))
+    (goto-char slime-fuzzy-completion-end)))
+
+(defun slime-fuzzy-completion-minor-mode (completions start end)
+  (setq slime-fuzzy-completion-minor-mode " Fuzzy")
+  (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-buffer (current-buffer))
+  (setq slime-fuzzy-completion-window-configuration (current-window-configuration))
+  (add-hook 'mouse-leave-buffer-hook 'slime-fuzzy-completion-exit)
+  (with-current-buffer (get-slime-fuzzy-completions-buffer)
+    (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-completions-first (point))
+      (dolist (completion completions)
+        (slime-fuzzy-insert-completion-choice completion max-length)))
+    (slime-fuzzy-completion-insert (caar completions))
+    (goto-char slime-fuzzy-completions-first)
+    (pop-to-buffer (current-buffer))
+    (setq overriding-local-map slime-fuzzy-completion-mode-map)
+    )
+  (recursive-edit))
+
+(defun slime-fuzzy-completion-next ()
+  (interactive)
+  (goto-char 
+   (next-single-char-property-change (point) 'completion))
+  (slime-fuzzy-completion-insert 
+   (first (get-text-property (point) 'completion))))
+
+(defun slime-fuzzy-completion-prev ()
+  (interactive)
+  (goto-char (previous-single-char-property-change 
+              (point) 'completion
+              nil slime-fuzzy-completions-first))
+  (slime-fuzzy-completion-insert 
+   (first (get-text-property (point) 'completion))))
+
+(defun slime-fuzzy-completion-abort ()
+  (interactive)
+  (slime-fuzzy-completion-insert slime-fuzzy-completion-original)
+  (slime-fuzzy-completion-done))
+
+(defun slime-fuzzy-completion-exit ()
+  (interactive)
+  (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 ()
+  (remove-hook 'mouse-leave-buffer-hook 'slime-fuzzy-completion-exit)
+  (set-buffer slime-fuzzy-completion-buffer)
+  (setq overriding-local-map nil)
+  (setq slime-fuzzy-completion-minor-mode nil)
+  (set-window-configuration slime-fuzzy-completion-window-configuration)
+  (setq slime-fuzzy-completion-window-configuration nil)
+  (setq slime-fuzzy-completion-buffer nil)
+  (exit-recursive-edit))
 
 
 ;;; Interpreting Elisp symbols as CL symbols (package qualifiers)
Index: swank.lisp
===================================================================
RCS file: /project/slime/cvsroot/slime/swank.lisp,v
retrieving revision 1.189
diff -u -r1.189 swank.lisp
--- swank.lisp	10 Jun 2004 17:51:33 -0000	1.189
+++ swank.lisp	11 Jun 2004 08:05:02 -0000
@@ -1415,14 +1415,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)
@@ -1481,6 +1483,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.  
 
@@ -1509,6 +1577,10 @@
                                         #'prefix-match-p)))
     (list completion-set (longest-common-prefix completion-set))))
 
+(defslimefun fuzzy-completions (string default-package-name &optional limit)
+  "FIXME"
+  (fuzzy-completion-set string default-package-name limit))
+
 (defun tokenize-symbol-designator (string)
   "Parse STRING as a symbol designator.
 Return three values:
@@ -1530,6 +1602,147 @@
     (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-half-previous (base-score pos chunk-pos)
+                        (if (zerop chunk-pos) 
+                            base-score 
+                            (max base-score 
+                                 (/ (score-char (1- pos) (1- chunk-pos)) 2))))
+                      (score-char (pos chunk-pos)
+                        (score-or-half-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