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