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