アパート問題をSchemeで
素直なプログラム
昨日Prologで書いたアパート問題をSchemeに翻訳してみる．
最初はいちばん素直なプログラム．このRubyプログラムをほぼ忠実に翻訳したものだ．使用処理系はGauche．
(use gauche.time) (use srfi-1) (load "./nd.scm") (define-syntax name-value (syntax-rules () ((_ n ...) (list (cons 'n n) ...)))) (define (solve) (let* ((floor (iota 5 1)) (baker (choose floor)) (cooper (choose floor)) (fletcher (choose floor)) (miller (choose floor)) (smith (choose floor)) (answer (name-value baker cooper fletcher miller smith))) (assert (lset= = floor (map cdr answer))) (assert (not (= baker 5))) (assert (not (= cooper 1))) (assert (and (not (= fletcher 5)) (not (= fletcher 1)))) (assert (> miller cooper)) (assert (not (= 1 (abs (- smith fletcher))))) (assert (not (= 1 (abs (- cooper fletcher))))) answer)) (define (main args) (time (print (solve))))
ただし，nd.scmはOn Lispのchooseとfailを少しだけ書き換えてassertを足したもので，内容はこうなっている．
(define *paths* '()) (define (choose l) (if (null? l) (fail) (let/cc k (set! *paths* (cons (lambda () (k (choose (cdr l)))) *paths*)) (car l)))) (define fail #f) (let/cc k (set! fail (lambda () (if (null? *paths*) (k #f) (let ((p1 (car *paths*))) (set! *paths* (cdr *paths*)) (p1)))))) (define (assert e) (unless e (fail)))
実行結果は次のとおり．
((baker . 3) (cooper . 2) (fletcher . 4) (miller . 5) (smith . 1)) ;(time (print (solve))) ; real 0.156 ; user 0.141 ; sys 0.000
伝統的マクロがよくわからない
少し脱線するが，先のプログラムで，結果をわかりやすく表示するために健全なマクロで定義したname-valueを，define-macroで定義しようとしたら，さっぱりわからない…．どなたか教えてくれるとすごく嬉しいです．
階の割り当ての間に制約を挟む
住人ひとりずつに階を割り当てながら制約条件をチェックするようにsolveを書き直したのが次のプログラム．letがどんどん深くなるのがいやな感じ．これならProlog版の方が簡潔で見やすいな．
(define (solve) (let ((baker (choose '(1 2 3 4)))) (assert (not (= baker 5))) (let ((cooper (choose '(2 3 4)))) (assert (not (= cooper 1))) (let ((fletcher (choose '(2 3 4)))) (assert (and (not (= fletcher 5)) (not (= fletcher 1)))) (assert (not (= 1 (abs (- cooper fletcher))))) (let ((miller (choose '(2 3 4 5)))) (assert (> miller cooper)) (let* ((smith (choose '(1 2 3 4 5))) (answer (name-value baker cooper fletcher miller smith))) (assert (not (= 1 (abs (- smith fletcher))))) (assert (lset= = '(1 2 3 4 5) (map cdr answer))) answer))))))
順列を使う
宣言的プログラミングという観点からは邪道とも思える順列利用版は，素直に書くと以下のようになるだろう．
(use util.combinations) (define (solve) (let* ((floor (choose (permutations (iota 5 1)))) (baker (first floor)) (cooper (second floor)) (fletcher (third floor)) (miller (fourth floor)) (smith (fifth floor))) (assert (not (= baker 5))) (assert (not (= cooper 1))) (assert (and (not (= fletcher 5)) (not (= fletcher 1)))) (assert (> miller cooper)) (assert (not (= 1 (abs (- smith fletcher))))) (assert (not (= 1 (abs (- cooper fletcher))))) (name-value baker cooper fletcher miller smith)))
しかし，このプログラムはProlog版とは振る舞いが全然違う．こちらは，最初に(1 2 3 4 5)の順列をすべて生成してしまうが，Prolog版ではバックトラックする度に新しい順列を作る．解がひとつしか必要ない場合（今の場合はまさにそう），順列を前もってすべて生成しておくなんて，非決定性計算の醍醐味はまるでなく，下記の決定性計算版とほとんど同じことになってしまう．
(define (solve) (filter-map (lambda (floor) (let ((baker (first floor)) (cooper (second floor)) (fletcher (third floor)) (miller (fourth floor)) (smith (fifth floor))) (and (not (= baker 5)) (not (= cooper 1)) (and (not (= fletcher 5)) (not (= fletcher 1))) (> miller cooper) (not (= 1 (abs (- smith fletcher)))) (not (= 1 (abs (- cooper fletcher)))) (name-value baker cooper fletcher miller smith)))) (permutations (iota 5 1))))
こんなときこそストリームを使うんだろう，と思うのだが，情けないことに，これがすんなりといかない…．続きはまた．
非決定性計算ならPrologで
問題とRubyおよびHaskellのプログラム
何かを探していて偶然面白い問題を見つけた．
Baker, Cooper, Fletcher, MillerとSmithは五階建てアパートの異なる階に住んでいる。Bakerは最上階に住むのではない。Cooperは最下階に住むのではない。Fletcherは最上階にも最下階にも住むのではない。MillerはCooperより上の階に住んでいる。SmithはFletcherの隣の階に住むのではない。FletcherはCooperの隣の階に住むのではない。それぞれはどの階に住んでいるか。
そういえばSICPで見かけた気もするけど，あまり気にしていなかった．
このRubyプログラム，継続で非決定性計算を実現しているのはともかく，それをRubyでやっているのが新鮮だった．Rubyにファーストクラス継続が導入されているなんて知らなかったから．
Haskell版はよくわからないが（Haskell勉強しなくちゃ…），非決定性計算ならPrologでしょ，ということで，Prologで書いてみた．使用処理系はSWI Prolog．
Prologに翻訳
baker(N) :- between(1,5,N). cooper(N) :- between(1,5,N). fletcher(N) :- between(1,5,N). miller(N) :- between(1,5,N). smith(N) :- between(1,5,N). solve(Baker,Cooper,Fletcher,Miller,Smith) :- baker(Baker),cooper(Cooper),fletcher(Fletcher),miller(Miller),smith(Smith), sort([Baker,Cooper,Fletcher,Miller,Smith],[1,2,3,4,5]), Baker =\= 5, Cooper =\=1, Fletcher =\=1, Fletcher =\= 5, Miller > Cooper, abs(Smith - Fletcher) =\= 1, abs(Fletcher - Cooper) =\= 1.
実行結果は次のとおり．
?-time(solve(Baker,Cooper,Fletcher,Miller,Smith)). % 2,475 inferences, 0.00 CPU in 0.06 seconds (0% CPU, Infinite Lips) Baker = 3, Cooper = 2, Fletcher = 4, Miller = 5, Smith = 1 Yes
枝刈り
しかし，SICPにも書かれているとおり，このプログラムにはあまりに無駄が多いのが気になる．生成＆検査アルゴリズムでは，できるだけ生成の深いところで無駄な枝を刈るべし，というのがセオリーなので，solve/5を書き直してみた．住人の住む階をまとめて決めずに，1つずつ決めながら制約を満たしているか確かめていくのがポイント．
baker(N) :- between(1,5,N). cooper(N) :- between(1,5,N). fletcher(N) :- between(1,5,N). miller(N) :- between(1,5,N). smith(N) :- between(1,5,N). solve(Baker,Cooper,Fletcher,Miller,Smith) :- baker(Baker), Baker =\= 5, cooper(Cooper), Cooper =\=1, fletcher(Fletcher), Fletcher =\=1, Fletcher =\= 5, abs(Fletcher - Cooper) =\= 1, miller(Miller), Miller > Cooper, smith(Smith), abs(Smith - Fletcher) =\= 1, sort([Baker,Cooper,Fletcher,Miller,Smith],[1,2,3,4,5]). % 568 inferences, 0.00 CPU in 0.03 seconds (0% CPU, Infinite Lips)
さらなる枝刈り
推論回数が4分の1以下に落ちているので，かなりの無駄が省けていることがわかる．毒を食らわば皿をまでと，もう少しがんばったのが以下のコード．between/3の段階で不要な枝を刈り，制約条件の順番も変えてみた．
baker(N) :- between(1,4,N). cooper(N) :- between(2,4,N). fletcher(N) :- between(2,4,N). miller(N) :- between(2,5,N). smith(N) :- between(1,5,N). solve(Baker,Cooper,Fletcher,Miller,Smith) :- cooper(Cooper), fletcher(Fletcher), abs(Fletcher - Cooper) =\= 1, smith(Smith), abs(Smith - Fletcher) =\= 1, miller(Miller), Miller > Cooper, baker(Baker), sort([Baker,Cooper,Fletcher,Miller,Smith],[1,2,3,4,5]). % 117 inferences, 0.00 CPU in 0.02 seconds (0% CPU, Infinite Lips)
かなり推論回数は減ったが，こうなってくると宣言的プログラミングという感じがあまりしなくなってくるのが悲しい．
順列を使う
やっぱり，「異なる階に住んでいる」というところで最初に枝刈りしちゃうのが筋なんじゃないの，と思い直して書いたのが以下のプログラム．
solve(Baker,Cooper,Fletcher,Miller,Smith) :- permutation([1,2,3,4,5],[Baker,Cooper,Fletcher,Miller,Smith]), Baker =\= 5, Cooper =\=1, Fletcher =\=1, Fletcher =\= 5, Miller > Cooper, abs(Smith - Fletcher) =\= 1, abs(Fletcher - Cooper) =\= 1. % 73 inferences, 0.00 CPU in 0.00 seconds (?% CPU, Infinite Lips)
ゴールの順序を変えると推論回数はまだ減らせるけど，それはもうしたくない．
だけど，よく考えると順列を使っちゃうところが宣言的ではないかも．Howを書いてしまっているかな，やっぱり…．
それはともかく，これをSchemeに翻訳しようとしてはまってしまったのだが，その話はまた日を改めて書く．
