非決定性計算

Haskell Monad

なんだか毎回続く、とか書きながら違うことを書いているような気がする。
今回は、リストモナドを使うと非決定性計算が記述できるという話。
また微妙に脇にそれる。
そういやSICPにamb評価器があったよなぁとか、
それをすんなりかけそうだなぁとか。


というわけで、SICPの4.3章より、非決定性計算のところ。
詳しくはそちらを参考に…

(define (prime-sum-pair list1 list2)
  (let *1

list-element-ofは、与えられたリストの要素のどれか、を返す。
この辺が非決定。
requireは与えられた式が偽のときリジェクトするような関数。
で、全体では、与えられたリスト2つから一つずつ選んだ
要素の和が素数になるようなもののどれか、を返す(文章がなんかおかしい…)。
どれか、といっているけど、実際にはシステマティックに調べられる
わけなので、その辺は心配いらない。
というか、こんな書き方でrequireとかが継続とかを使って
バックトラックさせたり、Schemeはやっぱりすごいなぁ…


で、同じようなことをHaskellでは、
遅延評価+モナドでできるっぽいということに最近ふと気が付いた。

primSumPair l1 l2 = do
  a <- l1
  b <- l2
  guard $ prime (a+b)
  return (a,b)

list-element-ofが <- になっている。
Scheme版でも非決定性な値の候補はリストで表しているので、
(まぁ、当たり前といえば当たり前だけど…)
Haskellでもリストを。
requireはguardでいける。偽で呼び出せばfailになるのか。


せっかくなので、ambEvalっぽい物を。
Scheme版よりはるかにしょぼいけど…
解を一つずつ表示する機能のみ。

ambEval []     = putStrLn ";;; There are no more values."
ambEval (x:xs) = do
  putStrLn ";;; Amb-Eval value:"
  print x
  putStrLn ";;; Amb-Eval input:"
  str <- getLine
  if str == "try-again" then ambEval xs
    else return ()

で、このようにすると

main = ambEval $ primSumPair [1,3,5,8] [20,35,110]

こうなる。

;;; Amb-Eval value:
(3,20)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(3,110)
;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(8,35)
;;; Amb-Eval input:
try-again
;;; There are no more values.

このような例ではあまり面白くないので、
SICPにある例、論理パズルでも解かせてみる。

まず、問い。

Baker,Cooper,Fletcher,MillerとSmithは五階建てアパートの相異なる階に住んでいる。
・Backerは最上階に住んでいない。
・Cooperは最下階に住んでいない。
・Fletcherは最上階にも最下階にも住んでいない。
・MillerはCooperよりも上の階に住んでいる。
・SmithはFletcherの隣の階に住んでいない。
・FletcherはCooperの隣の階に住んでいない。
それぞれの住んでいる階は?

Haskellでの実装例。
というか、本文中にてSchemeで書かれているものを
そのままモナドに変換しただけ…

multipleDwelling = do
  backer   <- [1,2,3,4,5]
  cooper   <- [1,2,3,4,5]
  fletcher <- [1,2,3,4,5]
  miller   <- [1,2,3,4,5]
  smith    <- [1,2,3,4,5]

  guard $ distinct [backer,cooper,fletcher,miller,smith]
  guard $ backer   /= 5
  guard $ cooper   /= 1
  guard $ fletcher /= 5
  guard $ fletcher /= 1
  guard $ miller > cooper
  guard $ abs (smith -  fletcher) /= 1
  guard $ abs (fletcher - cooper) /= 1

  return [("backer"  ,  backer)
         ,("cooper"  ,  cooper)
         ,("fletcher",fletcher)
         ,("miller"  ,  miller)
         ,("smith"   ,   smith)]

distinctの定義は、

distinct [] = True
distinct (x:xs) = all (/=x) xs && distinct xs

こんな感じ。
これを実行すると

;;; Amb-Eval value:
[("backer",3),("cooper",2),("fletcher",4),("miller",5),("smith",1)]
;;; Amb-Eval input:
try-again
;;; There are no more values.

結構すんなりと。


ついでに練習問題でも解いてみる。


問題4.38 SmithとFletcherが隣り合う階に住まないという制限を取り除いたときの解
(書き換えて実行するだけなので、略)


問題4.39 制限の順序は解に影響するか?あるいは解を見出す時間に影響するか?
解そのものには影響しない。
(ベン図でも書けば自明か)
解を見出す時間は、多くの候補が削られる制限を先においたほうが短くなる。
(証明は…ここは余白が少なすぎる)


問題4.40 人の階への割り当ての組は、階の割り当てが相異なるという制約を課す前と後ではいくつか?および、制約での候補の除外を行わない、はるかに高効率な非決定性計算を示せ。
制約を課す前……5^5=3125個
制約を課した後…5P5=120個
(結構違うのね)


高効率な計算

multipleDwelling2 = do
  backer   <- [1,2,3,4]
  cooper   <- [2,3,4,5]   \\ [backer]
  fletcher <- [2,3,4]     \\ [backer,cooper]
  guard $ abs (fletcher - cooper) /= 1
  miller   <- [1,2,3,4,5] \\ [backer,cooper,fletcher]
  guard $ miller > cooper
  smith    <- [1,2,3,4,5] \\ [backer,cooper,fletcher,miller]
  guard $ abs (smith -  fletcher) /= 1

  return [("backer"  ,  backer)
         ,("cooper"  ,  cooper)
         ,("fletcher",fletcher)
         ,("miller"  ,  miller)
         ,("smith"   ,   smith)]

(こうかな)


問題4.41 上記問題を解く通常のSchemeプログラムを示せ
(略…順列生成してフィルタでもすりゃいいでしょう)


問題4.42 次の「うそつきパズル」を解け

5人の女子生徒が試験を受けている。
(…略…)
それぞれ正しいことと正しくないことを一つずつ述べている。
それぞれの順位は?
・Betty 「Kittyは試験が二番で、私は三番でした」
・Ethel 「私がトップと聞いて嬉しいでしょう。Joanが二位でした。」
・Joan 「私は三番でした。かわいそうなEthelはびりでした。」
・Kitty 「私は二番になりました。Maryは四番でしかありませんでした。」
・Mary 「私は四番でした。トップの座はBettyが取りました。」

プログラムは素直に書いて、

phillips = do
  betty <- [1,2,3,4,5]
  ethel <- [1,2,3,4,5]
  joan  <- [1,2,3,4,5]
  kitty <- [1,2,3,4,5]
  mary  <- [1,2,3,4,5]

  guard $ distinct [betty,ethel,joan,kitty,mary]
  guardOne (kitty==2) (betty==3)
  guardOne (ethel==1) (joan ==2)
  guardOne (joan ==3) (ethel==5)
  guardOne (kitty==2) (mary ==4)
  guardOne (mary ==4) (betty==1)

  return [("betty",betty)
         ,("ethel",ethel)
         ,("joan" , joan)
         ,("kitty",kitty)
         ,("mary" , mary)]

guardOne a b = guard $ a && not b || not a && b

実行結果

;;; Amb-Eval value:
[("betty",3),("ethel",5),("joan",2),("kitty",1),("mary",4)]
;;; Amb-Eval input:
try-again
;;; There are no more values.

うむむ…かわいそうなEthel…


そろそろ疲れてきたので、この辺で。

*1:a (list-element-of list1) (b (list-element-of list2))) (require (prime? (+ a b))) (list a b