git.chise.org Git - chise/xemacs-chise.git-/blob - lisp/utf-2000/ideograph-util.el

   1 ;;; ideograph-util.el --- Ideographic Character Database utility
   2
   3 ;; Copyright (C) 1999,2000 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 ideograph-char< (a b)
 189   (let ((a-m-m (get-char-attribute a 'ideograph-daikanwa))
 190         (b-m-m (get-char-attribute b 'ideograph-daikanwa))
 191         a-m-r b-m-r
 192         a-s b-s
 193         a-u b-u m)
 194     (if a-m-m
 195         (setq a-s (char-ideographic-strokes a))
 196       (setq a-m-r (get-char-attribute a 'morohashi-daikanwa))
 197       (if a-m-r
 198           (progn
 199             (setq a-m-m (car a-m-r)
 200                   a-m-r (cdr a-m-r))
 201             (if (= (car a-m-r) 0)
 202                 (setq a-s (char-ideographic-strokes
 203                            (decode-char 'ideograph-daikanwa a-m-m)))
 204               (if (setq m (get-char-attribute a '->mojikyo))
 205                   (setq a-s (char-ideographic-strokes
 206                              (decode-char 'mojikyo m)))
 207                 (setq a-s (char-ideographic-strokes a)))))
 208         (setq a-s (char-ideographic-strokes a))))
 209     (if b-m-m
 210         (setq b-s (char-ideographic-strokes b))
 211       (setq b-m-r (get-char-attribute b 'morohashi-daikanwa))
 212       (if b-m-r
 213           (progn
 214             (setq b-m-m (car b-m-r)
 215                   b-m-r (cdr b-m-r))
 216             (if (= (car b-m-r) 0)
 217                 (setq b-s (char-ideographic-strokes
 218                            (decode-char 'ideograph-daikanwa b-m-m)))
 219               (if (setq m (get-char-attribute b '->mojikyo))
 220                   (setq b-s (char-ideographic-strokes
 221                              (decode-char 'mojikyo m)))
 222                 (setq b-s (char-ideographic-strokes b)))))
 223         (setq b-s (char-ideographic-strokes b))))
 224     (if a-s
 225         (if b-s
 226             (if (= a-s b-s)
 227                 (if a-m-m
 228                     (if b-m-m
 229                         (int-list< (cons a-m-m a-m-r)
 230                                    (cons b-m-m b-m-r))
 231                       t)
 232                   (if b-m-m
 233                       nil
 234                     (setq a-u (get-char-attribute a 'ucs)
 235                           b-u (get-char-attribute b 'ucs))
 236                     (if a-u
 237                         (if b-u
 238                             (< a-u b-u)
 239                           (setq b-u (get-char-attribute b '->ucs))
 240                           (if b-u
 241                               (<= a-u b-u)
 242                             t))
 243                       (setq a-u (get-char-attribute a '->ucs))
 244                       (if a-u
 245                           (if b-u
 246                               (< a-u b-u)
 247                             (setq b-u (get-char-attribute b '->ucs))
 248                             (if b-u
 249                                 (< a-u b-u)
 250                               t))
 251                         (if (or b-u (get-char-attribute b '->ucs))
 252                             nil
 253                           (< (char-int a)(char-int b)))))))
 254               (< a-s b-s))
 255           t))))
 256
 257 ;; (defun ideograph-char< (a b)
 258 ;;   (let (ra rb mma mmb msa msb)
 259 ;;     (cond
 260 ;;      ((progn
 261 ;;         (if (setq ra (or (get-char-attribute a 'non-morohashi)
 262 ;;                          (get-char-attribute a 'morohashi-daikanwa)))
 263 ;;             (setq msa (cdr ra)
 264 ;;                   mma (car ra))
 265 ;;           (setq mma (get-char-attribute a 'ideograph-daikanwa))))
 266 ;;       (cond
 267 ;;        ((progn
 268 ;;           (if (setq rb (or (get-char-attribute b 'non-morohashi)
 269 ;;                            (get-char-attribute b 'morohashi-daikanwa)))
 270 ;;               (setq msb (cdr rb)
 271 ;;                     mmb (car rb))
 272 ;;             (setq mmb (get-char-attribute b 'ideograph-daikanwa))))
 273 ;;         (cond
 274 ;;          ((= mma mmb)
 275 ;;           (cond ((eq (car msa)(car msb))
 276 ;;                  (cond ((< (length msa)(length msb)))
 277 ;;                        ((= (length msa)(length msb))
 278 ;;                         (cond ((integerp (nth 1 msa))
 279 ;;                                (cond ((integerp (nth 1 msb))
 280 ;;                                       (< (nth 1 msa)(nth 1 msb)))
 281 ;;                                      (t nil)))
 282 ;;                               (t
 283 ;;                                (cond ((setq ra (get-char-attribute a 'ucs))
 284 ;;                                       (cond
 285 ;;                                        ((setq rb (get-char-attribute b 'ucs))
 286 ;;                                         (< ra rb))
 287 ;;                                        (t))))))))
 288 ;;                  )
 289 ;;                 ((null (car msa)))
 290 ;;                 ((null (car msb))
 291 ;;                  nil)
 292 ;;                 (t (< (car msa)(car msb)))))
 293 ;;          (t (< mma mmb))))
 294 ;;        (t)))
 295 ;;      ((or (get-char-attribute b 'non-morohashi)
 296 ;;           (get-char-attribute b 'morohashi-daikanwa)
 297 ;;           (get-char-attribute b 'ideograph-daikanwa))
 298 ;;       nil)
 299 ;;      ((setq ra (get-char-attribute a 'ucs))
 300 ;;       (cond
 301 ;;        ((setq rb (get-char-attribute b 'ucs))
 302 ;;         (< ra rb))))
 303 ;;      (t
 304 ;;       (cond
 305 ;;        ((setq ra (char-ideographic-strokes a))
 306 ;;         (cond ((setq rb (char-ideographic-strokes b))
 307 ;;                (cond ((= ra rb)
 308 ;;                       (not (char-ideographic-strokes b)))
 309 ;;                      ((< ra rb))))))
 310 ;;        )))))
 311
 312 (defun insert-ideograph-radical-char-data (radical)
 313   (let ((chars
 314          (sort (copy-list (aref ideograph-radical-chars-vector radical))
 315                (function ideograph-char<)))
 316         (attributes (sort (char-attribute-list) #'char-attribute-name<))
 317         (ccs (sort (charset-list) #'char-attribute-name<)))
 318     (aset ideograph-radical-chars-vector radical chars)
 319     (while chars
 320       (insert-char-data (car chars) nil attributes ccs)
 321       (setq chars (cdr chars)))))
 322
 323 (defun write-ideograph-radical-char-data (radical file)
 324   (if (file-directory-p file)
 325       (let ((name (get-char-attribute (int-char (+ #x2EFF radical)) 'name)))
 326         (if (string-match "KANGXI RADICAL " name)
 327             (setq name (capitalize (substring name (match-end 0)))))
 328         (setq name (mapconcat (lambda (char)
 329                                 (if (eq char ? )
 330                                     "-"
 331                                   (char-to-string char))) name ""))
 332         (setq file
 333               (expand-file-name
 334                (format "Ideograph-R%03d-%s.el" radical name)
 335                file))))
 336   (with-temp-buffer
 337     (insert-ideograph-radical-char-data radical)
 338     (char-db-update-comment)
 339     (let ((coding-system-for-write 'utf-8))
 340       (write-region (point-min)(point-max) file)
 341       )))
 342
 343 (provide 'ideograph-util)
 344
 345 ;;; ideograph-util.el ends here