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