lisp/utf-2000/ideograph-util.el

   1 ;;; ideograph-util.el --- Ideographic Character Database utility
   2
   3 ;; Copyright (C) 1999 MORIOKA Tomohiko.
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@m17n.org>
   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-ideograph-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 (defun char-ideograph-strokes (char)
  44   (or (get-char-attribute char 'ideographic-strokes)
  45       (let ((strokes
  46              (or (get-char-attribute char 'daikanwa-strokes)
  47                  (get-char-attribute char 'kangxi-strokes)
  48                  (get-char-attribute char 'japanese-strokes)
  49                  (get-char-attribute char 'korean-strokes))))
  50         (when strokes
  51           (put-char-attribute char 'ideographic-strokes strokes)
  52           strokes))))
  53
  54 ;;;###autoload
  55 (defun update-ideograph-radical-table ()
  56   (interactive)
  57   (let ((i #x3400)
  58         j
  59         char radical
  60         (charsets '(japanese-jisx0208-1978
  61                     japanese-jisx0208
  62                     japanese-jisx0208-1990
  63                     japanese-jisx0212
  64                     japanese-jisx0213-1
  65                     japanese-jisx0213-2
  66                     chinese-cns11643-1
  67                     chinese-cns11643-2
  68                     chinese-cns11643-3
  69                     chinese-cns11643-4
  70                     chinese-cns11643-5
  71                     chinese-cns11643-6
  72                     chinese-cns11643-7
  73                     korean-ksc5601
  74                     chinese-gb2312
  75                     chinese-isoir165
  76                     chinese-big5-1
  77                     chinese-big5-2))
  78         ret)
  79     (while (<= i #x9FFF)
  80       (setq char (int-char i))
  81       (when (setq radical (char-ideograph-radical char))
  82         (or (get-char-attribute char 'ucs)
  83             (put-char-attribute char 'ucs i))
  84         (if (not (memq char
  85                        (setq ret
  86                              (aref ideograph-radical-chars-vector radical))))
  87             (aset ideograph-radical-chars-vector radical
  88                   (cons char ret))))
  89       (setq i (1+ i)))
  90     (setq i #x100000)
  91     (while (<= i #x10FFFF)
  92       (setq char (int-char i))
  93       (when (setq radical (char-ideograph-radical char))
  94         (if (not (memq char
  95                        (setq ret
  96                              (aref ideograph-radical-chars-vector radical))))
  97             (aset ideograph-radical-chars-vector radical
  98                   (cons char ret))))
  99       (setq i (1+ i)))
 100     (setq i 0)
 101     (while (< i 256)
 102       (setq j 0)
 103       (while (< j 256)
 104         (setq char (make-char 'ideograph-daikanwa i j))
 105         (if (and (setq radical (char-ideograph-radical char))
 106                  (not
 107                   (memq char
 108                         (setq ret
 109                               (aref ideograph-radical-chars-vector radical)))))
 110             (aset ideograph-radical-chars-vector radical
 111                   (cons char ret)))
 112         (setq j (1+ j)))
 113       (setq i (1+ i)))
 114     (while charsets
 115       (setq i 33)
 116       (while (< i 127)
 117         (setq j 33)
 118         (while (< j 127)
 119           (setq char (make-char (car charsets) i j))
 120           (if (and (setq radical (char-ideograph-radical char))
 121                    (not (memq char
 122                               (setq ret
 123                                     (aref ideograph-radical-chars-vector
 124                                           radical)))))
 125               (aset ideograph-radical-chars-vector radical
 126                     (cons char ret)))
 127           (setq j (1+ j)))
 128         (setq i (1+ i)))
 129       (setq charsets (cdr charsets)))
 130     ))
 131
 132 (defun ideograph-char< (a b)
 133   (let (ra rb)
 134     (cond
 135      ((setq ra (or (get-char-attribute a 'morohashi-daikanwa)
 136                    (get-char-attribute a 'non-morohashi)))
 137       (cond
 138        ((setq rb (or (get-char-attribute b 'morohashi-daikanwa)
 139                      (get-char-attribute b 'non-morohashi)))
 140         (cond
 141          ((= (car ra)(car rb))
 142           (cond ((eq (car (cdr ra))(car (cdr rb)))
 143                  (cond ((< (length ra)(length rb)))
 144                        ((= (length ra)(length rb))
 145                         (cond ((integerp (nth 2 ra))
 146                                (cond ((integerp (nth 2 rb))
 147                                       (< (nth 2 ra)(nth 2 rb)))
 148                                      (t nil)))
 149                               (t
 150                                (cond ((setq ra (get-char-attribute a 'ucs))
 151                                       (cond
 152                                        ((setq rb (get-char-attribute b 'ucs))
 153                                         (< ra rb))
 154                                        (t))))))))
 155                  )
 156                 ((null (car (cdr ra))))
 157                 ((null (car (cdr rb)))
 158                  nil)
 159                 (t (< (car (cdr ra))(car (cdr rb))))))
 160          (t (< (car ra)(car rb)))))
 161        (t)))
 162      ((or (get-char-attribute b 'morohashi-daikanwa)
 163           (get-char-attribute b 'non-morohashi))
 164       nil)
 165      ((setq ra (get-char-attribute a 'ucs))
 166       (cond
 167        ((setq rb (get-char-attribute b 'ucs))
 168         (< ra rb))))
 169      (t
 170       (cond
 171        ((setq ra (char-ideograph-strokes a))
 172         (cond ((setq rb (char-ideograph-strokes b))
 173                (cond ((= ra rb)
 174                       (not (char-ideograph-strokes b)))
 175                      ((< ra rb))))))
 176        )))))
 177
 178 (defun insert-ideograph-radical-char-data (radical)
 179   (let ((chars
 180          (sort (copy-list (aref ideograph-radical-chars-vector radical))
 181                (function ideograph-char<))))
 182     (while chars
 183       (insert-char-data (car chars))
 184       (setq chars (cdr chars)))))
 185
 186 (defun write-ideograph-radical-char-data (radical file)
 187   (if (file-directory-p file)
 188       (let ((name (get-char-attribute (int-char (+ #x2EFF radical)) 'name)))
 189         (if (string-match "KANGXI RADICAL " name)
 190             (setq name (capitalize (substring name (match-end 0)))))
 191         (setq name (mapconcat (lambda (char)
 192                                 (if (eq char ? )
 193                                     "-"
 194                                   (char-to-string char))) name ""))
 195         (setq file
 196               (expand-file-name
 197                (format "Ideograph-R%03d-%s.el" radical name)
 198                file))))
 199   (with-temp-buffer
 200     (insert-ideograph-radical-char-data radical)
 201     (char-db-update-comment)
 202     (let ((coding-system-for-write 'utf-8))
 203       (write-region (point-min)(point-max) file)
 204       )))
 205
 206 (provide 'ideograph-util)
 207
 208 ;;; ideograph-util.el ends here