Also there were bugs in original patch, here is the fixed version, I
tested it with SBCL 1.0.40 and CLISP 2.48 and everything seems to be
working fine.
2010/10/1 Anonymous <swel...@gmail.com>:
> Evgeny <maet...@gmail.com> writes:
>
>> Hello,
>>
>> Here's patch for slime-like fuzzy autocompletion for input. Completion
>> type is specified in *input-completion-type* variable which can be
>> either :prefix or :fuzzy. Old prefix completion type is left as
>> default. I hope someone will find this useful.
>
> Not sure why but it doesn't work without (in-package :stumpwm), e.g.
>
> Invalid *input-completion-type* (:PREFIX)
>
> %%
> diff --git a/input.lisp b/input.lisp
> index 97d7aa6..3802c97 100644
> --- a/input.lisp
> +++ b/input.lisp
> @@ -461,7 +461,7 @@ functions are passed this structure as their first
> argument."
> (fboundp completions)))
> (funcall completions str)
> (let* ((method-name (format nil "input-find-completions/~A"
> *input-completion-type*))
> - (method (find-symbol (string-upcase method-name))))
> + (method (find-symbol (string-upcase method-name) :stumpwm)))
> (if method
> (funcall method str completions)
> (message "Invalid *input-completion-type* (:~A)"
> *input-completion-type*)))))
> %%
>
diff --git a/input.lisp b/input.lisp
index 9b3dcd9..1c0662c 100644
--- a/input.lisp
+++ b/input.lisp
@@ -26,6 +26,7 @@
(export '(*input-history-ignore-duplicates*
*input-map*
+ *input-completion-type*
completing-read
input-delete-region
input-goto-char
@@ -377,19 +378,98 @@ functions are passed this structure as their first argument."
;;; "interactive" input functions
-(defun input-find-completions (str completions)
- (if (or (functionp completions)
- (and (symbolp completions)
- (fboundp completions)))
- (funcall completions str)
- (remove-if-not (lambda (elt)
+(defun fuzzy-match (short full)
+ (declare (optimize (speed 3) (safety 0) (space 0))
+ (type simple-string short full))
+ (labels ((word-separator-p (c)
+ (or (eq c #\-) (eq c #\Space)))
+ (chunk-split (short full)
+ (let ((chunks '())
+ (chunk (list 0 0 0 0)))
+ (loop for i from 0 to (1- (length full)) for c = (aref full i) do
+ (if (word-separator-p c)
+ (let ((new-short
+ (cadr chunk))
+ (new-full (1+ i)))
+ (push chunk chunks)
+ (when (and (< new-short (length short))
+ (word-separator-p (aref short new-short)))
+ (setf new-short (1+ new-short)))
+ (setf chunk (list new-short new-short new-full new-full)))
+ (progn
+ (when (and (< (cadr chunk) (length short))
+ (eq c (aref short (cadr chunk))))
+ (setf (cadr chunk) (1+ (cadr chunk))))
+ (setf (cadddr chunk) (1+ (cadddr chunk))))))
+ (and (eq (length short) (cadr chunk))
+ (reverse (push chunk chunks)))))
+ (distance (short s0 s full f0 f)
+ (let* ((short-len (- s s0))
+ (full-len (- f f0))
+ (prev-row (make-array (1+ full-len) :initial-element 0))
+ (curr-row (make-array (1+ full-len) :initial-element 0))
+ (flag)
+ (delta 1)
+ (next-j 1))
+ (declare (dynamic-extent prev-row curr-row)
+ (type simple-vector prev-row curr-row)
+ (type fixnum short-len full-len delta next-j s0 s f0 f))
+ (loop for i from 0 to full-len do
+ (setf (aref curr-row i) (* i 2)))
+ (loop for i from 1 to short-len do
+ (let ((tmp prev-row))
+ (setf prev-row curr-row
+ curr-row tmp
+ flag NIL))
+ (loop for j from next-j to full-len do
+ (if (and (eq (aref short (+ s0 (1- i))) (aref full (+ f0 (1- j))))
+ (not flag))
+ (setf (aref curr-row j) (aref prev-row (1- j))
+ flag T
+ delta (1+ (- j i))
+ next-j (1+ j))
+ (setf (aref curr-row j) (+ delta (aref curr-row (1- j)))
+ delta 1))))
+ (aref curr-row full-len))))
+ (let ((chunks (chunk-split short full)))
+ (when chunks
+ (let ((distance (loop for (s0 s f0 f)
+ in chunks
+ for factor from 1 to (length chunks)
+ sum (* factor (distance short s0 s full f0 f)))))
+ (cons full distance))))))
+
+(defun input-find-completions/fuzzy (str completions)
+ (let* ((str (string-downcase str))
+ (completions (mapcar 'string-downcase completions))
+ (matches (remove-if-not
+ 'identity
+ (loop for candidate in completions
+ collect (fuzzy-match str candidate)))))
+ (mapcar 'car (sort matches '< :key 'cdr))))
+
+(defun input-find-completions/prefix (str completions)
+ (remove-if-not (lambda (elt)
(when (listp elt)
(setf elt (car elt)))
(and (<= (length str) (length elt))
(string= str elt
:end1 (length str)
:end2 (length str))))
- completions)))
+ completions))
+
+(defvar *input-completion-type* :prefix)
+
+(defun input-find-completions (str completions)
+ (if (or (functionp completions)
+ (and (symbolp completions)
+ (fboundp completions)))
+ (funcall completions str)
+ (let* ((method-name (format nil "input-find-completions/~A" *input-completion-type*))
+ (method (find-symbol (string-upcase method-name) :stumpwm)))
+ (if method
+ (funcall method str completions)
+ (message "Invalid *input-completion-type* (:~A)" *input-completion-type*)))))
(defun input-complete (input direction)
;; reset the completion list if this is the first time they're
_______________________________________________
Stumpwm-devel mailing list
Stumpwm-devel@nongnu.org
http://lists.nongnu.org/mailman/listinfo/stumpwm-devel
