X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Futf-2000%2Fideograph-util.el;h=c00d5bff51a7751c4a2881a7a2b9062e1874174b;hb=fbffe7af9ce38f36944579ed848f3e2d027f1b81;hp=2b880e46189deae732ca3e80bb7f2d26418bd29f;hpb=a739c12c974209f70555393efc67e3b626f0270e;p=chise%2Fxemacs-chise.git.1 diff --git a/lisp/utf-2000/ideograph-util.el b/lisp/utf-2000/ideograph-util.el index 2b880e4..c00d5bf 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 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 @@ -430,61 +382,6 @@ rest (cdr rest)))))) (unless ignore-default char))))) -;; (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) -;; (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 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