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                 (and (setq str
 603                            (get-char-attribute pc 'ideographic-structure@apparent/rightmost))
 604                      (ideographic-structure-equal str structure)))
 605         (setq pl (cons pc pl))
 606         ))
 607     pl))
 608
 609 ;;;###autoload
 610 (defun ideographic-char-count-components (char component)
 611   (let ((dest 0)
 612         structure)
 613     (cond ((eq char component)
 614            1)
 615           ((setq structure (get-char-attribute char 'ideographic-structure))
 616            (dolist (cell (ideographic-structure-to-components-alist structure))
 617              (setq dest
 618                    (+ dest
 619                       (if (eq (car cell) char)
 620                           (cdr cell)
 621                         (* (ideographic-char-count-components (car cell) component)
 622                            (cdr cell))))))
 623            dest)
 624           (t
 625            0))))
 626
 627
 628 ;;;###autoload
 629 (defun ideographic-character-get-structure (character)
 630   "Return ideographic-structure of CHARACTER.
 631 CHARACTER can be a character or char-spec."
 632   (mapcar (lambda (cell)
 633             (or (and (listp cell)
 634                      (find-char cell))
 635                 cell))
 636           (let (ret)
 637             (cond ((characterp character)
 638                    (get-char-attribute character 'ideographic-structure)
 639                    )
 640                   ((setq ret (assq 'ideographic-structure character))
 641                    (cdr ret)
 642                    )
 643                   ((setq ret (find-char character))
 644                    (get-char-attribute ret 'ideographic-structure)
 645                    )))))
 646
 647 ;;;###autoload
 648 (defun ideographic-char-match-component (char component)
 649   "Return non-nil if character CHAR has COMPONENT in ideographic-structure.
 650 COMPONENT can be a character or char-spec."
 651   (or (ideographic-structure-character= char component)
 652       (let ((str (ideographic-character-get-structure char)))
 653         (and str
 654              (or (ideographic-char-match-component (nth 1 str) component)
 655                  (ideographic-char-match-component (nth 2 str) component)
 656                  (if (memq (car str) '(?\u2FF2 ?\u2FF3))
 657                      (ideographic-char-match-component (nth 3 str) component)))))))
 658
 659 (defun ideographic-structure-char< (a b)
 660   (let ((sa (get-char-attribute a 'ideographic-structure))
 661         (sb (get-char-attribute b 'ideographic-structure))
 662         tsa tsb)
 663     (cond (sa
 664            (cond (sb
 665                   (setq tsa (char-total-strokes a)
 666                         tsb (char-total-strokes b))
 667                   (if tsa
 668                       (if tsb
 669                           (or (< tsa tsb)
 670                               (and (= tsa tsb)
 671                                    (ideograph-char< a b)))
 672                         t)
 673                     (if tsb
 674                         nil
 675                       (ideograph-char< a b))))
 676                  (t
 677                   nil))
 678            )
 679           (t
 680            (cond (sb
 681                   t)
 682                  (t
 683                   (setq tsa (char-total-strokes a)
 684                         tsb (char-total-strokes b))
 685                   (if tsa
 686                       (if tsb
 687                           (or (< tsa tsb)
 688                               (and (= tsa tsb)
 689                                    (ideograph-char< a b)))
 690                         t)
 691                     (if tsb
 692                         nil
 693                       (ideograph-char< a b)))
 694                   ))
 695            ))
 696     ))
 697
 698 (defun ideo-comp-tree-adjoin (tree char)
 699   (let ((rest tree)
 700         included ; other
 701         dest cell finished)
 702     (while (and (not finished)
 703                 rest)
 704       (setq cell (pop rest))
 705       (cond ((ideographic-structure-character= char (car cell))
 706              (setq finished t
 707                    dest tree
 708                    rest nil)
 709              )
 710             ((ideographic-char-match-component char (car cell))
 711              (setq dest
 712                    (cons (cons (car cell)
 713                                (ideo-comp-tree-adjoin (cdr cell) char))
 714                          dest))
 715              (setq finished t)
 716              )
 717             ((ideographic-char-match-component (car cell) char)
 718              (setq included (cons cell included))
 719              )
 720             ;; (included
 721             ;;  (setq other (cons cell other))
 722             ;;  )
 723             (t
 724              (setq dest (cons cell dest))
 725              )))
 726     (cond (finished
 727            (nconc dest rest)
 728            )
 729           (included
 730            (cons (cons char included)
 731                  (nconc dest rest))
 732            )
 733           (t
 734            (cons (list char) tree)
 735            ))))
 736
 737 (defun ideographic-chars-to-is-a-tree (chars)
 738   (let (tree)
 739     (dolist (char (sort (copy-list chars) #'ideographic-structure-char<))
 740       (setq tree (ideo-comp-tree-adjoin tree char)))
 741     tree))
 742
 743 (defun ids-find-chars-including-ids (structure)
 744   (let (comp-alist comp-spec ret str rest)
 745     (cond
 746      ((characterp structure)
 747       (setq rest (copy-list (get-char-attribute structure 'ideographic-products)))
 748       )
 749      ((setq ret (ideographic-structure-find-chars structure))
 750       (dolist (pc ret)
 751         (setq rest
 752               (union
 753                rest
 754                (copy-list (get-char-attribute pc 'ideographic-products)))))
 755       )
 756      (t
 757       (setq comp-alist (ideographic-structure-to-components-alist structure)
 758             comp-spec (list (cons 'ideographic-structure structure)))
 759       (dolist (pc (caar
 760                    (sort (mapcar (lambda (cell)
 761                                    (if (setq ret (get-char-attribute
 762                                                   (car cell) 'ideographic-products))
 763                                        (cons ret (length ret))
 764                                      (cons nil 0)))
 765                                  comp-alist)
 766                          (lambda (a b)
 767                            (< (cdr a)(cdr b))))))
 768         (when (and (every (lambda (cell)
 769                             (>= (ideographic-char-count-components pc (car cell))
 770                                 (cdr cell)))
 771                           comp-alist)
 772                    (or (ideographic-char-match-component pc comp-spec)
 773                        (and (setq str (get-char-attribute pc 'ideographic-structure))
 774                             (ideographic-char-match-component
 775                              (list
 776                               (cons
 777                                'ideographic-structure
 778                                (functional-ideographic-structure-to-apparent-structure
 779                                 str)))
 780                              comp-spec))))
 781           (push pc rest)))
 782       ))
 783     (ideographic-chars-to-is-a-tree rest)))
 784
 785 (defun functional-ideographic-structure-to-apparent-structure (structure)
 786   (ideographic-structure-compare-functional-and-apparent
 787    structure nil 'conversion-only))
 788
 789 ;;;###autoload
 790 (defun ideographic-structure-compact (structure)
 791   (let ((rest structure)
 792         cell
 793         ret dest sub)
 794     (while rest
 795       (setq cell (pop rest))
 796       (if (and (consp cell)
 797                (setq ret (find-char cell)))
 798           (setq cell ret))
 799       (cond
 800        ((and (consp cell)
 801              (cond ((setq ret (assq 'ideographic-structure cell))
 802                     (setq sub (cdr ret))
 803                     )
 804                    ((atom (car cell))
 805                     (setq sub cell)
 806                     )))
 807         (setq cell
 808               (cond ((setq ret (ideographic-structure-find-chars sub))
 809                      (car ret)
 810                      )
 811                     ((setq ret (ideographic-structure-compact sub))
 812                      (list (cons 'ideographic-structure ret))
 813                      )
 814                     (t
 815                      (list (cons 'ideographic-structure sub))))
 816               )
 817         ))
 818       (setq dest (cons cell dest)))
 819     (nreverse dest)))
 820
 821 (defun ideographic-structure-compare-functional-and-apparent (structure
 822                                                               &optional char
 823                                                               conversion-only)
 824   (let (enc enc-str enc2-str enc3-str new-str new-str-c
 825             f-res a-res ret code)
 826     (cond
 827      ((eq (car structure) ?⿸)
 828       (setq enc (nth 1 structure))
 829       (when (setq enc-str
 830                   (cond ((characterp enc)
 831                          (get-char-attribute enc 'ideographic-structure)
 832                          )
 833                         ((consp enc)
 834                          (cdr (assq 'ideographic-structure enc))
 835                          )))
 836         (cond
 837          ((eq (car enc-str) ?⿰)
 838           (unless conversion-only
 839             (setq f-res (ids-find-chars-including-ids enc-str)))
 840           (setq new-str (list ?⿱
 841                               (nth 2 enc-str)
 842                               (nth 2 structure)))
 843           (setq new-str-c
 844                 (if (setq ret (ideographic-structure-find-chars new-str))
 845                     (car ret)
 846                   (list (cons 'ideographic-structure new-str))))
 847           (if conversion-only
 848               (list ?⿰ (nth 1 enc-str) new-str-c)
 849             (setq a-res (ids-find-chars-including-ids new-str))
 850             (list enc
 851                   f-res
 852                   new-str-c
 853                   a-res
 854                   (list ?⿰ (nth 1 enc-str) new-str-c)
 855                   111))
 856           )
 857          ((and (eq (car enc-str) ?⿲)
 858                (memq (char-ucs (nth 1 enc-str)) '(#x4EBB #x2E85))
 859                (eq (nth 2 enc-str) ?丨))
 860           (unless conversion-only
 861             (setq f-res (ids-find-chars-including-ids enc-str)))
 862           (setq new-str (list ?⿱
 863                               (nth 3 enc-str)
 864                               (nth 2 structure)))
 865           (setq new-str-c
 866                 (if (setq ret (ideographic-structure-find-chars new-str))
 867                     (car ret)
 868                   (list (cons 'ideographic-structure new-str))))
 869           (if conversion-only
 870               (list ?⿰ (decode-char '=big5-cdp #x8B7A) new-str-c)
 871             (setq a-res (ids-find-chars-including-ids new-str))
 872             (list enc
 873                   f-res
 874                   new-str-c
 875                   a-res
 876                   (list ?⿰ (decode-char '=big5-cdp #x8B7A) new-str-c)
 877                   112))
 878           )
 879          ((eq (car enc-str) ?⿱)
 880           (unless conversion-only
 881             (setq f-res (ids-find-chars-including-ids enc-str)))
 882           (setq new-str
 883                 (list
 884                  (cond
 885                   ((characterp (nth 2 enc-str))
 886                    (if (or (memq (encode-char (nth 2 enc-str) '=>ucs@component)
 887                                  '(#x20087 #x5382 #x4E06))
 888                            (eq (encode-char (nth 2 enc-str) '=>ucs@iwds-1)
 889                                #x4E06)
 890                            (eq (encode-char (nth 2 enc-str) '=ucs-itaiji-001)
 891                                #x2E282)
 892                            (eq (encode-char (nth 2 enc-str) '=big5-cdp)
 893                                #x89CE)
 894                            (eq (encode-char (nth 2 enc-str) '=>big5-cdp)
 895                                #x88E2)
 896                            (eq (encode-char (nth 2 enc-str) '=big5-cdp)
 897                                #x88AD)
 898                            (eq (or (encode-char (nth 2 enc-str) '=>big5-cdp)
 899                                    (encode-char (nth 2 enc-str) '=big5-cdp-itaiji-001))
 900                                #x8766)
 901                            (eq (car (get-char-attribute (nth 2 enc-str)
 902                                                         'ideographic-structure))
 903                                ?⿸))
 904                        ?⿸
 905                      ?⿰))
 906                   ((eq (car (cdr (assq 'ideographic-structure (nth 2 enc-str))))
 907                        ?⿸)
 908                    ?⿸)
 909                   (t
 910                    ?⿰))
 911                  (nth 2 enc-str)
 912                  (nth 2 structure)))
 913           (setq new-str-c
 914                 (if (setq ret (ideographic-structure-find-chars new-str))
 915                     (car ret)
 916                   (list (cons 'ideographic-structure new-str))))
 917           (if conversion-only
 918               (list ?⿱ (nth 1 enc-str) new-str-c)
 919             (setq a-res (ids-find-chars-including-ids new-str))
 920             (list enc
 921                   f-res
 922                   new-str-c
 923                   a-res
 924                   (list ?⿱ (nth 1 enc-str) new-str-c)
 925                   (if (eq (car new-str) ?⿸)
 926                       121
 927                     122)))
 928           )
 929          ((eq (car enc-str) ?⿸)
 930           (unless conversion-only
 931             (setq f-res (ids-find-chars-including-ids enc-str)))
 932           (setq new-str (list (cond
 933                                ((characterp (nth 2 enc-str))
 934                                 (if (memq (char-ucs (nth 2 enc-str))
 935                                           '(#x5F73))
 936                                     ?⿰
 937                                   ?⿱)
 938                                 )
 939                                (t
 940                                 ?⿱))
 941                               (nth 2 enc-str)
 942                               (nth 2 structure)))
 943           (setq new-str-c
 944                 (if (setq ret (ideographic-structure-find-chars new-str))
 945                     (car ret)
 946                   (list (cons 'ideographic-structure new-str))))
 947           (if conversion-only
 948               (list ?⿸ (nth 1 enc-str) new-str-c)
 949             (setq a-res (ids-find-chars-including-ids new-str))
 950             (list enc
 951                   f-res
 952                   new-str-c
 953                   a-res
 954                   (list ?⿸ (nth 1 enc-str) new-str-c)
 955                   (if (eq (car new-str) ?⿰)
 956                       131
 957                     132)))
 958           )))
 959       )
 960      ((eq (car structure) ?⿹)
 961       (setq enc (nth 1 structure))
 962       (when (setq enc-str
 963                   (cond ((characterp enc)
 964                          (get-char-attribute enc 'ideographic-structure)
 965                          )
 966                         ((consp enc)
 967                          (cdr (assq 'ideographic-structure enc))
 968                          )))
 969         (cond
 970          ((eq (car enc-str) ?⿰)
 971           (unless conversion-only
 972             (setq f-res (ids-find-chars-including-ids enc-str)))
 973           (setq new-str (list ?⿱
 974                               (nth 1 enc-str)
 975                               (nth 2 structure)))
 976           (setq new-str-c
 977                 (if (setq ret (ideographic-structure-find-chars new-str))
 978                     (car ret)
 979                   (list (cons 'ideographic-structure new-str))))
 980           (if conversion-only
 981               (list ?⿰ new-str-c (nth 2 enc-str))
 982             (setq a-res (ids-find-chars-including-ids new-str))
 983             (list enc
 984                   f-res
 985                   new-str-c
 986                   a-res
 987                   (list ?⿰ new-str-c (nth 2 enc-str))
 988                   210))
 989           )
 990          ((eq (car enc-str) ?⿱)
 991           (unless conversion-only
 992             (setq f-res (ids-find-chars-including-ids enc-str)))
 993           (setq new-str (list ?⿰
 994                               (nth 2 structure)
 995                               (nth 2 enc-str)))
 996           (setq new-str-c
 997                 (if (setq ret (ideographic-structure-find-chars new-str))
 998                     (car ret)
 999                   (list (cons 'ideographic-structure new-str))))
1000           (if conversion-only
1001               (list ?⿱ (nth 1 enc-str) new-str-c)
1002             (setq a-res (ids-find-chars-including-ids new-str))
1003             (list enc
1004                   f-res
1005                   new-str-c
1006                   a-res
1007                   (list ?⿱ (nth 1 enc-str) new-str-c)
1008                   220))
1009           )
1010          ))
1011       )
1012      ((eq (get-char-attribute (car structure) '=ucs-itaiji-001) #x2FF6)
1013       (setq enc (nth 1 structure))
1014       (when (setq enc-str
1015                   (cond ((characterp enc)
1016                          (get-char-attribute enc 'ideographic-structure)
1017                          )
1018                         ((consp enc)
1019                          (cdr (assq 'ideographic-structure enc))
1020                          )))
1021         (cond
1022          ((eq (car enc-str) ?⿺)
1023           (unless conversion-only
1024             (setq f-res (ids-find-chars-including-ids enc-str)))
1025           (setq new-str (list ?⿱
1026                               (nth 2 structure)
1027                               (nth 1 enc-str)))
1028           (setq new-str-c
1029                 (if (setq ret (ideographic-structure-find-chars new-str))
1030                     (car ret)
1031                   (list (cons 'ideographic-structure new-str))))
1032           (if conversion-only
1033               (list ?⿺ new-str-c (nth 2 enc-str))
1034             (setq a-res (ids-find-chars-including-ids new-str))
1035             (list enc
1036                   f-res
1037                   new-str-c
1038                   a-res
1039                   (list ?⿺ new-str-c (nth 2 enc-str))
1040                   310))
1041           )
1042          ((eq (car enc-str) ?⿱)
1043           (unless conversion-only
1044             (setq f-res (ids-find-chars-including-ids enc-str)))
1045           (setq new-str (list ?⿰
1046                               (nth 2 structure)
1047                               (nth 1 enc-str)))
1048           (setq new-str-c
1049                 (if (setq ret (ideographic-structure-find-chars new-str))
1050                     (car ret)
1051                   (list (cons 'ideographic-structure new-str))))
1052           (if conversion-only
1053               (list ?⿱ new-str-c (nth 2 enc-str))
1054             (setq a-res (ids-find-chars-including-ids new-str))
1055             (list enc
1056                   f-res
1057                   new-str-c
1058                   a-res
1059                   (list ?⿱ new-str-c (nth 2 enc-str))
1060                   320))
1061           )
1062          ((eq (car enc-str) ?⿰)
1063           (unless conversion-only
1064             (setq f-res (ids-find-chars-including-ids enc-str)))
1065           (setq new-str (list ?⿱
1066                               (nth 2 structure)
1067                               (nth 1 enc-str)))
1068           (setq new-str-c
1069                 (if (setq ret (ideographic-structure-find-chars new-str))
1070                     (car ret)
1071                   (list (cons 'ideographic-structure new-str))))
1072           (if conversion-only
1073               (list ?⿰ new-str-c (nth 2 enc-str))
1074             (setq a-res (ids-find-chars-including-ids new-str))
1075             (list enc
1076                   f-res
1077                   new-str-c
1078                   a-res
1079                   (list ?⿰ new-str-c (nth 2 enc-str))
1080                   330))
1081           ))
1082         )
1083       )
1084      ((eq (car structure) ?⿴)
1085       (setq enc (nth 1 structure))
1086       (when (setq enc-str
1087                   (cond ((characterp enc)
1088                          (get-char-attribute enc 'ideographic-structure)
1089                          )
1090                         ((consp enc)
1091                          (cdr (assq 'ideographic-structure enc))
1092                          )))
1093         (cond
1094          ((eq (car enc-str) ?⿱)
1095           (cond
1096            ((and (characterp (nth 2 enc-str))
1097                  (or (memq (char-ucs (nth 2 enc-str)) '(#x56D7 #x5F51 #x897F))
1098                      (eq (char-feature (nth 2 enc-str) '=>big5-cdp)
1099                          #x87A5)))
1100             (unless conversion-only
1101               (setq f-res (ids-find-chars-including-ids enc-str)))
1102             (setq new-str (list ?⿴
1103                                 (nth 2 enc-str)
1104                                 (nth 2 structure)))
1105             (setq new-str-c
1106                   (if (setq ret (ideographic-structure-find-chars new-str))
1107                       (car ret)
1108                     (list (cons 'ideographic-structure new-str))))
1109             (if conversion-only
1110                 (list ?⿱ (nth 1 enc-str) new-str-c)
1111               (setq a-res (ids-find-chars-including-ids new-str))
1112               (list enc
1113                     f-res
1114                     new-str-c
1115                     a-res
1116                     (list ?⿱ (nth 1 enc-str) new-str-c)
1117                     411))
1118             )
1119            ((and (characterp (nth 2 enc-str))
1120                  (eq (char-ucs (nth 2 enc-str)) #x51F5))
1121             (unless conversion-only
1122               (setq f-res (ids-find-chars-including-ids enc-str)))
1123             (setq new-str (list ?⿶
1124                                 (nth 2 enc-str)
1125                                 (nth 2 structure)))
1126             (setq new-str-c
1127                   (if (setq ret (ideographic-structure-find-chars new-str))
1128                       (car ret)
1129                     (list (cons 'ideographic-structure new-str))))
1130             (if conversion-only
1131                 (list ?⿱ (nth 1 enc-str) new-str-c)
1132               (setq a-res (ids-find-chars-including-ids new-str))
1133               (list enc
1134                     f-res
1135                     new-str-c
1136                     a-res
1137                     (list ?⿱ (nth 1 enc-str) new-str-c)
1138                     412))
1139             )
1140            ((and (characterp (nth 1 enc-str))
1141                  (eq (char-feature (nth 1 enc-str) '=>ucs@component)
1142                      #x300E6))
1143             (unless conversion-only
1144               (setq f-res (ids-find-chars-including-ids enc-str)))
1145             (setq new-str (list ?⿵
1146                                 (nth 1 enc-str)
1147                                 (nth 2 structure)))
1148             (setq new-str-c
1149                   (if (setq ret (ideographic-structure-find-chars new-str))
1150                       (car ret)
1151                     (list (cons 'ideographic-structure new-str))))
1152             (if conversion-only
1153                 (list ?⿱ new-str-c (nth 2 enc-str))
1154               (setq a-res (ids-find-chars-including-ids new-str))
1155               (list enc
1156                     f-res
1157                     new-str-c
1158                     a-res
1159                     (list ?⿱ new-str-c (nth 2 enc-str))
1160                     413))
1161             )
1162            (t
1163             (unless conversion-only
1164               (setq f-res (ids-find-chars-including-ids enc-str)))
1165             (setq new-str (list ?⿱ (nth 2 structure) (nth 2 enc-str)))
1166             (setq new-str-c
1167                   (if (setq ret (ideographic-structure-find-chars new-str))
1168                       (car ret)
1169                     (list (cons 'ideographic-structure new-str))))
1170             (if conversion-only
1171                 (list ?⿱ (nth 1 enc-str) new-str-c)
1172               (setq a-res (ids-find-chars-including-ids new-str))
1173               (list enc
1174                     f-res
1175                     new-str-c
1176                     a-res
1177                     (list ?⿱ (nth 1 enc-str) new-str-c)
1178                     414))
1179             ))
1180           )
1181          ((eq (car enc-str) ?⿳)
1182           (cond
1183            ((and (characterp (nth 2 enc-str))
1184                  (eq (char-ucs (nth 2 enc-str)) #x56D7))
1185             (unless conversion-only
1186               (setq f-res (ids-find-chars-including-ids enc-str)))
1187             (setq new-str (list ?⿴ (nth 2 enc-str) (nth 2 structure)))
1188             (setq new-str-c
1189                   (if (setq ret (ideographic-structure-find-chars new-str))
1190                       (car ret)
1191                     (list (cons 'ideographic-structure new-str))))
1192             (setq new-str (list ?⿱ (nth 1 enc-str) new-str-c))
1193             (setq new-str-c
1194                   (if (setq ret (ideographic-structure-find-chars new-str))
1195                       (car ret)
1196                     (list (cons 'ideographic-structure new-str))))
1197             (if conversion-only
1198                 (list ?⿱  new-str-c (nth 3 enc-str))
1199               (setq a-res (ids-find-chars-including-ids new-str))
1200               (list enc
1201                     f-res
1202                     new-str-c
1203                     a-res
1204                     (list ?⿱  new-str-c (nth 3 enc-str))
1205                     415))
1206             )
1207            ((and (characterp (nth 2 enc-str))
1208                  (eq (char-ucs (nth 2 enc-str)) #x5196))
1209             (unless conversion-only
1210               (setq f-res (ids-find-chars-including-ids enc-str)))
1211             (setq new-str (list ?⿱ (nth 1 enc-str) (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             (setq new-str (list ?⿱ new-str-c (nth 2 structure)))
1217             (setq new-str-c
1218                   (if (setq ret (ideographic-structure-find-chars new-str))
1219                       (car ret)
1220                     (list (cons 'ideographic-structure new-str))))
1221             (if conversion-only
1222                 (list ?⿱ new-str-c (nth 3 enc-str))
1223               (setq a-res (ids-find-chars-including-ids new-str))
1224               (list enc
1225                     f-res
1226                     new-str-c
1227                     a-res
1228                     (list ?⿱ new-str-c (nth 3 enc-str))
1229                     416))
1230             )
1231            ((and (characterp (nth 2 enc-str))
1232                  (or (eq (encode-char (nth 2 enc-str) '=>big5-cdp)
1233                          #x89A6)
1234                      (eq (encode-char (nth 2 enc-str) '=>gt-k)
1235                          146)
1236                      (eq (char-ucs (nth 2 enc-str)) #x2008A)))
1237             (unless conversion-only
1238               (setq f-res (ids-find-chars-including-ids enc-str)))
1239             (setq new-str (list ?⿱ (nth 2 structure) (nth 2 enc-str)))
1240             (setq new-str-c
1241                   (if (setq ret (ideographic-structure-find-chars new-str))
1242                       (car ret)
1243                     (list (cons 'ideographic-structure new-str))))
1244             (setq new-str (list ?⿸ new-str-c (nth 3 enc-str)))
1245             (setq new-str-c
1246                   (if (setq ret (ideographic-structure-find-chars new-str))
1247                       (car ret)
1248                     (list (cons 'ideographic-structure new-str))))
1249             (if conversion-only
1250                 (list ?⿱ (nth 1 enc-str) new-str-c)
1251               (setq a-res (ids-find-chars-including-ids new-str))
1252               (list enc
1253                     f-res
1254                     new-str-c
1255                     a-res
1256                     (list ?⿱ (nth 1 enc-str) new-str-c)
1257                     417))
1258             )
1259            (t
1260             (unless conversion-only
1261               (setq f-res (ids-find-chars-including-ids enc-str)))
1262             (setq new-str (list ?⿻ (nth 2 enc-str) (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             (setq new-str (list ?⿱ (nth 1 enc-str) new-str-c))
1268             (setq new-str-c
1269                   (if (setq ret (ideographic-structure-find-chars new-str))
1270                       (car ret)
1271                     (list (cons 'ideographic-structure new-str))))
1272             (if conversion-only
1273                 (list ?⿱  new-str-c (nth 3 enc-str))
1274               (setq a-res (ids-find-chars-including-ids new-str))
1275               (list enc
1276                     f-res
1277                     new-str-c
1278                     a-res
1279                     (list ?⿱  new-str-c (nth 3 enc-str))
1280                     419))
1281             ))
1282           )
1283          ((eq (car enc-str) ?⿰)
1284           (cond
1285            ((equal (nth 1 enc-str)(nth 2 enc-str))
1286             (unless conversion-only
1287               (setq f-res (ids-find-chars-including-ids enc-str)))
1288             (setq new-str (list ?⿲
1289                                 (nth 1 enc-str)
1290                                 (nth 2 structure)
1291                                 (nth 2 enc-str)))
1292             (setq new-str-c
1293                   (list (cons 'ideographic-structure new-str)))
1294             (if conversion-only
1295                 new-str
1296               (setq a-res (ids-find-chars-including-ids new-str))
1297               (list enc
1298                     f-res
1299                     new-str-c
1300                     a-res
1301                     new-str
1302                     421))
1303             )
1304            (t
1305             (unless conversion-only
1306               (setq f-res (ids-find-chars-including-ids enc-str)))
1307             (setq new-str (list ?⿰
1308                                 (nth 2 structure)
1309                                 (nth 2 enc-str)))
1310             (setq new-str-c
1311                   (if (setq ret (ideographic-structure-find-chars new-str))
1312                       (car ret)
1313                     (list (cons 'ideographic-structure new-str))))
1314             (if conversion-only
1315                 (list ?⿰ (nth 1 enc-str) new-str-c)
1316               (setq a-res (ids-find-chars-including-ids new-str))
1317               (list enc
1318                     f-res
1319                     new-str-c
1320                     a-res
1321                     (list ?⿰ (nth 1 enc-str) new-str-c)
1322                     422))
1323             ))
1324           ))
1325         )
1326       )
1327      ((eq (car structure) ?⿶)
1328       (setq enc (nth 1 structure))
1329       (when (setq enc-str
1330                   (cond ((characterp enc)
1331                          (get-char-attribute enc 'ideographic-structure)
1332                          )
1333                         ((consp enc)
1334                          (cdr (assq 'ideographic-structure enc))
1335                          )))
1336         (cond
1337          ((eq (car enc-str) ?⿱)
1338           (setq enc2-str (ideographic-character-get-structure (nth 1 enc-str)))
1339           (when (and enc2-str
1340                      (eq (car enc2-str) ?⿰))
1341             (unless conversion-only
1342               (setq f-res (ids-find-chars-including-ids enc-str)))
1343             (setq new-str (list ?⿲
1344                                 (nth 1 enc2-str)
1345                                 (nth 2 structure)
1346                                 (nth 2 enc2-str)))
1347             (setq new-str-c
1348                   (if (setq ret (ideographic-structure-find-chars new-str))
1349                       (car ret)
1350                     (list (cons 'ideographic-structure new-str))))
1351             (if conversion-only
1352                 (list ?⿱ new-str-c (nth 2 enc-str))
1353               (setq a-res (ids-find-chars-including-ids new-str))
1354               (list enc
1355                     f-res
1356                     new-str-c
1357                     a-res
1358                     (list ?⿱ new-str-c (nth 2 enc-str))
1359                     511))
1360             )
1361           )
1362          ((eq (car enc-str) ?⿳)
1363           (setq enc2-str (ideographic-character-get-structure (nth 1 enc-str)))
1364           (when (and enc2-str
1365                      (eq (car enc2-str) ?⿰))
1366             (unless conversion-only
1367               (setq f-res (ids-find-chars-including-ids enc-str)))
1368             (setq new-str (list ?⿲
1369                                 (nth 1 enc2-str)
1370                                 (nth 2 structure)
1371                                 (nth 2 enc2-str)))
1372             (setq new-str-c
1373                   (if (setq ret (ideographic-structure-find-chars new-str))
1374                       (car ret)
1375                     (list (cons 'ideographic-structure new-str))))
1376             (if conversion-only
1377                 (list ?⿳ new-str-c (nth 2 enc-str) (nth 3 enc-str))
1378               (setq a-res (ids-find-chars-including-ids new-str))
1379               (list enc
1380                     f-res
1381                     new-str-c
1382                     a-res
1383                     (list ?⿳ new-str-c (nth 2 enc-str) (nth 3 enc-str))
1384                     512))
1385             )
1386           )
1387          ((eq (car enc-str) ?⿲)
1388           (unless conversion-only
1389             (setq f-res (ids-find-chars-including-ids enc-str)))
1390           (setq new-str (list ?⿱
1391                               (nth 2 structure)
1392                               (nth 2 enc-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 ?⿲ (nth 1 enc-str) new-str-c (nth 3 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 ?⿲ (nth 1 enc-str) new-str-c (nth 3 enc-str))
1405                   520))
1406           )
1407          ((eq (car enc-str) ?⿴)
1408           (setq enc2-str (ideographic-character-get-structure (nth 1 enc-str)))
1409           (when (and enc2-str
1410                      (eq (car enc2-str) ?⿰))
1411             (unless conversion-only
1412               (setq f-res (ids-find-chars-including-ids enc-str)))
1413             (setq new-str (list ?⿱
1414                                 (nth 2 structure)
1415                                 (nth 2 enc-str)))
1416             (setq new-str-c
1417                   (if (setq ret (ideographic-structure-find-chars new-str))
1418                       (car ret)
1419                     (list (cons 'ideographic-structure new-str))))
1420             (if conversion-only
1421                 (list ?⿲ (nth 1 enc2-str) new-str-c (nth 2 enc2-str))
1422               (setq a-res (ids-find-chars-including-ids new-str))
1423               (list enc
1424                     f-res
1425                     new-str-c
1426                     a-res
1427                     (list ?⿲ (nth 1 enc2-str) new-str-c (nth 2 enc2-str))
1428                     530))
1429             )
1430           )))
1431       )
1432      ((eq (car structure) ?⿵)
1433       (setq enc (nth 1 structure))
1434       (when (setq enc-str
1435                   (cond ((characterp enc)
1436                          (get-char-attribute enc 'ideographic-structure)
1437                          )
1438                         ((consp enc)
1439                          (cdr (assq 'ideographic-structure enc))
1440                          )))
1441         (cond
1442          ((eq (car enc-str) ?⿱)
1443           (cond
1444            ((and (characterp (nth 2 enc-str))
1445                  (memq (char-ucs (nth 2 enc-str))
1446                        '(#x9580 #x9B25)))
1447             (unless conversion-only
1448               (setq f-res (ids-find-chars-including-ids enc-str)))
1449             (setq new-str (list ?⿵
1450                                 (nth 2 enc-str)
1451                                 (nth 2 structure)))
1452             (setq new-str-c
1453                   (if (setq ret (ideographic-structure-find-chars new-str))
1454                       (car ret)
1455                     (list (cons 'ideographic-structure new-str))))
1456             (if conversion-only
1457                 (list ?⿱ (nth 1 enc-str) new-str-c)
1458               (setq a-res (ids-find-chars-including-ids new-str))
1459               (list enc
1460                     f-res
1461                     new-str-c
1462                     a-res
1463                     (list ?⿱ (nth 1 enc-str) new-str-c)
1464                     601))
1465             )
1466            ((and (setq enc2-str (ideographic-character-get-structure (nth 2 enc-str)))
1467                  (cond
1468                   ((eq (car enc2-str) ?⿰)
1469                    (setq code 611)
1470                    )
1471                   ((eq (car enc2-str) ?⿲)
1472                    (setq code 614)
1473                    )
1474                   ((and (eq (car enc2-str) ?⿱)
1475                         (setq enc3-str
1476                               (ideographic-character-get-structure (nth 2 enc2-str)))
1477                         (eq (car enc3-str) ?⿰))
1478                    (setq code 613)
1479                    )))
1480             (unless conversion-only
1481               (setq f-res (ids-find-chars-including-ids enc-str)))
1482             (setq new-str
1483                   (cond ((eq code 611)
1484                          (list ?⿲
1485                                (nth 1 enc2-str)
1486                                (nth 2 structure)
1487                                (nth 2 enc2-str))
1488                          )
1489                         ((eq code 613)
1490                          (list ?⿲
1491                                (nth 1 enc3-str)
1492                                (nth 2 structure)
1493                                (nth 2 enc3-str))
1494                          )
1495                         ((eq code 614)
1496                          (list ?⿲
1497                                (nth 1 enc2-str)
1498                                (list (list 'ideographic-structure
1499                                            ?⿱
1500                                            (nth 2 enc2-str)
1501                                            (nth 2 structure)))
1502                                (nth 3 enc2-str))
1503                          )))
1504             (setq new-str-c
1505                   (if (setq ret (ideographic-structure-find-chars new-str))
1506                       (car ret)
1507                     (list (cons 'ideographic-structure
1508                                 (ideographic-structure-compact new-str)))))
1509             (if conversion-only
1510                 (cond ((or (eq code 611)
1511                            (eq code 614))
1512                        (list ?⿱ (nth 1 enc-str) new-str-c)
1513                        )
1514                       ((eq code 613)
1515                        (list ?⿳ (nth 1 enc-str)(nth 1 enc2-str) new-str-c)
1516                        ))
1517               (setq a-res (ids-find-chars-including-ids new-str))
1518               (list enc
1519                     f-res
1520                     new-str-c
1521                     a-res
1522                     (cond ((or (eq code 611)
1523                                (eq code 614))
1524                            (list ?⿱ (nth 1 enc-str) new-str-c)
1525                            )
1526                           ((eq code 613)
1527                            (list ?⿳ (nth 1 enc-str)(nth 1 enc2-str) new-str-c)
1528                            ))
1529                     code))
1530             ))
1531           )
1532          ((eq (car enc-str) ?⿳)
1533           (setq enc2-str (ideographic-character-get-structure (nth 3 enc-str)))
1534           (when (and enc2-str
1535                      (eq (car enc2-str) ?⿰))
1536             (unless conversion-only
1537               (setq f-res (ids-find-chars-including-ids enc-str)))
1538             (setq new-str (list ?⿲
1539                                 (nth 1 enc2-str)
1540                                 (nth 2 structure)
1541                                 (nth 2 enc2-str)))
1542             (setq new-str-c
1543                   (if (setq ret (ideographic-structure-find-chars new-str))
1544                       (car ret)
1545                     (list (cons 'ideographic-structure new-str))))
1546             (if conversion-only
1547                 (list ?⿳ (nth 1 enc-str) (nth 2 enc-str) new-str-c)
1548               (setq a-res (ids-find-chars-including-ids new-str))
1549               (list enc
1550                     f-res
1551                     new-str-c
1552                     a-res
1553                     (list ?⿳ (nth 1 enc-str) (nth 2 enc-str) new-str-c)
1554                     612))
1555             )
1556           )
1557          ((eq (car enc-str) ?⿲)
1558           (unless conversion-only
1559             (setq f-res (ids-find-chars-including-ids enc-str)))
1560           (setq new-str (list ?⿱
1561                               (nth 2 enc-str)
1562                               (nth 2 structure)))
1563           (setq new-str-c
1564                 (if (setq ret (ideographic-structure-find-chars new-str))
1565                     (car ret)
1566                   (list (cons 'ideographic-structure new-str))))
1567           (if conversion-only
1568               (list ?⿲ (nth 1 enc-str) new-str-c (nth 3 enc-str))
1569             (setq a-res (ids-find-chars-including-ids new-str))
1570             (list enc
1571                   f-res
1572                   new-str-c
1573                   a-res
1574                   (list ?⿲ (nth 1 enc-str) new-str-c (nth 3 enc-str))
1575                   620))
1576           )
1577          ((eq (car enc-str) ?⿴)
1578           (setq enc2-str (ideographic-character-get-structure (nth 1 enc-str)))
1579           (when (and enc2-str
1580                      (eq (car enc2-str) ?⿰))
1581             (unless conversion-only
1582               (setq f-res (ids-find-chars-including-ids enc-str)))
1583             (setq new-str (list ?⿱
1584                                 (nth 2 enc-str)
1585                                 (nth 2 structure)))
1586             (setq new-str-c
1587                   (if (setq ret (ideographic-structure-find-chars new-str))
1588                       (car ret)
1589                     (list (cons 'ideographic-structure new-str))))
1590             (if conversion-only
1591                 (list ?⿲ (nth 1 enc2-str) new-str-c (nth 2 enc2-str))
1592               (setq a-res (ids-find-chars-including-ids new-str))
1593               (list enc
1594                     f-res
1595                     new-str-c
1596                     a-res
1597                     (list ?⿲ (nth 1 enc2-str) new-str-c (nth 2 enc2-str))
1598                     630)))
1599           )
1600          ((eq (car enc-str) ?⿵)
1601           (unless conversion-only
1602             (setq f-res (ids-find-chars-including-ids enc-str)))
1603           (setq new-str (list ?⿱
1604                               (nth 2 enc-str)
1605                               (nth 2 structure)))
1606           (setq new-str-c
1607                 (if (setq ret (ideographic-structure-find-chars new-str))
1608                     (car ret)
1609                   (list (cons 'ideographic-structure new-str))))
1610           (if conversion-only
1611               (list ?⿵ (nth 1 enc-str) new-str-c)
1612             (setq a-res (ids-find-chars-including-ids new-str))
1613             (list enc
1614                   f-res
1615                   new-str-c
1616                   a-res
1617                   (list ?⿵ (nth 1 enc-str) new-str-c)
1618                   640))
1619           )
1620          ))
1621       )
1622      ((eq (car structure) ?⿷)
1623       (setq enc (nth 1 structure))
1624       (when (setq enc-str
1625                   (cond ((characterp enc)
1626                          (get-char-attribute enc 'ideographic-structure)
1627                          )
1628                         ((consp enc)
1629                          (cdr (assq 'ideographic-structure enc))
1630                          )))
1631         (cond
1632          ((eq (car enc-str) ?⿺)
1633           (unless conversion-only
1634             (setq f-res (ids-find-chars-including-ids enc-str)))
1635           (setq new-str (list ?⿱
1636                               (nth 2 enc-str)
1637                               (nth 2 structure)))
1638           (setq new-str-c
1639                 (if (setq ret (ideographic-structure-find-chars new-str))
1640                     (car ret)
1641                   (list (cons 'ideographic-structure new-str))))
1642           (if conversion-only
1643               (list ?⿺ (nth 1 enc-str) new-str-c)
1644             (setq a-res (ids-find-chars-including-ids new-str))
1645             (list enc
1646                   f-res
1647                   new-str-c
1648                   a-res
1649                   (list ?⿺ (nth 1 enc-str) new-str-c)
1650                   710))
1651           )
1652          ((eq (car enc-str) ?⿸)
1653           (unless conversion-only
1654             (setq f-res (ids-find-chars-including-ids enc-str)))
1655           (cond
1656            ((and (characterp (nth 2 enc-str))
1657                  (or (memq (char-ucs (nth 2 enc-str))
1658                            '(#x4EBA #x5165 #x513F #x51E0))
1659                      (memq (or (encode-char (nth 2 enc-str) '=>ucs@iwds-1)
1660                                (encode-char (nth 2 enc-str) '=>ucs@component))
1661                            '(#x4EBA #x513F))))
1662             (setq new-str (list ?⿺
1663                                 (nth 2 enc-str)
1664                                 (nth 2 structure)))
1665             (setq new-str-c
1666                   (if (setq ret (ideographic-structure-find-chars new-str))
1667                       (car ret)
1668                     (list (cons 'ideographic-structure new-str))))
1669             (if conversion-only
1670                 (list ?⿸ (nth 1 enc-str) new-str-c)
1671               (setq a-res (ids-find-chars-including-ids new-str))
1672               (list enc
1673                     f-res
1674                     new-str-c
1675                     a-res
1676                     (list ?⿸ (nth 1 enc-str) new-str-c)
1677                     721))
1678             )
1679            (t
1680             (setq new-str (list ?⿱
1681                                 (nth 2 structure)
1682                                 (nth 2 enc-str)))
1683             (setq new-str-c
1684                   (if (setq ret (ideographic-structure-find-chars new-str))
1685                       (car ret)
1686                     (list (cons 'ideographic-structure new-str))))
1687             (if conversion-only
1688                 (list ?⿸ (nth 1 enc-str) new-str-c)
1689               (setq a-res (ids-find-chars-including-ids new-str))
1690               (list enc
1691                     f-res
1692                     new-str-c
1693                     a-res
1694                     (list ?⿸ (nth 1 enc-str) new-str-c)
1695                     722))
1696             ))
1697           )
1698          ))
1699       )
1700      ((eq (car structure) ?⿺)
1701       (setq enc (nth 1 structure))
1702       (when (setq enc-str
1703                   (cond ((characterp enc)
1704                          (or (get-char-attribute enc 'ideographic-structure)
1705                              (get-char-attribute enc 'ideographic-structure@apparent)
1706                              (get-char-attribute enc 'ideographic-structure@apparent/leftmost)
1707                              (get-char-attribute enc 'ideographic-structure@apparent/rightmost))
1708                          )
1709                         ((consp enc)
1710                          (or (cdr (assq 'ideographic-structure enc))
1711                              (cdr (assq 'ideographic-structure@apparent enc))
1712                              (cdr (assq 'ideographic-structure@apparent/leftmost enc))
1713                              (cdr (assq 'ideographic-structure@apparent/rightmost enc)))
1714                          )))
1715         ;; (setq enc-str
1716         ;;       (mapcar (lambda (cell)
1717         ;;                 (or (and (listp cell)
1718         ;;                          (find-char cell))
1719         ;;                     cell))
1720         ;;               enc-str))
1721         (cond
1722          ((eq (car enc-str) ?⿱)
1723           (cond
1724            ((and (characterp (nth 1 enc-str))
1725                  (or (and (eq (char-ucs (nth 1 enc-str)) #x200CA)
1726                           (setq code 811))
1727                      (and (eq (char-feature (nth 1 enc-str) '=>iwds-1) 233)
1728                           (characterp (nth 2 structure))
1729                           (eq (char-ucs (nth 2 structure)) #x4E36)
1730                           (setq code 812))))
1731             (unless conversion-only
1732               (setq f-res (ids-find-chars-including-ids enc-str)))
1733             (setq new-str (list ?⿺
1734                                 (nth 1 enc-str)
1735                                 (nth 2 structure)))
1736             (setq new-str-c
1737                   (if (setq ret (ideographic-structure-find-chars new-str))
1738                       (car ret)
1739                     (list (cons 'ideographic-structure new-str))))
1740             (if conversion-only
1741                 (list ?⿱ new-str-c (nth 2 enc-str))
1742               (setq a-res (ids-find-chars-including-ids new-str))
1743               (list enc
1744                     f-res
1745                     new-str-c
1746                     a-res
1747                     (list ?⿱ new-str-c (nth 2 enc-str))
1748                     code))
1749             )
1750            ((and (characterp (nth 2 enc-str))
1751                  (or (memq (char-ucs (nth 2 enc-str))
1752                            '(#x4E00
1753                              #x706C
1754                              #x65E5 #x66F0 #x5FC3
1755                              #x2123C #x58EC #x738B #x7389))
1756                      (memq (encode-char (nth 2 enc-str) '=>ucs@component)
1757                            '(#x2123C #x58EC))
1758                      (eq (encode-char (nth 2 enc-str) '=>ucs@iwds-1)
1759                          #x7389)
1760                      (eq (encode-char (nth 2 enc-str) '=>big5-cdp)
1761                          #x8D71)))
1762             (unless conversion-only
1763               (setq f-res (ids-find-chars-including-ids enc-str)))
1764             (setq new-str (list ?⿰
1765                                 (nth 1 enc-str)
1766                                 (nth 2 structure)))
1767             (setq new-str-c
1768                   (if (setq ret (ideographic-structure-find-chars new-str))
1769                       (car ret)
1770                     (list (cons 'ideographic-structure new-str))))
1771             (if conversion-only
1772                 (list ?⿱ new-str-c (nth 2 enc-str))
1773               (setq a-res (ids-find-chars-including-ids new-str))
1774               (list enc
1775                     f-res
1776                     new-str-c
1777                     a-res
1778                     (list ?⿱ new-str-c (nth 2 enc-str))
1779                     813))
1780             )
1781            ))))
1782       )
1783      ((eq (car structure) ?⿻)
1784       (setq enc (nth 1 structure))
1785       (when (setq enc-str
1786                   (cond ((characterp enc)
1787                          (get-char-attribute enc 'ideographic-structure)
1788                          )
1789                         ((consp enc)
1790                          (cdr (assq 'ideographic-structure enc))
1791                          )))
1792         (cond
1793          ((eq (car enc-str) ?⿱)
1794           (unless conversion-only
1795             (setq f-res (ids-find-chars-including-ids enc-str)))
1796           (if conversion-only
1797               (list ?⿳ (nth 1 enc-str) (nth 2 structure) (nth 2 enc-str))
1798             (list enc
1799                   f-res
1800                   new-str
1801                   nil
1802                   (list ?⿳
1803                         (nth 1 enc-str)
1804                         (nth 2 structure)
1805                         (nth 2 enc-str))
1806                   911))
1807           )))
1808       ))
1809     ))
1810
1811
1812 ;;; @ End.
1813 ;;;
1814
1815 (provide 'ids-find)
1816
1817 ;;; ids-find.el ends here