[nongnu] elpa/flx 6189f05c7e 004/182: add flx, ido implementation and helm experiment

[ELPA Syncer]

branch: elpa/flx
commit 6189f05c7e45688f0e83e28941bf6b6914b75b95
Author: Le Wang <le.wang@agworld.com.au>
Commit: Le Wang <le.wang@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
+
+