ids-find.el

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