X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;ds=sidebyside;f=ids-find.el;h=be0c66eb14e15d09985cee39d0fb53d6091abe45;hb=90c8359b7317df21246668ac6fd1a0bacee4f42f;hp=576718ff76dd60c06230c1ed05d7a19e3399a09e;hpb=19573c0f2925166fcc42324ec872c1c46576a6b5;p=chise%2Fids.git diff --git a/ids-find.el b/ids-find.el index 576718f..be0c66e 100644 --- a/ids-find.el +++ b/ids-find.el @@ -1,6 +1,7 @@ ;;; ids-find.el --- search utility based on Ideographic-structures ;; -*- coding: utf-8-mcs-er -*- -;; Copyright (C) 2002, 2003, 2005, 2006, 2007, 2017, 2020 MORIOKA Tomohiko +;; Copyright (C) 2002, 2003, 2005, 2006, 2007, 2017, 2020, 2021 +;; MORIOKA Tomohiko ;; Author: MORIOKA Tomohiko ;; Keywords: Kanji, Ideographs, search, IDS, CHISE, UCS, Unicode @@ -599,16 +600,20 @@ (defun ideographic-character-get-structure (character) "Return ideographic-structure of CHARACTER. CHARACTER can be a character or char-spec." - (let (ret) - (cond ((characterp character) - (get-char-attribute character 'ideographic-structure) - ) - ((setq ret (assq 'ideographic-structure character)) - (cdr ret) - ) - ((setq ret (find-char character)) - (get-char-attribute ret 'ideographic-structure) - )))) + (mapcar (lambda (cell) + (or (and (listp cell) + (find-char cell)) + cell)) + (let (ret) + (cond ((characterp character) + (get-char-attribute character 'ideographic-structure) + ) + ((setq ret (assq 'ideographic-structure character)) + (cdr ret) + ) + ((setq ret (find-char character)) + (get-char-attribute ret 'ideographic-structure) + ))))) ;;;###autoload (defun ideographic-char-match-component (char component) @@ -768,9 +773,15 @@ COMPONENT can be a character or char-spec." (setq sub cell) ))) (setq cell - (if (setq ret (ideographic-structure-find-chars sub)) - (car ret) - (list (cons 'ideographic-structure sub)))) + (cond ((setq ret (ideographic-structure-find-chars sub)) + (car ret) + ) + ((setq ret (ideographic-structure-compact sub)) + (list (cons 'ideographic-structure ret)) + ) + (t + (list (cons 'ideographic-structure sub)))) + ) )) (setq dest (cons cell dest))) (nreverse dest))) @@ -778,7 +789,8 @@ COMPONENT can be a character or char-spec." (defun ideographic-structure-compare-functional-and-apparent (structure &optional char conversion-only) - (let (enc enc-str enc2-str new-str new-str-c f-res a-res ret code) + (let (enc enc-str enc2-str enc3-str new-str new-str-c + f-res a-res ret code) (cond ((eq (car structure) ?⿸) (setq enc (nth 1 structure)) @@ -942,7 +954,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)) @@ -1399,26 +1432,69 @@ COMPONENT can be a character or char-spec." 601)) ) ((and (setq enc2-str (ideographic-character-get-structure (nth 2 enc-str))) - (eq (car enc2-str) ?⿰)) + (cond + ((eq (car enc2-str) ?⿰) + (setq code 611) + ) + ((eq (car enc2-str) ?⿲) + (setq code 614) + ) + ((and (eq (car enc2-str) ?⿱) + (setq enc3-str + (ideographic-character-get-structure (nth 2 enc2-str))) + (eq (car enc3-str) ?⿰)) + (setq code 613) + ))) (unless conversion-only (setq f-res (ids-find-chars-including-ids enc-str))) - (setq new-str (list ?⿲ - (nth 1 enc2-str) - (nth 2 structure) - (nth 2 enc2-str))) + (setq new-str + (cond ((eq code 611) + (list ?⿲ + (nth 1 enc2-str) + (nth 2 structure) + (nth 2 enc2-str)) + ) + ((eq code 613) + (list ?⿲ + (nth 1 enc3-str) + (nth 2 structure) + (nth 2 enc3-str)) + ) + ((eq code 614) + (list ?⿲ + (nth 1 enc2-str) + (list (list 'ideographic-structure + ?⿱ + (nth 2 enc2-str) + (nth 2 structure))) + (nth 3 enc2-str)) + ))) (setq new-str-c (if (setq ret (ideographic-structure-find-chars new-str)) (car ret) - (list (cons 'ideographic-structure new-str)))) + (list (cons 'ideographic-structure + (ideographic-structure-compact new-str))))) (if conversion-only - (list ?⿱ (nth 1 enc-str) new-str-c) + (cond ((or (eq code 611) + (eq code 614)) + (list ?⿱ (nth 1 enc-str) new-str-c) + ) + ((eq code 613) + (list ?⿳ (nth 1 enc-str)(nth 1 enc2-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) - 611)) + (cond ((or (eq code 611) + (eq code 614)) + (list ?⿱ (nth 1 enc-str) new-str-c) + ) + ((eq code 613) + (list ?⿳ (nth 1 enc-str)(nth 1 enc2-str) new-str-c) + )) + code)) )) ) ((eq (car enc-str) ?⿳) @@ -1533,12 +1609,12 @@ COMPONENT can be a character or char-spec." (or (cdr (assq 'ideographic-structure enc)) (cdr (assq 'ideographic-structure@apparent enc))) ))) - (setq enc-str - (mapcar (lambda (cell) - (or (and (listp cell) - (find-char cell)) - cell)) - enc-str)) + ;; (setq enc-str + ;; (mapcar (lambda (cell) + ;; (or (and (listp cell) + ;; (find-char cell)) + ;; cell)) + ;; enc-str)) (cond ((eq (car enc-str) ?⿱) (cond @@ -1569,11 +1645,15 @@ COMPONENT can be a character or char-spec." code)) ) ((and (characterp (nth 2 enc-str)) - (memq (char-ucs (nth 2 enc-str)) - '(#x4E00 - #x706C - #x65E5 #x66F0 #x5FC3 - #x2123C #x58EC #x738B #x7389))) + (or (memq (char-ucs (nth 2 enc-str)) + '(#x4E00 + #x706C + #x65E5 #x66F0 #x5FC3 + #x2123C #x58EC #x738B #x7389)) + (memq (encode-char (nth 2 enc-str) '=>ucs@component) + '(#x2123C #x58EC)) + (eq (encode-char (nth 2 enc-str) '=>ucs@iwds-1) + #x7389))) (unless conversion-only (setq f-res (ids-find-chars-including-ids enc-str))) (setq new-str (list ?⿰