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 ;;;###autoload
  30 (defun expand-char-feature-name (feature domain)
  31   (if domain
  32       (intern (format "%s@%s" feature domain))
  33     feature))
  34
  35 (defun map-char-family (function char &optional ignore-sisters)
  36   (let ((rest (list char))
  37         ret checked)
  38     (catch 'tag
  39       (while rest
  40         (unless (memq (car rest) checked)
  41           (if (setq ret (funcall function (car rest)))
  42               (throw 'tag ret))
  43           (setq checked (cons (car rest) checked)
  44                 rest (append rest
  45                              (get-char-attribute (car rest) '->subsumptive)
  46                              (get-char-attribute (car rest) '->denotational)
  47                              (get-char-attribute (car rest) '->identical)))
  48           (unless ignore-sisters
  49             (setq rest (append rest
  50                                (get-char-attribute (car rest) '<-subsumptive)
  51                                (get-char-attribute (car rest) '<-denotational)))))
  52         (setq rest (cdr rest))))))
  53
  54 (defun get-char-feature-from-domains (char feature domains
  55                                            &optional tester arg
  56                                            ignore-sisters)
  57   (map-char-family
  58    (lambda (ch)
  59      (let (ret)
  60        (catch 'tag
  61          (dolist (domain domains)
  62            (if (and (or (null tester)
  63                         (equal (or (char-feature
  64                                     ch (expand-char-feature-name
  65                                         tester domain))
  66                                    (char-feature ch tester))
  67                                arg))
  68                     (setq ret (or (char-feature
  69                                    ch (expand-char-feature-name
  70                                        feature domain))
  71                                   (char-feature ch feature))))
  72                (throw 'tag ret))))))
  73    char ignore-sisters)
  74   ;; (let ((rest (list char))
  75   ;;       ret checked)
  76   ;;   (catch 'tag
  77   ;;     (while rest
  78   ;;       (setq char (car rest))
  79   ;;       (unless (memq char checked)
  80   ;;         (dolist (domain domains)
  81   ;;           (if (and (setq ret (char-feature
  82   ;;                               char
  83   ;;                               (expand-char-feature-name
  84   ;;                                feature domain)))
  85   ;;                    (or (null tester)
  86   ;;                        (equal (or (char-feature
  87   ;;                                    char
  88   ;;                                    (expand-char-feature-name
  89   ;;                                     tester domain))
  90   ;;                                   (char-feature char tester))
  91   ;;                               arg)))
  92   ;;               (throw 'tag ret)))
  93   ;;         (setq rest (append rest
  94   ;;                            (get-char-attribute char '->subsumptive)
  95   ;;                            (get-char-attribute char '->denotational)
  96   ;;                            (get-char-attribute char '<-subsumptive)
  97   ;;                            (get-char-attribute char '<-denotational))
  98   ;;               checked (cons char checked)))
  99   ;;       (setq rest (cdr rest)))))
 100   )
 101
 102
 103 (defvar ideograph-radical-chars-vector
 104   (make-vector 215 nil))
 105
 106 (defun char-ideographic-radical (char &optional radical ignore-sisters)
 107   (let (ret)
 108     (or (if radical
 109             (get-char-feature-from-domains
 110              char 'ideographic-radical (cons nil char-db-feature-domains)
 111              'ideographic-radical radical ignore-sisters)
 112           (get-char-feature-from-domains
 113            char 'ideographic-radical (cons nil char-db-feature-domains)
 114            ignore-sisters))
 115         ;; (catch 'tag
 116         ;;   (dolist (domain char-db-feature-domains)
 117         ;;     (if (and (setq ret (char-feature
 118         ;;                         char
 119         ;;                         (intern
 120         ;;                          (format "%s@%s"
 121         ;;                                  'ideographic-radical domain))))
 122         ;;              (or (eq ret radical)
 123         ;;                  (null radical)))
 124         ;;         (throw 'tag ret))))
 125         (catch 'tag
 126           (dolist (cell (get-char-attribute char 'ideographic-))
 127             (if (and (setq ret (plist-get cell :radical))
 128                      (or (eq ret radical)
 129                          (null radical)))
 130                 (throw 'tag ret))))
 131         (get-char-feature-from-domains
 132          char 'ideographic-radical (cons nil char-db-feature-domains))
 133         ;; (char-feature char 'ideographic-radical)
 134         (progn
 135           (setq ret
 136                 (or (get-char-attribute char 'daikanwa-radical)
 137                     (get-char-attribute char 'kangxi-radical)
 138                     (get-char-attribute char 'japanese-radical)
 139                     (get-char-attribute char 'korean-radical)))
 140           (when ret
 141             (put-char-attribute char 'ideographic-radical ret)
 142             ret)))))
 143
 144 (defvar ideograph-radical-strokes-vector
 145   ;;0  1  2  3  4  5  6  7  8  9
 146   [nil 1  1  1  1  1  1  2  2  2
 147     2  2  2  2  2  2  2  2  2  2
 148     2  2  2  2  2  2  2  2  2  2
 149     3  3  3  3  3  3  3  3  3  3
 150     3  3  3  3  3  3  3  3  3  3
 151     3  3  3  3  3  3  3  3  3  3
 152     3  4  4  4  3  4  4  4  4  4
 153     4  4  4  4  4  4  4  4  4  4
 154     4  4  4  4  4  3  4  4  4  4
 155     4  4  4  4  3  5  4  5  5  5
 156     ;; 100
 157     5  5  5  5  5  5  5  5  5  5
 158     5  5  5  5  5  5  5  5  6  6
 159     6  6  6  6  6  6  6  6  6  6
 160     4  6  6  6  6  6  6  6  6  6
 161     4  6  6  6  6  6  6  7  7  7
 162     7  7  7  7  7  7  7  7  7  7
 163     7  7  4  3  7  7  7  8  7  8
 164     3  8  8  8  8  8  9  9  9  9
 165     9  9  9  9  8  9  9 10 10 10
 166    10 10 10 10 10 11 11 11 11 11
 167    ;; 200
 168    11 12 12 12 12 13 13 13 13 14
 169    14 15 16 16 17])
 170
 171 ;;;###autoload
 172 (defun char-ideographic-strokes-from-domains (char domains &optional radical)
 173   (if radical
 174       (get-char-feature-from-domains char 'ideographic-strokes domains
 175                                      'ideographic-radical radical)
 176     (get-char-feature-from-domains char 'ideographic-strokes domains))
 177   ;; (let ((rest (list char))
 178   ;;       ret checked)
 179   ;;   (catch 'tag
 180   ;;     (while rest
 181   ;;       (setq char (car rest))
 182   ;;       (unless (memq char checked)
 183   ;;         (dolist (domain domains)
 184   ;;           (if (and (setq ret (or (char-feature
 185   ;;                                   char
 186   ;;                                   (expand-char-feature-name
 187   ;;                                    'ideographic-radical domain))
 188   ;;                                  (char-feature
 189   ;;                                   char 'ideographic-radical)))
 190   ;;                    (or (eq ret radical)
 191   ;;                        (null radical))
 192   ;;                    (setq ret (or (char-feature
 193   ;;                                   char
 194   ;;                                   (expand-char-feature-name
 195   ;;                                    'ideographic-strokes domain))
 196   ;;                                  (char-feature
 197   ;;                                   char 'ideographic-strokes))))
 198   ;;               (throw 'tag ret)))
 199   ;;         (setq rest (append rest
 200   ;;                            (get-char-attribute char '->subsumptive)
 201   ;;                            (get-char-attribute char '->denotational))
 202   ;;               checked (cons char checked)))
 203   ;;       (setq rest (cdr rest)))))
 204   )
 205
 206 ;;;###autoload
 207 (defun char-ideographic-strokes (char &optional radical preferred-domains)
 208   (let (ret)
 209     (or (catch 'tag
 210           (dolist (cell (get-char-attribute char 'ideographic-))
 211             (if (and (setq ret (plist-get cell :radical))
 212                      (or (eq ret radical)
 213                          (null radical)))
 214                 (throw 'tag (plist-get cell :strokes)))))
 215         (char-ideographic-strokes-from-domains
 216          char (append preferred-domains
 217                       (cons nil
 218                             char-db-feature-domains))
 219          radical)
 220         (get-char-attribute char 'daikanwa-strokes)
 221         (let ((strokes
 222                (or (get-char-attribute char 'kangxi-strokes)
 223                    (get-char-attribute char 'japanese-strokes)
 224                    (get-char-attribute char 'korean-strokes)
 225                    (let ((r (char-ideographic-radical char))
 226                          (ts (get-char-attribute char 'total-strokes)))
 227                      (if (and r ts)
 228                          (- ts (aref ideograph-radical-strokes-vector r))))
 229                    )))
 230           (when strokes
 231             (put-char-attribute char 'ideographic-strokes strokes)
 232             strokes)))))
 233
 234 ;;;###autoload
 235 (defun char-total-strokes-from-domains (char domains)
 236   (let (ret)
 237     (catch 'tag
 238       (dolist (domain domains)
 239         (if (setq ret (get-char-attribute
 240                        char
 241                        (intern
 242                         (format "%s@%s"
 243                                 'total-strokes domain))))
 244             (throw 'tag ret))))))
 245
 246 ;;;###autoload
 247 (defun char-total-strokes (char &optional preferred-domains)
 248   (or (char-total-strokes-from-domains char preferred-domains)
 249       (get-char-attribute char 'total-strokes)
 250       (char-total-strokes-from-domains char char-db-feature-domains)))
 251
 252 ;;;###autoload
 253 (defun update-ideograph-radical-table ()
 254   (interactive)
 255   (let (ret radical script dest)
 256     (dolist (feature
 257              (cons 'ideographic-radical
 258                    (mapcar
 259                     (lambda (domain)
 260                       (intern (format "%s@%s" 'ideographic-radical domain)))
 261                     char-db-feature-domains)))
 262       (map-char-attribute
 263        (lambda (chr radical)
 264          (dolist (char (append
 265                         (if (setq ret
 266                                   (get-char-attribute chr '<-subsumptive))
 267                             (progn
 268                               (setq dest nil)
 269                               (dolist (pc ret)
 270                                 (unless (eq (get-char-attribute
 271                                              pc 'ideographic-radical)
 272                                             radical)
 273                                   (setq dest (cons pc dest))))
 274                               dest)
 275                           (list chr))
 276                         (get-char-attribute chr '<-identical)
 277                         (get-char-attribute chr '->denotational)))
 278            (when (and radical
 279                       (or (eq radical
 280                               (or (get-char-attribute
 281                                    char 'ideographic-radical)
 282                                   (char-ideographic-radical char radical)))
 283                           (null (char-ideographic-radical char)))
 284                       (or (null (setq script
 285                                       (get-char-attribute char 'script)))
 286                           (memq 'Ideograph script)))
 287              (unless (memq char
 288                            (setq ret
 289                                  (aref ideograph-radical-chars-vector
 290                                        radical)))
 291                (char-ideographic-strokes char)
 292                (aset ideograph-radical-chars-vector radical
 293                      (cons char ret)))))
 294          nil)
 295        feature))
 296     (map-char-attribute
 297      (lambda (char data)
 298        (dolist (cell data)
 299          (setq radical (plist-get cell :radical))
 300          (when (and radical
 301                     (or (null (setq script (get-char-attribute char 'script)))
 302                         (memq 'Ideograph script)))
 303            (unless (memq char
 304                          (setq ret
 305                                (aref ideograph-radical-chars-vector radical)))
 306              (char-ideographic-strokes char)
 307              (aset ideograph-radical-chars-vector radical
 308                    (cons char ret))))))
 309      'ideographic-)))
 310
 311 (defun int-list< (a b)
 312   (if (numberp (car a))
 313       (if (numberp (car b))
 314           (if (= (car a) (car b))
 315               (int-list< (cdr a)(cdr b))
 316             (< (car a) (car b)))
 317         nil)
 318     (numberp (car b))))
 319
 320 (defun morohashi-daikanwa< (a b)
 321   (if (integerp a)
 322       (setq a (list a)))
 323   (if (integerp b)
 324       (setq b (list b)))
 325   (cond ((eq (car a) 'ho)
 326          (if (eq (car b) 'ho)
 327              (int-list< (cdr a)(cdr b))
 328            nil))
 329         ((numberp (car a))
 330          (if (eq (car b) 'ho)
 331              t
 332            (int-list< a b)))
 333         (t
 334          (if (eq (car b) 'ho)
 335              t
 336            (int-list< a b)))))
 337
 338 ;; (defun nil=-int< (a b)
 339 ;;   (cond ((null a) nil)
 340 ;;         ((null b) nil)
 341 ;;         (t (< a b))))
 342
 343 ;; (defun nil>-int< (a b)
 344 ;;   (cond ((null a) nil)
 345 ;;         ((null b) t)
 346 ;;         (t (< a b))))
 347
 348 ;;;###autoload
 349 (defun char-representative-of-daikanwa (char &optional radical
 350                                              ignore-default dont-inherit)
 351   (unless radical
 352     (setq radical ideographic-radical))
 353   (if (or (encode-char char 'ideograph-daikanwa 'defined-only)
 354           (encode-char char '=daikanwa-rev2 'defined-only))
 355       char
 356     (let ((m (char-feature char '=>daikanwa))
 357           m-m m-s pat
 358           ;;scs sc ret
 359           )
 360       (or (and (integerp m)
 361                (or (decode-char '=daikanwa-rev2 m 'defined-only)
 362                    (decode-char 'ideograph-daikanwa m)))
 363           (when (or m
 364                     (setq m (get-char-attribute char 'morohashi-daikanwa)))
 365             (setq m-m (car m))
 366             (setq m-s (nth 1 m))
 367             (if (= m-s 0)
 368                 (or (decode-char '=daikanwa-rev2 m-m 'defined-only)
 369                     (decode-char 'ideograph-daikanwa m-m))
 370               (when m
 371                 (setq pat (list m-m m-s))
 372                 (map-char-attribute (lambda (c v)
 373                                       (if (equal pat v)
 374                                           c))
 375                                     'morohashi-daikanwa))))
 376           (unless dont-inherit
 377             (map-char-family
 378              (lambda (sc)
 379                (let ((ret (char-representative-of-daikanwa sc nil t t)))
 380                  (if (and ret
 381                           (or (null radical)
 382                               (eq (char-ideographic-radical ret radical)
 383                                   radical)))
 384                      ret)))
 385              char))
 386           ;; (when (setq scs (append
 387           ;;                  (get-char-attribute char '->subsumptive)
 388           ;;                  (get-char-attribute char '->denotational)))
 389           ;;   (while (and scs
 390           ;;               (setq sc (car scs))
 391           ;;               (not
 392           ;;                (and
 393           ;;                 (setq ret
 394           ;;                       (char-representative-of-daikanwa sc nil t))
 395           ;;                 (or (null radical)
 396           ;;                     (eq (char-ideographic-radical ret radical)
 397           ;;                         radical)
 398           ;;                     (setq ret nil)))))
 399           ;;     (setq scs (cdr scs)))
 400           ;;   ret)
 401           (unless ignore-default
 402             char)))))
 403
 404 (defun char-attributes-poly< (c1 c2 accessors testers defaulters)
 405   (catch 'tag
 406     (let (a1 a2 accessor tester dm)
 407       (while (and accessors testers)
 408         (setq accessor (car accessors)
 409               tester (car testers)
 410               dm (car defaulters))
 411         (when (and accessor tester)
 412           (setq a1 (funcall accessor c1)
 413                 a2 (funcall accessor c2))
 414           (cond ((null a1)
 415                  (if a2
 416                      (cond ((eq dm '<)
 417                             (throw 'tag t))
 418                            ((eq dm '>)
 419                             (throw 'tag nil)))))
 420                 ((null a2)
 421                  (cond ((eq dm '<)
 422                         (throw 'tag nil))
 423                        ((eq dm '>)
 424                         (throw 'tag t))))
 425                 (t
 426                  (cond ((funcall tester a1 a2)
 427                         (throw 'tag t))
 428                        ((funcall tester a2 a1)
 429                         (throw 'tag nil))))))
 430         (setq accessors (cdr accessors)
 431               testers (cdr testers)
 432               defaulters (cdr defaulters))))))
 433
 434 (defvar ideographic-radical nil)
 435
 436 (defun char-daikanwa-strokes (char &optional radical)
 437   (unless radical
 438     (setq radical ideographic-radical))
 439   (let ((drc (char-representative-of-daikanwa char radical))
 440         (r (char-ideographic-radical char radical)))
 441     (if (or (null r)
 442             (= (char-ideographic-radical drc radical) r))
 443         (setq char drc)))
 444   (char-ideographic-strokes char radical '(daikanwa)))
 445
 446 ;;;###autoload
 447 (defun char-daikanwa (char &optional radical)
 448   (unless radical
 449     (setq radical ideographic-radical))
 450   (map-char-family
 451    (lambda (sc)
 452      (if (or (null radical)
 453              (eq (or (get-char-attribute sc 'ideographic-radical)
 454                      (char-ideographic-radical sc radical t))
 455                  radical))
 456          (let ((ret (or (encode-char sc 'ideograph-daikanwa 'defined-only)
 457                         (encode-char sc '=daikanwa-rev2 'defined-only))))
 458            (if ret
 459                (if (or (eq sc char)
 460                        (and (null (get-char-attribute char '<-subsumptive))
 461                             (null (get-char-attribute char '<-denotational))))
 462                    ret
 463                  (list ret 0))
 464              (or (get-char-attribute sc 'morohashi-daikanwa)
 465                  (if (setq ret (char-feature sc '=>daikanwa))
 466                      (cond ((consp ret) ret)
 467                            ((or (get-char-attribute char '<-subsumptive)
 468                                 (get-char-attribute char '<-denotational))
 469                             (list ret 0))
 470                            (t ret))))))))
 471    char))
 472
 473 ;;;###autoload
 474 (defun char-ucs (char)
 475   (or (encode-char char '=ucs 'defined-only)
 476       (char-feature char '=>ucs)))
 477
 478 (defun char-id (char)
 479   (logand (char-int char) #x3FFFFFFF))
 480
 481 (defun ideograph-char< (a b &optional radical)
 482   (let ((ideographic-radical (or radical
 483                                  ideographic-radical)))
 484     (char-attributes-poly<
 485      a b
 486      '(char-daikanwa-strokes char-daikanwa char-ucs char-id)
 487      '(< morohashi-daikanwa< < <)
 488      '(> > > >))))
 489
 490 (defun insert-ideograph-radical-char-data (radical)
 491   (let ((chars
 492          (sort (copy-list (aref ideograph-radical-chars-vector radical))
 493                (lambda (a b)
 494                  (ideograph-char< a b radical))))
 495         attributes ; ccss
 496         )
 497     (dolist (name (char-attribute-list))
 498       (unless (memq name char-db-ignored-attributes)
 499         ;; (if (find-charset name)
 500         ;;     (push name ccss)
 501         (push name attributes)
 502         ;; )
 503         ))
 504     (setq attributes (sort attributes #'char-attribute-name<)
 505           ;; ccss (sort ccss #'char-attribute-name<)
 506           )
 507     (aset ideograph-radical-chars-vector radical chars)
 508     (dolist (char chars)
 509       (when ;;(or
 510           (not (some (lambda (atr)
 511                        (get-char-attribute char atr))
 512                      char-db-ignored-attributes))
 513         ;; (some (lambda (ccs)
 514         ;;         (encode-char char ccs 'defined-only))
 515         ;;       ccss)
 516         ;;)
 517         (insert-char-data char nil attributes ;ccss
 518                           )))))
 519
 520 (defun write-ideograph-radical-char-data (radical file)
 521   (if (file-directory-p file)
 522       (let ((name (get-char-attribute (int-char (+ #x2EFF radical)) 'name)))
 523         (if (string-match "KANGXI RADICAL " name)
 524             (setq name (capitalize (substring name (match-end 0)))))
 525         (setq name (mapconcat (lambda (char)
 526                                 (if (eq char ? )
 527                                     "-"
 528                                   (char-to-string char))) name ""))
 529         (setq file
 530               (expand-file-name
 531                (format "Ideograph-R%03d-%s.el" radical name)
 532                file))))
 533   (with-temp-buffer
 534     (insert ";; -*- coding: utf-8-mcs -*-\n")
 535     (insert-ideograph-radical-char-data radical)
 536     (let ((coding-system-for-write 'utf-8-mcs))
 537       (write-region (point-min)(point-max) file)
 538       )))
 539
 540 (defun ideographic-structure= (char1 char2)
 541   (if (char-ref-p char1)
 542       (setq char1 (plist-get char1 :char)))
 543   (if (char-ref-p char2)
 544       (setq char2 (plist-get char2 :char)))
 545   (let ((s1 (if (characterp char1)
 546                 (get-char-attribute char1 'ideographic-structure)
 547               (cdr (assq 'ideographic-structure char1))))
 548         (s2 (if (characterp char2)
 549                 (get-char-attribute char2 'ideographic-structure)
 550               (cdr (assq 'ideographic-structure char2))))
 551         e1 e2)
 552     (if (or (null s1)(null s2))
 553         (char-spec= char1 char2)
 554       (catch 'tag
 555         (while (and s1 s2)
 556           (setq e1 (car s1)
 557                 e2 (car s2))
 558           (unless (ideographic-structure= e1 e2)
 559             (throw 'tag nil))
 560           (setq s1 (cdr s1)
 561                 s2 (cdr s2)))
 562         (and (null s1)(null s2))))))
 563
 564 ;;;###autoload
 565 (defun ideographic-structure-find-char (structure)
 566   (let (rest)
 567     (map-char-attribute (lambda (char value)
 568                           (setq rest structure)
 569                           (catch 'tag
 570                             (while (and rest value)
 571                               (unless (ideographic-structure=
 572                                        (car rest)(car value))
 573                                 (throw 'tag nil))
 574                               (setq rest (cdr rest)
 575                                     value (cdr value)))
 576                             (unless (or rest value)
 577                               char)))
 578                         'ideographic-structure)))
 579
 580 ;;;###autoload
 581 (defun chise-string< (string1 string2 accessors)
 582   (let ((len1 (length string1))
 583         (len2 (length string2))
 584         len
 585         (i 0)
 586         c1 c2
 587         rest func
 588         v1 v2)
 589     (setq len (min len1 len2))
 590     (catch 'tag
 591       (while (< i len)
 592         (setq c1 (aref string1 i)
 593               c2 (aref string2 i))
 594         (setq rest accessors)
 595         (while (and rest
 596                     (setq func (car rest))
 597                     (setq v1 (funcall func c1)
 598                           v2 (funcall func c2))
 599                     (eq v1 v2))
 600           (setq rest (cdr rest)))
 601         (if v1
 602             (if v2
 603                 (cond ((< v1 v2)
 604                        (throw 'tag t))
 605                       ((> v1 v2)
 606                        (throw 'tag nil)))
 607               (throw 'tag nil))
 608           (if v2
 609               (throw 'tag t)))
 610         (setq i (1+ i)))
 611       (< len1 len2))))
 612
 613
 614 (provide 'ideograph-util)
 615
 616 ;;; ideograph-util.el ends here