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-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 script)
  79     (while (<= i #x9FFF)
  80       (setq char (decode-char 'ucs i))
  81       (when (and (or (null (setq script (get-char-attribute char 'script)))
  82                      (memq 'Ideograph script))
  83                  (setq radical (char-ideograph-radical char)))
  84         (or (get-char-attribute char 'ucs)
  85             (put-char-attribute char 'ucs i))
  86         (if (not (memq char
  87                        (setq ret
  88                              (aref ideograph-radical-chars-vector radical))))
  89             (aset ideograph-radical-chars-vector radical
  90                   (cons char ret))))
  91       (setq i (1+ i)))
  92     (setq i #x100000)
  93     (while (<= i #x10FFFF)
  94       (setq char (decode-char 'ucs i))
  95       (when (and (or (null (setq script (get-char-attribute char 'script)))
  96                      (memq 'Ideograph script))
  97                  (setq radical (char-ideograph-radical char)))
  98         (if (not (memq char
  99                        (setq ret
 100                              (aref ideograph-radical-chars-vector radical))))
 101             (aset ideograph-radical-chars-vector radical
 102                   (cons char ret))))
 103       (setq i (1+ i)))
 104     (setq i 0)
 105     (while (< i 256)
 106       (setq j 0)
 107       (while (< j 256)
 108         (setq char (make-char 'ideograph-daikanwa i j))
 109         (if (and (setq radical (char-ideograph-radical char))
 110                  (not
 111                   (memq char
 112                         (setq ret
 113                               (aref ideograph-radical-chars-vector radical)))))
 114             (aset ideograph-radical-chars-vector radical
 115                   (cons char ret)))
 116         (setq j (1+ j)))
 117       (setq i (1+ i)))
 118     (while charsets
 119       (setq i 33)
 120       (while (< i 127)
 121         (setq j 33)
 122         (while (< j 127)
 123           (setq char (make-char (car charsets) i j))
 124           (if (and (or (null (setq script (get-char-attribute char 'script)))
 125                        (memq 'Ideograph script))
 126                    (setq radical (char-ideograph-radical char))
 127                    (not (memq char
 128                               (setq ret
 129                                     (aref ideograph-radical-chars-vector
 130                                           radical)))))
 131               (aset ideograph-radical-chars-vector radical
 132                     (cons char ret)))
 133           (setq j (1+ j)))
 134         (setq i (1+ i)))
 135       (setq charsets (cdr charsets)))
 136     ))
 137
 138 (defun ideograph-char< (a b)
 139   (let (ra rb)
 140     (cond
 141      ((setq ra (or (get-char-attribute a 'non-morohashi)
 142                    (get-char-attribute a 'morohashi-daikanwa)))
 143       (cond
 144        ((setq rb (or (get-char-attribute b 'non-morohashi)
 145                      (get-char-attribute b 'morohashi-daikanwa)))
 146         (cond
 147          ((= (car ra)(car rb))
 148           (cond ((eq (car (cdr ra))(car (cdr rb)))
 149                  (cond ((< (length ra)(length rb)))
 150                        ((= (length ra)(length rb))
 151                         (cond ((integerp (nth 2 ra))
 152                                (cond ((integerp (nth 2 rb))
 153                                       (< (nth 2 ra)(nth 2 rb)))
 154                                      (t nil)))
 155                               (t
 156                                (cond ((setq ra (get-char-attribute a 'ucs))
 157                                       (cond
 158                                        ((setq rb (get-char-attribute b 'ucs))
 159                                         (< ra rb))
 160                                        (t))))))))
 161                  )
 162                 ((null (car (cdr ra))))
 163                 ((null (car (cdr rb)))
 164                  nil)
 165                 (t (< (car (cdr ra))(car (cdr rb))))))
 166          (t (< (car ra)(car rb)))))
 167        (t)))
 168      ((or (get-char-attribute b 'non-morohashi)
 169           (get-char-attribute b 'morohashi-daikanwa))
 170       nil)
 171      ((setq ra (get-char-attribute a 'ucs))
 172       (cond
 173        ((setq rb (get-char-attribute b 'ucs))
 174         (< ra rb))))
 175      (t
 176       (cond
 177        ((setq ra (char-ideograph-strokes a))
 178         (cond ((setq rb (char-ideograph-strokes b))
 179                (cond ((= ra rb)
 180                       (not (char-ideograph-strokes b)))
 181                      ((< ra rb))))))
 182        )))))
 183
 184 (defun insert-ideograph-radical-char-data (radical)
 185   (let ((chars
 186          (sort (copy-list (aref ideograph-radical-chars-vector radical))
 187                (function ideograph-char<))))
 188     (while chars
 189       (insert-char-data (car chars))
 190       (setq chars (cdr chars)))))
 191
 192 (defun write-ideograph-radical-char-data (radical file)
 193   (if (file-directory-p file)
 194       (let ((name (get-char-attribute (int-char (+ #x2EFF radical)) 'name)))
 195         (if (string-match "KANGXI RADICAL " name)
 196             (setq name (capitalize (substring name (match-end 0)))))
 197         (setq name (mapconcat (lambda (char)
 198                                 (if (eq char ? )
 199                                     "-"
 200                                   (char-to-string char))) name ""))
 201         (setq file
 202               (expand-file-name
 203                (format "Ideograph-R%03d-%s.el" radical name)
 204                file))))
 205   (with-temp-buffer
 206     (insert-ideograph-radical-char-data radical)
 207     (char-db-update-comment)
 208     (let ((coding-system-for-write 'utf-8))
 209       (write-region (point-min)(point-max) file)
 210       )))
 211
 212 (provide 'ideograph-util)
 213
 214 ;;; ideograph-util.el ends here