;;; 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, 2010, 2012, 2014, 2015, 2016 MORIOKA Tomohiko.
;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
;; Keywords: CHISE, Chaon model, ISO/IEC 10646, Unicode, UCS-4, MULE.
;;; Code:
+(require 'chise-subr)
+(require 'ideograph-subr)
(require 'char-db-util)
+
(defvar ideograph-radical-chars-vector
(make-vector 215 nil))
-(defun char-ideographic-radical (char &optional radical)
- (let (ret)
- (or (catch 'tag
- (dolist (domain char-db-feature-domains)
- (if (and (setq ret (char-feature
- char
- (intern
- (format "%s@%s"
- 'ideographic-radical domain))))
- (or (eq ret radical)
- (null radical)))
- (throw 'tag ret))))
- (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 ret))))
- (char-feature char 'ideographic-radical)
- (progn
- (setq ret
- (or (get-char-attribute char 'daikanwa-radical)
- (get-char-attribute char 'kangxi-radical)
- (get-char-attribute char 'japanese-radical)
- (get-char-attribute char 'korean-radical)))
- (when ret
- (put-char-attribute char 'ideographic-radical ret)
- ret)))))
-
-(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-from-domains (char domains &optional radical)
- (let (ret)
- (catch 'tag
- (dolist (domain domains)
- (if (and (setq ret (or (char-feature
- char
- (intern
- (format "%s@%s"
- 'ideographic-radical domain)))
- (char-feature
- char 'ideographic-radical)))
- (or (eq ret radical)
- (null radical))
- (setq ret (char-feature
- char
- (intern
- (format "%s@%s"
- 'ideographic-strokes domain)))))
- (throw 'tag ret))))))
-
-;;;###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 preferred-domains radical)
- (get-char-attribute char 'ideographic-strokes)
- (char-ideographic-strokes-from-domains
- char char-db-feature-domains radical)
- (char-feature char 'ideographic-strokes)
- (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 (get-char-attribute
- 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)
- (get-char-attribute 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
(get-char-attribute chr '<-subsumptive))
(progn
(setq dest nil)
+ (setq ret (list ret))
(dolist (pc ret)
- (unless (get-char-attribute
- pc 'ideographic-radical)
- (setq dest (cons pc dest))))
+ (unless (eq (get-char-attribute
+ pc 'ideographic-radical)
+ radical)
+ (if (setq rret
+ (get-char-attribute
+ pc '<-subsumptive))
+ (setq ret (append ret (list rret)))
+ (setq dest (cons pc dest)))))
dest)
(list chr))
- (get-char-attribute chr '<-identical)
- (get-char-attribute chr '->denotational)))
+ (let ((rest (append
+ (get-char-attribute chr '<-identical)
+ (get-char-attribute chr '->denotational)))
+ pc)
+ (setq dest nil)
+ (while rest
+ (setq pc (car rest))
+ (if (memq pc dest)
+ (setq rest (cdr rest))
+ (setq dest (cons pc dest))
+ (setq rest
+ (append (cdr rest)
+ (get-char-attribute
+ pc '<-identical)
+ (get-char-attribute
+ pc '->denotational)))))
+ dest)))
(when (and radical
(or (eq radical
- (char-ideographic-radical char radical))
+ (or (get-char-attribute
+ char 'ideographic-radical)
+ (char-ideographic-radical char radical)))
(null (char-ideographic-radical char)))
(or (null (setq script
(get-char-attribute char 'script)))
(cons char ret))))))
'ideographic-)))
+
(defun int-list< (a b)
(if (numberp (car a))
(if (numberp (car b))
(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)))))
;; ((null b) t)
;; (t (< a b))))
+(defvar ideographic-radical nil)
+
;;;###autoload
-(defun char-representative-of-daikanwa (char &optional radical)
+(defun char-representative-of-daikanwa (char &optional radical
+ 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))))
- (when (setq scs (get-char-attribute char '->subsumptive))
- (while (and scs
- (setq sc (car scs))
- (not
- (and
- (setq ret
- (char-representative-of-daikanwa sc))
- (or (null radical)
- (eq (char-ideographic-radical ret radical)
- radical)
- (setq ret nil)))))
- (setq scs (cdr scs)))
- ret)
- 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 '=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 '=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 '=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)))
+ (when (setq sc (get-char-attribute char '<-subsumptive))
+ (if (setq ret (char-representative-of-daikanwa
+ sc radical t checked))
+ (throw 'tag ret)
+ (setq checked (cons sc checked))
+ nil))
+ (when (setq sc (get-char-attribute char '<-denotational))
+ (if (setq ret (char-representative-of-daikanwa
+ sc radical t checked))
+ (throw 'tag ret)
+ (setq checked (cons sc checked))
+ nil))
+ )))
+ (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-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)))
;;;###autoload
-(defun char-daikanwa (char &optional radical)
- (or (encode-char char 'ideograph-daikanwa 'defined-only)
- (encode-char char '=daikanwa-rev2 'defined-only)
- (get-char-attribute char 'morohashi-daikanwa)
- (let ((ret (char-feature char '=>daikanwa)))
- (and ret
- (if (or (get-char-attribute char '<-subsumptive)
- (get-char-attribute char '<-denotational))
- (list ret 0)
- ret)))
- (let ((scs (get-char-attribute char '->subsumptive))
- sc ret)
- (unless radical
- (setq radical ideographic-radical))
- (when scs
- (while (and scs
- (setq sc (car scs))
- (not
- (and
- (setq ret
- (char-representative-of-daikanwa sc))
- (or (null radical)
- (eq (char-ideographic-radical ret radical)
- radical)
- (setq ret nil)))))
- (setq scs (cdr scs))))
- (if ret
- (char-daikanwa ret)))))
+(defun char-daikanwa (char &optional radical checked depth)
+ (unless radical
+ (setq radical ideographic-radical))
+ (if (or (null radical)
+ (eq (or (get-char-attribute char 'ideographic-radical)
+ (char-daikanwa-radical char radical t))
+ radical))
+ (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)
+ (list ret depth)
+ (append ret (list depth)))
+ ret))
+ (and (setq ret (get-char-attribute char '=>daikanwa))
+ (if (numberp ret)
+ (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)
+ (get-char-attribute char '->denotational@component)
+ ))
+ (i 0)
+ sc lnum)
+ (setq checked (cons char checked))
+ (while rest
+ (setq sc (car rest))
+ (if (setq ret (char-daikanwa sc radical checked
+ (1- depth)))
+ (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-daikanwa sc radical checked depth))
+ (throw 'tag
+ (if (numberp ret)
+ (list ret 0)
+ (append ret (list i)))))
+ (setq checked (cons sc checked)
+ rest (cdr rest)))
+ (setq rest
+ (append
+ (if (setq ret (get-char-attribute
+ char '<-subsumptive))
+ (list ret))
+ (if (setq ret (get-char-attribute
+ char '<-denotational))
+ (list ret))
+ (get-char-attribute char '<-denotational@component)
+ ))
+ (while rest
+ (setq sc (car rest))
+ (when (setq ret (char-daikanwa sc radical checked depth))
+ (throw 'tag
+ (if (numberp ret)
+ (list ret 0 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))))))))))
+
+(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 char-ucs (char)
- (or (encode-char char '=ucs 'defined-only)
- (char-feature char '=>ucs)))
-
-(defun char-id (char)
- (logand (char-int char) #x3FFFFFFF))
-
(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
(defun write-ideograph-radical-char-data (radical file)
(if (file-directory-p file)
- (let ((name (get-char-attribute (int-char (+ #x2EFF radical)) 'name)))
+ (let ((name (char-feature (decode-char 'ucs (+ #x2EFF radical))
+ 'name)))
(if (string-match "KANGXI RADICAL " name)
(setq name (capitalize (substring name (match-end 0)))))
(setq name (mapconcat (lambda (char)
(format "Ideograph-R%03d-%s.el" radical name)
file))))
(with-temp-buffer
- (insert ";; -*- coding: utf-8-mcs -*-\n")
+ (insert (format ";; -*- coding: %s -*-\n"
+ char-db-file-coding-system))
(insert-ideograph-radical-char-data radical)
- (let ((coding-system-for-write 'utf-8-mcs))
- (write-region (point-min)(point-max) file)
- )))
+ (let ((coding-system-for-write char-db-file-coding-system))
+ (write-region (point-min)(point-max) file))))
(defun ideographic-structure= (char1 char2)
(if (char-ref-p char1)
char)))
'ideographic-structure)))
-;;;###autoload
-(defun chise-string< (string1 string2 accessors)
- (let ((len1 (length string1))
- (len2 (length string2))
- len
- (i 0)
- c1 c2
- rest func
- v1 v2)
- (setq len (min len1 len2))
- (catch 'tag
- (while (< i len)
- (setq c1 (aref string1 i)
- c2 (aref string2 i))
- (setq rest accessors)
- (while (and rest
- (setq func (car rest))
- (setq v1 (funcall func c1)
- v2 (funcall func c2))
- (eq v1 v2))
- (setq rest (cdr rest)))
- (if v1
- (if v2
- (cond ((< v1 v2)
- (throw 'tag t))
- ((> v1 v2)
- (throw 'tag nil)))
- (throw 'tag nil))
- (if v2
- (throw 'tag t)))
- (setq i (1+ i)))
- (< len1 len2))))
-
(provide 'ideograph-util)