From 29aab027a61ca1b8f743fc4a6d144c5d7cea2b1f Mon Sep 17 00:00:00 2001 From: tomo Date: Sat, 13 Jul 2002 18:41:06 +0000 Subject: [PATCH] (char-ideographic-radical): Add new optional argument `radical'; refer `ideographic-' property. (char-ideographic-strokes): Likewise. (update-ideograph-radical-table): Check `ideographic-' property too. (ideographic-radical): New variable. (char-daikanwa-strokes): Add new optional argument `radical'. (ideograph-char<): Add new optional argument `radical'. (insert-ideograph-radical-char-data): Bind `ideographic-radical' as argument `radical'. (insert-ideograph-radical-char-data): Specify optional argument `radical' of `ideograph-char<' instead of bind `ideographic-radical'. --- lisp/utf-2000/ideograph-util.el | 113 ++++++++++++++++++++++++++------------- 1 file changed, 75 insertions(+), 38 deletions(-) diff --git a/lisp/utf-2000/ideograph-util.el b/lisp/utf-2000/ideograph-util.el index 5e80f57..1bb7c38 100644 --- a/lisp/utf-2000/ideograph-util.el +++ b/lisp/utf-2000/ideograph-util.el @@ -29,16 +29,24 @@ (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 @@ -67,26 +75,33 @@ 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 @@ -99,7 +114,21 @@ (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)) @@ -186,13 +215,18 @@ 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) @@ -208,17 +242,20 @@ (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) -- 1.7.10.4