X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Futf-2000%2Fideograph-util.el;h=097d33f4a6c61c170356ed9500caaba61582ce9d;hb=4d9280cd5d0f925d2afa157dcf20f13fdcf4de17;hp=9bddea0fd47430ed6e356530aac7fcefabf80759;hpb=41959750aedad18859ac70645f5bc3768a932e52;p=chise%2Fxemacs-chise.git diff --git a/lisp/utf-2000/ideograph-util.el b/lisp/utf-2000/ideograph-util.el index 9bddea0..097d33f 100644 --- a/lisp/utf-2000/ideograph-util.el +++ b/lisp/utf-2000/ideograph-util.el @@ -1,26 +1,26 @@ ;;; ideograph-util.el --- Ideographic Character Database utility -;; Copyright (C) 1999,2000 MORIOKA Tomohiko. +;; Copyright (C) 1999,2000,2001 MORIOKA Tomohiko. ;; Author: MORIOKA Tomohiko ;; Keywords: UTF-2000, ISO/IEC 10646, Unicode, UCS-4, MULE. -;; This file is part of UTF-2000. +;; This file is part of XEmacs 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. +;; XEmacs 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 +;; XEmacs 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. +;; along with XEmacs UTF-2000; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Code: @@ -50,28 +50,28 @@ 3 3 3 3 3 3 3 3 3 3 3 4 4 4 3 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 - 4 4 4 4 4 4 4 4 4 4 - 4 4 4 4 4 5 5 5 5 5 + 4 4 4 4 4 3 4 4 4 4 + 4 4 4 4 3 5 4 5 5 5 ;; 100 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 6 6 6 6 6 6 6 6 6 6 6 6 - 6 6 6 6 6 6 6 6 6 6 - 6 6 6 6 6 6 6 7 7 7 + 4 6 6 6 6 6 6 6 6 6 + 4 6 6 6 6 6 6 7 7 7 7 7 7 7 7 7 7 7 7 7 - 7 7 4 3 7 7 7 8 8 8 - 8 8 8 8 8 8 9 9 9 9 - 9 9 9 9 9 9 9 10 10 10 + 7 7 4 3 7 7 7 8 7 8 + 3 8 8 8 8 8 9 9 9 9 + 9 9 9 9 8 9 9 10 10 10 10 10 10 10 10 11 11 11 11 11 ;; 200 11 12 12 12 12 13 13 13 13 14 14 15 16 16 17]) (defun char-ideographic-strokes (char) - (or (get-char-attribute char 'ideographic-strokes) + (or (get-char-attribute char 'daikanwa-strokes) + (get-char-attribute char 'ideographic-strokes) (let ((strokes - (or (get-char-attribute char 'daikanwa-strokes) - (get-char-attribute char 'kangxi-strokes) + (or (get-char-attribute char 'kangxi-strokes) (get-char-attribute char 'japanese-strokes) (get-char-attribute char 'korean-strokes) (let ((r (char-ideographic-radical char)) @@ -86,84 +86,20 @@ ;;;###autoload (defun update-ideograph-radical-table () (interactive) - (let ((i #x3400) - j - char radical - (charsets '(japanese-jisx0208-1978 - japanese-jisx0208 - japanese-jisx0208-1990 - japanese-jisx0212 - japanese-jisx0213-1 - japanese-jisx0213-2 - 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 script) - (while (<= i #x9FFF) - (setq char (decode-char 'ucs i)) - (when (and (or (null (setq script (get-char-attribute char 'script))) - (memq 'Ideograph script)) - (setq radical (char-ideographic-radical char))) - (or (get-char-attribute char 'ucs) - (put-char-attribute char 'ucs i)) - (char-ideographic-strokes char) - (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 #x100000) - (while (<= i #x10FFFF) - (setq char (decode-char 'ucs i)) - (when (and (or (null (setq script (get-char-attribute char 'script))) - (memq 'Ideograph script)) - (setq radical (char-ideographic-radical char))) - (if (not (memq char + (let (ret script) + (map-char-attribute + (lambda (char radical) + (when (and radical + (or (null (setq script (get-char-attribute char 'script))) + (memq 'Ideograph script))) + (unless (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 50101) - (setq char (decode-char 'ideograph-daikanwa i)) - (if (and (setq radical (char-ideographic-radical char)) - (not - (memq char - (setq ret - (aref ideograph-radical-chars-vector radical))))) - (aset ideograph-radical-chars-vector radical - (cons char ret))) - (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 (or (null (setq script (get-char-attribute char 'script))) - (memq 'Ideograph script)) - (setq radical (char-ideographic-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))) - )) + (aref ideograph-radical-chars-vector radical))) + (char-ideographic-strokes char) + (aset ideograph-radical-chars-vector radical + (cons char ret)))) + nil) + 'ideographic-radical))) (defun int-list< (a b) (if (numberp (car a)) @@ -174,136 +110,108 @@ nil) (numberp (car b)))) +(defun morohashi-daikanwa< (a b) + (if (integerp a) + (setq a (list a))) + (if (integerp b) + (setq b (list b))) + (cond ((eq (car a) 'ho) + (if (eq (car b) 'ho) + (int-list< (cdr a)(cdr b)) + nil)) + ((numberp (car a)) + (if (eq (car b) 'ho) + t + (int-list< a b))) + (t + (if (eq (car b) 'ho) + t + (int-list< a b))))) + +(defun char-representative-of-daikanwa (char) + (if (get-char-attribute char 'ideograph-daikanwa) + char + (let ((m (get-char-attribute char 'morohashi-daikanwa)) + m-m m-s pat) + (or (when m + (setq m-m (pop m)) + (setq m-s (pop m)) + (if (= m-s 0) + (decode-char 'ideograph-daikanwa m-m) + (when m + (setq pat (list m-m m-s)) + (map-char-attribute (lambda (c v) + (if (equal pat v) + c)) + 'morohashi-daikanwa)))) + char)))) + (defun ideograph-char< (a b) - (let ((a-m-m (get-char-attribute a 'ideograph-daikanwa)) - (b-m-m (get-char-attribute b 'ideograph-daikanwa)) - a-m-r b-m-r - a-s b-s - a-u b-u m) - (if a-m-m - (setq a-s (char-ideographic-strokes a)) - (setq a-m-r (get-char-attribute a 'morohashi-daikanwa)) - (if a-m-r - (progn - (setq a-m-m (car a-m-r) - a-m-r (cdr a-m-r)) - (if (= (car a-m-r) 0) - (setq a-s (char-ideographic-strokes - (decode-char 'ideograph-daikanwa a-m-m))) - (if (setq m (get-char-attribute a '->mojikyo)) - (setq a-s (char-ideographic-strokes - (decode-char 'mojikyo m))) - (setq a-s (char-ideographic-strokes a))))) - (setq a-s (char-ideographic-strokes a)))) - (if b-m-m - (setq b-s (char-ideographic-strokes b)) - (setq b-m-r (get-char-attribute b 'morohashi-daikanwa)) - (if b-m-r - (progn - (setq b-m-m (car b-m-r) - b-m-r (cdr b-m-r)) - (if (= (car b-m-r) 0) - (setq b-s (char-ideographic-strokes - (decode-char 'ideograph-daikanwa b-m-m))) - (if (setq m (get-char-attribute b '->mojikyo)) - (setq b-s (char-ideographic-strokes - (decode-char 'mojikyo m))) - (setq b-s (char-ideographic-strokes b))))) - (setq b-s (char-ideographic-strokes b)))) + (let (a-m b-m a-s b-s a-u b-u ret) + (setq ret (char-representative-of-daikanwa a)) + (setq a-s (char-ideographic-strokes + (if (= (get-char-attribute ret 'ideographic-radical) + (get-char-attribute a 'ideographic-radical)) + ret + a))) + (setq ret (char-representative-of-daikanwa b)) + (setq b-s (char-ideographic-strokes + (if (= (get-char-attribute ret 'ideographic-radical) + (get-char-attribute b 'ideographic-radical)) + ret + b))) (if a-s (if b-s (if (= a-s b-s) - (if a-m-m - (if b-m-m - (int-list< (cons a-m-m a-m-r) - (cons b-m-m b-m-r)) + (if (setq a-m (or (get-char-attribute a 'ideograph-daikanwa) + (get-char-attribute a 'morohashi-daikanwa))) + (if (setq b-m + (or (get-char-attribute b 'ideograph-daikanwa) + (get-char-attribute b 'morohashi-daikanwa))) + (morohashi-daikanwa< a-m b-m) t) - (if b-m-m + (if (setq b-m + (or (get-char-attribute b 'ideograph-daikanwa) + (get-char-attribute b 'morohashi-daikanwa))) nil (setq a-u (get-char-attribute a 'ucs) b-u (get-char-attribute b 'ucs)) (if a-u (if b-u (< a-u b-u) - (setq b-u (get-char-attribute b '->ucs)) + (setq b-u (or (get-char-attribute b '=>ucs) + (get-char-attribute b '->ucs))) (if b-u (<= a-u b-u) t)) - (setq a-u (get-char-attribute a '->ucs)) + (setq a-u (or (get-char-attribute a '=>ucs) + (get-char-attribute a '->ucs))) (if a-u (if b-u (< a-u b-u) - (setq b-u (get-char-attribute b '->ucs)) + (setq b-u (or (get-char-attribute b '=>ucs) + (get-char-attribute b '->ucs))) (if b-u (< a-u b-u) t)) - (if (or b-u (get-char-attribute b '->ucs)) + (if (or b-u (or (get-char-attribute b '=>ucs) + (get-char-attribute b '->ucs))) nil (< (char-int a)(char-int b))))))) (< a-s b-s)) t)))) -;; (defun ideograph-char< (a b) -;; (let (ra rb mma mmb msa msb) -;; (cond -;; ((progn -;; (if (setq ra (or (get-char-attribute a 'non-morohashi) -;; (get-char-attribute a 'morohashi-daikanwa))) -;; (setq msa (cdr ra) -;; mma (car ra)) -;; (setq mma (get-char-attribute a 'ideograph-daikanwa)))) -;; (cond -;; ((progn -;; (if (setq rb (or (get-char-attribute b 'non-morohashi) -;; (get-char-attribute b 'morohashi-daikanwa))) -;; (setq msb (cdr rb) -;; mmb (car rb)) -;; (setq mmb (get-char-attribute b 'ideograph-daikanwa)))) -;; (cond -;; ((= mma mmb) -;; (cond ((eq (car msa)(car msb)) -;; (cond ((< (length msa)(length msb))) -;; ((= (length msa)(length msb)) -;; (cond ((integerp (nth 1 msa)) -;; (cond ((integerp (nth 1 msb)) -;; (< (nth 1 msa)(nth 1 msb))) -;; (t nil))) -;; (t -;; (cond ((setq ra (get-char-attribute a 'ucs)) -;; (cond -;; ((setq rb (get-char-attribute b 'ucs)) -;; (< ra rb)) -;; (t)))))))) -;; ) -;; ((null (car msa))) -;; ((null (car msb)) -;; nil) -;; (t (< (car msa)(car msb))))) -;; (t (< mma mmb)))) -;; (t))) -;; ((or (get-char-attribute b 'non-morohashi) -;; (get-char-attribute b 'morohashi-daikanwa) -;; (get-char-attribute b 'ideograph-daikanwa)) -;; nil) -;; ((setq ra (get-char-attribute a 'ucs)) -;; (cond -;; ((setq rb (get-char-attribute b 'ucs)) -;; (< ra rb)))) -;; (t -;; (cond -;; ((setq ra (char-ideographic-strokes a)) -;; (cond ((setq rb (char-ideographic-strokes b)) -;; (cond ((= ra rb) -;; (not (char-ideographic-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<))) - (attributes (sort (char-attribute-list) #'char-attribute-name<)) - (ccs (sort (charset-list) #'char-attribute-name<))) + attributes ccs) + (dolist (name (char-attribute-list)) + (if (find-charset name) + (push name ccs) + (push name attributes))) + (setq attributes (sort attributes #'char-attribute-name<) + ccs (sort ccs #'char-attribute-name<)) (aset ideograph-radical-chars-vector radical chars) (while chars (insert-char-data (car chars) nil attributes ccs) @@ -329,6 +237,46 @@ (write-region (point-min)(point-max) file) ))) +(defun ideographic-structure= (char1 char2) + (if (char-ref-p char1) + (setq char1 (plist-get char1 :char))) + (if (char-ref-p char2) + (setq char2 (plist-get char2 :char))) + (let ((s1 (if (characterp char1) + (get-char-attribute char1 'ideographic-structure) + (cdr (assq 'ideographic-structure char1)))) + (s2 (if (characterp char2) + (get-char-attribute char2 'ideographic-structure) + (cdr (assq 'ideographic-structure char2)))) + e1 e2) + (if (or (null s1)(null s2)) + (char-spec= char1 char2) + (catch 'tag + (while (and s1 s2) + (setq e1 (car s1) + e2 (car s2)) + (unless (ideographic-structure= e1 e2) + (throw 'tag nil)) + (setq s1 (cdr s1) + s2 (cdr s2))) + (and (null s1)(null s2)))))) + +;;;###autoload +(defun ideographic-structure-find-char (structure) + (let (rest) + (map-char-attribute (lambda (char value) + (setq rest structure) + (catch 'tag + (while (and rest value) + (unless (ideographic-structure= + (car rest)(car value)) + (throw 'tag nil)) + (setq rest (cdr rest) + value (cdr value))) + (unless (or rest value) + char))) + 'ideographic-structure))) + (provide 'ideograph-util) ;;; ideograph-util.el ends here