Score flex-style completions according to match tightness

The new completion style needs to score completion matches so that we
can use it later on when sorting the completions.  This is because, in
the flex style, "foo" can now match "foobar", "frodo" and
"barfromsober" but we probably want "foobar" to appear at the top of
the completion list.

This change makes the new flex completion style add sort-order hints
under the completion string's `completion-style-sort-order' property.

* lisp/minibuffer.el (completion-pcm--hilit-commonality): Propertize
completion with 'completion-pcm-commonality-score.
(completion-flx-all-completions): Propertize completion with
completion-style-sort-order and completion-style-annotation.

lisp/minibuffer.el

@@ -788,6 +788,11 @@ Additionally the user can use the char \"*\" as a glob pattern.")
 I.e. when completing \"foo_bar\" (where _ is the position of point),
 it will consider all completions candidates matching the glob
 pattern \"*foo*bar*\".")
+    (flex
+     completion-flex-try-completion completion-flex-all-completions
+     "Completion of an in-order subset of characters.
+When completing \"foo\" the glob \"*f*o*o*\" is used, so that
+i.e. foo can complete to frodo.")
     (initials
      completion-initials-try-completion completion-initials-all-completions
      "Completion of acronyms and initialisms.
@@ -3051,20 +3056,38 @@ PATTERN is as returned by `completion-pcm--string->pattern'."
          (let* ((pos (if point-idx (match-beginning point-idx) (match-end 0)))
                 (md (match-data))
                 (start (pop md))
-                (end (pop md)))
+                (end (pop md))
+                (len (length str))
+                (score-numerator 0)
+                (score-denominator 0)
+                (aux 0)
+                (update-score
+                 (lambda (a b)
+                   "Update score variables given match range (A B)."
+                   (setq
+                    score-numerator   (+ score-numerator (- b a))
+                    score-denominator (+ score-denominator (expt (- a aux) 1.5))
+                    aux              b))))
+           (funcall update-score 0 start)
            (while md
-             (put-text-property start (pop md)
+             (funcall update-score start (car md))
+             (put-text-property start
+                                (pop md)
                                 'font-lock-face 'completions-common-part
                                 str)
              (setq start (pop md)))
            (put-text-property start end
                               'font-lock-face 'completions-common-part
                               str)
+           (funcall update-score start end)
            (if (> (length str) pos)
                (put-text-property pos (1+ pos)
-				  'font-lock-face 'completions-first-difference
-				  str)))
-	 str)
+                                  'font-lock-face 'completions-first-difference
+                                  str))
+           (put-text-property
+            0 1 'completion-pcm-commonality-score
+            (/ score-numerator (* len (1+ score-denominator)) 1.0) str))
+         str)
        completions))))
 
 (defun completion-pcm--find-all-completions (string table pred point
@@ -3345,7 +3368,12 @@ the same set of elements."
 ;;; Substring completion
 ;; Mostly derived from the code of `basic' completion.
 
-(defun completion-substring--all-completions (string table pred point)
+(defun completion-substring--all-completions
+    (string table pred point &optional transform-pattern-fn)
+  "Match the presumed substring STRING to the entries in TABLE.
+Respect PRED and POINT.  The pattern used is a PCM-style
+substring pattern, but it be massaged by TRANSFORM-PATTERN-FN, if
+that is non-nil."
   (let* ((beforepoint (substring string 0 point))
          (afterpoint (substring string point))
          (bounds (completion-boundaries beforepoint table pred afterpoint))
@@ -3356,6 +3384,9 @@ the same set of elements."
          (pattern (if (not (stringp (car basic-pattern)))
                       basic-pattern
                     (cons 'prefix basic-pattern)))
+         (pattern (if transform-pattern-fn
+                      (funcall transform-pattern-fn pattern)
+                    pattern))
          (all (completion-pcm--all-completions prefix pattern table pred)))
     (list all pattern prefix suffix (car bounds))))
 
@@ -3375,6 +3406,66 @@ the same set of elements."
       (nconc (completion-pcm--hilit-commonality pattern all)
              (length prefix)))))
 
+;;; "flex" completion, also known as flx/fuzzy/scatter completion
+;; Completes "foo" to "frodo" and "farfromsober"
+
+(defun completion-flex--make-flex-pattern (pattern)
+  "Convert PCM-style PATTERN into PCM-style flex pattern.
+
+This turns
+    (prefix \"foo\" point)
+into
+    (prefix \"f\" any \"o\" any \"o\" star point)
+which is at the core of flex logic.  The extra
+'any' is optimized away later on."
+  (mapcan (lambda (elem)
+            (if (stringp elem)
+                (mapcan (lambda (char)
+                          (list (string char) 'any))
+                        elem)
+              (list elem)))
+          pattern))
+
+(defun completion-flex-try-completion (string table pred point)
+  "Try to flex-complete STRING in TABLE given PRED and POINT."
+  (pcase-let ((`(,all ,pattern ,prefix ,suffix ,_carbounds)
+               (completion-substring--all-completions
+                string table pred point
+                #'completion-flex--make-flex-pattern)))
+    (if minibuffer-completing-file-name
+        (setq all (completion-pcm--filename-try-filter all)))
+    (cond ((not (consp all))
+           all)
+          ((not (consp (cdr all))) ; single completion
+           (if (equal string (car all))
+               t
+             (cons (car all) (length (car all)))))
+          (t
+           ;; If more than one completion, try some "merging".
+           ;; Meaning add as much as possible to the user's
+           ;; pattern without losing any possible matches in
+           ;; `all'.  If that fails, leave user input
+           ;; untouched.
+           (let ((probe (completion-pcm--merge-try pattern all prefix suffix)))
+             (if (stringp probe)
+                 (cons probe (length probe))
+               (cons string point)))))))
+
+(defun completion-flex-all-completions (string table pred point)
+  "Get flex-completions of STRING in TABLE, given PRED and POINT."
+  (pcase-let ((`(,all ,pattern ,prefix ,_suffix ,_carbounds)
+               (completion-substring--all-completions
+                string table pred point
+                #'completion-flex--make-flex-pattern)))
+    (when all
+      (let ((hilighted (completion-pcm--hilit-commonality pattern all)))
+        (mapc
+         (lambda (comp)
+           (let ((score (get-text-property 0 'completion-pcm-commonality-score comp)))
+             (put-text-property 0 1 'completion-style-sort-order (- score) comp)))
+         hilighted)
+        (nconc hilighted (length prefix))))))
+
 ;; Initials completion
 ;; Complete /ums to /usr/monnier/src or lch to list-command-history.