X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Futf-2000%2Fchar-db-util.el;h=b0d07b7a1d4c0d9b75f92bc1ccbd39ab5f0b3a15;hb=b5ebdf2c6a17025483ceff54d9d893e4ffe88a5d;hp=78bc6547565e77a654ec7e065a3dd95a4c3724cd;hpb=026445a5fcb93ce75d78c2d7af98f14ae3359842;p=chise%2Fxemacs-chise.git diff --git a/lisp/utf-2000/char-db-util.el b/lisp/utf-2000/char-db-util.el index 78bc654..b0d07b7 100644 --- a/lisp/utf-2000/char-db-util.el +++ b/lisp/utf-2000/char-db-util.el @@ -119,9 +119,10 @@ (defun char-db-insert-char-spec (char &optional readable column) (unless column (setq column (current-column))) - (let (char-spec ret al cal key) + (let (char-spec ret al cal key temp-char) (cond ((characterp char) - (cond ((setq ret (get-char-attribute char 'ucs)) + (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))) @@ -129,8 +130,9 @@ ((setq ret (split-char char)) (setq char-spec (list ret)) (dolist (ccs (delq (car ret) (charset-list))) - (if (and (>= (charset-iso-final-char ccs) ?0) - (setq ret (get-char-attribute char ccs))) + (if (or (and (>= (charset-iso-final-char ccs) ?0) + (setq ret (get-char-attribute char ccs))) + (eq ccs 'ideograph-daikanwa)) (setq char-spec (cons (cons ccs ret) char-spec)))) (if (setq ret (get-char-attribute char 'name)) (setq char-spec (cons (cons 'name ret) char-spec))) @@ -138,23 +140,34 @@ ((consp char) (setq char-spec char) (setq char nil))) - (if (or char - (setq char (condition-case nil - (define-char char-spec) - (error nil)))) - (progn - (setq al nil - cal nil) - (while char-spec - (setq key (car (car char-spec))) - (if (find-charset key) - (setq cal (cons key cal)) - (setq al (cons key al))) - (setq char-spec (cdr char-spec))) - (insert-char-attributes char - readable - (or al 'none) cal)) - (insert (prin1-to-string char-spec))))) + (unless (or char + (condition-case nil + (setq char (find-char char-spec)) + (error nil))) + ;; define temporary character + ;; Current implementation is dirty. + (setq temp-char (define-char (cons '(ideograph-daikanwa . 0) + char-spec))) + (remove-char-attribute temp-char 'ideograph-daikanwa) + (setq char temp-char)) + (setq al nil + cal nil) + (while char-spec + (setq key (car (car char-spec))) + (if (find-charset key) + (setq cal (cons key cal)) + (setq al (cons key al))) + (setq char-spec (cdr char-spec))) + (insert-char-attributes char + readable + (or al 'none) cal) + (when temp-char + ;; undefine temporary character + ;; Current implementation is dirty. + (setq char-spec (char-attribute-alist temp-char)) + (while char-spec + (remove-char-attribute temp-char (car (car char-spec))) + (setq char-spec (cdr char-spec)))))) (defun char-db-insert-alist (alist &optional readable column) (unless column @@ -171,7 +184,7 @@ (cond ((eq name 'char) (insert "(char . ") (if (setq ret (condition-case nil - (define-char value) + (find-char value) (error nil))) (progn (setq al nil @@ -196,7 +209,7 @@ (if (and (consp cell) (consp (car cell)) (setq ret (condition-case nil - (define-char cell) + (find-char cell) (error nil))) ) (progn @@ -241,6 +254,12 @@ (setq value (pop plist)) (cond ((eq name :char) (insert ":char\t") + (cond ((numberp value) + (setq value (decode-char 'ucs value))) + ;; ((consp value) + ;; (setq value (or (find-char value) + ;; value))) + ) (char-db-insert-char-spec value readable) (insert line-breaking)) (t @@ -253,21 +272,24 @@ (defun char-db-decode-isolated-char (ccs code-point) (let (ret) (setq ret - (if (and (memq ccs '(ideograph-gt-pj-1 - ideograph-gt-pj-2 - ideograph-gt-pj-3 - ideograph-gt-pj-4 - ideograph-gt-pj-5 - ideograph-gt-pj-6 - ideograph-gt-pj-7 - ideograph-gt-pj-8 - ideograph-gt-pj-9 - ideograph-gt-pj-10 - ideograph-gt-pj-11)) - (setq ret (decode-char ccs code-point)) - (setq ret (get-char-attribute ret 'ideograph-gt))) - (decode-builtin-char 'ideograph-gt ret) - (decode-builtin-char ccs code-point))) + (cond ((eq ccs 'arabic-iso8859-6) + (decode-char ccs code-point)) + ((and (memq ccs '(ideograph-gt-pj-1 + ideograph-gt-pj-2 + ideograph-gt-pj-3 + ideograph-gt-pj-4 + ideograph-gt-pj-5 + ideograph-gt-pj-6 + ideograph-gt-pj-7 + ideograph-gt-pj-8 + ideograph-gt-pj-9 + ideograph-gt-pj-10 + ideograph-gt-pj-11)) + (setq ret (decode-char ccs code-point)) + (setq ret (get-char-attribute ret 'ideograph-gt))) + (decode-builtin-char 'ideograph-gt ret)) + (t + (decode-builtin-char ccs code-point)))) (cond ((and (<= 0 (char-int ret)) (<= (char-int ret) #x1F)) (decode-char 'ucs (+ #x2400 (char-int ret)))) @@ -303,7 +325,7 @@ (when (and (memq 'name attributes) (setq value (get-char-attribute char 'name))) (insert (format - (if (> (length value) 47) + (if (> (+ (current-column) (length value)) 48) "(name . %S)%s" "(name . %S)%s") value line-breaking)) @@ -581,9 +603,16 @@ ->fullwidth <-fullwidth ->vulgar-ideograph <-vulgar-ideograph ->ancient-ideograph <-ancient-ideograph + ->original-ideograph <-original-ideograph ->simplified-ideograph <-simplified-ideograph + ->wrong-ideograph <-wrong-ideograph ->same-ideograph - ->bopomofo)) + ->ideographic-variants + ->synonyms + ->radical <-radical + ->bopomofo <-bopomofo + ->ideographic <-ideographic + ideographic-structure)) (insert (format "(%-18s%s " name line-breaking)) (setq lbs (concat "\n" (make-string (current-column) ?\ )) separator nil) @@ -661,7 +690,7 @@ (if (and (consp cell) (consp (car cell)) (setq ret (condition-case nil - (define-char cell) + (find-char cell) (error nil)))) (progn (setq rest cell @@ -790,6 +819,7 @@ (if ucs (delete char (char-variants (int-char ucs))))))) variant vs) + (setq variants (sort variants #'<)) (while variants (setq variant (car variants)) (if (and (or (null script)