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
  61                     japanese-jisx0208-1978
  62                     japanese-jisx0212
  63                     chinese-cns11643-1
  64                     chinese-cns11643-2
  65                     chinese-cns11643-3
  66                     chinese-cns11643-4
  67                     chinese-cns11643-5
  68                     chinese-cns11643-6
  69                     chinese-cns11643-7
  70                     korean-ksc5601
  71                     chinese-gb2312
  72                     chinese-isoir165
  73                     chinese-big5-1
  74                     chinese-big5-2))
  75         ret)
  76     (while (<= i #x9FFF)
  77       (setq char (int-char i))
  78       (when (setq radical (char-ideograph-radical char))
  79         (or (get-char-attribute char 'ucs)
  80             (put-char-attribute char 'ucs i))
  81         (if (not (memq char
  82                        (setq ret
  83                              (aref ideograph-radical-chars-vector radical))))
  84             (aset ideograph-radical-chars-vector radical
  85                   (cons char ret))))
  86       (setq i (1+ i)))
  87     (setq i 0)
  88     (while (< i 256)
  89       (setq j 0)
  90       (while (< j 256)
  91         (setq char (make-char 'ideograph-daikanwa i j))
  92         (if (and (setq radical (char-ideograph-radical char))
  93                  (not
  94                   (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 j (1+ j)))
 100       (setq i (1+ i)))
 101     (while charsets
 102       (setq i 33)
 103       (while (< i 127)
 104         (setq j 33)
 105         (while (< j 127)
 106           (setq char (make-char (car charsets) i j))
 107           (if (and (setq radical (char-ideograph-radical char))
 108                    (not (memq char
 109                               (setq ret
 110                                     (aref ideograph-radical-chars-vector
 111                                           radical)))))
 112               (aset ideograph-radical-chars-vector radical
 113                     (cons char ret)))
 114           (setq j (1+ j)))
 115         (setq i (1+ i)))
 116       (setq charsets (cdr charsets)))
 117     ))
 118
 119 (defun ideograph-char< (a b)
 120   (let (ra rb)
 121     (cond
 122      ((setq ra (or (get-char-attribute a 'morohashi-daikanwa)
 123                    (get-char-attribute a 'non-morohashi)))
 124       (cond
 125        ((setq rb (or (get-char-attribute b 'morohashi-daikanwa)
 126                      (get-char-attribute b 'non-morohashi)))
 127         (cond
 128          ((= (car ra)(car rb))
 129           (cond ((eq (car (cdr ra))(car (cdr rb)))
 130                  (cond ((< (length ra)(length rb)))
 131                        ((= (length ra)(length rb))
 132                         (cond ((setq ra (get-char-attribute a 'ucs))
 133                                (cond
 134                                 ((setq rb (get-char-attribute b 'ucs))
 135                                  (< ra rb))
 136                                 (t))))))
 137                  )
 138                 ((null (car (cdr ra))))
 139                 ((null (car (cdr rb)))
 140                  nil)
 141                 (t (< (car (cdr ra))(car (cdr rb))))))
 142          (t (< (car ra)(car rb)))))
 143        ((setq ra (get-char-attribute a 'ucs))
 144         (cond
 145          ((setq rb (get-char-attribute b 'ucs))
 146           (< ra rb))))
 147        (t
 148         (cond
 149          ((setq ra (char-ideograph-strokes a))
 150           (cond ((setq rb (char-ideograph-strokes b))
 151                  (cond ((= ra rb)
 152                         (not (char-ideograph-strokes b)))
 153                        ((< ra rb))))))
 154          )))))))
 155
 156 (defun insert-ideograph-radical-char-data (radical)
 157   (let ((chars
 158          (sort (copy-list (aref ideograph-radical-chars-vector radical))
 159                (function ideograph-char<))))
 160     (while chars
 161       (insert-char-data (car chars))
 162       (setq chars (cdr chars)))))
 163
 164 (defun write-ideograph-radical-char-data (radical file)
 165   (if (file-directory-p file)
 166       (let ((name (get-char-attribute (int-char (+ #x2EFF radical)) 'name)))
 167         (if (string-match "KANGXI RADICAL " name)
 168             (setq name (capitalize (substring name (match-end 0)))))
 169         (setq file
 170               (expand-file-name
 171                (format "Ideograph-R%03d-%s.el" radical name)
 172                file))))
 173   (with-temp-buffer
 174     (insert-ideograph-radical-char-data radical)
 175     (write-region (point-min)(point-max) file)))
 176
 177 (provide 'ideograph-util)
 178
 179 ;;; ideograph-util.el ends here