branch: elpa/flx
commit 6189f05c7e45688f0e83e28941bf6b6914b75b95
Author: Le Wang <le.w...@agworld.com.au>
Commit: Le Wang <le.w...@agworld.com.au>
add flx, ido implementation and helm experiment
---
flx-ido.el | 73 ++++++++++++++
flx-scratch-helm.el | 69 ++++++++++++++
flx.el | 268 ++++++++++++++++++++++++++++++++++++++++++++++++++++
3 files changed, 410 insertions(+)
diff --git a/flx-ido.el b/flx-ido.el
new file mode 100644
index 0000000000..0d66727099
--- /dev/null
+++ b/flx-ido.el
@@ -0,0 +1,73 @@
+;;;
+;;; credit to scott frazer's blog entry
here:http://scottfrazersblog.blogspot.com.au/2009/12/emacs-better-ido-flex-matching.html
+;;;
+
+(require 'ido)
+(require 'flx)
+
+;;; dynamically bound by ido
+(defvar hist)
+
+(defun flx-ido-match (query items)
+ "Better sorting for flx ido matching."
+ (if (zerop (length query))
+ items
+ (let ((cache (if (eq hist 'ido-file-history)
+ flx-file-cache
+ flx-strings-cache))
+ matches)
+ (mapc (lambda (item)
+ (let ((score (flx-score item query cache)))
+ (when score
+ (push (cons item (car score)) matches))))
+ items)
+ (mapcar 'car (if ido-rotate
+ matches
+ (sort matches (lambda (x y) (> (cdr x) (cdr y)))))))))
+
+(defvar flx-ido-use t
+ "*Use flx matching for ido.")
+
+(defadvice ido-set-matches-1 (around flx-ido-set-matches-1 activate)
+ "Choose between the regular ido-set-matches-1 and my-ido-fuzzy-match"
+ (if flx-ido-use
+ (setq ad-return-value (flx-ido-match ido-text (ad-get-arg 0)))
+ ad-do-it))
+
+
+(setq ido-enable-flex-matching t)
+
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;; testing
+
+;; (defvar ido-enable-replace-completing-read t
+;; "If t, use ido-completing-read instead of completing-read if possible.
+
+;; Set it to nil using let in around-advice for functions where the
+;; original completing-read is required. For example, if a function
+;; foo absolutely must use the original completing-read, define some
+;; advice like this:
+
+;; (defadvice foo (around original-completing-read-only activate)
+;; (let (ido-enable-replace-completing-read) ad-do-it))")
+
+;; ;; Replace completing-read wherever possible, unless directed otherwise
+;; (defadvice completing-read
+;; (around use-ido-when-possible activate)
+;; (if (or (not ido-enable-replace-completing-read) ; Manual override
disable ido
+;; (and (boundp 'ido-cur-list)
+;; ido-cur-list)) ; Avoid infinite loop from ido calling this
+;; ad-do-it
+;; (let ((allcomp (all-completions "" collection predicate)))
+;; (if allcomp
+;; (setq ad-return-value
+;; (ido-completing-read prompt
+;; allcomp
+;; nil require-match initial-input hist
def))
+;; ad-do-it))))
+
+;; (ido-everywhere t)
+
+(provide 'flx-ido)
diff --git a/flx-scratch-helm.el b/flx-scratch-helm.el
new file mode 100644
index 0000000000..859f466309
--- /dev/null
+++ b/flx-scratch-helm.el
@@ -0,0 +1,69 @@
+(require 'flx)
+(require 'flx-test-list)
+
+(defun helm-mp-flx-propertize (str score)
+ "Return propertized string according to score."
+ (let ((block-started (cadr score))
+ (last-char nil))
+ (loop for char in (cdr score)
+ do (progn
+ (when (and last-char
+ (not (= (1+ last-char) char)))
+ (put-text-property block-started (1+ last-char) 'face
'helm-match str)
+ (setq block-started char))
+ (setq last-char char)))
+ (put-text-property block-started (1+ last-char) 'face 'helm-match str)
+ (format "% [%s]" str (car score))))
+
+(defun flx-helm-candidate-transformer (candidates)
+ "We score candidate and add the score info for later use.
+
+The score info we add here is later removed with another filter."
+ (if (zerop (length helm-pattern))
+ candidates
+ (let* ((mp-3-patterns (helm-mp-3-get-patterns helm-pattern))
+ (flx-pattern (cdar mp-3-patterns))
+ (patterns (cons (cons 'identity
+ (mapconcat
+ #'identity
+ (split-string flx-pattern "" t)
+ ".*"))
+ (cdr mp-3-patterns)))
+ res)
+ (setq res (loop for candidate in candidates
+ for matched = (loop for (predicate . regexp) in patterns
+ always (funcall predicate
(string-match regexp (helm-candidate-get-display candidate))))
+ if matched
+ collect (let ((score (flx-score candidate flx-pattern
flx-file-cache)))
+ (unless (consp candidate)
+ (setq candidate (cons (copy-sequence
candidate) candidate)))
+ (setcdr candidate (cons (cdr candidate) score))
+ candidate)))
+ (sort res
+ (lambda (a b)
+ (> (caddr a) (caddr b))))
+ (loop for item in res
+ for index from 0
+ for score = (cddr item)
+ do (progn
+ ;; highlight first 20 matches
+ (when (and (< index 20) (> (car score) 0))
+ (setcar item (helm-mp-flx-propertize (car item) score)))
+ (setcdr item (cadr item))))
+ res)))
+
+(defun flx-helm-test-candidates ()
+ foo-list)
+
+(setq flx-helm-candidate-list-test
+ '((name . "flx candidate-list-test")
+ (candidates . flx-helm-test-candidates)
+ (candidate-transformer flx-helm-candidate-transformer)
+ (volatile)
+ (match-strict identity)
+ ))
+
+
+(defun flx-helm-demo ()
+ (interactive)
+ (helm :sources '(flx-helm-candidate-list-test)))
diff --git a/flx.el b/flx.el
new file mode 100644
index 0000000000..65d223dcd6
--- /dev/null
+++ b/flx.el
@@ -0,0 +1,268 @@
+;;; credit note: Daniel Skarda ido-speed-hack for bitmap idea
+;;; not necessary as we aren't using bitmap caching
+;;;
+;;;
+;;; credit to scott frazer's blog entry
here:http://scottfrazersblog.blogspot.com.au/2009/12/emacs-better-ido-flex-matching.html
+
+;;; Use defsubst instead of defun
+
+;;; Notes:
+;;;
+;;; * Using bitmaps to check for matches worked out to be SLOWER than just
+;;; scanning the string and using `flx-get-matches'.
+;;;
+;;; * Consing causes GC, which can often slowdown Emacs more than the benefits
+;;; of an optimization.
+;;;
+
+
+
+(eval-when-compile
+ (require 'cl))
+
+(defun flx-get-hash-for-string (str heatmap-func)
+ "Return hash-table for string where keys are characters value
+ is a sorted list of indexes for character occurrences."
+ (let* ((res (make-hash-table :test 'eq :size 32))
+ (str-len (length str))
+ char)
+ (loop for index from (1- str-len) downto 0
+ do (progn
+ (setq char (downcase (aref str index)))
+ (push index (gethash char res))))
+ (puthash 'heatmap (funcall heatmap-func str) res)
+ res))
+
+;;; Do we need more word separators than ST?
+(defsubst flx-is-word (char)
+ "returns t if char is word"
+ (and char
+ (not (memq char '(?\ ?- ?_ ?. ?/ ?\\)))))
+
+(defsubst flx-is-capital (char)
+ "returns t if char is word"
+ (and char
+ (and (<= char ?Z)
+ (<= ?A char))))
+
+(defsubst flx-is-boundary (last-char char)
+ (or (flx-is-capital char)
+ (null last-char)
+ (and (not (flx-is-word last-char))
+ (flx-is-word char))))
+
+(defsubst flx-inc-vec (vec &optional inc beg end)
+ "increment each element of vectory by INC(default=1)
+from BEG (inclusive) to end (not inclusive).
+"
+ (or inc
+ (setq inc 1))
+ (or beg
+ (setq beg 0))
+ (or end
+ (setq end (length vec)))
+ (while (< beg end)
+ (incf (aref vec beg) inc)
+ (incf beg))
+ vec)
+
+;; So we store one fixnum per character. Is this too memory inefficient?
+(defun flx-get-heatmap-str (str &optional group-separator)
+ "Generate heat map vector of string.
+
+See documentation for logic."
+ (let* ((str-len (length str))
+ (str-last-index (1- str-len))
+ ;; ++++ base
+ (scores (make-vector str-len -35))
+ (penalty-lead ?.)
+ (groups-alist (list (list -1 0))))
+ ;; ++++ final char bonus
+ (incf (aref scores str-last-index) 1)
+ ;; Establish baseline mapping
+ (loop for char across str
+ for index from 0
+ with last-char = nil
+ with group-word-count = 0
+ do (progn
+ (let ((effective-last-char
+ ;; before we find any words, all separaters are
+ ;; considered words of length 1. This is so "foo/__ab"
+ ;; gets penalized compared to "foo/ab".
+ (if (zerop group-word-count) nil last-char)))
+ (when (flx-is-boundary effective-last-char char)
+ (setcdr (cdar groups-alist) (cons index (cddar
groups-alist))))
+ (when (and (not (flx-is-word last-char))
+ (flx-is-word char))
+ (incf group-word-count)))
+ ;; ++++ -45 penalize extension
+ (when (eq last-char penalty-lead)
+ (incf (aref scores index) -45))
+ (when (eq group-separator char )
+ (setcar (cdar groups-alist) group-word-count)
+ (setq group-word-count 0)
+ (push (nconc (list index group-word-count)) groups-alist))
+ (if (= index str-last-index)
+ (setcar (cdar groups-alist) group-word-count)
+ (setq last-char char))))
+ (let* ((group-count (length groups-alist))
+ (separator-count (1- group-count)))
+ ;; ++++ slash group-count penalty
+ (unless (zerop separator-count)
+ (flx-inc-vec scores (* -2 group-count)))
+ ;; score each group further
+ (loop for group in groups-alist
+ for index from separator-count downto 0
+ with last-group-limit = nil
+ do (let ((group-start (car group))
+ (word-count (cadr group))
+ ;; this is the number of effective word groups
+ (words-length (length (cddr group)))
+ (basepath-p (not last-group-limit)))
+ (let (num)
+ (setq num
+ (if basepath-p
+ (+ 35
+ ;; ++++ basepath separator-count boosts
+ (if (> separator-count 1)
+ (1- separator-count)
+ 0)
+ ;; ++++ basepath word count penalty
+ (- word-count))
+ ;; ++++ non-basepath penalties
+ (if (= index 0)
+ -3
+ (+ -5 (1- index)))))
+ (flx-inc-vec scores num (1+ group-start) last-group-limit))
+ (loop for word in (cddr group)
+ for word-index from (1- words-length) downto 0
+ with last-word = (or last-group-limit
+ str-len)
+ do (progn
+ (incf (aref scores word)
+ ;; ++++ beg word bonus AND
+ 85)
+ (loop for index from word below last-word
+ for char-i from 0
+ do (incf (aref scores index)
+ (-
+ ;; ++++ word order penalty
+ (* -3 word-index)
+ ;; ++++ char order penalty
+ char-i)))
+ (setq last-word word)))
+ (setq last-group-limit (1+ group-start)))))
+ scores))
+
+(defun flx-get-heatmap-file (filename)
+ "Return heatmap vector for filename."
+ (flx-get-heatmap-str filename ?/))
+
+
+(defsubst flx-bigger-sublist (sorted-list val)
+ "return sublist bigger than VAL from sorted SORTED-LIST
+
+ if VAL is nil, return entire list."
+ (if val
+ (loop for sub on sorted-list
+ do (when (> (car sub) val)
+ (return sub)))
+ sorted-list))
+
+(defun flx-get-matches (hash query &optional greater-than q-index)
+ "Return list of all unique indexes into str where query can match.
+
+That is all character sequences of query that occur in str are returned.
+
+HASH accept as the cached analysis of str.
+sstr
+e.g. (\"aab\" \"ab\") returns
+ '((0 2) (1 2)
+"
+
+ (setq q-index (or q-index 0))
+ (let* ((q-char (aref query q-index))
+ (indexes (flx-bigger-sublist
+ (gethash q-char hash) greater-than)))
+ (if (< q-index (1- (length query)))
+ (apply ; `mapcan'
+ 'nconc
+ (mapcar
+ (lambda (index)
+ (let ((next-matches-for-rest (flx-get-matches hash query index
(1+ q-index))))
+ (when next-matches-for-rest
+ (mapcar (lambda (match)
+ (cons index match))
+ next-matches-for-rest))))
+ indexes))
+ (mapcar 'list indexes))))
+
+(defun flx-make-filename-cache ()
+ "Return cache hashtable appropraite for storeing filenames."
+ (flx-make-string-cache 'flx-get-heatmap-file))
+
+(defun flx-make-string-cache (&optional heat-func)
+ "Return cache hashtable appropraite for storeing strings."
+ (let ((hash (make-hash-table :test 'equal
+ :size 4096)))
+ (puthash 'heatmap-func (or heat-func 'flx-get-heatmap-str) hash)
+ hash))
+
+(defun flx-process-cache (str cache)
+ "Get calculated heatmap from cache, add it if necessary."
+ (let ((res (when cache
+ (gethash str cache))))
+ (or res
+ (progn
+ (setq res (flx-get-hash-for-string
+ str
+ (or (and cache (gethash 'heatmap-func cache))
+ 'flx-get-heatmap-str)))
+ (when cache
+ (puthash str res cache))
+ res))))
+
+
+(defun flx-score (str query &optional cache)
+ "return best score matching QUERY against STR"
+ (unless (or (zerop (length query))
+ (zerop (length str)))
+ (let* ((info-hash (flx-process-cache str cache))
+ (heatmap (gethash 'heatmap info-hash))
+ (matches (flx-get-matches info-hash query))
+ (best-score nil))
+ (mapc (lambda (match-vector)
+ (let ((score 0)
+ (contiguous-count 0)
+ last-match)
+ (loop for index in match-vector
+ do (progn
+ (if (and last-match
+ (= (1+ last-match) index))
+ (incf contiguous-count)
+ (setq contiguous-count 0))
+ (incf score (aref heatmap index))
+ (when (> contiguous-count 0)
+ (incf score (+ 45 (* 15 (min contiguous-count
4)))))
+ (setq last-match index)))
+ (if (or (null best-score)
+ (> score (car best-score)))
+ (setq best-score (cons score match-vector)))))
+ matches)
+ best-score)))
+
+
+(defvar flx-file-cache (flx-make-filename-cache)
+ "Cached heatmap info about strings.")
+
+(defvar flx-strings-cache (flx-make-string-cache)
+ "Cached heatmap info about filenames.")
+
+
+
+(provide 'flx)
+
+
+;;; macro expanded
+
+
