lisp/utf-2000/ideograph-util.el

   1 ;;; ideograph-util.el --- Ideographic Character Database utility
   2
   3 ;; Copyright (C) 1999,2000,2001 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)
  33   (or (get-char-attribute char 'ideographic-radical)
  34       (let ((radical
  35              (or (get-char-attribute char 'daikanwa-radical)
  36                  (get-char-attribute char 'kangxi-radical)
  37                  (get-char-attribute char 'japanese-radical)
  38                  (get-char-attribute char 'korean-radical))))
  39         (when radical
  40           (put-char-attribute char 'ideographic-radical radical)
  41           radical))))
  42
  43 (defvar ideograph-radical-strokes-vector
  44   ;;0  1  2  3  4  5  6  7  8  9
  45   [nil 1  1  1  1  1  1  2  2  2
  46     2  2  2  2  2  2  2  2  2  2
  47     2  2  2  2  2  2  2  2  2  2
  48     3  3  3  3  3  3  3  3  3  3
  49     3  3  3  3  3  3  3  3  3  3
  50     3  3  3  3  3  3  3  3  3  3
  51     3  4  4  4  3  4  4  4  4  4
  52     4  4  4  4  4  4  4  4  4  4
  53     4  4  4  4  4  3  4  4  4  4
  54     4  4  4  4  3  5  4  5  5  5
  55     ;; 100
  56     5  5  5  5  5  5  5  5  5  5
  57     5  5  5  5  5  5  5  5  6  6
  58     6  6  6  6  6  6  6  6  6  6
  59     4  6  6  6  6  6  6  6  6  6
  60     4  6  6  6  6  6  6  7  7  7
  61     7  7  7  7  7  7  7  7  7  7
  62     7  7  4  3  7  7  7  8  7  8
  63     3  8  8  8  8  8  9  9  9  9
  64     9  9  9  9  8  9  9 10 10 10
  65    10 10 10 10 10 11 11 11 11 11
  66    ;; 200
  67    11 12 12 12 12 13 13 13 13 14
  68    14 15 16 16 17])
  69
  70 (defun char-ideographic-strokes (char)
  71   (or (get-char-attribute char 'daikanwa-strokes)
  72       (get-char-attribute char 'ideographic-strokes)
  73       (let ((strokes
  74              (or (get-char-attribute char 'kangxi-strokes)
  75                  (get-char-attribute char 'japanese-strokes)
  76                  (get-char-attribute char 'korean-strokes)
  77                  (let ((r (char-ideographic-radical char))
  78                        (ts (get-char-attribute char 'total-strokes)))
  79                    (if (and r ts)
  80                        (- ts (aref ideograph-radical-strokes-vector r))))
  81                  )))
  82         (when strokes
  83           (put-char-attribute char 'ideographic-strokes strokes)
  84           strokes))))
  85
  86 ;;;###autoload
  87 (defun update-ideograph-radical-table ()
  88   (interactive)
  89   (let ((i #x3400)
  90         j
  91         char radical
  92         (charsets '(japanese-jisx0208-1978
  93                     japanese-jisx0208
  94                     japanese-jisx0208-1990
  95                     japanese-jisx0212
  96                     japanese-jisx0213-1
  97                     japanese-jisx0213-2
  98                     chinese-cns11643-1
  99                     chinese-cns11643-2
 100                     chinese-cns11643-3
 101                     chinese-cns11643-4
 102                     chinese-cns11643-5
 103                     chinese-cns11643-6
 104                     chinese-cns11643-7
 105                     korean-ksc5601
 106                     chinese-gb2312
 107                     chinese-isoir165
 108                     chinese-big5-1
 109                     chinese-big5-2))
 110         ret script)
 111     (while (<= i #x9FFF)
 112       (setq char (decode-char 'ucs i))
 113       (when (and (or (null (setq script (get-char-attribute char 'script)))
 114                      (memq 'Ideograph script))
 115                  (setq radical (char-ideographic-radical char)))
 116         (or (get-char-attribute char 'ucs)
 117             (put-char-attribute char 'ucs i))
 118         (char-ideographic-strokes char)
 119         (if (not (memq char
 120                        (setq ret
 121                              (aref ideograph-radical-chars-vector radical))))
 122             (aset ideograph-radical-chars-vector radical
 123                   (cons char ret))))
 124       (setq i (1+ i)))
 125     (setq i #x100000)
 126     (while (<= i #x10FFFF)
 127       (setq char (decode-char 'ucs i))
 128       (when (and (or (null (setq script (get-char-attribute char 'script)))
 129                      (memq 'Ideograph script))
 130                  (setq radical (char-ideographic-radical char)))
 131         (if (not (memq char
 132                        (setq ret
 133                              (aref ideograph-radical-chars-vector radical))))
 134             (aset ideograph-radical-chars-vector radical
 135                   (cons char ret))))
 136       (setq i (1+ i)))
 137     (setq i 1)
 138     (while (<= i 66773)
 139       (setq char (decode-char 'ideograph-gt i))
 140       (if (and (setq radical (char-ideographic-radical char))
 141                (not
 142                 (memq char
 143                       (setq ret
 144                             (aref ideograph-radical-chars-vector radical)))))
 145           (aset ideograph-radical-chars-vector radical
 146                 (cons char ret)))
 147       (setq i (1+ i)))
 148     (setq i 0)
 149     (while (< i 50101)
 150       (setq char (decode-char 'ideograph-daikanwa i))
 151       (if (and (setq radical (char-ideographic-radical char))
 152                (not
 153                 (memq char
 154                       (setq ret
 155                             (aref ideograph-radical-chars-vector radical)))))
 156           (aset ideograph-radical-chars-vector radical
 157                 (cons char ret)))
 158       (setq i (1+ i)))
 159     (setq i 0)
 160     (while (< i (* 94 60 22))
 161       (setq char (decode-char 'mojikyo i))
 162       (if (and (setq radical (char-ideographic-radical char))
 163                (not
 164                 (memq char
 165                       (setq ret
 166                             (aref ideograph-radical-chars-vector radical)))))
 167           (aset ideograph-radical-chars-vector radical
 168                 (cons char ret)))
 169       (setq i (1+ i)))
 170     (while charsets
 171       (setq i 33)
 172       (while (< i 127)
 173         (setq j 33)
 174         (while (< j 127)
 175           (setq char (make-char (car charsets) i j))
 176           (if (and (or (null (setq script (get-char-attribute char 'script)))
 177                        (memq 'Ideograph script))
 178                    (setq radical (char-ideographic-radical char))
 179                    (not (memq char
 180                               (setq ret
 181                                     (aref ideograph-radical-chars-vector
 182                                           radical)))))
 183               (aset ideograph-radical-chars-vector radical
 184                     (cons char ret)))
 185           (setq j (1+ j)))
 186         (setq i (1+ i)))
 187       (setq charsets (cdr charsets)))
 188     ))
 189
 190 (defun int-list< (a b)
 191   (if (numberp (car a))
 192       (if (numberp (car b))
 193           (if (= (car a) (car b))
 194               (int-list< (cdr a)(cdr b))
 195             (< (car a) (car b)))
 196         nil)
 197     (numberp (car b))))
 198
 199 (defun morohashi-daikanwa< (a b)
 200   (cond ((eq (car a) 'ho)
 201          (if (eq (car b) 'ho)
 202              (int-list< (cdr a)(cdr b))
 203            nil))
 204         ((numberp (car a))
 205          (if (eq (car b) 'ho)
 206              t
 207            (int-list< a b)))
 208         (t
 209          (if (eq (car b) 'ho)
 210              t
 211            (int-list< a b)))))
 212
 213 (defun ideograph-char< (a b)
 214   (let ((a-m-m (get-char-attribute a 'ideograph-daikanwa))
 215         (b-m-m (get-char-attribute b 'ideograph-daikanwa))
 216         a-m-r b-m-r
 217         a-s b-s
 218         a-u b-u m ret)
 219     (if a-m-m
 220         (setq a-s (char-ideographic-strokes a))
 221       (setq a-m-r (get-char-attribute a 'morohashi-daikanwa))
 222       (if a-m-r
 223           (progn
 224             (setq a-m-m (car a-m-r)
 225                   a-m-r (cdr a-m-r))
 226             (if (= (car a-m-r) 0)
 227                 (progn
 228                   (setq ret (decode-char 'ideograph-daikanwa a-m-m))
 229                   (if (= (get-char-attribute ret 'ideographic-radical)
 230                          (get-char-attribute a 'ideographic-radical))
 231                       (setq a-s (char-ideographic-strokes ret))
 232                     (setq a-s (char-ideographic-strokes a))))
 233               (if (setq m (get-char-attribute a '->mojikyo))
 234                   (setq a-s (char-ideographic-strokes
 235                              (decode-char 'mojikyo m)))
 236                 (setq a-s (char-ideographic-strokes a)))))
 237         (setq a-s (char-ideographic-strokes a))))
 238     (if b-m-m
 239         (setq b-s (char-ideographic-strokes b))
 240       (setq b-m-r (get-char-attribute b 'morohashi-daikanwa))
 241       (if b-m-r
 242           (progn
 243             (setq b-m-m (car b-m-r)
 244                   b-m-r (cdr b-m-r))
 245             (if (= (car b-m-r) 0)
 246                 (progn
 247                   (setq ret (decode-char 'ideograph-daikanwa b-m-m))
 248                   (if (= (get-char-attribute ret 'ideographic-radical)
 249                          (get-char-attribute b 'ideographic-radical))
 250                       (setq b-s (char-ideographic-strokes ret))
 251                     (setq b-s (char-ideographic-strokes b))))
 252               (if (setq m (get-char-attribute b '->mojikyo))
 253                   (setq b-s (char-ideographic-strokes
 254                              (decode-char 'mojikyo m)))
 255                 (setq b-s (char-ideographic-strokes b)))))
 256         (setq b-s (char-ideographic-strokes b))))
 257     (if a-s
 258         (if b-s
 259             (if (= a-s b-s)
 260                 (if a-m-m
 261                     (if b-m-m
 262                         (morohashi-daikanwa< (cons a-m-m a-m-r)
 263                                              (cons b-m-m b-m-r))
 264                       t)
 265                   (if b-m-m
 266                       nil
 267                     (setq a-u (get-char-attribute a 'ucs)
 268                           b-u (get-char-attribute b 'ucs))
 269                     (if a-u
 270                         (if b-u
 271                             (< a-u b-u)
 272                           (setq b-u (or (get-char-attribute b '=>ucs)
 273                                         (get-char-attribute b '->ucs)))
 274                           (if b-u
 275                               (<= a-u b-u)
 276                             t))
 277                       (setq a-u (or (get-char-attribute a '=>ucs)
 278                                     (get-char-attribute a '->ucs)))
 279                       (if a-u
 280                           (if b-u
 281                               (< a-u b-u)
 282                             (setq b-u (or (get-char-attribute b '=>ucs)
 283                                           (get-char-attribute b '->ucs)))
 284                             (if b-u
 285                                 (< a-u b-u)
 286                               t))
 287                         (if (or b-u (or (get-char-attribute b '=>ucs)
 288                                         (get-char-attribute b '->ucs)))
 289                             nil
 290                           (< (char-int a)(char-int b)))))))
 291               (< a-s b-s))
 292           t))))
 293
 294 (defun insert-ideograph-radical-char-data (radical)
 295   (let ((chars
 296          (sort (copy-list (aref ideograph-radical-chars-vector radical))
 297                (function ideograph-char<)))
 298         (attributes (sort (char-attribute-list) #'char-attribute-name<))
 299         (ccs (sort (charset-list) #'char-attribute-name<)))
 300     (aset ideograph-radical-chars-vector radical chars)
 301     (while chars
 302       (insert-char-data (car chars) nil attributes ccs)
 303       (setq chars (cdr chars)))))
 304
 305 (defun write-ideograph-radical-char-data (radical file)
 306   (if (file-directory-p file)
 307       (let ((name (get-char-attribute (int-char (+ #x2EFF radical)) 'name)))
 308         (if (string-match "KANGXI RADICAL " name)
 309             (setq name (capitalize (substring name (match-end 0)))))
 310         (setq name (mapconcat (lambda (char)
 311                                 (if (eq char ? )
 312                                     "-"
 313                                   (char-to-string char))) name ""))
 314         (setq file
 315               (expand-file-name
 316                (format "Ideograph-R%03d-%s.el" radical name)
 317                file))))
 318   (with-temp-buffer
 319     (insert-ideograph-radical-char-data radical)
 320     (char-db-update-comment)
 321     (let ((coding-system-for-write 'utf-8))
 322       (write-region (point-min)(point-max) file)
 323       )))
 324
 325 (provide 'ideograph-util)
 326
 327 ;;; ideograph-util.el ends here