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