update.

[chise/xemacs-chise.git] / lisp / utf-2000 / chise-subr.el

diff --git a/lisp/utf-2000/chise-subr.el b/lisp/utf-2000/chise-subr.el
index c6e968c..1b8f413 100644 (file)
--- a/lisp/utf-2000/chise-subr.el
+++ b/lisp/utf-2000/chise-subr.el
@@ -1,7 +1,7 @@
 ;;; chise-subr.el --- basic lisp subroutines for XEmacs CHISE
 
 ;; Copyright (C) 1999, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009,
-;;   2010, 2011, 2012, 2013, 2014, 2015 MORIOKA Tomohiko.
+;;   2010, 2011, 2012, 2013, 2014, 2015, 2020, 2021, 2022, 2023 MORIOKA Tomohiko.
 
 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
 ;; Keywords: CHISE, Character Database, ISO/IEC 10646, UCS, Unicode, MULE.
@@ -39,8 +39,8 @@
   ;;             (push domain dest))))))
   ;;   (sort dest #'string<))
   '(ucs ucs/compat daikanwa cns gt jis jis/a jis/b
-       jis-x0212 jis-x0213 cdp shinjigen
-       r030 r140 misc unknown))
+       jis-x0212 jis-x0213 cdp shinjigen mj
+       r001 r007 r030 r053 r055 r074 r130 r140 r159 misc unknown))
 
 (defconst charset-id-=adobe-japan1-0 (charset-id '=adobe-japan1-0))
 (defconst charset-id-=adobe-japan1-6 (charset-id '=adobe-japan1-6))
@@ -167,11 +167,17 @@
                 (t nil))
              (cond
               ((eq ka '=mj)
-               t)
+               (not (eq kb '=mj))
+               )
               ((eq ka '==mj)
-               t)
+               (not (or (eq kb '=mj)
+                        (eq kb '=>>mj)
+                        (eq kb '==mj)))
+               )
               ((eq ka '=>>mj)
-               t)
+               (not (or (eq kb '=mj)
+                        (eq kb '=>>mj)))
+               )
               ((and (setq a-id (charset-id ka))
                     (charset-id-adobe-japan1-p a-id))
                (cond
@@ -189,9 +195,14 @@
               ((eq kb '=mj)
                nil)
               ((eq kb '==mj)
-               nil)
+               (or (eq ka '=mj)
+                   (eq ka '=>>mj)
+                   (eq ka '==mj))
+               )
               ((eq kb '=>>mj)
-               nil)
+               (or (eq ka '=mj)
+                   (eq ka '=>>mj))
+               )
               ((and (setq b-id (charset-id kb))
                     (charset-id-adobe-japan1-p b-id))
                nil)
@@ -229,6 +240,26 @@
 ;;;
 
 ;;;###autoload
+(defun char-ucs-chars (character)
+  "Return list of UCS abstract characters unified by CHARACTER."
+  (let (ucs dest)
+    (if (and (setq ucs (encode-char character '=ucs))
+            (not (and (<= #x2E80 ucs)(<= ucs #x2EF3)))
+            (null (get-char-attribute character '=>ucs*)))
+       (setq dest (list character)))
+    (dolist (c (mapcan #'char-ucs-chars
+                      (get-char-attribute character '->subsumptive)))
+      (setq dest (adjoin c dest)))
+    (dolist (c (mapcan #'char-ucs-chars
+                      (get-char-attribute character '->denotational)))
+      (setq dest (adjoin c dest)))
+    (dolist (c (mapcan #'char-ucs-chars
+                      (get-char-attribute character '->denotational@component)))
+      (setq dest (adjoin c dest)))
+    dest))
+
+
+;;;###autoload
 (defun map-char-family (function char &optional ignore-sisters)
   (let ((rest (list char))
        ret checked)