X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Futf-2000%2Fideograph-util.el;h=c928114d3d77bc7edb60f000462673ae825b9887;hb=6466cdd52a36764c931204047fd2eabdc3071098;hp=2fc44024d316373b4584c5a77a8e2287bd17654e;hpb=9ebbb78223e047fdc1001990e3527de9d62ba2e1;p=chise%2Fxemacs-chise.git diff --git a/lisp/utf-2000/ideograph-util.el b/lisp/utf-2000/ideograph-util.el index 2fc4402..c928114 100644 --- a/lisp/utf-2000/ideograph-util.el +++ b/lisp/utf-2000/ideograph-util.el @@ -1,6 +1,6 @@ ;;; ideograph-util.el --- Ideographic Character Database utility -;; Copyright (C) 1999,2000,2001,2002,2003,2004 MORIOKA Tomohiko. +;; Copyright (C) 1999,2000,2001,2002,2003,2004,2005,2007 MORIOKA Tomohiko. ;; Author: MORIOKA Tomohiko ;; Keywords: CHISE, Chaon model, ISO/IEC 10646, Unicode, UCS-4, MULE. @@ -32,6 +32,7 @@ (intern (format "%s@%s" feature domain)) feature)) +;;;###autoload (defun map-char-family (function char &optional ignore-sisters) (let ((rest (list char)) ret checked) @@ -70,34 +71,7 @@ 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))))) - ) + char ignore-sisters)) (defvar ideograph-radical-chars-vector @@ -173,35 +147,7 @@ (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))))) - ) + (get-char-feature-from-domains char 'ideographic-strokes domains))) ;;;###autoload (defun char-ideographic-strokes (char &optional radical preferred-domains) @@ -236,7 +182,7 @@ (let (ret) (catch 'tag (dolist (domain domains) - (if (setq ret (get-char-attribute + (if (setq ret (char-feature char (intern (format "%s@%s" @@ -246,19 +192,21 @@ ;;;###autoload (defun char-total-strokes (char &optional preferred-domains) (or (char-total-strokes-from-domains char preferred-domains) - (get-char-attribute char 'total-strokes) + (char-feature char 'total-strokes) (char-total-strokes-from-domains char char-db-feature-domains))) ;;;###autoload (defun update-ideograph-radical-table () (interactive) - (let (ret radical script dest) + (let (ret rret radical script dest) (dolist (feature (cons 'ideographic-radical - (mapcar - (lambda (domain) - (intern (format "%s@%s" 'ideographic-radical domain))) - char-db-feature-domains))) + (progn + (dolist (feature (char-attribute-list)) + (if (string-match "^ideographic-radical@[^@*]+$" + (symbol-name feature)) + (setq dest (cons feature dest)))) + dest))) (map-char-attribute (lambda (chr radical) (dolist (char (append @@ -270,7 +218,11 @@ (unless (eq (get-char-attribute pc 'ideographic-radical) radical) - (setq dest (cons pc dest)))) + (if (setq rret + (get-char-attribute + pc '<-subsumptive)) + (setq ret (append ret rret)) + (setq dest (cons pc dest))))) dest) (list chr)) (let ((rest (append @@ -360,61 +312,76 @@ ;; ((null b) t) ;; (t (< a b)))) +(defvar ideographic-radical nil) + ;;;###autoload (defun char-representative-of-daikanwa (char &optional radical - ignore-default dont-inherit) + ignore-default checked) (unless radical (setq radical ideographic-radical)) - (if (or (encode-char char 'ideograph-daikanwa 'defined-only) - (encode-char char '=daikanwa-rev2 'defined-only)) - char - (let ((m (char-feature char '=>daikanwa)) - m-m m-s pat - ;;scs sc ret - ) - (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)) - (when m - (setq pat (list m-m m-s)) - (map-char-attribute (lambda (c v) - (if (equal pat v) - c)) - 'morohashi-daikanwa)))) - (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))) - 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))))) + (if (or (null radical) + (eq (or (get-char-attribute char 'ideographic-radical) + (char-ideographic-radical char radical t)) + radical)) + (let ((ret (or (encode-char char 'ideograph-daikanwa 'defined-only) + (encode-char char '=daikanwa-rev2 'defined-only)))) + (or (and ret char) + (if (setq ret (get-char-attribute char 'morohashi-daikanwa)) + (let ((m-m (car ret)) + (m-s (nth 1 ret)) + pat) + (if (= m-s 0) + (or (decode-char '=daikanwa-rev2 m-m 'defined-only) + (decode-char 'ideograph-daikanwa m-m)) + (setq pat (list m-m m-s)) + (map-char-attribute (lambda (c v) + (if (equal pat v) + c)) + 'morohashi-daikanwa)))) + (and (setq ret (get-char-attribute char '=>daikanwa)) + (if (numberp ret) + (or (decode-char '=daikanwa-rev2 ret 'defined-only) + (decode-char 'ideograph-daikanwa ret)) + (map-char-attribute (lambda (c v) + (if (equal ret v) + char)) + 'morohashi-daikanwa))) + (unless (memq char checked) + (catch 'tag + (let ((rest + (append (get-char-attribute char '->subsumptive) + (get-char-attribute char '->denotational))) + (i 0) + sc) + (setq checked (cons char checked)) + (while rest + (setq sc (car rest)) + (if (setq ret (char-representative-of-daikanwa + sc radical t checked)) + (throw 'tag ret)) + (setq checked (cons sc checked) + rest (cdr rest) + i (1+ i))) + (setq rest (get-char-attribute char '->identical)) + (while rest + (setq sc (car rest)) + (when (setq ret (char-representative-of-daikanwa + sc radical t checked)) + (throw 'tag ret)) + (setq checked (cons sc checked) + rest (cdr rest))) + (setq rest + (append (get-char-attribute char '<-subsumptive) + (get-char-attribute char '<-denotational))) + (while rest + (setq sc (car rest)) + (when (setq ret (char-representative-of-daikanwa + sc radical t checked)) + (throw 'tag ret)) + (setq checked (cons sc checked) + rest (cdr rest)))))) + (unless ignore-default + char))))) (defun char-attributes-poly< (c1 c2 accessors testers defaulters) (catch 'tag @@ -446,8 +413,6 @@ testers (cdr testers) defaulters (cdr defaulters)))))) -(defvar ideographic-radical nil) - (defun char-daikanwa-strokes (char &optional radical) (unless radical (setq radical ideographic-radical)) @@ -468,9 +433,12 @@ radical)) (let ((ret (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 '=>daikanwa)))) + (get-char-attribute char 'morohashi-daikanwa)))) (or ret + (and (setq ret (get-char-attribute char '=>daikanwa)) + (if (numberp ret) + (list ret 0 8) + (append ret '(8)))) (unless (memq char checked) (catch 'tag (let ((rest @@ -531,28 +499,24 @@ (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) + (if (find-charset name) + (push name ccss)) (push name attributes) - ;; ) )) (setq attributes (sort attributes #'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) - ;;) + (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 )))))