git.chise.org Git - chise/xemacs-chise.git.1/blob - lisp/utf-2000/ideograph-util.el

   1 ;;; ideograph-util.el --- Ideographic Character Database utility
   2
   3 ;; Copyright (C) 1999,2000,2001,2002,2003 MORIOKA Tomohiko.
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
   6 ;; Keywords: UTF-2000, ISO/IEC 10646, Unicode, UCS-4, MULE.
   7
   8 ;; This file is part of XEmacs UTF-2000.
   9
  10 ;; XEmacs UTF-2000 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 ;; XEmacs UTF-2000 is distributed in the hope that it will be useful,
  16 ;; but 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 XEmacs UTF-2000; 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 (require 'char-db-util)
  28
  29 (defvar ideograph-radical-chars-vector
  30   (make-vector 215 nil))
  31
  32 (defun char-ideographic-radical (char &optional radical)
  33   (let (ret)
  34     (or (catch 'tag
  35           (dolist (cell (get-char-attribute char 'ideographic-))
  36             (if (and (setq ret (plist-get cell :radical))
  37                      (or (eq ret radical)
  38                          (null radical)))
  39                 (throw 'tag ret))))
  40         (get-char-attribute char 'ideographic-radical)
  41         (progn
  42           (setq ret
  43                 (or (get-char-attribute char 'daikanwa-radical)
  44                     (get-char-attribute char 'kangxi-radical)
  45                     (get-char-attribute char 'japanese-radical)
  46                     (get-char-attribute char 'korean-radical)))
  47           (when ret
  48             (put-char-attribute char 'ideographic-radical ret)
  49             ret)))))
  50
  51 (defvar ideograph-radical-strokes-vector
  52   ;;0  1  2  3  4  5  6  7  8  9
  53   [nil 1  1  1  1  1  1  2  2  2
  54     2  2  2  2  2  2  2  2  2  2
  55     2  2  2  2  2  2  2  2  2  2
  56     3  3  3  3  3  3  3  3  3  3
  57     3  3  3  3  3  3  3  3  3  3
  58     3  3  3  3  3  3  3  3  3  3
  59     3  4  4  4  3  4  4  4  4  4
  60     4  4  4  4  4  4  4  4  4  4
  61     4  4  4  4  4  3  4  4  4  4
  62     4  4  4  4  3  5  4  5  5  5
  63     ;; 100
  64     5  5  5  5  5  5  5  5  5  5
  65     5  5  5  5  5  5  5  5  6  6
  66     6  6  6  6  6  6  6  6  6  6
  67     4  6  6  6  6  6  6  6  6  6
  68     4  6  6  6  6  6  6  7  7  7
  69     7  7  7  7  7  7  7  7  7  7
  70     7  7  4  3  7  7  7  8  7  8
  71     3  8  8  8  8  8  9  9  9  9
  72     9  9  9  9  8  9  9 10 10 10
  73    10 10 10 10 10 11 11 11 11 11
  74    ;; 200
  75    11 12 12 12 12 13 13 13 13 14
  76    14 15 16 16 17])
  77
  78 (defun char-ideographic-strokes (char &optional radical)
  79   (let (ret)
  80     (or (catch 'tag
  81           (dolist (cell (get-char-attribute char 'ideographic-))
  82             (if (and (setq ret (plist-get cell :radical))
  83                      (or (eq ret radical)
  84                          (null radical)))
  85                 (throw 'tag (plist-get cell :strokes)))))
  86         (get-char-attribute char 'daikanwa-strokes)
  87         (get-char-attribute char 'ideographic-strokes)
  88         (let ((strokes
  89                (or (get-char-attribute char 'kangxi-strokes)
  90                    (get-char-attribute char 'japanese-strokes)
  91                    (get-char-attribute char 'korean-strokes)
  92                    (let ((r (char-ideographic-radical char))
  93                          (ts (get-char-attribute char 'total-strokes)))
  94                      (if (and r ts)
  95                          (- ts (aref ideograph-radical-strokes-vector r))))
  96                    )))
  97           (when strokes
  98             (put-char-attribute char 'ideographic-strokes strokes)
  99             strokes)))))
 100
 101 ;;;###autoload
 102 (defun update-ideograph-radical-table ()
 103   (interactive)
 104   (let (ret radical script)
 105     (map-char-attribute
 106      (lambda (char radical)
 107        (when (and radical
 108                   (or (null (setq script (get-char-attribute char 'script)))
 109                       (memq 'Ideograph script)))
 110          (unless (memq char
 111                        (setq ret
 112                              (aref ideograph-radical-chars-vector radical)))
 113            (char-ideographic-strokes char)
 114            (aset ideograph-radical-chars-vector radical
 115                  (cons char ret))))
 116        nil)
 117      'ideographic-radical)
 118     (map-char-attribute
 119      (lambda (char data)
 120        (dolist (cell data)
 121          (setq radical (plist-get cell :radical))
 122          (when (and radical
 123                     (or (null (setq script (get-char-attribute char 'script)))
 124                         (memq 'Ideograph script)))
 125            (unless (memq char
 126                          (setq ret
 127                                (aref ideograph-radical-chars-vector radical)))
 128              (char-ideographic-strokes char)
 129              (aset ideograph-radical-chars-vector radical
 130                    (cons char ret))))))
 131      'ideographic-)))
 132
 133 (defun int-list< (a b)
 134   (if (numberp (car a))
 135       (if (numberp (car b))
 136           (if (= (car a) (car b))
 137               (int-list< (cdr a)(cdr b))
 138             (< (car a) (car b)))
 139         nil)
 140     (numberp (car b))))
 141
 142 (defun morohashi-daikanwa< (a b)
 143   (if (integerp a)
 144       (setq a (list a)))
 145   (if (integerp b)
 146       (setq b (list b)))
 147   (cond ((eq (car a) 'ho)
 148          (if (eq (car b) 'ho)
 149              (int-list< (cdr a)(cdr b))
 150            nil))
 151         ((numberp (car a))
 152          (if (eq (car b) 'ho)
 153              t
 154            (int-list< a b)))
 155         (t
 156          (if (eq (car b) 'ho)
 157              t
 158            (int-list< a b)))))
 159
 160 ;; (defun nil=-int< (a b)
 161 ;;   (cond ((null a) nil)
 162 ;;         ((null b) nil)
 163 ;;         (t (< a b))))
 164
 165 ;; (defun nil>-int< (a b)
 166 ;;   (cond ((null a) nil)
 167 ;;         ((null b) t)
 168 ;;         (t (< a b))))
 169
 170 ;;;###autoload
 171 (defun char-representative-of-daikanwa (char)
 172   (if (or (encode-char char 'ideograph-daikanwa 'defined-only)
 173           (encode-char char '=daikanwa-rev2 'defined-only))
 174       char
 175     (let ((m (get-char-attribute char 'morohashi-daikanwa))
 176           m-m m-s pat)
 177       (or (when m
 178             (setq m-m (pop m))
 179             (setq m-s (pop m))
 180             (if (= m-s 0)
 181                 (or (decode-char '=daikanwa-rev2 m-m 'defined-only)
 182                     (decode-char 'ideograph-daikanwa m-m))
 183               (when m
 184                 (setq pat (list m-m m-s))
 185                 (map-char-attribute (lambda (c v)
 186                                       (if (equal pat v)
 187                                           c))
 188                                     'morohashi-daikanwa))))
 189           char))))
 190
 191 (defun char-attributes-poly< (c1 c2 accessors testers defaulters)
 192   (catch 'tag
 193     (let (a1 a2 accessor tester dm)
 194       (while (and accessors testers)
 195         (setq accessor (car accessors)
 196               tester (car testers)
 197               dm (car defaulters))
 198         (when (and accessor tester)
 199           (setq a1 (funcall accessor c1)
 200                 a2 (funcall accessor c2))
 201           (cond ((null a1)
 202                  (if a2
 203                      (cond ((eq dm '<)
 204                             (throw 'tag t))
 205                            ((eq dm '>)
 206                             (throw 'tag nil)))))
 207                 ((null a2)
 208                  (cond ((eq dm '<)
 209                         (throw 'tag nil))
 210                        ((eq dm '>)
 211                         (throw 'tag t))))
 212                 (t
 213                  (cond ((funcall tester a1 a2)
 214                         (throw 'tag t))
 215                        ((funcall tester a2 a1)
 216                         (throw 'tag nil))))))
 217         (setq accessors (cdr accessors)
 218               testers (cdr testers)
 219               defaulters (cdr defaulters))))))
 220
 221 (defvar ideographic-radical nil)
 222
 223 (defun char-daikanwa-strokes (char &optional radical)
 224   (unless radical
 225     (setq radical ideographic-radical))
 226   (let ((drc (char-representative-of-daikanwa char)))
 227     (char-ideographic-strokes
 228      (if (= (char-ideographic-radical drc radical)
 229             (char-ideographic-radical char radical))
 230          drc
 231        char)
 232      radical)))
 233
 234 ;;;###autoload
 235 (defun char-daikanwa (char)
 236   (or (encode-char char 'ideograph-daikanwa 'defined-only)
 237       (encode-char char '=daikanwa-rev2 'defined-only)
 238       (get-char-attribute char 'morohashi-daikanwa)))
 239
 240 ;;;###autoload
 241 (defun char-ucs (char)
 242   (or (encode-char char '=ucs 'defined-only)
 243       (get-char-attribute char '=>ucs)))
 244
 245 (defun char-id (char)
 246   (logand (char-int char) #x3FFFFFFF))
 247
 248 (defun ideograph-char< (a b &optional radical)
 249   (let ((ideographic-radical (or radical
 250                                  ideographic-radical)))
 251     (char-attributes-poly<
 252      a b
 253      '(char-daikanwa-strokes char-daikanwa char-ucs char-id)
 254      '(< morohashi-daikanwa< < <)
 255      '(> > > >))))
 256
 257 (defun insert-ideograph-radical-char-data (radical)
 258   (let ((chars
 259          (sort (copy-list (aref ideograph-radical-chars-vector radical))
 260                (lambda (a b)
 261                  (ideograph-char< a b radical))))
 262         attributes ccss)
 263     (dolist (name (char-attribute-list))
 264       (unless (memq name char-db-ignored-attributes)
 265         (if (find-charset name)
 266             (push name ccss)
 267           (push name attributes))))
 268     (setq attributes (sort attributes #'char-attribute-name<)
 269           ccss (sort ccss #'char-attribute-name<))
 270     (aset ideograph-radical-chars-vector radical chars)
 271     (dolist (char chars)
 272       (when (or (not (some (lambda (atr)
 273                              (get-char-attribute char atr))
 274                            char-db-ignored-attributes))
 275                 (some (lambda (ccs)
 276                         (encode-char char ccs 'defined-only))
 277                       ccss))
 278         (insert-char-data char nil attributes ccss)))))
 279
 280 (defun write-ideograph-radical-char-data (radical file)
 281   (if (file-directory-p file)
 282       (let ((name (get-char-attribute (int-char (+ #x2EFF radical)) 'name)))
 283         (if (string-match "KANGXI RADICAL " name)
 284             (setq name (capitalize (substring name (match-end 0)))))
 285         (setq name (mapconcat (lambda (char)
 286                                 (if (eq char ? )
 287                                     "-"
 288                                   (char-to-string char))) name ""))
 289         (setq file
 290               (expand-file-name
 291                (format "Ideograph-R%03d-%s.el" radical name)
 292                file))))
 293   (with-temp-buffer
 294     (insert-ideograph-radical-char-data radical)
 295     (let ((coding-system-for-write 'utf-8))
 296       (write-region (point-min)(point-max) file)
 297       )))
 298
 299 (defun ideographic-structure= (char1 char2)
 300   (if (char-ref-p char1)
 301       (setq char1 (plist-get char1 :char)))
 302   (if (char-ref-p char2)
 303       (setq char2 (plist-get char2 :char)))
 304   (let ((s1 (if (characterp char1)
 305                 (get-char-attribute char1 'ideographic-structure)
 306               (cdr (assq 'ideographic-structure char1))))
 307         (s2 (if (characterp char2)
 308                 (get-char-attribute char2 'ideographic-structure)
 309               (cdr (assq 'ideographic-structure char2))))
 310         e1 e2)
 311     (if (or (null s1)(null s2))
 312         (char-spec= char1 char2)
 313       (catch 'tag
 314         (while (and s1 s2)
 315           (setq e1 (car s1)
 316                 e2 (car s2))
 317           (unless (ideographic-structure= e1 e2)
 318             (throw 'tag nil))
 319           (setq s1 (cdr s1)
 320                 s2 (cdr s2)))
 321         (and (null s1)(null s2))))))
 322
 323 ;;;###autoload
 324 (defun ideographic-structure-find-char (structure)
 325   (let (rest)
 326     (map-char-attribute (lambda (char value)
 327                           (setq rest structure)
 328                           (catch 'tag
 329                             (while (and rest value)
 330                               (unless (ideographic-structure=
 331                                        (car rest)(car value))
 332                                 (throw 'tag nil))
 333                               (setq rest (cdr rest)
 334                                     value (cdr value)))
 335                             (unless (or rest value)
 336                               char)))
 337                         'ideographic-structure)))
 338
 339 (provide 'ideograph-util)
 340
 341 ;;; ideograph-util.el ends here