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,2001 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 XEmacs UTF-2000.
   9
  10 ;; XEmacs UTF-2000 is free software; you can redistribute it and/or
  11 ;; modify it under the terms of the GNU General Public License as
  12 ;; published by the Free Software Foundation; either version 2, or (at
  13 ;; your option) any later version.
  14
  15 ;; XEmacs UTF-2000 is distributed in the hope that it will be useful,
  16 ;; but 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 UTF-2000; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 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-ideographic-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 (defvar ideograph-radical-strokes-vector
  44   ;;0  1  2  3  4  5  6  7  8  9
  45   [nil 1  1  1  1  1  1  2  2  2
  46     2  2  2  2  2  2  2  2  2  2
  47     2  2  2  2  2  2  2  2  2  2
  48     3  3  3  3  3  3  3  3  3  3
  49     3  3  3  3  3  3  3  3  3  3
  50     3  3  3  3  3  3  3  3  3  3
  51     3  4  4  4  3  4  4  4  4  4
  52     4  4  4  4  4  4  4  4  4  4
  53     4  4  4  4  4  3  4  4  4  4
  54     4  4  4  4  3  5  4  5  5  5
  55     ;; 100
  56     5  5  5  5  5  5  5  5  5  5
  57     5  5  5  5  5  5  5  5  6  6
  58     6  6  6  6  6  6  6  6  6  6
  59     4  6  6  6  6  6  6  6  6  6
  60     4  6  6  6  6  6  6  7  7  7
  61     7  7  7  7  7  7  7  7  7  7
  62     7  7  4  3  7  7  7  8  7  8
  63     3  8  8  8  8  8  9  9  9  9
  64     9  9  9  9  8  9  9 10 10 10
  65    10 10 10 10 10 11 11 11 11 11
  66    ;; 200
  67    11 12 12 12 12 13 13 13 13 14
  68    14 15 16 16 17])
  69
  70 (defun char-ideographic-strokes (char)
  71   (or (get-char-attribute char 'daikanwa-strokes)
  72       (get-char-attribute char 'ideographic-strokes)
  73       (let ((strokes
  74              (or (get-char-attribute char 'kangxi-strokes)
  75                  (get-char-attribute char 'japanese-strokes)
  76                  (get-char-attribute char 'korean-strokes)
  77                  (let ((r (char-ideographic-radical char))
  78                        (ts (get-char-attribute char 'total-strokes)))
  79                    (if (and r ts)
  80                        (- ts (aref ideograph-radical-strokes-vector r))))
  81                  )))
  82         (when strokes
  83           (put-char-attribute char 'ideographic-strokes strokes)
  84           strokes))))
  85
  86 ;;;###autoload
  87 (defun update-ideograph-radical-table ()
  88   (interactive)
  89   (let (ret script)
  90     (map-char-attribute
  91      (lambda (char radical)
  92        (when (and radical
  93                   (or (null (setq script (get-char-attribute char 'script)))
  94                       (memq 'Ideograph script)))
  95          (unless (memq char
  96                        (setq ret
  97                              (aref ideograph-radical-chars-vector radical)))
  98            (char-ideographic-strokes char)
  99            (aset ideograph-radical-chars-vector radical
 100                  (cons char ret))))
 101        nil)
 102      'ideographic-radical)))
 103
 104 (defun int-list< (a b)
 105   (if (numberp (car a))
 106       (if (numberp (car b))
 107           (if (= (car a) (car b))
 108               (int-list< (cdr a)(cdr b))
 109             (< (car a) (car b)))
 110         nil)
 111     (numberp (car b))))
 112
 113 (defun morohashi-daikanwa< (a b)
 114   (cond ((eq (car a) 'ho)
 115          (if (eq (car b) 'ho)
 116              (int-list< (cdr a)(cdr b))
 117            nil))
 118         ((numberp (car a))
 119          (if (eq (car b) 'ho)
 120              t
 121            (int-list< a b)))
 122         (t
 123          (if (eq (car b) 'ho)
 124              t
 125            (int-list< a b)))))
 126
 127 (defun ideograph-char< (a b)
 128   (let ((a-m-m (get-char-attribute a 'ideograph-daikanwa))
 129         (b-m-m (get-char-attribute b 'ideograph-daikanwa))
 130         a-m-r b-m-r
 131         a-s b-s
 132         a-u b-u
 133         ret pat)
 134     (if a-m-m
 135         (setq a-s (char-ideographic-strokes a))
 136       (setq a-m-r (get-char-attribute a 'morohashi-daikanwa))
 137       (if a-m-r
 138           (progn
 139             (setq a-m-m (car a-m-r)
 140                   a-m-r (cdr a-m-r))
 141             (if (= (car a-m-r) 0)
 142                 (progn
 143                   (setq ret (decode-char 'ideograph-daikanwa a-m-m))
 144                   (if (= (get-char-attribute ret 'ideographic-radical)
 145                          (get-char-attribute a 'ideographic-radical))
 146                       (setq a-s (char-ideographic-strokes ret))
 147                     (setq a-s (char-ideographic-strokes a))))
 148               (setq a-s (char-ideographic-strokes
 149                          (if (cdr a-m-r)
 150                              (progn
 151                                (setq pat (list a-m-m (car a-m-r)))
 152                                (or (map-char-attribute (lambda (c v)
 153                                                          (if (equal v pat)
 154                                                              c))
 155                                                        'morohashi-daikanwa)
 156                                    a))
 157                            a)))
 158               ))
 159         (setq a-s (char-ideographic-strokes a))))
 160     (if b-m-m
 161         (setq b-s (char-ideographic-strokes b))
 162       (setq b-m-r (get-char-attribute b 'morohashi-daikanwa))
 163       (if b-m-r
 164           (progn
 165             (setq b-m-m (car b-m-r)
 166                   b-m-r (cdr b-m-r))
 167             (if (= (car b-m-r) 0)
 168                 (progn
 169                   (setq ret (decode-char 'ideograph-daikanwa b-m-m))
 170                   (if (= (get-char-attribute ret 'ideographic-radical)
 171                          (get-char-attribute b 'ideographic-radical))
 172                       (setq b-s (char-ideographic-strokes ret))
 173                     (setq b-s (char-ideographic-strokes b))))
 174               (setq b-s (char-ideographic-strokes
 175                          (if (cdr b-m-r)
 176                              (progn
 177                                (setq pat (list b-m-m (car b-m-r)))
 178                                (or (map-char-attribute (lambda (c v)
 179                                                          (if (equal v pat)
 180                                                              c))
 181                                                        'morohashi-daikanwa)
 182                                    b))
 183                            b)))
 184               ))
 185         (setq b-s (char-ideographic-strokes b))))
 186     (if a-s
 187         (if b-s
 188             (if (= a-s b-s)
 189                 (if a-m-m
 190                     (if b-m-m
 191                         (morohashi-daikanwa< (cons a-m-m a-m-r)
 192                                              (cons b-m-m b-m-r))
 193                       t)
 194                   (if b-m-m
 195                       nil
 196                     (setq a-u (get-char-attribute a 'ucs)
 197                           b-u (get-char-attribute b 'ucs))
 198                     (if a-u
 199                         (if b-u
 200                             (< a-u b-u)
 201                           (setq b-u (or (get-char-attribute b '=>ucs)
 202                                         (get-char-attribute b '->ucs)))
 203                           (if b-u
 204                               (<= a-u b-u)
 205                             t))
 206                       (setq a-u (or (get-char-attribute a '=>ucs)
 207                                     (get-char-attribute a '->ucs)))
 208                       (if a-u
 209                           (if b-u
 210                               (< a-u b-u)
 211                             (setq b-u (or (get-char-attribute b '=>ucs)
 212                                           (get-char-attribute b '->ucs)))
 213                             (if b-u
 214                                 (< a-u b-u)
 215                               t))
 216                         (if (or b-u (or (get-char-attribute b '=>ucs)
 217                                         (get-char-attribute b '->ucs)))
 218                             nil
 219                           (< (char-int a)(char-int b)))))))
 220               (< a-s b-s))
 221           t))))
 222
 223 (defun insert-ideograph-radical-char-data (radical)
 224   (let ((chars
 225          (sort (copy-list (aref ideograph-radical-chars-vector radical))
 226                (function ideograph-char<)))
 227         (attributes (sort (char-attribute-list) #'char-attribute-name<))
 228         (ccs (sort (charset-list) #'char-attribute-name<)))
 229     (aset ideograph-radical-chars-vector radical chars)
 230     (while chars
 231       (insert-char-data (car chars) nil attributes ccs)
 232       (setq chars (cdr chars)))))
 233
 234 (defun write-ideograph-radical-char-data (radical file)
 235   (if (file-directory-p file)
 236       (let ((name (get-char-attribute (int-char (+ #x2EFF radical)) 'name)))
 237         (if (string-match "KANGXI RADICAL " name)
 238             (setq name (capitalize (substring name (match-end 0)))))
 239         (setq name (mapconcat (lambda (char)
 240                                 (if (eq char ? )
 241                                     "-"
 242                                   (char-to-string char))) name ""))
 243         (setq file
 244               (expand-file-name
 245                (format "Ideograph-R%03d-%s.el" radical name)
 246                file))))
 247   (with-temp-buffer
 248     (insert-ideograph-radical-char-data radical)
 249     (char-db-update-comment)
 250     (let ((coding-system-for-write 'utf-8))
 251       (write-region (point-min)(point-max) file)
 252       )))
 253
 254 (provide 'ideograph-util)
 255
 256 ;;; ideograph-util.el ends here