X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Futf-2000%2Fideograph-util.el;h=8c59833f03d81def7fbebfaaef347cf615ae53c3;hb=a7101749196aa721b543fbf4544baeda56e51fc9;hp=095a0183b7266a8fa0b8805e3173987611328120;hpb=0548c338357c879085d4e2eef1930c6f39a3256f;p=chise%2Fxemacs-chise.git.1 diff --git a/lisp/utf-2000/ideograph-util.el b/lisp/utf-2000/ideograph-util.el index 095a018..8c59833 100644 --- a/lisp/utf-2000/ideograph-util.el +++ b/lisp/utf-2000/ideograph-util.el @@ -1,7 +1,7 @@ ;;; 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 MORIOKA Tomohiko. ;; Author: MORIOKA Tomohiko ;; Keywords: CHISE, Chaon model, ISO/IEC 10646, Unicode, UCS-4, MULE. @@ -33,85 +33,6 @@ (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-from-domains (char domains &optional radical) - (if radical - (get-char-feature-from-domains char 'ideographic-strokes domains - 'ideographic-radical radical) - (get-char-feature-from-domains char 'ideographic-strokes domains))) - -;;;###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 () @@ -193,6 +114,7 @@ (cons char ret)))))) 'ideographic-))) + (defun int-list< (a b) (if (numberp (car a)) (if (numberp (car b)) @@ -248,25 +170,35 @@ (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)) @@ -343,8 +275,9 @@ (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))) @@ -356,9 +289,17 @@ (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 '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) @@ -367,8 +308,8 @@ 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))