X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Futf-2000%2Fchar-db-util.el;h=78887c18168e03695df05665dc4f0f7e816dd40b;hb=4643476dfb003afee0c8c95ee0401dcea8ebf6d6;hp=9ac1fdf2e935ffc6758348cf3e6a02c7ec120302;hpb=544dce950fba3d56a0d2ce7d6ffd80ca1225694d;p=chise%2Fxemacs-chise.git diff --git a/lisp/utf-2000/char-db-util.el b/lisp/utf-2000/char-db-util.el index 9ac1fdf..78887c1 100644 --- a/lisp/utf-2000/char-db-util.el +++ b/lisp/utf-2000/char-db-util.el @@ -71,10 +71,7 @@ (aset v 34 (make-char 'chinese-gb2312 #x62 #x3A))) v)) -;;;###autoload -(defun char-ref-p (obj) - (and (consp obj) - (keywordp (car obj)))) +(defvar char-db-ignored-attributes nil) ;;;###autoload (defun char-ref= (cr1 cr2) @@ -170,10 +167,8 @@ (append (sort dest #'char-attribute-name<) '(chinese-big5-cdp chinese-big5-eten chinese-big5)))) -(defun char-db-insert-char-spec (char &optional readable column) - (unless column - (setq column (current-column))) - (let (char-spec ret al cal key temp-char) +(defun char-db-make-char-spec (char) + (let (ret char-spec) (cond ((characterp char) (cond ((and (setq ret (get-char-attribute char 'ucs)) (not (and (<= #xE000 ret)(<= ret #xF8FF)))) @@ -195,11 +190,42 @@ (setq char-spec (split-char char))) (if (setq ret (get-char-attribute char 'name)) (setq char-spec (cons (cons 'name ret) char-spec))) - ))) + )) + char-spec) ((consp char) - (setq char-spec char) - (setq char nil))) - (unless (or char + char)))) + +(defun char-db-insert-char-spec (char &optional readable column) + (unless column + (setq column (current-column))) + (let (char-spec ret al cal key temp-char) + (setq char-spec (char-db-make-char-spec char)) + ;; (cond ((characterp char) + ;; (cond ((and (setq ret (get-char-attribute char 'ucs)) + ;; (not (and (<= #xE000 ret)(<= ret #xF8FF)))) + ;; (setq char-spec (list (cons 'ucs ret))) + ;; (if (setq ret (get-char-attribute char 'name)) + ;; (setq char-spec (cons (cons 'name ret) char-spec))) + ;; ) + ;; ((setq ret + ;; (let ((default-coded-charset-priority-list + ;; char-db-coded-charset-priority-list)) + ;; (split-char char))) + ;; (setq char-spec (list ret)) + ;; (dolist (ccs (delq (car ret) (charset-list))) + ;; (if (or (and (charset-iso-final-char ccs) + ;; (setq ret (get-char-attribute char ccs))) + ;; (eq ccs 'ideograph-daikanwa)) + ;; (setq char-spec (cons (cons ccs ret) char-spec)))) + ;; (if (null char-spec) + ;; (setq char-spec (split-char char))) + ;; (if (setq ret (get-char-attribute char 'name)) + ;; (setq char-spec (cons (cons 'name ret) char-spec))) + ;; ))) + ;; ((consp char) + ;; (setq char-spec char) + ;; (setq char nil))) + (unless (or (characterp char) ; char (condition-case nil (setq char (find-char char-spec)) (error nil))) @@ -215,9 +241,20 @@ (setq key (car (car char-spec))) (unless (memq key char-db-ignored-attributes) (if (find-charset key) - (setq cal (cons key cal)) + (if (get-char-attribute char key) + (setq cal (cons key cal))) (setq al (cons key al)))) (setq char-spec (cdr char-spec))) + (unless cal + (setq char-spec (char-db-make-char-spec char)) + (while char-spec + (setq key (car (car char-spec))) + (unless (memq key char-db-ignored-attributes) + (if (find-charset key) + (setq cal (cons key cal)) + (setq al (cons key al)))) + (setq char-spec (cdr char-spec))) + ) (unless (or cal (memq 'ideographic-structure al)) (push 'ideographic-structure al)) @@ -310,12 +347,14 @@ (setq column (current-column))) (let ((line-breaking (concat "\n" (make-string (1+ column) ?\ ))) + (separator "") name value) (insert "(") (while plist (setq name (pop plist)) (setq value (pop plist)) (cond ((eq name :char) + (insert separator) (insert ":char\t") (cond ((numberp value) (setq value (decode-char 'ucs value))) @@ -324,11 +363,18 @@ ;; value))) ) (char-db-insert-char-spec value readable) - (insert line-breaking)) - (t - (insert (format "%s\t%S%s" + (insert line-breaking) + (setq separator "")) + ((eq name :radical) + (insert (format "%s%s\t%d ; %c%s" + separator name value - line-breaking)))) + (aref ideographic-radicals value) + line-breaking)) + (setq separator "")) + (t + (insert (format "%s%s\t%S" separator name value)) + (setq separator line-breaking))) )) (insert ")")) @@ -362,8 +408,6 @@ (defvar char-db-convert-obsolete-format t) -(defvar char-db-ignored-attributes nil) - (defun insert-char-attributes (char &optional readable attributes ccs-attributes column) @@ -633,6 +677,38 @@ (setq radical value))) (setq attributes (delq 'shinjigen-1-radical attributes)) ) + (when (and (memq 'ideographic- attributes) + (setq value (get-char-attribute char 'ideographic-))) + (insert "(ideographic- ") + (setq lbs (concat "\n" (make-string (current-column) ?\ )) + separator nil) + (while (consp value) + (setq cell (car value)) + (if (integerp cell) + (setq cell (decode-char 'ucs cell))) + (cond ((characterp cell) + (if separator + (insert lbs)) + (if readable + (insert (format "%S" cell)) + (char-db-insert-char-spec cell readable)) + (setq separator lbs)) + ((consp cell) + (if separator + (insert lbs)) + (if (consp (car cell)) + (char-db-insert-char-spec cell readable) + (char-db-insert-char-reference cell readable)) + (setq separator lbs)) + (t + (if separator + (insert separator)) + (insert (prin1-to-string cell)) + (setq separator " "))) + (setq value (cdr value))) + (insert ")") + (insert line-breaking) + (setq attributes (delq 'ideographic- attributes))) (when (and (memq 'total-strokes attributes) (setq value (get-char-attribute char 'total-strokes))) (insert (format "(total-strokes . %S)%s" @@ -722,22 +798,9 @@ (insert (format "(%-18s . #x%04X)%s" name value line-breaking))) - ((memq name '(->lowercase - ->uppercase ->titlecase - ->fullwidth <-fullwidth - ->identical - ->vulgar-ideograph <-vulgar-ideograph - ->ancient-ideograph <-ancient-ideograph - ->original-ideograph <-original-ideograph - ->simplified-ideograph <-simplified-ideograph - ->wrong-ideograph <-wrong-ideograph - ->same-ideograph - ->ideographic-variants - ->synonyms - ->radical <-radical - ->bopomofo <-bopomofo - ->ideographic <-ideographic - ideographic-structure)) + ((or (eq name 'ideographic-structure) + (eq name 'ideographic-) + (string-match "^\\(->\\|<-\\)" (symbol-name name))) (insert (format "(%-18s%s " name line-breaking)) (setq lbs (concat "\n" (make-string (current-column) ?\ )) separator nil) @@ -748,7 +811,9 @@ (cond ((characterp cell) (if separator (insert lbs)) - (char-db-insert-char-spec cell readable) + (if readable + (insert (format "%S" cell)) + (char-db-insert-char-spec cell readable)) (setq separator lbs)) ((consp cell) (if separator @@ -792,20 +857,20 @@ (setq value (cdr value))) (insert ")") (insert line-breaking)) - ((string-match "^->" (symbol-name name)) - (insert - (format "(%-18s %s)%s" - name - (mapconcat (lambda (code) - (cond ((symbolp code) - (symbol-name code)) - ((integerp code) - (format "#x%04X" code)) - (t - (format "%s%S" - line-breaking code)))) - value " ") - line-breaking))) + ;; ((string-match "^->" (symbol-name name)) + ;; (insert + ;; (format "(%-18s %s)%s" + ;; name + ;; (mapconcat (lambda (code) + ;; (cond ((symbolp code) + ;; (symbol-name code)) + ;; ((integerp code) + ;; (format "#x%04X" code)) + ;; (t + ;; (format "%s%S" + ;; line-breaking code)))) + ;; value " ") + ;; line-breaking))) ((consp value) (insert (format "(%-18s " name)) (setq lbs (concat "\n" (make-string (current-column) ?\ ))