RE: char equivalence classes in search - why not symmetric?

[Drew Adams <drew.adams@oracle.com>]

[-- Attachment #1: Type: text/plain, Size: 1707 bytes --]

Yesterday I said:

 > 2. The code I have is not sufficient for everything.  You can
 > use it to see what the behavior is for single-char entries in the
 > char table, which includes accented chars (chars with diacritics).
 > But it does not also handle multiple-char entries in the table.
 > 
 > For instance, you can search for "é" and get char folding, but you
 > cannot search for "é" and get char folding.  The first of these is
 > just the char named LATIN SMALL LETTER E WITH ACUTE.  The second is
 > plain "e" composed with "́" (the char named COMBINING ACUTE ACCENT).
 > 
 > Some more work would be needed to make such combinations work too.
 > As I said, I'm no expert on char tables.  But the attached code
 > should give you a good idea of what is involved.

The attached version seems to take care of this, so you can search
with, say, the decomposition "é" and get the same effect as
searching for the fully composed char "é".

Again, just load the file, to try it out.  Remember that M-s '
toggles char folding.

At the end of the file there are a few strings you can use to test.
When you see two consecutive strings there that look the same, the
first is a decomposition, and the second is the same char fully
composed.

For example: "é" "é".  (The first string is two chars, however it
might be displayed.)

`C-u C-x =' on the first char of the first string tells you:
LATIN SMALL LETTER E, decomposition: (101) ('e')
and on the second char it tells you:
COMBINING ACUTE ACCENT, decomposition: (769) ('́').

`C-u C-x =' on the single char of the second string tells you:
LATIN SMALL LETTER E WITH ACUTE, decomposition: (101 769) ('e' '́')

[-- Attachment #2: symmetric-char-fold.el --]
[-- Type: application/octet-stream, Size: 7320 bytes --]

(setq character-fold-search t)
(load-library "character-fold")

(defvar char-fold-decomps ()
  "List of conses of a decomposition and its base char.")

(defun update-char-fold-table ()
  "Update the value of variable `character-fold-table'.
The new value reflects the current value of `char-fold-symmetric'."
  (setq char-fold-decomps  ())
  (setq character-fold-table
        (let* ((equiv  (make-char-table 'character-fold-table))
               (table  (unicode-property-table-internal 'decomposition))
               (func   (char-table-extra-slot table 1)))
          ;; Ensure the table is populated.
          (map-char-table (lambda (i v) (when (consp i) (funcall func (car i) v table)))
                          table)
          ;; Compile a list of all complex chars that each simple char should match.
          (map-char-table
           (lambda (i dec)
             (when (consp dec)
               ;; Discard a possible formatting tag.
               (when (symbolp (car dec))
                 (setq dec  (cdr dec)))
               ;; Skip trivial cases like ?a decomposing to (?a).
               (unless (and (eq i (car dec))  (not  (cdr dec)))
                 (let ((d            dec)
                       (fold-decomp  t)
                       k found)
                   (while (and d  (not found))
                     (setq k  (pop d))
                     ;; Is k a number or letter, per unicode standard?
                     (setq found  (memq (get-char-code-property k 'general-category)
                                        '(Lu Ll Lt Lm Lo Nd Nl No))))
                   (if found
                       ;; Check if the decomposition has more than one letter,
                       ;; because then we don't want the first letter to match
                       ;; the decomposition.
                       (dolist (k d)
                         (when (and fold-decomp
                                    (memq (get-char-code-property k 'general-category)
                                          '(Lu Ll Lt Lm Lo Nd Nl No)))
                           (setq fold-decomp  nil)))
                     ;; If there's no number or letter on the
                     ;; decomposition, take the first character in it.
                     (setq found  (car-safe dec)))
                   ;; Finally, we only fold multi-char decomposition if at
                   ;; least one of the chars is non-spacing (combining).
                   (when fold-decomp
                     (setq fold-decomp  nil)
                     (dolist (k  dec)
                       (when (and (not fold-decomp)
                                  (> (get-char-code-property k 'canonical-combining-class) 0))
                         (setq fold-decomp  t))))
                   ;; Add i to the list of characters that k can
                   ;; represent. Also possibly add its decomposition, so we can
                   ;; match multi-char representations like (format "a%c" 769)
                   (when (and found  (not (eq i k)))
                     (let ((chr-strgs  (cons (char-to-string i) (aref equiv k))))
                       (aset equiv k (if fold-decomp
                                         (cons (apply #'string dec) chr-strgs)
                                       chr-strgs))))))))
           table)
          ;; Add some manual entries.
          (dolist (it '((?\" "＂" "“" "”" "”" "„" "⹂" "〞" "‟" "‟" "❞" "❝"
                         "❠" "“" "„" "〝" "〟" "🙷" "🙶" "🙸" "«" "»")
                        (?' "❟" "❛" "❜" "‘" "’" "‚" "‛" "‚" "󠀢" "❮" "❯" "‹" "›")
                        (?` "❛" "‘" "‛" "󠀢" "❮" "‹")))
            (let ((idx        (car it))
                  (chr-strgs  (cdr it)))
              (aset equiv idx (append chr-strgs (aref equiv idx)))))

          ;; --------8<------the only addition----------------
          (when char-fold-symmetric
            ;; Add an entry for each equivalent char.
            (let ((others  ()))
              (map-char-table
               (lambda (base v)
                 (let ((chr-strgs  (aref equiv base)))
                   (when (consp chr-strgs)
                     (dolist (strg  (cdr chr-strgs))
                       (if (< (length strg) 2)
                           (push (cons (string-to-char strg) (remove strg chr-strgs)) others)
                         ;; A decomposition.  Add it and its base char to `char-fold-decomps'.
                         (push (cons strg (char-to-string base)) char-fold-decomps))))))
               equiv)
              (dolist (it  others)
                (let ((base       (car it))
                      (chr-strgs  (cdr it)))
                  (aset equiv base (append chr-strgs (aref equiv base)))))))
          ;; --------8<---------------------------------------

          ;; Convert the lists of characters we compiled into regexps.
          (map-char-table
           (lambda (i v) (let ((re  (regexp-opt (cons (char-to-string i) v))))
                      (if (consp i)
                          (set-char-table-range equiv i re)
                        (aset equiv i re))))
           equiv)
          equiv)))

(defun character-fold-to-regexp (string &optional lax)
  "Return a regexp matching anything that character-folds into STRING.
If `character-fold-search' is nil, just `regexp-quote' STRING.
Otherwise:

Replace any decompositions in `character-fold-table' by their base
chars, so search will match all equivalents.  Then replace any chars
in STRING that have entries in `character-fold-table' by their
entries (which are regexps), and replace other chars in STRING by
`regexp-quote' applied to them.

Non-nil LAX means any whitespace char can match any number of times."
  (if (not character-fold-search)
      (regexp-quote string)
    (when char-fold-decomps
      (dolist (decomp  char-fold-decomps)
        (setq string  (replace-regexp-in-string
                       (regexp-quote (car decomp)) (cdr decomp) string 'FIXED-CASE 'LITERAL))))
    (apply #'concat
           (mapcar (lambda (c) (if (and lax (memq c '(?\s ?\t ?\r ?\n)))
                              "[ \t\n\r\xa0\x2002\x2d\x200a\x202f\x205f\x3000]+"
                            (or (aref character-fold-table c)
                                (regexp-quote (string c)))))
                   string))))

(defcustom char-fold-symmetric t
  "Non-nil means char-fold searching treats equivalent chars the same.
That is, use of any of a set of char-fold equivalent chars in a search
string finds any of them in the text being searched.

If nil then only the \"base\" or \"canonical\" char of the set matches
any of them.  The others match only themselves, even when char-folding
is turned on."
  :set (lambda (sym defs)
         (custom-set-default sym defs)
         (update-char-fold-table))
  :type 'boolean :group 'isearch)

;; Test by searching for these strings.
;; ("𝚎" "𝙚" "𝘦" "𝗲" "𝖾" "𝖊" "𝕖" "𝔢" "𝓮" "𝒆" "𝑒" "𝐞" "ｅ" "㋎" "㋍" "ⓔ" "⒠"
;;  "ⅇ" "ℯ" "ₑ" "ẽ" "ẽ" "ẻ" "ẻ" "ẹ" "ẹ" "ḛ" "ḛ" "ḙ" "ḙ" "ᵉ" "ȩ" "ȩ" "ȇ" "ȇ"
;; "ȅ" "ȅ" "ě" "ě" "ę" "ę" "ė" "ė" "ĕ" "ĕ" "ē" "ē" "ë" "ë" "ê" "ê" "é" "é" "è" "è")