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