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 0)
 138     (while (< i 50101)
 139       (setq char (decode-char 'ideograph-daikanwa 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 (* 94 60 22))
 150       (setq char (decode-char 'mojikyo 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     (while charsets
 160       (setq i 33)
 161       (while (< i 127)
 162         (setq j 33)
 163         (while (< j 127)
 164           (setq char (make-char (car charsets) i j))
 165           (if (and (or (null (setq script (get-char-attribute char 'script)))
 166                        (memq 'Ideograph script))
 167                    (setq radical (char-ideographic-radical char))
 168                    (not (memq char
 169                               (setq ret
 170                                     (aref ideograph-radical-chars-vector
 171                                           radical)))))
 172               (aset ideograph-radical-chars-vector radical
 173                     (cons char ret)))
 174           (setq j (1+ j)))
 175         (setq i (1+ i)))
 176       (setq charsets (cdr charsets)))
 177     ))
 178
 179 (defun int-list< (a b)
 180   (if (numberp (car a))
 181       (if (numberp (car b))
 182           (if (= (car a) (car b))
 183               (int-list< (cdr a)(cdr b))
 184             (< (car a) (car b)))
 185         nil)
 186     (numberp (car b))))
 187
 188 (defun morohashi-daikanwa< (a b)
 189   (cond ((eq (car a) 'ho)
 190          (if (eq (car b) 'ho)
 191              (int-list< (cdr a)(cdr b))
 192            nil))
 193         ((numberp (car a))
 194          (if (eq (car b) 'ho)
 195              t
 196            (int-list< a b)))
 197         (t
 198          (if (eq (car b) 'ho)
 199              t
 200            (int-list< a b)))))
 201
 202 (defun ideograph-char< (a b)
 203   (let ((a-m-m (get-char-attribute a 'ideograph-daikanwa))
 204         (b-m-m (get-char-attribute b 'ideograph-daikanwa))
 205         a-m-r b-m-r
 206         a-s b-s
 207         a-u b-u m ret)
 208     (if a-m-m
 209         (setq a-s (char-ideographic-strokes a))
 210       (setq a-m-r (get-char-attribute a 'morohashi-daikanwa))
 211       (if a-m-r
 212           (progn
 213             (setq a-m-m (car a-m-r)
 214                   a-m-r (cdr a-m-r))
 215             (if (= (car a-m-r) 0)
 216                 (progn
 217                   (setq ret (decode-char 'ideograph-daikanwa a-m-m))
 218                   (if (= (get-char-attribute ret 'ideographic-radical)
 219                          (get-char-attribute a 'ideographic-radical))
 220                       (setq a-s (char-ideographic-strokes ret))
 221                     (setq a-s (char-ideographic-strokes a))))
 222               (if (setq m (get-char-attribute a '->mojikyo))
 223                   (setq a-s (char-ideographic-strokes
 224                              (decode-char 'mojikyo m)))
 225                 (setq a-s (char-ideographic-strokes a)))))
 226         (setq a-s (char-ideographic-strokes a))))
 227     (if b-m-m
 228         (setq b-s (char-ideographic-strokes b))
 229       (setq b-m-r (get-char-attribute b 'morohashi-daikanwa))
 230       (if b-m-r
 231           (progn
 232             (setq b-m-m (car b-m-r)
 233                   b-m-r (cdr b-m-r))
 234             (if (= (car b-m-r) 0)
 235                 (progn
 236                   (setq ret (decode-char 'ideograph-daikanwa b-m-m))
 237                   (if (= (get-char-attribute ret 'ideographic-radical)
 238                          (get-char-attribute b 'ideographic-radical))
 239                       (setq b-s (char-ideographic-strokes ret))
 240                     (setq b-s (char-ideographic-strokes b))))
 241               (if (setq m (get-char-attribute b '->mojikyo))
 242                   (setq b-s (char-ideographic-strokes
 243                              (decode-char 'mojikyo m)))
 244                 (setq b-s (char-ideographic-strokes b)))))
 245         (setq b-s (char-ideographic-strokes b))))
 246     (if a-s
 247         (if b-s
 248             (if (= a-s b-s)
 249                 (if a-m-m
 250                     (if b-m-m
 251                         (morohashi-daikanwa< (cons a-m-m a-m-r)
 252                                              (cons b-m-m b-m-r))
 253                       t)
 254                   (if b-m-m
 255                       nil
 256                     (setq a-u (get-char-attribute a 'ucs)
 257                           b-u (get-char-attribute b 'ucs))
 258                     (if a-u
 259                         (if b-u
 260                             (< a-u b-u)
 261                           (setq b-u (get-char-attribute b '->ucs))
 262                           (if b-u
 263                               (<= a-u b-u)
 264                             t))
 265                       (setq a-u (get-char-attribute a '->ucs))
 266                       (if a-u
 267                           (if b-u
 268                               (< a-u b-u)
 269                             (setq b-u (get-char-attribute b '->ucs))
 270                             (if b-u
 271                                 (< a-u b-u)
 272                               t))
 273                         (if (or b-u (get-char-attribute b '->ucs))
 274                             nil
 275                           (< (char-int a)(char-int b)))))))
 276               (< a-s b-s))
 277           t))))
 278
 279 ;; (defun ideograph-char< (a b)
 280 ;;   (let (ra rb mma mmb msa msb)
 281 ;;     (cond
 282 ;;      ((progn
 283 ;;         (if (setq ra (or (get-char-attribute a 'non-morohashi)
 284 ;;                          (get-char-attribute a 'morohashi-daikanwa)))
 285 ;;             (setq msa (cdr ra)
 286 ;;                   mma (car ra))
 287 ;;           (setq mma (get-char-attribute a 'ideograph-daikanwa))))
 288 ;;       (cond
 289 ;;        ((progn
 290 ;;           (if (setq rb (or (get-char-attribute b 'non-morohashi)
 291 ;;                            (get-char-attribute b 'morohashi-daikanwa)))
 292 ;;               (setq msb (cdr rb)
 293 ;;                     mmb (car rb))
 294 ;;             (setq mmb (get-char-attribute b 'ideograph-daikanwa))))
 295 ;;         (cond
 296 ;;          ((= mma mmb)
 297 ;;           (cond ((eq (car msa)(car msb))
 298 ;;                  (cond ((< (length msa)(length msb)))
 299 ;;                        ((= (length msa)(length msb))
 300 ;;                         (cond ((integerp (nth 1 msa))
 301 ;;                                (cond ((integerp (nth 1 msb))
 302 ;;                                       (< (nth 1 msa)(nth 1 msb)))
 303 ;;                                      (t nil)))
 304 ;;                               (t
 305 ;;                                (cond ((setq ra (get-char-attribute a 'ucs))
 306 ;;                                       (cond
 307 ;;                                        ((setq rb (get-char-attribute b 'ucs))
 308 ;;                                         (< ra rb))
 309 ;;                                        (t))))))))
 310 ;;                  )
 311 ;;                 ((null (car msa)))
 312 ;;                 ((null (car msb))
 313 ;;                  nil)
 314 ;;                 (t (< (car msa)(car msb)))))
 315 ;;          (t (< mma mmb))))
 316 ;;        (t)))
 317 ;;      ((or (get-char-attribute b 'non-morohashi)
 318 ;;           (get-char-attribute b 'morohashi-daikanwa)
 319 ;;           (get-char-attribute b 'ideograph-daikanwa))
 320 ;;       nil)
 321 ;;      ((setq ra (get-char-attribute a 'ucs))
 322 ;;       (cond
 323 ;;        ((setq rb (get-char-attribute b 'ucs))
 324 ;;         (< ra rb))))
 325 ;;      (t
 326 ;;       (cond
 327 ;;        ((setq ra (char-ideographic-strokes a))
 328 ;;         (cond ((setq rb (char-ideographic-strokes b))
 329 ;;                (cond ((= ra rb)
 330 ;;                       (not (char-ideographic-strokes b)))
 331 ;;                      ((< ra rb))))))
 332 ;;        )))))
 333
 334 (defun insert-ideograph-radical-char-data (radical)
 335   (let ((chars
 336          (sort (copy-list (aref ideograph-radical-chars-vector radical))
 337                (function ideograph-char<)))
 338         (attributes (sort (char-attribute-list) #'char-attribute-name<))
 339         (ccs (sort (charset-list) #'char-attribute-name<)))
 340     (aset ideograph-radical-chars-vector radical chars)
 341     (while chars
 342       (insert-char-data (car chars) nil attributes ccs)
 343       (setq chars (cdr chars)))))
 344
 345 (defun write-ideograph-radical-char-data (radical file)
 346   (if (file-directory-p file)
 347       (let ((name (get-char-attribute (int-char (+ #x2EFF radical)) 'name)))
 348         (if (string-match "KANGXI RADICAL " name)
 349             (setq name (capitalize (substring name (match-end 0)))))
 350         (setq name (mapconcat (lambda (char)
 351                                 (if (eq char ? )
 352                                     "-"
 353                                   (char-to-string char))) name ""))
 354         (setq file
 355               (expand-file-name
 356                (format "Ideograph-R%03d-%s.el" radical name)
 357                file))))
 358   (with-temp-buffer
 359     (insert-ideograph-radical-char-data radical)
 360     (char-db-update-comment)
 361     (let ((coding-system-for-write 'utf-8))
 362       (write-region (point-min)(point-max) file)
 363       )))
 364
 365 (provide 'ideograph-util)
 366
 367 ;;; ideograph-util.el ends here