projects / chise / ids.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
update.
[chise/ids.git] / ids-find.el
diff --git a/ids-find.el b/ids-find.el
index 3c46851..b0afbdd 100644 (file)
--- a/ids-find.el
+++ b/ids-find.el
@@ -1,6 +1,6 @@
 ;;; ids-find.el --- search utility based on Ideographic-structures ;; -*- coding: utf-8-mcs-er -*-
 
-;; Copyright (C) 2002, 2003, 2005, 2006, 2007, 2017, 2020, 2021
+;; Copyright (C) 2002, 2003, 2005, 2006, 2007, 2017, 2020, 2021, 2022, 2023
 ;;   MORIOKA Tomohiko
 
 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
@@ -31,7 +31,14 @@
       (put-char-attribute component 'ideographic-products
                          (cons product ret))
       (when (setq ret (char-feature component 'ideographic-structure))
-       (ids-index-store-structure product ret)))
+       (ids-index-store-structure product ret))
+      (when (setq ret (char-feature component 'ideographic-structure@apparent))
+       (ids-index-store-structure product ret))
+      (when (setq ret (char-feature component 'ideographic-structure@apparent/leftmost))
+       (ids-index-store-structure product ret))
+      (when (setq ret (char-feature component 'ideographic-structure@apparent/rightmost))
+       (ids-index-store-structure product ret))
+      )
     ))
 
 (defun ids-index-store-structure (product structure)
@@ -43,6 +50,12 @@
             (ids-index-store-char product cell))
            ((setq ret (assq 'ideographic-structure cell))
             (ids-index-store-structure product (cdr ret)))
+           ((setq ret (assq 'ideographic-structure@apparent cell))
+            (ids-index-store-structure product (cdr ret)))
+           ((setq ret (assq 'ideographic-structure@apparent/leftmost cell))
+            (ids-index-store-structure product (cdr ret)))
+           ((setq ret (assq 'ideographic-structure@apparent/rightmost cell))
+            (ids-index-store-structure product (cdr ret)))
            ((setq ret (find-char cell))
             (ids-index-store-char product ret))
            ))))
@@ -60,6 +73,62 @@
      (ids-index-store-structure c v)
      nil)
    'ideographic-structure@apparent)
+  (map-char-attribute
+   (lambda (c v)
+     (ids-index-store-structure c v)
+     nil)
+   'ideographic-structure@apparent/leftmost)
+  (map-char-attribute
+   (lambda (c v)
+     (ids-index-store-structure c v)
+     nil)
+   'ideographic-structure@apparent/rightmost)
+  (let (products ucs)
+    (map-char-attribute
+     (lambda (c v)
+       (setq products (get-char-attribute c 'ideographic-products))
+       (dolist (comp (delq c (char-ucs-chars c)))
+        (dolist (p_c (get-char-attribute comp 'ideographic-products))
+          (unless (encode-char p_c '=ucs)
+            (if (setq ucs (char-ucs p_c))
+                (setq p_c (decode-char '=ucs ucs))))
+          (setq products (adjoin p_c products))))
+       (put-char-attribute c 'ideographic-products products)
+       nil)
+     '=>iwds-1)
+    (map-char-attribute
+     (lambda (c v)
+       (setq products (get-char-attribute c 'ideographic-products))
+       (dolist (comp (delq c (char-ucs-chars c)))
+        (dolist (p_c (get-char-attribute comp 'ideographic-products))
+          (unless (encode-char p_c '=ucs)
+            (if (setq ucs (char-ucs p_c))
+                (setq p_c (decode-char '=ucs ucs))))
+          (setq products (adjoin p_c products))))
+       (put-char-attribute c 'ideographic-products products)
+       nil)
+     '=>ucs@iwds-1)
+    (map-char-attribute
+     (lambda (c v)
+       (setq products (get-char-attribute c 'ideographic-products))
+       (dolist (comp (delq c (char-ucs-chars c)))
+        (put-char-attribute
+         comp 'ideographic-products
+         (union products
+                (get-char-attribute comp 'ideographic-products))))
+       )
+     '=>iwds-1)
+    (map-char-attribute
+     (lambda (c v)
+       (setq products (get-char-attribute c 'ideographic-products))
+       (dolist (comp (delq c (char-ucs-chars c)))
+        (put-char-attribute
+         comp 'ideographic-products
+         (union products
+                (get-char-attribute comp 'ideographic-products))))
+       )
+     '=>ucs@iwds-1)
+    )
   (unless in-memory
     (save-char-attribute-table 'ideographic-products)))
 
@@ -572,6 +641,12 @@
                     (ideographic-structure-equal str structure))
                (and (setq str
                           (get-char-attribute pc 'ideographic-structure@apparent))
+                    (ideographic-structure-equal str structure))
+               (and (setq str
+                          (get-char-attribute pc 'ideographic-structure@apparent/leftmost))
+                    (ideographic-structure-equal str structure))
+               (and (setq str
+                          (get-char-attribute pc 'ideographic-structure@apparent/rightmost))
                     (ideographic-structure-equal str structure)))
        (setq pl (cons pc pl))
        ))
@@ -764,6 +839,9 @@ COMPONENT can be a character or char-spec."
        ret dest sub)
     (while rest
       (setq cell (pop rest))
+      (if (and (consp cell)
+              (setq ret (find-char cell)))
+         (setq cell ret))
       (cond
        ((and (consp cell)
             (cond ((setq ret (assq 'ideographic-structure cell))
@@ -954,7 +1032,28 @@ COMPONENT can be a character or char-spec."
                  a-res
                  (list ?⿰ new-str-c (nth 2 enc-str))
                  210))
-         )))
+         )
+        ((eq (car enc-str) ?⿱)
+         (unless conversion-only
+           (setq f-res (ids-find-chars-including-ids enc-str)))
+         (setq new-str (list ?⿰
+                             (nth 2 structure)
+                             (nth 2 enc-str)))
+         (setq new-str-c
+               (if (setq ret (ideographic-structure-find-chars new-str))
+                   (car ret)
+                 (list (cons 'ideographic-structure new-str))))
+         (if conversion-only
+             (list ?⿱ (nth 1 enc-str) new-str-c)
+           (setq a-res (ids-find-chars-including-ids new-str))
+           (list enc
+                 f-res
+                 new-str-c
+                 a-res
+                 (list ?⿱ (nth 1 enc-str) new-str-c)
+                 220))
+         )
+        ))
       )
      ((eq (get-char-attribute (car structure) '=ucs-itaiji-001) #x2FF6)
       (setq enc (nth 1 structure))
@@ -1542,9 +1641,29 @@ COMPONENT can be a character or char-spec."
                    new-str-c
                    a-res
                    (list ?⿲ (nth 1 enc2-str) new-str-c (nth 2 enc2-str))
-                   630))
-           )
-         )))
+                   630)))
+         )
+        ((eq (car enc-str) ?⿵)
+         (unless conversion-only
+           (setq f-res (ids-find-chars-including-ids enc-str)))
+         (setq new-str (list ?⿱
+                             (nth 2 enc-str)
+                             (nth 2 structure)))
+         (setq new-str-c
+               (if (setq ret (ideographic-structure-find-chars new-str))
+                   (car ret)
+                 (list (cons 'ideographic-structure new-str))))
+         (if conversion-only
+             (list ?⿵ (nth 1 enc-str) new-str-c)
+           (setq a-res (ids-find-chars-including-ids new-str))
+           (list enc
+                 f-res
+                 new-str-c
+                 a-res
+                 (list ?⿵ (nth 1 enc-str) new-str-c)
+                 640))
+         )
+        ))
       )
      ((eq (car structure) ?⿷)
       (setq enc (nth 1 structure))
@@ -1575,18 +1694,69 @@ COMPONENT can be a character or char-spec."
                  a-res
                  (list ?⿺ (nth 1 enc-str) new-str-c)
                  710))
-         )))
+         )
+        ((eq (car enc-str) ?⿸)
+         (unless conversion-only
+           (setq f-res (ids-find-chars-including-ids enc-str)))
+         (cond
+          ((and (characterp (nth 2 enc-str))
+                (or (memq (char-ucs (nth 2 enc-str))
+                          '(#x4EBA #x5165 #x513F #x51E0))
+                    (memq (or (encode-char (nth 2 enc-str) '=>ucs@iwds-1)
+                              (encode-char (nth 2 enc-str) '=>ucs@component))
+                          '(#x4EBA #x513F))))
+           (setq new-str (list ?⿺
+                               (nth 2 enc-str)
+                               (nth 2 structure)))
+           (setq new-str-c
+                 (if (setq ret (ideographic-structure-find-chars new-str))
+                     (car ret)
+                   (list (cons 'ideographic-structure new-str))))
+           (if conversion-only
+               (list ?⿸ (nth 1 enc-str) new-str-c)
+             (setq a-res (ids-find-chars-including-ids new-str))
+             (list enc
+                   f-res
+                   new-str-c
+                   a-res
+                   (list ?⿸ (nth 1 enc-str) new-str-c)
+                   721))
+           )
+          (t
+           (setq new-str (list ?⿱
+                               (nth 2 structure)
+                               (nth 2 enc-str)))
+           (setq new-str-c
+                 (if (setq ret (ideographic-structure-find-chars new-str))
+                     (car ret)
+                   (list (cons 'ideographic-structure new-str))))
+           (if conversion-only
+               (list ?⿸ (nth 1 enc-str) new-str-c)
+             (setq a-res (ids-find-chars-including-ids new-str))
+             (list enc
+                   f-res
+                   new-str-c
+                   a-res
+                   (list ?⿸ (nth 1 enc-str) new-str-c)
+                   722))
+           ))
+         )
+        ))
       )
      ((eq (car structure) ?⿺)
       (setq enc (nth 1 structure))
       (when (setq enc-str
                  (cond ((characterp enc)
                         (or (get-char-attribute enc 'ideographic-structure)
-                            (get-char-attribute enc 'ideographic-structure@apparent))
+                            (get-char-attribute enc 'ideographic-structure@apparent)
+                            (get-char-attribute enc 'ideographic-structure@apparent/leftmost)
+                            (get-char-attribute enc 'ideographic-structure@apparent/rightmost))
                         )
                        ((consp enc)
                         (or (cdr (assq 'ideographic-structure enc))
-                            (cdr (assq 'ideographic-structure@apparent enc)))
+                            (cdr (assq 'ideographic-structure@apparent enc))
+                            (cdr (assq 'ideographic-structure@apparent/leftmost enc))
+                            (cdr (assq 'ideographic-structure@apparent/rightmost enc)))
                         )))
         ;; (setq enc-str
         ;;       (mapcar (lambda (cell)
@@ -1632,7 +1802,9 @@ COMPONENT can be a character or char-spec."
                     (memq (encode-char (nth 2 enc-str) '=>ucs@component)
                           '(#x2123C #x58EC))
                     (eq (encode-char (nth 2 enc-str) '=>ucs@iwds-1)
-                        #x7389)))
+                        #x7389)
+                    (eq (encode-char (nth 2 enc-str) '=>big5-cdp)
+                        #x8D71)))
            (unless conversion-only
              (setq f-res (ids-find-chars-including-ids enc-str)))
            (setq new-str (list ?⿰