[nongnu] elpa/flx e80bc0dea4 018/182: more ido optimizations, refactor out flx-propertize

[ELPA Syncer]

branch: elpa/flx
commit e80bc0dea4dfa954feb5a314aeb6db7b71c811bf
Author: Le Wang <le.wang@agworld.com.au>
Commit: Le Wang <le.wang@agworld.com.au>

    more ido optimizations, refactor out flx-propertize
---
 flx-ido.el          | 192 ++++++++++++++++++++++++++++++++--------------------
 flx-scratch-helm.el |  16 +----
 flx.el              |  35 +++++++---
 ido-demo.el         |  20 ++++++
 4 files changed, 165 insertions(+), 98 deletions(-)

diff --git a/flx-ido.el b/flx-ido.el
index 9217da773c..29cef169f8 100644
--- a/flx-ido.el
+++ b/flx-ido.el
@@ -1,56 +1,132 @@
+;;; flx-ido.el --- flx integration for ido
+
+;; this file is not part of Emacs
+
+;; Copyright (C) 2013 Le Wang
+;; Author: Le Wang
+;; Maintainer: Le Wang
+;; Description: flx integration for ido
+;; Author: Le Wang
+;; Maintainer: Le Wang
+
+;; Created: Sun Apr 21 20:38:36 2013 (+0800)
+;; Version: 0.1
+;; Last-Updated:
+;;           By:
+;;     Update #: 1
+;; URL:
+;; Keywords:
+;; Compatibility:
+
+;;; Installation:
+
+;;
+;;
+;;
+
+;;; Commentary:
+
+;;
+;;
+;;
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 3, or
+;; (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth
+;; Floor, Boston, MA 02110-1301, USA.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
 ;;;
 ;;; credit to Scott Frazer's blog entry 
here:http://scottfrazersblog.blogspot.com.au/2009/12/emacs-better-ido-flex-matching.html
 ;;;
 
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
 (require 'ido)
 (require 'flx)
 
-;;; dynamically bound by ido
-(defvar hist)
-
 (defvar flx-ido-narrowed-matches-hash (make-hash-table :test 'equal))
 
-(defun flx-ido-narrowed (query)
+(defun flx-ido-narrowed (query items)
   "Get the value from `flx-ido-narrowed-matches-hash' with the
   longest prefix match."
-  (let (best-match)
-    (loop for key being the hash-key of flx-ido-narrowed-matches-hash
-          do (when (and (>= (length query) (length key))
-                        (eq t
-                            (compare-strings query 0 nil
-                                             key 0 nil))
-                        (> (length key) (length best-match)))
-               (setq best-match key)
-               (when (= (length key)
-                      (length query))
-                 (return))))
-    (and best-match
-         (gethash best-match flx-ido-narrowed-matches-hash))))
+  (if (zerop (length query))
+      (list t (flx-ido-undecorate items))
+    (let (best-match
+          exact
+          res)
+      (loop for key being the hash-key of flx-ido-narrowed-matches-hash
+            do (when (and (>= (length query) (length key))
+                          (eq t
+                              (compare-strings query 0 (min (length query)
+                                                            (length key))
+                                               key 0 nil))
+                          (> (length key) (length best-match)))
+                 (setq best-match key)
+                 (when (= (length key)
+                          (length query))
+                   (setq exact t)
+                   (return))))
+      (setq res (cond (exact
+                       (gethash best-match flx-ido-narrowed-matches-hash))
+                      (best-match
+                       (flx-ido-undecorate (gethash best-match 
flx-ido-narrowed-matches-hash)))
+                      (t
+                       (flx-ido-undecorate items))))
+      (list exact res))))
+
+(defun flx-ido-undecorate (strings)
+  (flx-ido-decorate strings t))
+
+
+(defun flx-ido-decorate (things &optional clear)
+  (let ((decorate-count (min ido-max-prospects
+                             (length things))))
+    (nconc
+     (loop for thing in things
+           for i from 0 below decorate-count
+           collect (if clear
+                       (substring-no-properties thing)
+                     ;; copy the string in case it's "pure"
+                     (flx-propertize (copy-sequence (car thing)) (cdr thing))))
+     (if clear
+         (nthcdr decorate-count things)
+       (mapcar 'car (nthcdr decorate-count things))))))
 
 (defun flx-ido-match (query items)
   "Better sorting for flx ido matching."
-  (if (zerop (length query))
-      items
-    (let ((existing (gethash query flx-ido-narrowed-matches-hash)))
-      (or existing
-          (let* ((narrowed-items (or (flx-ido-narrowed query)
-                                     items))
-                 (matches (loop for item in narrowed-items
-                                for score = (flx-score item query 
flx-file-cache)
-                                if score
-                                collect (cons item (car score)) into matches
-                                finally return matches))
-                 res)
-            (setq res (mapcar
-                       'car
-                       (if ido-rotate
-                           matches
-                         (sort matches
-                               (lambda (x y) (> (cdr x) (cdr y)))))))
-            (puthash query res flx-ido-narrowed-matches-hash))))))
+  (destructuring-bind (exact items)
+      (flx-ido-narrowed query items)
+    (if exact                         ; `ido-rotate' case is covered by exact 
match
+        items
+      (let* ((matches (loop for item in items
+                            for score = (flx-score item query flx-file-cache)
+                            if score
+                            collect (cons item score)
+                            into matches
+                            finally return matches))
+             res)
+        (setq res (flx-ido-decorate (sort matches
+                                          (lambda (x y) (> (cadr x) (cadr 
y))))))
+        (puthash query res flx-ido-narrowed-matches-hash)))))
 
 (defvar flx-ido-use t
-  "*Use flx matching for ido.")
+  "Use flx matching for ido.")
 
 (defadvice ido-read-internal (before flx-ido-reset-hash activate)
   "clear our narrowed hash."
@@ -58,47 +134,15 @@
 
 (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
+  (if (and flx-ido-use
+           ido-enable-flex-matching)
       (setq ad-return-value (flx-ido-match ido-text (ad-get-arg 0)))
     ad-do-it))
 
+(provide 'flx-ido)
 
-(setq ido-enable-flex-matching t)
-
-(defun ido-demo ()
-  (interactive)
-  (require 'flx-test-list)
-  (ido-completing-read ": " foo-list))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;; 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)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; flx-ido.el ends here
 
-(provide 'flx-ido)
diff --git a/flx-scratch-helm.el b/flx-scratch-helm.el
index 61b9a8b569..34fb4d17fe 100644
--- a/flx-scratch-helm.el
+++ b/flx-scratch-helm.el
@@ -1,20 +1,6 @@
 (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 [%s]" str (car score))))
-
 (defun flx-helm-candidate-transformer (candidates)
   "We score candidate and add the score info for later use.
 
@@ -48,7 +34,7 @@ The score info we add here is later removed with another 
filter."
             do (progn
                  ;; highlight first 20 matches
                  (when (and (< index 20) (> (car score) 0))
-                   (setcar item (helm-mp-flx-propertize (car item) score)))
+                   (setcar item (flx-propertize (car item) score 'add-score)))
                  (setcdr item (cadr item))))
       res)))
 
diff --git a/flx.el b/flx.el
index 10a2ddc599..350adf8fb5 100644
--- a/flx.el
+++ b/flx.el
@@ -1,6 +1,3 @@
-
-
-
 ;;; flx.el --- fuzzy matching with good sorting
 
 ;; this file is not part of Emacs
@@ -16,7 +13,7 @@
 ;; Version: 0.1
 ;; Last-Updated:
 ;;           By:
-;;     Update #: 1
+;;     Update #: 3
 ;; URL:
 ;; Keywords:
 ;; Compatibility:
@@ -54,14 +51,10 @@
 
 ;;; Code:
 
-(eval-when-compile (require 'cl))
 
 
-;;; 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
+;;; credit to ido-hacks for ido optimization
 
 ;;; Use defsubst instead of defun
 
@@ -74,6 +67,12 @@
 ;;;   of an optimization.
 ;;;
 
+(eval-when-compile (require 'cl))
+
+(defface flx-highlight-face  '((t (:inherit font-lock-variable-name-face :bold 
t :underline t)))
+  "Face used by flx for highlighting flx match characters."
+  :group 'flx)
+
 
 (defun flx-get-hash-for-string (str heatmap-func)
   "Return hash-table for string where keys are characters value
@@ -307,6 +306,24 @@ e.g. (\"aab\" \"ab\") returns
       best-score)))
 
 
+(defun flx-propertize (str score &optional add-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 
'flx-highlight-face str)
+                 (setq block-started char))
+               (setq last-char char)))
+    (put-text-property block-started  (1+ last-char) 'face 'flx-highlight-face 
str)
+    (when add-score
+      (setq str (format "%s [%s]" str (car score))))
+    str))
+
+
+
 (defvar flx-file-cache (flx-make-filename-cache)
   "Cached heatmap info about strings.")
 
diff --git a/ido-demo.el b/ido-demo.el
new file mode 100644
index 0000000000..9321772f8b
--- /dev/null
+++ b/ido-demo.el
@@ -0,0 +1,20 @@
+(require 'flx-ido)
+(require 'flx-test-list)
+
+(defun ido-demo ()
+  (interactive)
+  (require 'flx-test-list)
+  (ido-completing-read ": " foo-list))
+
+(defun ido-big-demo (max)
+  (interactive "P")
+  (setq max (or max
+                most-positive-fixnum))
+  (let* ((names (loop for i in (ucs-names)
+                      for stop below max
+                      collect (car i)))
+         (names-length (length names)))
+    (ido-completing-read (format "ucs (%s total): " names-length)
+                         names)))
+
+(provide 'flx-ido-demo)
\ No newline at end of file