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