uim-data 1:1.8.6+gh20180114.64e3173-2build2 / usr / share / uim / tutcode-bushu.scm

;;;
;;; Copyright (c) 2010-2013 uim Project https://github.com/uim/uim
;;;
;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; 1. Redistributions of source code must retain the above copyright
;;;    notice, this list of conditions and the following disclaimer.
;;; 2. Redistributions in binary form must reproduce the above copyright
;;;    notice, this list of conditions and the following disclaimer in the
;;;    documentation and/or other materials provided with the distribution.
;;; 3. Neither the name of authors nor the names of its contributors
;;;    may be used to endorse or promote products derived from this software
;;;    without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' AND
;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE
;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
;;; SUCH DAMAGE.
;;;;

;;; tutcode-bushu.scm: ÂÐÏÃŪ¤ÊÉô¼ó¹çÀ®ÊÑ´¹
;;;
;;; tc-2.3.1¤Îtc-bushu.el¤ò°Ü¿¢(sort¤Ç¤ÎÂǤÁ¤ä¤¹¤µ¤Î¹Íθ¤Ï̤Âбþ)¡£
;;; (»²¹Í:Éô¼ó¹çÀ®¥¢¥ë¥´¥ê¥º¥à¤Ï[tcode-ml:1942]¤¢¤¿¤ê¡£°Ê²¼È´¿è)
;;; ¡üÄêµÁ
;;; ¡û¦²¤òÁ´Ê¸»ú¤Î½¸¹ç¤È¤¹¤ë¡£
;;; ¡û¦°¤òÁ´Éô¼ó¤Î½¸¹ç¤È¤¹¤ë¡£(¦° ¢¾ ¦²¤Ç¤Ê¤¯¤Æ¤â¤è¤¤¤Ï¤º¡£)
;;; ¡û³Æʸ»úc ¢º ¦²¤ÏÉô¼óp ¢º ¦°¤Î½¸¹ç¤«¤éÀ®¤ë¡£
;;; ¡û°Ê²¼¤Î½¸¹ç¤òʸ»úa¤Èʸ»úb¤Î¹çÀ®½¸¹ç¤È¸Æ¤Ö¡£
;;; 
;;;   {c | c ¢º ¦², c ¢½ a' ¢À b', a' ¢¼ a (a' ¡â ¶õ½¸¹ç), b' ¢¼ b (b' ¡â ¶õ½¸¹ç)
;;;        c ¡â a, c ¡â b }
;;; 
;;;   Æäˡ¢ a' = a ¤«¤Ä b' = b ¤Î¾ì¹ç¤ò¶¯¹çÀ®½¸¹ç¤È¸Æ¤Ö¡£
;;;   ¶¯¹çÀ®½¸¹ç¤Ç¤Ê¤¤¹çÀ®½¸¹ç¤ò¼å¹çÀ®½¸¹ç¤È¸Æ¤Ö¡£
;;; 
;;; ¡û°Ê²¼¤Î½¸¹ç¤òʸ»úa¤Èʸ»úb¤Îº¹¹çÀ®½¸¹ç¤È¸Æ¤Ö¡£
;;; 
;;;   {c | c ¢º ¦², c ¢¼ a- ¢À b-}
;;; 
;;;   ¤³¤³¤Ç¡¢a-¡¢b-¤ÎÄêµÁ¤Ï¼¡¤È¤ª¤ê¤Ç¤¢¤ë¡£
;;;         a- = a \ (a ¢Á b)
;;;         b- = b \ (a ¢Á b)
;;; 
;;;   Æäˡ¢(a- = ¶õ½¸¹ç) ¤Þ¤¿¤Ï (b- = ¶õ½¸¹ç)¤Î¾ì¹ç¤ò¶¯º¹¹çÀ®½¸¹ç¤È¸Æ¤Ö¡£
;;;   ¶¯º¹¹çÀ®½¸¹ç¤Ç¤Ê¤¤º¹¹çÀ®½¸¹ç¤ò¼åº¹¹çÀ®½¸¹ç¤È¸Æ¤Ö¡£
;;; --------------------------------------------------------
;;; ¡üÉô¼ó¹çÀ®ÊÑ´¹¤ÎÍ¥Àè½ç°Ì
;;; (1) ¶¯¹çÀ®½¸¹ç
;;;       Ê£¿ô¤¢¤ë¾ì¹ç¤Ï¡¢Éô¼ó¤Î½¸¹ç¤ÎÍ×ÁÇ¿ô¤¬¾®¤µ¤¤Êý¤¬Í¥Àè?
;;; (2) ¶¯º¹¹çÀ®½¸¹ç
;;; (3) ¼å¹çÀ®½¸¹ç
;;; (4) ¼åº¹¹çÀ®½¸¹ç
;;; --------------------------------------------------------
;;; 
;;; Îã:
;;; 
;;; Á² ¢á {¥·, ¼Ö, ¶Ô}
;;; »Â ¢á {¼Ö, ¶Ô}
;;; 
;;; ¹Æ ¢á {²Ó, ¹â}
;;; »ä ¢á {²Ó, ¥à}
;;; --------
;;; 
;;; (i) a = ¥· ¢á {¥·}¡¢ b = »Â¤Î¾ì¹ç
;;; 
;;;   a ¢À b = {¥·, ¼Ö, ¶Ô} ¤ª¤è¤Ó¡ÖÁ² ¢½ a ¢À b¡×¤è¤ê¡¢
;;;   ¡ÖÁ²¡×¤Ï¶¯¹çÀ®½¸¹ç¤ÎÍ×ÁǤˤʤ롣
;;; 
;;; (ii) a = ¥·¡¢ b = ¼Ö ¢á {¼Ö} ¤Î¾ì¹ç
;;; 
;;;   a ¢À b = {¥·, ¼Ö} ¤ª¤è¤Ó¡ÖÁ² ¢½ a ¢À b¡×¤è¤ê¡¢
;;;   ¡ÖÁ²¡×¤Ï¶¯¹çÀ®½¸¹ç¤ÎÍ×ÁǤˤʤ롣
;;; 
;;; (iii) a = »ä¡¢b = ¹â ¢á {¹â} ¤Î¾ì¹ç
;;; 
;;;   a' = {²Ó}, b' = {¹â} ¤È¤¹¤ë¤È¡¢
;;;   a' ¢À b' = {²Ó, ¹â} ¤Ç¤¢¤ê¡¢¤«¤Ä¡Ö¹Æ ¢½ a' ¢À b'¡×¤è¤ê
;;;   ¡Ö¹Æ¡×¤Ï¼å¹çÀ®½¸¹ç¤ÎÍ×ÁǤˤʤ롣
;;; 
;;; (iv) a = »ä¡¢b = ¥à ¤Î¾ì¹ç
;;; 
;;;   a- = {¥à}¡¢b- = ¶õ½¸¹ç ¤è¤ê¡¢
;;;   ¡Ö¥à¡×¤Ï¶¯º¹¹çÀ®½¸¹ç¤ÎÍ×ÁǤˤʤ롣
;;; 
;;; (v) a = »ä¡¢b = ¹Æ ¤Î¾ì¹ç
;;; 
;;;   a- = {¥à}¡¢b- = {¹â}¤è¤ê¡¢
;;;   ¡Ö¥à¡×¤ª¤è¤Ó¡Ö¹â¡×¤Ï¼åº¹¹çÀ®½¸¹ç¤ÎÍ×ÁǤˤʤ롣

(require-extension (srfi 1 2 8 69 95))
(require "util.scm")
(require-dynlib "look")

;;; #t¤Î¾ì¹ç¡¢Éô¼ó¤ÎʤÙÊý¤Ë¤è¤Ã¤Æ¹çÀ®¤µ¤ì¤ëʸ»ú¤ÎÍ¥ÀèÅÙ¤¬ÊѤï¤ë
(define tutcode-bushu-sequence-sensitive? #t)

;;; Í¥ÀèÅÙ¤¬Æ±¤¸¾ì¹ç¤ËÍ¥À褵¤ì¤ëʸ»ú¤Î¥ê¥¹¥È
(define tutcode-bushu-prioritized-chars ())

;;; Éô¼ó¹çÀ®½ÐÎϤˤÏÆþ¤ì¤Ê¤¤Ê¸»ú¤Î¥ê¥¹¥È (tc-2.3.1-22.6¤è¤ê)
(define tutcode-bushu-inhibited-output-chars
  '("¤¨" "¤·" "¤Ø" "¥¢" "¥¤" "¥¦" "¥¨" "¥ª" "¥«" "¥¯" "¥±" "¥µ" "¥·"
    "¥¿" "¥Á" "¥Æ" "¥È" "¥Ë" "¥Ì" "¥Í" "¥Î" "¥Ï" "¥Ò" "¥Û" "¥à" "¥á"
    "¥è" "¥ê" "¥ë" "¥ì" "¥í" "¥ï" "¥ó"))

;;; sort¤òÆþ¤ì¤ë¤ÈÃÙ¤¹¤®¤ë´Ä¶­¤Ç¤â¡¢ÂÐÏÃŪ¤ÊÉô¼ó¹çÀ®ÊÑ´¹¤Ï»È¤¤¤¿¤¤¾ì¹ç¸þ¤±¡£
;;; ~/.uim¤Ë°Ê²¼¤òÄɲ乤ë¤Èsort¤ò¾Êά²Äǽ¡£
;;; (set! tutcode-bushu-sort! (lambda (seq less?) seq))
(define tutcode-bushu-sort! sort!)

;;; bushu.help¥Õ¥¡¥¤¥ë¤òÆɤó¤ÇÀ¸À®¤·¤¿tutcode-bushudic·Á¼°¤Î¥ê¥¹¥È
(define tutcode-bushu-help ())

;;; tutcode-bushu-for-char¤Î¥­¥ã¥Ã¥·¥åÍÑhash-table
(define tutcode-bushu-for-char-hash-table (make-hash-table =))

;;; ʸ»ú¤Î¥ê¥¹¥È¤È¤·¤ÆÊÖ¤¹¡£
(define (tutcode-bushu-parse-entry str)
  (reverse! (string-to-list str)))

;;; STR ¤Ç»Ï¤Þ¤ë¹Ô¤Î¤¦¤Á¡¢ºÇ½é¤Î¤â¤Î¤ò¸«¤Ä¤±¤ë¡£
;;; @param str ¸¡º÷ʸ»úÎó
;;; @param file Âоݥե¡¥¤¥ë̾
;;; @return ¸«¤Ä¤±¤¿Ê¸»úÎó(str¤Ï´Þ¤Þ¤Ê¤¤)¡£¸«¤Ä¤«¤é¤Ê¤«¤Ã¤¿¾ì¹ç¤Ï#f
(define (tutcode-bushu-search str file)
  (let ((looked (look-lib-look #f #f 1 file str)))
    (and (pair? looked)
         (car looked)))) ; 1¹Ô¤Ö¤ó¤Îʸ»úÎó¤À¤±¼èÆÀ

;;; CHAR¤ò¹½À®¤¹¤ëÉô¼ó¤Î¥ê¥¹¥È¤òÊÖ¤¹¡£
(define (tutcode-bushu-for-char char)
  (let*
    ((i (tutcode-euc-jp-string->ichar char))
     (cache
      (and i (hash-table-ref/default tutcode-bushu-for-char-hash-table i #f))))
    (if cache
      (list-copy cache)
      (let*
        ((looked (tutcode-bushu-search char tutcode-bushu-expand-filename))
         (res
          (if looked
            (tutcode-bushu-parse-entry looked)
            (list char))))
        (if i
          (hash-table-set! tutcode-bushu-for-char-hash-table i (list-copy res)))
        res))))

(define (tutcode-bushu-lookup-index2-entry-internal str)
  (let
    ((looked (tutcode-bushu-search (string-append str " ")
              tutcode-bushu-index2-filename)))
    (if looked
      (tutcode-bushu-parse-entry looked)
      ())))

;;; CHAR¤òÉô¼ó¤È¤·¤Æ»ý¤Äʸ»ú¤Î¥ê¥¹¥È¤òÊÖ¤¹¡£
;;; ÊÖ¤¹¥ê¥¹¥È¤Ë¤ÏCHAR¤â´Þ¤Þ¤ì¤ë¡£
(define (tutcode-bushu-lookup-index2-entry-1 char)
  (cons char (tutcode-bushu-lookup-index2-entry-internal char)))

;;; CHAR¤ÈCHAR2¤òÉô¼ó¤È¤·¤Æ»ý¤Äʸ»ú¤Î¥ê¥¹¥È¤òÊÖ¤¹¡£
(define (tutcode-bushu-lookup-index2-entry-2 char char2)
  (let
    ((str (if (string<? char char2)
              (string-append char char2)
              (string-append char2 char))))
    (tutcode-bushu-lookup-index2-entry-internal str)))

;;; CHAR¤òN¸Ä°Ê¾åÉô¼ó¤È¤·¤Æ»ý¤Äʸ»ú¤Î¥ê¥¹¥È¤òÊÖ¤¹¡£
(define (tutcode-bushu-lookup-index2-entry-many char n)
  (if (= n 1)
    (tutcode-bushu-lookup-index2-entry-1 char)
    (tutcode-bushu-lookup-index2-entry-internal
      (apply string-append (make-list n char)))))

;;; LISTÃæ¤ÎELT¤Î¿ô¤òÊÖ¤¹¡£
(define (tutcode-bushu-count elt list)
  (count (lambda (elem) (string=? elt elem)) list))

;;; BUSHU ¤ò N ¸Ä°Ê¾å´Þ¤àʸ»ú¤Î¥ê¥¹¥È¤òÊÖ¤¹¡£
(define (tutcode-bushu-included-char-list bushu n)
  (tutcode-bushu-lookup-index2-entry-many bushu n))

;;; LIST1¤¬LIST2¤Ë´Þ¤Þ¤ì¤ë½¸¹ç¤«¤É¤¦¤«¤òɽ¤¹½Ò¸ì¡£
;;; Ʊ¤¸Í×ÁǤ¬Ê£¿ô¤¢¤ë¾ì¹ç¤Ï¡¢LIST2¤Ë´Þ¤Þ¤ì¤ë¿ô¤ÎÊý¤¬¾¯¤Ê¤±¤ì¤Ð#f¤òÊÖ¤¹¡£
(define (tutcode-bushu-included-set? list1 list2)
  (if (null? list1)
    #t
    (let ((x (car list1)))
      (if (> (tutcode-bushu-count x list1) (tutcode-bushu-count x list2))
        #f
        (tutcode-bushu-included-set? (cdr list1) list2)))))

;;; LIST1¤ÈLIST2¤¬Æ±¤¸½¸¹ç¤«¤É¤¦¤«¤òɽ¤¹½Ò¸ì¡£
;;; Ʊ¤¸Í×ÁǤ¬Ê£¿ô¤¢¤ë¾ì¹ç¤Ï¡¢Æ±¤¸¿ô¤À¤±´Þ¤Þ¤ì¤Æ¤¤¤Ê¤¤¤ÈÅù¤·¤¤¤È¤Ï¤ß¤Ê¤µ¤Ê¤¤¡£
(define (tutcode-bushu-same-set? list1 list2)
  (and (= (length list1) (length list2))
       (tutcode-bushu-included-set? list1 list2)))

;;; BUSHU-LIST¤Ç¹½À®¤µ¤ì¤ë»ú¤Î½¸¹ç¤òµá¤á¤ë¡£
(define (tutcode-bushu-char-list-for-bushu bushu-list)
  (cond
    ((null? bushu-list) ())
    ((null? (cdr bushu-list)) ; 1ʸ»ú
      (let*
        ((bushu (car bushu-list))
         (included (tutcode-bushu-included-char-list bushu 1))
         (ret
          (filter-map
            (lambda (elem)
              (let ((l (tutcode-bushu-for-char elem)))
                ;; Åù²Áʸ»ú
                (and (string=? bushu (car l))
                     (null? (cdr l))
                     elem)))
            included)))
        ret))
    ((null? (cddr bushu-list)) ; 2ʸ»ú
      (let*
        ((bushu1 (car bushu-list))
         (bushu2 (cadr bushu-list))
         (included (tutcode-bushu-lookup-index2-entry-2 bushu1 bushu2))
         (ret
          (filter-map
            (lambda (elem)
              (let*
                ((l (tutcode-bushu-for-char elem))
                 (len2? (= (length l) 2))
                 (l1 (and len2? (car l)))
                 (l2 (and len2? (cadr l))))
                (and
                  len2?
                  (or (and (string=? bushu1 l1) (string=? bushu2 l2))
                      (and (string=? bushu2 l1) (string=? bushu1 l2)))
                  elem)))
            included)))
        ret))
    (else ; 3ʸ»ú°Ê¾å
      (let*
        ((bushu1 (car bushu-list))
         (bushu2 (cadr bushu-list))
         (included (tutcode-bushu-lookup-index2-entry-2 bushu1 bushu2))
         (ret
          (filter-map
            (lambda (elem)
              (and
                (tutcode-bushu-same-set?
                  (tutcode-bushu-for-char elem) bushu-list)
                elem))
            included)))
        ret))))

;;; LIST1¤ÈLIST2¤È¤Î½¸¹çÀѤòÊÖ¤¹¡£
;;; Ʊ¤¸Í×ÁǤ¬Ê£¿ô¤¢¤ë¾ì¹ç¤Ï¶èÊ̤¹¤ë¡£
;;; ÊÖ¤êÃͤˤª¤±¤ëÍ×ÁǤÎʤÓÊý¤ÏLIST1¤ÎÊý¤Ë´ð¤Å¤¯¡£
(define (tutcode-bushu-intersection list1 list2)
  (let loop
    ((l1 list1)
     (l2 list2)
     (intersection ()))
    (if (or (null? l1) (null? l2))
      (reverse! intersection)
      (let*
        ((elt (car l1))
         (l2mem (member elt l2))
         (new-intersection (if l2mem (cons elt intersection) intersection))
         (l2-deleted-first-elt
          (if l2mem
            (append (drop-right l2 (length l2mem)) (cdr l2mem))
            l2)))
        (loop (cdr l1) l2-deleted-first-elt new-intersection)))))

(define (tutcode-bushu-complement-intersection list1 list2)
  (if (null? list2)
    list1
    (let loop
      ((l1 list1)
       (l2 list2)
       (ci ()))
      (if (or (null? l1) (null? l2))
        (append ci l1 l2)
        (let*
          ((e (car l1))
           (c1 (+ 1 (tutcode-bushu-count e (cdr l1))))
           (c2 (tutcode-bushu-count e l2))
           (diff (abs (- c1 c2))))
          (loop
            (if (> c1 1)
              (delete e (cdr l1))
              (cdr l1))
            (if (> c2 0)
              (delete e l2)
              l2)
            (if (> diff 0)
              (append! ci (make-list diff e))
              ci)))))))

(define (tutcode-bushu-subtract-set list1 list2)
  (if (null? list2)
    list1
    (let loop
      ((l1 list1)
       (l2 list2)
       (ci ()))
      (if (or (null? l1) (null? l2))
        (append l1 ci)
        (let*
          ((e (car l1))
           (c1 (+ 1 (tutcode-bushu-count e (cdr l1))))
           (c2 (tutcode-bushu-count e l2))
           (diff (- c1 c2)))
          (loop
            (if (> c1 1)
              (delete e (cdr l1))
              (cdr l1))
            (if (> c2 0)
              (delete e l2)
              l2)
            (if (> diff 0)
              (append! ci (make-list diff e))
              ci)))))))

;;; Éô¼ó¤ÎÉôʬ½¸¹ç¤¬BUSHU-LIST¤Ç¤¢¤ë»ú¤Î½¸¹ç¤òµá¤á¤ë¡£
(define (tutcode-bushu-superset bushu-list)
  (cond
    ((null? bushu-list) ())
    ((null? (cdr bushu-list)) ; 1ʸ»ú
      (tutcode-bushu-included-char-list (car bushu-list) 1))
    ((null? (cddr bushu-list)) ; 2ʸ»ú
      (tutcode-bushu-lookup-index2-entry-2 (car bushu-list) (cadr bushu-list)))
    (else ; 3ʸ»ú°Ê¾å
      (let*
        ((bushu (car bushu-list))
         (n (tutcode-bushu-count bushu bushu-list))
         (bushu-list-wo-bushu
          (if (> n 1)
            (delete bushu (cdr bushu-list))
            (cdr bushu-list)))
         (included
          (if (> n 1)
            (tutcode-bushu-included-char-list bushu n)
            (tutcode-bushu-lookup-index2-entry-2 bushu
              (list-ref bushu-list-wo-bushu 1))))
         (ret
          (filter-map
            (lambda (elem)
              (and
                (tutcode-bushu-included-set? bushu-list-wo-bushu
                  (tutcode-bushu-for-char elem))
                elem))
            included)))
        ret))))

;;; CHAR¤¬ÊÑ¿ô`tutcode-bushu-prioritized-chars'¤Î²¿ÈÖÌܤˤ¢¤ë¤«¤òÊÖ¤¹¡£
;;; ¤Ê¤±¤ì¤Ð #f ¤òÊÖ¤¹¡£
(define (tutcode-bushu-priority-level char)
  (and (pair? tutcode-bushu-prioritized-chars)
    (let ((char-list (member char tutcode-bushu-prioritized-chars)))
      (and char-list
        (- (length tutcode-bushu-prioritized-chars) (length char-list) -1)))))

;;; REF¤ò´ð½à¤È¤·¤Æ¡¢BUSHU1¤ÎÊý¤¬BUSHU2¤è¤ê¤âʤÓÊý¤¬´ð½à¤Ë¶á¤¤¤«¤É¤¦¤«¡£
;;; ȽÃǤǤ­¤Ê¤«¤Ã¤¿¤ê¡¢¤¹¤ëɬÍפ¬¤Ê¤¤¾ì¹ç¤ÏDEFAULT¤òÊÖ¤¹¡£
(define (tutcode-bushu-higher-priority? bushu1 bushu2 ref default)
  (if tutcode-bushu-sequence-sensitive?
    (let loop
      ((bushu1 bushu1)
       (bushu2 bushu2)
       (ref ref))
      (if (or (null? ref) (null? bushu1) (null? bushu2))
        default
        (let*
          ((b1 (car bushu1))
           (b2 (car bushu2))
           (r (car ref))
           (r=b1? (string=? r b1))
           (r=b2? (string=? r b2)))
          (if (and r=b1? r=b2?)
            (loop (cdr bushu1) (cdr bushu2) (cdr ref))
            (cond
              ((and r=b1? (not r=b2?))
                #t)
              ((and (not r=b1?) r=b2?)
                #f)
              ((and (not r=b1?) (not r=b2?))
                default))))))
    default))

;;; CHAR1¤¬CHAR2¤è¤êÍ¥ÀèÅÙ¤¬¹â¤¤¤«?
;;; BUSHU-LIST¤Ç»ØÄꤵ¤ì¤¿Éô¼ó¥ê¥¹¥È¤ò´ð½à¤È¤¹¤ë¡£
;;; MANY?¤¬#f¤Î¾ì¹ç¡¢Æ±¤¸Í¥ÀèÅ٤Ǥϡ¢BUSHU-LIST¤Ë´Þ¤Þ¤ì¤Ê¤¤
;;; Éô¼ó¤Î¿ô¤¬¾¯¤Ê¤¤Êý¤¬Í¥À褵¤ì¤ë¡£
;;; #t¤Î¾ì¹ç¤Ï¿¤¤Êý¤¬Í¥À褵¤ì¤ë¡£
(define (tutcode-bushu-less? char1 char2 bushu-list many?)
  (let*
    ((bushu1 (tutcode-bushu-for-char char1))
     (bushu2 (tutcode-bushu-for-char char2))
     (i1 (tutcode-bushu-intersection bushu1 bushu-list))
     (i2 (tutcode-bushu-intersection bushu2 bushu-list))
     (il1 (length i1))
     (il2 (length i2))
     (l1 (length bushu1))
     (l2 (length bushu2)))
    (if (= il1 il2)
      (if (= l1 l2)
        (let ((p1 (tutcode-bushu-priority-level char1))
              (p2 (tutcode-bushu-priority-level char2)))
          (cond
            (p1
              (if p2
                (< p1 p2)
                #t))
            (p2
              #f)
            (else
              (let
                ((val (tutcode-bushu-higher-priority? i1 i2
                        (tutcode-bushu-intersection bushu-list (append! i1 i2))
                        'default)))
                (if (not (eq? val 'default))
                  val
                  (let
                    ((s1 (tutcode-reverse-find-seq char1 tutcode-rule))
                     (s2 (tutcode-reverse-find-seq char2 tutcode-rule)))
                    (cond 
                      ((and s1 s2)
                        (let
                          ((sl1 (length s1))
                           (sl2 (length s2)))
                          (if (= sl1 sl2)
                            ;;XXX:ÂǤÁ¤ä¤¹¤µ¤Ç¤ÎÈæ³Ó¤Ï¾Êά
                            (string<? char1 char2)
                            (< sl1 sl2))))
                      (s1
                        #t)
                      (s2
                        #f)
                      (else
                        (string<? char1 char2)))))))))
        (if many?
          (> l1 l2)
          (< l1 l2)))
      (> il1 il2))))

(define (tutcode-bushu-less-against-sequence? char1 char2 bushu-list)
  (let ((p1 (tutcode-bushu-priority-level char1))
        (p2 (tutcode-bushu-priority-level char2)))
    (cond
      (p1
        (if p2
          (< p1 p2)
          #t))
      (p2
        #f)
      (else
        (tutcode-bushu-higher-priority?
          (tutcode-bushu-for-char char1)
          (tutcode-bushu-for-char char2)
          bushu-list
          (string<? char1 char2))))))

(define (tutcode-bushu-complete-compose-set char-list bushu-list)
  (tutcode-bushu-sort!
    (tutcode-bushu-subtract-set
      (tutcode-bushu-char-list-for-bushu bushu-list) char-list)
    (lambda (a b)
      (tutcode-bushu-less-against-sequence? a b bushu-list))))

(define (tutcode-bushu-strong-compose-set char-list bushu-list)
  (let*
    ((r (tutcode-bushu-superset bushu-list))
     (r2
      (let loop
        ((lis char-list)
         (r r))
        (if (null? lis)
          r
          (loop (cdr lis) (delete! (car lis) r))))))
    (tutcode-bushu-sort! r2
      (lambda (a b) (tutcode-bushu-less? a b bushu-list #f)))))

(define (tutcode-bushu-include-all-chars-bushu? char char-list)
  (let*
    ((bushu0 (tutcode-bushu-for-char char))
     (new-bushu
      (let loop
        ((char-list char-list)
         (new-bushu bushu0))
        (if (null? char-list)
          new-bushu
          (loop
            (cdr char-list)
            (tutcode-bushu-subtract-set
              new-bushu (tutcode-bushu-for-char (car char-list)))))))
     (bushu (tutcode-bushu-subtract-set bushu0 new-bushu)))
    (let loop
      ((cl char-list))
      (cond
        ((null? cl)
          #t)
        ((null?
          (tutcode-bushu-subtract-set bushu
            (append-map!
              (lambda (char)
                (tutcode-bushu-for-char char))
              (tutcode-bushu-subtract-set char-list (list (car cl))))))
          #f)
        (else
          (loop (cdr cl)))))))

(define (tutcode-bushu-all-compose-set char-list bushu-list)
  (let*
    ((char (car char-list))
     (rest (cdr char-list))
     (all-list
      (delete-duplicates!
        (delete! char
          (append-map!
            (if (pair? rest)
              (lambda (bushu)
                (tutcode-bushu-all-compose-set rest (cons bushu bushu-list)))
              (lambda (bushu)
                (tutcode-bushu-superset (cons bushu bushu-list))))
            (tutcode-bushu-for-char char))))))
    (filter!
      (lambda (char)
        (tutcode-bushu-include-all-chars-bushu? char char-list))
      all-list)))

(define (tutcode-bushu-weak-compose-set char-list bushu-list strong-compose-set)
  (if (null? (cdr char-list)) ; char-list ¤¬°ìʸ»ú¤À¤±¤Î»þ¤Ï²¿¤â¤·¤Ê¤¤
    ()
    (tutcode-bushu-sort!
      (tutcode-bushu-subtract-set
        (tutcode-bushu-all-compose-set char-list ())
        strong-compose-set)
      (lambda (a b)
        (tutcode-bushu-less? a b bushu-list #f)))))

(define (tutcode-bushu-subset bushu-list)
  ;;XXX:Ť¤¥ê¥¹¥È¤ËÂФ¹¤ëdelete-duplicates!¤ÏÃÙ¤¤¤Î¤Ç¡¢filter¸å¤Ë¹Ô¤¦
  (delete-duplicates!
    (filter!
      (lambda (char)
        (null? 
          (tutcode-bushu-subtract-set
            (tutcode-bushu-for-char char) bushu-list)))
      (append-map!
        (lambda (elem)
          (tutcode-bushu-included-char-list elem 1))
        (delete-duplicates bushu-list)))))

(define (tutcode-bushu-strong-diff-set char-list . args)
  (let-optionals* args ((bushu-list ()) (complete? #f))
    (let*
      ((char (car char-list))
       (rest (cdr char-list))
       (bushu (tutcode-bushu-for-char char))
       (i
        (if (pair? bushu-list)
          (tutcode-bushu-intersection bushu bushu-list)
          bushu)))
      (if (null? i)
        ()
        (let*
          ((d1 (tutcode-bushu-complement-intersection bushu i))
           (d2 (tutcode-bushu-complement-intersection bushu-list i))
           (d1-or-d2 (if (pair? d1) d1 d2)))
          (if
            (or (and (pair? d1) (pair? d2))
                (and (null? d1) (null? d2)))
            ()
            (if (pair? rest)
              (delete! char
                (tutcode-bushu-strong-diff-set rest d1-or-d2 complete?))
              (tutcode-bushu-sort!
                (delete! char
                  (if complete?
                    (tutcode-bushu-char-list-for-bushu d1-or-d2)
                    (tutcode-bushu-subset d1-or-d2)))
                (lambda (a b)
                  (tutcode-bushu-less? a b bushu-list #t))))))))))

(define (tutcode-bushu-complete-diff-set char-list)
  (tutcode-bushu-strong-diff-set char-list () #t))

(define (tutcode-bushu-all-diff-set char-list bushu-list common-list)
  (let*
    ((char (car char-list))
     (rest (cdr char-list))
     (bushu (tutcode-bushu-for-char char))
     (new-common-list
      (if (pair? common-list)
        (tutcode-bushu-intersection bushu common-list)
        bushu)))
    (if (null? new-common-list)
      ()
      (let*
        ((new-bushu-list
          (if (null? common-list)
            ()
            (append bushu-list
              (tutcode-bushu-complement-intersection
                bushu new-common-list)
              (tutcode-bushu-complement-intersection
                common-list new-common-list)))))
        (if (pair? rest)
          (delete! char
            (tutcode-bushu-all-diff-set rest new-bushu-list new-common-list))
          (delete-duplicates!
            (delete! char
              (append-map!
                (lambda (bushu)
                  (tutcode-bushu-subset
                    (append new-bushu-list (delete bushu new-common-list))))
                new-common-list))))))))

(define (tutcode-bushu-weak-diff-set char-list strong-diff-set)
  (let*
    ((bushu-list (tutcode-bushu-for-char (car char-list)))
     (diff-set
      (tutcode-bushu-subtract-set
        (tutcode-bushu-all-diff-set char-list () ())
        strong-diff-set))
     (less-or-many? (lambda (a b) (tutcode-bushu-less? a b bushu-list #t)))
     (res
       (receive
        (true-diff-set rest-diff-set)
        (partition!
          (lambda (char)
            (null?
              (tutcode-bushu-subtract-set
                (tutcode-bushu-for-char char) bushu-list)))
          diff-set)
        (append! (tutcode-bushu-sort! true-diff-set less-or-many?)
                 (tutcode-bushu-sort! rest-diff-set less-or-many?)))))
    (delete-duplicates! res)))

;;; bushu.help¥Õ¥¡¥¤¥ë¤òÆɤó¤Çtutcode-bushudic·Á¼°¤Î¥ê¥¹¥È¤òÀ¸À®¤¹¤ë
;;; @return tutcode-bushudic·Á¼°¤Î¥ê¥¹¥È¡£Æɤ߹þ¤á¤Ê¤«¤Ã¤¿¾ì¹ç¤Ï#f
(define (tutcode-bushu-help-load)
  (define parse
    (lambda (line)
      ;; Îã: "Ñ£¥¤Àì* ÅÁ¡¦"
      ;; ¢ª(((("¥¤" "Àì"))("Ñ£"))((("Àì" "¥¤"))("Ñ£"))((("ÅÁ" "¡¦"))("Ñ£")))
      (let*
          ((comps (string-split line " "))
           (kanji-lcomps (map tutcode-bushu-parse-entry comps))
           (kanji (and (pair? (car kanji-lcomps)) (caar kanji-lcomps)))
           ;; ¹ÔƬ¤Î¹çÀ®¸å¤Î´Á»ú¤ò½ü¤¤¤¿¥ê¥¹¥È¡£Îã:(("¥¤" "Àì" "*")("ÅÁ" "¡¦"))
           (lcomps
            (if kanji
                (cons (cdar kanji-lcomps) (cdr kanji-lcomps))
                ())))
        (append-map!
         (lambda (elem)
           (let ((len (length elem)))
             (if (< len 2)
                 ()
                 (let*
                     ((bushu1 (list-ref elem 0))
                      (bushu2 (list-ref elem 1))
                      (rule (list (list (list bushu1 bushu2)) (list kanji)))
                      (rev
                       (and
                        (and (>= len 3) (string=? (list-ref elem 2) "*"))
                        (list (list (list bushu2 bushu1)) (list kanji)))))
                   (if rev
                       (list rule rev)
                       (list rule))))))
         lcomps))))
  (and
    (file-readable? tutcode-bushu-help-filename)
    (call-with-input-file tutcode-bushu-help-filename
      (lambda (port)
        (let loop ((line (read-line port))
                   (rules ()))
          (if (or (not line)
                  (eof-object? line))
              rules
              (loop (read-line port)
                    (append! rules (parse line)))))))))


;;; bushu.help¥Õ¥¡¥¤¥ë¤Ë´ð¤Å¤¯Éô¼ó¹çÀ®¤ò¹Ô¤¦
(define (tutcode-bushu-compose-explicitly char-list)
  (if (null? tutcode-bushu-help)
    (set! tutcode-bushu-help (tutcode-bushu-help-load)))
  (if (not tutcode-bushu-help)
    ()
    (cond
      ((null? char-list)
        ())
      ((null? (cdr char-list)) ; 1ʸ»ú
        (map (lambda (elem) (caadr elem))
          (rk-lib-find-partial-seqs char-list tutcode-bushu-help)))
      ((pair? (cddr char-list)) ; 3ʸ»ú°Ê¾å
        ())
      (else ; 2ʸ»ú
        (let ((seq (rk-lib-find-seq char-list tutcode-bushu-help)))
          (if seq
            (cadr seq)
            ()))))))

;;; ÂÐÏÃŪ¤ÊÉô¼ó¹çÀ®ÊÑ´¹ÍѤˡ¢»ØÄꤵ¤ì¤¿Éô¼ó¤Î¥ê¥¹¥È¤«¤éÉô¼ó¹çÀ®²Äǽ¤Ê
;;; ´Á»ú¤Î¥ê¥¹¥È¤òÊÖ¤¹¡£
;;; @param char-list ÆþÎϤµ¤ì¤¿Éô¼ó¤Î¥ê¥¹¥È
;;; @param exit-on-found? ´Á»ú¤¬1ʸ»ú¤Ç¤â¹çÀ®¤Ç¤­¤¿¤é¤½¤ì°Ê¾å¤Î¹çÀ®¤ÏÃæ»ß¤¹¤ë
;;; @return ¹çÀ®²Äǽ¤Ê´Á»ú¤Î¥ê¥¹¥È
(define (tutcode-bushu-compose-tc23 char-list exit-on-found?)
  (let*
    ((bushu-list (append-map! tutcode-bushu-for-char char-list))
     (update-res!
      (lambda (res lst)
        (append! res
          (filter!
            (lambda (elem)
              (not (member elem tutcode-bushu-inhibited-output-chars)))
            lst))))
     (resall
      (let
        ((r0 (update-res! () (tutcode-bushu-compose-explicitly char-list))))
        (if (and exit-on-found? (pair? r0))
          r0
          (let
            ((r1 (update-res! r0
                  (tutcode-bushu-complete-compose-set char-list bushu-list))))
            (if (and exit-on-found? (pair? r1))
              r1
              (let
                ((r2 (update-res! r1
                      (tutcode-bushu-complete-diff-set char-list))))
                (if (and exit-on-found? (pair? r2))
                  r2
                  (let*
                    ((strong-compose-set
                      (tutcode-bushu-strong-compose-set char-list bushu-list))
                     (r3 (update-res! r2 strong-compose-set)))
                    (if (and exit-on-found? (pair? r3))
                      r3
                      (let*
                        ((strong-diff-set
                          (tutcode-bushu-strong-diff-set char-list))
                         (r4 (update-res! r3 strong-diff-set)))
                        (if (and exit-on-found? (pair? r4))
                          r4
                          (let
                            ((r5 (update-res! r4
                                  (tutcode-bushu-weak-diff-set char-list
                                    strong-diff-set))))
                            (if (and exit-on-found? (pair? r5))
                              r5
                              (let
                                ((r6 (update-res! r5
                                      (tutcode-bushu-weak-compose-set char-list
                                        bushu-list strong-compose-set))))
                                r6)))))))))))))))
    (delete-duplicates! resall)))

;;; ÂÐÏÃŪ¤ÊÉô¼ó¹çÀ®ÊÑ´¹ÍѤˡ¢»ØÄꤵ¤ì¤¿Éô¼ó¤Î¥ê¥¹¥È¤«¤éÉô¼ó¹çÀ®²Äǽ¤Ê
;;; ´Á»ú¤Î¥ê¥¹¥È¤òÊÖ¤¹¡£
;;; @param char-list ÆþÎϤµ¤ì¤¿Éô¼ó¤Î¥ê¥¹¥È
;;; @return ¹çÀ®²Äǽ¤Ê´Á»ú¤Î¥ê¥¹¥È
(define (tutcode-bushu-compose-interactively char-list)
  (tutcode-bushu-compose-tc23 char-list #f))

;;; Éô¼ó¹çÀ®ÊÑ´¹¤ò¹Ô¤¦¡£
;;; tc-2.3.1-22.6¤ÎÉô¼ó¹çÀ®¥¢¥ë¥´¥ê¥º¥à¤ò»ÈÍÑ¡£
;;; @param c1 1ÈÖÌܤÎÉô¼ó
;;; @param c2 2ÈÖÌܤÎÉô¼ó
;;; @return ¹çÀ®¸å¤Îʸ»ú¡£¹çÀ®¤Ç¤­¤Ê¤«¤Ã¤¿¤È¤­¤Ï#f
(define (tutcode-bushu-convert-tc23 c1 c2)
  (let ((res (tutcode-bushu-compose-tc23 (list c1 c2) #t)))
    (if (null? res)
      #f
      (car res))))

;; tc-2.3.1¤Îtc-help.el¤«¤é¤Î°Ü¿¢
(define (tutcode-bushu-decompose-to-two-char char)
  (let ((b1 (tutcode-bushu-for-char char)))
    (let loop
      ((b1 (cdr b1))
       (b2 (list (car b1))))
      (if (null? b1)
        #f
        (let*
          ((cl1t (tutcode-bushu-char-list-for-bushu b2))
           (cl1
            (if (pair? cl1t)
              cl1t
              (if (= (length b2) 1)
                b2
                ())))
           (cl2t (tutcode-bushu-char-list-for-bushu b1))
           (cl2
            (if (pair? cl2t)
              cl2t
              (if (= (length b1) 1)
                b1
                ()))))
          (let c1loop
            ((cl1 cl1))
            (if (null? cl1)
              (loop (cdr b1) (append b2 (list (car b1))))
              (let c2loop
                ((cl2 cl2))
                (if (null? cl2)
                  (c1loop (cdr cl1))
                  (if
                    (equal?
                      (tutcode-bushu-convert-tc23 (car cl1) (car cl2))
                      char)
                    (cons (car cl1) (car cl2))
                    (c2loop (cdr cl2))))))))))))

;;; CHAR¤¬Ä¾ÀÜÆþÎϲÄǽ¤ÊBUSHU1¤ÈBUSHU2¤Ç¹çÀ®¤Ç¤­¤ë¾ì¹ç¡¢
;;; BUSHU1¤ÈBUSHU2¤Î¥¹¥È¥í¡¼¥¯¤ò´Þ¤à¥ê¥¹¥È¤òÊÖ¤¹¡£
;;; Îã: "·Ò" => (((("," "o"))("·â")) ((("f" "q"))("»å")))
;;; @param char ¹çÀ®¸å¤Îʸ»ú
;;; @param bushu1 Éô¼ó1
;;; @param bushu2 Éô¼ó2
;;; @param rule tutcode-rule
;;; @return ÂоÝʸ»ú¤ÎÉô¼ó¹çÀ®¤ËɬÍפÊ2¤Ä¤Îʸ»ú¤È¥¹¥È¥í¡¼¥¯¤Î¥ê¥¹¥È¡£
;;;  ¹çÀ®¤Ç¤­¤Ê¤¤¾ì¹ç¤Ï#f
(define (tutcode-bushu-composed char bushu1 bushu2 rule)
  (and-let*
    ((seq1 (tutcode-auto-help-get-stroke bushu1 rule))
     (seq2 (tutcode-auto-help-get-stroke bushu2 rule))
     (composed (tutcode-bushu-convert-tc23 bushu1 bushu2)))
    (and
      (string=? composed char)
      (list seq1 seq2))))

;;; ¼«Æ°¥Ø¥ë¥×:ÂоÝʸ»ú¤òÉô¼ó¹çÀ®¤¹¤ë¤Î¤ËɬÍפȤʤ롢
;;; ³°»ú¤Ç¤Ê¤¤2¤Ä¤Îʸ»ú¤Î¥ê¥¹¥È¤òÊÖ¤¹
;;; Îã: "·Ò" => (((("," "o"))("·â")) ((("f" "q"))("»å")))
;;; @param kanji ÂоÝʸ»ú
;;; @param rule tutcode-rule
;;; @param stime ³«»ÏÆü»þ
;;; @return ÂоÝʸ»ú¤ÎÉô¼ó¹çÀ®¤ËɬÍפÊ2¤Ä¤Îʸ»ú¤È¥¹¥È¥í¡¼¥¯¤Î¥ê¥¹¥È¡£
;;;  ¸«¤Ä¤«¤é¤Ê¤«¤Ã¤¿¾ì¹ç¤Ï#f
(define (tutcode-auto-help-bushu-decompose-tc23 kanji rule stime)
  (if (> (string->number (difftime (time) stime)) tutcode-auto-help-time-limit)
    #f
    (let ((decomposed (tutcode-bushu-decompose-to-two-char kanji)))
      (if decomposed
        (let*
          ((char1 (car decomposed))
           (char2 (cdr decomposed))
           (seq1 (tutcode-auto-help-get-stroke char1 rule))
           (seq2 (tutcode-auto-help-get-stroke char2 rule)))
          (cond
            (seq1
              (if seq2
                (list seq1 seq2)
                (let*
                  ((bushu-list (tutcode-bushu-for-char char2))
                   (find-loop
                    (lambda (set)
                      (let loop
                        ((lis
                          (tutcode-bushu-sort! set
                            (lambda (a b)
                              (tutcode-bushu-less? a b bushu-list #f)))))
                        (if (null? lis)
                          #f
                          (let
                            ((res (tutcode-bushu-composed
                                    kanji char1 (car lis) rule)))
                            (or res
                              (loop (cdr lis)))))))))
                  (or
                    ;; ¶¯¹çÀ®½¸¹ç¤òõ¤¹
                    (find-loop (tutcode-bushu-subset bushu-list))
                    ;; ¼å¹çÀ®½¸¹ç¤òõ¤¹
                    (find-loop (tutcode-bushu-superset bushu-list))
                    ;; ºÆµ¢Åª¤Ëõ¤¹
                    (let
                      ((dec2
                        (tutcode-auto-help-bushu-decompose-tc23 char2
                          rule stime)))
                      (and dec2
                        (list seq1 dec2)))))))
            (seq2
              (let*
                ((bushu-list (tutcode-bushu-for-char char1))
                 (find-loop
                  (lambda (set)
                    (let loop
                      ((lis
                        (tutcode-bushu-sort! set
                          (lambda (a b)
                            (tutcode-bushu-less? a b bushu-list #f)))))
                      (if (null? lis)
                        #f
                        (let
                          ((res (tutcode-bushu-composed
                                  kanji (car lis) char2 rule)))
                          (or res
                            (loop (cdr lis)))))))))
                (or
                  ;; ¶¯¹çÀ®½¸¹ç¤òõ¤¹
                  (find-loop (tutcode-bushu-subset bushu-list))
                  ;; ¼å¹çÀ®½¸¹ç¤òõ¤¹
                  (find-loop (tutcode-bushu-superset bushu-list))
                  ;; ºÆµ¢Åª¤Ëõ¤¹
                  (let
                    ((dec1
                      (tutcode-auto-help-bushu-decompose-tc23 char1
                        rule stime)))
                    (and dec1
                      (list dec1 seq2))))))
            (else
              (let*
                ((bushu1 (tutcode-bushu-for-char char1))
                 (bushu2 (tutcode-bushu-for-char char2))
                 (bushu-list (append bushu1 bushu2))
                 (mkcl
                  (lambda (bushu)
                    (tutcode-bushu-sort!
                      (delete-duplicates!
                        (append!
                          (tutcode-bushu-subset bushu)
                          (tutcode-bushu-superset bushu)))
                      (lambda (a b)
                        (tutcode-bushu-less? a b bushu-list #f)))))
                 (cl1 (mkcl bushu1))
                 (cl2 (mkcl bushu2)))
                (let loop1
                  ((cl1 cl1))
                  (if (null? cl1)
                    #f
                    (let loop2
                      ((cl2 cl2))
                      (if (null? cl2)
                        (loop1 (cdr cl1))
                        (let
                          ((res (tutcode-bushu-composed
                                  kanji (car cl1) (car cl2) rule)))
                          (or res
                            (loop2 (cdr cl2))))))))))))
        ;; Æó¤Ä¤Ëʬ³ä¤Ç¤­¤Ê¤¤¾ì¹ç
        ;; ¶¯º¹¹çÀ®½¸¹ç¤òõ¤¹
        (let*
          ((bushu-list (tutcode-bushu-for-char kanji))
           (superset
            (tutcode-bushu-sort!
              (tutcode-bushu-superset bushu-list)
              (lambda (a b)
                (tutcode-bushu-less? a b bushu-list #f)))))
          (let loop1
            ((lis superset))
            (if (null? lis)
              #f
              (let*
                ((seq1 (tutcode-auto-help-get-stroke (car lis) rule))
                 (diff (if seq1
                        (tutcode-bushu-subtract-set
                          (tutcode-bushu-for-char (car lis)) bushu-list)
                        ())))
                (if seq1
                  (let loop2
                    ((lis2 (tutcode-bushu-subset diff)))
                    (if (null? lis2)
                      (loop1 (cdr lis))
                      (let
                        ((res (tutcode-bushu-composed
                                kanji (car lis) (car lis2) rule)))
                        (or res
                          (loop2 (cdr lis2))))))
                  (loop1 (cdr lis)))))))))))