;;; ideograph-util.el --- Ideographic Character Database utility
;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008,
-;; 2009, 2010 MORIOKA Tomohiko.
+;; 2009, 2010, 2012, 2014, 2015 MORIOKA Tomohiko.
;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
;; Keywords: CHISE, Chaon model, ISO/IEC 10646, Unicode, UCS-4, MULE.
(defvar ideograph-radical-chars-vector
(make-vector 215 nil))
-(defvar ideograph-radical-strokes-vector
- ;;0 1 2 3 4 5 6 7 8 9
- [nil 1 1 1 1 1 1 2 2 2
- 2 2 2 2 2 2 2 2 2 2
- 2 2 2 2 2 2 2 2 2 2
- 3 3 3 3 3 3 3 3 3 3
- 3 3 3 3 3 3 3 3 3 3
- 3 3 3 3 3 3 3 3 3 3
- 3 4 4 4 3 4 4 4 4 4
- 4 4 4 4 4 4 4 4 4 4
- 4 4 4 4 4 3 4 4 4 4
- 4 4 4 4 3 5 4 5 5 5
- ;; 100
- 5 5 5 5 5 5 5 5 5 5
- 5 5 5 5 5 5 5 5 6 6
- 6 6 6 6 6 6 6 6 6 6
- 4 6 6 6 6 6 6 6 6 6
- 4 6 6 6 6 6 6 7 7 7
- 7 7 7 7 7 7 7 7 7 7
- 7 7 4 3 7 7 7 8 7 8
- 3 8 8 8 8 8 9 9 9 9
- 9 9 9 9 8 9 9 10 10 10
- 10 10 10 10 10 11 11 11 11 11
- ;; 200
- 11 12 12 12 12 13 13 13 13 14
- 14 15 16 16 17])
-
-;;;###autoload
-(defun char-ideographic-strokes (char &optional radical preferred-domains)
- (let (ret)
- (or (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 (plist-get cell :strokes)))))
- (char-ideographic-strokes-from-domains
- 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)
- (get-char-attribute char 'japanese-strokes)
- (get-char-attribute char 'korean-strokes)
- (let ((r (char-ideographic-radical char))
- (ts (get-char-attribute char 'total-strokes)))
- (if (and r ts)
- (- ts (aref ideograph-radical-strokes-vector r))))
- )))
- (when strokes
- (put-char-attribute char 'ideographic-strokes strokes)
- strokes)))))
-
-;;;###autoload
-(defun char-total-strokes-from-domains (char domains)
- (let (ret)
- (catch 'tag
- (dolist (domain domains)
- (if (setq ret (char-feature
- char
- (intern
- (format "%s@%s"
- 'total-strokes domain))))
- (throw 'tag ret))))))
-
-;;;###autoload
-(defun char-total-strokes (char &optional preferred-domains)
- (or (char-total-strokes-from-domains char preferred-domains)
- (char-feature char 'total-strokes)
- (char-total-strokes-from-domains char char-db-feature-domains)))
;;;###autoload
(defun update-ideograph-radical-table ()
(cons char ret))))))
'ideographic-)))
+
(defun int-list< (a b)
(if (numberp (car a))
(if (numberp (car b))
(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))))
+ (let ((ret (or (encode-char char '=daikanwa@rev2 'defined-only)
+ (encode-char char '=daikanwa/+p 'defined-only)
+ (encode-char char '=daikanwa/+2p 'defined-only)
+ (encode-char char '=daikanwa/ho '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))))
+ (or (decode-char '=daikanwa@rev2 m-m 'defined-only)
+ (decode-char '=daikanwa m-m))
+ (or (cond ((eq m-m 'ho)
+ (decode-char '=daikanwa/ho m-s))
+ ((eq m-s 1)
+ (decode-char '=daikanwa/+p m-m))
+ ((eq m-s 2)
+ (decode-char '=daikanwa/+2p m-m)))
+ (progn
+ (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))
+ (or (decode-char '=daikanwa@rev2 ret 'defined-only)
+ (decode-char '=daikanwa ret))
(map-char-attribute (lambda (c v)
(if (equal ret v)
char))
testers (cdr testers)
defaulters (cdr defaulters))))))
+(defun char-daikanwa-radical (char &optional radical ignore-sisters)
+ (or (and (encode-char char '=daikanwa@rev2 'defined-only)
+ (or (get-char-attribute char 'ideographic-radical@daikanwa)
+ (get-char-attribute char 'ideographic-radical)))
+ (char-ideographic-radical char radical ignore-sisters)))
+
(defun char-daikanwa-strokes (char &optional radical)
(unless radical
(setq radical ideographic-radical))
(let ((drc (char-representative-of-daikanwa char radical))
(r (char-ideographic-radical char radical)))
- (if (or (null r)
- (= (char-ideographic-radical drc radical) r))
+ (if (and drc
+ (or (null r)
+ (= (char-ideographic-radical drc radical) r)))
(setq char drc)))
(char-ideographic-strokes char radical '(daikanwa)))
(setq radical ideographic-radical))
(if (or (null radical)
(eq (or (get-char-attribute char 'ideographic-radical)
- (char-ideographic-radical char radical t))
+ (char-daikanwa-radical char radical t))
radical))
- (let ((ret (or (encode-char char 'ideograph-daikanwa 'defined-only)
- (encode-char char '=daikanwa-rev2 'defined-only)
+ (let ((ret (or (encode-char char '=daikanwa@rev2 'defined-only)
+ ;; (encode-char char '=daikanwa 'defined-only)
(get-char-attribute char 'morohashi-daikanwa))))
+ (unless ret
+ (cond
+ ((setq ret (encode-char char '=daikanwa/+p 'defined-only))
+ (setq ret (list ret 1)))
+ ((setq ret (encode-char char '=daikanwa/+2p 'defined-only))
+ (setq ret (list ret 2)))
+ ((setq ret (encode-char char '=daikanwa/ho 'defined-only))
+ (setq ret (list 'ho ret)))))
(or (if ret
(if depth
(if (integerp ret)
ret))
(and (setq ret (get-char-attribute char '=>daikanwa))
(if (numberp ret)
- (list ret 0 8)
- (append ret '(8))))
+ (list ret -10)
+ (append ret '(-10))))
(unless (memq char checked)
(unless depth
(setq depth 0))
(catch 'tag
(let ((rest
- (append (get-char-attribute char '->subsumptive)
- (get-char-attribute char '->denotational)))
+ (append
+ (get-char-attribute char '->subsumptive)
+ (get-char-attribute char '->denotational)
+ (get-char-attribute char '->denotational@component)
+ ))
(i 0)
sc lnum)
(setq checked (cons char checked))
(setq checked (cons sc checked)
rest (cdr rest)))
(setq rest
- (append (get-char-attribute char '<-subsumptive)
- (get-char-attribute char '<-denotational)))
+ (append
+ (get-char-attribute char '<-subsumptive)
+ (get-char-attribute char '<-denotational)
+ (get-char-attribute char '<-denotational@component)
+ ))
(while rest
(setq sc (car rest))
(when (setq ret (char-daikanwa sc radical checked depth))
projects / chise / xemacs-chise.git.1 / blobdiff