New file.

diff --git a/lisp/utf-2000/ideograph-util.el b/lisp/utf-2000/ideograph-util.el
new file mode 100644 (file)
index 0000000..dea2031
--- /dev/null
+++ b/lisp/utf-2000/ideograph-util.el
@@ -0,0 +1,179 @@
+;;; ideograph-util.el --- Ideographic Character Database utility
+
+;; Copyright (C) 1999 MORIOKA Tomohiko.
+
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;; Keywords: UTF-2000, ISO/IEC 10646, Unicode, UCS-4, MULE.
+
+;; This file is part of UTF-2000.
+
+;; UTF-2000 is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; UTF-2000 is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with XEmacs; see the file COPYING.  If not, write to the Free
+;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;; 02111-1307, USA.
+
+;;; Code:
+
+(require 'char-db-util)
+
+(defvar ideograph-radical-chars-vector
+  (make-vector 215 nil))
+
+(defun char-ideograph-radical (char)
+  (or (get-char-attribute char 'ideographic-radical)
+      (let ((radical
+            (or (get-char-attribute char 'daikanwa-radical)
+                (get-char-attribute char 'kangxi-radical)
+                (get-char-attribute char 'japanese-radical)
+                (get-char-attribute char 'korean-radical))))
+       (when radical
+         (put-char-attribute char 'ideographic-radical radical)
+         radical))))
+
+(defun char-ideograph-strokes (char)
+  (or (get-char-attribute char 'ideographic-strokes)
+      (let ((strokes
+            (or (get-char-attribute char 'daikanwa-strokes)
+                (get-char-attribute char 'kangxi-strokes)
+                (get-char-attribute char 'japanese-strokes)
+                (get-char-attribute char 'korean-strokes))))
+       (when strokes
+         (put-char-attribute char 'ideographic-strokes strokes)
+         strokes))))
+
+;;;###autoload
+(defun update-ideograph-radical-table ()
+  (interactive)
+  (let ((i #x3400)
+       j
+       char radical
+       (charsets '(japanese-jisx0208
+                   japanese-jisx0208-1978
+                   japanese-jisx0212
+                   chinese-cns11643-1
+                   chinese-cns11643-2
+                   chinese-cns11643-3
+                   chinese-cns11643-4
+                   chinese-cns11643-5
+                   chinese-cns11643-6
+                   chinese-cns11643-7
+                   korean-ksc5601
+                   chinese-gb2312
+                   chinese-isoir165
+                   chinese-big5-1
+                   chinese-big5-2))
+       ret)
+    (while (<= i #x9FFF)
+      (setq char (int-char i))
+      (when (setq radical (char-ideograph-radical char))
+       (or (get-char-attribute char 'ucs)
+           (put-char-attribute char 'ucs i))
+       (if (not (memq char
+                      (setq ret
+                            (aref ideograph-radical-chars-vector radical))))
+           (aset ideograph-radical-chars-vector radical
+                 (cons char ret))))
+      (setq i (1+ i)))
+    (setq i 0)
+    (while (< i 256)
+      (setq j 0)
+      (while (< j 256)
+       (setq char (make-char 'ideograph-daikanwa i j))
+       (if (and (setq radical (char-ideograph-radical char))
+                (not
+                 (memq char
+                       (setq ret
+                             (aref ideograph-radical-chars-vector radical)))))
+           (aset ideograph-radical-chars-vector radical
+                 (cons char ret)))
+       (setq j (1+ j)))
+      (setq i (1+ i)))
+    (while charsets
+      (setq i 33)
+      (while (< i 127)
+       (setq j 33)
+       (while (< j 127)
+         (setq char (make-char (car charsets) i j))
+         (if (and (setq radical (char-ideograph-radical char))
+                  (not (memq char
+                             (setq ret
+                                   (aref ideograph-radical-chars-vector
+                                         radical)))))
+             (aset ideograph-radical-chars-vector radical
+                   (cons char ret)))
+         (setq j (1+ j)))
+       (setq i (1+ i)))
+      (setq charsets (cdr charsets)))
+    ))
+
+(defun ideograph-char< (a b)
+  (let (ra rb)
+    (cond
+     ((setq ra (or (get-char-attribute a 'morohashi-daikanwa)
+                  (get-char-attribute a 'non-morohashi)))
+      (cond
+       ((setq rb (or (get-char-attribute b 'morohashi-daikanwa)
+                    (get-char-attribute b 'non-morohashi)))
+       (cond
+        ((= (car ra)(car rb))
+         (cond ((eq (car (cdr ra))(car (cdr rb)))
+                (cond ((< (length ra)(length rb)))
+                      ((= (length ra)(length rb))
+                       (cond ((setq ra (get-char-attribute a 'ucs))
+                              (cond
+                               ((setq rb (get-char-attribute b 'ucs))
+                                (< ra rb))
+                               (t))))))
+                )
+               ((null (car (cdr ra))))
+               ((null (car (cdr rb)))
+                nil)
+               (t (< (car (cdr ra))(car (cdr rb))))))
+        (t (< (car ra)(car rb)))))
+       ((setq ra (get-char-attribute a 'ucs))
+       (cond
+        ((setq rb (get-char-attribute b 'ucs))
+         (< ra rb))))
+       (t
+       (cond
+        ((setq ra (char-ideograph-strokes a))
+         (cond ((setq rb (char-ideograph-strokes b))
+                (cond ((= ra rb)
+                       (not (char-ideograph-strokes b)))
+                      ((< ra rb))))))
+        )))))))
+
+(defun insert-ideograph-radical-char-data (radical)
+  (let ((chars
+        (sort (copy-list (aref ideograph-radical-chars-vector radical))
+              (function ideograph-char<))))
+    (while chars
+      (insert-char-data (car chars))
+      (setq chars (cdr chars)))))
+
+(defun write-ideograph-radical-char-data (radical file)
+  (if (file-directory-p file)
+      (let ((name (get-char-attribute (int-char (+ #x2EFF radical)) 'name)))
+       (if (string-match "KANGXI RADICAL " name)
+           (setq name (capitalize (substring name (match-end 0)))))
+       (setq file
+             (expand-file-name
+              (format "Ideograph-R%03d-%s.el" radical name)
+              file))))
+  (with-temp-buffer
+    (insert-ideograph-radical-char-data radical)
+    (write-region (point-min)(point-max) file)))
+
+(provide 'ideograph-util)
+
+;;; ideograph-util.el ends here