From: tomo <tomo>
Date: Wed, 17 Nov 1999 14:26:05 +0000 (+0000)
Subject: New file.
X-Git-Tag: r21-2-19-utf-2000-0_13-0~157
X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=45fd1039f9b5aaace22617e9f4f0e51f7392c41a;p=chise%2Fxemacs-chise.git.1

New file.
---

diff --git a/lisp/utf-2000/ideograph-util.el b/lisp/utf-2000/ideograph-util.el
new file mode 100644
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