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