X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Futf-2000%2Fchar-db-util.el;h=0bc9803466a463d9c4019e4a1bb2d76085d544f5;hb=c729fb7d27b5a757ee5db66946b5b11927cd34d6;hp=12a2c1e369f17c789b1b7c71e3ad91a13d1f960e;hpb=fb0740fc59d92c355dc382c41174f887d1f1c739;p=chise%2Fxemacs-chise.git- diff --git a/lisp/utf-2000/char-db-util.el b/lisp/utf-2000/char-db-util.el index 12a2c1e..0bc9803 100644 --- a/lisp/utf-2000/char-db-util.el +++ b/lisp/utf-2000/char-db-util.el @@ -5,22 +5,22 @@ ;; 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: @@ -93,7 +93,10 @@ ((>= (charset-iso-final-char kb) ?0) (< (charset-iso-final-char ka) (charset-iso-final-char kb))) - (t))))) + (t))) + (t (if (>= (charset-iso-final-char kb) ?0) + nil + (> (charset-id ka)(charset-id kb)))))) ((<= (charset-chars ka)(charset-chars kb))))) (t (< (charset-dimension ka) @@ -141,7 +144,7 @@ (setq value (cdr value))) (insert-char-attributes ret readable - al cal)) + (or al 'none) cal)) (insert (prin1-to-string value))) (insert ")") (insert line-breaking)) @@ -190,21 +193,27 @@ attributes ccs-attributes column) (setq attributes - (if attributes - (copy-sequence attributes) - (sort (char-attribute-list) #'char-attribute-name<))) + (sort (if attributes + (if (consp attributes) + (copy-sequence attributes)) + (char-attribute-list)) + #'char-attribute-name<)) (setq ccs-attributes - (if ccs-attributes - (copy-sequence ccs-attributes) - (sort (charset-list) #'char-attribute-name<))) + (sort (if ccs-attributes + (copy-sequence ccs-attributes) + (charset-list)) + #'char-attribute-name<)) (unless column (setq column (current-column))) (let (name value has-long-ccs-name rest radical strokes (line-breaking - (concat "\n" (make-string (1+ column) ?\ )))) + (concat "\n" (make-string (1+ column) ?\ ))) + lbs cell separator ret + key al cal) (insert "(") - (when (setq value (get-char-attribute char 'name)) + (when (and (memq 'name attributes) + (setq value (get-char-attribute char 'name))) (insert (format (if (> (length value) 47) "(name . %S)%s" @@ -212,20 +221,23 @@ value line-breaking)) (setq attributes (delq 'name attributes)) ) - (when (setq value (get-char-attribute char 'script)) + (when (and (memq 'script attributes) + (setq value (get-char-attribute char 'script))) (insert (format "(script\t\t%s)%s" (mapconcat (function prin1-to-string) value " ") line-breaking)) (setq attributes (delq 'script attributes)) ) - (when (setq value (get-char-attribute char '->ucs)) + (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)) ) - (when (setq value (get-char-attribute char 'general-category)) + (when (and (memq 'general-category attributes) + (setq value (get-char-attribute char 'general-category))) (insert (format "(general-category\t%s) ; %s%s" (mapconcat (lambda (cell) @@ -240,32 +252,37 @@ line-breaking)) (setq attributes (delq 'general-category attributes)) ) - (when (setq value (get-char-attribute char 'bidi-category)) + (when (and (memq 'bidi-category attributes) + (setq value (get-char-attribute char 'bidi-category))) (insert (format "(bidi-category\t. %S)%s" value line-breaking)) (setq attributes (delq 'bidi-category attributes)) ) - (unless (eq (setq value (get-char-attribute char 'mirrored 'empty)) - 'empty) + (unless (or (not (memq 'mirrored attributes)) + (eq (setq value (get-char-attribute char 'mirrored 'empty)) + 'empty)) (insert (format "(mirrored\t\t. %S)%s" value line-breaking)) (setq attributes (delq 'mirrored attributes)) ) (cond - ((setq value (get-char-attribute char 'decimal-digit-value)) + ((and (memq 'decimal-digit-value attributes) + (setq value (get-char-attribute char 'decimal-digit-value))) (insert (format "(decimal-digit-value . %S)%s" value line-breaking)) (setq attributes (delq 'decimal-digit-value attributes)) - (when (setq value (get-char-attribute char 'digit-value)) + (when (and (memq 'digit-value attributes) + (setq value (get-char-attribute char 'digit-value))) (insert (format "(digit-value\t . %S)%s" value line-breaking)) (setq attributes (delq 'digit-value attributes)) ) - (when (setq value (get-char-attribute char 'numeric-value)) + (when (and (memq 'numeric-value attributes) + (setq value (get-char-attribute char 'numeric-value))) (insert (format "(numeric-value\t . %S)%s" value line-breaking)) @@ -273,25 +290,29 @@ ) ) (t - (when (setq value (get-char-attribute char 'digit-value)) + (when (and (memq 'digit-value attributes) + (setq value (get-char-attribute char 'digit-value))) (insert (format "(digit-value\t. %S)%s" value line-breaking)) (setq attributes (delq 'digit-value attributes)) ) - (when (setq value (get-char-attribute char 'numeric-value)) + (when (and (memq 'numeric-value attributes) + (setq value (get-char-attribute char 'numeric-value))) (insert (format "(numeric-value\t. %S)%s" value line-breaking)) (setq attributes (delq 'numeric-value attributes)) ))) - (when (setq value (get-char-attribute char 'iso-10646-comment)) + (when (and (memq 'iso-10646-comment attributes) + (setq value (get-char-attribute char 'iso-10646-comment))) (insert (format "(iso-10646-comment\t. %S)%s" value line-breaking)) (setq attributes (delq 'iso-10646-comment attributes)) ) - (when (setq value (get-char-attribute char 'morohashi-daikanwa)) + (when (and (memq 'morohashi-daikanwa attributes) + (setq value (get-char-attribute char 'morohashi-daikanwa))) (insert (format "(morohashi-daikanwa\t%s)%s" (mapconcat (function prin1-to-string) value " ") line-breaking)) @@ -299,7 +320,8 @@ ) (setq radical nil strokes nil) - (when (setq value (get-char-attribute char 'ideographic-radical)) + (when (and (memq 'ideographic-radical attributes) + (setq value (get-char-attribute char 'ideographic-radical))) (setq radical value) (insert (format "(ideographic-radical . %S)\t; %c%s" radical @@ -307,14 +329,16 @@ line-breaking)) (setq attributes (delq 'ideographic-radical attributes)) ) - (when (setq value (get-char-attribute char 'ideographic-strokes)) + (when (and (memq 'ideographic-strokes attributes) + (setq value (get-char-attribute char 'ideographic-strokes))) (setq strokes value) (insert (format "(ideographic-strokes . %S)%s" strokes line-breaking)) (setq attributes (delq 'ideographic-strokes attributes)) ) - (when (setq value (get-char-attribute char 'kangxi-radical)) + (when (and (memq 'kangxi-radical attributes) + (setq value (get-char-attribute char 'kangxi-radical))) (unless (eq value radical) (insert (format "(kangxi-radical\t . %S)\t; %c%s" value @@ -324,7 +348,8 @@ (setq radical value))) (setq attributes (delq 'kangxi-radical attributes)) ) - (when (setq value (get-char-attribute char 'kangxi-strokes)) + (when (and (memq 'kangxi-strokes attributes) + (setq value (get-char-attribute char 'kangxi-strokes))) (unless (eq value strokes) (insert (format "(kangxi-strokes\t . %S)%s" value @@ -333,7 +358,8 @@ (setq strokes value))) (setq attributes (delq 'kangxi-strokes attributes)) ) - (when (setq value (get-char-attribute char 'japanese-radical)) + (when (and (memq 'japanese-radical attributes) + (setq value (get-char-attribute char 'japanese-radical))) (unless (eq value radical) (insert (format "(japanese-radical\t . %S)\t; %c%s" value @@ -343,7 +369,8 @@ (setq radical value))) (setq attributes (delq 'japanese-radical attributes)) ) - (when (setq value (get-char-attribute char 'japanese-strokes)) + (when (and (memq 'japanese-strokes attributes) + (setq value (get-char-attribute char 'japanese-strokes))) (unless (eq value strokes) (insert (format "(japanese-strokes\t . %S)%s" value @@ -352,14 +379,16 @@ (setq strokes value))) (setq attributes (delq 'japanese-strokes attributes)) ) - (when (setq value (get-char-attribute char 'cns-radical)) + (when (and (memq 'cns-radical attributes) + (setq value (get-char-attribute char 'cns-radical))) (insert (format "(cns-radical\t . %S)\t; %c%s" value (aref ideographic-radicals value) line-breaking)) (setq attributes (delq 'cns-radical attributes)) ) - (when (setq value (get-char-attribute char 'cns-strokes)) + (when (and (memq 'cns-strokes attributes) + (setq value (get-char-attribute char 'cns-strokes))) (unless (eq value strokes) (insert (format "(cns-strokes\t . %S)%s" value @@ -368,7 +397,8 @@ (setq strokes value))) (setq attributes (delq 'cns-strokes attributes)) ) - (when (setq value (get-char-attribute char 'shinjigen-1-radical)) + (when (and (memq 'shinjigen-1-radical attributes) + (setq value (get-char-attribute char 'shinjigen-1-radical))) (unless (eq value radical) (insert (format "(shinjigen-1-radical . %S)\t; %c%s" value @@ -378,13 +408,15 @@ (setq radical value))) (setq attributes (delq 'shinjigen-1-radical attributes)) ) - (when (setq value (get-char-attribute char 'total-strokes)) + (when (and (memq 'total-strokes attributes) + (setq value (get-char-attribute char 'total-strokes))) (insert (format "(total-strokes . %S)%s" value line-breaking)) (setq attributes (delq 'total-strokes attributes)) ) - (when (setq value (get-char-attribute char '->ideograph)) + (when (and (memq '->ideograph attributes) + (setq value (get-char-attribute char '->ideograph))) (insert (format "(->ideograph\t%s)%s" (mapconcat (lambda (code) (cond ((symbolp code) @@ -392,12 +424,14 @@ ((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)) ) - (when (setq value (get-char-attribute char '->decomposition)) + (when (and (memq '->decomposition attributes) + (setq value (get-char-attribute char '->decomposition))) (insert (format "(->decomposition\t%s)%s" (mapconcat (lambda (code) (cond ((symbolp code) @@ -416,7 +450,8 @@ line-breaking)) (setq attributes (delq '->decomposition attributes)) ) - (when (setq value (get-char-attribute char '->uppercase)) + (when (and (memq '->uppercase attributes) + (setq value (get-char-attribute char '->uppercase))) (insert (format "(->uppercase\t%s)%s" (mapconcat (lambda (code) (cond ((symbolp code) @@ -424,12 +459,14 @@ ((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 '->uppercase attributes)) ) - (when (setq value (get-char-attribute char '->lowercase)) + (when (and (memq '->lowercase attributes) + (setq value (get-char-attribute char '->lowercase))) (insert (format "(->lowercase\t%s)%s" (mapconcat (lambda (code) (cond ((symbolp code) @@ -437,12 +474,14 @@ ((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 '->lowercase attributes)) ) - (when (setq value (get-char-attribute char '->titlecase)) + (when (and (memq '->titlecase attributes) + (setq value (get-char-attribute char '->titlecase))) (insert (format "(->titlecase\t%s)%s" (mapconcat (lambda (code) (cond ((symbolp code) @@ -450,12 +489,14 @@ ((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 '->titlecase attributes)) ) - (when (setq value (get-char-attribute char '->mojikyo)) + (when (and (memq '->mojikyo attributes) + (setq value (get-char-attribute char '->mojikyo))) (insert (format "(->mojikyo\t\t. %06d)\t; %c%s" value (decode-char 'mojikyo value) line-breaking)) @@ -496,62 +537,63 @@ line-breaking))) ((memq name '(ideograph= original-ideograph-of - vulgar-ideograph-of)) + ancient-ideograph-of + vulgar-ideograph-of + wrong-ideograph-of + simplified-ideograph-of + ideographic-variants + ideographic-different-form-of)) (insert (format "(%-18s%s " name line-breaking)) - (let ((lbs (concat "\n" (make-string (current-column) ?\ ))) - cell ret - rest key al cal - separator) - (while (consp value) - (setq cell (car value)) - (if (and (consp cell) - (consp (car cell))) - (progn - (if separator - (insert lbs)) - (char-db-insert-alist cell readable) - (setq separator lbs)) - (if separator - (insert separator)) - (insert (prin1-to-string cell)) - (setq separator " ")) - (setq value (cdr value)))) + (setq lbs (concat "\n" (make-string (current-column) ?\ )) + separator nil) + (while (consp value) + (setq cell (car value)) + (if (and (consp cell) + (consp (car cell))) + (progn + (if separator + (insert lbs)) + (char-db-insert-alist cell readable) + (setq separator lbs)) + (if separator + (insert separator)) + (insert (prin1-to-string cell)) + (setq separator " ")) + (setq value (cdr value))) (insert ")") (insert line-breaking)) ((consp value) (insert (format "(%-18s " name)) - (let ((lbs (concat "\n" (make-string (current-column) ?\ ))) - cell ret - rest key al cal - separator) - (while (consp value) - (setq cell (car value)) - (if (and (consp cell) - (consp (car cell)) - (setq ret (condition-case nil - (define-char cell) - (error nil)))) - (progn - (setq rest cell - al nil - cal nil) - (while rest - (setq key (car (car rest))) - (if (find-charset key) - (setq cal (cons key cal)) - (setq al (cons key al))) - (setq rest (cdr rest))) - (if separator - (insert lbs)) - (insert-char-attributes ret - readable - al cal) - (setq separator lbs)) - (if separator - (insert separator)) - (insert (prin1-to-string cell)) - (setq separator " ")) - (setq value (cdr value)))) + (setq lbs (concat "\n" (make-string (current-column) ?\ )) + separator nil) + (while (consp value) + (setq cell (car value)) + (if (and (consp cell) + (consp (car cell)) + (setq ret (condition-case nil + (define-char cell) + (error nil)))) + (progn + (setq rest cell + al nil + cal nil) + (while rest + (setq key (car (car rest))) + (if (find-charset key) + (setq cal (cons key cal)) + (setq al (cons key al))) + (setq rest (cdr rest))) + (if separator + (insert lbs)) + (insert-char-attributes ret + readable + al cal) + (setq separator lbs)) + (if separator + (insert separator)) + (insert (prin1-to-string cell)) + (setq separator " ")) + (setq value (cdr value))) (insert ")") (insert line-breaking)) (t @@ -562,28 +604,22 @@ (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 ideograph-gt)) + (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 + "(%-18s . %06d)\t; %c%s")) + (t + (if has-long-ccs-name "(%-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 . #x%X)\t; %c%s"))) name (if (= (charset-iso-graphic-plane name) 1) (logior value @@ -595,7 +631,21 @@ #x808080) (t 0))) value) - (decode-builtin-char name value) + (if (and (memq name '(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 name value)) + (setq ret (get-char-attribute ret 'ideograph-gt))) + (decode-builtin-char 'ideograph-gt ret) + (decode-builtin-char name value)) line-breaking))) (setq ccs-attributes (cdr ccs-attributes))) (insert ")"))) @@ -651,8 +701,9 @@ (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))) @@ -661,28 +712,33 @@ variant vs) (while variants (setq variant (car variants)) - (if (or (null script) - (null (setq vs (get-char-attribute variant 'script))) - (memq script vs)) + (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)) + (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) @@ -700,7 +756,7 @@ (erase-buffer) (condition-case err (progn - (insert-char-data-with-variant char nil 'printable) + (insert-char-data-with-variant char 'printable) ;; (char-db-update-comment) (set-buffer-modified-p nil) (view-mode the-buf (lambda (buf)