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