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