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 ;;;###autoload
 364 (defun char-representative-of-daikanwa (char &optional radical
 365                                              ignore-default dont-inherit)
 366   (unless radical
 367     (setq radical ideographic-radical))
 368   (if (or (encode-char char 'ideograph-daikanwa 'defined-only)
 369           (encode-char char '=daikanwa-rev2 'defined-only))
 370       char
 371     (let ((m (char-feature char '=>daikanwa))
 372           m-m m-s pat
 373           ;;scs sc ret
 374           )
 375       (or (and (integerp m)
 376                (or (decode-char '=daikanwa-rev2 m 'defined-only)
 377                    (decode-char 'ideograph-daikanwa m)))
 378           (when (or m
 379                     (setq m (get-char-attribute char 'morohashi-daikanwa)))
 380             (setq m-m (car m))
 381             (setq m-s (nth 1 m))
 382             (if (= m-s 0)
 383                 (or (decode-char '=daikanwa-rev2 m-m 'defined-only)
 384                     (decode-char 'ideograph-daikanwa m-m))
 385               (when m
 386                 (setq pat (list m-m m-s))
 387                 (map-char-attribute (lambda (c v)
 388                                       (if (equal pat v)
 389                                           c))
 390                                     'morohashi-daikanwa))))
 391           (unless dont-inherit
 392             (map-char-family
 393              (lambda (sc)
 394                (let ((ret (char-representative-of-daikanwa sc nil t t)))
 395                  (if (and ret
 396                           (or (null radical)
 397                               (eq (char-ideographic-radical ret radical)
 398                                   radical)))
 399                      ret)))
 400              char))
 401           ;; (when (setq scs (append
 402           ;;                  (get-char-attribute char '->subsumptive)
 403           ;;                  (get-char-attribute char '->denotational)))
 404           ;;   (while (and scs
 405           ;;               (setq sc (car scs))
 406           ;;               (not
 407           ;;                (and
 408           ;;                 (setq ret
 409           ;;                       (char-representative-of-daikanwa sc nil t))
 410           ;;                 (or (null radical)
 411           ;;                     (eq (char-ideographic-radical ret radical)
 412           ;;                         radical)
 413           ;;                     (setq ret nil)))))
 414           ;;     (setq scs (cdr scs)))
 415           ;;   ret)
 416           (unless ignore-default
 417             char)))))
 418
 419 (defun char-attributes-poly< (c1 c2 accessors testers defaulters)
 420   (catch 'tag
 421     (let (a1 a2 accessor tester dm)
 422       (while (and accessors testers)
 423         (setq accessor (car accessors)
 424               tester (car testers)
 425               dm (car defaulters))
 426         (when (and accessor tester)
 427           (setq a1 (funcall accessor c1)
 428                 a2 (funcall accessor c2))
 429           (cond ((null a1)
 430                  (if a2
 431                      (cond ((eq dm '<)
 432                             (throw 'tag t))
 433                            ((eq dm '>)
 434                             (throw 'tag nil)))))
 435                 ((null a2)
 436                  (cond ((eq dm '<)
 437                         (throw 'tag nil))
 438                        ((eq dm '>)
 439                         (throw 'tag t))))
 440                 (t
 441                  (cond ((funcall tester a1 a2)
 442                         (throw 'tag t))
 443                        ((funcall tester a2 a1)
 444                         (throw 'tag nil))))))
 445         (setq accessors (cdr accessors)
 446               testers (cdr testers)
 447               defaulters (cdr defaulters))))))
 448
 449 (defvar ideographic-radical nil)
 450
 451 (defun char-daikanwa-strokes (char &optional radical)
 452   (unless radical
 453     (setq radical ideographic-radical))
 454   (let ((drc (char-representative-of-daikanwa char radical))
 455         (r (char-ideographic-radical char radical)))
 456     (if (or (null r)
 457             (= (char-ideographic-radical drc radical) r))
 458         (setq char drc)))
 459   (char-ideographic-strokes char radical '(daikanwa)))
 460
 461 ;;;###autoload
 462 (defun char-daikanwa (char &optional radical checked)
 463   (unless radical
 464     (setq radical ideographic-radical))
 465   (if (or (null radical)
 466           (eq (or (get-char-attribute char 'ideographic-radical)
 467                   (char-ideographic-radical char radical t))
 468               radical))
 469       (let ((ret (or (encode-char char 'ideograph-daikanwa 'defined-only)
 470                      (encode-char char '=daikanwa-rev2 'defined-only)
 471                      (get-char-attribute char 'morohashi-daikanwa)
 472                      (get-char-attribute char '=>daikanwa))))
 473         (or ret
 474             (unless (memq char checked)
 475               (catch 'tag
 476                 (let ((rest
 477                        (append (get-char-attribute char '->subsumptive)
 478                                (get-char-attribute char '->denotational)))
 479                       (i 0)
 480                       sc)
 481                   (setq checked (cons char checked))
 482                   (while rest
 483                     (setq sc (car rest))
 484                     (if (setq ret (char-daikanwa sc radical checked))
 485                         (throw 'tag ret))
 486                     (setq checked (cons sc checked)
 487                           rest (cdr rest)
 488                           i (1+ i)))
 489                   (setq rest (get-char-attribute char '->identical))
 490                   (while rest
 491                     (setq sc (car rest))
 492                     (when (setq ret (char-daikanwa sc radical checked))
 493                       (throw 'tag
 494                              (if (numberp ret)
 495                                  (list ret 0)
 496                                (append ret (list i)))))
 497                     (setq checked (cons sc checked)
 498                           rest (cdr rest)))
 499                   (setq rest
 500                         (append (get-char-attribute char '<-subsumptive)
 501                                 (get-char-attribute char '<-denotational)))
 502                   (while rest
 503                     (setq sc (car rest))
 504                     (when (setq ret (char-daikanwa sc radical checked))
 505                       (throw 'tag
 506                              (if (numberp ret)
 507                                  (list ret 0 i)
 508                                (append ret (list i)))))
 509                     (setq checked (cons sc checked)
 510                           rest (cdr rest))))))))))
 511
 512 ;;;###autoload
 513 (defun char-ucs (char)
 514   (or (encode-char char '=ucs 'defined-only)
 515       (char-feature char '=>ucs)))
 516
 517 (defun char-id (char)
 518   (logand (char-int char) #x3FFFFFFF))
 519
 520 (defun ideograph-char< (a b &optional radical)
 521   (let ((ideographic-radical (or radical
 522                                  ideographic-radical)))
 523     (char-attributes-poly<
 524      a b
 525      '(char-daikanwa-strokes char-daikanwa char-ucs char-id)
 526      '(< morohashi-daikanwa< < <)
 527      '(> > > >))))
 528
 529 (defun insert-ideograph-radical-char-data (radical)
 530   (let ((chars
 531          (sort (copy-list (aref ideograph-radical-chars-vector radical))
 532                (lambda (a b)
 533                  (ideograph-char< a b radical))))
 534         attributes ; ccss
 535         )
 536     (dolist (name (char-attribute-list))
 537       (unless (memq name char-db-ignored-attributes)
 538         ;; (if (find-charset name)
 539         ;;     (push name ccss)
 540         (push name attributes)
 541         ;; )
 542         ))
 543     (setq attributes (sort attributes #'char-attribute-name<)
 544           ;; ccss (sort ccss #'char-attribute-name<)
 545           )
 546     (aset ideograph-radical-chars-vector radical chars)
 547     (dolist (char chars)
 548       (when ;;(or
 549           (not (some (lambda (atr)
 550                        (get-char-attribute char atr))
 551                      char-db-ignored-attributes))
 552         ;; (some (lambda (ccs)
 553         ;;         (encode-char char ccs 'defined-only))
 554         ;;       ccss)
 555         ;;)
 556         (insert-char-data char nil attributes ;ccss
 557                           )))))
 558
 559 (defun write-ideograph-radical-char-data (radical file)
 560   (if (file-directory-p file)
 561       (let ((name (char-feature (decode-char 'ucs (+ #x2EFF radical))
 562                                 'name)))
 563         (if (string-match "KANGXI RADICAL " name)
 564             (setq name (capitalize (substring name (match-end 0)))))
 565         (setq name (mapconcat (lambda (char)
 566                                 (if (eq char ? )
 567                                     "-"
 568                                   (char-to-string char))) name ""))
 569         (setq file
 570               (expand-file-name
 571                (format "Ideograph-R%03d-%s.el" radical name)
 572                file))))
 573   (with-temp-buffer
 574     (insert (format ";; -*- coding: %s -*-\n"
 575                     char-db-file-coding-system))
 576     (insert-ideograph-radical-char-data radical)
 577     (let ((coding-system-for-write char-db-file-coding-system))
 578       (write-region (point-min)(point-max) file))))
 579
 580 (defun ideographic-structure= (char1 char2)
 581   (if (char-ref-p char1)
 582       (setq char1 (plist-get char1 :char)))
 583   (if (char-ref-p char2)
 584       (setq char2 (plist-get char2 :char)))
 585   (let ((s1 (if (characterp char1)
 586                 (get-char-attribute char1 'ideographic-structure)
 587               (cdr (assq 'ideographic-structure char1))))
 588         (s2 (if (characterp char2)
 589                 (get-char-attribute char2 'ideographic-structure)
 590               (cdr (assq 'ideographic-structure char2))))
 591         e1 e2)
 592     (if (or (null s1)(null s2))
 593         (char-spec= char1 char2)
 594       (catch 'tag
 595         (while (and s1 s2)
 596           (setq e1 (car s1)
 597                 e2 (car s2))
 598           (unless (ideographic-structure= e1 e2)
 599             (throw 'tag nil))
 600           (setq s1 (cdr s1)
 601                 s2 (cdr s2)))
 602         (and (null s1)(null s2))))))
 603
 604 ;;;###autoload
 605 (defun ideographic-structure-find-char (structure)
 606   (let (rest)
 607     (map-char-attribute (lambda (char value)
 608                           (setq rest structure)
 609                           (catch 'tag
 610                             (while (and rest value)
 611                               (unless (ideographic-structure=
 612                                        (car rest)(car value))
 613                                 (throw 'tag nil))
 614                               (setq rest (cdr rest)
 615                                     value (cdr value)))
 616                             (unless (or rest value)
 617                               char)))
 618                         'ideographic-structure)))
 619
 620 ;;;###autoload
 621 (defun chise-string< (string1 string2 accessors)
 622   (let ((len1 (length string1))
 623         (len2 (length string2))
 624         len
 625         (i 0)
 626         c1 c2
 627         rest func
 628         v1 v2)
 629     (setq len (min len1 len2))
 630     (catch 'tag
 631       (while (< i len)
 632         (setq c1 (aref string1 i)
 633               c2 (aref string2 i))
 634         (setq rest accessors)
 635         (while (and rest
 636                     (setq func (car rest))
 637                     (setq v1 (funcall func c1)
 638                           v2 (funcall func c2))
 639                     (eq v1 v2))
 640           (setq rest (cdr rest)))
 641         (if v1
 642             (if v2
 643                 (cond ((< v1 v2)
 644                        (throw 'tag t))
 645                       ((> v1 v2)
 646                        (throw 'tag nil)))
 647               (throw 'tag nil))
 648           (if v2
 649               (throw 'tag t)))
 650         (setq i (1+ i)))
 651       (< len1 len2))))
 652
 653
 654 (provide 'ideograph-util)
 655
 656 ;;; ideograph-util.el ends here