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