(U+342B): Use `ideographic-radical@ucs' instead of
[chise/xemacs-chise.git] / lisp / utf-2000 / ideograph-util.el
index 423321e..adc7564 100644 (file)
@@ -1,6 +1,6 @@
 ;;; ideograph-util.el --- Ideographic Character Database utility
 
-;; Copyright (C) 1999,2000,2001,2002 MORIOKA Tomohiko.
+;; Copyright (C) 1999,2000,2001,2002,2003 MORIOKA Tomohiko.
 
 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
 ;; Keywords: UTF-2000, ISO/IEC 10646, Unicode, UCS-4, MULE.
 (defun char-ideographic-radical (char &optional radical)
   (let (ret)
     (or (catch 'tag
+         (dolist (domain '(ucs daikanwa cns))
+           (if (and (setq ret (get-char-attribute
+                               char
+                               (intern
+                                (format "%s@%s"
+                                        'ideographic-radical domain))))
+                    (or (eq ret radical)
+                        (null radical)))
+               (throw 'tag ret))))
+       (catch 'tag
          (dolist (cell (get-char-attribute char 'ideographic-))
            (if (and (setq ret (plist-get cell :radical))
                     (or (eq ret radical)
 (defun char-ideographic-strokes (char &optional radical)
   (let (ret)
     (or (catch 'tag
+         (dolist (domain '(ucs daikanwa cns))
+           (if (and (setq ret (get-char-attribute
+                               char
+                               (intern
+                                (format "%s@%s"
+                                        'ideographic-radical domain))))
+                    (or (eq ret radical)
+                        (null radical)))
+               (throw 'tag
+                      (get-char-attribute
+                       char
+                       (intern
+                        (format "%s@%s"
+                                'ideographic-strokes domain)))))))
+       (catch 'tag
          (dolist (cell (get-char-attribute char 'ideographic-))
            (if (and (setq ret (plist-get cell :radical))
                     (or (eq ret radical)
 (defun update-ideograph-radical-table ()
   (interactive)
   (let (ret radical script)
+    (dolist (domain '(ucs daikanwa cns))
+      (map-char-attribute
+       (lambda (char radical)
+        (when (and radical
+                   (or (null (setq script (get-char-attribute char 'script)))
+                       (memq 'Ideograph script)))
+          (unless (memq char
+                        (setq ret
+                              (aref ideograph-radical-chars-vector radical)))
+            (char-ideographic-strokes char)
+            (aset ideograph-radical-chars-vector radical
+                  (cons char ret))))
+        nil)
+       (intern (format "%s@%s" 'ideographic-radical domain))))
     (map-char-attribute
      (lambda (char radical)
        (when (and radical
 ;;         ((null b) t)
 ;;         (t (< a b))))
 
+;;;###autoload
 (defun char-representative-of-daikanwa (char)
-  (if (get-char-attribute char 'ideograph-daikanwa)
+  (if (or (encode-char char 'ideograph-daikanwa 'defined-only)
+         (encode-char char '=daikanwa-rev2 'defined-only))
       char
     (let ((m (get-char-attribute char 'morohashi-daikanwa))
          m-m m-s pat)
            (setq m-m (pop m))
            (setq m-s (pop m))
            (if (= m-s 0)
-               (decode-char 'ideograph-daikanwa m-m)
+               (or (decode-char '=daikanwa-rev2 m-m 'defined-only)
+                   (decode-char 'ideograph-daikanwa m-m))
              (when m
                (setq pat (list m-m m-s))
                (map-char-attribute (lambda (c v)
 
 ;;;###autoload
 (defun char-daikanwa (char)
-  (or (get-char-attribute char 'ideograph-daikanwa)
+  (or (encode-char char 'ideograph-daikanwa 'defined-only)
+      (encode-char char '=daikanwa-rev2 'defined-only)
       (get-char-attribute char 'morohashi-daikanwa)))
 
 ;;;###autoload
 (defun char-ucs (char)
-  (or (get-char-attribute char 'ucs)
-      (get-char-attribute char '=>ucs)
-      (get-char-attribute char '->ucs)))
+  (or (encode-char char '=ucs 'defined-only)
+      (get-char-attribute char '=>ucs)))
 
 (defun char-id (char)
   (logand (char-int char) #x3FFFFFFF))
      '(> > > >))))
 
 (defun insert-ideograph-radical-char-data (radical)
-  (let* ((ideographic-radical radical)
-        (chars
-         (sort (copy-list (aref ideograph-radical-chars-vector radical))
-               (function ideograph-char<)))
-        attributes ccss)
+  (let ((chars
+        (sort (copy-list (aref ideograph-radical-chars-vector radical))
+              (lambda (a b)
+                (ideograph-char< a b radical))))
+       attributes ccss)
     (dolist (name (char-attribute-list))
       (unless (memq name char-db-ignored-attributes)
        (if (find-charset name)
          ccss (sort ccss #'char-attribute-name<))
     (aset ideograph-radical-chars-vector radical chars)
     (dolist (char chars)
-      (when (some (lambda (ccs)
-                   (encode-char char ccs))
-                 ccss)
+      (when (or (not (some (lambda (atr)
+                            (get-char-attribute char atr))
+                          char-db-ignored-attributes))
+               (some (lambda (ccs)
+                       (encode-char char ccs 'defined-only))
+                     ccss))
        (insert-char-data char nil attributes ccss)))))
 
 (defun write-ideograph-radical-char-data (radical file)
               file))))
   (with-temp-buffer
     (insert-ideograph-radical-char-data radical)
-    (char-db-update-comment)
     (let ((coding-system-for-write 'utf-8))
       (write-region (point-min)(point-max) file)
       )))