ids-find.el

   1 ;;; ids-find.el --- search utility based on Ideographic-structures ;; -*- coding: utf-8-mcs-er -*-
   2
   3 ;; Copyright (C) 2002, 2003, 2005, 2006, 2007, 2017, 2020, 2021
   4 ;;   MORIOKA Tomohiko
   5
   6 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
   7 ;; Keywords: Kanji, Ideographs, search, IDS, CHISE, UCS, Unicode
   8
   9 ;; This file is a part of CHISE-IDS.
  10
  11 ;; This program is free software; you can redistribute it and/or
  12 ;; modify it under the terms of the GNU General Public License as
  13 ;; published by the Free Software Foundation; either version 2, or (at
  14 ;; your option) any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with this program; see the file COPYING.  If not, write to
  23 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Code:
  27
  28 (defun ids-index-store-char (product component)
  29   (let ((ret (get-char-attribute component 'ideographic-products)))
  30     (unless (memq product ret)
  31       (put-char-attribute component 'ideographic-products
  32                           (cons product ret))
  33       (when (setq ret (char-feature component 'ideographic-structure))
  34         (ids-index-store-structure product ret)))
  35     ))
  36
  37 (defun ids-index-store-structure (product structure)
  38   (let (ret)
  39     (dolist (cell (cdr structure))
  40       (if (char-ref-p cell)
  41           (setq cell (plist-get cell :char)))
  42       (cond ((characterp cell)
  43              (ids-index-store-char product cell))
  44             ((setq ret (assq 'ideographic-structure cell))
  45              (ids-index-store-structure product (cdr ret)))
  46             ((setq ret (find-char cell))
  47              (ids-index-store-char product ret))
  48             ))))
  49
  50 ;;;###autoload
  51 (defun ids-update-index (&optional in-memory)
  52   (interactive)
  53   (map-char-attribute
  54    (lambda (c v)
  55      (ids-index-store-structure c v)
  56      nil)
  57    'ideographic-structure)
  58   (map-char-attribute
  59    (lambda (c v)
  60      (ids-index-store-structure c v)
  61      nil)
  62    'ideographic-structure@apparent)
  63   (map-char-attribute
  64    (lambda (c v)
  65      (ids-index-store-structure c v)
  66      nil)
  67    'ideographic-structure@apparent/leftmost)
  68   (unless in-memory
  69     (save-char-attribute-table 'ideographic-products)))
  70
  71
  72 (mount-char-attribute-table 'ideographic-products)
  73
  74 ;;;###autoload
  75 (defun ids-find-all-products (char)
  76   (let (dest)
  77     (dolist (cell (char-feature char 'ideographic-products))
  78       (unless (memq cell dest)
  79         (setq dest (cons cell dest)))
  80       (setq dest (union dest (ids-find-all-products cell))))
  81     dest))
  82
  83 (defun of-component-features ()
  84   (let (dest)
  85     (dolist (feature (char-attribute-list))
  86       (when (string-match "^<-.*[@/]component\\(/[^*/]+\\)*$"
  87                           (symbol-name feature))
  88         (push feature dest)))
  89     (list* '<-mistakable '->mistakable
  90            '<-formed '->formed
  91            '<-same '->same
  92            '<-original '->original
  93            '<-ancient '->ancient
  94            dest)))
  95
  96 (defun to-component-features ()
  97   (let (dest)
  98     (dolist (feature (char-attribute-list))
  99       (when (string-match "^->.*[@/]component\\(/[^*/]+\\)*$"
 100                           (symbol-name feature))
 101         (push feature dest)))
 102     dest))
 103
 104 ;;;###autoload
 105 (defun char-component-variants (char)
 106   (let ((dest (list char))
 107         ret uchr)
 108     (dolist (feature (to-component-features))
 109       (if (setq ret (get-char-attribute char feature))
 110           (dolist (c ret)
 111             (setq dest (union dest (char-component-variants c))))))
 112     (cond
 113      ;; ((setq ret (some (lambda (feature)
 114      ;;                    (get-char-attribute char feature))
 115      ;;                  (to-component-features)))
 116      ;;  (dolist (c ret)
 117      ;;    (setq dest (union dest (char-component-variants c))))
 118      ;;  )
 119      ((setq ret (get-char-attribute char '->ucs-unified))
 120       (setq dest (cons char ret))
 121       (dolist (c dest)
 122         (setq dest (union dest
 123                           (some (lambda (feature)
 124                                   (get-char-attribute c feature))
 125                                 (of-component-features))
 126                           )))
 127       )
 128      ((and (setq ret (get-char-attribute char '=>ucs))
 129            (setq uchr (decode-char '=ucs ret)))
 130       (setq dest (cons uchr (char-variants uchr)))
 131       (dolist (c dest)
 132         (setq dest (union dest
 133                           (some (lambda (feature)
 134                                   (get-char-attribute c feature))
 135                                 (of-component-features))
 136                           )))
 137       )
 138      (t
 139       (map-char-family
 140        (lambda (c)
 141          (unless (memq c dest)
 142            (setq dest (cons c dest)))
 143          (setq dest
 144                (union dest
 145                       (some (lambda (feature)
 146                               (char-feature c feature))
 147                             (of-component-features))
 148                       ))
 149          nil)
 150        char)
 151       ))
 152     dest))
 153
 154 ;;;###autoload
 155 (defun ideographic-products-find (&rest components)
 156   (if (stringp (car components))
 157       (setq components (string-to-char-list (car components))))
 158   (let (dest products)
 159     (dolist (variant (char-component-variants (car components)))
 160       (setq products
 161             (union products
 162                    (get-char-attribute variant 'ideographic-products))))
 163     (setq dest products)
 164     (while (and dest
 165                 (setq components (cdr components)))
 166       (setq products nil)
 167       (dolist (variant (char-component-variants (car components)))
 168         (setq products
 169               (union products
 170                      (get-char-attribute variant 'ideographic-products))))
 171       (setq dest (intersection dest products)))
 172     dest))
 173
 174 (defun ideograph-find-products-with-variants (components &optional ignored-chars)
 175   (if (stringp components)
 176       (setq components (string-to-char-list components)))
 177   (let (dest products)
 178     (dolist (variant (char-component-variants (car components)))
 179       (setq products
 180             (union products
 181                    (set-difference
 182                     (get-char-attribute variant 'ideographic-products)
 183                     ignored-chars))))
 184     (setq dest products)
 185     (while (and dest
 186                 (setq components (cdr components)))
 187       (setq products nil)
 188       (dolist (variant (char-component-variants (car components)))
 189         (setq products
 190               (union products
 191                      (set-difference
 192                       (get-char-attribute variant 'ideographic-products)
 193                       ignored-chars))))
 194       (setq dest (intersection dest products)))
 195     dest))
 196
 197 (defun ideograph-find-products (components &optional ignored-chars)
 198   (if (stringp components)
 199       (setq components (string-to-char-list components)))
 200   (let (dest products)
 201     ;; (dolist (variant (char-component-variants (car components)))
 202     ;;   (setq products
 203     ;;         (union products
 204     ;;                (get-char-attribute variant 'ideographic-products))))
 205     ;; (setq dest products)
 206     (setq dest (get-char-attribute (car components) 'ideographic-products))
 207     (while (and dest
 208                 (setq components (cdr components)))
 209       ;; (setq products nil)
 210       ;; (dolist (variant (char-component-variants (car components)))
 211       ;;   (setq products
 212       ;;         (union products
 213       ;;                (get-char-attribute variant 'ideographic-products))))
 214       (setq products (get-char-attribute (car components) 'ideographic-products))
 215       (setq dest (intersection dest products)))
 216     dest))
 217
 218
 219 (defun ideographic-structure-char= (c1 c2)
 220   (or (eq c1 c2)
 221       (and c1 c2
 222            (let ((m1 (char-ucs c1))
 223                  (m2 (char-ucs c2)))
 224              (or (and m1 m2
 225                       (eq m1 m2))
 226                  (memq c1 (char-component-variants c2)))))))
 227
 228 (defun ideographic-structure-member-compare-components (component s-component)
 229   (let (ret)
 230     (cond ((char-ref= component s-component #'ideographic-structure-char=))
 231           ((listp s-component)
 232            (if (setq ret (assq 'ideographic-structure s-component))
 233                (ideographic-structure-member component (cdr ret))))
 234           ((setq ret (get-char-attribute s-component 'ideographic-structure))
 235            (ideographic-structure-member component ret)))))
 236
 237 ;;;###autoload
 238 (defun ideographic-structure-member (component structure)
 239   "Return non-nil if COMPONENT is included in STRUCTURE."
 240   (or (memq component structure)
 241       (progn
 242         (setq structure (cdr structure))
 243         (ideographic-structure-member-compare-components
 244          component (car structure)))
 245       (progn
 246         (setq structure (cdr structure))
 247         (ideographic-structure-member-compare-components
 248          component (car structure)))
 249       (progn
 250         (setq structure (cdr structure))
 251         (and (car structure)
 252              (ideographic-structure-member-compare-components
 253               component (car structure))))))
 254
 255
 256 ;;;###autoload
 257 (defun ideographic-structure-repertoire-p (structure components)
 258   "Return non-nil if STRUCTURE can be constructed by a subset of COMPONENTS."
 259   (and structure
 260        (let (ret s-component)
 261          (catch 'tag
 262            (while (setq structure (cdr structure))
 263              (setq s-component (car structure))
 264              (unless (characterp s-component)
 265                (if (setq ret (find-char s-component))
 266                    (setq s-component ret)))
 267              (unless (cond
 268                       ((listp s-component)
 269                        (if (setq ret (assq 'ideographic-structure s-component))
 270                            (ideographic-structure-repertoire-p
 271                             (cdr ret) components)))
 272                       ((member* s-component components
 273                                 :test #'ideographic-structure-char=))
 274                       ((setq ret
 275                              (get-char-attribute s-component
 276                                                  'ideographic-structure))
 277                        (ideographic-structure-repertoire-p ret components)))
 278                (throw 'tag nil)))
 279            t))))
 280
 281
 282 (defvar ids-find-result-buffer "*ids-chars*")
 283
 284 (defun ids-find-format-line (c v)
 285   (format "%c\t%s\t%s\n"
 286           c
 287           (or (let ((ucs (or (char-ucs c)
 288                              (encode-char c 'ucs))))
 289                 (if ucs
 290                     (cond ((<= ucs #xFFFF)
 291                            (format "    U+%04X" ucs))
 292                           ((<= ucs #x10FFFF)
 293                            (format "U-%08X" ucs)))))
 294               "          ")
 295           (or (ideographic-structure-to-ids v)
 296               v)))
 297
 298 (defun ids-insert-chars-including-components* (components
 299                                                &optional level ignored-chars)
 300   (unless level
 301     (setq level 0))
 302   (let (is i as bs)
 303     (dolist (c (sort (copy-list (ideograph-find-products components
 304                                                          ignored-chars))
 305                      (lambda (a b)
 306                        (if (setq as (char-total-strokes a))
 307                            (if (setq bs (char-total-strokes b))
 308                                (if (= as bs)
 309                                    (ideograph-char< a b)
 310                                  (< as bs))
 311                              t)
 312                          (ideograph-char< a b)))))
 313       (unless (memq c ignored-chars)
 314         (setq is (char-feature c 'ideographic-structure))
 315         (setq i 0)
 316         (while (< i level)
 317           (insert "\t")
 318           (setq i (1+ i)))
 319         (insert (ids-find-format-line c is))
 320         (setq ignored-chars
 321               (ids-insert-chars-including-components*
 322                (char-to-string c) (1+ level)
 323                (cons c ignored-chars))))
 324       )
 325     )
 326   ignored-chars)
 327
 328 (defun ids-insert-chars-including-components (components
 329                                               &optional level ignored-chars)
 330   (unless level
 331     (setq level 0))
 332   (setq ignored-chars
 333         (nreverse
 334          (ids-insert-chars-including-components* components
 335                                                  level ignored-chars)))
 336   (let (is i as bs)
 337     (dolist (c ignored-chars)
 338       (dolist (vc (char-component-variants c))
 339         (unless (memq vc ignored-chars)
 340           (when (setq is (get-char-attribute vc 'ideographic-structure))
 341             (setq i 0)
 342             (while (< i level)
 343               (insert "\t")
 344               (setq i (1+ i)))
 345             (insert (ids-find-format-line vc is))
 346             (setq ignored-chars
 347                   (ids-insert-chars-including-components*
 348                    (char-to-string vc) (1+ level)
 349                    (cons vc ignored-chars)))))))
 350     (dolist (c (sort (copy-list (ideograph-find-products-with-variants
 351                                  components ignored-chars))
 352                      (lambda (a b)
 353                        (if (setq as (char-total-strokes a))
 354                            (if (setq bs (char-total-strokes b))
 355                                (if (= as bs)
 356                                    (ideograph-char< a b)
 357                                  (< as bs))
 358                              t)
 359                          (ideograph-char< a b)))))
 360       (unless (memq c ignored-chars)
 361         (setq is (get-char-attribute c 'ideographic-structure))
 362         (setq i 0)
 363         (while (< i level)
 364           (insert "\t")
 365           (setq i (1+ i)))
 366         (insert (ids-find-format-line c is))
 367         (setq ignored-chars
 368               (ids-insert-chars-including-components*
 369                (char-to-string c) (1+ level)
 370                (cons c ignored-chars))))
 371       )
 372     )
 373   ignored-chars)
 374
 375 ;;;###autoload
 376 (defun ids-find-chars-including-components (components)
 377   "Search Ideographs whose structures have COMPONENTS."
 378   (interactive "sComponents : ")
 379   (with-current-buffer (get-buffer-create ids-find-result-buffer)
 380     (setq buffer-read-only nil)
 381     (erase-buffer)
 382     (ids-insert-chars-including-components components 0 nil)
 383     ;; (let ((ignored-chars
 384     ;;        (nreverse
 385     ;;         (ids-insert-chars-including-components components 0 nil
 386     ;;                                                #'ideograph-find-products)))
 387     ;;       rest)
 388     ;;   (setq rest ignored-chars)
 389     ;;   ;; (dolist (c rest)
 390     ;;   ;;   (setq ignored-chars
 391     ;;   ;;         (union ignored-chars
 392     ;;   ;;                (ids-insert-chars-including-components
 393     ;;   ;;                 (list c) 0 ignored-chars
 394     ;;   ;;                 #'ideograph-find-products-with-variants))))
 395     ;;   (ids-insert-chars-including-components components 0 ignored-chars
 396     ;;                                          #'ideograph-find-products-with-variants))
 397     (goto-char (point-min)))
 398   (view-buffer ids-find-result-buffer))
 399
 400 ;;;###autoload
 401 (define-obsolete-function-alias 'ideographic-structure-search-chars
 402   'ids-find-chars-including-components)
 403
 404 ;;;###autoload
 405 (defun ids-find-chars-covered-by-components (components)
 406   "Search Ideographs which structures are consisted by subsets of COMPONENTS."
 407   (interactive "sComponents: ")
 408   (if (stringp components)
 409       (setq components (string-to-char-list components)))
 410   (with-current-buffer (get-buffer-create ids-find-result-buffer)
 411     (setq buffer-read-only nil)
 412     (erase-buffer)
 413     (map-char-attribute
 414      (lambda (c v)
 415        (when (ideographic-structure-repertoire-p v components)
 416          (insert (ids-find-format-line c v))))
 417      'ideographic-structure)
 418     (goto-char (point-min)))
 419   (view-buffer ids-find-result-buffer))
 420
 421
 422 (defun ideographic-structure-merge-components-alist (ca1 ca2)
 423   (let ((dest-alist ca1)
 424         ret)
 425     (dolist (cell ca2)
 426       (if (setq ret (assq (car cell) dest-alist))
 427           (setcdr ret (+ (cdr ret)(cdr cell)))
 428         (setq dest-alist (cons cell dest-alist))))
 429     dest-alist))
 430
 431 (defun ideographic-structure-to-components-alist (structure)
 432   (apply #'ideographic-structure-to-components-alist* structure))
 433
 434 (defun ideographic-structure-to-components-alist* (operator component1 component2
 435                                                             &optional component3
 436                                                             &rest opts)
 437   (let (dest-alist ret)
 438     (setq dest-alist
 439           (cond ((characterp component1)
 440                  (unless (encode-char component1 'ascii)
 441                    (list (cons component1 1)))
 442                  )
 443                 ((setq ret (assq 'ideographic-structure component1))
 444                  (ideographic-structure-to-components-alist (cdr ret))
 445                  )
 446                 ((setq ret (find-char component1))
 447                  (list (cons ret 1))
 448                  )))
 449     (setq dest-alist
 450           (ideographic-structure-merge-components-alist
 451            dest-alist
 452            (cond ((characterp component2)
 453                   (unless (encode-char component2 'ascii)
 454                     (list (cons component2 1)))
 455                   )
 456                  ((setq ret (assq 'ideographic-structure component2))
 457                   (ideographic-structure-to-components-alist (cdr ret))
 458                   )
 459                  ((setq ret (find-char component2))
 460                   (list (cons ret 1))
 461                   ))))
 462     (if (memq operator '(?\u2FF2 ?\u2FF3))
 463         (ideographic-structure-merge-components-alist
 464          dest-alist
 465          (cond ((characterp component3)
 466                 (unless (encode-char component3 'ascii)
 467                   (list (cons component3 1)))
 468                 )
 469                ((setq ret (assq 'ideographic-structure component3))
 470                 (ideographic-structure-to-components-alist (cdr ret))
 471                 )
 472                ((setq ret (find-char component3))
 473                 (list (cons ret 1))
 474                 )))
 475       dest-alist)))
 476
 477 (defun ids-find-merge-variables (ve1 ve2)
 478   (cond ((eq ve1 t)
 479          ve2)
 480         ((eq ve2 t)
 481          ve1)
 482         (t
 483          (let ((dest-alist ve1)
 484                (rest ve2)
 485                cell ret)
 486            (while (and rest
 487                        (setq cell (car rest))
 488                        (if (setq ret (assq (car cell) ve1))
 489                            (eq (cdr ret)(cdr cell))
 490                          (setq dest-alist (cons cell dest-alist))))
 491              (setq rest (cdr rest)))
 492            (if rest
 493                nil
 494              dest-alist)))))
 495
 496 ;;;###autoload
 497 (defun ideographic-structure-equal (structure1 structure2)
 498   (let (dest-alist ret)
 499     (and (setq dest-alist (ideographic-structure-character=
 500                            (car structure1)(car structure2)))
 501          (setq ret (ideographic-structure-character=
 502                     (nth 1 structure1)(nth 1 structure2)))
 503          (setq dest-alist (ids-find-merge-variables dest-alist ret))
 504          (setq ret (ideographic-structure-character=
 505                     (nth 2 structure1)(nth 2 structure2)))
 506          (setq dest-alist (ids-find-merge-variables dest-alist ret))
 507          (if (memq (car structure1) '(?\u2FF2 ?\u2FF3))
 508              (and (setq ret (ideographic-structure-character=
 509                              (nth 3 structure1)(nth 3 structure2)))
 510                   (setq dest-alist (ids-find-merge-variables dest-alist ret)))
 511            dest-alist))))
 512
 513 ;;;###autoload
 514 (defun ideographic-structure-character= (c1 c2)
 515   (let (ret ret2)
 516     (cond ((characterp c1)
 517            (cond ((encode-char c1 'ascii)
 518                   (list (cons c1 c2))
 519                   )
 520                  ((characterp c2)
 521                   (if (encode-char c2 'ascii)
 522                       (list (cons c2 c1))
 523                     (eq c1 c2))
 524                   )
 525                  ((setq ret2 (find-char c2))
 526                   (eq c1 ret2)
 527                   )
 528                  ((setq ret2 (assq 'ideographic-structure c2))
 529                   (and (setq ret (get-char-attribute c1 'ideographic-structure))
 530                        (ideographic-structure-equal ret (cdr ret2)))
 531                   ))
 532            )
 533           ((setq ret (assq 'ideographic-structure c1))
 534            (cond ((characterp c2)
 535                   (if (encode-char c2 'ascii)
 536                       (list (cons c2 c1))
 537                     (and (setq ret2 (get-char-attribute c2 'ideographic-structure))
 538                          (ideographic-structure-equal (cdr ret) ret2)))
 539                   )
 540                  ((setq ret2 (find-char c2))
 541                   (and (setq ret2 (get-char-attribute ret2 'ideographic-structure))
 542                        (ideographic-structure-equal (cdr ret) ret2))
 543                   )
 544                  ((setq ret2 (assq 'ideographic-structure c2))
 545                   (ideographic-structure-equal (cdr ret)(cdr ret2))
 546                   ))
 547            )
 548           ((setq ret (find-char c1))
 549            (cond ((characterp c2)
 550                   (if (encode-char c2 'ascii)
 551                       (list (cons c2 c1))
 552                     (eq ret c2))
 553                   )
 554                  ((setq ret2 (find-char c2))
 555                   (eq ret ret2)
 556                   )
 557                  ((setq ret2 (assq 'ideographic-structure c2))
 558                   (and (setq ret (get-char-attribute ret 'ideographic-structure))
 559                        (ideographic-structure-equal ret (cdr ret2))
 560                        )))))))
 561
 562 ;;;###autoload
 563 (defun ideographic-structure-find-chars (structure)
 564   (let ((comp-alist (ideographic-structure-to-components-alist structure))
 565         ret pl str)
 566     (dolist (pc (caar
 567                  (sort (mapcar (lambda (cell)
 568                                  (if (setq ret (get-char-attribute
 569                                                 (car cell) 'ideographic-products))
 570                                      (cons ret (length ret))
 571                                    (cons nil 0)))
 572                                comp-alist)
 573                        (lambda (a b)
 574                          (< (cdr a)(cdr b))))))
 575       (when (or (and (setq str
 576                            (get-char-attribute pc 'ideographic-structure))
 577                      (ideographic-structure-equal str structure))
 578                 (and (setq str
 579                            (get-char-attribute pc 'ideographic-structure@apparent))
 580                      (ideographic-structure-equal str structure))
 581                 (and (setq str
 582                            (get-char-attribute pc 'ideographic-structure@apparent/leftmost))
 583                      (ideographic-structure-equal str structure)))
 584         (setq pl (cons pc pl))
 585         ))
 586     pl))
 587
 588 ;;;###autoload
 589 (defun ideographic-char-count-components (char component)
 590   (let ((dest 0)
 591         structure)
 592     (cond ((eq char component)
 593            1)
 594           ((setq structure (get-char-attribute char 'ideographic-structure))
 595            (dolist (cell (ideographic-structure-to-components-alist structure))
 596              (setq dest
 597                    (+ dest
 598                       (if (eq (car cell) char)
 599                           (cdr cell)
 600                         (* (ideographic-char-count-components (car cell) component)
 601                            (cdr cell))))))
 602            dest)
 603           (t
 604            0))))
 605
 606
 607 ;;;###autoload
 608 (defun ideographic-character-get-structure (character)
 609   "Return ideographic-structure of CHARACTER.
 610 CHARACTER can be a character or char-spec."
 611   (mapcar (lambda (cell)
 612             (or (and (listp cell)
 613                      (find-char cell))
 614                 cell))
 615           (let (ret)
 616             (cond ((characterp character)
 617                    (get-char-attribute character 'ideographic-structure)
 618                    )
 619                   ((setq ret (assq 'ideographic-structure character))
 620                    (cdr ret)
 621                    )
 622                   ((setq ret (find-char character))
 623                    (get-char-attribute ret 'ideographic-structure)
 624                    )))))
 625
 626 ;;;###autoload
 627 (defun ideographic-char-match-component (char component)
 628   "Return non-nil if character CHAR has COMPONENT in ideographic-structure.
 629 COMPONENT can be a character or char-spec."
 630   (or (ideographic-structure-character= char component)
 631       (let ((str (ideographic-character-get-structure char)))
 632         (and str
 633              (or (ideographic-char-match-component (nth 1 str) component)
 634                  (ideographic-char-match-component (nth 2 str) component)
 635                  (if (memq (car str) '(?\u2FF2 ?\u2FF3))
 636                      (ideographic-char-match-component (nth 3 str) component)))))))
 637
 638 (defun ideographic-structure-char< (a b)
 639   (let ((sa (get-char-attribute a 'ideographic-structure))
 640         (sb (get-char-attribute b 'ideographic-structure))
 641         tsa tsb)
 642     (cond (sa
 643            (cond (sb
 644                   (setq tsa (char-total-strokes a)
 645                         tsb (char-total-strokes b))
 646                   (if tsa
 647                       (if tsb
 648                           (or (< tsa tsb)
 649                               (and (= tsa tsb)
 650                                    (ideograph-char< a b)))
 651                         t)
 652                     (if tsb
 653                         nil
 654                       (ideograph-char< a b))))
 655                  (t
 656                   nil))
 657            )
 658           (t
 659            (cond (sb
 660                   t)
 661                  (t
 662                   (setq tsa (char-total-strokes a)
 663                         tsb (char-total-strokes b))
 664                   (if tsa
 665                       (if tsb
 666                           (or (< tsa tsb)
 667                               (and (= tsa tsb)
 668                                    (ideograph-char< a b)))
 669                         t)
 670                     (if tsb
 671                         nil
 672                       (ideograph-char< a b)))
 673                   ))
 674            ))
 675     ))
 676
 677 (defun ideo-comp-tree-adjoin (tree char)
 678   (let ((rest tree)
 679         included ; other
 680         dest cell finished)
 681     (while (and (not finished)
 682                 rest)
 683       (setq cell (pop rest))
 684       (cond ((ideographic-structure-character= char (car cell))
 685              (setq finished t
 686                    dest tree
 687                    rest nil)
 688              )
 689             ((ideographic-char-match-component char (car cell))
 690              (setq dest
 691                    (cons (cons (car cell)
 692                                (ideo-comp-tree-adjoin (cdr cell) char))
 693                          dest))
 694              (setq finished t)
 695              )
 696             ((ideographic-char-match-component (car cell) char)
 697              (setq included (cons cell included))
 698              )
 699             ;; (included
 700             ;;  (setq other (cons cell other))
 701             ;;  )
 702             (t
 703              (setq dest (cons cell dest))
 704              )))
 705     (cond (finished
 706            (nconc dest rest)
 707            )
 708           (included
 709            (cons (cons char included)
 710                  (nconc dest rest))
 711            )
 712           (t
 713            (cons (list char) tree)
 714            ))))
 715
 716 (defun ideographic-chars-to-is-a-tree (chars)
 717   (let (tree)
 718     (dolist (char (sort (copy-list chars) #'ideographic-structure-char<))
 719       (setq tree (ideo-comp-tree-adjoin tree char)))
 720     tree))
 721
 722 (defun ids-find-chars-including-ids (structure)
 723   (let (comp-alist comp-spec ret str rest)
 724     (cond
 725      ((characterp structure)
 726       (setq rest (copy-list (get-char-attribute structure 'ideographic-products)))
 727       )
 728      ((setq ret (ideographic-structure-find-chars structure))
 729       (dolist (pc ret)
 730         (setq rest
 731               (union
 732                rest
 733                (copy-list (get-char-attribute pc 'ideographic-products)))))
 734       )
 735      (t
 736       (setq comp-alist (ideographic-structure-to-components-alist structure)
 737             comp-spec (list (cons 'ideographic-structure structure)))
 738       (dolist (pc (caar
 739                    (sort (mapcar (lambda (cell)
 740                                    (if (setq ret (get-char-attribute
 741                                                   (car cell) 'ideographic-products))
 742                                        (cons ret (length ret))
 743                                      (cons nil 0)))
 744                                  comp-alist)
 745                          (lambda (a b)
 746                            (< (cdr a)(cdr b))))))
 747         (when (and (every (lambda (cell)
 748                             (>= (ideographic-char-count-components pc (car cell))
 749                                 (cdr cell)))
 750                           comp-alist)
 751                    (or (ideographic-char-match-component pc comp-spec)
 752                        (and (setq str (get-char-attribute pc 'ideographic-structure))
 753                             (ideographic-char-match-component
 754                              (list
 755                               (cons
 756                                'ideographic-structure
 757                                (functional-ideographic-structure-to-apparent-structure
 758                                 str)))
 759                              comp-spec))))
 760           (push pc rest)))
 761       ))
 762     (ideographic-chars-to-is-a-tree rest)))
 763
 764 (defun functional-ideographic-structure-to-apparent-structure (structure)
 765   (ideographic-structure-compare-functional-and-apparent
 766    structure nil 'conversion-only))
 767
 768 ;;;###autoload
 769 (defun ideographic-structure-compact (structure)
 770   (let ((rest structure)
 771         cell
 772         ret dest sub)
 773     (while rest
 774       (setq cell (pop rest))
 775       (if (and (consp cell)
 776                (setq ret (find-char cell)))
 777           (setq cell ret))
 778       (cond
 779        ((and (consp cell)
 780              (cond ((setq ret (assq 'ideographic-structure cell))
 781                     (setq sub (cdr ret))
 782                     )
 783                    ((atom (car cell))
 784                     (setq sub cell)
 785                     )))
 786         (setq cell
 787               (cond ((setq ret (ideographic-structure-find-chars sub))
 788                      (car ret)
 789                      )
 790                     ((setq ret (ideographic-structure-compact sub))
 791                      (list (cons 'ideographic-structure ret))
 792                      )
 793                     (t
 794                      (list (cons 'ideographic-structure sub))))
 795               )
 796         ))
 797       (setq dest (cons cell dest)))
 798     (nreverse dest)))
 799
 800 (defun ideographic-structure-compare-functional-and-apparent (structure
 801                                                               &optional char
 802                                                               conversion-only)
 803   (let (enc enc-str enc2-str enc3-str new-str new-str-c
 804             f-res a-res ret code)
 805     (cond
 806      ((eq (car structure) ?⿸)
 807       (setq enc (nth 1 structure))
 808       (when (setq enc-str
 809                   (cond ((characterp enc)
 810                          (get-char-attribute enc 'ideographic-structure)
 811                          )
 812                         ((consp enc)
 813                          (cdr (assq 'ideographic-structure enc))
 814                          )))
 815         (cond
 816          ((eq (car enc-str) ?⿰)
 817           (unless conversion-only
 818             (setq f-res (ids-find-chars-including-ids enc-str)))
 819           (setq new-str (list ?⿱
 820                               (nth 2 enc-str)
 821                               (nth 2 structure)))
 822           (setq new-str-c
 823                 (if (setq ret (ideographic-structure-find-chars new-str))
 824                     (car ret)
 825                   (list (cons 'ideographic-structure new-str))))
 826           (if conversion-only
 827               (list ?⿰ (nth 1 enc-str) new-str-c)
 828             (setq a-res (ids-find-chars-including-ids new-str))
 829             (list enc
 830                   f-res
 831                   new-str-c
 832                   a-res
 833                   (list ?⿰ (nth 1 enc-str) new-str-c)
 834                   111))
 835           )
 836          ((and (eq (car enc-str) ?⿲)
 837                (memq (char-ucs (nth 1 enc-str)) '(#x4EBB #x2E85))
 838                (eq (nth 2 enc-str) ?丨))
 839           (unless conversion-only
 840             (setq f-res (ids-find-chars-including-ids enc-str)))
 841           (setq new-str (list ?⿱
 842                               (nth 3 enc-str)
 843                               (nth 2 structure)))
 844           (setq new-str-c
 845                 (if (setq ret (ideographic-structure-find-chars new-str))
 846                     (car ret)
 847                   (list (cons 'ideographic-structure new-str))))
 848           (if conversion-only
 849               (list ?⿰ (decode-char '=big5-cdp #x8B7A) new-str-c)
 850             (setq a-res (ids-find-chars-including-ids new-str))
 851             (list enc
 852                   f-res
 853                   new-str-c
 854                   a-res
 855                   (list ?⿰ (decode-char '=big5-cdp #x8B7A) new-str-c)
 856                   112))
 857           )
 858          ((eq (car enc-str) ?⿱)
 859           (unless conversion-only
 860             (setq f-res (ids-find-chars-including-ids enc-str)))
 861           (setq new-str
 862                 (list
 863                  (cond
 864                   ((characterp (nth 2 enc-str))
 865                    (if (or (memq (encode-char (nth 2 enc-str) '=>ucs@component)
 866                                  '(#x20087 #x5382 #x4E06))
 867                            (eq (encode-char (nth 2 enc-str) '=>ucs@iwds-1)
 868                                #x4E06)
 869                            (eq (encode-char (nth 2 enc-str) '=ucs-itaiji-001)
 870                                #x2E282)
 871                            (eq (encode-char (nth 2 enc-str) '=big5-cdp)
 872                                #x89CE)
 873                            (eq (encode-char (nth 2 enc-str) '=>big5-cdp)
 874                                #x88E2)
 875                            (eq (encode-char (nth 2 enc-str) '=big5-cdp)
 876                                #x88AD)
 877                            (eq (or (encode-char (nth 2 enc-str) '=>big5-cdp)
 878                                    (encode-char (nth 2 enc-str) '=big5-cdp-itaiji-001))
 879                                #x8766)
 880                            (eq (car (get-char-attribute (nth 2 enc-str)
 881                                                         'ideographic-structure))
 882                                ?⿸))
 883                        ?⿸
 884                      ?⿰))
 885                   ((eq (car (cdr (assq 'ideographic-structure (nth 2 enc-str))))
 886                        ?⿸)
 887                    ?⿸)
 888                   (t
 889                    ?⿰))
 890                  (nth 2 enc-str)
 891                  (nth 2 structure)))
 892           (setq new-str-c
 893                 (if (setq ret (ideographic-structure-find-chars new-str))
 894                     (car ret)
 895                   (list (cons 'ideographic-structure new-str))))
 896           (if conversion-only
 897               (list ?⿱ (nth 1 enc-str) new-str-c)
 898             (setq a-res (ids-find-chars-including-ids new-str))
 899             (list enc
 900                   f-res
 901                   new-str-c
 902                   a-res
 903                   (list ?⿱ (nth 1 enc-str) new-str-c)
 904                   (if (eq (car new-str) ?⿸)
 905                       121
 906                     122)))
 907           )
 908          ((eq (car enc-str) ?⿸)
 909           (unless conversion-only
 910             (setq f-res (ids-find-chars-including-ids enc-str)))
 911           (setq new-str (list (cond
 912                                ((characterp (nth 2 enc-str))
 913                                 (if (memq (char-ucs (nth 2 enc-str))
 914                                           '(#x5F73))
 915                                     ?⿰
 916                                   ?⿱)
 917                                 )
 918                                (t
 919                                 ?⿱))
 920                               (nth 2 enc-str)
 921                               (nth 2 structure)))
 922           (setq new-str-c
 923                 (if (setq ret (ideographic-structure-find-chars new-str))
 924                     (car ret)
 925                   (list (cons 'ideographic-structure new-str))))
 926           (if conversion-only
 927               (list ?⿸ (nth 1 enc-str) new-str-c)
 928             (setq a-res (ids-find-chars-including-ids new-str))
 929             (list enc
 930                   f-res
 931                   new-str-c
 932                   a-res
 933                   (list ?⿸ (nth 1 enc-str) new-str-c)
 934                   (if (eq (car new-str) ?⿰)
 935                       131
 936                     132)))
 937           )))
 938       )
 939      ((eq (car structure) ?⿹)
 940       (setq enc (nth 1 structure))
 941       (when (setq enc-str
 942                   (cond ((characterp enc)
 943                          (get-char-attribute enc 'ideographic-structure)
 944                          )
 945                         ((consp enc)
 946                          (cdr (assq 'ideographic-structure enc))
 947                          )))
 948         (cond
 949          ((eq (car enc-str) ?⿰)
 950           (unless conversion-only
 951             (setq f-res (ids-find-chars-including-ids enc-str)))
 952           (setq new-str (list ?⿱
 953                               (nth 1 enc-str)
 954                               (nth 2 structure)))
 955           (setq new-str-c
 956                 (if (setq ret (ideographic-structure-find-chars new-str))
 957                     (car ret)
 958                   (list (cons 'ideographic-structure new-str))))
 959           (if conversion-only
 960               (list ?⿰ new-str-c (nth 2 enc-str))
 961             (setq a-res (ids-find-chars-including-ids new-str))
 962             (list enc
 963                   f-res
 964                   new-str-c
 965                   a-res
 966                   (list ?⿰ new-str-c (nth 2 enc-str))
 967                   210))
 968           )
 969          ((eq (car enc-str) ?⿱)
 970           (unless conversion-only
 971             (setq f-res (ids-find-chars-including-ids enc-str)))
 972           (setq new-str (list ?⿰
 973                               (nth 2 structure)
 974                               (nth 2 enc-str)))
 975           (setq new-str-c
 976                 (if (setq ret (ideographic-structure-find-chars new-str))
 977                     (car ret)
 978                   (list (cons 'ideographic-structure new-str))))
 979           (if conversion-only
 980               (list ?⿱ (nth 1 enc-str) new-str-c)
 981             (setq a-res (ids-find-chars-including-ids new-str))
 982             (list enc
 983                   f-res
 984                   new-str-c
 985                   a-res
 986                   (list ?⿱ (nth 1 enc-str) new-str-c)
 987                   220))
 988           )
 989          ))
 990       )
 991      ((eq (get-char-attribute (car structure) '=ucs-itaiji-001) #x2FF6)
 992       (setq enc (nth 1 structure))
 993       (when (setq enc-str
 994                   (cond ((characterp enc)
 995                          (get-char-attribute enc 'ideographic-structure)
 996                          )
 997                         ((consp enc)
 998                          (cdr (assq 'ideographic-structure enc))
 999                          )))
1000         (cond
1001          ((eq (car enc-str) ?⿺)
1002           (unless conversion-only
1003             (setq f-res (ids-find-chars-including-ids enc-str)))
1004           (setq new-str (list ?⿱
1005                               (nth 2 structure)
1006                               (nth 1 enc-str)))
1007           (setq new-str-c
1008                 (if (setq ret (ideographic-structure-find-chars new-str))
1009                     (car ret)
1010                   (list (cons 'ideographic-structure new-str))))
1011           (if conversion-only
1012               (list ?⿺ new-str-c (nth 2 enc-str))
1013             (setq a-res (ids-find-chars-including-ids new-str))
1014             (list enc
1015                   f-res
1016                   new-str-c
1017                   a-res
1018                   (list ?⿺ new-str-c (nth 2 enc-str))
1019                   310))
1020           )
1021          ((eq (car enc-str) ?⿱)
1022           (unless conversion-only
1023             (setq f-res (ids-find-chars-including-ids enc-str)))
1024           (setq new-str (list ?⿰
1025                               (nth 2 structure)
1026                               (nth 1 enc-str)))
1027           (setq new-str-c
1028                 (if (setq ret (ideographic-structure-find-chars new-str))
1029                     (car ret)
1030                   (list (cons 'ideographic-structure new-str))))
1031           (if conversion-only
1032               (list ?⿱ new-str-c (nth 2 enc-str))
1033             (setq a-res (ids-find-chars-including-ids new-str))
1034             (list enc
1035                   f-res
1036                   new-str-c
1037                   a-res
1038                   (list ?⿱ new-str-c (nth 2 enc-str))
1039                   320))
1040           )
1041          ((eq (car enc-str) ?⿰)
1042           (unless conversion-only
1043             (setq f-res (ids-find-chars-including-ids enc-str)))
1044           (setq new-str (list ?⿱
1045                               (nth 2 structure)
1046                               (nth 1 enc-str)))
1047           (setq new-str-c
1048                 (if (setq ret (ideographic-structure-find-chars new-str))
1049                     (car ret)
1050                   (list (cons 'ideographic-structure new-str))))
1051           (if conversion-only
1052               (list ?⿰ new-str-c (nth 2 enc-str))
1053             (setq a-res (ids-find-chars-including-ids new-str))
1054             (list enc
1055                   f-res
1056                   new-str-c
1057                   a-res
1058                   (list ?⿰ new-str-c (nth 2 enc-str))
1059                   330))
1060           ))
1061         )
1062       )
1063      ((eq (car structure) ?⿴)
1064       (setq enc (nth 1 structure))
1065       (when (setq enc-str
1066                   (cond ((characterp enc)
1067                          (get-char-attribute enc 'ideographic-structure)
1068                          )
1069                         ((consp enc)
1070                          (cdr (assq 'ideographic-structure enc))
1071                          )))
1072         (cond
1073          ((eq (car enc-str) ?⿱)
1074           (cond
1075            ((and (characterp (nth 2 enc-str))
1076                  (or (memq (char-ucs (nth 2 enc-str)) '(#x56D7 #x5F51 #x897F))
1077                      (eq (char-feature (nth 2 enc-str) '=>big5-cdp)
1078                          #x87A5)))
1079             (unless conversion-only
1080               (setq f-res (ids-find-chars-including-ids enc-str)))
1081             (setq new-str (list ?⿴
1082                                 (nth 2 enc-str)
1083                                 (nth 2 structure)))
1084             (setq new-str-c
1085                   (if (setq ret (ideographic-structure-find-chars new-str))
1086                       (car ret)
1087                     (list (cons 'ideographic-structure new-str))))
1088             (if conversion-only
1089                 (list ?⿱ (nth 1 enc-str) new-str-c)
1090               (setq a-res (ids-find-chars-including-ids new-str))
1091               (list enc
1092                     f-res
1093                     new-str-c
1094                     a-res
1095                     (list ?⿱ (nth 1 enc-str) new-str-c)
1096                     411))
1097             )
1098            ((and (characterp (nth 2 enc-str))
1099                  (eq (char-ucs (nth 2 enc-str)) #x51F5))
1100             (unless conversion-only
1101               (setq f-res (ids-find-chars-including-ids enc-str)))
1102             (setq new-str (list ?⿶
1103                                 (nth 2 enc-str)
1104                                 (nth 2 structure)))
1105             (setq new-str-c
1106                   (if (setq ret (ideographic-structure-find-chars new-str))
1107                       (car ret)
1108                     (list (cons 'ideographic-structure new-str))))
1109             (if conversion-only
1110                 (list ?⿱ (nth 1 enc-str) new-str-c)
1111               (setq a-res (ids-find-chars-including-ids new-str))
1112               (list enc
1113                     f-res
1114                     new-str-c
1115                     a-res
1116                     (list ?⿱ (nth 1 enc-str) new-str-c)
1117                     412))
1118             )
1119            ((and (characterp (nth 1 enc-str))
1120                  (eq (char-feature (nth 1 enc-str) '=>ucs@component)
1121                      #x300E6))
1122             (unless conversion-only
1123               (setq f-res (ids-find-chars-including-ids enc-str)))
1124             (setq new-str (list ?⿵
1125                                 (nth 1 enc-str)
1126                                 (nth 2 structure)))
1127             (setq new-str-c
1128                   (if (setq ret (ideographic-structure-find-chars new-str))
1129                       (car ret)
1130                     (list (cons 'ideographic-structure new-str))))
1131             (if conversion-only
1132                 (list ?⿱ new-str-c (nth 2 enc-str))
1133               (setq a-res (ids-find-chars-including-ids new-str))
1134               (list enc
1135                     f-res
1136                     new-str-c
1137                     a-res
1138                     (list ?⿱ new-str-c (nth 2 enc-str))
1139                     413))
1140             )
1141            (t
1142             (unless conversion-only
1143               (setq f-res (ids-find-chars-including-ids enc-str)))
1144             (setq new-str (list ?⿱ (nth 2 structure) (nth 2 enc-str)))
1145             (setq new-str-c
1146                   (if (setq ret (ideographic-structure-find-chars new-str))
1147                       (car ret)
1148                     (list (cons 'ideographic-structure new-str))))
1149             (if conversion-only
1150                 (list ?⿱ (nth 1 enc-str) new-str-c)
1151               (setq a-res (ids-find-chars-including-ids new-str))
1152               (list enc
1153                     f-res
1154                     new-str-c
1155                     a-res
1156                     (list ?⿱ (nth 1 enc-str) new-str-c)
1157                     414))
1158             ))
1159           )
1160          ((eq (car enc-str) ?⿳)
1161           (cond
1162            ((and (characterp (nth 2 enc-str))
1163                  (eq (char-ucs (nth 2 enc-str)) #x56D7))
1164             (unless conversion-only
1165               (setq f-res (ids-find-chars-including-ids enc-str)))
1166             (setq new-str (list ?⿴ (nth 2 enc-str) (nth 2 structure)))
1167             (setq new-str-c
1168                   (if (setq ret (ideographic-structure-find-chars new-str))
1169                       (car ret)
1170                     (list (cons 'ideographic-structure new-str))))
1171             (setq new-str (list ?⿱ (nth 1 enc-str) new-str-c))
1172             (setq new-str-c
1173                   (if (setq ret (ideographic-structure-find-chars new-str))
1174                       (car ret)
1175                     (list (cons 'ideographic-structure new-str))))
1176             (if conversion-only
1177                 (list ?⿱  new-str-c (nth 3 enc-str))
1178               (setq a-res (ids-find-chars-including-ids new-str))
1179               (list enc
1180                     f-res
1181                     new-str-c
1182                     a-res
1183                     (list ?⿱  new-str-c (nth 3 enc-str))
1184                     415))
1185             )
1186            ((and (characterp (nth 2 enc-str))
1187                  (eq (char-ucs (nth 2 enc-str)) #x5196))
1188             (unless conversion-only
1189               (setq f-res (ids-find-chars-including-ids enc-str)))
1190             (setq new-str (list ?⿱ (nth 1 enc-str) (nth 2 enc-str)))
1191             (setq new-str-c
1192                   (if (setq ret (ideographic-structure-find-chars new-str))
1193                       (car ret)
1194                     (list (cons 'ideographic-structure new-str))))
1195             (setq new-str (list ?⿱ new-str-c (nth 2 structure)))
1196             (setq new-str-c
1197                   (if (setq ret (ideographic-structure-find-chars new-str))
1198                       (car ret)
1199                     (list (cons 'ideographic-structure new-str))))
1200             (if conversion-only
1201                 (list ?⿱ new-str-c (nth 3 enc-str))
1202               (setq a-res (ids-find-chars-including-ids new-str))
1203               (list enc
1204                     f-res
1205                     new-str-c
1206                     a-res
1207                     (list ?⿱ new-str-c (nth 3 enc-str))
1208                     416))
1209             )
1210            ((and (characterp (nth 2 enc-str))
1211                  (or (eq (encode-char (nth 2 enc-str) '=>big5-cdp)
1212                          #x89A6)
1213                      (eq (encode-char (nth 2 enc-str) '=>gt-k)
1214                          146)
1215                      (eq (char-ucs (nth 2 enc-str)) #x2008A)))
1216             (unless conversion-only
1217               (setq f-res (ids-find-chars-including-ids enc-str)))
1218             (setq new-str (list ?⿱ (nth 2 structure) (nth 2 enc-str)))
1219             (setq new-str-c
1220                   (if (setq ret (ideographic-structure-find-chars new-str))
1221                       (car ret)
1222                     (list (cons 'ideographic-structure new-str))))
1223             (setq new-str (list ?⿸ new-str-c (nth 3 enc-str)))
1224             (setq new-str-c
1225                   (if (setq ret (ideographic-structure-find-chars new-str))
1226                       (car ret)
1227                     (list (cons 'ideographic-structure new-str))))
1228             (if conversion-only
1229                 (list ?⿱ (nth 1 enc-str) new-str-c)
1230               (setq a-res (ids-find-chars-including-ids new-str))
1231               (list enc
1232                     f-res
1233                     new-str-c
1234                     a-res
1235                     (list ?⿱ (nth 1 enc-str) new-str-c)
1236                     417))
1237             )
1238            (t
1239             (unless conversion-only
1240               (setq f-res (ids-find-chars-including-ids enc-str)))
1241             (setq new-str (list ?⿻ (nth 2 enc-str) (nth 2 structure)))
1242             (setq new-str-c
1243                   (if (setq ret (ideographic-structure-find-chars new-str))
1244                       (car ret)
1245                     (list (cons 'ideographic-structure new-str))))
1246             (setq new-str (list ?⿱ (nth 1 enc-str) new-str-c))
1247             (setq new-str-c
1248                   (if (setq ret (ideographic-structure-find-chars new-str))
1249                       (car ret)
1250                     (list (cons 'ideographic-structure new-str))))
1251             (if conversion-only
1252                 (list ?⿱  new-str-c (nth 3 enc-str))
1253               (setq a-res (ids-find-chars-including-ids new-str))
1254               (list enc
1255                     f-res
1256                     new-str-c
1257                     a-res
1258                     (list ?⿱  new-str-c (nth 3 enc-str))
1259                     419))
1260             ))
1261           )
1262          ((eq (car enc-str) ?⿰)
1263           (cond
1264            ((equal (nth 1 enc-str)(nth 2 enc-str))
1265             (unless conversion-only
1266               (setq f-res (ids-find-chars-including-ids enc-str)))
1267             (setq new-str (list ?⿲
1268                                 (nth 1 enc-str)
1269                                 (nth 2 structure)
1270                                 (nth 2 enc-str)))
1271             (setq new-str-c
1272                   (list (cons 'ideographic-structure new-str)))
1273             (if conversion-only
1274                 new-str
1275               (setq a-res (ids-find-chars-including-ids new-str))
1276               (list enc
1277                     f-res
1278                     new-str-c
1279                     a-res
1280                     new-str
1281                     421))
1282             )
1283            (t
1284             (unless conversion-only
1285               (setq f-res (ids-find-chars-including-ids enc-str)))
1286             (setq new-str (list ?⿰
1287                                 (nth 2 structure)
1288                                 (nth 2 enc-str)))
1289             (setq new-str-c
1290                   (if (setq ret (ideographic-structure-find-chars new-str))
1291                       (car ret)
1292                     (list (cons 'ideographic-structure new-str))))
1293             (if conversion-only
1294                 (list ?⿰ (nth 1 enc-str) new-str-c)
1295               (setq a-res (ids-find-chars-including-ids new-str))
1296               (list enc
1297                     f-res
1298                     new-str-c
1299                     a-res
1300                     (list ?⿰ (nth 1 enc-str) new-str-c)
1301                     422))
1302             ))
1303           ))
1304         )
1305       )
1306      ((eq (car structure) ?⿶)
1307       (setq enc (nth 1 structure))
1308       (when (setq enc-str
1309                   (cond ((characterp enc)
1310                          (get-char-attribute enc 'ideographic-structure)
1311                          )
1312                         ((consp enc)
1313                          (cdr (assq 'ideographic-structure enc))
1314                          )))
1315         (cond
1316          ((eq (car enc-str) ?⿱)
1317           (setq enc2-str (ideographic-character-get-structure (nth 1 enc-str)))
1318           (when (and enc2-str
1319                      (eq (car enc2-str) ?⿰))
1320             (unless conversion-only
1321               (setq f-res (ids-find-chars-including-ids enc-str)))
1322             (setq new-str (list ?⿲
1323                                 (nth 1 enc2-str)
1324                                 (nth 2 structure)
1325                                 (nth 2 enc2-str)))
1326             (setq new-str-c
1327                   (if (setq ret (ideographic-structure-find-chars new-str))
1328                       (car ret)
1329                     (list (cons 'ideographic-structure new-str))))
1330             (if conversion-only
1331                 (list ?⿱ new-str-c (nth 2 enc-str))
1332               (setq a-res (ids-find-chars-including-ids new-str))
1333               (list enc
1334                     f-res
1335                     new-str-c
1336                     a-res
1337                     (list ?⿱ new-str-c (nth 2 enc-str))
1338                     511))
1339             )
1340           )
1341          ((eq (car enc-str) ?⿳)
1342           (setq enc2-str (ideographic-character-get-structure (nth 1 enc-str)))
1343           (when (and enc2-str
1344                      (eq (car enc2-str) ?⿰))
1345             (unless conversion-only
1346               (setq f-res (ids-find-chars-including-ids enc-str)))
1347             (setq new-str (list ?⿲
1348                                 (nth 1 enc2-str)
1349                                 (nth 2 structure)
1350                                 (nth 2 enc2-str)))
1351             (setq new-str-c
1352                   (if (setq ret (ideographic-structure-find-chars new-str))
1353                       (car ret)
1354                     (list (cons 'ideographic-structure new-str))))
1355             (if conversion-only
1356                 (list ?⿳ new-str-c (nth 2 enc-str) (nth 3 enc-str))
1357               (setq a-res (ids-find-chars-including-ids new-str))
1358               (list enc
1359                     f-res
1360                     new-str-c
1361                     a-res
1362                     (list ?⿳ new-str-c (nth 2 enc-str) (nth 3 enc-str))
1363                     512))
1364             )
1365           )
1366          ((eq (car enc-str) ?⿲)
1367           (unless conversion-only
1368             (setq f-res (ids-find-chars-including-ids enc-str)))
1369           (setq new-str (list ?⿱
1370                               (nth 2 structure)
1371                               (nth 2 enc-str)))
1372           (setq new-str-c
1373                 (if (setq ret (ideographic-structure-find-chars new-str))
1374                     (car ret)
1375                   (list (cons 'ideographic-structure new-str))))
1376           (if conversion-only
1377               (list ?⿲ (nth 1 enc-str) new-str-c (nth 3 enc-str))
1378             (setq a-res (ids-find-chars-including-ids new-str))
1379             (list enc
1380                   f-res
1381                   new-str-c
1382                   a-res
1383                   (list ?⿲ (nth 1 enc-str) new-str-c (nth 3 enc-str))
1384                   520))
1385           )
1386          ((eq (car enc-str) ?⿴)
1387           (setq enc2-str (ideographic-character-get-structure (nth 1 enc-str)))
1388           (when (and enc2-str
1389                      (eq (car enc2-str) ?⿰))
1390             (unless conversion-only
1391               (setq f-res (ids-find-chars-including-ids enc-str)))
1392             (setq new-str (list ?⿱
1393                                 (nth 2 structure)
1394                                 (nth 2 enc-str)))
1395             (setq new-str-c
1396                   (if (setq ret (ideographic-structure-find-chars new-str))
1397                       (car ret)
1398                     (list (cons 'ideographic-structure new-str))))
1399             (if conversion-only
1400                 (list ?⿲ (nth 1 enc2-str) new-str-c (nth 2 enc2-str))
1401               (setq a-res (ids-find-chars-including-ids new-str))
1402               (list enc
1403                     f-res
1404                     new-str-c
1405                     a-res
1406                     (list ?⿲ (nth 1 enc2-str) new-str-c (nth 2 enc2-str))
1407                     530))
1408             )
1409           )))
1410       )
1411      ((eq (car structure) ?⿵)
1412       (setq enc (nth 1 structure))
1413       (when (setq enc-str
1414                   (cond ((characterp enc)
1415                          (get-char-attribute enc 'ideographic-structure)
1416                          )
1417                         ((consp enc)
1418                          (cdr (assq 'ideographic-structure enc))
1419                          )))
1420         (cond
1421          ((eq (car enc-str) ?⿱)
1422           (cond
1423            ((and (characterp (nth 2 enc-str))
1424                  (memq (char-ucs (nth 2 enc-str))
1425                        '(#x9580 #x9B25)))
1426             (unless conversion-only
1427               (setq f-res (ids-find-chars-including-ids enc-str)))
1428             (setq new-str (list ?⿵
1429                                 (nth 2 enc-str)
1430                                 (nth 2 structure)))
1431             (setq new-str-c
1432                   (if (setq ret (ideographic-structure-find-chars new-str))
1433                       (car ret)
1434                     (list (cons 'ideographic-structure new-str))))
1435             (if conversion-only
1436                 (list ?⿱ (nth 1 enc-str) new-str-c)
1437               (setq a-res (ids-find-chars-including-ids new-str))
1438               (list enc
1439                     f-res
1440                     new-str-c
1441                     a-res
1442                     (list ?⿱ (nth 1 enc-str) new-str-c)
1443                     601))
1444             )
1445            ((and (setq enc2-str (ideographic-character-get-structure (nth 2 enc-str)))
1446                  (cond
1447                   ((eq (car enc2-str) ?⿰)
1448                    (setq code 611)
1449                    )
1450                   ((eq (car enc2-str) ?⿲)
1451                    (setq code 614)
1452                    )
1453                   ((and (eq (car enc2-str) ?⿱)
1454                         (setq enc3-str
1455                               (ideographic-character-get-structure (nth 2 enc2-str)))
1456                         (eq (car enc3-str) ?⿰))
1457                    (setq code 613)
1458                    )))
1459             (unless conversion-only
1460               (setq f-res (ids-find-chars-including-ids enc-str)))
1461             (setq new-str
1462                   (cond ((eq code 611)
1463                          (list ?⿲
1464                                (nth 1 enc2-str)
1465                                (nth 2 structure)
1466                                (nth 2 enc2-str))
1467                          )
1468                         ((eq code 613)
1469                          (list ?⿲
1470                                (nth 1 enc3-str)
1471                                (nth 2 structure)
1472                                (nth 2 enc3-str))
1473                          )
1474                         ((eq code 614)
1475                          (list ?⿲
1476                                (nth 1 enc2-str)
1477                                (list (list 'ideographic-structure
1478                                            ?⿱
1479                                            (nth 2 enc2-str)
1480                                            (nth 2 structure)))
1481                                (nth 3 enc2-str))
1482                          )))
1483             (setq new-str-c
1484                   (if (setq ret (ideographic-structure-find-chars new-str))
1485                       (car ret)
1486                     (list (cons 'ideographic-structure
1487                                 (ideographic-structure-compact new-str)))))
1488             (if conversion-only
1489                 (cond ((or (eq code 611)
1490                            (eq code 614))
1491                        (list ?⿱ (nth 1 enc-str) new-str-c)
1492                        )
1493                       ((eq code 613)
1494                        (list ?⿳ (nth 1 enc-str)(nth 1 enc2-str) new-str-c)
1495                        ))
1496               (setq a-res (ids-find-chars-including-ids new-str))
1497               (list enc
1498                     f-res
1499                     new-str-c
1500                     a-res
1501                     (cond ((or (eq code 611)
1502                                (eq code 614))
1503                            (list ?⿱ (nth 1 enc-str) new-str-c)
1504                            )
1505                           ((eq code 613)
1506                            (list ?⿳ (nth 1 enc-str)(nth 1 enc2-str) new-str-c)
1507                            ))
1508                     code))
1509             ))
1510           )
1511          ((eq (car enc-str) ?⿳)
1512           (setq enc2-str (ideographic-character-get-structure (nth 3 enc-str)))
1513           (when (and enc2-str
1514                      (eq (car enc2-str) ?⿰))
1515             (unless conversion-only
1516               (setq f-res (ids-find-chars-including-ids enc-str)))
1517             (setq new-str (list ?⿲
1518                                 (nth 1 enc2-str)
1519                                 (nth 2 structure)
1520                                 (nth 2 enc2-str)))
1521             (setq new-str-c
1522                   (if (setq ret (ideographic-structure-find-chars new-str))
1523                       (car ret)
1524                     (list (cons 'ideographic-structure new-str))))
1525             (if conversion-only
1526                 (list ?⿳ (nth 1 enc-str) (nth 2 enc-str) new-str-c)
1527               (setq a-res (ids-find-chars-including-ids new-str))
1528               (list enc
1529                     f-res
1530                     new-str-c
1531                     a-res
1532                     (list ?⿳ (nth 1 enc-str) (nth 2 enc-str) new-str-c)
1533                     612))
1534             )
1535           )
1536          ((eq (car enc-str) ?⿲)
1537           (unless conversion-only
1538             (setq f-res (ids-find-chars-including-ids enc-str)))
1539           (setq new-str (list ?⿱
1540                               (nth 2 enc-str)
1541                               (nth 2 structure)))
1542           (setq new-str-c
1543                 (if (setq ret (ideographic-structure-find-chars new-str))
1544                     (car ret)
1545                   (list (cons 'ideographic-structure new-str))))
1546           (if conversion-only
1547               (list ?⿲ (nth 1 enc-str) new-str-c (nth 3 enc-str))
1548             (setq a-res (ids-find-chars-including-ids new-str))
1549             (list enc
1550                   f-res
1551                   new-str-c
1552                   a-res
1553                   (list ?⿲ (nth 1 enc-str) new-str-c (nth 3 enc-str))
1554                   620))
1555           )
1556          ((eq (car enc-str) ?⿴)
1557           (setq enc2-str (ideographic-character-get-structure (nth 1 enc-str)))
1558           (when (and enc2-str
1559                      (eq (car enc2-str) ?⿰))
1560             (unless conversion-only
1561               (setq f-res (ids-find-chars-including-ids enc-str)))
1562             (setq new-str (list ?⿱
1563                                 (nth 2 enc-str)
1564                                 (nth 2 structure)))
1565             (setq new-str-c
1566                   (if (setq ret (ideographic-structure-find-chars new-str))
1567                       (car ret)
1568                     (list (cons 'ideographic-structure new-str))))
1569             (if conversion-only
1570                 (list ?⿲ (nth 1 enc2-str) new-str-c (nth 2 enc2-str))
1571               (setq a-res (ids-find-chars-including-ids new-str))
1572               (list enc
1573                     f-res
1574                     new-str-c
1575                     a-res
1576                     (list ?⿲ (nth 1 enc2-str) new-str-c (nth 2 enc2-str))
1577                     630)))
1578           )
1579          ((eq (car enc-str) ?⿵)
1580           (unless conversion-only
1581             (setq f-res (ids-find-chars-including-ids enc-str)))
1582           (setq new-str (list ?⿱
1583                               (nth 2 enc-str)
1584                               (nth 2 structure)))
1585           (setq new-str-c
1586                 (if (setq ret (ideographic-structure-find-chars new-str))
1587                     (car ret)
1588                   (list (cons 'ideographic-structure new-str))))
1589           (if conversion-only
1590               (list ?⿵ (nth 1 enc-str) new-str-c)
1591             (setq a-res (ids-find-chars-including-ids new-str))
1592             (list enc
1593                   f-res
1594                   new-str-c
1595                   a-res
1596                   (list ?⿵ (nth 1 enc-str) new-str-c)
1597                   640))
1598           )
1599          ))
1600       )
1601      ((eq (car structure) ?⿷)
1602       (setq enc (nth 1 structure))
1603       (when (setq enc-str
1604                   (cond ((characterp enc)
1605                          (get-char-attribute enc 'ideographic-structure)
1606                          )
1607                         ((consp enc)
1608                          (cdr (assq 'ideographic-structure enc))
1609                          )))
1610         (cond
1611          ((eq (car enc-str) ?⿺)
1612           (unless conversion-only
1613             (setq f-res (ids-find-chars-including-ids enc-str)))
1614           (setq new-str (list ?⿱
1615                               (nth 2 enc-str)
1616                               (nth 2 structure)))
1617           (setq new-str-c
1618                 (if (setq ret (ideographic-structure-find-chars new-str))
1619                     (car ret)
1620                   (list (cons 'ideographic-structure new-str))))
1621           (if conversion-only
1622               (list ?⿺ (nth 1 enc-str) new-str-c)
1623             (setq a-res (ids-find-chars-including-ids new-str))
1624             (list enc
1625                   f-res
1626                   new-str-c
1627                   a-res
1628                   (list ?⿺ (nth 1 enc-str) new-str-c)
1629                   710))
1630           )
1631          ((eq (car enc-str) ?⿸)
1632           (unless conversion-only
1633             (setq f-res (ids-find-chars-including-ids enc-str)))
1634           (cond
1635            ((and (characterp (nth 2 enc-str))
1636                  (or (memq (char-ucs (nth 2 enc-str))
1637                            '(#x4EBA #x5165 #x513F #x51E0))
1638                      (memq (or (encode-char (nth 2 enc-str) '=>ucs@iwds-1)
1639                                (encode-char (nth 2 enc-str) '=>ucs@component))
1640                            '(#x4EBA #x513F))))
1641             (setq new-str (list ?⿺
1642                                 (nth 2 enc-str)
1643                                 (nth 2 structure)))
1644             (setq new-str-c
1645                   (if (setq ret (ideographic-structure-find-chars new-str))
1646                       (car ret)
1647                     (list (cons 'ideographic-structure new-str))))
1648             (if conversion-only
1649                 (list ?⿸ (nth 1 enc-str) new-str-c)
1650               (setq a-res (ids-find-chars-including-ids new-str))
1651               (list enc
1652                     f-res
1653                     new-str-c
1654                     a-res
1655                     (list ?⿸ (nth 1 enc-str) new-str-c)
1656                     721))
1657             )
1658            (t
1659             (setq new-str (list ?⿱
1660                                 (nth 2 structure)
1661                                 (nth 2 enc-str)))
1662             (setq new-str-c
1663                   (if (setq ret (ideographic-structure-find-chars new-str))
1664                       (car ret)
1665                     (list (cons 'ideographic-structure new-str))))
1666             (if conversion-only
1667                 (list ?⿸ (nth 1 enc-str) new-str-c)
1668               (setq a-res (ids-find-chars-including-ids new-str))
1669               (list enc
1670                     f-res
1671                     new-str-c
1672                     a-res
1673                     (list ?⿸ (nth 1 enc-str) new-str-c)
1674                     722))
1675             ))
1676           )
1677          ))
1678       )
1679      ((eq (car structure) ?⿺)
1680       (setq enc (nth 1 structure))
1681       (when (setq enc-str
1682                   (cond ((characterp enc)
1683                          (or (get-char-attribute enc 'ideographic-structure)
1684                              (get-char-attribute enc 'ideographic-structure@apparent)
1685                              (get-char-attribute enc 'ideographic-structure@apparent/leftmost))
1686                          )
1687                         ((consp enc)
1688                          (or (cdr (assq 'ideographic-structure enc))
1689                              (cdr (assq 'ideographic-structure@apparent enc))
1690                              (cdr (assq 'ideographic-structure@apparent/leftmost enc)))
1691                          )))
1692         ;; (setq enc-str
1693         ;;       (mapcar (lambda (cell)
1694         ;;                 (or (and (listp cell)
1695         ;;                          (find-char cell))
1696         ;;                     cell))
1697         ;;               enc-str))
1698         (cond
1699          ((eq (car enc-str) ?⿱)
1700           (cond
1701            ((and (characterp (nth 1 enc-str))
1702                  (or (and (eq (char-ucs (nth 1 enc-str)) #x200CA)
1703                           (setq code 811))
1704                      (and (eq (char-feature (nth 1 enc-str) '=>iwds-1) 233)
1705                           (characterp (nth 2 structure))
1706                           (eq (char-ucs (nth 2 structure)) #x4E36)
1707                           (setq code 812))))
1708             (unless conversion-only
1709               (setq f-res (ids-find-chars-including-ids enc-str)))
1710             (setq new-str (list ?⿺
1711                                 (nth 1 enc-str)
1712                                 (nth 2 structure)))
1713             (setq new-str-c
1714                   (if (setq ret (ideographic-structure-find-chars new-str))
1715                       (car ret)
1716                     (list (cons 'ideographic-structure new-str))))
1717             (if conversion-only
1718                 (list ?⿱ new-str-c (nth 2 enc-str))
1719               (setq a-res (ids-find-chars-including-ids new-str))
1720               (list enc
1721                     f-res
1722                     new-str-c
1723                     a-res
1724                     (list ?⿱ new-str-c (nth 2 enc-str))
1725                     code))
1726             )
1727            ((and (characterp (nth 2 enc-str))
1728                  (or (memq (char-ucs (nth 2 enc-str))
1729                            '(#x4E00
1730                              #x706C
1731                              #x65E5 #x66F0 #x5FC3
1732                              #x2123C #x58EC #x738B #x7389))
1733                      (memq (encode-char (nth 2 enc-str) '=>ucs@component)
1734                            '(#x2123C #x58EC))
1735                      (eq (encode-char (nth 2 enc-str) '=>ucs@iwds-1)
1736                          #x7389)
1737                      (eq (encode-char (nth 2 enc-str) '=>big5-cdp)
1738                          #x8D71)))
1739             (unless conversion-only
1740               (setq f-res (ids-find-chars-including-ids enc-str)))
1741             (setq new-str (list ?⿰
1742                                 (nth 1 enc-str)
1743                                 (nth 2 structure)))
1744             (setq new-str-c
1745                   (if (setq ret (ideographic-structure-find-chars new-str))
1746                       (car ret)
1747                     (list (cons 'ideographic-structure new-str))))
1748             (if conversion-only
1749                 (list ?⿱ new-str-c (nth 2 enc-str))
1750               (setq a-res (ids-find-chars-including-ids new-str))
1751               (list enc
1752                     f-res
1753                     new-str-c
1754                     a-res
1755                     (list ?⿱ new-str-c (nth 2 enc-str))
1756                     813))
1757             )
1758            ))))
1759       )
1760      ((eq (car structure) ?⿻)
1761       (setq enc (nth 1 structure))
1762       (when (setq enc-str
1763                   (cond ((characterp enc)
1764                          (get-char-attribute enc 'ideographic-structure)
1765                          )
1766                         ((consp enc)
1767                          (cdr (assq 'ideographic-structure enc))
1768                          )))
1769         (cond
1770          ((eq (car enc-str) ?⿱)
1771           (unless conversion-only
1772             (setq f-res (ids-find-chars-including-ids enc-str)))
1773           (if conversion-only
1774               (list ?⿳ (nth 1 enc-str) (nth 2 structure) (nth 2 enc-str))
1775             (list enc
1776                   f-res
1777                   new-str
1778                   nil
1779                   (list ?⿳
1780                         (nth 1 enc-str)
1781                         (nth 2 structure)
1782                         (nth 2 enc-str))
1783                   911))
1784           )))
1785       ))
1786     ))
1787
1788
1789 ;;; @ End.
1790 ;;;
1791
1792 (provide 'ids-find)
1793
1794 ;;; ids-find.el ends here