git.chise.org Git - chise/xemacs-chise.git.1/blob - lisp/utf-2000/ideograph-util.el

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