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 (get-char-attribute char 'ideograph-daikanwa)
 173       char
 174     (let ((m (get-char-attribute char 'morohashi-daikanwa))
 175           m-m m-s pat)
 176       (or (when m
 177             (setq m-m (pop m))
 178             (setq m-s (pop m))
 179             (if (= m-s 0)
 180                 (decode-char 'ideograph-daikanwa m-m)
 181               (when m
 182                 (setq pat (list m-m m-s))
 183                 (map-char-attribute (lambda (c v)
 184                                       (if (equal pat v)
 185                                           c))
 186                                     'morohashi-daikanwa))))
 187           char))))
 188
 189 (defun char-attributes-poly< (c1 c2 accessors testers defaulters)
 190   (catch 'tag
 191     (let (a1 a2 accessor tester dm)
 192       (while (and accessors testers)
 193         (setq accessor (car accessors)
 194               tester (car testers)
 195               dm (car defaulters))
 196         (when (and accessor tester)
 197           (setq a1 (funcall accessor c1)
 198                 a2 (funcall accessor c2))
 199           (cond ((null a1)
 200                  (if a2
 201                      (cond ((eq dm '<)
 202                             (throw 'tag t))
 203                            ((eq dm '>)
 204                             (throw 'tag nil)))))
 205                 ((null a2)
 206                  (cond ((eq dm '<)
 207                         (throw 'tag nil))
 208                        ((eq dm '>)
 209                         (throw 'tag t))))
 210                 (t
 211                  (cond ((funcall tester a1 a2)
 212                         (throw 'tag t))
 213                        ((funcall tester a2 a1)
 214                         (throw 'tag nil))))))
 215         (setq accessors (cdr accessors)
 216               testers (cdr testers)
 217               defaulters (cdr defaulters))))))
 218
 219 (defvar ideographic-radical nil)
 220
 221 (defun char-daikanwa-strokes (char &optional radical)
 222   (unless radical
 223     (setq radical ideographic-radical))
 224   (let ((drc (char-representative-of-daikanwa char)))
 225     (char-ideographic-strokes
 226      (if (= (char-ideographic-radical drc radical)
 227             (char-ideographic-radical char radical))
 228          drc
 229        char)
 230      radical)))
 231
 232 ;;;###autoload
 233 (defun char-daikanwa (char)
 234   (or (get-char-attribute char 'ideograph-daikanwa)
 235       (get-char-attribute char 'morohashi-daikanwa)))
 236
 237 ;;;###autoload
 238 (defun char-ucs (char)
 239   (or (encode-char char '=ucs 'defined-only)
 240       (get-char-attribute char '=>ucs)))
 241
 242 (defun char-id (char)
 243   (logand (char-int char) #x3FFFFFFF))
 244
 245 (defun ideograph-char< (a b &optional radical)
 246   (let ((ideographic-radical (or radical
 247                                  ideographic-radical)))
 248     (char-attributes-poly<
 249      a b
 250      '(char-daikanwa-strokes char-daikanwa char-ucs char-id)
 251      '(< morohashi-daikanwa< < <)
 252      '(> > > >))))
 253
 254 (defun insert-ideograph-radical-char-data (radical)
 255   (let ((chars
 256          (sort (copy-list (aref ideograph-radical-chars-vector radical))
 257                (lambda (a b)
 258                  (ideograph-char< a b radical))))
 259         attributes ccss)
 260     (dolist (name (char-attribute-list))
 261       (unless (memq name char-db-ignored-attributes)
 262         (if (find-charset name)
 263             (push name ccss)
 264           (push name attributes))))
 265     (setq attributes (sort attributes #'char-attribute-name<)
 266           ccss (sort ccss #'char-attribute-name<))
 267     (aset ideograph-radical-chars-vector radical chars)
 268     (dolist (char chars)
 269       (when (or (not (some (lambda (atr)
 270                              (get-char-attribute char atr))
 271                            char-db-ignored-attributes))
 272                 (some (lambda (ccs)
 273                         (encode-char char ccs 'defined-only))
 274                       ccss))
 275         (insert-char-data char nil attributes ccss)))))
 276
 277 (defun write-ideograph-radical-char-data (radical file)
 278   (if (file-directory-p file)
 279       (let ((name (get-char-attribute (int-char (+ #x2EFF radical)) 'name)))
 280         (if (string-match "KANGXI RADICAL " name)
 281             (setq name (capitalize (substring name (match-end 0)))))
 282         (setq name (mapconcat (lambda (char)
 283                                 (if (eq char ? )
 284                                     "-"
 285                                   (char-to-string char))) name ""))
 286         (setq file
 287               (expand-file-name
 288                (format "Ideograph-R%03d-%s.el" radical name)
 289                file))))
 290   (with-temp-buffer
 291     (insert-ideograph-radical-char-data radical)
 292     (let ((coding-system-for-write 'utf-8))
 293       (write-region (point-min)(point-max) file)
 294       )))
 295
 296 (defun ideographic-structure= (char1 char2)
 297   (if (char-ref-p char1)
 298       (setq char1 (plist-get char1 :char)))
 299   (if (char-ref-p char2)
 300       (setq char2 (plist-get char2 :char)))
 301   (let ((s1 (if (characterp char1)
 302                 (get-char-attribute char1 'ideographic-structure)
 303               (cdr (assq 'ideographic-structure char1))))
 304         (s2 (if (characterp char2)
 305                 (get-char-attribute char2 'ideographic-structure)
 306               (cdr (assq 'ideographic-structure char2))))
 307         e1 e2)
 308     (if (or (null s1)(null s2))
 309         (char-spec= char1 char2)
 310       (catch 'tag
 311         (while (and s1 s2)
 312           (setq e1 (car s1)
 313                 e2 (car s2))
 314           (unless (ideographic-structure= e1 e2)
 315             (throw 'tag nil))
 316           (setq s1 (cdr s1)
 317                 s2 (cdr s2)))
 318         (and (null s1)(null s2))))))
 319
 320 ;;;###autoload
 321 (defun ideographic-structure-find-char (structure)
 322   (let (rest)
 323     (map-char-attribute (lambda (char value)
 324                           (setq rest structure)
 325                           (catch 'tag
 326                             (while (and rest value)
 327                               (unless (ideographic-structure=
 328                                        (car rest)(car value))
 329                                 (throw 'tag nil))
 330                               (setq rest (cdr rest)
 331                                     value (cdr value)))
 332                             (unless (or rest value)
 333                               char)))
 334                         'ideographic-structure)))
 335
 336 (provide 'ideograph-util)
 337
 338 ;;; ideograph-util.el ends here