X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Futf-2000%2Fchar-db-util.el;h=17049aa0e7004b2a6b43e825877eb51aa3709905;hb=b3f6e5a496412855a44cb9aa34f2de22b3c6ba14;hp=7e9a87defcaa8805554890568680b47c94100b5d;hpb=9b710aef5540ef8db1dec890dc94da125b2f576f;p=chise%2Fxemacs-chise.git

diff --git a/lisp/utf-2000/char-db-util.el b/lisp/utf-2000/char-db-util.el
index 7e9a87d..17049aa 100644
--- a/lisp/utf-2000/char-db-util.el
+++ b/lisp/utf-2000/char-db-util.el
@@ -96,6 +96,17 @@
     nil)
    ((eq '->subsumptive ka)
     nil)
+   ((and (symbolp ka)
+	 (string-match "^->" (symbol-name ka)))
+    (cond ((and (symbolp kb)
+		(string-match "^->" (symbol-name kb)))
+	   (string< (symbol-name ka)
+		    (symbol-name kb))
+	   ))
+    )
+   ((and (symbolp kb)
+	 (string-match "^->" (symbol-name kb)))
+    t)
    ((find-charset ka)
     (if (find-charset kb)
 	(if (<= (charset-id ka) 1)
@@ -439,6 +450,101 @@
 		      (- (logand value 255) 32))))
   (insert line-breaking))
 
+(defun char-db-insert-relation-feature (char name value line-breaking
+					     ccss readable)
+  (insert (format "(%-18s%s " name line-breaking))
+  (let ((lbs (concat "\n" (make-string (current-column) ?\ )))
+	separator cell sources required-features
+	ret)
+    (while (consp value)
+      (setq cell (car value))
+      (if (integerp cell)
+	  (setq cell (decode-char '=ucs cell)))
+      (cond
+       ((eq name '->subsumptive)
+	(when (or (not (some (lambda (atr)
+			       (get-char-attribute cell atr))
+			     char-db-ignored-attributes))
+		  (some (lambda (ccs)
+			  (encode-char cell ccs 'defined-only))
+			ccss))
+	  (if separator
+	      (insert lbs))
+	  (let ((char-db-ignored-attributes
+		 (cons '<-subsumptive
+		       char-db-ignored-attributes)))
+	    (insert-char-attributes cell readable))
+	  (setq separator lbs))
+	)
+       ((characterp cell)
+	(setq sources
+	      (get-char-attribute
+	       char (intern (format "%s*sources" name))))
+	(setq required-features nil)
+	(dolist (source sources)
+	  (cond
+	   ((memq source '(JP JP/Jouyou shinjigen-1))
+	    (setq required-features
+		  (union required-features
+			 '(=jis-x0208
+			   =jis-x0208@1990
+			   =jis-x0213-1-2000
+			   =jis-x0213-2-2000
+			   =jis-x0212
+			   =jis-x0208@1983
+			   =jis-x0208@1978))))
+	   ((eq source 'CN)
+	    (setq required-features
+		  (union required-features
+			 '(=gb2312
+			   =gb12345
+			   =iso-ir165)))))
+	  (cond
+	   ((find-charset (setq ret (intern (format "=%s" source))))
+	    (setq required-features
+		  (cons ret required-features)))
+	   (t (setq required-features
+		    (cons source required-features)))))
+	(cond ((string-match "@JP" (symbol-name name))
+	       (setq required-features
+		     (union required-features
+			    '(=jis-x0208
+			      =jis-x0208@1990
+			      =jis-x0213-1-2000
+			      =jis-x0213-2-2000
+			      =jis-x0212
+			      =jis-x0208@1983
+			      =jis-x0208@1978))))
+	      ((string-match "@CN" (symbol-name name))
+	       (setq required-features
+		     (union required-features
+			    '(=gb2312
+			      =gb12345
+			      =iso-ir165)))))
+	(if separator
+	    (insert lbs))
+	(if readable
+	    (insert (format "%S" cell))
+	  (char-db-insert-char-spec cell readable
+				    nil
+				    required-features))
+	(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)))
+
 (defun insert-char-attributes (char &optional readable attributes column)
   (unless column
     (setq column (current-column)))
@@ -449,8 +555,7 @@
 	 (concat "\n" (make-string (1+ column) ?\ )))
 	lbs cell separator ret
 	key al cal
-	dest-ccss
-	sources required-features
+	dest-ccss ; sources required-features
 	ccss)
     (let (atr-d)
       (setq attributes
@@ -471,6 +576,19 @@
 		    atr-d)
 		  #'char-attribute-name<)))
     (insert "(")
+    (when (memq '<-subsumptive attributes)
+      (when readable
+	(when (setq value (get-char-attribute char '<-subsumptive))
+	  (char-db-insert-relation-feature char '<-subsumptive value
+					   line-breaking
+					   ccss readable)))
+      (setq attributes (delq '<-subsumptive attributes)))
+    (when (and (memq '<-denotational attributes)
+	       (setq value (get-char-attribute char '<-denotational)))
+      (char-db-insert-relation-feature char '<-denotational value
+				       line-breaking
+				       ccss readable)
+      (setq attributes (delq '<-denotational attributes)))
     (when (and (memq 'name attributes)
 	       (setq value (get-char-attribute char 'name)))
       (insert (format
@@ -497,14 +615,6 @@
 		      line-breaking))
       (setq attributes (delq 'script attributes))
       )
-    ;; (when (and (memq '<-denotational attributes)
-    ;;            (setq value (get-char-attribute char '<-denotational))
-    ;;            (null (cdr value))
-    ;;            (setq value (encode-char (car value) 'ucs 'defined-only)))
-    ;;   (insert (format "(%-18s . #x%04X)\t; %c%s"
-    ;;                   '=>ucs value (decode-char 'ucs value)
-    ;;                   line-breaking))
-    ;;   (setq attributes (delq '<-denotational attributes)))
     (dolist (name '(=>ucs =>ucs*))
       (when (and (memq name attributes)
 		 (setq value (get-char-attribute char name)))
@@ -832,26 +942,26 @@
 		      line-breaking))
       (setq attributes (delq '->ideograph attributes))
       )
-    (when (and (memq '->decomposition attributes)
-	       (setq value (get-char-attribute char '->decomposition)))
-      (insert (format "(->decomposition\t%s)%s"
-		      (mapconcat (lambda (code)
-				   (cond ((symbolp code)
-					  (symbol-name code))
-					 ((characterp code)
-					  (if readable
-					      (format "%S" code)
-					    (format "#x%04X"
-						    (char-int code))
-					    ))
-					 ((integerp code)
-					  (format "#x%04X" code))
-					 (t
-					  (format "%s%S" line-breaking code))))
-				 value " ")
-		      line-breaking))
-      (setq attributes (delq '->decomposition attributes))
-      )
+    ;; (when (and (memq '->decomposition attributes)
+    ;;            (setq value (get-char-attribute char '->decomposition)))
+    ;;   (insert (format "(->decomposition\t%s)%s"
+    ;;                   (mapconcat (lambda (code)
+    ;;                                (cond ((symbolp code)
+    ;;                                       (symbol-name code))
+    ;;                                      ((characterp code)
+    ;;                                       (if readable
+    ;;                                           (format "%S" code)
+    ;;                                         (format "#x%04X"
+    ;;                                                 (char-int code))
+    ;;                                         ))
+    ;;                                      ((integerp code)
+    ;;                                       (format "#x%04X" code))
+    ;;                                      (t
+    ;;                                       (format "%s%S" line-breaking code))))
+    ;;                              value " ")
+    ;;                   line-breaking))
+    ;;   (setq attributes (delq '->decomposition attributes))
+    ;;   )
     (if (equal (get-char-attribute char '->titlecase)
 	       (get-char-attribute char '->uppercase))
 	(setq attributes (delq '->titlecase attributes)))
@@ -912,6 +1022,12 @@
 			     (intern (format "%s*sources" name))))
 		      (not (string-match "\\*sources$" (symbol-name name)))
 		      (or (eq name '<-identical)
+			  (eq name '<-canonical)
+			  (eq name '->superscript)
+			  (eq name '->subscript)
+			  (eq name '->circled)
+			  (string-match "^->font" (symbol-name name))
+			  (string-match "^->compat" (symbol-name name))
 			  (string-match "^->halfwidth" (symbol-name name))
 			  (and
 			   (string-match "^->fullwidth" (symbol-name name))
@@ -933,102 +1049,12 @@
 		((or (eq name 'ideographic-structure)
 		     (eq name 'ideographic-combination)
 		     (eq name 'ideographic-)
+		     (eq name '=decomposition)
+		     (string-match "^=>decomposition" (symbol-name name))
 		     (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 ((eq name '->subsumptive)
-			  (when (or (not
-				     (some (lambda (atr)
-					     (get-char-attribute cell atr))
-					   char-db-ignored-attributes))
-				    (some (lambda (ccs)
-					    (encode-char cell ccs
-							 'defined-only))
-					  ccss))
-			    (if separator
-				(insert lbs))
-			    (let ((char-db-ignored-attributes
-				   (cons '<-subsumptive
-					 char-db-ignored-attributes)))
-			      (insert-char-attributes cell readable))
-			    (setq separator lbs))
-			  )
-			 ((characterp cell)
-			  (setq sources
-				(get-char-attribute
-				 char
-				 (intern (format "%s*sources" name))))
-			  (setq required-features nil)
-			  (dolist (source sources)
-			    (cond
-			     ((memq source '(JP JP/Jouyou
-						shinjigen-1))
-			      (setq required-features
-				    (union required-features
-					   '(=jis-x0208
-					     =jis-x0208@1990
-					     =jis-x0213-1-2000
-					     =jis-x0213-2-2000
-					     =jis-x0212
-					     =jis-x0208@1983
-					     =jis-x0208@1978))))
-			     ((eq source 'CN)
-			      (setq required-features
-				    (union required-features
-					   '(=gb2312
-					     =gb12345
-					     =iso-ir165)))))
-			    (cond
-			     ((find-charset
-			       (setq ret (intern (format "=%s" source))))
-			      (setq required-features
-				    (cons ret required-features)))
-			     (t (setq required-features
-				      (cons source required-features)))))
-			  (cond ((string-match "@JP" (symbol-name name))
-				 (setq required-features
-				       (union required-features
-					      '(=jis-x0208
-						=jis-x0208@1990
-						=jis-x0213-1-2000
-						=jis-x0213-2-2000
-						=jis-x0212
-						=jis-x0208@1983
-						=jis-x0208@1978))))
-				((string-match "@CN" (symbol-name name))
-				 (setq required-features
-				       (union required-features
-					      '(=gb2312
-						=gb12345
-						=iso-ir165)))))
-			  (if separator
-			      (insert lbs))
-			  (if readable
-			      (insert (format "%S" cell))
-			    (char-db-insert-char-spec cell readable
-						      nil
-						      required-features))
-			  (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))
+		 (char-db-insert-relation-feature char name value
+						  line-breaking
+						  ccss readable))
 		((memq name '(ideograph=
 			      original-ideograph-of
 			      ancient-ideograph-of