From: tomo Date: Wed, 19 Jul 2000 03:40:52 +0000 (+0000) Subject: (char-ideographic-radical): Renamed from `char-ideograph-radical'. X-Git-Tag: r21-2-34-utf-2000-0_17-0~46 X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=41959750aedad18859ac70645f5bc3768a932e52;p=chise%2Fxemacs-chise.git- (char-ideographic-radical): Renamed from `char-ideograph-radical'. (ideograph-radical-strokes-vector): New variable. (char-ideographic-strokes): Renamed from `char-ideograph-strokes'; detect `ideographic-strokes' using `ideograph-radical-strokes-vector' if `total-strokes' is found. (int-list<): New function. (ideograph-char<): New implementation. --- diff --git a/lisp/utf-2000/ideograph-util.el b/lisp/utf-2000/ideograph-util.el index 87e2e21..9bddea0 100644 --- a/lisp/utf-2000/ideograph-util.el +++ b/lisp/utf-2000/ideograph-util.el @@ -29,7 +29,7 @@ (defvar ideograph-radical-chars-vector (make-vector 215 nil)) -(defun char-ideograph-radical (char) +(defun char-ideographic-radical (char) (or (get-char-attribute char 'ideographic-radical) (let ((radical (or (get-char-attribute char 'daikanwa-radical) @@ -40,13 +40,45 @@ (put-char-attribute char 'ideographic-radical radical) radical)))) -(defun char-ideograph-strokes (char) +(defvar ideograph-radical-strokes-vector + ;;0 1 2 3 4 5 6 7 8 9 + [nil 1 1 1 1 1 1 2 2 2 + 2 2 2 2 2 2 2 2 2 2 + 2 2 2 2 2 2 2 2 2 2 + 3 3 3 3 3 3 3 3 3 3 + 3 3 3 3 3 3 3 3 3 3 + 3 3 3 3 3 3 3 3 3 3 + 3 4 4 4 3 4 4 4 4 4 + 4 4 4 4 4 4 4 4 4 4 + 4 4 4 4 4 4 4 4 4 4 + 4 4 4 4 4 5 5 5 5 5 + ;; 100 + 5 5 5 5 5 5 5 5 5 5 + 5 5 5 5 5 5 5 5 6 6 + 6 6 6 6 6 6 6 6 6 6 + 6 6 6 6 6 6 6 6 6 6 + 6 6 6 6 6 6 6 7 7 7 + 7 7 7 7 7 7 7 7 7 7 + 7 7 4 3 7 7 7 8 8 8 + 8 8 8 8 8 8 9 9 9 9 + 9 9 9 9 9 9 9 10 10 10 + 10 10 10 10 10 11 11 11 11 11 + ;; 200 + 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 'ideographic-strokes) (let ((strokes (or (get-char-attribute char 'daikanwa-strokes) (get-char-attribute char 'kangxi-strokes) (get-char-attribute char 'japanese-strokes) - (get-char-attribute char 'korean-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)))) @@ -80,10 +112,10 @@ (setq char (decode-char 'ucs i)) (when (and (or (null (setq script (get-char-attribute char 'script))) (memq 'Ideograph script)) - (setq radical (char-ideograph-radical char))) + (setq radical (char-ideographic-radical char))) (or (get-char-attribute char 'ucs) (put-char-attribute char 'ucs i)) - (char-ideograph-strokes char) + (char-ideographic-strokes char) (if (not (memq char (setq ret (aref ideograph-radical-chars-vector radical)))) @@ -95,7 +127,7 @@ (setq char (decode-char 'ucs i)) (when (and (or (null (setq script (get-char-attribute char 'script))) (memq 'Ideograph script)) - (setq radical (char-ideograph-radical char))) + (setq radical (char-ideographic-radical char))) (if (not (memq char (setq ret (aref ideograph-radical-chars-vector radical)))) @@ -105,7 +137,7 @@ (setq i 0) (while (< i 50101) (setq char (decode-char 'ideograph-daikanwa i)) - (if (and (setq radical (char-ideograph-radical char)) + (if (and (setq radical (char-ideographic-radical char)) (not (memq char (setq ret @@ -121,7 +153,7 @@ (setq char (make-char (car charsets) i j)) (if (and (or (null (setq script (get-char-attribute char 'script))) (memq 'Ideograph script)) - (setq radical (char-ideograph-radical char)) + (setq radical (char-ideographic-radical char)) (not (memq char (setq ret (aref ideograph-radical-chars-vector @@ -133,60 +165,138 @@ (setq charsets (cdr charsets))) )) +(defun int-list< (a b) + (if (numberp (car a)) + (if (numberp (car b)) + (if (= (car a) (car b)) + (int-list< (cdr a)(cdr b)) + (< (car a) (car b))) + nil) + (numberp (car b)))) + (defun ideograph-char< (a b) - (let (ra rb mma mmb msa msb) - (cond - ((progn - (if (setq ra (or (get-char-attribute a 'non-morohashi) - (get-char-attribute a 'morohashi-daikanwa))) - (setq msa (cdr ra) - mma (car ra)) - (setq mma (get-char-attribute a 'ideograph-daikanwa)))) - (cond - ((progn - (if (setq rb (or (get-char-attribute b 'non-morohashi) - (get-char-attribute b 'morohashi-daikanwa))) - (setq msb (cdr rb) - mmb (car rb)) - (setq mmb (get-char-attribute b 'ideograph-daikanwa)))) - (cond - ((= mma mmb) - (cond ((eq (car msa)(car msb)) - (cond ((< (length msa)(length msb))) - ((= (length msa)(length msb)) - (cond ((integerp (nth 1 msa)) - (cond ((integerp (nth 1 msb)) - (< (nth 1 msa)(nth 1 msb))) - (t nil))) - (t - (cond ((setq ra (get-char-attribute a 'ucs)) - (cond - ((setq rb (get-char-attribute b 'ucs)) - (< ra rb)) - (t)))))))) - ) - ((null (car msa))) - ((null (car msb)) - nil) - (t (< (car msa)(car msb))))) - (t (< mma mmb)))) - (t))) - ((or (get-char-attribute b 'non-morohashi) - (get-char-attribute b 'morohashi-daikanwa) - (get-char-attribute b 'ideograph-daikanwa)) - nil) - ((setq ra (get-char-attribute a 'ucs)) - (cond - ((setq rb (get-char-attribute b 'ucs)) - (< ra rb)))) - (t - (cond - ((setq ra (char-ideograph-strokes a)) - (cond ((setq rb (char-ideograph-strokes b)) - (cond ((= ra rb) - (not (char-ideograph-strokes b))) - ((< ra rb)))))) - ))))) + (let ((a-m-m (get-char-attribute a 'ideograph-daikanwa)) + (b-m-m (get-char-attribute b 'ideograph-daikanwa)) + a-m-r b-m-r + a-s b-s + a-u b-u m) + (if a-m-m + (setq a-s (char-ideographic-strokes a)) + (setq a-m-r (get-char-attribute a 'morohashi-daikanwa)) + (if a-m-r + (progn + (setq a-m-m (car a-m-r) + a-m-r (cdr a-m-r)) + (if (= (car a-m-r) 0) + (setq a-s (char-ideographic-strokes + (decode-char 'ideograph-daikanwa a-m-m))) + (if (setq m (get-char-attribute a '->mojikyo)) + (setq a-s (char-ideographic-strokes + (decode-char 'mojikyo m))) + (setq a-s (char-ideographic-strokes a))))) + (setq a-s (char-ideographic-strokes a)))) + (if b-m-m + (setq b-s (char-ideographic-strokes b)) + (setq b-m-r (get-char-attribute b 'morohashi-daikanwa)) + (if b-m-r + (progn + (setq b-m-m (car b-m-r) + b-m-r (cdr b-m-r)) + (if (= (car b-m-r) 0) + (setq b-s (char-ideographic-strokes + (decode-char 'ideograph-daikanwa b-m-m))) + (if (setq m (get-char-attribute b '->mojikyo)) + (setq b-s (char-ideographic-strokes + (decode-char 'mojikyo m))) + (setq b-s (char-ideographic-strokes b))))) + (setq b-s (char-ideographic-strokes b)))) + (if a-s + (if b-s + (if (= a-s b-s) + (if a-m-m + (if b-m-m + (int-list< (cons a-m-m a-m-r) + (cons b-m-m b-m-r)) + t) + (if b-m-m + 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 (get-char-attribute b '->ucs)) + (if b-u + (<= a-u b-u) + t)) + (setq a-u (get-char-attribute a '->ucs)) + (if a-u + (if b-u + (< a-u b-u) + (setq b-u (get-char-attribute b '->ucs)) + (if b-u + (< a-u b-u) + t)) + (if (or b-u (get-char-attribute b '->ucs)) + nil + (< (char-int a)(char-int b))))))) + (< a-s b-s)) + t)))) + +;; (defun ideograph-char< (a b) +;; (let (ra rb mma mmb msa msb) +;; (cond +;; ((progn +;; (if (setq ra (or (get-char-attribute a 'non-morohashi) +;; (get-char-attribute a 'morohashi-daikanwa))) +;; (setq msa (cdr ra) +;; mma (car ra)) +;; (setq mma (get-char-attribute a 'ideograph-daikanwa)))) +;; (cond +;; ((progn +;; (if (setq rb (or (get-char-attribute b 'non-morohashi) +;; (get-char-attribute b 'morohashi-daikanwa))) +;; (setq msb (cdr rb) +;; mmb (car rb)) +;; (setq mmb (get-char-attribute b 'ideograph-daikanwa)))) +;; (cond +;; ((= mma mmb) +;; (cond ((eq (car msa)(car msb)) +;; (cond ((< (length msa)(length msb))) +;; ((= (length msa)(length msb)) +;; (cond ((integerp (nth 1 msa)) +;; (cond ((integerp (nth 1 msb)) +;; (< (nth 1 msa)(nth 1 msb))) +;; (t nil))) +;; (t +;; (cond ((setq ra (get-char-attribute a 'ucs)) +;; (cond +;; ((setq rb (get-char-attribute b 'ucs)) +;; (< ra rb)) +;; (t)))))))) +;; ) +;; ((null (car msa))) +;; ((null (car msb)) +;; nil) +;; (t (< (car msa)(car msb))))) +;; (t (< mma mmb)))) +;; (t))) +;; ((or (get-char-attribute b 'non-morohashi) +;; (get-char-attribute b 'morohashi-daikanwa) +;; (get-char-attribute b 'ideograph-daikanwa)) +;; nil) +;; ((setq ra (get-char-attribute a 'ucs)) +;; (cond +;; ((setq rb (get-char-attribute b 'ucs)) +;; (< ra rb)))) +;; (t +;; (cond +;; ((setq ra (char-ideographic-strokes a)) +;; (cond ((setq rb (char-ideographic-strokes b)) +;; (cond ((= ra rb) +;; (not (char-ideographic-strokes b))) +;; ((< ra rb)))))) +;; ))))) (defun insert-ideograph-radical-char-data (radical) (let ((chars