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