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