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