X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Futf-2000%2Fchar-db-util.el;h=0bc9803466a463d9c4019e4a1bb2d76085d544f5;hb=4a97f3ba353fb539a06b3d60625f450c1008b452;hp=a2ee0ea474de484a8c4f502a2e1661cdef8c0d45;hpb=1e5d934ebb0ce156e3c6ca97c6fe9aad61cb184f;p=chise%2Fxemacs-chise.git diff --git a/lisp/utf-2000/char-db-util.el b/lisp/utf-2000/char-db-util.el index a2ee0ea..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) @@ -190,14 +193,16 @@ attributes ccs-attributes column) (setq attributes - (if attributes - (if (consp 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 @@ -419,7 +424,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)) @@ -453,7 +459,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 '->uppercase attributes)) @@ -467,7 +474,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 '->lowercase attributes)) @@ -481,7 +489,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 '->titlecase attributes)) @@ -532,7 +541,8 @@ vulgar-ideograph-of wrong-ideograph-of simplified-ideograph-of - ideographic-variants)) + ideographic-variants + ideographic-different-form-of)) (insert (format "(%-18s%s " name line-breaking)) (setq lbs (concat "\n" (make-string (current-column) ?\ )) separator nil) @@ -594,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 @@ -627,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 ")"))) @@ -683,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))) @@ -693,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) @@ -732,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)