X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Futf-2000%2Fideograph-util.el;h=7044aa9403b7753f26b81123a8faed93e171db45;hb=3e24e759557296215478c951a8f8c34941b33a35;hp=d00f60d25386fe2fb7ae484821765b8139564c54;hpb=60752d3a52d6af885539cbaf07ebbb20b145c328;p=chise%2Fxemacs-chise.git- diff --git a/lisp/utf-2000/ideograph-util.el b/lisp/utf-2000/ideograph-util.el index d00f60d..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)) @@ -128,6 +157,16 @@ t (int-list< a b))))) +;; (defun nil=-int< (a b) +;; (cond ((null a) nil) +;; ((null b) nil) +;; (t (< a b)))) + +;; (defun nil>-int< (a b) +;; (cond ((null a) nil) +;; ((null b) t) +;; (t (< a b)))) + (defun char-representative-of-daikanwa (char) (if (get-char-attribute char 'ideograph-daikanwa) char @@ -146,65 +185,77 @@ 'morohashi-daikanwa)))) char)))) -(defun ideograph-char< (a 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 (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 (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)) - (if a-u - (if b-u - (< a-u b-u) - (setq b-u (or (get-char-attribute b '=>ucs) - (get-char-attribute b '->ucs))) - (if b-u - (<= a-u b-u) - t)) - (setq a-u (or (get-char-attribute a '=>ucs) - (get-char-attribute a '->ucs))) - (if a-u - (if b-u - (< a-u b-u) - (setq b-u (or (get-char-attribute b '=>ucs) - (get-char-attribute b '->ucs))) - (if b-u - (< a-u b-u) - t)) - (if (or b-u (or (get-char-attribute b '=>ucs) - (get-char-attribute b '->ucs))) - nil - (< (char-int a)(char-int b))))))) - (< a-s b-s)) - t)))) +(defun char-attributes-poly< (c1 c2 accessors testers defaulters) + (catch 'tag + (let (a1 a2 accessor tester dm) + (while (and accessors testers) + (setq accessor (car accessors) + tester (car testers) + dm (car defaulters)) + (when (and accessor tester) + (setq a1 (funcall accessor c1) + a2 (funcall accessor c2)) + (cond ((null a1) + (if a2 + (cond ((eq dm '<) + (throw 'tag t)) + ((eq dm '>) + (throw 'tag nil))))) + ((null a2) + (cond ((eq dm '<) + (throw 'tag nil)) + ((eq dm '>) + (throw 'tag t)))) + (t + (cond ((funcall tester a1 a2) + (throw 'tag t)) + ((funcall tester a2 a1) + (throw 'tag nil)))))) + (setq accessors (cdr accessors) + testers (cdr testers) + defaulters (cdr defaulters)))))) + +(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 (= (char-ideographic-radical drc radical) + (char-ideographic-radical char radical)) + drc + char) + radical))) + +;;;###autoload +(defun char-daikanwa (char) + (or (get-char-attribute char 'ideograph-daikanwa) + (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))) + +(defun char-id (char) + (logand (char-int char) #x3FFFFFFF)) + +(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) @@ -216,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)))))