From 612ec2d7d4b921678e383aa3d6b5a85302a9e786 Mon Sep 17 00:00:00 2001 From: tomo Date: Fri, 13 Feb 2004 20:36:51 +0000 Subject: [PATCH] (char-attribute-name<): Put `->denotational' into the last place and `->subsumptive' is second to last. (char-db-make-char-spec): Use `=daikanwa' instead of `ideograph-daikanwa'. (char-db-insert-char-spec): Modify for `insert-char-attributes'. (char-db-insert-alist): Likewise. (insert-char-attributes): Delete optional argument `ccs-attributes'; CCS-features are also specified in `attributes'. (insert-char-data): Likewise. --- lisp/utf-2000/char-db-util.el | 270 +++++++++++++++++++++++------------------ 1 file changed, 153 insertions(+), 117 deletions(-) diff --git a/lisp/utf-2000/char-db-util.el b/lisp/utf-2000/char-db-util.el index fe5ab7b..5aaa6e2 100644 --- a/lisp/utf-2000/char-db-util.el +++ b/lisp/utf-2000/char-db-util.el @@ -98,6 +98,14 @@ nil) (t t))) + ((eq '->denotational kb) + t) + ((eq '->subsumptive kb) + (not (eq '->denotational ka))) + ((eq '->denotational ka) + nil) + ((eq '->subsumptive ka) + nil) ((find-charset kb) t) ((symbolp ka) @@ -193,7 +201,7 @@ (dolist (ccs (delq (car ret) (charset-list))) (if (and (or (charset-iso-final-char ccs) (memq ccs - '(ideograph-daikanwa + '(=daikanwa =daikanwa-rev2 ;; =gt-k ))) @@ -228,37 +236,40 @@ 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 (encode-char char key 'defined-only) - (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)) - (dolist (feature required-features) - (if (find-charset feature) - (if (encode-char char feature 'defined-only) - (setq cal (adjoin feature cal))) - (setq al (adjoin feature al)))) + ;; (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 (encode-char char key 'defined-only) + ;; (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)) + ;; (dolist (feature required-features) + ;; (if (find-charset feature) + ;; (if (encode-char char feature 'defined-only) + ;; (setq cal (adjoin feature cal))) + ;; (setq al (adjoin feature al)))) (insert-char-attributes char readable - (or al 'none) cal) + ;; (or al 'none) cal + (union (mapcar #'car char-spec) + required-features) + ) (when temp-char ;; undefine temporary character ;; Current implementation is dirty. @@ -273,7 +284,8 @@ (let ((line-breaking (concat "\n" (make-string (1+ column) ?\ ))) name value - ret al cal key + ret al ; cal + key lbs cell rest separator) (insert "(") (while alist @@ -289,13 +301,15 @@ cal nil) (while value (setq key (car (car value))) - (if (find-charset key) - (setq cal (cons key cal)) - (setq al (cons key al))) + ;; (if (find-charset key) + ;; (setq cal (cons key cal)) + (setq al (cons key al)) + ;; ) (setq value (cdr value))) (insert-char-attributes ret readable - (or al 'none) cal)) + (or al 'none) ; cal + )) (insert (prin1-to-string value))) (insert ")") (insert line-breaking)) @@ -316,15 +330,17 @@ cal nil) (while rest (setq key (car (car rest))) - (if (find-charset key) - (setq cal (cons key cal)) - (setq al (cons key al))) + ;; (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) + al ; cal + ) (setq separator lbs)) (if separator (insert separator)) @@ -406,10 +422,8 @@ (defvar char-db-convert-obsolete-format t) -(defun insert-char-attributes (char &optional readable - attributes ccs-attributes - column) - (let (atr-d ccs-d) +(defun insert-char-attributes (char &optional readable attributes column) + (let (atr-d) (setq attributes (sort (if attributes (if (consp attributes) @@ -420,25 +434,8 @@ 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)))) + (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))) @@ -860,22 +857,62 @@ (dolist (ignored '(composition ->denotational <-subsumptive ->ucs-unified)) (setq attributes (delq ignored attributes)))) - (setq rest ccs-attributes) - (while (and rest - (progn - (setq value (get-char-attribute char (car rest))) - (if value - (if (>= (length (symbol-name (car rest))) 19) - (progn - (setq has-long-ccs-name t) - nil) - t) - t))) - (setq rest (cdr rest))) + ;; (setq rest ccs-attributes) + ;; (while (and rest + ;; (progn + ;; (setq value (get-char-attribute char (car rest))) + ;; (if value + ;; (if (>= (length (symbol-name (car rest))) 19) + ;; (progn + ;; (setq has-long-ccs-name t) + ;; nil) + ;; t) + ;; t))) + ;; (setq rest (cdr rest))) (while attributes (setq name (car attributes)) (if (setq value (get-char-attribute char name)) - (cond ((string-match "^=>ucs@" (symbol-name name)) + (cond ((setq ret (find-charset name)) + (setq name (charset-name ret)) + (if (and (not (memq name dest-ccss)) + (prog1 + (setq value (get-char-attribute char name)) + (setq dest-ccss (cons name dest-ccss)))) + (insert + (format + (cond ((memq name '(=daikanwa + =daikanwa-rev1 =daikanwa-rev2 + =gt =gt-k =cbeta)) + (if has-long-ccs-name + "(%-26s . %05d)\t; %c%s" + "(%-18s . %05d)\t; %c%s")) + ((eq name 'mojikyo) + (if has-long-ccs-name + "(%-26s . %06d)\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 + (cond ((= (charset-dimension name) 1) + #x80) + ((= (charset-dimension name) 2) + #x8080) + ((= (charset-dimension name) 3) + #x808080) + (t 0))) + value) + (char-db-decode-isolated-char name value) + line-breaking))) + ) + ((string-match "^=>ucs@" (symbol-name name)) (insert (format "(%-18s . #x%04X)\t; %c%s" name value (decode-char '=ucs value) line-breaking)) @@ -1028,56 +1065,55 @@ line-breaking))) )) (setq attributes (cdr attributes))) - (while ccs-attributes - (setq name (charset-name (car ccs-attributes))) - (if (and (not (memq name dest-ccss)) - (prog1 - (setq value (get-char-attribute char name)) - (setq dest-ccss (cons name dest-ccss)))) - (insert - (format - (cond ((memq name '(=daikanwa - =daikanwa-rev1 =daikanwa-rev2 - =gt =gt-k =cbeta)) - (if has-long-ccs-name - "(%-26s . %05d)\t; %c%s" - "(%-18s . %05d)\t; %c%s")) - ((eq name 'mojikyo) - (if has-long-ccs-name - "(%-26s . %06d)\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 - (cond ((= (charset-dimension name) 1) - #x80) - ((= (charset-dimension name) 2) - #x8080) - ((= (charset-dimension name) 3) - #x808080) - (t 0))) - value) - (char-db-decode-isolated-char name value) - line-breaking))) - (setq ccs-attributes (cdr ccs-attributes))) + ;; (while ccs-attributes + ;; (setq name (charset-name (car ccs-attributes))) + ;; (if (and (not (memq name dest-ccss)) + ;; (prog1 + ;; (setq value (get-char-attribute char name)) + ;; (setq dest-ccss (cons name dest-ccss)))) + ;; (insert + ;; (format + ;; (cond ((memq name '(=daikanwa + ;; =daikanwa-rev1 =daikanwa-rev2 + ;; =gt =gt-k =cbeta)) + ;; (if has-long-ccs-name + ;; "(%-26s . %05d)\t; %c%s" + ;; "(%-18s . %05d)\t; %c%s")) + ;; ((eq name 'mojikyo) + ;; (if has-long-ccs-name + ;; "(%-26s . %06d)\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 + ;; (cond ((= (charset-dimension name) 1) + ;; #x80) + ;; ((= (charset-dimension name) 2) + ;; #x8080) + ;; ((= (charset-dimension name) 3) + ;; #x808080) + ;; (t 0))) + ;; value) + ;; (char-db-decode-isolated-char name value) + ;; line-breaking))) + ;; (setq ccs-attributes (cdr ccs-attributes))) (insert ")"))) (defun insert-char-data (char &optional readable - attributes ccs-attributes) + attributes) (save-restriction (narrow-to-region (point)(point)) (insert "(define-char '") - (insert-char-attributes char readable - attributes ccs-attributes) + (insert-char-attributes char readable attributes) (insert ")\n") (goto-char (point-min)) (while (re-search-forward "[ \t]+$" nil t) -- 1.7.10.4