;;; ideograph-util.el --- Ideographic Character Database utility
-;; Copyright (C) 1999,2000,2001,2002 MORIOKA Tomohiko.
+;; Copyright (C) 1999,2000,2001,2002,2003 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))
;; ((null b) t)
;; (t (< a b))))
+;;;###autoload
(defun char-representative-of-daikanwa (char)
- (if (get-char-attribute char 'ideograph-daikanwa)
+ (if (or (encode-char char 'ideograph-daikanwa 'defined-only)
+ (encode-char char '=daikanwa-rev2 'defined-only))
char
(let ((m (get-char-attribute char 'morohashi-daikanwa))
m-m m-s pat)
(setq m-m (pop m))
(setq m-s (pop m))
(if (= m-s 0)
- (decode-char 'ideograph-daikanwa m-m)
+ (or (decode-char '=daikanwa-rev2 m-m 'defined-only)
+ (decode-char 'ideograph-daikanwa m-m))
(when m
(setq pat (list m-m m-s))
(map-char-attribute (lambda (c v)
testers (cdr testers)
defaulters (cdr defaulters))))))
-(defun char-daikanwa-strokes (char)
+(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 (= (get-char-attribute drc 'ideographic-radical)
- (get-char-attribute char 'ideographic-radical))
+ (if (= (char-ideographic-radical drc radical)
+ (char-ideographic-radical char radical))
drc
- char))))
+ char)
+ radical)))
;;;###autoload
(defun char-daikanwa (char)
- (or (get-char-attribute char 'ideograph-daikanwa)
+ (or (encode-char char 'ideograph-daikanwa 'defined-only)
+ (encode-char char '=daikanwa-rev2 'defined-only)
(get-char-attribute char 'morohashi-daikanwa)))
;;;###autoload
(defun char-ucs (char)
- (or (get-char-attribute char 'ucs)
- (get-char-attribute char '=>ucs)
- (get-char-attribute char '->ucs)))
+ (or (encode-char char '=ucs 'defined-only)
+ (get-char-attribute char '=>ucs)))
(defun char-id (char)
(logand (char-int char) #x3FFFFFFF))
-(defun ideograph-char< (a b)
- (char-attributes-poly<
- a b
- '(char-daikanwa-strokes char-daikanwa char-ucs char-id)
- '(< morohashi-daikanwa< < <)
- '(> > > >)))
+(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<)))
+ (lambda (a b)
+ (ideograph-char< a b radical))))
attributes ccss)
(dolist (name (char-attribute-list))
(unless (memq name char-db-ignored-attributes)
ccss (sort ccss #'char-attribute-name<))
(aset ideograph-radical-chars-vector radical chars)
(dolist (char chars)
- (when (some (lambda (ccs)
- (encode-char char ccs))
- ccss)
+ (when (or (not (some (lambda (atr)
+ (get-char-attribute char atr))
+ char-db-ignored-attributes))
+ (some (lambda (ccs)
+ (encode-char char ccs 'defined-only))
+ ccss))
(insert-char-data char nil attributes ccss)))))
(defun write-ideograph-radical-char-data (radical 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)
)))