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 ;;;###autoload
  74 (defun char-component-variants (char)
  75   (let (dest ret uchr)
  76     (cond
  77      ((setq ret (char-feature char '<-ideographic-component-forms))
  78       (dolist (c ret)
  79         (setq dest (union dest (char-component-variants c)))))
  80      ((setq ret (get-char-attribute char '->ucs-unified))
  81       (setq dest (cons char ret))
  82       (dolist (c dest)
  83         (setq dest (union dest
  84                           (get-char-attribute
  85                            c '->ideographic-component-forms))))
  86       )
  87      ((and (setq ret (get-char-attribute char '=>ucs))
  88            (setq uchr (decode-char '=ucs ret)))
  89       (setq dest (cons uchr (char-variants uchr)))
  90       (dolist (c dest)
  91         (setq dest (union dest
  92                           (get-char-attribute
  93                            c '->ideographic-component-forms))))
  94       )
  95      (t
  96       (map-char-family (lambda (c)
  97                          (unless (memq c dest)
  98                            (setq dest (cons c dest)))
  99                          (setq dest
 100                                (union dest
 101                                       (get-char-attribute
 102                                        c '->ideographic-component-forms)))
 103                          nil)
 104                        char)))
 105     dest))
 106
 107 ;;;###autoload
 108 (defun ideographic-products-find (&rest components)
 109   (if (stringp (car components))
 110       (setq components (car components)))
 111   (let ((len (length components))
 112         (i 1)
 113         dest products)
 114     (dolist (variant (char-component-variants (elt components 0)))
 115       (dolist (product (get-char-attribute variant 'ideographic-products))
 116         (unless (memq product products)
 117           (setq products (cons product products)))))
 118     (setq dest products)
 119     (while (and
 120             (< i len)
 121             (progn
 122               (setq products nil)
 123               (dolist (variant (char-component-variants (elt components i)))
 124                 (dolist (product (get-char-attribute
 125                                   variant 'ideographic-products))
 126                   (unless (memq product products)
 127                     (when (memq product dest)
 128                       (setq products (cons product products))))))
 129               (setq dest products)))
 130       (setq i (1+ i)))
 131     products))
 132
 133
 134 (defun ideographic-structure-char= (c1 c2)
 135   (or (eq c1 c2)
 136       (and c1 c2
 137            (let ((m1 (char-ucs c1))
 138                  (m2 (char-ucs c2)))
 139              (or (and m1 m2
 140                       (eq m1 m2))
 141                  (some (lambda (b2)
 142                          (unless (characterp b2)
 143                            (setq b2 (find-char b2)))
 144                          (and b2
 145                               (ideographic-structure-char= c1 b2)))
 146                        (get-char-attribute
 147                         c2 '<-ideographic-component-forms))
 148                  (progn
 149                    (setq m1 (car (get-char-attribute c1 '<-radical))
 150                          m2 (car (get-char-attribute c2 '<-radical)))
 151                    (unless (characterp m1)
 152                      (setq m1 (find-char m1)))
 153                    (unless (characterp m2)
 154                      (setq m2 (find-char m2)))
 155                    (when (or m1 m2)
 156                      (ideographic-structure-char= m1 m2))))))))
 157
 158 (defun ideographic-structure-member-compare-components (component s-component)
 159   (let (ret)
 160     (cond ((char-ref= component s-component #'ideographic-structure-char=))
 161           ((listp s-component)
 162            (if (setq ret (assq 'ideographic-structure s-component))
 163                (ideographic-structure-member component (cdr ret))))
 164           ((setq ret (get-char-attribute s-component 'ideographic-structure))
 165            (ideographic-structure-member component ret)))))
 166
 167 ;;;###autoload
 168 (defun ideographic-structure-member (component structure)
 169   "Return non-nil if COMPONENT is included in STRUCTURE."
 170   (or (memq component structure)
 171       (progn
 172         (setq structure (cdr structure))
 173         (ideographic-structure-member-compare-components
 174          component (car structure)))
 175       (progn
 176         (setq structure (cdr structure))
 177         (ideographic-structure-member-compare-components
 178          component (car structure)))
 179       (progn
 180         (setq structure (cdr structure))
 181         (and (car structure)
 182              (ideographic-structure-member-compare-components
 183               component (car structure))))))
 184
 185
 186 ;;;###autoload
 187 (defun ideographic-structure-repertoire-p (structure components)
 188   "Return non-nil if STRUCTURE can be constructed by a subset of COMPONENTS."
 189   (and structure
 190        (let (ret s-component)
 191          (catch 'tag
 192            (while (setq structure (cdr structure))
 193              (setq s-component (car structure))
 194              (unless (characterp s-component)
 195                (if (setq ret (find-char s-component))
 196                    (setq s-component ret)))
 197              (unless (cond
 198                       ((listp s-component)
 199                        (if (setq ret (assq 'ideographic-structure s-component))
 200                            (ideographic-structure-repertoire-p
 201                             (cdr ret) components)))
 202                       ((member* s-component components
 203                                 :test #'ideographic-structure-char=))
 204                       ((setq ret
 205                              (get-char-attribute s-component
 206                                                  'ideographic-structure))
 207                        (ideographic-structure-repertoire-p ret components)))
 208                (throw 'tag nil)))
 209            t))))
 210
 211
 212 (defvar ids-find-result-buffer "*ids-chars*")
 213
 214 (defun ids-find-format-line (c v)
 215   (format "%c\t%s\t%s\n"
 216           c
 217           (or (let ((ucs (or (char-ucs c)
 218                              (encode-char c 'ucs))))
 219                 (if ucs
 220                     (cond ((<= ucs #xFFFF)
 221                            (format "    U+%04X" ucs))
 222                           ((<= ucs #x10FFFF)
 223                            (format "U-%08X" ucs)))))
 224               "          ")
 225           (or (ideographic-structure-to-ids v)
 226               v)))
 227
 228 (defun ids-insert-chars-including-components (components level)
 229   (let (is dis i)
 230     (dolist (c (ideographic-products-find components))
 231       (setq is (char-feature c 'ideographic-structure))
 232       ;; to avoid problems caused by wrong indexes
 233       (when (every (lambda (cc)
 234                      (ideographic-structure-member cc is))
 235                    components)
 236         ;;(ids-insert-chars-including-components (char-to-string c) (1+ level))
 237         (setq i 0)
 238         (while (< i level)
 239           (insert "\t")
 240           (setq i (1+ i)))
 241         (insert (ids-find-format-line c is))
 242         ;;(forward-line -1)
 243         (ids-insert-chars-including-components
 244          (char-to-string c) (1+ level))
 245         )
 246       )))
 247
 248 ;;;###autoload
 249 (defun ids-find-chars-including-components (components)
 250   "Search Ideographs whose structures have COMPONENTS."
 251   (interactive "sComponents : ")
 252   (with-current-buffer (get-buffer-create ids-find-result-buffer)
 253     (setq buffer-read-only nil)
 254     (erase-buffer)
 255     (ids-insert-chars-including-components components 0)
 256     ;; (let (is dis)
 257     ;;   (dolist (c (ideographic-products-find components))
 258     ;;     (setq is (char-feature c 'ideographic-structure))
 259     ;;     ;; to avoid problems caused by wrong indexes
 260     ;;     ;; (when (every (lambda (cc)
 261     ;;     ;;                (ideographic-structure-member cc is))
 262     ;;     ;;              components)
 263     ;;     (dolist (dc (ideographic-products-find (char-to-string c)))
 264     ;;       (setq dis (char-feature dc 'ideographic-structure))
 265     ;;     ;;     ;; to avoid problems caused by wrong indexes
 266     ;;     ;;     (when (every (lambda (dcc)
 267     ;;     ;;                    (ideographic-structure-member dcc is))
 268     ;;     ;;                  components)
 269     ;;       (insert "\t")
 270     ;;       (insert (ids-find-format-line dc dis))
 271     ;;       (forward-line -1)
 272     ;;     ;;       )
 273     ;;       )
 274     ;;     (insert (ids-find-format-line c is))
 275     ;;     (forward-line -1)
 276     ;;     ;;   )
 277     ;;     )
 278     ;;   )
 279     (goto-char (point-min)))
 280   (view-buffer ids-find-result-buffer))
 281 ;; (defun ids-find-chars-including-components (components)
 282 ;;   "Search Ideographs whose structures have COMPONENTS."
 283 ;;   (interactive "sComponents : ")
 284 ;;   (with-current-buffer (get-buffer-create ids-find-result-buffer)
 285 ;;     (setq buffer-read-only nil)
 286 ;;     (erase-buffer)
 287 ;;     (map-char-attribute
 288 ;;      (lambda (c v)
 289 ;;        (when (every (lambda (p)
 290 ;;                       (ideographic-structure-member p v))
 291 ;;                     components)
 292 ;;          (insert (ids-find-format-line c v)))
 293 ;;        nil)
 294 ;;      'ideographic-structure)
 295 ;;     (goto-char (point-min)))
 296 ;;   (view-buffer ids-find-result-buffer))
 297
 298 ;;;###autoload
 299 (define-obsolete-function-alias 'ideographic-structure-search-chars
 300   'ids-find-chars-including-components)
 301
 302 ;;;###autoload
 303 (defun ids-find-chars-covered-by-components (components)
 304   "Search Ideographs which structures are consisted by subsets of COMPONENTS."
 305   (interactive "sComponents: ")
 306   (if (stringp components)
 307       (setq components (string-to-char-list components)))
 308   (with-current-buffer (get-buffer-create ids-find-result-buffer)
 309     (setq buffer-read-only nil)
 310     (erase-buffer)
 311     (let (ucs jis)
 312       (map-char-attribute
 313        (lambda (c v)
 314          (when (ideographic-structure-repertoire-p v components)
 315            (insert (ids-find-format-line c v))))
 316        'ideographic-structure))
 317     (goto-char (point-min)))
 318   (view-buffer ids-find-result-buffer))
 319
 320
 321 ;;; @ End.
 322 ;;;
 323
 324 (provide 'ids-find)
 325
 326 ;;; ids-find.el ends here