X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=ids-find.el;h=40b27b5d189a5bdfbc44a88a6729e65ffe182688;hb=5bb982218a899ed898c7405227a3871cd48ca0ca;hp=0a85b5b105fadfa06d060be485233260d7bcf1bf;hpb=ab7074fead0fe4d946a8a1b37be48f45f7af99b0;p=chise%2Fids.git diff --git a/ids-find.el b/ids-find.el index 0a85b5b..40b27b5 100644 --- a/ids-find.el +++ b/ids-find.el @@ -1,11 +1,11 @@ ;;; ids-find.el --- search utility based on Ideographic-structures -;; Copyright (C) 2002,2003,2005 MORIOKA Tomohiko +;; Copyright (C) 2002,2003,2005,2006,2007 MORIOKA Tomohiko ;; Author: MORIOKA Tomohiko ;; Keywords: Kanji, Ideographs, search, IDS, CHISE, UCS, Unicode -;; This file is a part of Tomoyo-Tools. +;; 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 @@ -25,14 +25,12 @@ ;;; Code: (defun ids-index-store-char (product component) - (let ((ret (get-char-attribute ; char-feature - component 'ideographic-products))) + (let ((ret (get-char-attribute component 'ideographic-products))) (unless (memq product ret) (put-char-attribute component 'ideographic-products - (cons product ret))) - ;; (when ret (setq ret (get-char-attribute ; char-feature - ;; component 'ideographic-structure)) - ;; (ids-index-store-structure product ret)) + (cons product ret)) + (when (setq ret (char-feature component 'ideographic-structure)) + (ids-index-store-structure product ret))) )) (defun ids-index-store-structure (product structure) @@ -44,8 +42,8 @@ (ids-index-store-char product cell)) ((setq ret (assq 'ideographic-structure cell)) (ids-index-store-structure product (cdr ret))) - ;; ((setq ret (find-char cell)) - ;; (ids-index-store-char product ret)) + ((setq ret (find-char cell)) + (ids-index-store-char product ret)) )))) ;;;###autoload @@ -92,19 +90,23 @@ (defun char-component-variants (char) (let ((dest (list char)) ret uchr) + (dolist (feature (to-component-features)) + (if (setq ret (get-char-attribute char feature)) + (dolist (c ret) + (setq dest (union dest (char-component-variants c)))))) (cond - ((setq ret (some (lambda (feature) - (get-char-attribute char feature)) - (to-component-features))) - (dolist (c ret) - (setq dest (union dest (char-component-variants c)))) - ) + ;; ((setq ret (some (lambda (feature) + ;; (get-char-attribute char feature)) + ;; (to-component-features))) + ;; (dolist (c ret) + ;; (setq dest (union dest (char-component-variants c)))) + ;; ) ((setq ret (get-char-attribute char '->ucs-unified)) (setq dest (cons char ret)) (dolist (c dest) (setq dest (union dest (some (lambda (feature) - (get-char-attribute char feature)) + (get-char-attribute c feature)) (of-component-features)) ))) ) @@ -114,7 +116,7 @@ (dolist (c dest) (setq dest (union dest (some (lambda (feature) - (get-char-attribute char feature)) + (get-char-attribute c feature)) (of-component-features)) ))) ) @@ -137,28 +139,46 @@ ;;;###autoload (defun ideographic-products-find (&rest components) (if (stringp (car components)) - (setq components (car components))) - (let ((len (length components)) - (i 1) - dest products) - (dolist (variant (char-component-variants (elt components 0))) - (dolist (product (get-char-attribute variant 'ideographic-products)) - (unless (memq product products) - (setq products (cons product products))))) + (setq components (string-to-char-list (car components)))) + (let (dest products) + (dolist (variant (char-component-variants (car components))) + (setq products + (union products + (get-char-attribute variant 'ideographic-products)))) (setq dest products) - (while (and - (< i len) - (progn - (setq products nil) - (dolist (variant (char-component-variants (elt components i))) - (dolist (product (get-char-attribute - variant 'ideographic-products)) - (unless (memq product products) - (when (memq product dest) - (setq products (cons product products)))))) - (setq dest products))) - (setq i (1+ i))) - products)) + (while (and dest + (setq components (cdr components))) + (setq products nil) + (dolist (variant (char-component-variants (car components))) + (setq products + (union products + (get-char-attribute variant 'ideographic-products)))) + (setq dest (intersection dest products))) + dest)) +;; (defun ideographic-products-find (&rest components) +;; (if (stringp (car components)) +;; (setq components (car components))) +;; (let ((len (length components)) +;; (i 1) +;; dest products) +;; (dolist (variant (char-component-variants (elt components 0))) +;; (setq products +;; (union products +;; (get-char-attribute variant 'ideographic-products)))) +;; (setq dest products) +;; (while (and +;; (< i len) +;; (progn +;; (setq products nil) +;; (dolist (variant (char-component-variants (elt components i))) +;; (dolist (product (get-char-attribute +;; variant 'ideographic-products)) +;; (unless (memq product products) +;; (when (memq product dest) +;; (setq products (cons product products)))))) +;; (setq dest products))) +;; (setq i (1+ i))) +;; products)) (defun ideographic-structure-char= (c1 c2) @@ -168,26 +188,29 @@ (m2 (char-ucs c2))) (or (and m1 m2 (eq m1 m2)) - (some (lambda (feature) - (some (lambda (b2) - (unless (characterp b2) - (setq b2 (find-char b2))) - (and b2 - (ideographic-structure-char= c1 b2))) - (char-feature c2 feature) - ;; (get-char-attribute - ;; c2 '<-ideographic-component-forms) - )) - (of-component-features)) - (progn - (setq m1 (car (get-char-attribute c1 '<-radical)) - m2 (car (get-char-attribute c2 '<-radical))) - (unless (characterp m1) - (setq m1 (find-char m1))) - (unless (characterp m2) - (setq m2 (find-char m2))) - (when (or m1 m2) - (ideographic-structure-char= m1 m2)))))))) + (memq c1 (char-component-variants c2)) + ;; (some (lambda (feature) + ;; (some (lambda (b2) + ;; (unless (characterp b2) + ;; (setq b2 (find-char b2))) + ;; (and b2 + ;; (ideographic-structure-char= c1 b2))) + ;; (char-feature c2 feature) + ;; ;; (get-char-attribute + ;; ;; c2 '<-ideographic-component-forms) + ;; )) + ;; (of-component-features)) + ;; (progn + ;; (setq m1 (car (get-char-attribute c1 '<-radical)) + ;; m2 (car (get-char-attribute c2 '<-radical))) + ;; (unless (characterp m1) + ;; (setq m1 (find-char m1))) + ;; (unless (characterp m2) + ;; (setq m2 (find-char m2))) + ;; (when (or m1 m2) + ;; (ideographic-structure-char= m1 m2)) + ;; ) + ))))) (defun ideographic-structure-member-compare-components (component s-component) (let (ret) @@ -259,25 +282,46 @@ (or (ideographic-structure-to-ids v) v))) -(defun ids-insert-chars-including-components (components level) - (let (is dis i) - (dolist (c (ideographic-products-find components)) - (setq is (char-feature c 'ideographic-structure)) - ;; to avoid problems caused by wrong indexes - (when (every (lambda (cc) - (ideographic-structure-member cc is)) - components) - ;;(ids-insert-chars-including-components (char-to-string c) (1+ level)) +(defun ids-insert-chars-including-components (components + &optional level ignored-chars) + (unless level + (setq level 0)) + (let (is i as bs) + (dolist (c (sort (copy-tree (ideographic-products-find components)) + (lambda (a b) + (if (setq as (char-total-strokes a)) + (if (setq bs (char-total-strokes b)) + (if (= as bs) + (ideograph-char< a b) + (< as bs)) + t) + (ideograph-char< a b))))) + (unless (memq c ignored-chars) + (setq is (char-feature c 'ideographic-structure)) (setq i 0) (while (< i level) (insert "\t") (setq i (1+ i))) (insert (ids-find-format-line c is)) - ;;(forward-line -1) - (ids-insert-chars-including-components - (char-to-string c) (1+ level)) - ) - ))) + (setq ignored-chars + (ids-insert-chars-including-components + (char-to-string c) (1+ level) + (cons c ignored-chars)))) + )) + ignored-chars) +;; (defun ids-insert-chars-including-components (components level) +;; (let (is dis i) +;; (dolist (c (ideographic-products-find components)) +;; (setq is (char-feature c 'ideographic-structure)) +;; (setq i 0) +;; (while (< i level) +;; (insert "\t") +;; (setq i (1+ i))) +;; (insert (ids-find-format-line c is)) +;; ;;(forward-line -1) +;; (ids-insert-chars-including-components +;; (char-to-string c) (1+ level)) +;; ))) ;;;###autoload (defun ids-find-chars-including-components (components)