(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)
char
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)
;;;###autoload
(defun char-ucs (char)
(or (get-char-attribute char 'ucs)
- (get-char-attribute char '=>ucs)
- (get-char-attribute char '->ucs)))
+ (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)
(aset ideograph-radical-chars-vector radical chars)
(dolist (char chars)
(when (some (lambda (ccs)
- (encode-char char 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)))))
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)
)))
projects / chise / xemacs-chise.git- / blobdiff