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