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 UTF-2000.
   9
  10 ;; UTF-2000 is free software; you can redistribute it and/or modify it
  11 ;; under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; UTF-2000 is distributed in the hope that it will be useful, but
  16 ;; 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; see the file COPYING.  If not, write to the Free
  22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  23 ;; 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 (get-char-attribute b '->ucs))
 273                           (if b-u
 274                               (<= a-u b-u)
 275                             t))
 276                       (setq a-u (get-char-attribute a '->ucs))
 277                       (if a-u
 278                           (if b-u
 279                               (< a-u b-u)
 280                             (setq b-u (get-char-attribute b '->ucs))
 281                             (if b-u
 282                                 (< a-u b-u)
 283                               t))
 284                         (if (or b-u (get-char-attribute b '->ucs))
 285                             nil
 286                           (< (char-int a)(char-int b)))))))
 287               (< a-s b-s))
 288           t))))
 289
 290 ;; (defun ideograph-char< (a b)
 291 ;;   (let (ra rb mma mmb msa msb)
 292 ;;     (cond
 293 ;;      ((progn
 294 ;;         (if (setq ra (or (get-char-attribute a 'non-morohashi)
 295 ;;                          (get-char-attribute a 'morohashi-daikanwa)))
 296 ;;             (setq msa (cdr ra)
 297 ;;                   mma (car ra))
 298 ;;           (setq mma (get-char-attribute a 'ideograph-daikanwa))))
 299 ;;       (cond
 300 ;;        ((progn
 301 ;;           (if (setq rb (or (get-char-attribute b 'non-morohashi)
 302 ;;                            (get-char-attribute b 'morohashi-daikanwa)))
 303 ;;               (setq msb (cdr rb)
 304 ;;                     mmb (car rb))
 305 ;;             (setq mmb (get-char-attribute b 'ideograph-daikanwa))))
 306 ;;         (cond
 307 ;;          ((= mma mmb)
 308 ;;           (cond ((eq (car msa)(car msb))
 309 ;;                  (cond ((< (length msa)(length msb)))
 310 ;;                        ((= (length msa)(length msb))
 311 ;;                         (cond ((integerp (nth 1 msa))
 312 ;;                                (cond ((integerp (nth 1 msb))
 313 ;;                                       (< (nth 1 msa)(nth 1 msb)))
 314 ;;                                      (t nil)))
 315 ;;                               (t
 316 ;;                                (cond ((setq ra (get-char-attribute a 'ucs))
 317 ;;                                       (cond
 318 ;;                                        ((setq rb (get-char-attribute b 'ucs))
 319 ;;                                         (< ra rb))
 320 ;;                                        (t))))))))
 321 ;;                  )
 322 ;;                 ((null (car msa)))
 323 ;;                 ((null (car msb))
 324 ;;                  nil)
 325 ;;                 (t (< (car msa)(car msb)))))
 326 ;;          (t (< mma mmb))))
 327 ;;        (t)))
 328 ;;      ((or (get-char-attribute b 'non-morohashi)
 329 ;;           (get-char-attribute b 'morohashi-daikanwa)
 330 ;;           (get-char-attribute b 'ideograph-daikanwa))
 331 ;;       nil)
 332 ;;      ((setq ra (get-char-attribute a 'ucs))
 333 ;;       (cond
 334 ;;        ((setq rb (get-char-attribute b 'ucs))
 335 ;;         (< ra rb))))
 336 ;;      (t
 337 ;;       (cond
 338 ;;        ((setq ra (char-ideographic-strokes a))
 339 ;;         (cond ((setq rb (char-ideographic-strokes b))
 340 ;;                (cond ((= ra rb)
 341 ;;                       (not (char-ideographic-strokes b)))
 342 ;;                      ((< ra rb))))))
 343 ;;        )))))
 344
 345 (defun insert-ideograph-radical-char-data (radical)
 346   (let ((chars
 347          (sort (copy-list (aref ideograph-radical-chars-vector radical))
 348                (function ideograph-char<)))
 349         (attributes (sort (char-attribute-list) #'char-attribute-name<))
 350         (ccs (sort (charset-list) #'char-attribute-name<)))
 351     (aset ideograph-radical-chars-vector radical chars)
 352     (while chars
 353       (insert-char-data (car chars) nil attributes ccs)
 354       (setq chars (cdr chars)))))
 355
 356 (defun write-ideograph-radical-char-data (radical file)
 357   (if (file-directory-p file)
 358       (let ((name (get-char-attribute (int-char (+ #x2EFF radical)) 'name)))
 359         (if (string-match "KANGXI RADICAL " name)
 360             (setq name (capitalize (substring name (match-end 0)))))
 361         (setq name (mapconcat (lambda (char)
 362                                 (if (eq char ? )
 363                                     "-"
 364                                   (char-to-string char))) name ""))
 365         (setq file
 366               (expand-file-name
 367                (format "Ideograph-R%03d-%s.el" radical name)
 368                file))))
 369   (with-temp-buffer
 370     (insert-ideograph-radical-char-data radical)
 371     (char-db-update-comment)
 372     (let ((coding-system-for-write 'utf-8))
 373       (write-region (point-min)(point-max) file)
 374       )))
 375
 376 (provide 'ideograph-util)
 377
 378 ;;; ideograph-util.el ends here