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