From b2796f83b94d04d36cb97efe94dcda51af55ea75 Mon Sep 17 00:00:00 2001 From: tomo Date: Wed, 24 Mar 2004 18:32:46 +0000 Subject: [PATCH] (expand-char-feature-name): New function. (map-char-family): New function. (get-char-feature-from-domains): New function. (char-ideographic-radical): Add new optional argument `ignore-sisters'; use `get-char-feature-from-domains'. (char-ideographic-strokes-from-domains): Use `get-char-feature-from-domains'. (char-ideographic-strokes): Simplify code about domains. (update-ideograph-radical-table): Check ancestors' radicals; prefer to use `get-char-attribute' to get `ideographic-radical' rather than to use `char-ideographic-radical'. (char-representative-of-daikanwa): Add new optional arguments `ignore-default' and `dont-inherit'; use `map-char-family'. (char-daikanwa): Use `map-char-family'. --- lisp/utf-2000/ideograph-util.el | 269 +++++++++++++++++++++++++++------------ 1 file changed, 190 insertions(+), 79 deletions(-) diff --git a/lisp/utf-2000/ideograph-util.el b/lisp/utf-2000/ideograph-util.el index a815051..24a3be5 100644 --- a/lisp/utf-2000/ideograph-util.el +++ b/lisp/utf-2000/ideograph-util.el @@ -26,28 +26,111 @@ (require 'char-db-util) +;;;###autoload +(defun expand-char-feature-name (feature domain) + (if domain + (intern (format "%s@%s" feature domain)) + feature)) + +(defun map-char-family (function char &optional ignore-sisters) + (let ((rest (list char)) + ret checked) + (catch 'tag + (while rest + (unless (memq (car rest) checked) + (if (setq ret (funcall function (car rest))) + (throw 'tag ret)) + (setq checked (cons (car rest) checked) + rest (append rest + (get-char-attribute (car rest) '->subsumptive) + (get-char-attribute (car rest) '->denotational) + (get-char-attribute (car rest) '->identical))) + (unless ignore-sisters + (setq rest (append rest + (get-char-attribute (car rest) '<-subsumptive) + (get-char-attribute (car rest) '<-denotational))))) + (setq rest (cdr rest)))))) + +(defun get-char-feature-from-domains (char feature domains + &optional tester arg + ignore-sisters) + (map-char-family + (lambda (ch) + (let (ret) + (catch 'tag + (dolist (domain domains) + (if (and (or (null tester) + (equal (or (char-feature + ch (expand-char-feature-name + tester domain)) + (char-feature ch tester)) + arg)) + (setq ret (or (char-feature + ch (expand-char-feature-name + feature domain)) + (char-feature ch feature)))) + (throw 'tag ret)))))) + char ignore-sisters) + ;; (let ((rest (list char)) + ;; ret checked) + ;; (catch 'tag + ;; (while rest + ;; (setq char (car rest)) + ;; (unless (memq char checked) + ;; (dolist (domain domains) + ;; (if (and (setq ret (char-feature + ;; char + ;; (expand-char-feature-name + ;; feature domain))) + ;; (or (null tester) + ;; (equal (or (char-feature + ;; char + ;; (expand-char-feature-name + ;; tester domain)) + ;; (char-feature char tester)) + ;; arg))) + ;; (throw 'tag ret))) + ;; (setq rest (append rest + ;; (get-char-attribute char '->subsumptive) + ;; (get-char-attribute char '->denotational) + ;; (get-char-attribute char '<-subsumptive) + ;; (get-char-attribute char '<-denotational)) + ;; checked (cons char checked))) + ;; (setq rest (cdr rest))))) + ) + + (defvar ideograph-radical-chars-vector (make-vector 215 nil)) -(defun char-ideographic-radical (char &optional radical) +(defun char-ideographic-radical (char &optional radical ignore-sisters) (let (ret) - (or (catch 'tag - (dolist (domain char-db-feature-domains) - (if (and (setq ret (char-feature - char - (intern - (format "%s@%s" - 'ideographic-radical domain)))) - (or (eq ret radical) - (null radical))) - (throw 'tag ret)))) + (or (if radical + (get-char-feature-from-domains + char 'ideographic-radical (cons nil char-db-feature-domains) + 'ideographic-radical radical ignore-sisters) + (get-char-feature-from-domains + char 'ideographic-radical (cons nil char-db-feature-domains) + ignore-sisters)) + ;; (catch 'tag + ;; (dolist (domain char-db-feature-domains) + ;; (if (and (setq ret (char-feature + ;; char + ;; (intern + ;; (format "%s@%s" + ;; 'ideographic-radical domain)))) + ;; (or (eq ret radical) + ;; (null radical))) + ;; (throw 'tag ret)))) (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)))) - (char-feature char 'ideographic-radical) + (get-char-feature-from-domains + char 'ideographic-radical (cons nil char-db-feature-domains)) + ;; (char-feature char 'ideographic-radical) (progn (setq ret (or (get-char-attribute char 'daikanwa-radical) @@ -87,24 +170,38 @@ ;;;###autoload (defun char-ideographic-strokes-from-domains (char domains &optional radical) - (let (ret) - (catch 'tag - (dolist (domain domains) - (if (and (setq ret (or (char-feature - char - (intern - (format "%s@%s" - 'ideographic-radical domain))) - (char-feature - char 'ideographic-radical))) - (or (eq ret radical) - (null radical)) - (setq ret (char-feature - char - (intern - (format "%s@%s" - 'ideographic-strokes domain))))) - (throw 'tag ret)))))) + (if radical + (get-char-feature-from-domains char 'ideographic-strokes domains + 'ideographic-radical radical) + (get-char-feature-from-domains char 'ideographic-strokes domains)) + ;; (let ((rest (list char)) + ;; ret checked) + ;; (catch 'tag + ;; (while rest + ;; (setq char (car rest)) + ;; (unless (memq char checked) + ;; (dolist (domain domains) + ;; (if (and (setq ret (or (char-feature + ;; char + ;; (expand-char-feature-name + ;; 'ideographic-radical domain)) + ;; (char-feature + ;; char 'ideographic-radical))) + ;; (or (eq ret radical) + ;; (null radical)) + ;; (setq ret (or (char-feature + ;; char + ;; (expand-char-feature-name + ;; 'ideographic-strokes domain)) + ;; (char-feature + ;; char 'ideographic-strokes)))) + ;; (throw 'tag ret))) + ;; (setq rest (append rest + ;; (get-char-attribute char '->subsumptive) + ;; (get-char-attribute char '->denotational)) + ;; checked (cons char checked))) + ;; (setq rest (cdr rest))))) + ) ;;;###autoload (defun char-ideographic-strokes (char &optional radical preferred-domains) @@ -116,11 +213,10 @@ (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) + char (append preferred-domains + (cons nil + char-db-feature-domains)) + radical) (get-char-attribute char 'daikanwa-strokes) (let ((strokes (or (get-char-attribute char 'kangxi-strokes) @@ -171,8 +267,9 @@ (progn (setq dest nil) (dolist (pc ret) - (unless (get-char-attribute - pc 'ideographic-radical) + (unless (eq (get-char-attribute + pc 'ideographic-radical) + radical) (setq dest (cons pc dest)))) dest) (list chr)) @@ -180,7 +277,9 @@ (get-char-attribute chr '->denotational))) (when (and radical (or (eq radical - (char-ideographic-radical char radical)) + (or (get-char-attribute + char 'ideographic-radical) + (char-ideographic-radical char radical))) (null (char-ideographic-radical char))) (or (null (setq script (get-char-attribute char 'script))) @@ -247,7 +346,8 @@ ;; (t (< a b)))) ;;;###autoload -(defun char-representative-of-daikanwa (char &optional radical) +(defun char-representative-of-daikanwa (char &optional radical + ignore-default dont-inherit) (unless radical (setq radical ideographic-radical)) (if (or (encode-char char 'ideograph-daikanwa 'defined-only) @@ -255,7 +355,8 @@ char (let ((m (char-feature char '=>daikanwa)) m-m m-s pat - scs sc ret) + ;;scs sc ret + ) (or (and (integerp m) (or (decode-char '=daikanwa-rev2 m 'defined-only) (decode-char 'ideograph-daikanwa m))) @@ -272,20 +373,33 @@ (if (equal pat v) c)) 'morohashi-daikanwa)))) - (when (setq scs (get-char-attribute char '->subsumptive)) - (while (and scs - (setq sc (car scs)) - (not - (and - (setq ret - (char-representative-of-daikanwa sc)) + (unless dont-inherit + (map-char-family + (lambda (sc) + (let ((ret (char-representative-of-daikanwa sc nil t t))) + (if (and ret (or (null radical) (eq (char-ideographic-radical ret radical) - radical) - (setq ret nil))))) - (setq scs (cdr scs))) - ret) - char)))) + radical))) + ret))) + char)) + ;; (when (setq scs (append + ;; (get-char-attribute char '->subsumptive) + ;; (get-char-attribute char '->denotational))) + ;; (while (and scs + ;; (setq sc (car scs)) + ;; (not + ;; (and + ;; (setq ret + ;; (char-representative-of-daikanwa sc nil t)) + ;; (or (null radical) + ;; (eq (char-ideographic-radical ret radical) + ;; radical) + ;; (setq ret nil))))) + ;; (setq scs (cdr scs))) + ;; ret) + (unless ignore-default + char))))) (defun char-attributes-poly< (c1 c2 accessors testers defaulters) (catch 'tag @@ -331,33 +445,30 @@ ;;;###autoload (defun char-daikanwa (char &optional radical) - (or (encode-char char 'ideograph-daikanwa 'defined-only) - (encode-char char '=daikanwa-rev2 'defined-only) - (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))) - (let ((scs (get-char-attribute char '->subsumptive)) - sc ret) - (unless radical - (setq radical ideographic-radical)) - (when scs - (while (and scs - (setq sc (car scs)) - (not - (and - (setq ret - (char-representative-of-daikanwa sc)) - (or (null radical) - (eq (char-ideographic-radical ret radical) - radical) - (setq ret nil))))) - (setq scs (cdr scs)))) - (if ret - (char-daikanwa ret))))) + (unless radical + (setq radical ideographic-radical)) + (map-char-family + (lambda (sc) + (if (or (null radical) + (eq (or (get-char-attribute sc 'ideographic-radical) + (char-ideographic-radical sc radical t)) + radical)) + (let ((ret (or (encode-char sc 'ideograph-daikanwa 'defined-only) + (encode-char sc '=daikanwa-rev2 'defined-only)))) + (if ret + (if (or (eq sc char) + (and (null (get-char-attribute char '<-subsumptive)) + (null (get-char-attribute char '<-denotational)))) + ret + (list ret 0)) + (or (get-char-attribute sc 'morohashi-daikanwa) + (if (setq ret (char-feature sc '=>daikanwa)) + (cond ((consp ret) ret) + ((or (get-char-attribute char '<-subsumptive) + (get-char-attribute char '<-denotational)) + (list ret 0)) + (t ret)))))))) + char)) ;;;###autoload (defun char-ucs (char) -- 1.7.10.4