Scheme:イラストロジック

Scheme:イラストロジック

イラストロジック解析

Scheme:イラストロジック:デモ


イラストロジック

パズルとして有名だけど、約15年くらいまえかなぁ新聞のパズル欄に出てて、 母親が何のパズルなんだかよく分からんがと聞いて来たのが最初。

私も初めて問題を読んで、それで説明してやった。 するとその後、家族で一時期ブームが訪れた。

その時に pascal ベースの解析ソフトなんかも出てて、 DOS 上で走らせて解いてみたりもした。

その pascal コードには結構真面目に論理的な解き方の解説もしてあり、 かつ複数解存在する問題についても全解を一気に表示することができた。

ただ、このソフトは残念ながら彼女には不評だったのだ。 彼女は次の一手が見付からなかった時に次の一手だけが欲しいのであって 答えそのものは見たくないのだ。

その後つき合った彼女などもイラストロジックには結構はまるタイプが。。。 しかもほとんど上記と同じ要望を持つ。

ならばと以前 C で取り組んだことがあったのだが、 問題を読み込む所で挫折。。。(早っ (^^;;)

さくさく書けちゃう scheme で再チャレンジだ。

最初のバージョンはコメントと空行を除けばわずか 215 行の簡単なもの。 特に私は実装済関数ですら調べずに再発明するし、 無駄も多いと思うので核はもっと短くなるだろう。

イラストロジック解析の最初のコード illust.scm

":";exec gosh -b $0 "$@"
;
; 簡単な関数
;
(define (inc n) (+ n 1))
(define (dec n) (- n 1))

;
; 組合せ
;
(define (combination n r)
  (cond ((= n r) 1)                          ;; all select
        ((= r 0) 1)                          ;; non select
        ((= r 1) n)                          ;; only one select
        ((> r (- n r))                       ;; optimize
         (combination n (- n r)))
        (else
         (+ (combination (dec n) r)          ;; recursive main body
            (combination (dec n) (dec r))))))

;
; 以後よく使うリスト生成の関数
;
(define (make-list len item)  
  (if (= len 0)
      '()
      (cons item (make-list (dec len) item))))

;
; 組合せ nCr の m 番目のパターンを生成する関数を生成
;
; 1.) nCr = n-1Cr + n-1Cr-1
;     右辺第一項は先頭が 0(非選択) 第二項は先頭が 1(非選択) である。
;     m 番目のパターンは第一項より大きいかどうかで先頭が 0 か 1 か
;     決定して結果リスト v に cons しておき、レベルを引き下げる。
;
; 2.) 1. の第一項が選ばれていれば m は変更ないが、第二項が選ばれたら
;     m は第二項の中の m - n-1Cr 番目にあたる点に注意してレベル引き下げ。
;
; 3.) g は選択されたところにはめ込む atom で f は非選択のところにはめ込む atom
;
(define (make-comb-pattern-nth g f)
  (letrec ((comb-pattern-nth
            (lambda (n r m v)
              (cond ((= r 0)
                     (reverse (append (make-list n f) v)))
                    ((= n r)
                     (reverse (append (make-list n g) v)))
                    (else
                     (let ((f-start (combination (dec n) r)))
                       (if (> m f-start)
                           (comb-pattern-nth (dec n) (dec r) (- m f-start) (cons g v))
                           (comb-pattern-nth (dec n) r m (cons f v)))))))))
    comb-pattern-nth))

(define comb-pattern-nth (make-comb-pattern-nth 1 0))
;(define comb-pattern-nth (make-comb-pattern-nth '★ '☆))

;
; comb-pattern-nth で得られたパターン p を l なるリストのメンバで順に置き換える
; l は p に出現する 1 の数より大きく与えないとダメ
;
; (trans1 (0 1 1 0 0 1) '(1 2 3 4 5))
;         => (0 1 2 0 0 3)
; (trans1 (0 1 1 0 0 1) '(3 0 5))
;         => (0 3 0 0 0 5)
;
(define (trans1 p l)
  (let loop ((p p)
             (l l)
             (v '()))
    (if (null? p)
        (reverse v)
        (let ((f (car p))
              (r (cdr p)))
          (cond ((= f 0)
                 (loop r l (cons 0 v)))
                ((= f 1)
                 (loop r (cdr l) (cons (car l) v))))))))

;
; リストの非零の数値をその長さの 1 の並びに展開する。
; ただし、二番目以降の非零の数値は暗黙の空白(塗りつぶし無し)がある。
;
(define (extract-bar p)
  (define appear? #f)  ;; 最初の非零の数値が出たかどうか
  (let loop ((p p)
             (r '()))
    (if (null? p)
        (reverse r)
        (if (= (car p) 0)
            (loop (cdr p) (cons 0 r))
            (loop (cdr p) (append (make-list (car p) 1)
                                  (if appear?
                                      (cons 0 r)
                                      (begin (set! appear? #t)
                                             r))))))))

;
; n 番目のパターンを返す関数を生成する。
; (define s (generate-pattern-nth 40 '(12 5 2)))
; => s
; (s 'size)  ;; パターン集合のサイズを取得
; => 42504
; (s 120)
; =>(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 0 1 1 1 1 1 0 0 0 1 1 0 0)
;
(define (generate-pattern-nth cells hint)
  (if (null? hint)
      (let ((size 1))
        (lambda (arg)
          (cond ((eq? arg 'size) size)
                ((and (number? arg) (= arg 1))
                 (make-list cells 0))
                (else
                 (error "ERROR: --it's over stream size or invalid message." arg)))))
      (let* ((closed (apply + hint))                   ;; 塗りつぶしセル数
             (bar    (length hint))                    ;; 塗りつぶしバー数(ヒントの要素数)
             (free   (- cells closed (dec bar)))       ;; 余りの 0(自由度)
             (pat    hint)                             ;; パターン
             (r      (length pat))                     ;; パターンの長さ(nCr の r)
             (n      (+ r free)))                      ;; nCr の n
        (let ((size (combination n r)))
          (lambda (arg)
            (cond ((eq? arg 'size) size)
                  ((and (number? arg) (<= arg size))
                   (extract-bar (trans1 (comb-pattern-nth n r arg '()) pat)))
                  (else
                   (error "ERROR: -- it's over stream size or invalid message." arg))))))))


;
; 0,1,* で構成される二つのリストの合成を行う。
; 合成の規則は以下
;
; 1.) 0 vs 0 なら 0
; 2.) 1 vs 1 なら 1
; 3.) * vs 0 または * vs 1 なら *
; 4.) 1 vs 0 または 0 vs 1 なら *
; 長さはチェックしてない。
;
;(make-filter-list '(1 1 1 0 0 1 0) '(0 1 0 1 1 1 0))
;       =>(* 1 * * * 1 0)
;
(define (make-filter-list filter pattern)
  (let loop ((f filter)
             (p pattern)
             (v '()))
    (if (null? p)
        (reverse v)
        (let ((carf (car f))
              (carp (car p))
              (cdrf (cdr f))
              (cdrp (cdr p)))
          (cond ((eq? carf carp)
                 (loop cdrf cdrp (cons carf v)))
                (else
                 (loop cdrf cdrp (cons '* v))))))))

;
; 二つのフィルターの合成を行う
; メンバは以下の規則にしたがう
;
; 1.) 0 vs 0 または 1 vs 1 なら その値
; 2.) * vs 0 または 0 vs * ならば 0
; 3.) * vs 1 または * vs 1 ならば 1
; 4.) 1 vs 0 または 0 vs 1 は矛盾でエラー
;
(define (filter-marge f1 f2)
  (let loop ((f1 f1)
             (f2 f2)
             (v '()))
    (if (null? f1)
        (reverse v)
        (let ((car1 (car f1))
              (car2 (car f2))
              (cdr1 (cdr f1))
              (cdr2 (cdr f2)))
          (cond ((eq? car1 '*)
                 (loop cdr1 cdr2 (cons car2 v)))
                ((eq? car2 '*)
                 (loop cdr1 cdr2 (cons car1 v)))
                ((eq? car1 car2)
                 (loop cdr1 cdr2 (cons car1 v)))
                (else
                 (error "ERROR: -- unconsistency occured!" f1 f2)))))))

;
; 0,1,* で構成される filter にマッチするかどうかチェックする関数
; filter のメンバが * のところはパターンによらずマッチしているとする
;
(define (match-pattern? filter pattern)
  (let loop ((f filter)
             (p pattern))
    (if (null? p)
        #t
        (let ((carf (car f))
              (carp (car p))
              (cdrf (cdr f))
              (cdrp (cdr p)))
          (if (or (eq? carf '*)
                  (eq? carf carp))
              (loop cdrf cdrp)
              #f)))))

;
; メインルーチン
;
(define next #f)
(define cont #f)
(define (make-illust-analysis black white open)
  (lambda (row col)
    (define (all? item lst)
      (if (null? lst)
          #t
          (if (eq? (car lst) item)
              (all? item (cdr lst))
              #f)))

    (define (calc-filter s)
      (let ((size (s 'size)))
        (if (= size 1)
            (s 1)
            (let ((v (s 1)))
              (do ((i 2 (inc i))
                   (j size  (dec j)))
                  ((or (> i j)
                       (all? '* v))
                   v)
                (set! v (make-filter-list v (s i)))
                (set! v (make-filter-list v (s j))))))))

    (define (renew-filter f s)
      (let ((size (s 'size)))
        (if (= size 1)
            (s 1)
            (let ((start 1))
              (let* ((v (do ((i start (inc i)))
                            ((match-pattern? f (s i))
                             (set! start i)
                             (s i)))))
                (do ((i start (inc i))
                     (j size (dec j)))
                    ((or (> i j)
                         (all? '* v))
                     v)
                  (set! v (if (match-pattern? f (s i))
                              (make-filter-list v (s i))
                              v))
                  (set! v (if (match-pattern? f (s j))
                              (make-filter-list v (s j))
                              v))))))))

    (define (trans-row-col reclist)
      (let loop ((l reclist)
                 (v '()))
        (if (null? (car l))
            (reverse v)
            (loop (map cdr l) (cons (map car l) v)))))

    (define (draw-illust lst)
      (for-each (lambda (l)
                  (for-each
                   (lambda (c) (cond ((eq? c 1)  (format #t "~a" black))
                                     ((eq? c 0)  (format #t "~a" white))
                                     ((eq? c '*) (format #t "~a" open))))
                   l)
                  (format #t "\n"))
                lst))

    (let ((row-N (length col))
          (col-N (length row)))
      (let ((expRow
             (map (lambda (x) (generate-pattern-nth row-N x)) row))
            (expCol
             (map (lambda (x) (generate-pattern-nth col-N x)) col))
            (result '())
            (tmpres '()))

        (if (not (= (apply + (map (lambda (x) (apply + x)) row))
                    (apply + (map (lambda (x) (apply + x)) col))))
            (error "ERROR: -- Check your puzzle!\nFound unconsistency between row and col.\n"))

        ;; first stage
        (set! result (map (lambda (a b) (filter-marge a b))
                          (map (lambda (s) (calc-filter s)) expRow)
                          (trans-row-col
                           (map (lambda (s) (calc-filter s)) expCol))))

        (let loop ((result result))
          (format #t "*** Analysis and Result ***\n")
          (draw-illust result)

          ;; second stage
          (set! tmpres result) ;; pre-result backup
          (set! result
                (map (lambda (a b) (filter-marge a b))
                     (map (lambda (f s) (renew-filter f s))
                          result expRow)
                     (trans-row-col
                      (map (lambda (f s) (renew-filter f s))
                           (trans-row-col result) expCol))))

          (set! next (if (equal? tmpres result)
                         (lambda ()
                           (draw-illust result)
                           (format #t "finish logical thinking...\n")
                           #t)
                         (lambda () (loop result)))))
        ))))

(define illust-analysis (make-illust-analysis '■ '・ '□))

イラストロジック解析(ストリーム版) illust-lazy.scm

推論モードを考えていたらどうもストリーム版の方がよさそうな気がする。 組合せを考えるとインデックスでの指定は結構複雑になりそうだ。

逆に最初の実装はインデックスでダイレクトアクセスができて高速化の可能性は高い とは思うものの、今のままだと他の命令型言語とあまり変わらないし面白くない。

どっちが記述しやすいかはやっている内に判明するだろう。 とにかく最初の version と機能面で等価なレベルのストリーム版を 無理矢理作ってみる。 但しこのストリームは無限ストリームではなく有限ストリーム。。。

":";exec gosh -b $0 "$@"
;
; 簡単な関数
;
(define (inc n) (+ n 1))
(define (dec n) (- n 1))

;
; 遅延評価を実現する関数
;
(define-syntax cons-stream
  (syntax-rules ()
    ((_ x y)
     (cons x (delay y)))))

(define (stream-car s)
  (car s))

(define (stream-cdr s)
  (force (cdr s)))

;
; 組合せ
;
(define (combination n r)
  (cond ((= n r) 1)                          ;; all select
        ((= r 0) 1)                          ;; non select
        ((= r 1) n)                          ;; only one select
        ((> r (- n r))                       ;; optimize
         (combination n (- n r)))
        (else
         (+ (combination (dec n) r)          ;; recursive main body
            (combination (dec n) (dec r))))))

;
; 以後よく使うリスト生成の関数
;
(define (make-list len item)
  (if (= len 0)
      '()
      (cons item (make-list (dec len) item))))

;
; 組合せ nCr の m 番目のパターンを生成する関数を生成
;
; 1.) nCr = n-1Cr + n-1Cr-1
;     右辺第一項は先頭が 0(非選択) 第二項は先頭が 1(非選択) である。
;     m 番目のパターンは第一項より大きいかどうかで先頭が 0 か 1 か
;     決定して結果リスト v に cons しておき、レベルを引き下げる。
;
; 2.) 1. の第一項が選ばれていれば m は変更ないが、第二項が選ばれたら
;     m は第二項の中の m - n-1Cr 番目にあたる点に注意してレベル引き下げ。
;
; 3.) g は選択されたところにはめ込む atom で f は非選択のところにはめ込む atom
;
(define (make-comb-pattern-nth g f)
  (letrec ((comb-pattern-nth
            (lambda (n r m v)
              (cond ((= r 0)
                     (reverse (append (make-list n f) v)))
                    ((= n r)
                     (reverse (append (make-list n g) v)))
                    (else
                     (let ((f-start (combination (dec n) r)))
                       (if (> m f-start)
                           (comb-pattern-nth (dec n) (dec r) (- m f-start) (cons g v))
                           (comb-pattern-nth (dec n) r m (cons f v)))))))))
    comb-pattern-nth))
;
; comb-pattern-nth には nCr の n,r それから nth に相当する m と初期リスト v (通常 '())を与える
;
(define comb-pattern-nth (make-comb-pattern-nth 1 0))
;(define comb-pattern-nth (make-comb-pattern-nth '★ '☆))

;
; comb-pattern-nth のストリーム版
; stream-car stream-cdr でアクセスできる。
; ただし無限ストリームではなく有限ストリームで最後は () で終端される。
;
(define (make-comb-pattern-stream n r)
  (define (comb-pattern-stream-from a)
    (cons-stream (comb-pattern-nth n r a '())
                 (if (>= a (combination n r))
                     ()
                     (comb-pattern-stream-from (inc a)))))
  (comb-pattern-stream-from 1))

;
; comb-pattern-nth で得られたパターン p を l なるリストのメンバで順に置き換える
; l は p に出現する 1 の数より大きく与えないとダメ
;
; (trans1 (0 1 1 0 0 1) '(1 2 3 4 5))
;         => (0 1 2 0 0 3)
; (trans1 (0 1 1 0 0 1) '(3 0 5))
;         => (0 3 0 0 0 5)
;
(define (trans1 p l)
  (let loop ((p p)
             (l l)
             (v '()))
    (if (null? p)
        (reverse v)
        (let ((f (car p))
              (r (cdr p)))
          (cond ((= f 0)
                 (loop r l (cons 0 v)))
                ((= f 1)
                 (loop r (cdr l) (cons (car l) v))))))))

;
; リストの非零の数値をその長さの 1 の並びに展開する。
; ただし、二番目以降の非零の数値は暗黙の空白(塗りつぶし無し)がある。
;
(define (extract-bar p)
  (define appear? #f)  ;; 最初の非零の数値が出たかどうか
  (let loop ((p p)
             (r '()))
    (if (null? p)
        (reverse r)
        (if (= (car p) 0)
            (loop (cdr p) (cons 0 r))
            (loop (cdr p) (append (make-list (car p) 1)
                                  (if appear?
                                      (cons 0 r)
                                      (begin (set! appear? #t)
                                             r))))))))

;
; generate-pattern-nth のストリーム版
; stream-car stream-cdr でアクセスできる。
; ただし無限ストリームではなく有限ストリームで最後は () で終端される。
;
(define (generate-pattern-stream cells hint)
  (if (null? hint)
      (cons (make-list cells 0) '())
      (let* ((closed (apply + hint))                   ;; 塗りつぶしセル数
             (bar    (length hint))                    ;; 塗りつぶしバー数(ヒントの要素数)
             (free   (- cells closed (dec bar)))       ;; 余りの 0(自由度)
             (pat    hint)                             ;; パターン
             (r      (length pat))                     ;; パターンの長さ(nCr の r)
             (n      (+ r free)))                      ;; nCr の n
        (define (generate-comb-pattern-stream n r)
          (define (comb-pattern-stream-from a)
            (cons-stream (extract-bar
                          (trans1 (comb-pattern-nth n r a '()) pat))
                         (if (>= a (combination n r))
                             ()
                             (comb-pattern-stream-from (inc a)))))
          (comb-pattern-stream-from 1))
        (generate-comb-pattern-stream n r))))

;
; 0,1,* で構成される二つのリストの合成を行う。
; 合成の規則は以下
;
; 1.) 0 vs 0 なら 0
; 2.) 1 vs 1 なら 1
; 3.) * vs 0 または * vs 1 なら *
; 4.) 1 vs 0 または 0 vs 1 なら *
; 長さはチェックしてない。
;
;(make-filter-list '(1 1 1 0 0 1 0) '(0 1 0 1 1 1 0))
;       =>(* 1 * * * 1 0)
;
(define (make-filter-list filter pattern)
  (let loop ((f filter)
             (p pattern)
             (v '()))
    (if (null? p)
        (reverse v)
        (let ((carf (car f))
              (carp (car p))
              (cdrf (cdr f))
              (cdrp (cdr p)))
          (cond ((eq? carf carp)
                 (loop cdrf cdrp (cons carf v)))
                (else
                 (loop cdrf cdrp (cons '* v))))))))

;
; 二つのフィルターの合成を行う
; メンバは以下の規則にしたがう
;
; 1.) 0 vs 0 または 1 vs 1 なら その値
; 2.) * vs 0 または 0 vs * ならば 0
; 3.) * vs 1 または * vs 1 ならば 1
; 4.) 1 vs 0 または 0 vs 1 は矛盾でエラー
;
(define (filter-marge f1 f2)
  (let loop ((f1 f1)
             (f2 f2)
             (v '()))
    (if (null? f1)
        (reverse v)
        (let ((car1 (car f1))
              (car2 (car f2))
              (cdr1 (cdr f1))
              (cdr2 (cdr f2)))
          (cond ((eq? car1 '*)
                 (loop cdr1 cdr2 (cons car2 v)))
                ((eq? car2 '*)
                 (loop cdr1 cdr2 (cons car1 v)))
                ((eq? car1 car2)
                 (loop cdr1 cdr2 (cons car1 v)))
                (else
                 (error "ERROR: -- unconsistency occured!" f1 f2)))))))

;
; 0,1,* で構成される filter にマッチするかどうかチェックする関数
; filter のメンバが * のところはパターンによらずマッチしているとする
;
(define (match-pattern? filter pattern)
  (let loop ((f filter)
             (p pattern))
    (if (null? p)
        #t
        (let ((carf (car f))
              (carp (car p))
              (cdrf (cdr f))
              (cdrp (cdr p)))
          (if (or (eq? carf '*)
                  (eq? carf carp))
              (loop cdrf cdrp)
              #f)))))

;
; メインルーチン
;
(define next #f)
(define cont #f)
(define (make-illust-analysis black white open)
  (lambda (row col)
    (define (all? item lst)
      (if (null? lst)
          #t
          (if (eq? (car lst) item)
              (all? item (cdr lst))
              #f)))

    (define (calc-filter s)
      (let ((x (stream-car s))
            (xs (stream-cdr s)))
        (let loop ((x x)
                   (xs xs)
                   (v x))
          (if (null? xs)
              (make-filter-list v x)
              (loop (stream-car xs) (stream-cdr xs) (make-filter-list v x))))))

    (define (renew-filter f s)
      (define (renew-filter2 f s v)
        (let loop2 ((x (stream-car s))
                    (xs (stream-cdr s))
                    (v v))
          (let ((v (if (match-pattern? f x)
                       (make-filter-list v x)
                       v)))
            (if (null? xs)
                v
                (loop2 (stream-car xs) (stream-cdr xs) v)))))
      (let loop ((x (stream-car s))
                 (xs (stream-cdr s)))
        (if (null? xs)
            x
            (if (match-pattern? f x)
                (renew-filter2 f xs x)
                (loop (stream-car xs) (stream-cdr xs))))))

    (define (trans-row-col reclist)
      (let loop ((l reclist)
                 (v '()))
        (if (null? (car l))
            (reverse v)
            (loop (map cdr l) (cons (map car l) v)))))

    (define (draw-illust lst)
      (for-each (lambda (l)
                  (for-each
                   (lambda (c) (cond ((eq? c 1)  (format #t "~a" black))
                                     ((eq? c 0)  (format #t "~a" white))
                                     ((eq? c '*) (format #t "~a" open))))
                   l)
                  (format #t "\n"))
                lst))

    (let ((row-N (length col))
          (col-N (length row)))
      (let ((expRow
             (map (lambda (x) (generate-pattern-stream row-N x)) row))
            (expCol
             (map (lambda (x) (generate-pattern-stream col-N x)) col))
            (result '())
            (tmpres '()))

        ;; check quest data
        (if (not (= (apply + (map (lambda (x) (apply + x)) row))
                    (apply + (map (lambda (x) (apply + x)) col))))
            (error "ERROR: -- Check your puzzle!\nFound unconsistency between row and col.\n"))

        ;; first stage
        (set! result (map (lambda (a b) (filter-marge a b))
                          (map (lambda (s) (calc-filter s)) expRow)
                          (trans-row-col
                           (map (lambda (s) (calc-filter s)) expCol))))

        (let loop ((result result))
          (format #t "*** Analysis and Result ***\n")
          (draw-illust result)

          ;; second stage
          (set! tmpres result) ;; pre-result backup
          (set! result
                (map (lambda (a b) (filter-marge a b))
                     (map (lambda (f s) (renew-filter f s))
                          result expRow)
                     (trans-row-col
                      (map (lambda (f s) (renew-filter f s))
                           (trans-row-col result) expCol))))

          (set! next (if (equal? tmpres result)
                         (lambda ()
                           (draw-illust result)
                           (format #t "finish logical thinking...\n")
                           #t)
                         (lambda () (loop result)))))
        ))))

(define illust-analysis (make-illust-analysis '■ '・ '□))

推論モード搭載 illust-lazy.scm(再新版)

":";exec gosh -b $0 "$@"
;
; 簡単な関数
;
(define (inc n) (+ n 1))
(define (dec n) (- n 1))

(define (include? mem tree)
  (define (atom? item)
    (not (pair? item)))
  (cond ((null? tree) #f)
        ((atom? tree) (eq? mem tree))
        ((pair? tree) (or (include? mem (car tree))
                          (include? mem (cdr tree))))))

;
; 遅延評価を実現する関数
;
(define-syntax cons-stream
  (syntax-rules ()
    ((_ x y)
     (cons x (delay y)))))

(define (stream-car s)
  (car s))

(define (stream-cdr s)
  (force (cdr s)))

;
; 組合せ
;; basic
;(define (combination n r)
;  (cond ((= n r) 1)                         ;; all select
;       ((= r 0) 1)                          ;; non select
;       ((= r 1) n)                          ;; only one select
;       ((> r (- n r))                       ;; optimize
;        (combination n (- n r)))
;       (else
;        (+ (combination (dec n) r)          ;; recursive main body
;           (combination (dec n) (dec r))))))
;
;; high speed
;(define (combination n r)
;  (define (fact x)
;    (if (= x 0)
;       1
;       (* x (fact (- x 1)))))
;  (/ (fact n) (* (fact (- n r)) (fact r))))
;
;; more high speed by teranishi
(define (combination n r)
  (cond ((= n r) 1)                          ;; all select
        ((= r 0) 1)                          ;; non select
        ((= r 1) n)                          ;; only one select
        ((> r (- n r))                       ;; optimize
         (combination n (- n r)))
        (else                                ;; recursive main body
         (/ (* (combination (dec n) (dec r)) n) r))))

;
; 以後よく使うリスト生成の関数
;
(define (make-list len item)
  (if (= len 0)
      '()
      (cons item (make-list (dec len) item))))

;
; 組合せ nCr の m 番目のパターンを生成する関数を生成
;
; 1.) nCr = n-1Cr + n-1Cr-1
;     右辺第一項は先頭が 0(非選択) 第二項は先頭が 1(非選択) である。
;     m 番目のパターンは第一項より大きいかどうかで先頭が 0 か 1 か
;     決定して結果リスト v に cons しておき、レベルを引き下げる。
;
; 2.) 1. の第一項が選ばれていれば m は変更ないが、第二項が選ばれたら
;     m は第二項の中の m - n-1Cr 番目にあたる点に注意してレベル引き下げ。
;
; 3.) g は選択されたところにはめ込む atom で f は非選択のところにはめ込む atom
;
(define (make-comb-pattern-nth g f)
  (letrec ((comb-pattern-nth
            (lambda (n r m v)
              (cond ((= r 0)
                     (reverse (append (make-list n f) v)))
                    ((= n r)
                     (reverse (append (make-list n g) v)))
                    (else
                     (let ((f-start (combination (dec n) r)))
                       (if (> m f-start)
                           (comb-pattern-nth (dec n) (dec r) (- m f-start) (cons g v))
                           (comb-pattern-nth (dec n) r m (cons f v)))))))))
    comb-pattern-nth))
;
; comb-pattern-nth には nCr の n,r それから nth に相当する m と初期リスト v (通常 '())を与える
;
(define comb-pattern-nth (make-comb-pattern-nth 1 0))
;(define comb-pattern-nth (make-comb-pattern-nth '★ '☆))

;
; comb-pattern-nth のストリーム版
; stream-car stream-cdr でアクセスできる。
; ただし無限ストリームではなく有限ストリームで最後は () で終端される。
;
(define (make-comb-pattern-stream n r)
  (define (comb-pattern-stream-from a)
    (cons-stream (comb-pattern-nth n r a '())
                 (if (>= a (combination n r))
                     ()
                     (comb-pattern-stream-from (inc a)))))
  (comb-pattern-stream-from 1))

;
; comb-pattern-nth で得られたパターン p を l なるリストのメンバで順に置き換える
; l は p に出現する 1 の数より大きく与えないとダメ
;
; (trans1 (0 1 1 0 0 1) '(1 2 3 4 5))
;         => (0 1 2 0 0 3)
; (trans1 (0 1 1 0 0 1) '(3 0 5))
;         => (0 3 0 0 0 5)
;
(define (trans1 p l)
  (let loop ((p p)
             (l l)
             (v '()))
    (if (null? p)
        (reverse v)
        (let ((f (car p))
              (r (cdr p)))
          (cond ((= f 0)
                 (loop r l (cons 0 v)))
                ((= f 1)
                 (loop r (cdr l) (cons (car l) v))))))))

;
; リストの非零の数値をその長さの 1 の並びに展開する。
; ただし、二番目以降の非零の数値は暗黙の空白(塗りつぶし無し)がある。
;
(define (extract-bar p)
  (define appear? #f)  ;; 最初の非零の数値が出たかどうか
  (let loop ((p p)
             (r '()))
    (if (null? p)
        (reverse r)
        (if (= (car p) 0)
            (loop (cdr p) (cons 0 r))
            (loop (cdr p) (append (make-list (car p) 1)
                                  (if appear?
                                      (cons 0 r)
                                      (begin (set! appear? #t)
                                             r))))))))

;
; generate-pattern-nth のストリーム版
; stream-car stream-cdr でアクセスできる。
; ただし無限ストリームではなく有限ストリームで最後は () で終端される。
;
(define (generate-pattern-stream cells hint)
  (if (null? hint)
      (cons (make-list cells 0) '())
      (let* ((closed (apply + hint))                   ;; 塗りつぶしセル数
             (bar    (length hint))                    ;; 塗りつぶしバー数(ヒントの要素数)
             (free   (- cells closed (dec bar)))       ;; 余りの 0(自由度)
             (pat    hint)                             ;; パターン
             (r      (length pat))                     ;; パターンの長さ(nCr の r)
             (n      (+ r free)))                      ;; nCr の n
        (define (generate-comb-pattern-stream n r)
          (define (comb-pattern-stream-from a)
            (cons-stream (extract-bar
                          (trans1 (comb-pattern-nth n r a '()) pat))
                         (if (>= a (combination n r))
                             ()
                             (comb-pattern-stream-from (inc a)))))
          (comb-pattern-stream-from 1))
        (generate-comb-pattern-stream n r))))

;
; 0,1,* で構成される二つのリストの合成を行う。
; 合成の規則は以下
;
; 1.) 0 vs 0 なら 0
; 2.) 1 vs 1 なら 1
; 3.) * vs 0 または * vs 1 なら *
; 4.) 1 vs 0 または 0 vs 1 なら *
; 長さはチェックしてない。
;
;(make-filter-list '(1 1 1 0 0 1 0) '(0 1 0 1 1 1 0))
;       =>(* 1 * * * 1 0)
;
(define (make-filter-list filter pattern)
  (let loop ((f filter)
             (p pattern)
             (v '()))
    (if (null? p)
        (reverse v)
        (let ((carf (car f))
              (carp (car p))
              (cdrf (cdr f))
              (cdrp (cdr p)))
          (cond ((eq? carf carp)
                 (loop cdrf cdrp (cons carf v)))
                (else
                 (loop cdrf cdrp (cons '* v))))))))

;
; 二つのフィルターの合成を行う
; メンバは以下の規則にしたがう
;
; 1.) 0 vs 0 または 1 vs 1 なら その値
; 2.) * vs 0 または 0 vs * ならば 0
; 3.) * vs 1 または 1 vs * ならば 1
; 4.) 1 vs 0 または 0 vs 1 は矛盾でエラー
;
(define (filter-marge f1 f2)
  (let loop ((f1 f1)
             (f2 f2)
             (v '()))
    (if (null? f1)
        (reverse v)
        (let ((car1 (car f1))
              (car2 (car f2))
              (cdr1 (cdr f1))
              (cdr2 (cdr f2)))
          (cond ((eq? car1 '*)
                 (loop cdr1 cdr2 (cons car2 v)))
                ((eq? car2 '*)
                 (loop cdr1 cdr2 (cons car1 v)))
                ((eq? car1 car2)
                 (loop cdr1 cdr2 (cons car1 v)))
                (else
                 #f))))))     ;; unconsistency occured!!

;
; 0,1,* で構成される filter にマッチするかどうかチェックする関数
; filter のメンバが * のところはパターンによらずマッチしているとする
;
(define (match-pattern? filter pattern)
  (let loop ((f filter)
             (p pattern))
    (if (null? p)
        #t
        (let ((carf (car f))
              (carp (car p))
              (cdrf (cdr f))
              (cdrp (cdr p)))
          (if (or (eq? carf '*)
                  (eq? carf carp))
              (loop cdrf cdrp)
              #f)))))

;
; 推論モードのための定義
;
(define *bt-stack* '()) ;; stack for back track
(define (check-in! r)
  (push! *bt-stack* r))
(define (check-out!)
  (pop! *bt-stack*))
(define (null-bt-point?)
  (null? *bt-stack*))

;
; リスト要素の置換
; リスト中で``最初に見付けた''対象を置換する。
; (substitute '* 1 '(1 1 0 1 0 * 1 0 1 * *))
;                => (1 1 0 1 0 1 1 0 1 * *)
; (substitute '* 0 '(1 1 (0 1 * 0) * 1 ((1 0) 0 1) 1 *))
;                => (1 1 (0 1 0 0) * 1 ((1 0) 0 1) 1 *)
(define (substitute old new tree)
  (define flag #f)
  (define (sub2 tree)
    (if (equal? old tree)
        (if flag
            tree
            (begin
              (set! flag #t)
              new))
        (if (pair? tree)
            (cons (sub2 (car tree))
                  (sub2 (cdr tree)))
            tree)))
  (sub2 tree))

;
; メインルーチン
;
(define next #f)
(define cont #f)
(define (make-illust-analysis black white open new-black new-white)
  (lambda (row col)
    (define (all? item lst)
      (if (null? lst)
          #t
          (if (eq? (car lst) item)
              (all? item (cdr lst))
              #f)))

    (define (calc-filter s)
      (let ((x (stream-car s))
            (xs (stream-cdr s)))
        (let loop ((x x)
                   (xs xs)
                   (v x))
          (if (null? xs)
              (make-filter-list v x)
              (loop (stream-car xs) (stream-cdr xs) (make-filter-list v x))))))

    (define (renew-filter f s)
      (define (renew-filter2 f s v)
        (let loop2 ((x (stream-car s))
                    (xs (stream-cdr s))
                    (v v))
          (let ((v (if (match-pattern? f x)
                       (make-filter-list v x)
                       v)))
            (if (null? xs)
                v
                (loop2 (stream-car xs) (stream-cdr xs) v)))))
      (let loop ((x (stream-car s))
                 (xs (stream-cdr s)))
        (if (null? xs)
            x
            (if (match-pattern? f x)
                (renew-filter2 f xs x)
                (loop (stream-car xs) (stream-cdr xs))))))

    (define (trans-row-col reclist)
      (let loop ((l reclist)
                 (v '()))
        (if (null? (car l))
            (reverse v)
            (loop (map cdr l) (cons (map car l) v)))))

    (define (draw-illust lst)
      (for-each (lambda (l)
                  (for-each
                   (lambda (c) (cond ((eq? c 1)  (format #t "~a" black))
                                     ((eq? c 0)  (format #t "~a" white))
                                     ((eq? c '*) (format #t "~a" open))))
                   l)
                  (format #t "\n"))
                lst))

    (define (draw-illust-diff new old)
      (for-each (lambda (n o)
                  (for-each
                   (lambda (nc oc)
                     (if (eq? nc oc)
                         (cond ((eq? nc 1)  (format #t "~a" black))
                               ((eq? nc 0)  (format #t "~a" white))
                               ((eq? nc '*) (format #t "~a" open)))
                         (cond ((eq? nc 1)  (format #t "~a" new-black))
                               ((eq? nc 0)  (format #t "~a" new-white)))))
                   n o)
                  (format #t "\n"))
                new old))

    (let ((row-N (length col))
          (col-N (length row)))
      (let ((expRow
             (map (lambda (x) (generate-pattern-stream row-N x)) row))
            (expCol
             (map (lambda (x) (generate-pattern-stream col-N x)) col))
            (result (make-list col-N (make-list row-N '*)))
            (tmpres (make-list col-N (make-list row-N '*))))

        ;; check quest data
        (if (not (= (apply + (map (lambda (x) (apply + x)) row))
                    (apply + (map (lambda (x) (apply + x)) col))))
            (error "ERROR: -- Check your puzzle!\nFound unconsistency between row and col.\n"))

        ;; first stage
        (set! result
              (map filter-marge
                   (map calc-filter expRow)
                   (trans-row-col
                    (map calc-filter expCol))))
        
        (let loop ((result result))
          (format #t "*** Analysis and Result ***\n")
          (draw-illust-diff result tmpres)
          ;; second stage
          (set! tmpres result) ;; pre-result backup
          (set! result
                (map filter-marge
                     (map renew-filter result expRow)
                     (trans-row-col
                      (map renew-filter (trans-row-col result) expCol))))

          ;; #f は filter-marge から返る可能性があり、
          ;; この場合には矛盾が発生したのでバックトラックする
          (if (include? #f result)
              (begin
                (format #t "back tracking occured!\n")
                (set! result (check-out!))
                (set! tmpres (check-out!))))

          (set! next
                (if (equal? tmpres result)
                    (if (include? '* result)     ;; 推論が必要か?
                        (begin
                          (format #t "Go into speculation mode...\n")
                          (check-in! tmpres)
                          (check-in! (substitute '* 0 result))
                          (set! result (substitute '* 1 result))
                          (loop result)
                          )
                        (lambda ()
                          (format #t "*** Analysis and Result ***\n")
                          (draw-illust-diff result tmpres)
                          (format #t "Finish analysis...\n")
                          #t))
                    (lambda () (loop result))))  ;; 標準ループ
          )))))

(define illust-analysis (make-illust-analysis '■ '・ '□ '★ '☆))
;(define illust-analysis (make-illust-analysis #\# #\. #\space '* #\o))

(define (main args)
  (load (cadr args))
  (illust-analysis row col)
  (do () ((boolean? (next))))
  0)

色々大幅に変更を実施した。
特に first stage/second stage 部分の filter-marge/calc-filter/renew-filter への map 適用部分にあった無駄な lambda なんかも修正。(恥)

とりあえず、解が一つのものについてはこれでOKなはず。 推論モードが必要だった問題で解いたやつはScheme:イラストロジック:デモに。

ただし、推論中の表示も毎回 (next) 起動になるので、 現時点では teranishi さんが追加した main を用いて コマンドラインからの呼び出しをするのが望ましい。 というかくそまじめに (next) やってたら間違い無く飽きる。

これについては後日変更修正して、途中経過は表示させず (next) 一発で 結果として得られる解までは一気に走らせたい。 推論状況は *bt-stack* を probe すれば良いのでそれで代用可能なはずだし。

ちなみに lambda.scm についてはやはり複数解が存在するらしく、 最初に見付かるのがλにならない。。。 なお複数解探索を作成してたら2つ目の解として得られたが・・・
どうにもコードがぐちゃぐちゃしてきたので、 ある程度整理しないとよろしく無いように思い、一旦この時点でUPさせて頂く。cut-sea:2004/05/06 07:11:27 PDT


問題文の生成 quest.scm

デバッグするのに問題をいちいち入力するのも結構面倒。。。

というわけで絵から問題を生成するスクリプトをアップします。 scheme のコードを吐くってことで define-macro を使ってみました。

まず kbanner とかエディタで絵を書きます。 絵は塗りつぶすところは特に指定しないけど塗らないところは 今のところ #\space である必要あり。(kbanner の出力を意識しただけ) まぁカスタマイズは簡単だと思う。多分。 あんまり他の文字で構成された絵を試してないのでバグバグしてると思います。

":"; exec gosh -b $0 "$@"
(use srfi-1)
(use srfi-13)

(define (illust->string filename)
  (call-with-input-file filename
    (lambda (in)
      (let loop ((l (read-line in))
                 (v '()))
        (if (eof-object? l)
            (reverse v)
            (if (equal? l "")
                (loop (read-line in) v)
                (loop (read-line in) (cons l v))))))))

(define (make-count-close-box regexp)
  (lambda (str)
    (filter (lambda (s) (not (= 0 s)))
            (map string-length
                 (string-split
                  str
                  (string->regexp regexp))))))
;
; 空白の文字を指定すればそれで作成してくれる
; デフォルトでは #\space 以外の文字で塗りつぶしの桝目数をカウントする
;
(define count-close-box (make-count-close-box "[^#\space]+"))

(define (car-string s)
  (list->string (list (car (string->list s)))))

(define (cdr-string s)
  (list->string (cdr (string->list s))))

(define (trans-row-col lst)
  (let loop ((lst lst)
             (v '()))
    (if (equal? (car lst) "")
        (reverse v)
        (loop (map cdr-string lst)
              (cons (string-concatenate (map car-string lst))
                    v)))))

(define (illust->row filename)
  (let ((v (illust->string filename)))
    (map count-close-box v)))

(define (illust->col filename)
  (let ((v (trans-row-col (illust->string filename))))
    (map count-close-box v)))

(define-macro (generate-quest filename)
  `(begin
    (format #t "~a\n" `(define row ',(illust->row ,filename)))
    (format #t "~a\n" `(define col ',(illust->col ,filename)))))

(for-each (lambda (f) (generate-quest f)) *argv*)

これを使えばその絵の問題を作れる。 こんな感じだ。

cut-sea@jini> cat foo

        ##        ##            
        ##        ##            
  ##############  ##############
    ##      ##    ##            
      ##  ##      ############  
##################          ##  
                  ############  
    ##########    ##            
    ##      ##    ############  
    ##########    ##            
    ##      ##    ############  
    ##########    ##            
    ##      ##    ############  
    ##      ##    ##          ##
    ##      ##    ####      ####
    ##    ####      ##########  
                                
;; でもってこいつを quest.scm に食わせる。

cut-sea@jini> ./quest.scm foo 
(define row '((2 2) (2 2) (14 14) (2 2 2) (2 2 12) (18 2) (12) (10 2) (2 2 12) (10 2) (2 2 12) (10 2) (2 2 12) (2 2 2 2) (2 2 4 4) (2 4 10) ()))
(define col '((1) (1) (1 1) (1 1) (2 1 9) (2 1 9) (1 2 1 1 1) (1 2 1 1 1) (3 1 1 1 1) (3 1 1 1 1) (1 2 1 1 1 1) (1 2 1 1 1 1) (2 1 9) (2 1 9) (1 1) (1 1) (1) (1) (5 9) (5 9) (1 1 1 1 1 1 2) (1 1 1 1 1 1 2) (1 1 1 1 1 1 1) (1 1 1 1 1 1 1) (1 1 1 1 1 1 1) (1 1 1 1 1 1 1) (1 1 1 1 1 1 1) (1 1 1 1 1 1 1) (1 3 1 1 1 2) (1 3 1 1 1 2) (1 2) (1 2)))
cut-sea@jini> 

最後のを何かのファイルにリダイレクトしておけば問題ファイルの出来上がり。cut-sea:2004/03/08 03:06:34 PST

一応この龍も最後まで解けるのを確認したけど、結構時間掛かります。
Pentium4 2.0GHz でも結構待たされたんで、それより非力なマシンでやる場合は 覚悟しておいてね。
あと、印字した後にプロンプト戻ってくるまで待たされるのは次の計算を しちゃってるからです。 使い方としてはそうなるかな〜って思っているからですが。。。
#従って(next) ってした時にはすぐに結果を出してくれる。cut-sea


デモに示した問題文

問題は下のような S式で表現。 ちなみに問題で 0 のところには () が対応する。 lambda.scm の col の両端や quest2.scm の row の 12番目がまさにそう。

lambda.scm

やってもらえば分かるけど、これはまだ途中までしか解けない。 問題と問題文の作り方を示すためにアップ。。。

問題は kbanner からの出力を利用したので、 そもそも解ける保証なしに作成したものだ。

;                1122
;       0112233221111993322110
;     4 .........XXXX.........
;     4 ...........XXXX.......
;     2 .............XX.......
;     2 .............XX.......
;     2 .............XX.......
;     2 .............XX.......
;     4 ...........XXXX.......
;   2 2 .........XX..XX.......
;   2 2 .......XX....XX.......
;   4 4 .....XXXX....XXXX.....
;   2 2 .....XX........XX.....
;   4 4 ...XXXX........XXXX...
;   4 4 .XXXX............XXXX.

(define row
  '((4)
    (4)
    (2)
    (2)
    (2)
    (2)
    (4)
    (2 2)
    (2 2)
    (4 4)
    (2 2)
    (4 4)
    (4 4)))
(define col
  '(()
    (1)
    (1)
    (2)
    (2)
    (3)
    (3)
    (2)
    (2)
    (1 1)
    (1 1)
    (2 1)
    (2 1)
    (9)
    (9)
    (3)
    (3)
    (2)
    (2)
    (1)
    (1)
    ()))

quest1.scm

(define row
  '((2)
    (4 2)
    (4 2)
    (4 2)
    (2 7)
    (2 6)
    (7)
    (6)
    (4)
    (4)))

(define col
  '((3)
    (4)
    (2)
    (9)
    (10)
    (10)
    (9)
    (2)
    (5)
    (4)))

quest2.scm

(define row
  '((8 9)
    (7 2 2 4)
    (8 2 3 3)
    (13 2 2)
    (15 2)
    (6 1 1 2)
    (5 8 1 2)
    (4 10 1 2)
    (3 12 2)
    (2 14 2)
    (1 16 1)
    ()
    (3 12 3)
    (3 1 1 1 3)
    (3 1 2 1 1 1 1 3)
    (3 1 2 1 1 1 1 3)
    (3 1 1 1 1 3)
    (3 1 2 7 3)
    (3 1 2 7 3)
    (3 3)))

(define col
  '((11 8)
    (10 8)
    (9 1 8)
    (8 2)
    (7 3 7)
    (6 4 1)
    (5 5 1 5)
    (1 3 5 1 2 2)
    (1 2 5 1)
    (1 2 5 7)
    (3 5 1 2)
    (5 5 1 2 2)
    (2 2 5 1 2)
    (1 1 1 5 1 2 2)
    (1 1 2 4 1 2)
    (1 2 3 7)
    (2 1 3 2)
    (3 1 8)
    (10 8)
    (11 8)))

覚書

最初のバージョンまでの覚書

実は最初はストリームの勉強になると思ってたのだが、思わぬ事になった。 generate-pattern-nthに相当する部分が元はストリームにしないとと思ってた。 nCr のパターンの数は nC(r-1) と (n-1)Cr になるところから同じように再帰的に パターンを起こすようにして、それが多くなるのでメモリが足りなくなり gosh が 終了してしまうため、ストリームにしようと目論んだわけだ。

ところがこの再帰パターンがどうしても map したものと map したものの append に なってしまい、関数各部を stream-map や cons-stream などにしたり delay を 挿入してもどうにもうまくいかない。

どうしても (直接のパターン . #<promise ...>) にするしかないと考え、 結局 generate-pattern-nth にたどり着いた。

その結果結局遅延評価が必要無くなってしまったという事態に。。。
コードとしても面白味は激減した。

最初はデモにもλ文字が浮かび上がるのを検討したのだが、kbanner から問題文を 作成すると完全に一意の解にたどり着かず、やはり推論モードへの移行が必要なようだ。

TODO

  1. 推論モードへの移行と解の順次表示(やはり継続)(複数解探索も含めて途中段階)
  2. 絵だけで問題が出てないのでこれもやっぱり表示させよう (容易・・・でも半角にした場合どうしよう)
  3. 次の一手が分かるように差分が分かるような表示をさせよう(比較的容易)
  4. 高速化。。。これはまぁやりながらちょこちょこ(実はめんどくさい)
  5. 随時コード整理も。。。(随時やっていかないと・・・)

Tag: Puzzle

More ...