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