;;; 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 <tomo@kanji.zinbun.kyoto-u.ac.jp>
;; Keywords: CHISE, Chaon model, ISO/IEC 10646, Unicode, UCS-4, MULE.
(intern (format "%s@%s" feature domain))
feature))
+;;;###autoload
(defun map-char-family (function char &optional ignore-sisters)
(let ((rest (list char))
ret checked)
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
(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)
(let (ret)
(catch 'tag
(dolist (domain domains)
- (if (setq ret (get-char-attribute
+ (if (setq ret (char-feature
char
(intern
(format "%s@%s"
;;;###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
(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
;; ((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
testers (cdr testers)
defaulters (cdr defaulters))))))
-(defvar ideographic-radical nil)
-
(defun char-daikanwa-strokes (char &optional radical)
(unless radical
(setq radical ideographic-radical))
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
(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
)))))
projects / chise / xemacs-chise.git / blobdiff