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 MORIOKA Tomohiko.
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
   6 ;; Keywords: UTF-2000, ISO/IEC 10646, Unicode, UCS-4, MULE.
   7
   8 ;; This file is part of XEmacs UTF-2000.
   9
  10 ;; XEmacs UTF-2000 is free software; you can redistribute it and/or
  11 ;; modify it under the terms of the GNU General Public License as
  12 ;; published by the Free Software Foundation; either version 2, or (at
  13 ;; your option) any later version.
  14
  15 ;; XEmacs UTF-2000 is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with XEmacs UTF-2000; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Code:
  26
  27 (require 'char-db-util)
  28
  29 (defvar ideograph-radical-chars-vector
  30   (make-vector 215 nil))
  31
  32 (defun char-ideographic-radical (char &optional radical)
  33   (let (ret)
  34     (or (catch 'tag
  35           (dolist (domain '(ucs daikanwa cns))
  36             (if (and (setq ret (get-char-attribute
  37                                 char
  38                                 (intern
  39                                  (format "%s@%s"
  40                                          'ideographic-radical domain))))
  41                      (or (eq ret radical)
  42                          (null radical)))
  43                 (throw 'tag ret))))
  44         (catch 'tag
  45           (dolist (cell (get-char-attribute char 'ideographic-))
  46             (if (and (setq ret (plist-get cell :radical))
  47                      (or (eq ret radical)
  48                          (null radical)))
  49                 (throw 'tag ret))))
  50         (get-char-attribute char 'ideographic-radical)
  51         (progn
  52           (setq ret
  53                 (or (get-char-attribute char 'daikanwa-radical)
  54                     (get-char-attribute char 'kangxi-radical)
  55                     (get-char-attribute char 'japanese-radical)
  56                     (get-char-attribute char 'korean-radical)))
  57           (when ret
  58             (put-char-attribute char 'ideographic-radical ret)
  59             ret)))))
  60
  61 (defvar ideograph-radical-strokes-vector
  62   ;;0  1  2  3  4  5  6  7  8  9
  63   [nil 1  1  1  1  1  1  2  2  2
  64     2  2  2  2  2  2  2  2  2  2
  65     2  2  2  2  2  2  2  2  2  2
  66     3  3  3  3  3  3  3  3  3  3
  67     3  3  3  3  3  3  3  3  3  3
  68     3  3  3  3  3  3  3  3  3  3
  69     3  4  4  4  3  4  4  4  4  4
  70     4  4  4  4  4  4  4  4  4  4
  71     4  4  4  4  4  3  4  4  4  4
  72     4  4  4  4  3  5  4  5  5  5
  73     ;; 100
  74     5  5  5  5  5  5  5  5  5  5
  75     5  5  5  5  5  5  5  5  6  6
  76     6  6  6  6  6  6  6  6  6  6
  77     4  6  6  6  6  6  6  6  6  6
  78     4  6  6  6  6  6  6  7  7  7
  79     7  7  7  7  7  7  7  7  7  7
  80     7  7  4  3  7  7  7  8  7  8
  81     3  8  8  8  8  8  9  9  9  9
  82     9  9  9  9  8  9  9 10 10 10
  83    10 10 10 10 10 11 11 11 11 11
  84    ;; 200
  85    11 12 12 12 12 13 13 13 13 14
  86    14 15 16 16 17])
  87
  88 (defun char-ideographic-strokes (char &optional radical)
  89   (let (ret)
  90     (or (catch 'tag
  91           (dolist (domain '(ucs daikanwa cns))
  92             (if (and (setq ret (get-char-attribute
  93                                 char
  94                                 (intern
  95                                  (format "%s@%s"
  96                                          'ideographic-radical domain))))
  97                      (or (eq ret radical)
  98                          (null radical)))
  99                 (throw 'tag
 100                        (get-char-attribute
 101                         char
 102                         (intern
 103                          (format "%s@%s"
 104                                  'ideographic-strokes domain)))))))
 105         (catch 'tag
 106           (dolist (cell (get-char-attribute char 'ideographic-))
 107             (if (and (setq ret (plist-get cell :radical))
 108                      (or (eq ret radical)
 109                          (null radical)))
 110                 (throw 'tag (plist-get cell :strokes)))))
 111         (get-char-attribute char 'daikanwa-strokes)
 112         (get-char-attribute char 'ideographic-strokes)
 113         (let ((strokes
 114                (or (get-char-attribute char 'kangxi-strokes)
 115                    (get-char-attribute char 'japanese-strokes)
 116                    (get-char-attribute char 'korean-strokes)
 117                    (let ((r (char-ideographic-radical char))
 118                          (ts (get-char-attribute char 'total-strokes)))
 119                      (if (and r ts)
 120                          (- ts (aref ideograph-radical-strokes-vector r))))
 121                    )))
 122           (when strokes
 123             (put-char-attribute char 'ideographic-strokes strokes)
 124             strokes)))))
 125
 126 ;;;###autoload
 127 (defun update-ideograph-radical-table ()
 128   (interactive)
 129   (let (ret radical script)
 130     (dolist (domain '(ucs daikanwa cns))
 131       (map-char-attribute
 132        (lambda (char radical)
 133          (when (and radical
 134                     (or (null (setq script (get-char-attribute char 'script)))
 135                         (memq 'Ideograph script)))
 136            (unless (memq char
 137                          (setq ret
 138                                (aref ideograph-radical-chars-vector radical)))
 139              (char-ideographic-strokes char)
 140              (aset ideograph-radical-chars-vector radical
 141                    (cons char ret))))
 142          nil)
 143        (intern (format "%s@%s" 'ideographic-radical domain))))
 144     (map-char-attribute
 145      (lambda (char radical)
 146        (when (and radical
 147                   (or (null (setq script (get-char-attribute char 'script)))
 148                       (memq 'Ideograph script)))
 149          (unless (memq char
 150                        (setq ret
 151                              (aref ideograph-radical-chars-vector radical)))
 152            (char-ideographic-strokes char)
 153            (aset ideograph-radical-chars-vector radical
 154                  (cons char ret))))
 155        nil)
 156      'ideographic-radical)
 157     (map-char-attribute
 158      (lambda (char data)
 159        (dolist (cell data)
 160          (setq radical (plist-get cell :radical))
 161          (when (and radical
 162                     (or (null (setq script (get-char-attribute char 'script)))
 163                         (memq 'Ideograph script)))
 164            (unless (memq char
 165                          (setq ret
 166                                (aref ideograph-radical-chars-vector radical)))
 167              (char-ideographic-strokes char)
 168              (aset ideograph-radical-chars-vector radical
 169                    (cons char ret))))))
 170      'ideographic-)))
 171
 172 (defun int-list< (a b)
 173   (if (numberp (car a))
 174       (if (numberp (car b))
 175           (if (= (car a) (car b))
 176               (int-list< (cdr a)(cdr b))
 177             (< (car a) (car b)))
 178         nil)
 179     (numberp (car b))))
 180
 181 (defun morohashi-daikanwa< (a b)
 182   (if (integerp a)
 183       (setq a (list a)))
 184   (if (integerp b)
 185       (setq b (list b)))
 186   (cond ((eq (car a) 'ho)
 187          (if (eq (car b) 'ho)
 188              (int-list< (cdr a)(cdr b))
 189            nil))
 190         ((numberp (car a))
 191          (if (eq (car b) 'ho)
 192              t
 193            (int-list< a b)))
 194         (t
 195          (if (eq (car b) 'ho)
 196              t
 197            (int-list< a b)))))
 198
 199 ;; (defun nil=-int< (a b)
 200 ;;   (cond ((null a) nil)
 201 ;;         ((null b) nil)
 202 ;;         (t (< a b))))
 203
 204 ;; (defun nil>-int< (a b)
 205 ;;   (cond ((null a) nil)
 206 ;;         ((null b) t)
 207 ;;         (t (< a b))))
 208
 209 ;;;###autoload
 210 (defun char-representative-of-daikanwa (char)
 211   (if (or (encode-char char 'ideograph-daikanwa 'defined-only)
 212           (encode-char char '=daikanwa-rev2 'defined-only))
 213       char
 214     (let ((m (get-char-attribute char 'morohashi-daikanwa))
 215           m-m m-s pat)
 216       (or (when m
 217             (setq m-m (pop m))
 218             (setq m-s (pop m))
 219             (if (= m-s 0)
 220                 (or (decode-char '=daikanwa-rev2 m-m 'defined-only)
 221                     (decode-char 'ideograph-daikanwa m-m))
 222               (when m
 223                 (setq pat (list m-m m-s))
 224                 (map-char-attribute (lambda (c v)
 225                                       (if (equal pat v)
 226                                           c))
 227                                     'morohashi-daikanwa))))
 228           char))))
 229
 230 (defun char-attributes-poly< (c1 c2 accessors testers defaulters)
 231   (catch 'tag
 232     (let (a1 a2 accessor tester dm)
 233       (while (and accessors testers)
 234         (setq accessor (car accessors)
 235               tester (car testers)
 236               dm (car defaulters))
 237         (when (and accessor tester)
 238           (setq a1 (funcall accessor c1)
 239                 a2 (funcall accessor c2))
 240           (cond ((null a1)
 241                  (if a2
 242                      (cond ((eq dm '<)
 243                             (throw 'tag t))
 244                            ((eq dm '>)
 245                             (throw 'tag nil)))))
 246                 ((null a2)
 247                  (cond ((eq dm '<)
 248                         (throw 'tag nil))
 249                        ((eq dm '>)
 250                         (throw 'tag t))))
 251                 (t
 252                  (cond ((funcall tester a1 a2)
 253                         (throw 'tag t))
 254                        ((funcall tester a2 a1)
 255                         (throw 'tag nil))))))
 256         (setq accessors (cdr accessors)
 257               testers (cdr testers)
 258               defaulters (cdr defaulters))))))
 259
 260 (defvar ideographic-radical nil)
 261
 262 (defun char-daikanwa-strokes (char &optional radical)
 263   (unless radical
 264     (setq radical ideographic-radical))
 265   (let ((drc (char-representative-of-daikanwa char)))
 266     (char-ideographic-strokes
 267      (if (= (char-ideographic-radical drc radical)
 268             (char-ideographic-radical char radical))
 269          drc
 270        char)
 271      radical)))
 272
 273 ;;;###autoload
 274 (defun char-daikanwa (char)
 275   (or (encode-char char 'ideograph-daikanwa 'defined-only)
 276       (encode-char char '=daikanwa-rev2 'defined-only)
 277       (get-char-attribute char 'morohashi-daikanwa)))
 278
 279 ;;;###autoload
 280 (defun char-ucs (char)
 281   (or (encode-char char '=ucs 'defined-only)
 282       (get-char-attribute char '=>ucs)))
 283
 284 (defun char-id (char)
 285   (logand (char-int char) #x3FFFFFFF))
 286
 287 (defun ideograph-char< (a b &optional radical)
 288   (let ((ideographic-radical (or radical
 289                                  ideographic-radical)))
 290     (char-attributes-poly<
 291      a b
 292      '(char-daikanwa-strokes char-daikanwa char-ucs char-id)
 293      '(< morohashi-daikanwa< < <)
 294      '(> > > >))))
 295
 296 (defun insert-ideograph-radical-char-data (radical)
 297   (let ((chars
 298          (sort (copy-list (aref ideograph-radical-chars-vector radical))
 299                (lambda (a b)
 300                  (ideograph-char< a b radical))))
 301         attributes ccss)
 302     (dolist (name (char-attribute-list))
 303       (unless (memq name char-db-ignored-attributes)
 304         (if (find-charset name)
 305             (push name ccss)
 306           (push name attributes))))
 307     (setq attributes (sort attributes #'char-attribute-name<)
 308           ccss (sort ccss #'char-attribute-name<))
 309     (aset ideograph-radical-chars-vector radical chars)
 310     (dolist (char chars)
 311       (when (or (not (some (lambda (atr)
 312                              (get-char-attribute char atr))
 313                            char-db-ignored-attributes))
 314                 (some (lambda (ccs)
 315                         (encode-char char ccs 'defined-only))
 316                       ccss))
 317         (insert-char-data char nil attributes ccss)))))
 318
 319 (defun write-ideograph-radical-char-data (radical file)
 320   (if (file-directory-p file)
 321       (let ((name (get-char-attribute (int-char (+ #x2EFF radical)) 'name)))
 322         (if (string-match "KANGXI RADICAL " name)
 323             (setq name (capitalize (substring name (match-end 0)))))
 324         (setq name (mapconcat (lambda (char)
 325                                 (if (eq char ? )
 326                                     "-"
 327                                   (char-to-string char))) name ""))
 328         (setq file
 329               (expand-file-name
 330                (format "Ideograph-R%03d-%s.el" radical name)
 331                file))))
 332   (with-temp-buffer
 333     (insert-ideograph-radical-char-data radical)
 334     (let ((coding-system-for-write 'utf-8))
 335       (write-region (point-min)(point-max) file)
 336       )))
 337
 338 (defun ideographic-structure= (char1 char2)
 339   (if (char-ref-p char1)
 340       (setq char1 (plist-get char1 :char)))
 341   (if (char-ref-p char2)
 342       (setq char2 (plist-get char2 :char)))
 343   (let ((s1 (if (characterp char1)
 344                 (get-char-attribute char1 'ideographic-structure)
 345               (cdr (assq 'ideographic-structure char1))))
 346         (s2 (if (characterp char2)
 347                 (get-char-attribute char2 'ideographic-structure)
 348               (cdr (assq 'ideographic-structure char2))))
 349         e1 e2)
 350     (if (or (null s1)(null s2))
 351         (char-spec= char1 char2)
 352       (catch 'tag
 353         (while (and s1 s2)
 354           (setq e1 (car s1)
 355                 e2 (car s2))
 356           (unless (ideographic-structure= e1 e2)
 357             (throw 'tag nil))
 358           (setq s1 (cdr s1)
 359                 s2 (cdr s2)))
 360         (and (null s1)(null s2))))))
 361
 362 ;;;###autoload
 363 (defun ideographic-structure-find-char (structure)
 364   (let (rest)
 365     (map-char-attribute (lambda (char value)
 366                           (setq rest structure)
 367                           (catch 'tag
 368                             (while (and rest value)
 369                               (unless (ideographic-structure=
 370                                        (car rest)(car value))
 371                                 (throw 'tag nil))
 372                               (setq rest (cdr rest)
 373                                     value (cdr value)))
 374                             (unless (or rest value)
 375                               char)))
 376                         'ideographic-structure)))
 377
 378 (provide 'ideograph-util)
 379
 380 ;;; ideograph-util.el ends here