From: MORIOKA Tomohiko Date: Tue, 23 Jun 2020 06:22:21 +0000 (+0900) Subject: (ideographic-structure-merge-components-alist): New function. X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=3d11f3b32760d7d2affaf1407eee99d1219afa91;p=chise%2Fids.git (ideographic-structure-merge-components-alist): New function. (ideographic-structure-to-components-alist): New function. (ideographic-structure-to-components-alist*): New function. (ideographic-structure-equal): New function. (ideographic-structure-character=): New function. (ideographic-structure-find-chars): New function. (ideographic-structure-find-chars*): New function. (ideographic-char-count-components): New function. --- diff --git a/ids-find.el b/ids-find.el index 181e948..baed758 100644 --- a/ids-find.el +++ b/ids-find.el @@ -5,7 +5,7 @@ ;; Author: MORIOKA Tomohiko ;; Keywords: Kanji, Ideographs, search, IDS, CHISE, UCS, Unicode -;; This file is a part of CHISE IDS. +;; This file is a part of CHISE-IDS. ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU General Public License as @@ -412,6 +412,168 @@ (view-buffer ids-find-result-buffer)) +(defun ideographic-structure-merge-components-alist (ca1 ca2) + (let ((dest-alist ca1) + ret) + (dolist (cell ca2) + (if (setq ret (assq (car cell) dest-alist)) + (setcdr ret (+ (cdr ret)(cdr cell))) + (setq dest-alist (cons cell dest-alist)))) + dest-alist)) + +(defun ideographic-structure-to-components-alist (structure) + (apply #'ideographic-structure-to-components-alist* structure)) + +(defun ideographic-structure-to-components-alist* (operator component1 component2 + &optional component3 + &rest opts) + (let (dest-alist ret) + (setq dest-alist + (cond ((characterp component1) + (unless (encode-char component1 'ascii) + (list (cons component1 1))) + ) + ((setq ret (assq 'ideographic-structure component1)) + (ideographic-structure-to-components-alist (cdr ret)) + ) + ((setq ret (find-char component1)) + (list (cons ret 1)) + ))) + (setq dest-alist + (ideographic-structure-merge-components-alist + dest-alist + (cond ((characterp component2) + (unless (encode-char component2 'ascii) + (list (cons component2 1))) + ) + ((setq ret (assq 'ideographic-structure component2)) + (ideographic-structure-to-components-alist (cdr ret)) + ) + ((setq ret (find-char component2)) + (list (cons ret 1)) + )))) + (if (memq operator '(?\u2FF2 ?\u2FF3)) + (ideographic-structure-merge-components-alist + dest-alist + (cond ((characterp component3) + (unless (encode-char component3 'ascii) + (list (cons component3 1))) + ) + ((setq ret (assq 'ideographic-structure component3)) + (ideographic-structure-to-components-alist (cdr ret)) + ) + ((setq ret (find-char component3)) + (list (cons ret 1)) + ))) + dest-alist))) + +;;;###autoload +(defun ideographic-structure-equal (structure1 structure2) + (and (eq (car structure1)(car structure2)) + (ideographic-structure-character= (nth 1 structure1)(nth 1 structure2)) + (ideographic-structure-character= (nth 2 structure1)(nth 2 structure2)) + (if (memq (car structure1) '(?\u2FF2 ?\u2FF3)) + (ideographic-structure-character= (nth 3 structure1)(nth 3 structure2)) + t))) + +;;;###autoload +(defun ideographic-structure-character= (c1 c2) + (let (ret ret2) + (cond ((characterp c1) + (cond ((encode-char c1 'ascii) + ) + ((characterp c2) + (or (eq c1 c2) + (encode-char c2 'ascii)) + ) + ((setq ret2 (find-char c2)) + (eq c1 ret2) + ) + ((setq ret2 (assq 'ideographic-structure c2)) + (and (setq ret (get-char-attribute c1 'ideographic-structure)) + (ideographic-structure-equal ret (cdr ret2))) + )) + ) + ((setq ret (assq 'ideographic-structure c1)) + (cond ((characterp c2) + (or (encode-char c2 'ascii) + (and (setq ret2 (get-char-attribute c2 'ideographic-structure)) + (ideographic-structure-equal (cdr ret) ret2))) + ) + ((setq ret2 (find-char c2)) + (and (setq ret2 (get-char-attribute c2 'ideographic-structure)) + (ideographic-structure-equal (cdr ret) ret2)) + ) + ((setq ret2 (assq 'ideographic-structure c2)) + (ideographic-structure-equal (cdr ret)(cdr ret2)) + )) + ) + ((setq ret (find-char c1)) + (cond ((characterp c2) + (or (eq ret c2) + (encode-char c2 'ascii)) + ) + ((setq ret2 (find-char c2)) + (eq ret ret2) + ) + ((setq ret2 (assq 'ideographic-structure c2)) + (and (setq ret (get-char-attribute c1 'ideographic-structure)) + (ideographic-structure-equal ret (cdr ret2)) + ))))))) + +;;;###autoload +(defun ideographic-structure-find-chars (structure) + (apply #'ideographic-structure-find-chars* structure)) + +(defun ideographic-structure-find-chars* (operator component1 component2 + &optional component3) + (let ((comp-alist (ideographic-structure-to-components-alist* + operator component1 component2 component3)) + c1 c2 c3 + ret pl str) + (dolist (pc (caar + (sort (mapcar (lambda (cell) + (if (setq ret (get-char-attribute + (car cell) 'ideographic-products)) + (cons ret (length ret)) + (cons nil 0))) + comp-alist) + (lambda (a b) + (< (cdr a)(cdr b)))))) + (when (and (setq str (get-char-attribute pc 'ideographic-structure)) + (eq (car str) operator) + (setq c1 (nth 1 str)) + (ideographic-structure-character= c1 component1) + (setq c2 (nth 2 str)) + (ideographic-structure-character= c2 component2) + (cond ((memq (car str) '(?\u2FF2 ?\u2FF3)) + (setq c3 (nth 3 str)) + (ideographic-structure-character= c3 component3) + ) + (t))) + (setq pl (cons pc pl)) + )) + pl)) + +;;;###autoload +(defun ideographic-char-count-components (char component) + (let ((dest 0) + structure) + (cond ((eq char component) + 1) + ((setq structure (get-char-attribute char 'ideographic-structure)) + (dolist (cell (ideographic-structure-to-components-alist structure)) + (setq dest + (+ dest + (if (eq (car cell) char) + (cdr cell) + (* (ideographic-char-count-components (car cell) component) + (cdr cell)))))) + dest) + (t + 0)))) + + ;;; @ End. ;;;