X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Futf-2000%2Fchar-db-util.el;h=aacb226f1a7fc6f32cddff9804077fdc3d6f6cdd;hb=6f8a91966f78f32c2150f434d378f7ac4d858bc0;hp=e7393e51a0abd1d1bffad824522e48512a58ed16;hpb=6fd920e7e59cb470495d05e098b4189602b4ac65;p=chise%2Fxemacs-chise.git diff --git a/lisp/utf-2000/char-db-util.el b/lisp/utf-2000/char-db-util.el index e7393e5..aacb226 100644 --- a/lisp/utf-2000/char-db-util.el +++ b/lisp/utf-2000/char-db-util.el @@ -1,26 +1,26 @@ ;;; char-db-util.el --- Character Database utility -;; Copyright (C) 1998,1999,2000,2001 MORIOKA Tomohiko. +;; Copyright (C) 1998,1999,2000,2001,2002,2003 MORIOKA Tomohiko. ;; Author: MORIOKA Tomohiko ;; Keywords: UTF-2000, ISO/IEC 10646, Unicode, UCS-4, MULE. -;; This file is part of UTF-2000. +;; This file is part of XEmacs UTF-2000. -;; UTF-2000 is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. +;; XEmacs UTF-2000 is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. -;; UTF-2000 is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; XEmacs UTF-2000 is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with XEmacs; see the file COPYING. If not, write to the Free -;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -;; 02111-1307, USA. +;; along with XEmacs UTF-2000; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Code: @@ -65,12 +65,35 @@ (let ((v (make-vector 215 nil)) (i 1)) (while (< i 215) - (aset v i (int-char (+ #x2EFF i))) + (aset v i (decode-char '=ucs (+ #x2EFF i))) (setq i (1+ i))) - (if (< (charset-iso-final-char (car (split-char (aref v 34)))) ?0) - (aset v 34 (make-char 'chinese-gb2312 #x62 #x3A))) v)) +(defvar char-db-ignored-attributes nil) + +;;;###autoload +(defun char-ref= (cr1 cr2) + (cond ((char-ref-p cr1) + (if (char-ref-p cr2) + (char-spec= (plist-get cr1 :char) + (plist-get cr2 :char)) + (char-spec= (plist-get cr1 :char) cr2))) + (t + (char-spec= cr1 + (if (char-ref-p cr2) + (plist-get cr2 :char) + cr2))))) + +;;;###autoload +(defun char-spec= (cs1 cs2) + (if (characterp cs1) + (if (characterp cs2) + (eq cs1 cs2) + (eq cs1 (find-char cs2))) + (if (characterp cs2) + (eq (find-char cs1) cs2) + (eq (find-char cs1) (find-char cs2))))) + (defun char-attribute-name< (ka kb) (cond ((find-charset ka) @@ -80,20 +103,24 @@ ((= (charset-dimension ka) (charset-dimension kb)) (cond ((= (charset-chars ka)(charset-chars kb)) - (cond - ((>= (charset-iso-final-char ka) ?@) - (if (>= (charset-iso-final-char kb) ?@) - (< (charset-iso-final-char ka) - (charset-iso-final-char kb)) - t)) - ((>= (charset-iso-final-char ka) ?0) - (cond - ((>= (charset-iso-final-char kb) ?@) - nil) - ((>= (charset-iso-final-char kb) ?0) - (< (charset-iso-final-char ka) - (charset-iso-final-char kb))) - (t))))) + (if (charset-iso-final-char ka) + (cond + ((>= (charset-iso-final-char ka) ?@) + (if (and (charset-iso-final-char kb) + (>= (charset-iso-final-char kb) ?@)) + (< (charset-iso-final-char ka) + (charset-iso-final-char kb)) + t)) + (t + (if (charset-iso-final-char kb) + (if (>= (charset-iso-final-char kb) ?@) + nil + (< (charset-iso-final-char ka) + (charset-iso-final-char kb))) + t))) + (if (charset-iso-final-char kb) + nil + (< (charset-id ka)(charset-id kb))))) ((<= (charset-chars ka)(charset-chars kb))))) (t (< (charset-dimension ka) @@ -113,6 +140,156 @@ ((symbolp kb) nil))) +(defvar char-db-coded-charset-priority-list + '(ascii + control-1 + latin-iso8859-1 + latin-iso8859-2 + latin-iso8859-3 + latin-iso8859-4 + latin-iso8859-9 + latin-jisx0201 + cyrillic-iso8859-5 + greek-iso8859-7 + thai-tis620 + =jis-x0208 + japanese-jisx0208 + japanese-jisx0212 + japanese-jisx0208-1978 + chinese-gb2312 + chinese-cns11643-1 + chinese-cns11643-2 + chinese-cns11643-3 + chinese-cns11643-4 + chinese-cns11643-5 + chinese-cns11643-6 + chinese-cns11643-7 + =jis-x0213-1-2000 + =jis-x0213-2-2000 + korean-ksc5601 + chinese-isoir165 + katakana-jisx0201 + hebrew-iso8859-8 + =jis-x0208-1990 + chinese-gb12345 + latin-viscii + ethiopic-ucs + =gt + =big5-cdp + =gt-k + ideograph-daikanwa-2 + ideograph-daikanwa + =cbeta + ideograph-hanziku-1 + ideograph-hanziku-2 + ideograph-hanziku-3 + ideograph-hanziku-4 + ideograph-hanziku-5 + ideograph-hanziku-6 + ideograph-hanziku-7 + ideograph-hanziku-8 + ideograph-hanziku-9 + ideograph-hanziku-10 + ideograph-hanziku-11 + ideograph-hanziku-12 + =cbeta + =jef-china3 + =big5-eten + =big5)) + +(defun char-db-make-char-spec (char) + (let (ret char-spec) + (cond ((characterp char) + (cond ((and (setq ret (encode-char char '=ucs 'defined-only)) + (not (and (<= #xE000 ret)(<= ret #xF8FF)))) + (setq char-spec (list (cons '=ucs ret))) + (cond ((setq ret (get-char-attribute char 'name)) + (setq char-spec (cons (cons 'name ret) char-spec)) + ) + ((setq ret (get-char-attribute char 'name*)) + (setq char-spec (cons (cons 'name* ret) char-spec)) + )) + ) + ((setq ret + (catch 'tag + (let ((rest char-db-coded-charset-priority-list)) + (while rest + (if (setq ret + (get-char-attribute char (car rest))) + (throw 'tag (cons (car rest) ret))) + (setq rest (cdr rest)))))) + (setq char-spec (list ret)) + (dolist (ccs (delq (car ret) (charset-list))) + (if (and (or (charset-iso-final-char ccs) + (memq ccs + '(ideograph-daikanwa + =daikanwa-rev2 + ;; =gt-k + ))) + (setq ret (get-char-attribute char ccs))) + (setq char-spec (cons (cons ccs ret) char-spec)))) + (if (null char-spec) + (setq char-spec (split-char char))) + (cond ((setq ret (get-char-attribute char 'name)) + (setq char-spec (cons (cons 'name ret) char-spec)) + ) + ((setq ret (get-char-attribute char 'name*)) + (setq char-spec (cons (cons 'name* ret) char-spec)) + )) + )) + char-spec) + ((consp 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)) + (unless (or (characterp char) ; 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))) + (unless (memq key char-db-ignored-attributes) + (if (find-charset key) + (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)) + (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 (setq column (current-column))) @@ -128,7 +305,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 @@ -153,7 +330,7 @@ (if (and (consp cell) (consp (car cell)) (setq ret (condition-case nil - (define-char cell) + (find-char cell) (error nil))) ) (progn @@ -186,18 +363,106 @@ (setq alist (cdr alist)))) (insert ")")) +(defun char-db-insert-char-reference (plist &optional readable column) + (unless column + (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))) + ;; ((consp value) + ;; (setq value (or (find-char value) + ;; value))) + ) + (char-db-insert-char-spec value readable) + (insert line-breaking) + (setq separator "")) + ((eq name :radical) + (insert (format "%s%s\t%d ; %c%s" + separator + name value + (aref ideographic-radicals value) + line-breaking)) + (setq separator "")) + (t + (insert (format "%s%s\t%S" separator name value)) + (setq separator line-breaking))) + )) + (insert ")")) + +(defun char-db-decode-isolated-char (ccs code-point) + (let (ret) + (setq ret + (cond ((eq ccs 'arabic-iso8859-6) + (decode-char ccs code-point)) + ((and (memq ccs '(=gt-pj-1 + =gt-pj-2 + =gt-pj-3 + =gt-pj-4 + =gt-pj-5 + =gt-pj-6 + =gt-pj-7 + =gt-pj-8 + =gt-pj-9 + =gt-pj-10 + =gt-pj-11)) + (setq ret (decode-char ccs code-point)) + (setq ret (get-char-attribute ret '=gt))) + (decode-builtin-char '=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)))) + ((= (char-int ret) #x7F) + ?\u2421) + (t ret)))) + +(defvar char-db-convert-obsolete-format t) + (defun insert-char-attributes (char &optional readable attributes ccs-attributes column) - (setq attributes - (if attributes - (if (consp attributes) - (copy-sequence attributes)) - (sort (char-attribute-list) #'char-attribute-name<))) - (setq ccs-attributes - (if ccs-attributes - (copy-sequence ccs-attributes) - (sort (charset-list) #'char-attribute-name<))) + (let (atr-d ccs-d) + (setq attributes + (sort (if attributes + (if (consp attributes) + (progn + (dolist (name attributes) + (unless (memq name char-db-ignored-attributes) + (push name atr-d))) + atr-d)) + (dolist (name (char-attribute-list)) + (unless (memq name char-db-ignored-attributes) + (if (find-charset name) + (push name ccs-d) + (push name atr-d)))) + atr-d) + #'char-attribute-name<)) + (setq ccs-attributes + (sort (if ccs-attributes + (progn + (setq ccs-d nil) + (dolist (name ccs-attributes) + (unless (memq name char-db-ignored-attributes) + (push name ccs-d))) + ccs-d) + (or ccs-d + (progn + (dolist (name (charset-list)) + (unless (memq name char-db-ignored-attributes) + (push name ccs-d))) + ccs-d))) + #'char-attribute-name<))) (unless column (setq column (current-column))) (let (name value has-long-ccs-name rest @@ -210,12 +475,21 @@ (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\t\t. %S)%s") + "(name . %S)%s") value line-breaking)) (setq attributes (delq 'name attributes)) ) + (when (and (memq 'name* attributes) + (setq value (get-char-attribute char 'name*))) + (insert (format + (if (> (+ (current-column) (length value)) 48) + "(name* . %S)%s" + "(name* . %S)%s") + value line-breaking)) + (setq attributes (delq 'name* attributes)) + ) (when (and (memq 'script attributes) (setq value (get-char-attribute char 'script))) (insert (format "(script\t\t%s)%s" @@ -224,10 +498,89 @@ line-breaking)) (setq attributes (delq 'script attributes)) ) + (dolist (name '(=>ucs =>ucs*)) + (when (and (memq name attributes) + (setq value (get-char-attribute char name))) + (insert (format "(%-18s . #x%04X)\t; %c%s" + name value (decode-char '=ucs value) + line-breaking)) + (setq attributes (delq name attributes)))) + ;; (when (and (memq '=>ucs* attributes) + ;; (setq value (get-char-attribute char '=>ucs*))) + ;; (insert (format "(=>ucs*\t\t. #x%04X)\t; %c%s" + ;; value (decode-char '=ucs value) + ;; line-breaking)) + ;; (setq attributes (delq '=>ucs* attributes)) + ;; ) + (dolist (name '(=>ucs@gb =>ucs@cns =>ucs@jis =>ucs@ks =>ucs@big5)) + (when (and (memq name attributes) + (setq value (get-char-attribute char name))) + (insert (format "(%-18s . #x%04X)\t; %c%s" + name value + (decode-char (intern + (concat "=" + (substring + (symbol-name name) 2))) + value) + line-breaking)) + (setq attributes (delq name attributes)) + )) + (dolist (name '(=>ucs-gb =>ucs-cns =>ucs-jis =>ucs-ks =>ucs-big5)) + (when (and (memq name attributes) + (setq value (get-char-attribute char name))) + (insert (format "(%-18s . #x%04X)\t; %c%s" + (intern + (concat "=>ucs@" + (substring (symbol-name name) 6))) + value + (decode-char (intern + (concat "=ucs@" + (substring + (symbol-name name) 6))) + value) + line-breaking)) + (setq attributes (delq name attributes)))) + ;; (when (and (memq '=>ucs-gb attributes) + ;; (setq value (get-char-attribute char '=>ucs-gb))) + ;; (insert (format "(=>ucs@gb\t\t. #x%04X)\t; %c%s" + ;; value (decode-char '=ucs@gb value) + ;; line-breaking)) + ;; (setq attributes (delq '=>ucs-gb attributes)) + ;; ) + ;; (when (and (memq '=>ucs-cns attributes) + ;; (setq value (get-char-attribute char '=>ucs-cns))) + ;; (insert (format "(=>ucs@cns\t\t. #x%04X)\t; %c%s" + ;; value (decode-char '=ucs@cns value) + ;; line-breaking)) + ;; (setq attributes (delq '=>ucs-cns attributes)) + ;; ) + ;; (when (and (memq '=>ucs-big5 attributes) + ;; (setq value (get-char-attribute char '=>ucs-big5))) + ;; (insert (format "(=>ucs-big5\t\t. #x%04X)\t; %c%s" + ;; value (decode-char 'ucs-big5 value) + ;; line-breaking)) + ;; (setq attributes (delq '=>ucs-big5 attributes)) + ;; ) + ;; (when (and (memq '=>ucs-jis attributes) + ;; (setq value (get-char-attribute char '=>ucs-jis))) + ;; (insert (format "(=>ucs@jis\t\t. #x%04X)\t; %c%s" + ;; value (decode-char '=ucs@jis value) + ;; line-breaking)) + ;; (setq attributes (delq '=>ucs-jis attributes)) + ;; ) + ;; (when (and (memq '=>ucs-ks attributes) + ;; (setq value (get-char-attribute char '=>ucs-ks))) + ;; (insert (format "(=>ucs-ks\t\t. #x%04X)\t; %c%s" + ;; value (decode-char 'ucs-ks value) + ;; line-breaking)) + ;; (setq attributes (delq '=>ucs-ks attributes)) + ;; ) (when (and (memq '->ucs attributes) (setq value (get-char-attribute char '->ucs))) - (insert (format "(->ucs\t\t. #x%04X)\t; %c%s" - value (decode-char 'ucs value) + (insert (format (if char-db-convert-obsolete-format + "(=>ucs\t\t. #x%04X)\t; %c%s" + "(->ucs\t\t. #x%04X)\t; %c%s") + value (decode-char '=ucs value) line-breaking)) (setq attributes (delq '->ucs attributes)) ) @@ -403,6 +756,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" @@ -419,7 +804,8 @@ ((integerp code) (format "#x%04X" code)) (t - (format "%s%S" line-breaking code)))) + (format "%s %S" + line-breaking code)))) value " ") line-breaking)) (setq attributes (delq '->ideograph attributes)) @@ -444,48 +830,9 @@ line-breaking)) (setq attributes (delq '->decomposition attributes)) ) - (when (and (memq '->uppercase attributes) - (setq value (get-char-attribute char '->uppercase))) - (insert (format "(->uppercase\t%s)%s" - (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)) - (setq attributes (delq '->uppercase attributes)) - ) - (when (and (memq '->lowercase attributes) - (setq value (get-char-attribute char '->lowercase))) - (insert (format "(->lowercase\t%s)%s" - (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)) - (setq attributes (delq '->lowercase attributes)) - ) - (when (and (memq '->titlecase attributes) - (setq value (get-char-attribute char '->titlecase))) - (insert (format "(->titlecase\t%s)%s" - (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)) - (setq attributes (delq '->titlecase attributes)) - ) + (if (equal (get-char-attribute char '->titlecase) + (get-char-attribute char '->uppercase)) + (setq attributes (delq '->titlecase attributes))) (when (and (memq '->mojikyo attributes) (setq value (get-char-attribute char '->mojikyo))) (insert (format "(->mojikyo\t\t. %06d)\t; %c%s" @@ -493,6 +840,24 @@ line-breaking)) (setq attributes (delq '->mojikyo attributes)) ) + (when (and (memq 'hanyu-dazidian-vol attributes) + (setq value (get-char-attribute char 'hanyu-dazidian-vol))) + (insert (format "(hanyu-dazidian-vol . %d)%s" + value line-breaking)) + (setq attributes (delq 'hanyu-dazidian-vol attributes)) + ) + (when (and (memq 'hanyu-dazidian-page attributes) + (setq value (get-char-attribute char 'hanyu-dazidian-page))) + (insert (format "(hanyu-dazidian-page . %d)%s" + value line-breaking)) + (setq attributes (delq 'hanyu-dazidian-page attributes)) + ) + (when (and (memq 'hanyu-dazidian-char attributes) + (setq value (get-char-attribute char 'hanyu-dazidian-char))) + (insert (format "(hanyu-dazidian-char . %d)%s" + value line-breaking)) + (setq attributes (delq 'hanyu-dazidian-char attributes)) + ) (setq rest ccs-attributes) (while (and rest (progn @@ -508,29 +873,55 @@ (while attributes (setq name (car attributes)) (if (setq value (get-char-attribute char name)) - (cond ((eq name 'jisx0208-1978/4X) + (cond ((string-match "^=>ucs@" (symbol-name name)) + (insert (format "(%-18s . #x%04X)\t; %c%s" + name value (decode-char '=ucs value) + line-breaking)) + ) + ((eq name 'jisx0208-1978/4X) (insert (format "(%-18s . #x%04X)%s" name 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))) + ((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) + (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)) ((memq name '(ideograph= original-ideograph-of ancient-ideograph-of vulgar-ideograph-of - simplified-ideograph-of)) + wrong-ideograph-of + simplified-ideograph-of + ideographic-variants + ideographic-different-form-of)) (insert (format "(%-18s%s " name line-breaking)) (setq lbs (concat "\n" (make-string (current-column) ?\ )) separator nil) @@ -550,6 +941,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))) ((consp value) (insert (format "(%-18s " name)) (setq lbs (concat "\n" (make-string (current-column) ?\ )) @@ -559,7 +964,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 @@ -592,28 +997,29 @@ (setq attributes (cdr attributes))) (while ccs-attributes (setq name (car ccs-attributes)) - (if (setq value (get-char-attribute char name)) + (if (and (eq name (charset-name name)) + (setq value (get-char-attribute char name))) (insert (format - (if has-long-ccs-name - (cond ((eq name 'ideograph-daikanwa) + (cond ((memq name '(ideograph-daikanwa + =daikanwa-rev1 + =daikanwa-rev2 + =gt =gt-k =cbeta)) + (if has-long-ccs-name "(%-26s . %05d)\t; %c%s" - ) - ((eq name 'mojikyo) + "(%-18s . %05d)\t; %c%s")) + ((eq name 'mojikyo) + (if has-long-ccs-name "(%-26s . %06d)\t; %c%s" - ) - (t - "(%-26s . #x%X)\t; %c%s" - )) - (cond ((eq name 'ideograph-daikanwa) - "(%-18s . %05d)\t; %c%s" - ) - ((eq name 'mojikyo) - "(%-18s . %06d)\t; %c%s" - ) - (t - "(%-18s . #x%X)\t; %c%s" - ))) + "(%-18s . %06d)\t; %c%s")) + ((>= (charset-dimension name) 2) + (if has-long-ccs-name + "(%-26s . #x%04X)\t; %c%s" + "(%-18s . #x%04X)\t; %c%s")) + (t + (if has-long-ccs-name + "(%-26s . #x%02X)\t; %c%s" + "(%-18s . #x%02X)\t; %c%s"))) name (if (= (charset-iso-graphic-plane name) 1) (logior value @@ -625,7 +1031,7 @@ #x808080) (t 0))) value) - (decode-builtin-char name value) + (char-db-decode-isolated-char name value) line-breaking))) (setq ccs-attributes (cdr ccs-attributes))) (insert ")"))) @@ -642,77 +1048,55 @@ (goto-char (point-min)) (while (re-search-forward "[ \t]+$" nil t) (replace-match "")) + ;; from tabify. + (goto-char (point-min)) + (while (re-search-forward "[ \t][ \t][ \t]*" nil t) + (let ((column (current-column)) + (indent-tabs-mode t)) + (delete-region (match-beginning 0) (point)) + (indent-to column))) (goto-char (point-max)) - (tabify (point-min)(point-max)) + ;; (tabify (point-min)(point-max)) )) -;;;###autoload -(defun char-db-update-comment () - (interactive) - (save-excursion - (goto-char (point-min)) - (let (cdef table char) - (while (re-search-forward "^[ \t]*\\(([^.()]+)\\)" nil t) - (goto-char (match-beginning 1)) - (setq cdef (read (current-buffer))) - (when (find-charset (car cdef)) - (goto-char (match-end 0)) - (setq char - (if (and - (not (eq (car cdef) 'ideograph-daikanwa)) - (or (memq (car cdef) '(ascii latin-viscii-upper - latin-viscii-lower - arabic-iso8859-6 - japanese-jisx0213-1 - japanese-jisx0213-2)) - (= (char-int (charset-iso-final-char (car cdef))) - 0))) - (apply (function make-char) cdef) - (if (setq table (charset-mapping-table (car cdef))) - (set-charset-mapping-table (car cdef) nil)) - (prog1 - (apply (function make-char) cdef) - (if table - (set-charset-mapping-table (car cdef) table))))) - (when (not (or (< (char-int char) 32) - (and (<= 128 (char-int char)) - (< (char-int char) 160)))) - (delete-region (point) (point-at-eol)) - (insert (format "\t; %c" char))) - ))))) - -(defun insert-char-data-with-variant (char &optional script printable - no-ucs-variant) +(defun insert-char-data-with-variant (char &optional printable + no-ucs-variant + script excluded-script) (insert-char-data char printable) (let ((variants (or (char-variants char) (let ((ucs (get-char-attribute char '->ucs))) (if ucs (delete char (char-variants (int-char ucs))))))) variant vs) + (setq variants (sort variants #'<)) (while variants (setq variant (car variants)) - (if (or (null script) - (null (setq vs (get-char-attribute variant 'script))) - (memq script vs)) - (or (and no-ucs-variant (get-char-attribute variant 'ucs)) + (if (and (or (null script) + (null (setq vs (get-char-attribute variant 'script))) + (memq script vs)) + (or (null excluded-script) + (null (setq vs (get-char-attribute variant 'script))) + (not (memq excluded-script vs)))) + (or (and no-ucs-variant (get-char-attribute variant '=ucs)) (insert-char-data variant printable))) (setq variants (cdr variants)) ))) -(defun insert-char-range-data (min max &optional script) +(defun insert-char-range-data (min max &optional script excluded-script) (let ((code min) char) (while (<= code max) - (setq char (decode-char 'ucs code)) - (if (get-char-attribute char 'ucs) - (insert-char-data-with-variant char script nil 'no-ucs-variant)) - (setq code (1+ code)) - ))) + (setq char (decode-char '=ucs code)) + (if (encode-char char '=ucs 'defined-only) + (insert-char-data-with-variant char nil 'no-ucs-variant + script excluded-script)) + (setq code (1+ code))))) -(defun write-char-range-data-to-file (min max file &optional script) +(defun write-char-range-data-to-file (min max file + &optional script excluded-script) (let ((coding-system-for-write 'utf-8)) (with-temp-buffer - (insert-char-range-data min max script) + (insert-char-range-data min max script excluded-script) (write-region (point-min)(point-max) file)))) (defvar what-character-original-window-configuration) @@ -730,7 +1114,16 @@ (erase-buffer) (condition-case err (progn - (insert-char-data-with-variant char nil 'printable) + (insert-char-data-with-variant char 'printable) + (unless (char-attribute-alist char) + (insert (format ";; = %c\n" + (let* ((rest (split-char char)) + (ccs (pop rest)) + (code (pop rest))) + (while rest + (setq code (logior (lsh code 8) + (pop rest)))) + (decode-char ccs code))))) ;; (char-db-update-comment) (set-buffer-modified-p nil) (view-mode the-buf (lambda (buf)