;;; ideograph-util.el --- Ideographic Character Database utility
-;; Copyright (C) 1999,2000,2001 MORIOKA Tomohiko.
+;; Copyright (C) 1999,2000,2001,2002 MORIOKA Tomohiko.
;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
;; Keywords: UTF-2000, ISO/IEC 10646, Unicode, UCS-4, MULE.
(defvar ideograph-radical-chars-vector
(make-vector 215 nil))
-(defun char-ideographic-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-ideographic-radical (char &optional radical)
+ (let (ret)
+ (or (catch 'tag
+ (dolist (cell (get-char-attribute char 'ideographic-))
+ (if (and (setq ret (plist-get cell :radical))
+ (or (eq ret radical)
+ (null radical)))
+ (throw 'tag ret))))
+ (get-char-attribute char 'ideographic-radical)
+ (progn
+ (setq ret
+ (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 ret
+ (put-char-attribute char 'ideographic-radical ret)
+ ret)))))
(defvar ideograph-radical-strokes-vector
;;0 1 2 3 4 5 6 7 8 9
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 'daikanwa-strokes)
- (get-char-attribute char 'ideographic-strokes)
- (let ((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))
- (ts (get-char-attribute char 'total-strokes)))
- (if (and r ts)
- (- ts (aref ideograph-radical-strokes-vector r))))
- )))
- (when strokes
- (put-char-attribute char 'ideographic-strokes strokes)
- strokes))))
+(defun char-ideographic-strokes (char &optional radical)
+ (let (ret)
+ (or (catch 'tag
+ (dolist (cell (get-char-attribute char 'ideographic-))
+ (if (and (setq ret (plist-get cell :radical))
+ (or (eq ret radical)
+ (null radical)))
+ (throw 'tag (plist-get cell :strokes)))))
+ (get-char-attribute char 'daikanwa-strokes)
+ (get-char-attribute char 'ideographic-strokes)
+ (let ((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))
+ (ts (get-char-attribute char 'total-strokes)))
+ (if (and r ts)
+ (- ts (aref ideograph-radical-strokes-vector r))))
+ )))
+ (when strokes
+ (put-char-attribute char 'ideographic-strokes strokes)
+ strokes)))))
;;;###autoload
(defun update-ideograph-radical-table ()
(interactive)
- (let (ret script)
+ (let (ret radical script)
(map-char-attribute
(lambda (char radical)
(when (and radical
(aset ideograph-radical-chars-vector radical
(cons char ret))))
nil)
- 'ideographic-radical)))
+ 'ideographic-radical)
+ (map-char-attribute
+ (lambda (char data)
+ (dolist (cell data)
+ (setq radical (plist-get cell :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)))
+ (char-ideographic-strokes char)
+ (aset ideograph-radical-chars-vector radical
+ (cons char ret))))))
+ 'ideographic-)))
(defun int-list< (a b)
(if (numberp (car a))
t
(int-list< a b)))))
+;; (defun nil=-int< (a b)
+;; (cond ((null a) nil)
+;; ((null b) nil)
+;; (t (< a b))))
+
+;; (defun nil>-int< (a b)
+;; (cond ((null a) nil)
+;; ((null b) t)
+;; (t (< a b))))
+
+;;;###autoload
(defun char-representative-of-daikanwa (char)
(if (get-char-attribute char 'ideograph-daikanwa)
char
'morohashi-daikanwa))))
char))))
-(defun ideograph-char< (a 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 (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 (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 (or (get-char-attribute b '=>ucs)
- (get-char-attribute b '->ucs)))
- (if b-u
- (<= a-u b-u)
- t))
- (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 (or (get-char-attribute b '=>ucs)
- (get-char-attribute b '->ucs)))
- (if b-u
- (< a-u b-u)
- t))
- (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 char-attributes-poly< (c1 c2 accessors testers defaulters)
+ (catch 'tag
+ (let (a1 a2 accessor tester dm)
+ (while (and accessors testers)
+ (setq accessor (car accessors)
+ tester (car testers)
+ dm (car defaulters))
+ (when (and accessor tester)
+ (setq a1 (funcall accessor c1)
+ a2 (funcall accessor c2))
+ (cond ((null a1)
+ (if a2
+ (cond ((eq dm '<)
+ (throw 'tag t))
+ ((eq dm '>)
+ (throw 'tag nil)))))
+ ((null a2)
+ (cond ((eq dm '<)
+ (throw 'tag nil))
+ ((eq dm '>)
+ (throw 'tag t))))
+ (t
+ (cond ((funcall tester a1 a2)
+ (throw 'tag t))
+ ((funcall tester a2 a1)
+ (throw 'tag nil))))))
+ (setq accessors (cdr accessors)
+ testers (cdr testers)
+ defaulters (cdr defaulters))))))
+
+(defvar ideographic-radical nil)
+
+(defun char-daikanwa-strokes (char &optional radical)
+ (unless radical
+ (setq radical ideographic-radical))
+ (let ((drc (char-representative-of-daikanwa char)))
+ (char-ideographic-strokes
+ (if (= (char-ideographic-radical drc radical)
+ (char-ideographic-radical char radical))
+ drc
+ char)
+ radical)))
+
+;;;###autoload
+(defun char-daikanwa (char)
+ (or (get-char-attribute char 'ideograph-daikanwa)
+ (get-char-attribute char 'morohashi-daikanwa)))
+
+;;;###autoload
+(defun char-ucs (char)
+ (or (get-char-attribute char 'ucs)
+ (get-char-attribute char '=>ucs)))
+
+(defun char-id (char)
+ (logand (char-int char) #x3FFFFFFF))
+
+(defun ideograph-char< (a b &optional radical)
+ (let ((ideographic-radical (or radical
+ ideographic-radical)))
+ (char-attributes-poly<
+ a b
+ '(char-daikanwa-strokes char-daikanwa char-ucs char-id)
+ '(< morohashi-daikanwa< < <)
+ '(> > > >))))
(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<)))
+ (lambda (a b)
+ (ideograph-char< a b radical))))
+ attributes ccss)
+ (dolist (name (char-attribute-list))
+ (unless (memq name char-db-ignored-attributes)
+ (if (find-charset name)
+ (push name ccss)
+ (push name attributes))))
+ (setq attributes (sort attributes #'char-attribute-name<)
+ ccss (sort ccss #'char-attribute-name<))
(aset ideograph-radical-chars-vector radical chars)
- (while chars
- (insert-char-data (car chars) nil attributes ccs)
- (setq chars (cdr chars)))))
+ (dolist (char chars)
+ (when (some (lambda (ccs)
+ (let ((code (encode-char char ccs)))
+ (and code
+ ;;(not (memq ccs char-db-ignored-attributes))
+ ;;(or (not (memq ccs '(ucs))
+ (and (<= 0 code)(<= code #x10FFFF)))))
+ ccss)
+ (insert-char-data char nil attributes ccss)))))
(defun write-ideograph-radical-char-data (radical file)
(if (file-directory-p file)
file))))
(with-temp-buffer
(insert-ideograph-radical-char-data radical)
- (char-db-update-comment)
(let ((coding-system-for-write 'utf-8))
(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)
(setq rest structure)
(catch 'tag
(while (and rest value)
- (unless (char-ref= (car rest)(car value))
+ (unless (ideographic-structure=
+ (car rest)(car value))
(throw 'tag nil))
(setq rest (cdr rest)
value (cdr value)))
projects / chise / xemacs-chise.git- / blobdiff