X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Futf-2000%2Fchar-db-util.el;h=3add8f94561263ed945e601a72ae48c13b1e5166;hb=3a22dcb3b6189c92c4a6841585f8bd1fea3f37d8;hp=dc740d232d0ea438bbd6181b4e2d42203ec96f7d;hpb=9cbb5c35e40f0025fca1ef185ea1fd4771e41567;p=chise%2Fxemacs-chise.git-

diff --git a/lisp/utf-2000/char-db-util.el b/lisp/utf-2000/char-db-util.el
index dc740d2..3add8f9 100644
--- a/lisp/utf-2000/char-db-util.el
+++ b/lisp/utf-2000/char-db-util.el
@@ -61,9 +61,61 @@
     ("So" symbol	other)
     ))
 
+(defconst ideographic-radicals
+  (let ((v (make-vector 215 nil))
+	(i 1))
+    (while (< i 215)
+      (aset v i (int-char (+ #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))
+
+(defun char-attribute-name< (ka kb)
+  (cond
+   ((find-charset ka)
+    (cond
+     ((find-charset kb)
+      (cond
+       ((= (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)))))
+	      ((<= (charset-chars ka)(charset-chars kb)))))
+       (t
+	(< (charset-dimension ka)
+	   (charset-dimension kb))
+	)))
+     ((symbolp kb)
+      nil)
+     (t
+      t)))
+   ((find-charset kb)
+    t)
+   ((symbolp ka)
+    (cond ((symbolp kb)
+	   (string< (symbol-name ka)
+		    (symbol-name kb)))
+	  (t)))
+   ((symbolp kb)
+    nil)))
+
 (defun insert-char-data (char)
   (let ((data (char-attribute-alist char))
-	cell ret name has-long-ccs-name rest)
+	cell ret has-long-ccs-name rest)
     (when data
       (save-restriction
 	(narrow-to-region (point)(point))
@@ -137,7 +189,8 @@
 			  cell))
 	  (setq data (del-alist 'mirrored data))
 	  )
-	(when (setq cell (assq 'decimal-digit-value data))
+	(cond
+	 ((setq cell (assq 'decimal-digit-value data))
 	  (setq cell (cdr cell))
 	  (insert (format "(decimal-digit-value . %S)
     "
@@ -158,30 +211,124 @@
 	    (setq data (del-alist 'numeric-value data))
 	    )
 	  )
-	(setq data (sort data
-			 (lambda (a b)
-			   (let ((ka (car a))
-				 (kb (car b)))
-			     (cond ((find-charset ka)
-				    (cond ((find-charset kb)
-					   (cond ((= (charset-dimension ka)
-						     (charset-dimension kb))
-						  (< (charset-final ka)
-						     (charset-final kb)))
-						 (t
-						  (< (charset-dimension ka)
-						     (charset-dimension kb))
-						  )))
-					  (t)))
-				   ((find-charset kb)
-				    t)
-				   ((symbolp ka)
-				    (cond ((symbolp kb)
-					   (string< (symbol-name ka)
-						    (symbol-name kb)))
-					  (t)))
-				   ((symbolp kb)
-				    nil))))))
+	 (t
+	  (when (setq cell (assq 'digit-value data))
+	    (setq cell (cdr cell))
+	    (insert (format "(digit-value\t. %S)
+    "
+			    cell))
+	    (setq data (del-alist 'digit-value data))
+	    )
+	  (when (setq cell (assq 'numeric-value data))
+	    (setq cell (cdr cell))
+	    (insert (format "(numeric-value\t. %S)
+    "
+			    cell))
+	    (setq data (del-alist 'numeric-value data))
+	    )))
+	(when (setq cell (assq 'iso-10646-comment data))
+	  (setq cell (cdr cell))
+	  (insert (format "(iso-10646-comment\t. %S)
+    "
+			  cell))
+	  (setq data (del-alist 'iso-10646-comment data))
+	  )
+	(when (setq cell (assq 'morohashi-daikanwa data))
+	  (setq cell (cdr cell))
+	  (insert (format "(morohashi-daikanwa\t%s)
+    "
+			  (mapconcat (function prin1-to-string) cell " ")))
+	  (setq data (del-alist 'morohashi-daikanwa data))
+	  )
+	(when (setq cell (assq 'ideographic-radical data))
+	  (setq cell (cdr cell))
+	  (insert (format "(ideographic-radical . %S)\t; %c
+    "
+			  cell
+			  (aref ideographic-radicals cell)))
+	  (setq data (del-alist 'ideographic-radical data))
+	  )
+	(cond
+	 ((setq cell (assq 'ideographic-strokes data))
+	  (setq cell (cdr cell))
+	  (insert (format "(ideographic-strokes . %S)
+    "
+			  cell))
+	  (setq data (del-alist 'ideographic-strokes data))
+	  (when (setq cell (assq 'total-strokes data))
+	    (setq cell (cdr cell))
+	    (insert (format "(total-strokes\t . %S)
+    "
+			    cell))
+	    (setq data (del-alist 'total-strokes data))
+	    ))
+	 ((setq cell (assq 'total-strokes data))
+	  (setq cell (cdr cell))
+	  (insert (format "(total-strokes\t. %S)
+    "
+			  cell))
+	  (setq data (del-alist 'total-strokes data))
+	  ))
+	(when (setq cell (assq '->decomposition data))
+	  (setq cell (cdr cell))
+	  (insert (format "(->decomposition\t%s)
+    "
+			  (mapconcat (lambda (code)
+				       (cond ((symbolp code)
+					      (symbol-name code))
+					     ((integerp code)
+					      (format "#x%04X" code))
+					     (t
+					      (format "\n     %S" code))))
+				     cell " ")))
+	  (setq data (del-alist '->decomposition data))
+	  )
+	(when (setq cell (assq '->uppercase data))
+	  (setq cell (cdr cell))
+	  (insert (format "(->uppercase\t%s)
+    "
+			  (mapconcat (lambda (code)
+				       (cond ((symbolp code)
+					      (symbol-name code))
+					     ((integerp code)
+					      (format "#x%04X" code))
+					     (t
+					      (format "\n     %S" code))))
+				     cell " ")))
+	  (setq data (del-alist '->uppercase data))
+	  )
+	(when (setq cell (assq '->lowercase data))
+	  (setq cell (cdr cell))
+	  (insert (format "(->lowercase\t%s)
+    "
+			  (mapconcat (lambda (code)
+				       (cond ((symbolp code)
+					      (symbol-name code))
+					     ((integerp code)
+					      (format "#x%04X" code))
+					     (t
+					      (format "\n     %S" code))))
+				     cell " ")))
+	  (setq data (del-alist '->lowercase data))
+	  )
+	(when (setq cell (assq '->titlecase data))
+	  (setq cell (cdr cell))
+	  (insert (format "(->titlecase\t%s)
+    "
+			  (mapconcat (lambda (code)
+				       (cond ((symbolp code)
+					      (symbol-name code))
+					     ((integerp code)
+					      (format "#x%04X" code))
+					     (t
+					      (format "\n     %S" code))))
+				     cell " ")))
+	  (setq data (del-alist '->titlecase data))
+	  )
+	(setq data
+	      (sort data
+		    (lambda (a b)
+		      (char-attribute-name< (car a)(car b)))))
 	(setq rest data)
 	(while (and rest
 		    (progn
@@ -197,17 +344,22 @@
 	(while data
 	  (setq cell (car data))
 	  (cond ((setq ret (find-charset (car cell)))
-		 (insert (format (if has-long-ccs-name
-				     "(%-26s %s)
+		 (insert
+		  (format
+		   (if has-long-ccs-name
+		       "(%-26s %s)
     "
-				   "(%-18s %s)
+		     "(%-18s %s)
     "
-				   )
-				 (charset-name ret)
-				 (mapconcat (lambda (b)
-					      (format "#x%02X" b)
-					      )
-					    (cdr cell) " "))))
+		     )
+		   (charset-name ret)
+		   (mapconcat
+		    (lambda (b)
+		      (format "#x%02X"
+			      (if (= (charset-iso-graphic-plane ret) 1)
+				  (logior b 128)
+				b)))
+		    (cdr cell) " "))))
 		((string-match "^->" (symbol-name (car cell)))
 		 (insert
 		  (format "(%-18s %s)
@@ -222,9 +374,11 @@
 					      (format "\n     %S" code))))
 				     (cdr cell) " "))))
 		((consp (cdr cell))
-		 (insert (format "%S
+		 (insert (format "(%-18s %s)
     "
-				 cell)))
+				 (car cell)
+				 (mapconcat (function prin1-to-string)
+					    (cdr cell) " "))))
 		(t
 		 (insert (format "(%-18s . %S)
     "
@@ -239,36 +393,60 @@
 	(tabify (point-min)(point-max))
 	))))
 
-(defun insert-char-range-data (min max)
-  (let ((code min))
-    (while (<= code max)
-      (insert-char-data (int-char code))
-      (setq code (1+ code))
-      )))
-
-(defun write-char-range-data-to-file (min max file)
-  (with-temp-buffer
-    (insert-char-range-data min max)
-    (write-region (point-min)(point-max) file)))
-
+;;;###autoload
 (defun char-db-update-comment ()
   (interactive)
   (save-excursion
     (goto-char (point-min))
-    (let (cdef table)
+    (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))
-	  (if (setq table (charset-mapping-table (car cdef)))
-	      (set-charset-mapping-table (car cdef) nil))
-	  (delete-region (point) (point-at-eol))
-	  (insert (format "\t; %c" (apply #'make-char cdef)))
-	  (if table
-	      (set-charset-mapping-table (car cdef) table))
+	  (setq char
+		(if (or (memq (car cdef) '(ascii latin-viscii-upper
+						 latin-viscii-lower
+						 arabic-iso8859-6))
+			(= (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)
+  (insert-char-data char)
+  (let ((variants (char-variants char)))
+    (while variants
+      (insert-char-data (car variants))
+      (setq variants (cdr variants))
+      )))
+
+(defun insert-char-range-data (min max)
+  (let ((code min)
+	char)
+    (while (<= code max)
+      (setq char (int-char code))
+      (insert-char-data-with-variant char)
+      (setq code (1+ code))
+      )))
+
+(defun write-char-range-data-to-file (min max file)
+  (with-temp-buffer
+    (insert-char-range-data min max)
+    (write-region (point-min)(point-max) file)))
+
+(defvar what-character-original-window-configuration)
+
 ;;;###autoload
 (defun what-char-definition (char)
   (interactive (list (char-after)))
@@ -282,7 +460,8 @@
     (erase-buffer)
     (condition-case err
 	(progn
-	  (insert-char-data char)
+	  (insert-char-data-with-variant char)
+	  (char-db-update-comment)
 	  (set-buffer-modified-p nil)
 	  (view-mode the-buf (lambda (buf)
 			       (set-window-configuration