F#で shift/reset プログラミング。限定継続(風)モナドで四天王問題を解く。
発売されてすぐにPSVitaのP4Gをダウンロードしたのだが、どちらかというとエヴィディ・ヤングライフ・VB6♪な生活を送っていてなかなかプレイする暇がなくてつらい。今日はGoAzureのゆーすと見たり、この記事をこしらえていたりな休日を過ごしていましたが、皆さんいかがお過ごしでしょうか。
限定継続と shift/resetプログラミング
少し前に書籍「Scala実践プログラミング」のChapter10-2 継続のところ読んでいて、限定継続面白いなー shift/reset プログラミング面白いなーと思っていたので、shift/reset プログラミングについて検索してみました。すると、書籍「プログラミングの基礎」でも有名な、お茶の水女子大学の浅井健一氏の「shift/reset プログラミング入門」が出てきました。いきなり当たりを引いた!今日のおれはツイてるな!(テッテレー)と言う感じで、こちらとてもわかりやすくて素晴らしい資料です。関数型プログラミングや限定継続に興味のある方はぜひご一読を。Scalaでは限定継続のサポートにより、以下のように shift/resetプログラミングをすることができます。
// result: 11 reset { shift { k: (Int=>Int) => k(10) } + 1 }
継続を限定しているreset部分について、shiftでその継続を取り出して k に束縛していて、 その k に 10 を適用することによって、1が加算されるので、結果は11になります。限定継続ってなんぞ?これの何が嬉しいのかわからないだって?まぁまぁそうおっしゃらずに。とりあえず「shift/reset プログラミング入門」を読みましょう。話はそれから。
ところで、Scala 2.8からサポートされたらしい限定継続ですが、F#にはいまのところそのような機能はないですし今後もサポートされる可能性は低そうです。でも、F#でちょっと真似してみたくなるよね。 shift/reset プログラミングちょっとあこがれちゃうよね。ということで、限定継続(風)モナドを作って F#でshift/reset プログラミングの雰囲気を感じてみましょう。
限定継続(風)モナド
ここで示すモナドはまぎれもなくモナドであるし、限定継続を意識した shift/reset なスタイルでプログラミングをすることができるようになるけど、いわゆるcall/cc的なことはしていませんので厳密には限定継続とは言えないので、限定継続(風)であるということに注意してください。F#でのモナド表現には、コンピューテーション式および、とてもCoolなライブラリFSharpxを利用しました。namespace Monad.DCont // 限定継続(風)モナド [<AutoOpen>] module DCont = open FSharpx type DCont<'a,'b,'c> = DCont of (('c -> 'a) -> 'b) let dcontreturn x = fun k -> k x let shift f = fun k -> f (fun s -> dcontreturn <| k s) id type DContBuilder() = member this.Return(x) = dcontreturn x member this.ReturnFrom(m) = m member this.Bind(m, bind) = fun k -> m <| fun s -> bind s k member this.Zero() = shift(fun _ -> id) member this.Combine(c1, c2) = this.Bind(c1, fun _ -> c2) member this.Delay(f) = f() member this.For(seq, f) = Seq.fold (fun cc elem -> this.Combine(cc, f elem)) (f <| Seq.head seq) <| Seq.skip 1 seq let reset = DContBuilder() let runDCont (f) = f id open Operators let inline returnM x = returnM reset x let inline (>>=) m f = bindM reset m f let inline (=<<) f m = bindM reset m f let inline (<*>) f m = applyM reset reset f m let inline ap m f = f <*> m let inline map f m = liftM reset f m let inline (<!>) f m = map f m let inline lift2 f a b = returnM f <*> a <*> b let inline ( *>) x y = lift2 (fun _ z -> z) x y let inline ( <*) x y = lift2 (fun z _ -> z) x y let inline (>>.) m f = bindM reset m (fun _ -> f) let inline (>=>) f g = fun x -> f x >>= g let inline (<=<) x = flip (>=>) x let dcont f = fun x -> returnM <| f x let shift' k = fun x -> reset { let! a = k x return a}
モナド則の確認とか
namespace MonadicRetry.Test open System [<AutoOpen>] module Tests = open NUnit.Framework open FsUnit open Monad.DCont [<TestFixture>] type ``モナド関連確認`` () = let x = 1 let m = reset { return 8 } let f x = reset { return 4 + x } let g x = reset { return 3 * x } let assertEqual (left, right) = reset {let! a1 = left let! a2 = right let r = (a1 |> should equal (a2)) printfn "%s" (sprintf "%d = %d , Result :%b" a1 a2 ((a1) = (a2))) return fun () -> 0} |> runDCont |> ignore let (==) left right = assertEqual (left, right) [<Test>] // モナド則1: return x >>= f == f x member test.``01.モナド則1`` () = returnM x >>= f == f x [<Test>] // モナド則2: m >>= return == m member test.``02.モナド則2`` () = let m' = m >>= returnM m' == m [<Test>] // モナド則3: (m >>= f) >>= g == m >>= (\x -> f x >>= g) member test.``03.モナド則3`` () = (m >>= f) >>= g == (m >>= (fun x -> f x >>= g)) // Functor(関手) [<Test>] //fmap id == id member test.``04.関手:functor1`` () = map id m == m [<Test>] //fmap (f.g) == fmap f . fmap g member test.``05.関手:functor2`` () = let f x = x * 2 let g x = x + 2 m |> map (f >> g) == (m |> (map f >> map g)) [<Test>] // fmap :: (a -> b) -> f a -> f b // fmap f m == m >>= return . f member test.``06.関手:functor3`` () = let f x = x * 2 (map f m) == (m >>= (f >> returnM)) // アプリカティブ: f <!> m1 <*> m2 == m1 >>= fun x -> m2 >>= fun y -> return f x y [<Test>] member test.``07.アプリカティブ:applicative1`` () = let f x y = x * 2 + y * 2 let m1 = reset { return 6 } let m2 = reset { return 9 } f <!> m1 <*> m2 == reset { let! a = m1 let! b = m2 return f a b } [<Test>] member test.``08.アプリカティブ:applicative2`` () = let f x y z = x * 2 + y * 2 - z let m1 = reset { return 6 } let m2 = reset { return 9 } let m3 = reset { return 20 } f <!> m1 <*> m2 <*> m3 == reset { let! a = m1 let! b = m2 let! c = m3 return f a b c} // Kleisli圏 [<Test>] member test.``09.クライスリ圏:kleisli composition1`` () = let x = 10 let f x = if x > 5 then reset { return "hello" } else reset { return "world" } let g x = if x = "hello" then reset { return 777 } else reset { return 0 } (f x >>= g) == (f >=> g <| x) // nunit-gui-runner let main () = NUnit.Gui.AppEntry.Main([|System.Windows.Forms.Application.ExecutablePath|]) |> ignore main ()
ホンモノの限定継続モナドは、きっと腕の立つF#マスター達が実装してくれるんじゃないかな。期待しましよう。
限定継続(風)モナドを利用してみる
さっそく利用してみる。さきほどのScalaの限定継続の例を、限定継続(風)モナドをつかって、F#で書いてみます。
reset {let! a = shift(fun k -> k 10) return a + 1 } |> runDCont |> printfn "%d"
意図通りに、11って出力される。コンピューテーション式でモナドを表現しているので、根本的には違うものの割とScalaと似たようなスタイルで記述できていい感じ。なんとなく雰囲気が醸し出せているね。雰囲気重視だよ!!!
限定継続(風)モナドで四天王問題
元ネタ
Scalaの限定継続で四天王問題を解いてみた - papamitra
http://d.hatena.ne.jp/papamitra/20100912/continuations
おお、あの四天王問題ですか。限定継続でAbmへの応用とかって面白いですね。
四天王問題
A「Dがやられたようだな…」B「ククク…奴は我ら四天王の中でも最弱…」C「私はBよりも弱い…」A「そして私は最強ではない…」B「四天王の中に私よりも弱いものが最低でも二人いる…」C「私はAよりも強い…」 ※以上の条件から四天王を強い順に並べよ(5点)
これを限定継続(風)モナドでF#で書くとこう
namespace TheBigFourProblem module Program = open System open Monad.DCont open Monad.DCont.Amb let abcd () = reset { let numbers = [1;2;3;4] let! a = amb numbers let! b = amb numbers let! c = amb numbers let! d = amb numbers // 同じ強さではないことを仮定 do! distinct [a;b;c;d] |> require // A「Dがやられたようだな…」B「ククク…奴は我ら四天王の中でも最弱…」 do! d = 4 |> require // C「私はBよりも弱い…」 do! b < c |> require // A「そして私は最強ではない…」 do! a = 1 |> not |> require // B「四天王の中に私よりも弱いものが最低でも二人いる…」 do! (b = 1 || b = 2) |> require // C「私はAよりも強い…」 do! c < a |> require // ※以上の条件から四天王ABCDを強い順に並べよ(5点) printfn "%s" <| sprintf "A:%d,B:%d,C:%d,D:%d" a b c d } abcd () |> runDCont |> ignore
実行結果
A:3,B:1,C:2,D:4
open Monad.DCont.Amb ってなんぞ? 限定継続(風)モナドでAmbを利用するために以下のようなmoduleを作って利用しています。
namespace Monad.DCont module Amb = open System let rec amb list = reset { if List.isEmpty list then return! shift(fun _ -> returnM (List.empty)) else return! shift(fun k -> k (List.head list) |> ignore reset.Bind(amb (Seq.toList <| Seq.skip 1 (List.toSeq list)), k)) } let require p = reset { return! shift(fun k -> if (p) then (k ()) else shift(fun _ -> id)) } let distinct list = let rec proc list = match list with | x :: xs -> List.toArray xs |> fun a -> if (Array.IndexOf(a,x)) < 0 && proc(xs) then true else false | _ -> true proc list
元ネタ
Scalaの限定継続で四天王問題を解いてみた その2 - papamitra
http://d.hatena.ne.jp/papamitra/20100912/continuations2
もっと四天王問題!すこし難易度があがります。
A「Dがやられたようだな…」B「ククク奴は四天王でも最弱…」C「私はBよりも強い」A「私は最強ではないが最弱でもない」B「私はAより強いぞ」C「四天王NO.3は嘘つき」A「私とCとの実力差は離れている」 問:四天王を強い順に並べよ。但し正直者は真実、嘘つきは嘘しか言わないものとする。(100ポイント)
let abcd2 () = reset { let numbers = [1;2;3;4] let! a = amb numbers let! b = amb numbers let! c = amb numbers let! d = amb numbers let! at = amb [true;false] let! bt = amb [true;false] let! ct = amb [true;false] let! dt = amb [true;false] // 同じ強さではないことを仮定 do! distinct [a;b;c;d] |> require // // A「Dがやられたようだな…」B「ククク…奴は我ら四天王の中でも最弱…」 do! ((bt && d = 4) || (bt |> not && d = 4 |> not)) |> require // C「私はBよりも強い」 do! ((ct && c < b) || (ct |> not && b < c)) |> require // A「私は最強ではないが最弱でもない」 do! ((at && (a = 1 |> not && a = 4 |> not)) || (at |> not && (a = 1 || a = 4))) |> require // B「私はAより強いぞ」 do! ((bt && b < a) || (bt |> not && a < b)) |> require // C「四天王NO.3は嘘つき」 do! (c = 3 |> not) |> require do! ((ct && ((at |> not && a=3) || (bt |> not && b=3) || (dt |> not && d=3))) || (ct |> not && ((at && a=3) || (bt && b=3) || (dt && d=3)))) |> require // A「私とCとの実力差は離れている」 // 順位が隣合っていないと解釈する. do! ((at && (abs(a-c) = 1 |> not)) || (at |> not && (abs(a-c) = 1))) |> require // ※以上の条件から四天王ABCDを強い順に並べよ printfn "%s" <| sprintf "A:%A,B:%A,C:%A,D:%A" (a,at) (b,bt) (c,ct) (d,dt) } abcd2 () |> runDCont |> ignore
実行結果
A:(1, false),B:(4, false),C:(2, true),D:(3, false)
ちゃんと、四天王の強さの順番と、C以外は嘘つきであるという結果が導きだせましたね!
おまけ:ダイハード3のやつ
なんだか、非決定計算の問題を解くのが面白くなってきちゃったので、せっかくなので限定継続(風)モナドでどんどん解いていきます。まずは、ダイハード3で出題された3ガロンと5ガロンの容器で4ガロンを量るってやつ。いわゆる、水差し問題とゆーやつですね。
これは、わざわざプログラミングで解くまでもないなぞなぞレベルの問いですが、書いてみます。
namespace PitcherProblem module Program = open System open Monad.DCont open Monad.DCont.Amb // ダイハード3の 3ガロンと5ガロンの水差し問題 let maxa = 5 let maxb = 3 let geta state = fst state let getb state = snd state let private action = [ // Aを満杯にする fun state -> maxa, getb state; // Aを空にする fun state -> 0, getb state; // AからBへ移す fun state -> let a = geta state let b = getb state let w = maxb - b if a <= w then // 全部移しきった場合 0, a + b else // Aに水が残る場合 a - w, b + w; // Bを満杯にする fun state -> geta state, maxb; // Bを空にする fun state -> geta state, 0; // BからAへ移す fun state -> let a = geta state let b = getb state let w = maxa - a if b <= w then // 全部移しきった場合 a + b, 0 else // Aに水が残る場合 a + w, b - w; ] let private solve answer = let rec solve' n answer move = let x = (List.length move) - 1 let prev = move.Item x reset { if n = 0 && prev |> fst = answer || prev |> snd = answer then return! shift(fun k -> k move) else let! act = amb action let newstate = act prev let contains s list = List.exists(fun x -> x = s) list if prev = newstate || contains newstate move then return! shift(fun _ -> returnM move) else return! solve' (n-1) answer (move@[newstate]) } let m = List.length action solve' m answer [(0,0)] let pitcherProblem answer = let result = ref [] reset { let! xs = solve answer result := !result@[xs] return xs } |> runDCont |> ignore !result pitcherProblem 4 |> fun x -> x |> Seq.iter (printfn "%A") printfn "%s" <| sprintf "%d通り" x.Length
おまけ:地図の塗り分け
いかなる地図も、隣接する領域が異なる色になるように塗るには4色あれば十分DAZEという、いわゆる四色定理とゆーやつ。
実際に塗り分けしてみよう。
namespace ColorMapProblem module Program = open System open Monad.DCont open Monad.DCont.Amb let colorMapProblem () = reset { let colors = ["red";"yellow";"green";"blue"] let! p = amb colors // Portugal:ポルトガル let! e = amb colors // Spain:スペイン let! f = amb colors // France:フランス let! b = amb colors // Belgium:ベルギー let! h = amb colors // Holland:オランダ let! g = amb colors // Germany:ドイツ let! l = amb colors // Luxemb:ルクセンブルク let! i = amb colors // Italy:イタリア let! s = amb colors // Switz:スイス let! a = amb colors // Austria:オーストリア let notcontains s list = List.exists(fun x -> x = s) list |> not // ポルトガルは、[スペイン]の色と違うよ do! notcontains p [e] |> require // スペインは、[フランス;ポルトガル]の色と違うよ do! notcontains e [f;p] |> require // 以下コメント略 do! notcontains f [e;i;s;b;g;l] |> require do! notcontains b [f;h;l;g] |> require do! notcontains h [b;g] |> require do! notcontains g [f;a;s;h;b;l] |> require do! notcontains l [f;b;g] |> require do! notcontains i [f;a;s] |> require do! notcontains s [f;i;a;g] |> require do! notcontains a [i;s;g] |> require // 4色で塗り分ける組み合わせ printfn "%s" <| sprintf "Portugal:%s,Spain:%s,France:%s,Belgium:%s,Holland:%s,Germany:%s,Luxemb:%s,Italy:%s,Switz:%s,Austria:%s" p e f b h g l i s a } colorMapProblem () |> runDCont |> ignore
想像以上に塗り分けれるね!
おまけ:狼とヤギとキャベツ
いわゆる川渡り問題。
オオカミとヤギを連れキャベツを持った農夫が川岸にいる。川にはボートがあるが農夫の他には動物一頭かキャベツ一玉しか乗せられない。農夫がいなければオオカミはヤギを襲うし、ヤギはキャベツを食べてしまう。すべてを無事に対岸に渡すにはどうしたらよいか?
namespace FarmerGoatWolfCabbage module Program = open System open Monad.DCont open Monad.DCont.Amb type Position = | Left of Kind | Right of Kind and Kind = | Farmer | Goat | Wolf | Cabbage let swap = function | Left x -> Right(x) | Right x -> Left(x) let init = Left(Farmer), Left(Goat), Left(Wolf), Left(Cabbage) let ans = Right(Farmer), Right(Goat), Right(Wolf), Right(Cabbage) let (==) x y = match x,y with | Left _, Left _ -> true | Right _, Right _ -> true | _,_ -> false let private action = [ // 農夫のみ移動 fun state -> let f, g, w, c = state swap f, g, w, c; // 農夫とヤギ fun state -> let f, g, w, c = state swap f, swap g, w, c; // 農夫と狼 fun state -> let f, g, w, c = state swap f, g, swap w, c; // 農夫とキャベツ fun state -> let f, g, w, c = state swap f, g, w, swap c; ] let safe state = let safegote = let f,g,w,c = state if f == g then true else g == w |> not let safecabbage = let f,g,w,c = state if f == c then true else g == c |> not safegote && safecabbage let private solve () = let rec solve' move = let x = (List.length move) - 1 let prev = move.Item x reset { if prev = ans then return! shift(fun k -> k move) else let! act = amb action let newstate = act prev let contains s list = List.exists(fun x -> x = s) list if prev = newstate then return! shift(fun _ -> returnM move) elif contains newstate move then return! shift(fun _ -> returnM move) elif (safe newstate |> not) then return! shift(fun _ -> returnM move) else return! solve' (move@[newstate]) } let m = List.length action solve' [init] let farmerGoatWolfCabbageProblem () = let result = ref [] reset { let! a = solve () result := a return a } |> runDCont |> ignore !result farmerGoatWolfCabbageProblem () |> fun x -> x |> Seq.iter(fun x -> let f,g,w,c = x let result = [f;g;w;c] printf "[" result |> Seq.filter (fun x -> x |> function | Left _ -> true | _ -> false) |> Seq.map (fun x -> x |> function | Left x -> x | Right x -> x) |> Seq.iter (printf "%A;" ) printf "] : " printf "[" result |> Seq.filter (fun x -> x |> function | Right _ -> true | _ -> false) |> Seq.map (fun x -> x |> function | Left x -> x | Right x -> x) |> Seq.iter (printf "%A;") printfn "]" )
実行結果
[Farmer;Goat;Wolf;Cabbage;] : [] [Wolf;Cabbage;] : [Farmer;Goat;] [Farmer;Wolf;Cabbage;] : [Goat;] [Wolf;] : [Farmer;Goat;Cabbage;] [Farmer;Goat;Wolf;] : [Cabbage;] [Goat;] : [Farmer;Wolf;Cabbage;] [Farmer;Goat;] : [Wolf;Cabbage;] [] : [Farmer;Goat;Wolf;Cabbage;]
わーい、無事に川を渡れたよ!
おまけ:順列と組み合わせ
今度はちょっと趣向を変えて。書いているうちに、だんだんshift/reset スタイルなプログラミングに慣れてきたかもな気がするよ!
namespace PermutationAndCombination module Program = open System open Monad.DCont open Monad.DCont.Amb let rec private selections n m lst result = let contains s list = List.exists(fun x -> x = s) list reset { if m = 0 || lst = [] then return! shift(fun k -> k result) else return! reset { let! x = amb [0..n-1] if contains (lst.Item x) result then return! shift(fun _ -> returnM result) else return! selections n (m-1) lst (result@[lst.Item x])} } // 順列 let permutations m lst = let n = List.length lst let result = ref [] reset { let! xs = selections n m lst [] xs.Length = m |> function | false -> () | true -> result := !result@[xs] return xs } |> runDCont |> ignore !result permutations 4 ['A'..'F'] |> fun x -> x |> Seq.iter (printfn "%A") printfn "%s" <| sprintf "%d通り" x.Length // 組み合わせ let combinations m (lst: 'a list) = let n = List.length lst let contains r sourece = sourece |> Seq.map (fun x -> (set x, set r) ||> Set.difference = Set.empty) |> Seq.exists id let result = ref [] reset { let! xs = selections n m lst [] contains xs !result |> function | true -> () | false -> result := !result@[xs] return xs } |> runDCont |> ignore !result combinations 4 ['A'..'F'] |> fun x -> x |> Seq.iter (printfn "%A") printfn "%s" <| sprintf "%d通り" x.Length
なんか、おまけの方が多くなっちゃいましたね。てへぺろ☆(・ω<)
Amb以外の応用例も書くつもりでしたが、積みゲー消化したいのでそれはまた別の機会に。たぶん。