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 rret 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                                   (if (setq rret
 274                                             (get-char-attribute
 275                                              pc '<-subsumptive))
 276                                       (setq ret (append ret rret))
 277                                     (setq dest (cons pc dest)))))
 278                               dest)
 279                           (list chr))
 280                         (let ((rest (append
 281                                      (get-char-attribute chr '<-identical)
 282                                      (get-char-attribute chr '->denotational)))
 283                               pc)
 284                           (setq dest nil)
 285                           (while rest
 286                             (setq pc (car rest))
 287                             (if (memq pc dest)
 288                                 (setq rest (cdr rest))
 289                               (setq dest (cons pc dest))
 290                               (setq rest
 291                                     (append (cdr rest)
 292                                             (get-char-attribute
 293                                              pc '<-identical)
 294                                             (get-char-attribute
 295                                              pc '->denotational)))))
 296                           dest)))
 297            (when (and radical
 298                       (or (eq radical
 299                               (or (get-char-attribute
 300                                    char 'ideographic-radical)
 301                                   (char-ideographic-radical char radical)))
 302                           (null (char-ideographic-radical char)))
 303                       (or (null (setq script
 304                                       (get-char-attribute char 'script)))
 305                           (memq 'Ideograph script)))
 306              (unless (memq char
 307                            (setq ret
 308                                  (aref ideograph-radical-chars-vector
 309                                        radical)))
 310                (char-ideographic-strokes char)
 311                (aset ideograph-radical-chars-vector radical
 312                      (cons char ret)))))
 313          nil)
 314        feature))
 315     (map-char-attribute
 316      (lambda (char data)
 317        (dolist (cell data)
 318          (setq radical (plist-get cell :radical))
 319          (when (and radical
 320                     (or (null (setq script (get-char-attribute char 'script)))
 321                         (memq 'Ideograph script)))
 322            (unless (memq char
 323                          (setq ret
 324                                (aref ideograph-radical-chars-vector radical)))
 325              (char-ideographic-strokes char)
 326              (aset ideograph-radical-chars-vector radical
 327                    (cons char ret))))))
 328      'ideographic-)))
 329
 330 (defun int-list< (a b)
 331   (if (numberp (car a))
 332       (if (numberp (car b))
 333           (if (= (car a) (car b))
 334               (int-list< (cdr a)(cdr b))
 335             (< (car a) (car b)))
 336         nil)
 337     (numberp (car b))))
 338
 339 (defun morohashi-daikanwa< (a b)
 340   (if (integerp a)
 341       (setq a (list a)))
 342   (if (integerp b)
 343       (setq b (list b)))
 344   (cond ((eq (car a) 'ho)
 345          (if (eq (car b) 'ho)
 346              (int-list< (cdr a)(cdr b))
 347            nil))
 348         ((numberp (car a))
 349          (if (eq (car b) 'ho)
 350              t
 351            (int-list< a b)))
 352         (t
 353          (if (eq (car b) 'ho)
 354              t
 355            (int-list< a b)))))
 356
 357 ;; (defun nil=-int< (a b)
 358 ;;   (cond ((null a) nil)
 359 ;;         ((null b) nil)
 360 ;;         (t (< a b))))
 361
 362 ;; (defun nil>-int< (a b)
 363 ;;   (cond ((null a) nil)
 364 ;;         ((null b) t)
 365 ;;         (t (< a b))))
 366
 367 (defvar ideographic-radical nil)
 368
 369 ;;;###autoload
 370 (defun char-representative-of-daikanwa (char &optional radical
 371                                              ignore-default checked)
 372   (unless radical
 373     (setq radical ideographic-radical))
 374   (if (or (null radical)
 375           (eq (or (get-char-attribute char 'ideographic-radical)
 376                   (char-ideographic-radical char radical t))
 377               radical))
 378       (let ((ret (or (encode-char char 'ideograph-daikanwa 'defined-only)
 379                      (encode-char char '=daikanwa-rev2 'defined-only))))
 380         (or (and ret char)
 381             (if (setq ret (get-char-attribute char 'morohashi-daikanwa))
 382                 (let ((m-m (car ret))
 383                       (m-s (nth 1 ret))
 384                       pat)
 385                   (if (= m-s 0)
 386                       (or (decode-char '=daikanwa-rev2 m-m 'defined-only)
 387                           (decode-char 'ideograph-daikanwa m-m))
 388                     (setq pat (list m-m m-s))
 389                     (map-char-attribute (lambda (c v)
 390                                           (if (equal pat v)
 391                                               c))
 392                                         'morohashi-daikanwa))))
 393             (and (setq ret (get-char-attribute char '=>daikanwa))
 394                  (if (numberp ret)
 395                      (or (decode-char '=daikanwa-rev2 ret 'defined-only)
 396                          (decode-char 'ideograph-daikanwa ret))
 397                    (map-char-attribute (lambda (c v)
 398                                          (if (equal ret v)
 399                                              char))
 400                                        'morohashi-daikanwa)))
 401             (unless (memq char checked)
 402               (catch 'tag
 403                 (let ((rest
 404                        (append (get-char-attribute char '->subsumptive)
 405                                (get-char-attribute char '->denotational)))
 406                       (i 0)
 407                       sc)
 408                   (setq checked (cons char checked))
 409                   (while rest
 410                     (setq sc (car rest))
 411                     (if (setq ret (char-representative-of-daikanwa
 412                                    sc radical t checked))
 413                         (throw 'tag ret))
 414                     (setq checked (cons sc checked)
 415                           rest (cdr rest)
 416                           i (1+ i)))
 417                   (setq rest (get-char-attribute char '->identical))
 418                   (while rest
 419                     (setq sc (car rest))
 420                     (when (setq ret (char-representative-of-daikanwa
 421                                      sc radical t checked))
 422                       (throw 'tag ret))
 423                     (setq checked (cons sc checked)
 424                           rest (cdr rest)))
 425                   (setq rest
 426                         (append (get-char-attribute char '<-subsumptive)
 427                                 (get-char-attribute char '<-denotational)))
 428                   (while rest
 429                     (setq sc (car rest))
 430                     (when (setq ret (char-representative-of-daikanwa
 431                                      sc radical t checked))
 432                       (throw 'tag ret))
 433                     (setq checked (cons sc checked)
 434                           rest (cdr rest))))))
 435             (unless ignore-default
 436               char)))))
 437 ;; (defun char-representative-of-daikanwa (char &optional radical
 438 ;;                                              ignore-default dont-inherit)
 439 ;;   (unless radical
 440 ;;     (setq radical ideographic-radical))
 441 ;;   (if (or (encode-char char 'ideograph-daikanwa 'defined-only)
 442 ;;           (encode-char char '=daikanwa-rev2 'defined-only))
 443 ;;       char
 444 ;;     (let ((m (char-feature char '=>daikanwa))
 445 ;;           m-m m-s pat
 446 ;;           scs sc ret
 447 ;;           )
 448 ;;       (or (and (integerp m)
 449 ;;                (or (decode-char '=daikanwa-rev2 m 'defined-only)
 450 ;;                    (decode-char 'ideograph-daikanwa m)))
 451 ;;           (when (or m
 452 ;;                     (setq m (get-char-attribute char 'morohashi-daikanwa)))
 453 ;;             (setq m-m (car m))
 454 ;;             (setq m-s (nth 1 m))
 455 ;;             (if (= m-s 0)
 456 ;;                 (or (decode-char '=daikanwa-rev2 m-m 'defined-only)
 457 ;;                     (decode-char 'ideograph-daikanwa m-m))
 458 ;;               (when m
 459 ;;                 (setq pat (list m-m m-s))
 460 ;;                 (map-char-attribute (lambda (c v)
 461 ;;                                       (if (equal pat v)
 462 ;;                                           c))
 463 ;;                                     'morohashi-daikanwa))))
 464 ;;           (unless dont-inherit
 465 ;;             ;; (map-char-family
 466 ;;             ;;  (lambda (sc)
 467 ;;             ;;    (let ((ret (char-representative-of-daikanwa sc nil t t)))
 468 ;;             ;;      (if (and ret
 469 ;;             ;;               (or (null radical)
 470 ;;             ;;                   (eq (char-ideographic-radical ret radical)
 471 ;;             ;;                       radical)))
 472 ;;             ;;          ret)))
 473 ;;             ;;  char)
 474 ;;             (when (setq scs (append
 475 ;;                              (get-char-attribute char '->subsumptive)
 476 ;;                              (get-char-attribute char '->denotational)))
 477 ;;               (while (and scs
 478 ;;                           (setq sc (car scs))
 479 ;;                           (not
 480 ;;                            (and
 481 ;;                             (setq ret
 482 ;;                                   (char-representative-of-daikanwa sc nil t t))
 483 ;;                             (or (null radical)
 484 ;;                                 (eq (char-ideographic-radical ret radical)
 485 ;;                                     radical)
 486 ;;                                 (setq ret nil)))))
 487 ;;                 (setq scs (cdr scs)))
 488 ;;               ret)
 489 ;;             )
 490 ;;           (unless ignore-default
 491 ;;             char)))))
 492
 493 (defun char-attributes-poly< (c1 c2 accessors testers defaulters)
 494   (catch 'tag
 495     (let (a1 a2 accessor tester dm)
 496       (while (and accessors testers)
 497         (setq accessor (car accessors)
 498               tester (car testers)
 499               dm (car defaulters))
 500         (when (and accessor tester)
 501           (setq a1 (funcall accessor c1)
 502                 a2 (funcall accessor c2))
 503           (cond ((null a1)
 504                  (if a2
 505                      (cond ((eq dm '<)
 506                             (throw 'tag t))
 507                            ((eq dm '>)
 508                             (throw 'tag nil)))))
 509                 ((null a2)
 510                  (cond ((eq dm '<)
 511                         (throw 'tag nil))
 512                        ((eq dm '>)
 513                         (throw 'tag t))))
 514                 (t
 515                  (cond ((funcall tester a1 a2)
 516                         (throw 'tag t))
 517                        ((funcall tester a2 a1)
 518                         (throw 'tag nil))))))
 519         (setq accessors (cdr accessors)
 520               testers (cdr testers)
 521               defaulters (cdr defaulters))))))
 522
 523 (defun char-daikanwa-strokes (char &optional radical)
 524   (unless radical
 525     (setq radical ideographic-radical))
 526   (let ((drc (char-representative-of-daikanwa char radical))
 527         (r (char-ideographic-radical char radical)))
 528     (if (or (null r)
 529             (= (char-ideographic-radical drc radical) r))
 530         (setq char drc)))
 531   (char-ideographic-strokes char radical '(daikanwa)))
 532
 533 ;;;###autoload
 534 (defun char-daikanwa (char &optional radical checked)
 535   (unless radical
 536     (setq radical ideographic-radical))
 537   (if (or (null radical)
 538           (eq (or (get-char-attribute char 'ideographic-radical)
 539                   (char-ideographic-radical char radical t))
 540               radical))
 541       (let ((ret (or (encode-char char 'ideograph-daikanwa 'defined-only)
 542                      (encode-char char '=daikanwa-rev2 'defined-only)
 543                      (get-char-attribute char 'morohashi-daikanwa))))
 544         (or ret
 545             (and (setq ret (get-char-attribute char '=>daikanwa))
 546                  (if (numberp ret)
 547                      (list ret 0)
 548                    (append ret '(0))))
 549             (unless (memq char checked)
 550               (catch 'tag
 551                 (let ((rest
 552                        (append (get-char-attribute char '->subsumptive)
 553                                (get-char-attribute char '->denotational)))
 554                       (i 0)
 555                       sc)
 556                   (setq checked (cons char checked))
 557                   (while rest
 558                     (setq sc (car rest))
 559                     (if (setq ret (char-daikanwa sc radical checked))
 560                         (throw 'tag ret))
 561                     (setq checked (cons sc checked)
 562                           rest (cdr rest)
 563                           i (1+ i)))
 564                   (setq rest (get-char-attribute char '->identical))
 565                   (while rest
 566                     (setq sc (car rest))
 567                     (when (setq ret (char-daikanwa sc radical checked))
 568                       (throw 'tag
 569                              (if (numberp ret)
 570                                  (list ret 0)
 571                                (append ret (list i)))))
 572                     (setq checked (cons sc checked)
 573                           rest (cdr rest)))
 574                   (setq rest
 575                         (append (get-char-attribute char '<-subsumptive)
 576                                 (get-char-attribute char '<-denotational)))
 577                   (while rest
 578                     (setq sc (car rest))
 579                     (when (setq ret (char-daikanwa sc radical checked))
 580                       (throw 'tag
 581                              (if (numberp ret)
 582                                  (list ret 0 i)
 583                                (append ret (list i)))))
 584                     (setq checked (cons sc checked)
 585                           rest (cdr rest))))))))))
 586
 587 ;;;###autoload
 588 (defun char-ucs (char)
 589   (or (encode-char char '=ucs 'defined-only)
 590       (char-feature char '=>ucs)))
 591
 592 (defun char-id (char)
 593   (logand (char-int char) #x3FFFFFFF))
 594
 595 (defun ideograph-char< (a b &optional radical)
 596   (let ((ideographic-radical (or radical
 597                                  ideographic-radical)))
 598     (char-attributes-poly<
 599      a b
 600      '(char-daikanwa-strokes char-daikanwa char-ucs char-id)
 601      '(< morohashi-daikanwa< < <)
 602      '(> > > >))))
 603
 604 (defun insert-ideograph-radical-char-data (radical)
 605   (let ((chars
 606          (sort (copy-list (aref ideograph-radical-chars-vector radical))
 607                (lambda (a b)
 608                  (ideograph-char< a b radical))))
 609         attributes ; ccss
 610         )
 611     (dolist (name (char-attribute-list))
 612       (unless (memq name char-db-ignored-attributes)
 613         ;; (if (find-charset name)
 614         ;;     (push name ccss)
 615         (push name attributes)
 616         ;; )
 617         ))
 618     (setq attributes (sort attributes #'char-attribute-name<)
 619           ;; ccss (sort ccss #'char-attribute-name<)
 620           )
 621     (aset ideograph-radical-chars-vector radical chars)
 622     (dolist (char chars)
 623       (when ;;(or
 624           (not (some (lambda (atr)
 625                        (get-char-attribute char atr))
 626                      char-db-ignored-attributes))
 627         ;; (some (lambda (ccs)
 628         ;;         (encode-char char ccs 'defined-only))
 629         ;;       ccss)
 630         ;;)
 631         (insert-char-data char nil attributes ;ccss
 632                           )))))
 633
 634 (defun write-ideograph-radical-char-data (radical file)
 635   (if (file-directory-p file)
 636       (let ((name (char-feature (decode-char 'ucs (+ #x2EFF radical))
 637                                 'name)))
 638         (if (string-match "KANGXI RADICAL " name)
 639             (setq name (capitalize (substring name (match-end 0)))))
 640         (setq name (mapconcat (lambda (char)
 641                                 (if (eq char ? )
 642                                     "-"
 643                                   (char-to-string char))) name ""))
 644         (setq file
 645               (expand-file-name
 646                (format "Ideograph-R%03d-%s.el" radical name)
 647                file))))
 648   (with-temp-buffer
 649     (insert (format ";; -*- coding: %s -*-\n"
 650                     char-db-file-coding-system))
 651     (insert-ideograph-radical-char-data radical)
 652     (let ((coding-system-for-write char-db-file-coding-system))
 653       (write-region (point-min)(point-max) file))))
 654
 655 (defun ideographic-structure= (char1 char2)
 656   (if (char-ref-p char1)
 657       (setq char1 (plist-get char1 :char)))
 658   (if (char-ref-p char2)
 659       (setq char2 (plist-get char2 :char)))
 660   (let ((s1 (if (characterp char1)
 661                 (get-char-attribute char1 'ideographic-structure)
 662               (cdr (assq 'ideographic-structure char1))))
 663         (s2 (if (characterp char2)
 664                 (get-char-attribute char2 'ideographic-structure)
 665               (cdr (assq 'ideographic-structure char2))))
 666         e1 e2)
 667     (if (or (null s1)(null s2))
 668         (char-spec= char1 char2)
 669       (catch 'tag
 670         (while (and s1 s2)
 671           (setq e1 (car s1)
 672                 e2 (car s2))
 673           (unless (ideographic-structure= e1 e2)
 674             (throw 'tag nil))
 675           (setq s1 (cdr s1)
 676                 s2 (cdr s2)))
 677         (and (null s1)(null s2))))))
 678
 679 ;;;###autoload
 680 (defun ideographic-structure-find-char (structure)
 681   (let (rest)
 682     (map-char-attribute (lambda (char value)
 683                           (setq rest structure)
 684                           (catch 'tag
 685                             (while (and rest value)
 686                               (unless (ideographic-structure=
 687                                        (car rest)(car value))
 688                                 (throw 'tag nil))
 689                               (setq rest (cdr rest)
 690                                     value (cdr value)))
 691                             (unless (or rest value)
 692                               char)))
 693                         'ideographic-structure)))
 694
 695 ;;;###autoload
 696 (defun chise-string< (string1 string2 accessors)
 697   (let ((len1 (length string1))
 698         (len2 (length string2))
 699         len
 700         (i 0)
 701         c1 c2
 702         rest func
 703         v1 v2)
 704     (setq len (min len1 len2))
 705     (catch 'tag
 706       (while (< i len)
 707         (setq c1 (aref string1 i)
 708               c2 (aref string2 i))
 709         (setq rest accessors)
 710         (while (and rest
 711                     (setq func (car rest))
 712                     (setq v1 (funcall func c1)
 713                           v2 (funcall func c2))
 714                     (eq v1 v2))
 715           (setq rest (cdr rest)))
 716         (if v1
 717             (if v2
 718                 (cond ((< v1 v2)
 719                        (throw 'tag t))
 720                       ((> v1 v2)
 721                        (throw 'tag nil)))
 722               (throw 'tag nil))
 723           (if v2
 724               (throw 'tag t)))
 725         (setq i (1+ i)))
 726       (< len1 len2))))
 727
 728
 729 (provide 'ideograph-util)
 730
 731 ;;; ideograph-util.el ends here