ids-find.el

   1 ;;; ids-find.el --- search utility based on Ideographic-structures
   2
   3 ;; Copyright (C) 2002,2003,2005 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 Tomoyo-Tools.
   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 ; char-feature
  29               component 'ideographic-products)))
  30     (unless (memq product ret)
  31       (put-char-attribute component 'ideographic-products
  32                           (cons product ret)))
  33     ;; (when ret (setq ret (get-char-attribute ; char-feature
  34     ;;                      component 'ideographic-structure))
  35     ;;   (ids-index-store-structure product ret))
  36     ))
  37
  38 (defun ids-index-store-structure (product structure)
  39   (let (ret)
  40     (dolist (cell (cdr structure))
  41       (if (char-ref-p cell)
  42           (setq cell (plist-get cell :char)))
  43       (cond ((characterp cell)
  44              (ids-index-store-char product cell))
  45             ((setq ret (assq 'ideographic-structure cell))
  46              (ids-index-store-structure product (cdr ret)))
  47             ;; ((setq ret (find-char cell))
  48             ;;  (ids-index-store-char product ret))
  49             ))))
  50
  51 ;;;###autoload
  52 (defun ids-update-index ()
  53   (interactive)
  54   (map-char-attribute
  55    (lambda (c v)
  56      (ids-index-store-structure c v)
  57      nil)
  58    'ideographic-structure)
  59   (save-char-attribute-table 'ideographic-products))
  60
  61
  62 (mount-char-attribute-table 'ideographic-products)
  63
  64 ;;;###autoload
  65 (defun ids-find-all-products (char)
  66   (let (dest)
  67     (dolist (cell (char-feature char 'ideographic-products))
  68       (unless (memq cell dest)
  69         (setq dest (cons cell dest)))
  70       (setq dest (union dest (ids-find-all-products cell))))
  71     dest))
  72
  73 (defun of-component-features ()
  74   (let (dest)
  75     (dolist (feature (char-attribute-list))
  76       (when (string-match "^<-.*[@/]component\\(/[^*/]+\\)*$"
  77                           (symbol-name feature))
  78         (push feature dest)))
  79     (cons '<-ideographic-component-forms
  80           dest)))
  81
  82 (defun to-component-features ()
  83   (let (dest)
  84     (dolist (feature (char-attribute-list))
  85       (when (string-match "^->.*[@/]component\\(/[^*/]+\\)*$"
  86                           (symbol-name feature))
  87         (push feature dest)))
  88     (cons '->ideographic-component-forms
  89           dest)))
  90
  91 ;;;###autoload
  92 (defun char-component-variants (char)
  93   (let ((dest (list char))
  94         ret uchr)
  95     (cond
  96      ((setq ret (some (lambda (feature)
  97                         (get-char-attribute char feature))
  98                       (to-component-features)))
  99       (dolist (c ret)
 100         (setq dest (union dest (char-component-variants c))))
 101       )
 102      ((setq ret (get-char-attribute char '->ucs-unified))
 103       (setq dest (cons char ret))
 104       (dolist (c dest)
 105         (setq dest (union dest
 106                           (some (lambda (feature)
 107                                   (get-char-attribute char feature))
 108                                 (of-component-features))
 109                           )))
 110       )
 111      ((and (setq ret (get-char-attribute char '=>ucs))
 112            (setq uchr (decode-char '=ucs ret)))
 113       (setq dest (cons uchr (char-variants uchr)))
 114       (dolist (c dest)
 115         (setq dest (union dest
 116                           (some (lambda (feature)
 117                                   (get-char-attribute char feature))
 118                                 (of-component-features))
 119                           )))
 120       )
 121      (t
 122       (map-char-family
 123        (lambda (c)
 124          (unless (memq c dest)
 125            (setq dest (cons c dest)))
 126          (setq dest
 127                (union dest
 128                       (some (lambda (feature)
 129                               (char-feature c feature))
 130                             (of-component-features))
 131                       ))
 132          nil)
 133        char)
 134       ))
 135     dest))
 136
 137 ;;;###autoload
 138 (defun ideographic-products-find (&rest components)
 139   (if (stringp (car components))
 140       (setq components (car components)))
 141   (let ((len (length components))
 142         (i 1)
 143         dest products)
 144     (dolist (variant (char-component-variants (elt components 0)))
 145       (dolist (product (get-char-attribute variant 'ideographic-products))
 146         (unless (memq product products)
 147           (setq products (cons product products)))))
 148     (setq dest products)
 149     (while (and
 150             (< i len)
 151             (progn
 152               (setq products nil)
 153               (dolist (variant (char-component-variants (elt components i)))
 154                 (dolist (product (get-char-attribute
 155                                   variant 'ideographic-products))
 156                   (unless (memq product products)
 157                     (when (memq product dest)
 158                       (setq products (cons product products))))))
 159               (setq dest products)))
 160       (setq i (1+ i)))
 161     products))
 162
 163
 164 (defun ideographic-structure-char= (c1 c2)
 165   (or (eq c1 c2)
 166       (and c1 c2
 167            (let ((m1 (char-ucs c1))
 168                  (m2 (char-ucs c2)))
 169              (or (and m1 m2
 170                       (eq m1 m2))
 171                  (some (lambda (feature)
 172                          (some (lambda (b2)
 173                                  (unless (characterp b2)
 174                                    (setq b2 (find-char b2)))
 175                                  (and b2
 176                                       (ideographic-structure-char= c1 b2)))
 177                                (char-feature c2 feature)
 178                                ;; (get-char-attribute
 179                                ;;  c2 '<-ideographic-component-forms)
 180                                ))
 181                        (of-component-features))
 182                  (progn
 183                    (setq m1 (car (get-char-attribute c1 '<-radical))
 184                          m2 (car (get-char-attribute c2 '<-radical)))
 185                    (unless (characterp m1)
 186                      (setq m1 (find-char m1)))
 187                    (unless (characterp m2)
 188                      (setq m2 (find-char m2)))
 189                    (when (or m1 m2)
 190                      (ideographic-structure-char= m1 m2))))))))
 191
 192 (defun ideographic-structure-member-compare-components (component s-component)
 193   (let (ret)
 194     (cond ((char-ref= component s-component #'ideographic-structure-char=))
 195           ((listp s-component)
 196            (if (setq ret (assq 'ideographic-structure s-component))
 197                (ideographic-structure-member component (cdr ret))))
 198           ((setq ret (get-char-attribute s-component 'ideographic-structure))
 199            (ideographic-structure-member component ret)))))
 200
 201 ;;;###autoload
 202 (defun ideographic-structure-member (component structure)
 203   "Return non-nil if COMPONENT is included in STRUCTURE."
 204   (or (memq component structure)
 205       (progn
 206         (setq structure (cdr structure))
 207         (ideographic-structure-member-compare-components
 208          component (car structure)))
 209       (progn
 210         (setq structure (cdr structure))
 211         (ideographic-structure-member-compare-components
 212          component (car structure)))
 213       (progn
 214         (setq structure (cdr structure))
 215         (and (car structure)
 216              (ideographic-structure-member-compare-components
 217               component (car structure))))))
 218
 219
 220 ;;;###autoload
 221 (defun ideographic-structure-repertoire-p (structure components)
 222   "Return non-nil if STRUCTURE can be constructed by a subset of COMPONENTS."
 223   (and structure
 224        (let (ret s-component)
 225          (catch 'tag
 226            (while (setq structure (cdr structure))
 227              (setq s-component (car structure))
 228              (unless (characterp s-component)
 229                (if (setq ret (find-char s-component))
 230                    (setq s-component ret)))
 231              (unless (cond
 232                       ((listp s-component)
 233                        (if (setq ret (assq 'ideographic-structure s-component))
 234                            (ideographic-structure-repertoire-p
 235                             (cdr ret) components)))
 236                       ((member* s-component components
 237                                 :test #'ideographic-structure-char=))
 238                       ((setq ret
 239                              (get-char-attribute s-component
 240                                                  'ideographic-structure))
 241                        (ideographic-structure-repertoire-p ret components)))
 242                (throw 'tag nil)))
 243            t))))
 244
 245
 246 (defvar ids-find-result-buffer "*ids-chars*")
 247
 248 (defun ids-find-format-line (c v)
 249   (format "%c\t%s\t%s\n"
 250           c
 251           (or (let ((ucs (or (char-ucs c)
 252                              (encode-char c 'ucs))))
 253                 (if ucs
 254                     (cond ((<= ucs #xFFFF)
 255                            (format "    U+%04X" ucs))
 256                           ((<= ucs #x10FFFF)
 257                            (format "U-%08X" ucs)))))
 258               "          ")
 259           (or (ideographic-structure-to-ids v)
 260               v)))
 261
 262 (defun ids-insert-chars-including-components (components level)
 263   (let (is dis i)
 264     (dolist (c (ideographic-products-find components))
 265       (setq is (char-feature c 'ideographic-structure))
 266       ;; to avoid problems caused by wrong indexes
 267       (when (every (lambda (cc)
 268                      (ideographic-structure-member cc is))
 269                    components)
 270         ;;(ids-insert-chars-including-components (char-to-string c) (1+ level))
 271         (setq i 0)
 272         (while (< i level)
 273           (insert "\t")
 274           (setq i (1+ i)))
 275         (insert (ids-find-format-line c is))
 276         ;;(forward-line -1)
 277         (ids-insert-chars-including-components
 278          (char-to-string c) (1+ level))
 279         )
 280       )))
 281
 282 ;;;###autoload
 283 (defun ids-find-chars-including-components (components)
 284   "Search Ideographs whose structures have COMPONENTS."
 285   (interactive "sComponents : ")
 286   (with-current-buffer (get-buffer-create ids-find-result-buffer)
 287     (setq buffer-read-only nil)
 288     (erase-buffer)
 289     (ids-insert-chars-including-components components 0)
 290     ;; (let (is dis)
 291     ;;   (dolist (c (ideographic-products-find components))
 292     ;;     (setq is (char-feature c 'ideographic-structure))
 293     ;;     ;; to avoid problems caused by wrong indexes
 294     ;;     ;; (when (every (lambda (cc)
 295     ;;     ;;                (ideographic-structure-member cc is))
 296     ;;     ;;              components)
 297     ;;     (dolist (dc (ideographic-products-find (char-to-string c)))
 298     ;;       (setq dis (char-feature dc 'ideographic-structure))
 299     ;;     ;;     ;; to avoid problems caused by wrong indexes
 300     ;;     ;;     (when (every (lambda (dcc)
 301     ;;     ;;                    (ideographic-structure-member dcc is))
 302     ;;     ;;                  components)
 303     ;;       (insert "\t")
 304     ;;       (insert (ids-find-format-line dc dis))
 305     ;;       (forward-line -1)
 306     ;;     ;;       )
 307     ;;       )
 308     ;;     (insert (ids-find-format-line c is))
 309     ;;     (forward-line -1)
 310     ;;     ;;   )
 311     ;;     )
 312     ;;   )
 313     (goto-char (point-min)))
 314   (view-buffer ids-find-result-buffer))
 315 ;; (defun ids-find-chars-including-components (components)
 316 ;;   "Search Ideographs whose structures have COMPONENTS."
 317 ;;   (interactive "sComponents : ")
 318 ;;   (with-current-buffer (get-buffer-create ids-find-result-buffer)
 319 ;;     (setq buffer-read-only nil)
 320 ;;     (erase-buffer)
 321 ;;     (map-char-attribute
 322 ;;      (lambda (c v)
 323 ;;        (when (every (lambda (p)
 324 ;;                       (ideographic-structure-member p v))
 325 ;;                     components)
 326 ;;          (insert (ids-find-format-line c v)))
 327 ;;        nil)
 328 ;;      'ideographic-structure)
 329 ;;     (goto-char (point-min)))
 330 ;;   (view-buffer ids-find-result-buffer))
 331
 332 ;;;###autoload
 333 (define-obsolete-function-alias 'ideographic-structure-search-chars
 334   'ids-find-chars-including-components)
 335
 336 ;;;###autoload
 337 (defun ids-find-chars-covered-by-components (components)
 338   "Search Ideographs which structures are consisted by subsets of COMPONENTS."
 339   (interactive "sComponents: ")
 340   (if (stringp components)
 341       (setq components (string-to-char-list components)))
 342   (with-current-buffer (get-buffer-create ids-find-result-buffer)
 343     (setq buffer-read-only nil)
 344     (erase-buffer)
 345     (let (ucs jis)
 346       (map-char-attribute
 347        (lambda (c v)
 348          (when (ideographic-structure-repertoire-p v components)
 349            (insert (ids-find-format-line c v))))
 350        'ideographic-structure))
 351     (goto-char (point-min)))
 352   (view-buffer ids-find-result-buffer))
 353
 354
 355 ;;; @ End.
 356 ;;;
 357
 358 (provide 'ids-find)
 359
 360 ;;; ids-find.el ends here