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