-(defun ideographic-chars-to-is-a-tree (chars)
- (let (comp char products others dest rest
- la lb)
- (setq chars (sort chars #'ideographic-structure-char<))
- (while chars
- (setq comp (pop chars)
- rest chars
- products nil
- others nil)
- (while rest
- (setq char (pop rest))
- (cond
- ((ideographic-char-match-component char comp)
- (push char products)
- )
- (t
- (push char others)
- )))
- (push (cons comp
- ;; (nreverse products)
- (if products
- (sort (ideographic-chars-to-is-a-tree products)
- (lambda (a b)
- (setq la (length (cdr a))
- lb (length (cdr b)))
- (or (> la lb)
- (and (= la lb)
- (ideograph-char< (car a) (car b))
- ;; (progn
- ;; (setq tsa (char-total-strokes (car a))
- ;; tsb (char-total-strokes (car b)))
- ;; (if tsa
- ;; (if tsb
- ;; (or (< tsa tsb)
- ;; (and (= tsa tsb)
- ;; (ideograph-char<
- ;; (car a) (car b))))
- ;; t)
- ;; (if tsb
- ;; nil
- ;; (ideograph-char< (car a) (car b)))))
- ))))
- nil)
- )
- dest)
- (setq chars others))
- dest))
-
-(defun ids-find-chars-including-ids* (operator component1 component2
- &optional component3)
- (let ((comp-alist (ideographic-structure-to-components-alist*
- operator component1 component2 component3))
- (comp-spec
- (list (list* 'ideographic-structure
- operator component1 component2
- (if component3
- (list component3)))))
- ret str rest)
- (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 (every (lambda (cell)
- (>= (ideographic-char-count-components pc (car cell))
- (cdr cell)))
- comp-alist)
- (or (ideographic-char-match-component pc comp-spec)
- (and (setq str (get-char-attribute pc 'ideographic-structure))
- (ideographic-char-match-component
- (list
- (cons
- 'ideographic-structure
- (functional-ideographic-structure-to-apparent-structure
- str)))
- comp-spec))))
- (push pc rest)))
- (ideographic-chars-to-is-a-tree rest)))
-
-(defun ids-find-chars-including-ids (structure)
- (if (characterp structure)
- (setq structure (get-char-attribute structure 'ideographic-structure)))
- (apply #'ids-find-chars-including-ids* structure))
-
-(defun functional-ideographic-structure-to-apparent-structure (structure)
- (ideographic-structure-compact
- (let (enc enc-str enc2-str new-str)
- (cond
- ((eq (car structure) ?⿸)
- (setq enc (nth 1 structure))
- (when (setq enc-str
- (cond ((characterp enc)
- (get-char-attribute enc 'ideographic-structure)
- )
- ((consp enc)
- (cdr (assq 'ideographic-structure enc))
- )))
- (cond
- ((eq (car enc-str) ?⿰)
- (list ?⿰ (nth 1 enc-str)
- (list (list 'ideographic-structure
- ?⿱
- (nth 2 enc-str)
- (nth 2 structure))))
- )
- ((and (eq (car enc-str) ?⿲)
- (memq (char-ucs (nth 1 enc-str)) '(#x4EBB #x2E85))
- (eq (nth 2 enc-str) ?丨))
- (list ?⿰
- (decode-char '=big5-cdp #x8B7A)
- (list (list 'ideographic-structure
- ?⿱
- (nth 3 enc-str)
- (nth 2 structure))))
- )
- ((eq (car enc-str) ?⿱)
- (list ?⿱ (nth 1 enc-str)
- (list
- (cons 'ideographic-structure
- (or (functional-ideographic-structure-to-apparent-structure
- (setq new-str
- (list
- (cond
- ((characterp (nth 2 enc-str))
- (if (or (eq (encode-char
- (nth 2 enc-str)
- '=>ucs@component)
- #x20087)
- (eq (encode-char
- (nth 2 enc-str)
- '=>ucs@component)
- #x5382)
- (eq (encode-char
- (nth 2 enc-str)
- '=>ucs@component)
- #x4E06)
- (eq (encode-char
- (nth 2 enc-str)
- '=big5-cdp)
- #x89CE)
- (eq (encode-char
- (nth 2 enc-str)
- '=>big5-cdp)
- #x88E2)
- (eq (encode-char
- (nth 2 enc-str)
- '=big5-cdp)
- #x88AD)
- (eq (or (encode-char
- (nth 2 enc-str)
- '=>big5-cdp)
- (encode-char
- (nth 2 enc-str)
- '=big5-cdp-itaiji-001))
- #x8766)
- (eq (car
- (get-char-attribute
- (nth 2 enc-str)
- 'ideographic-structure))
- ?⿸))
- ?⿸
- ?⿰))
- ((eq (car
- (cdr
- (assq 'ideographic-structure
- (nth 2 enc-str))))
- ?⿸)
- ?⿸)
- (t
- ?⿰))
- (nth 2 enc-str)
- (nth 2 structure)
- )))
- new-str))))
- )
- ((eq (car enc-str) ?⿸)
- (list ?⿸ (nth 1 enc-str)
- (list
- (cons 'ideographic-structure
- (setq new-str
- (list
- (cond
- ((characterp (nth 2 enc-str))
- (if (memq (char-ucs (nth 2 enc-str))
- '(#x5F73))
- ?⿰
- ?⿱)
- )
- (t
- ?⿱))
- (nth 2 enc-str)
- (nth 2 structure))))))
- )))
- )
- ((eq (car structure) ?⿹)
- (setq enc (nth 1 structure))
- (when (setq enc-str
- (cond ((characterp enc)
- (get-char-attribute enc 'ideographic-structure)
- )
- ((consp enc)
- (cdr (assq 'ideographic-structure enc))
- )))
- (cond
- ((eq (car enc-str) ?⿰)
- (list ?⿰
- (list (list 'ideographic-structure
- ?⿱
- (nth 1 enc-str)
- (nth 2 structure)))
- (nth 2 enc-str))
- )))
- )
- ((eq (get-char-attribute (car structure) '=ucs-itaiji-001) #x2FF6)
- (setq enc (nth 1 structure))
- (when (setq enc-str
- (cond ((characterp enc)
- (get-char-attribute enc 'ideographic-structure)
- )
- ((consp enc)
- (cdr (assq 'ideographic-structure enc))
- )))
- (cond
- ((eq (car enc-str) ?⿺)
- (list ?⿺
- (list (list 'ideographic-structure
- ?⿱
- (nth 2 structure)
- (nth 1 enc-str)))
- (nth 2 enc-str))
- )
- ((eq (car enc-str) ?⿱)
- (list ?⿱
- (list (list 'ideographic-structure
- ?⿰
- (nth 2 structure)
- (nth 1 enc-str)))
- (nth 2 enc-str))
- ))
- )
- )
- ((eq (car structure) ?⿴)
- (setq enc (nth 1 structure))
- (when (setq enc-str
- (cond ((characterp enc)
- (get-char-attribute enc 'ideographic-structure)
- )
- ((consp enc)
- (cdr (assq 'ideographic-structure enc))
- )))
- (cond
- ((eq (car enc-str) ?⿱)
- (cond
- ((and (characterp (nth 2 enc-str))
- (or (memq (char-ucs (nth 2 enc-str)) '(#x56D7 #x5F51 #x897F))
- (eq (char-feature (nth 2 enc-str) '=>big5-cdp)
- #x87A5)))
- (list ?⿱
- (nth 1 enc-str)
- (list (list 'ideographic-structure
- ?⿴
- (nth 2 enc-str)
- (nth 2 structure)))
- )