Scheme:イラストロジック
イラストロジック解析
イラストロジック
パズルとして有名だけど、約15年くらいまえかなぁ新聞のパズル欄に出てて、 母親が何のパズルなんだかよく分からんがと聞いて来たのが最初。
私も初めて問題を読んで、それで説明してやった。 するとその後、家族で一時期ブームが訪れた。
その時に pascal ベースの解析ソフトなんかも出てて、 DOS 上で走らせて解いてみたりもした。
その pascal コードには結構真面目に論理的な解き方の解説もしてあり、 かつ複数解存在する問題についても全解を一気に表示することができた。
ただ、このソフトは残念ながら彼女には不評だったのだ。 彼女は次の一手が見付からなかった時に次の一手だけが欲しいのであって 答えそのものは見たくないのだ。
その後つき合った彼女などもイラストロジックには結構はまるタイプが。。。 しかもほとんど上記と同じ要望を持つ。
ならばと以前 C で取り組んだことがあったのだが、 問題を読み込む所で挫折。。。(早っ (^^;;)
さくさく書けちゃう scheme で再チャレンジだ。
最初のバージョンはコメントと空行を除けばわずか 215 行の簡単なもの。 特に私は実装済関数ですら調べずに再発明するし、 無駄も多いと思うので核はもっと短くなるだろう。
- Shiro: とりあえず、combination → util.combinations参照;
make-list → 組み込み関数(srfi-1にもあり)、です。
- Thanks. make-list って全く同名で引数順序も同じですね。う〜む、不思議だ。 ちなみに combinarion は単純に nCr を計算しているだけなのでちょい違うようです。 微妙に見る角度が違うし結果のもらい方も違うけど combinations に相当するのは comb-pattern-nth かな。 combinations が "長さ n のリストから r 個を選択したリストの集合(リスト)を返す" のに対して comb-pattern-nth は"長さ n の場所の内 r 箇所を選択 (1を立てる)リスト のパッケージングしたものを返す"って感じ。cut-sea
イラストロジック解析の最初のコード 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 についてはやはり複数解が存在するらしく、
最初に見付かるのがλにならない。。。
なお複数解探索を作成してたら２つ目の解として得られたが・・・
どうにもコードがぐちゃぐちゃしてきたので、
ある程度整理しないとよろしく無いように思い、一旦この時点でUPさせて頂く。cut-sea:2004/05/06 07:11:27 PDT
- あ、そうそう。λの場合三つ目の解を探しに行った途中で矛盾発生して探索空間
が枯渇していたので、多分解は２つしかないと思われる。
ってことは
(if (include? '* result) ;; 推論が必要か? (begin (format #t "Go into speculation mode...\n") (check-in! (substitute '* 1 result)) ;; ←これを1に (set! result (substitute '* 0 result)) ;; ←これを0に (loop result) )この様に優先的に探索する条件を0/1逆にしてやれば、 このままでもλが一つ目の解となって停止するはず。 また、quest3.scm は解が一個しかないので、これも解ける。
ただ、通常推論モード移行が必要な場合ってのは(斜めに走る)線画が多い。 そして塗りつぶしが少ない。同じ絵で白黒逆問題を作るとほぼ一発で解けちゃう。 ((next)が要らないくらいになる)
したがって推論モード時に塗りつぶさないことを仮定して推論を進めるのは 基本的に推論に推論を重ねて行く方向に探索が進むはずなので なんとなくどうかなぁと思った。 塗りつぶしから仮定して入れば比較的さくさく論理思考が進んで矛盾か解かに すぐ行きつくんじゃないかなぁという直感だけ。
実際には複数解を探すなら結局全空間探索するんだから、 どっちから初めても同じだと思うんだけど気分的な問題かな。cut-sea:2004/05/06 17:03:35 PDT
- さらに変更修正を追加。
make-illust-analysis の引数に new-black と new-white を追加して、
差分を別のシンボルで表示できるようにした。
速度的には若干落ちるが、気になるレベルじゃなかったのでとりあえず適用した。cut-sea:2004/05/07 03:00:09 PDT
- やっぱりバグってた。バックトラック発生直後の差分表示が一部化ける。
てなわけで tmpres もスタックに取り込む形にした。cut-sea:2004/05/07 03:26:29 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 から問題文を 作成すると完全に一意の解にたどり着かず、やはり推論モードへの移行が必要なようだ。
- rowとcolを同時に処理していますが、片方ずつ処理するようにすれば、使える情報が増えるし、変化のない行を処理しないという最適化もやりやすくなります。--teranishi
;; first stage (set! result (map calc-filter expRow)) (let loop ((expRow expCol) (expCol expRow) (prev (make-list row-N (make-list col-N 'dummy))) (curr (trans-row-col result)) (trans? #t)) (format #t "*** Analysis and Result ***\n") (draw-illust (if trans? (trans-row-col curr) curr)) ;; second stage (if (equal? prev curr) (begin (format #t "finish logical thinking...\n") #t) (let ((new (map (lambda (p c s) (if (equal? p c) c (renew-filter c s))) prev curr expRow))) (set! next (lambda () (loop expCol expRow (trans-row-col curr) (trans-row-col new) (not trans?))))))) ))))
- なるほど。
実はこの辺りは人の思考ルーチンに近いなどとは詠いつつ、 結構いじりシロはあるなぁと思ってます。
たとえば縦横一個ずつ交互にやったらどうかとか、 特に元のデータが大きい数字の行や列のところから着目して詰めて行くのが定石なので その辺を組み入れた方がよさそうかな？とか。
これは基本的には自由度の小さい順に優先処理すればいいのかなと思ってますけども。
突っ込み大歓迎なんで、どんどんいじったって下さい。
実は私はっていうと別のこと勉強してて手がとまっとりますし。 単にSICPの再読み込みしてるだけなんですが。。。cut-sea
- generate-pattern-stream の別解 --teranishi
(define (make-rest-pattern hint pattern) (if (null? hint) (cdr pattern) (make-rest-pattern (cdr hint) (cons 0 (append! (make-list (car hint) 1) pattern))))) (define (generate-pattern-for free hint pattern rest) (cond ((= free 0) (cons (make-rest-pattern hint pattern) rest)) ((null? hint) (cons (append! (make-list (dec free) 0) pattern) rest)) (else (generate-pattern-for free (cdr hint) (cons 0 (append! (make-list (car hint) 1) pattern)) (delay (generate-pattern-for (dec free) hint (cons 0 pattern) rest)))))) (define (generate-pattern-stream cells hint) (generate-pattern-for (apply - cells (dec (length hint)) hint) (reverse hint) () ()))
- コマンドラインからの起動時に、解けるまで繰り返し (next) を呼ぶ --teranishi
(define (main args) (load (cadr args)) (illust-analysis row col) (do () ((boolean? (next)))) 0)
- combinarion の定義を変えるとかなり高速化される
(define (combination n r) (define (fact x) (if (= x 0) 1 (* x (fact (- x 1))))) (/ (fact n) (* (fact (- n r)) (fact r))))
以前あんだけ長かった龍の文字がざっと 7〜8 分の 1 になった。cut-sea:2004/04/29 14:54:33 PDT問題 新 combination 旧 combination quest1.scm 0.03 real 0.02 user 0.00 sys 0.03 real 0.02 user 0.00 sys quest2.scm 0.91 real 0.87 user 0.00 sys 1.77 real 1.71 user 0.01 sys quest3.scm 0.89 real 0.86 user 0.00 sys 0.92 real 0.88 user 0.00 sys quest4.scm 0.08 real 0.07 user 0.00 sys 0.07 real 0.02 user 0.02 sys quest5.scm 22.85 real 22.50 user 0.00 sys 154.38 real 153.17 user 0.04 sys
- ちなみに上記の表は推論モード非対応です。対応版での再測定。
全体に多少落ちる。問題 推論モード非対応 推論モード対応 quest1.scm 0.03 real 0.02 user 0.00 sys 0.04 real 0.02 user 0.00 sys quest2.scm 0.91 real 0.87 user 0.00 sys 0.93 real 0.89 user 0.01 sys quest3.scm 0.89 real 0.86 user 0.00 sys 38.80 real 38.16 user 0.25 sys quest4.scm 0.08 real 0.07 user 0.00 sys 0.09 real 0.07 user 0.00 sys quest5.scm 22.85 real 22.50 user 0.00 sys 22.91 real 22.54 user 0.09 sys
quest3.scm については非対応の場合は解けずにあきらめているので早いだけ。2004/05/06 07:49:40 PDT
- combination の更なる高速化 --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))))
- 早速試してみました。
combination のみの違いです。いずれも差分表示まで適用済み。
問題 fact combination teranishi combination quest1.scm 0.04 real 0.01 user 0.00 sys 0.03 real 0.02 user 0.00 sys quest2.scm 0.91 real 0.84 user 0.00 sys 0.51 real 0.50 user 0.01 sys quest3.scm 39.05 real 38.42 user 0.03 sys 38.41 real 37.74 user 0.23 sys quest4.scm 0.09 real 0.04 user 0.00 sys 0.07 real 0.06 user 0.00 sys quest5.scm 22.72 real 22.32 user 0.10 sys 8.25 real 7.99 user 0.13 sys - 驚いたのは quest5.scm(龍)ですが、quest2.scm(家)も早い！ いずれも半分からそれ以下になるのですが、 他の問題への効果と見比べると、どうも問題サイズが大きくなった時に 効果がはっきり出て来るみたいですね。 というわけで埋め込ませてもらいます。cut-sea:2004/05/07 07:21:12 PDT
- renew-filter の loop の方のループで、xs が null の場合に x が返されますが、f とマッチしているかどうか確認しないでかまわないのでしょうか。
どちらにしろ filter-marge で矛盾すると思うので多分大丈夫だとは思いますが。--teranishi- ホントだ。バグの匂いプンプンですね。 一応確認して後で fix しておきます。cut-sea:2004/05/07 07:21:12 PDT
TODO
- 推論モードへの移行と解の順次表示(やはり継続)(複数解探索も含めて途中段階)
- 絵だけで問題が出てないのでこれもやっぱり表示させよう (容易・・・でも半角にした場合どうしよう)
- 次の一手が分かるように差分が分かるような表示をさせよう(比較的容易)
- 高速化。。。これはまぁやりながらちょこちょこ(実はめんどくさい)
- 随時コード整理も。。。(随時やっていかないと・・・)
Tag: Puzzle