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