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