From: 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/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=45fd1039f9b5aaace22617e9f4f0e51f7392c41a;p=chise%2Fxemacs-chise.git- 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 +;; 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