ids-find.el

   1 ;;; ids-find.el --- search utility based on Ideographic-structures
   2
   3 ;; Copyright (C) 2002,2003,2005,2006,2007,2017 MORIOKA Tomohiko
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
   6 ;; Keywords: Kanji, Ideographs, search, IDS, CHISE, UCS, Unicode
   7
   8 ;; This file is a part of CHISE IDS.
   9
  10 ;; This program is free software; you can redistribute it and/or
  11 ;; modify it under the terms of the GNU General Public License as
  12 ;; published by the Free Software Foundation; either version 2, or (at
  13 ;; your option) any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with this program; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Code:
  26
  27 (defun ids-index-store-char (product component)
  28   (let ((ret (get-char-attribute component 'ideographic-products)))
  29     (unless (memq product ret)
  30       (put-char-attribute component 'ideographic-products
  31                           (cons product ret))
  32       (when (setq ret (char-feature component 'ideographic-structure))
  33         (ids-index-store-structure product ret)))
  34     ))
  35
  36 (defun ids-index-store-structure (product structure)
  37   (let (ret)
  38     (dolist (cell (cdr structure))
  39       (if (char-ref-p cell)
  40           (setq cell (plist-get cell :char)))
  41       (cond ((characterp cell)
  42              (ids-index-store-char product cell))
  43             ((setq ret (assq 'ideographic-structure cell))
  44              (ids-index-store-structure product (cdr ret)))
  45             ((setq ret (find-char cell))
  46              (ids-index-store-char product ret))
  47             ))))
  48
  49 ;;;###autoload
  50 (defun ids-update-index ()
  51   (interactive)
  52   (map-char-attribute
  53    (lambda (c v)
  54      (ids-index-store-structure c v)
  55      nil)
  56    'ideographic-structure)
  57   (save-char-attribute-table 'ideographic-products))
  58
  59
  60 (mount-char-attribute-table 'ideographic-products)
  61
  62 ;;;###autoload
  63 (defun ids-find-all-products (char)
  64   (let (dest)
  65     (dolist (cell (char-feature char 'ideographic-products))
  66       (unless (memq cell dest)
  67         (setq dest (cons cell dest)))
  68       (setq dest (union dest (ids-find-all-products cell))))
  69     dest))
  70
  71 (defun of-component-features ()
  72   (let (dest)
  73     (dolist (feature (char-attribute-list))
  74       (when (string-match "^<-.*[@/]component\\(/[^*/]+\\)*$"
  75                           (symbol-name feature))
  76         (push feature dest)))
  77     (list* '<-mistakable '->mistakable
  78            '<-formed '->formed
  79            dest)))
  80
  81 (defun to-component-features ()
  82   (let (dest)
  83     (dolist (feature (char-attribute-list))
  84       (when (string-match "^->.*[@/]component\\(/[^*/]+\\)*$"
  85                           (symbol-name feature))
  86         (push feature dest)))
  87     dest))
  88
  89 ;;;###autoload
  90 (defun char-component-variants (char)
  91   (let ((dest (list char))
  92         ret uchr)
  93     (dolist (feature (to-component-features))
  94       (if (setq ret (get-char-attribute char feature))
  95           (dolist (c ret)
  96             (setq dest (union dest (char-component-variants c))))))
  97     (cond
  98      ;; ((setq ret (some (lambda (feature)
  99      ;;                    (get-char-attribute char feature))
 100      ;;                  (to-component-features)))
 101      ;;  (dolist (c ret)
 102      ;;    (setq dest (union dest (char-component-variants c))))
 103      ;;  )
 104      ((setq ret (get-char-attribute char '->ucs-unified))
 105       (setq dest (cons char ret))
 106       (dolist (c dest)
 107         (setq dest (union dest
 108                           (some (lambda (feature)
 109                                   (get-char-attribute c feature))
 110                                 (of-component-features))
 111                           )))
 112       )
 113      ((and (setq ret (get-char-attribute char '=>ucs))
 114            (setq uchr (decode-char '=ucs ret)))
 115       (setq dest (cons uchr (char-variants uchr)))
 116       (dolist (c dest)
 117         (setq dest (union dest
 118                           (some (lambda (feature)
 119                                   (get-char-attribute c feature))
 120                                 (of-component-features))
 121                           )))
 122       )
 123      (t
 124       (map-char-family
 125        (lambda (c)
 126          (unless (memq c dest)
 127            (setq dest (cons c dest)))
 128          (setq dest
 129                (union dest
 130                       (some (lambda (feature)
 131                               (char-feature c feature))
 132                             (of-component-features))
 133                       ))
 134          nil)
 135        char)
 136       ))
 137     dest))
 138
 139 ;;;###autoload
 140 (defun ideographic-products-find (&rest components)
 141   (if (stringp (car components))
 142       (setq components (string-to-char-list (car components))))
 143   (let (dest products)
 144     (dolist (variant (char-component-variants (car components)))
 145       (setq products
 146             (union products
 147                    (get-char-attribute variant 'ideographic-products))))
 148     (setq dest products)
 149     (while (and dest
 150                 (setq components (cdr components)))
 151       (setq products nil)
 152       (dolist (variant (char-component-variants (car components)))
 153         (setq products
 154               (union products
 155                      (get-char-attribute variant 'ideographic-products))))
 156       (setq dest (intersection dest products)))
 157     dest))
 158
 159 (defun ideograph-find-products-with-variants (components &optional ignored-chars)
 160   (if (stringp components)
 161       (setq components (string-to-char-list components)))
 162   (let (dest products)
 163     (dolist (variant (char-component-variants (car components)))
 164       (setq products
 165             (union products
 166                    (set-difference
 167                     (get-char-attribute variant 'ideographic-products)
 168                     ignored-chars))))
 169     (setq dest products)
 170     (while (and dest
 171                 (setq components (cdr components)))
 172       (setq products nil)
 173       (dolist (variant (char-component-variants (car components)))
 174         (setq products
 175               (union products
 176                      (set-difference
 177                       (get-char-attribute variant 'ideographic-products)
 178                       ignored-chars))))
 179       (setq dest (intersection dest products)))
 180     dest))
 181
 182 (defun ideograph-find-products (components &optional ignored-chars)
 183   (if (stringp components)
 184       (setq components (string-to-char-list components)))
 185   (let (dest products)
 186     ;; (dolist (variant (char-component-variants (car components)))
 187     ;;   (setq products
 188     ;;         (union products
 189     ;;                (get-char-attribute variant 'ideographic-products))))
 190     ;; (setq dest products)
 191     (setq dest (get-char-attribute (car components) 'ideographic-products))
 192     (while (and dest
 193                 (setq components (cdr components)))
 194       ;; (setq products nil)
 195       ;; (dolist (variant (char-component-variants (car components)))
 196       ;;   (setq products
 197       ;;         (union products
 198       ;;                (get-char-attribute variant 'ideographic-products))))
 199       (setq products (get-char-attribute (car components) 'ideographic-products))
 200       (setq dest (intersection dest products)))
 201     dest))
 202
 203
 204 (defun ideographic-structure-char= (c1 c2)
 205   (or (eq c1 c2)
 206       (and c1 c2
 207            (let ((m1 (char-ucs c1))
 208                  (m2 (char-ucs c2)))
 209              (or (and m1 m2
 210                       (eq m1 m2))
 211                  (memq c1 (char-component-variants c2)))))))
 212
 213 (defun ideographic-structure-member-compare-components (component s-component)
 214   (let (ret)
 215     (cond ((char-ref= component s-component #'ideographic-structure-char=))
 216           ((listp s-component)
 217            (if (setq ret (assq 'ideographic-structure s-component))
 218                (ideographic-structure-member component (cdr ret))))
 219           ((setq ret (get-char-attribute s-component 'ideographic-structure))
 220            (ideographic-structure-member component ret)))))
 221
 222 ;;;###autoload
 223 (defun ideographic-structure-member (component structure)
 224   "Return non-nil if COMPONENT is included in STRUCTURE."
 225   (or (memq component structure)
 226       (progn
 227         (setq structure (cdr structure))
 228         (ideographic-structure-member-compare-components
 229          component (car structure)))
 230       (progn
 231         (setq structure (cdr structure))
 232         (ideographic-structure-member-compare-components
 233          component (car structure)))
 234       (progn
 235         (setq structure (cdr structure))
 236         (and (car structure)
 237              (ideographic-structure-member-compare-components
 238               component (car structure))))))
 239
 240
 241 ;;;###autoload
 242 (defun ideographic-structure-repertoire-p (structure components)
 243   "Return non-nil if STRUCTURE can be constructed by a subset of COMPONENTS."
 244   (and structure
 245        (let (ret s-component)
 246          (catch 'tag
 247            (while (setq structure (cdr structure))
 248              (setq s-component (car structure))
 249              (unless (characterp s-component)
 250                (if (setq ret (find-char s-component))
 251                    (setq s-component ret)))
 252              (unless (cond
 253                       ((listp s-component)
 254                        (if (setq ret (assq 'ideographic-structure s-component))
 255                            (ideographic-structure-repertoire-p
 256                             (cdr ret) components)))
 257                       ((member* s-component components
 258                                 :test #'ideographic-structure-char=))
 259                       ((setq ret
 260                              (get-char-attribute s-component
 261                                                  'ideographic-structure))
 262                        (ideographic-structure-repertoire-p ret components)))
 263                (throw 'tag nil)))
 264            t))))
 265
 266
 267 (defvar ids-find-result-buffer "*ids-chars*")
 268
 269 (defun ids-find-format-line (c v)
 270   (format "%c\t%s\t%s\n"
 271           c
 272           (or (let ((ucs (or (char-ucs c)
 273                              (encode-char c 'ucs))))
 274                 (if ucs
 275                     (cond ((<= ucs #xFFFF)
 276                            (format "    U+%04X" ucs))
 277                           ((<= ucs #x10FFFF)
 278                            (format "U-%08X" ucs)))))
 279               "          ")
 280           (or (ideographic-structure-to-ids v)
 281               v)))
 282
 283 (defun ids-insert-chars-including-components* (components
 284                                                &optional level ignored-chars)
 285   (unless level
 286     (setq level 0))
 287   (let (is i as bs)
 288     (dolist (c (sort (copy-tree (ideograph-find-products components
 289                                                          ignored-chars))
 290                      (lambda (a b)
 291                        (if (setq as (char-total-strokes a))
 292                            (if (setq bs (char-total-strokes b))
 293                                (if (= as bs)
 294                                    (ideograph-char< a b)
 295                                  (< as bs))
 296                              t)
 297                          (ideograph-char< a b)))))
 298       (unless (memq c ignored-chars)
 299         (setq is (char-feature c 'ideographic-structure))
 300         (setq i 0)
 301         (while (< i level)
 302           (insert "\t")
 303           (setq i (1+ i)))
 304         (insert (ids-find-format-line c is))
 305         (setq ignored-chars
 306               (ids-insert-chars-including-components*
 307                (char-to-string c) (1+ level)
 308                (cons c ignored-chars))))
 309       )
 310     )
 311   ignored-chars)
 312
 313 (defun ids-insert-chars-including-components (components
 314                                               &optional level ignored-chars)
 315   (unless level
 316     (setq level 0))
 317   (setq ignored-chars
 318         (nreverse
 319          (ids-insert-chars-including-components* components
 320                                                  level ignored-chars)))
 321   (let (is i as bs)
 322     (dolist (c ignored-chars)
 323       (dolist (vc (char-component-variants c))
 324         (unless (memq vc ignored-chars)
 325           (when (setq is (get-char-attribute vc 'ideographic-structure))
 326             (setq i 0)
 327             (while (< i level)
 328               (insert "\t")
 329               (setq i (1+ i)))
 330             (insert (ids-find-format-line vc is))
 331             (setq ignored-chars
 332                   (ids-insert-chars-including-components*
 333                    (char-to-string vc) (1+ level)
 334                    (cons vc ignored-chars)))))))
 335     (dolist (c (sort (copy-tree (ideograph-find-products-with-variants
 336                                  components ignored-chars))
 337                      (lambda (a b)
 338                        (if (setq as (char-total-strokes a))
 339                            (if (setq bs (char-total-strokes b))
 340                                (if (= as bs)
 341                                    (ideograph-char< a b)
 342                                  (< as bs))
 343                              t)
 344                          (ideograph-char< a b)))))
 345       (unless (memq c ignored-chars)
 346         (setq is (get-char-attribute c 'ideographic-structure))
 347         (setq i 0)
 348         (while (< i level)
 349           (insert "\t")
 350           (setq i (1+ i)))
 351         (insert (ids-find-format-line c is))
 352         (setq ignored-chars
 353               (ids-insert-chars-including-components*
 354                (char-to-string c) (1+ level)
 355                (cons c ignored-chars))))
 356       )
 357     )
 358   ignored-chars)
 359
 360 ;;;###autoload
 361 (defun ids-find-chars-including-components (components)
 362   "Search Ideographs whose structures have COMPONENTS."
 363   (interactive "sComponents : ")
 364   (with-current-buffer (get-buffer-create ids-find-result-buffer)
 365     (setq buffer-read-only nil)
 366     (erase-buffer)
 367     (ids-insert-chars-including-components components 0 nil)
 368     ;; (let ((ignored-chars
 369     ;;        (nreverse
 370     ;;         (ids-insert-chars-including-components components 0 nil
 371     ;;                                                #'ideograph-find-products)))
 372     ;;       rest)
 373     ;;   (setq rest ignored-chars)
 374     ;;   ;; (dolist (c rest)
 375     ;;   ;;   (setq ignored-chars
 376     ;;   ;;         (union ignored-chars
 377     ;;   ;;                (ids-insert-chars-including-components
 378     ;;   ;;                 (list c) 0 ignored-chars
 379     ;;   ;;                 #'ideograph-find-products-with-variants))))
 380     ;;   (ids-insert-chars-including-components components 0 ignored-chars
 381     ;;                                          #'ideograph-find-products-with-variants))
 382     (goto-char (point-min)))
 383   (view-buffer ids-find-result-buffer))
 384
 385 ;;;###autoload
 386 (define-obsolete-function-alias 'ideographic-structure-search-chars
 387   'ids-find-chars-including-components)
 388
 389 ;;;###autoload
 390 (defun ids-find-chars-covered-by-components (components)
 391   "Search Ideographs which structures are consisted by subsets of COMPONENTS."
 392   (interactive "sComponents: ")
 393   (if (stringp components)
 394       (setq components (string-to-char-list components)))
 395   (with-current-buffer (get-buffer-create ids-find-result-buffer)
 396     (setq buffer-read-only nil)
 397     (erase-buffer)
 398     (map-char-attribute
 399      (lambda (c v)
 400        (when (ideographic-structure-repertoire-p v components)
 401          (insert (ids-find-format-line c v))))
 402      'ideographic-structure)
 403     (goto-char (point-min)))
 404   (view-buffer ids-find-result-buffer))
 405
 406
 407 ;;; @ End.
 408 ;;;
 409
 410 (provide 'ids-find)
 411
 412 ;;; ids-find.el ends here