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