X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Futf-2000%2Fideograph-util.el;h=9f384dbfff476592cd448bbaa31ce6c12a1b8d67;hb=35e0e87c760d73f077492976aa8226ab94568bac;hp=38ccc19a1d8679a9be95cc05a363963b55fbd283;hpb=7c2debc0f9903c0b3980134856c4cd0825bc43b1;p=chise%2Fxemacs-chise.git.1 diff --git a/lisp/utf-2000/ideograph-util.el b/lisp/utf-2000/ideograph-util.el index 38ccc19..9f384db 100644 --- a/lisp/utf-2000/ideograph-util.el +++ b/lisp/utf-2000/ideograph-util.el @@ -33,7 +33,7 @@ (let (ret) (or (catch 'tag (dolist (domain char-db-feature-domains) - (if (and (setq ret (get-char-attribute + (if (and (setq ret (char-feature char (intern (format "%s@%s" @@ -47,7 +47,7 @@ (or (eq ret radical) (null radical))) (throw 'tag ret)))) - (get-char-attribute char 'ideographic-radical) + (char-feature char 'ideographic-radical) (progn (setq ret (or (get-char-attribute char 'daikanwa-radical) @@ -90,16 +90,16 @@ (let (ret) (catch 'tag (dolist (domain domains) - (if (and (setq ret (or (get-char-attribute + (if (and (setq ret (or (char-feature char (intern (format "%s@%s" 'ideographic-radical domain))) - (get-char-attribute + (char-feature char 'ideographic-radical))) (or (eq ret radical) (null radical)) - (setq ret (get-char-attribute + (setq ret (char-feature char (intern (format "%s@%s" @@ -109,17 +109,18 @@ ;;;###autoload (defun char-ideographic-strokes (char &optional radical preferred-domains) (let (ret) - (or (char-ideographic-strokes-from-domains - char preferred-domains radical) - (get-char-attribute char 'ideographic-strokes) - (char-ideographic-strokes-from-domains - char char-db-feature-domains radical) - (catch 'tag + (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))))) + (char-ideographic-strokes-from-domains + char preferred-domains radical) + (get-char-attribute char 'ideographic-strokes) + (char-ideographic-strokes-from-domains + char char-db-feature-domains radical) + (char-feature char 'ideographic-strokes) (get-char-attribute char 'daikanwa-strokes) (let ((strokes (or (get-char-attribute char 'kangxi-strokes) @@ -156,33 +157,33 @@ (defun update-ideograph-radical-table () (interactive) (let (ret radical script) - (dolist (domain char-db-feature-domains) + (dolist (feature + (cons 'ideographic-radical + (mapcar + (lambda (domain) + (intern (format "%s@%s" 'ideographic-radical domain))) + char-db-feature-domains))) (map-char-attribute - (lambda (char 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)))) + (lambda (chr radical) + (dolist (char (cons chr + (append + (get-char-attribute chr '<-identical) + (get-char-attribute chr '->denotational)))) + (when (and radical + (eq radical + (char-ideographic-radical char 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))))) nil) - (intern (format "%s@%s" 'ideographic-radical domain)))) - (map-char-attribute - (lambda (char 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)))) - nil) - 'ideographic-radical) + feature)) (map-char-attribute (lambda (char data) (dolist (cell data) @@ -240,11 +241,15 @@ (if (or (encode-char char 'ideograph-daikanwa 'defined-only) (encode-char char '=daikanwa-rev2 'defined-only)) char - (let ((m (get-char-attribute char 'morohashi-daikanwa)) + (let ((m (char-feature char '=>daikanwa)) m-m m-s pat) - (or (when m - (setq m-m (pop m)) - (setq m-s (pop m)) + (or (and (integerp m) + (or (decode-char '=daikanwa-rev2 m 'defined-only) + (decode-char 'ideograph-daikanwa m))) + (when (or m + (setq m (get-char-attribute char 'morohashi-daikanwa))) + (setq m-m (car m)) + (setq m-s (nth 1 m)) (if (= m-s 0) (or (decode-char '=daikanwa-rev2 m-m 'defined-only) (decode-char 'ideograph-daikanwa m-m)) @@ -301,12 +306,18 @@ (defun char-daikanwa (char) (or (encode-char char 'ideograph-daikanwa 'defined-only) (encode-char char '=daikanwa-rev2 'defined-only) - (get-char-attribute char 'morohashi-daikanwa))) + (get-char-attribute char 'morohashi-daikanwa) + (let ((ret (char-feature char '=>daikanwa))) + (and ret + (if (or (get-char-attribute char '<-subsumptive) + (get-char-attribute char '<-denotational)) + (list ret 0) + ret))))) ;;;###autoload (defun char-ucs (char) (or (encode-char char '=ucs 'defined-only) - (get-char-attribute char '=>ucs))) + (char-feature char '=>ucs))) (defun char-id (char) (logand (char-int char) #x3FFFFFFF)) @@ -325,23 +336,30 @@ (sort (copy-list (aref ideograph-radical-chars-vector radical)) (lambda (a b) (ideograph-char< a b radical)))) - attributes ccss) + attributes ; ccss + ) (dolist (name (char-attribute-list)) (unless (memq name char-db-ignored-attributes) - (if (find-charset name) - (push name ccss) - (push name attributes)))) + ;; (if (find-charset name) + ;; (push name ccss) + (push name attributes) + ;; ) + )) (setq attributes (sort attributes #'char-attribute-name<) - ccss (sort ccss #'char-attribute-name<)) + ;; ccss (sort ccss #'char-attribute-name<) + ) (aset ideograph-radical-chars-vector radical chars) (dolist (char chars) - (when (or (not (some (lambda (atr) - (get-char-attribute char atr)) - char-db-ignored-attributes)) - (some (lambda (ccs) - (encode-char char ccs 'defined-only)) - ccss)) - (insert-char-data char nil attributes ccss))))) + (when ;;(or + (not (some (lambda (atr) + (get-char-attribute char atr)) + char-db-ignored-attributes)) + ;; (some (lambda (ccs) + ;; (encode-char char ccs 'defined-only)) + ;; ccss) + ;;) + (insert-char-data char nil attributes ;ccss + ))))) (defun write-ideograph-radical-char-data (radical file) (if (file-directory-p file)