;;;###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
+ (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 #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
- (setq ret
- (aref ideograph-radical-chars-vector radical))))
- (aset ideograph-radical-chars-vector radical
- (cons char ret))))
- (setq i (1+ i)))
- (setq i 1)
- (while (<= i 66773)
- (setq char (decode-char 'ideograph-gt 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)))
- (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)))
- (setq i 0)
- (while (< i (* 94 60 22))
- (setq char (decode-char 'mojikyo 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))
(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))
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 ret)
- (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)
- (progn
- (setq ret (decode-char 'ideograph-daikanwa a-m-m))
- (if (= (get-char-attribute ret 'ideographic-radical)
- (get-char-attribute a 'ideographic-radical))
- (setq a-s (char-ideographic-strokes ret))
- (setq a-s (char-ideographic-strokes a))))
- (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)
- (progn
- (setq ret (decode-char 'ideograph-daikanwa b-m-m))
- (if (= (get-char-attribute ret 'ideographic-radical)
- (get-char-attribute b 'ideographic-radical))
- (setq b-s (char-ideographic-strokes ret))
- (setq b-s (char-ideographic-strokes b))))
- (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
- (morohashi-daikanwa< (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))
(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)
(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
projects / chise / xemacs-chise.git / blobdiff