X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Futf-2000%2Fideograph-util.el;h=7044aa9403b7753f26b81123a8faed93e171db45;hb=399cae61bc6f175584dad0416a2e50e86acdb2da;hp=5e80f57349c2314baa6a0b44649f6e65033173fb;hpb=258a2b8d36c2bb9c0ca8418d568b121300e26e53;p=chise%2Fxemacs-chise.git- diff --git a/lisp/utf-2000/ideograph-util.el b/lisp/utf-2000/ideograph-util.el index 5e80f57..7044aa9 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) @@ -230,7 +267,11 @@ (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)))))