lisp/utf-2000/ideograph-util.el

   1 ;;; ideograph-util.el --- Ideographic Character Database utility
   2
   3 ;; Copyright (C) 1999,2000,2001,2002 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 &optional radical)
  33   (let (ret)
  34     (or (catch 'tag
  35           (dolist (cell (get-char-attribute char 'ideographic-))
  36             (if (and (setq ret (plist-get cell :radical))
  37                      (or (eq ret radical)
  38                          (null radical)))
  39                 (throw 'tag ret))))
  40         (get-char-attribute char 'ideographic-radical)
  41         (progn
  42           (setq ret
  43                 (or (get-char-attribute char 'daikanwa-radical)
  44                     (get-char-attribute char 'kangxi-radical)
  45                     (get-char-attribute char 'japanese-radical)
  46                     (get-char-attribute char 'korean-radical)))
  47           (when ret
  48             (put-char-attribute char 'ideographic-radical ret)
  49             ret)))))
  50
  51 (defvar ideograph-radical-strokes-vector
  52   ;;0  1  2  3  4  5  6  7  8  9
  53   [nil 1  1  1  1  1  1  2  2  2
  54     2  2  2  2  2  2  2  2  2  2
  55     2  2  2  2  2  2  2  2  2  2
  56     3  3  3  3  3  3  3  3  3  3
  57     3  3  3  3  3  3  3  3  3  3
  58     3  3  3  3  3  3  3  3  3  3
  59     3  4  4  4  3  4  4  4  4  4
  60     4  4  4  4  4  4  4  4  4  4
  61     4  4  4  4  4  3  4  4  4  4
  62     4  4  4  4  3  5  4  5  5  5
  63     ;; 100
  64     5  5  5  5  5  5  5  5  5  5
  65     5  5  5  5  5  5  5  5  6  6
  66     6  6  6  6  6  6  6  6  6  6
  67     4  6  6  6  6  6  6  6  6  6
  68     4  6  6  6  6  6  6  7  7  7
  69     7  7  7  7  7  7  7  7  7  7
  70     7  7  4  3  7  7  7  8  7  8
  71     3  8  8  8  8  8  9  9  9  9
  72     9  9  9  9  8  9  9 10 10 10
  73    10 10 10 10 10 11 11 11 11 11
  74    ;; 200
  75    11 12 12 12 12 13 13 13 13 14
  76    14 15 16 16 17])
  77
  78 (defun char-ideographic-strokes (char &optional radical)
  79   (let (ret)
  80     (or (catch 'tag
  81           (dolist (cell (get-char-attribute char 'ideographic-))
  82             (if (and (setq ret (plist-get cell :radical))
  83                      (or (eq ret radical)
  84                          (null radical)))
  85                 (throw 'tag (plist-get cell :strokes)))))
  86         (get-char-attribute char 'daikanwa-strokes)
  87         (get-char-attribute char 'ideographic-strokes)
  88         (let ((strokes
  89                (or (get-char-attribute char 'kangxi-strokes)
  90                    (get-char-attribute char 'japanese-strokes)
  91                    (get-char-attribute char 'korean-strokes)
  92                    (let ((r (char-ideographic-radical char))
  93                          (ts (get-char-attribute char 'total-strokes)))
  94                      (if (and r ts)
  95                          (- ts (aref ideograph-radical-strokes-vector r))))
  96                    )))
  97           (when strokes
  98             (put-char-attribute char 'ideographic-strokes strokes)
  99             strokes)))))
 100
 101 ;;;###autoload
 102 (defun update-ideograph-radical-table ()
 103   (interactive)
 104   (let (ret radical script)
 105     (map-char-attribute
 106      (lambda (char radical)
 107        (when (and radical
 108                   (or (null (setq script (get-char-attribute char 'script)))
 109                       (memq 'Ideograph script)))
 110          (unless (memq char
 111                        (setq ret
 112                              (aref ideograph-radical-chars-vector radical)))
 113            (char-ideographic-strokes char)
 114            (aset ideograph-radical-chars-vector radical
 115                  (cons char ret))))
 116        nil)
 117      'ideographic-radical)
 118     (map-char-attribute
 119      (lambda (char data)
 120        (dolist (cell data)
 121          (setq radical (plist-get cell :radical))
 122          (when (and radical
 123                     (or (null (setq script (get-char-attribute char 'script)))
 124                         (memq 'Ideograph script)))
 125            (unless (memq char
 126                          (setq ret
 127                                (aref ideograph-radical-chars-vector radical)))
 128              (char-ideographic-strokes char)
 129              (aset ideograph-radical-chars-vector radical
 130                    (cons char ret))))))
 131      'ideographic-)))
 132
 133 (defun int-list< (a b)
 134   (if (numberp (car a))
 135       (if (numberp (car b))
 136           (if (= (car a) (car b))
 137               (int-list< (cdr a)(cdr b))
 138             (< (car a) (car b)))
 139         nil)
 140     (numberp (car b))))
 141
 142 (defun morohashi-daikanwa< (a b)
 143   (if (integerp a)
 144       (setq a (list a)))
 145   (if (integerp b)
 146       (setq b (list b)))
 147   (cond ((eq (car a) 'ho)
 148          (if (eq (car b) 'ho)
 149              (int-list< (cdr a)(cdr b))
 150            nil))
 151         ((numberp (car a))
 152          (if (eq (car b) 'ho)
 153              t
 154            (int-list< a b)))
 155         (t
 156          (if (eq (car b) 'ho)
 157              t
 158            (int-list< a b)))))
 159
 160 ;; (defun nil=-int< (a b)
 161 ;;   (cond ((null a) nil)
 162 ;;         ((null b) nil)
 163 ;;         (t (< a b))))
 164
 165 ;; (defun nil>-int< (a b)
 166 ;;   (cond ((null a) nil)
 167 ;;         ((null b) t)
 168 ;;         (t (< a b))))
 169
 170 (defun char-representative-of-daikanwa (char)
 171   (if (get-char-attribute char 'ideograph-daikanwa)
 172       char
 173     (let ((m (get-char-attribute char 'morohashi-daikanwa))
 174           m-m m-s pat)
 175       (or (when m
 176             (setq m-m (pop m))
 177             (setq m-s (pop m))
 178             (if (= m-s 0)
 179                 (decode-char 'ideograph-daikanwa m-m)
 180               (when m
 181                 (setq pat (list m-m m-s))
 182                 (map-char-attribute (lambda (c v)
 183                                       (if (equal pat v)
 184                                           c))
 185                                     'morohashi-daikanwa))))
 186           char))))
 187
 188 (defun char-attributes-poly< (c1 c2 accessors testers defaulters)
 189   (catch 'tag
 190     (let (a1 a2 accessor tester dm)
 191       (while (and accessors testers)
 192         (setq accessor (car accessors)
 193               tester (car testers)
 194               dm (car defaulters))
 195         (when (and accessor tester)
 196           (setq a1 (funcall accessor c1)
 197                 a2 (funcall accessor c2))
 198           (cond ((null a1)
 199                  (if a2
 200                      (cond ((eq dm '<)
 201                             (throw 'tag t))
 202                            ((eq dm '>)
 203                             (throw 'tag nil)))))
 204                 ((null a2)
 205                  (cond ((eq dm '<)
 206                         (throw 'tag nil))
 207                        ((eq dm '>)
 208                         (throw 'tag t))))
 209                 (t
 210                  (cond ((funcall tester a1 a2)
 211                         (throw 'tag t))
 212                        ((funcall tester a2 a1)
 213                         (throw 'tag nil))))))
 214         (setq accessors (cdr accessors)
 215               testers (cdr testers)
 216               defaulters (cdr defaulters))))))
 217
 218 (defvar ideographic-radical nil)
 219
 220 (defun char-daikanwa-strokes (char &optional radical)
 221   (unless radical
 222     (setq radical ideographic-radical))
 223   (let ((drc (char-representative-of-daikanwa char)))
 224     (char-ideographic-strokes
 225      (if (= (char-ideographic-radical drc radical)
 226             (char-ideographic-radical char radical))
 227          drc
 228        char)
 229      radical)))
 230
 231 ;;;###autoload
 232 (defun char-daikanwa (char)
 233   (or (get-char-attribute char 'ideograph-daikanwa)
 234       (get-char-attribute char 'morohashi-daikanwa)))
 235
 236 ;;;###autoload
 237 (defun char-ucs (char)
 238   (or (get-char-attribute char 'ucs)
 239       (get-char-attribute char '=>ucs)))
 240
 241 (defun char-id (char)
 242   (logand (char-int char) #x3FFFFFFF))
 243
 244 (defun ideograph-char< (a b &optional radical)
 245   (let ((ideographic-radical (or radical
 246                                  ideographic-radical)))
 247     (char-attributes-poly<
 248      a b
 249      '(char-daikanwa-strokes char-daikanwa char-ucs char-id)
 250      '(< morohashi-daikanwa< < <)
 251      '(> > > >))))
 252
 253 (defun insert-ideograph-radical-char-data (radical)
 254   (let ((chars
 255          (sort (copy-list (aref ideograph-radical-chars-vector radical))
 256                (lambda (a b)
 257                  (ideograph-char< a b radical))))
 258         attributes ccss)
 259     (dolist (name (char-attribute-list))
 260       (unless (memq name char-db-ignored-attributes)
 261         (if (find-charset name)
 262             (push name ccss)
 263           (push name attributes))))
 264     (setq attributes (sort attributes #'char-attribute-name<)
 265           ccss (sort ccss #'char-attribute-name<))
 266     (aset ideograph-radical-chars-vector radical chars)
 267     (dolist (char chars)
 268       (when (some (lambda (ccs)
 269                     (let ((code (encode-char char ccs)))
 270                       (and code
 271                            ;;(not (memq ccs char-db-ignored-attributes))
 272                            ;;(or (not (memq ccs '(ucs))
 273                            (and (<= 0 code)(<= code #x10FFFF)))))
 274                   ccss)
 275         (insert-char-data char nil attributes ccss)))))
 276
 277 (defun write-ideograph-radical-char-data (radical file)
 278   (if (file-directory-p file)
 279       (let ((name (get-char-attribute (int-char (+ #x2EFF radical)) 'name)))
 280         (if (string-match "KANGXI RADICAL " name)
 281             (setq name (capitalize (substring name (match-end 0)))))
 282         (setq name (mapconcat (lambda (char)
 283                                 (if (eq char ? )
 284                                     "-"
 285                                   (char-to-string char))) name ""))
 286         (setq file
 287               (expand-file-name
 288                (format "Ideograph-R%03d-%s.el" radical name)
 289                file))))
 290   (with-temp-buffer
 291     (insert-ideograph-radical-char-data radical)
 292     (let ((coding-system-for-write 'utf-8))
 293       (write-region (point-min)(point-max) file)
 294       )))
 295
 296 (defun ideographic-structure= (char1 char2)
 297   (if (char-ref-p char1)
 298       (setq char1 (plist-get char1 :char)))
 299   (if (char-ref-p char2)
 300       (setq char2 (plist-get char2 :char)))
 301   (let ((s1 (if (characterp char1)
 302                 (get-char-attribute char1 'ideographic-structure)
 303               (cdr (assq 'ideographic-structure char1))))
 304         (s2 (if (characterp char2)
 305                 (get-char-attribute char2 'ideographic-structure)
 306               (cdr (assq 'ideographic-structure char2))))
 307         e1 e2)
 308     (if (or (null s1)(null s2))
 309         (char-spec= char1 char2)
 310       (catch 'tag
 311         (while (and s1 s2)
 312           (setq e1 (car s1)
 313                 e2 (car s2))
 314           (unless (ideographic-structure= e1 e2)
 315             (throw 'tag nil))
 316           (setq s1 (cdr s1)
 317                 s2 (cdr s2)))
 318         (and (null s1)(null s2))))))
 319
 320 ;;;###autoload
 321 (defun ideographic-structure-find-char (structure)
 322   (let (rest)
 323     (map-char-attribute (lambda (char value)
 324                           (setq rest structure)
 325                           (catch 'tag
 326                             (while (and rest value)
 327                               (unless (ideographic-structure=
 328                                        (car rest)(car value))
 329                                 (throw 'tag nil))
 330                               (setq rest (cdr rest)
 331                                     value (cdr value)))
 332                             (unless (or rest value)
 333                               char)))
 334                         'ideographic-structure)))
 335
 336 (provide 'ideograph-util)
 337
 338 ;;; ideograph-util.el ends here