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.
diff --git a/input.lisp b/input.lisp
index 9b3dcd9..97d7aa6 100644
--- a/input.lisp
+++ b/input.lisp
@@ -377,19 +377,94 @@ 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)))
+ (declare (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)))
+ (curr-row (make-array (1+ full-len)))
+ (flag)
+ (delta 1)
+ (next-j 1))
+ (declare
+ (type fixnum short-len full-len delta next-j s0 s f0 f)
+ (type simple-vector prev-row curr-row))
+ (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 ((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))))
+ (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
