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