;;; 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, 2008,
+;; 2009 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
(if (string-match "^ideographic-radical@[^@*]+$"
(symbol-name feature))
(setq dest (cons feature dest))))
- dest)
- ;; (mapcar
- ;; (lambda (domain)
- ;; (intern (format "%s@%s" 'ideographic-radical domain)))
- ;; char-db-feature-domains)
- ))
+ dest)))
(map-char-attribute
(lambda (chr radical)
(dolist (char (append
(if (= (car a) (car b))
(int-list< (cdr a)(cdr b))
(< (car a) (car b)))
- nil)
- (numberp (car b))))
+ (if (= (car a) 0)
+ nil
+ (< (car a) 0)))
+ (if (numberp (car b))
+ (if (= (car b) 0)
+ t
+ (< 0 (car b)))
+ )))
(defun morohashi-daikanwa< (a b)
(if (integerp a)
(setq a (list a)))
(if (integerp b)
(setq b (list b)))
- (cond ((eq (car a) 'ho)
- (if (eq (car b) 'ho)
- (int-list< (cdr a)(cdr b))
+ (cond ((eq (car-safe a) 'ho)
+ (if (eq (car-safe b) 'ho)
+ (int-list< (cdr-safe a)(cdr-safe b))
nil))
- ((numberp (car a))
+ ((or (integerp a)
+ (integerp (car a)))
(if (eq (car b) 'ho)
t
(int-list< a b)))
(t
- (if (eq (car b) 'ho)
+ (if (eq (car-safe b) 'ho)
t
(int-list< a b)))))
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
(char-ideographic-strokes char radical '(daikanwa)))
;;;###autoload
-(defun char-daikanwa (char &optional radical checked)
+(defun char-daikanwa (char &optional radical checked depth)
(unless radical
(setq radical ideographic-radical))
(if (or (null radical)
(let ((ret (or (encode-char char 'ideograph-daikanwa 'defined-only)
(encode-char char '=daikanwa-rev2 'defined-only)
(get-char-attribute char 'morohashi-daikanwa))))
- (or ret
+ (or (if ret
+ (if depth
+ (if (integerp ret)
+ (list ret depth)
+ (append ret (list depth)))
+ ret))
(and (setq ret (get-char-attribute char '=>daikanwa))
(if (numberp ret)
- (list ret 0)
- (append ret '(0))))
+ (list ret 0 8)
+ (append ret '(8))))
(unless (memq char checked)
+ (unless depth
+ (setq depth 0))
(catch 'tag
(let ((rest
(append (get-char-attribute char '->subsumptive)
(get-char-attribute char '->denotational)))
(i 0)
- sc)
+ sc lnum)
(setq checked (cons char checked))
(while rest
(setq sc (car rest))
- (if (setq ret (char-daikanwa sc radical checked))
+ (if (setq ret (char-daikanwa sc radical checked
+ (1- depth)))
(throw 'tag ret))
(setq checked (cons sc checked)
rest (cdr rest)
(setq rest (get-char-attribute char '->identical))
(while rest
(setq sc (car rest))
- (when (setq ret (char-daikanwa sc radical checked))
+ (when (setq ret (char-daikanwa sc radical checked depth))
(throw 'tag
(if (numberp ret)
(list ret 0)
(get-char-attribute char '<-denotational)))
(while rest
(setq sc (car rest))
- (when (setq ret (char-daikanwa sc radical checked))
+ (when (setq ret (char-daikanwa sc radical checked depth))
(throw 'tag
(if (numberp ret)
(list ret 0 i)
- (append ret (list i)))))
+ (if (>= (setq lnum (car (last ret))) 0)
+ (append ret (list i))
+ (nconc (butlast ret)
+ (list 0 (- lnum) i))))))
(setq checked (cons sc checked)
rest (cdr rest))))))))))
(or (encode-char char '=ucs 'defined-only)
(char-feature char '=>ucs)))
+;;;###autoload
(defun char-id (char)
(logand (char-int char) #x3FFFFFFF))
+(defun char-ideographic-strokes-diff (char &optional radical)
+ (if (or (get-char-attribute char '<-subsumptive)
+ (get-char-attribute char '<-denotational))
+ (let (s ds)
+ (when (and (setq s (char-ideographic-strokes char radical))
+ (setq ds (char-daikanwa-strokes char radical)))
+ (abs (- s ds))))
+ 0))
+
+;;;###autoload
(defun ideograph-char< (a b &optional radical)
(let ((ideographic-radical (or radical
ideographic-radical)))
(char-attributes-poly<
a b
- '(char-daikanwa-strokes char-daikanwa char-ucs char-id)
- '(< morohashi-daikanwa< < <)
- '(> > > >))))
+ '(char-daikanwa-strokes char-daikanwa char-ucs
+ char-ideographic-strokes-diff char-id)
+ '(< morohashi-daikanwa< < < <)
+ '(> > > > >))))
(defun insert-ideograph-radical-char-data (radical)
(let ((chars
(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.1 / blobdiff