すごいH本の素朴な確率モナド
年末年始の連休から中五日あっての三連休で、正月ボケをぶり返してしまいそうな今日この頃ですが、いかがお過ごしでしょうか。
すごいH本こと、書籍「すごいHaskellたのしく学ぼう！」の最後のほう、第１４章「もうちょっとだけモナド」の 14.8 (P356)にて、素朴な確率モナドが紹介されています。
- 作者: Miran Lipovača,田中英行,村主崇行
- 出版社/メーカー: オーム社
- 発売日: 2012/05/23
- メディア: 単行本（ソフトカバー）
- 購入: 25人 クリック: 580回
- この商品を含むブログ (51件) を見る
普通、モナドは作りたいと思って作るものではありません。むしろ、とある問題のある側面をモデル化した型を作り、後からその型が文脈付きの値を表現していてモナドのように振る舞うと分かった場合に、Monad のインスタンスを与える場合が多いです。
というのが印象的で。ふむふむ確かになるほどなあという感じです。
ぼけーっと、ただ連休をだらだらと過ごすだけなのもなんなので、正月ボケのリハビリを兼ねて何か書いておこうかなということで、これを F# で書いてみようと思います。
確率を表現するための有理数を表す型
数学では通常、確率はパーセント（％）ではなく、0 から 1 までの実数で表します。確率が 0 ということは絶対にありえないということであり、確率が 1 というのは確実に起こるということを意味します。確率を浮動小数点で表すのも間違いではないのですが、どうしても精度が落ちてしまう。そこで Haskell では、Rationalという分数を表すために最適な有理数を表す型があり、例えば ４分の１は、1%4 のように、分子と分母は % で区切って表現することができる。では、F# はどうでしょう。標準には用意されていませんが、F# では、F# PowerPack という追加ライブラリにて数学に関する様々な機能が提供されています。これを導入することで分数の表現に対応することができます(NuGetで簡単に導入することもできます)。有理数を表すことができる BigRational という型が定義されているので、それを使えます。BigRational は、Nリテラルを用いて表現することができ、４分の１は、1N/4N というように表せます。
F# で素朴な確率モナド
Haskellでの実装例は書籍や(Learn You a Haskell for Great Good! - For a Few Monads More)に出ている通りなので、そちらを参照されたい。BigRational型と FSharpx を使って、F# で素朴な確率モナドをとりえず実装してみる。
namespace FSharpx.Monad // 素朴な確率モナド module Probability = let probMap f m = List.map (fun (x,p) -> (f x, p)) m type ProbBuilder() = member this.ReturnFrom(x) = x member this.Return(x) = [x,1N/1N] member this.Bind(m, f) = let flatten xs = let concatMap f m = List.concat( List.map (fun x -> f x) m ) let multAll (innerxs,p) = List.map (fun (x,r) -> (x, p*r)) innerxs concatMap multAll xs flatten (probMap f m) member this.Zero () = [] let prob = new ProbBuilder() open FSharpx open Operators let inline returnM x = returnM prob x let inline (>>=) m f = bindM prob m f let inline (=<<) f m = bindM prob m f let inline (<*>) f m = applyM prob prob f m let inline ap m f = f <*> m let inline map f m = liftM prob f m let inline (<!>) f m = map f m let inline lift2 f a b = returnM f <*> a <*> b let inline lift3 f a b c = returnM f <*> a <*> b <*> c 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 prob m (fun _ -> f) let inline (>=>) f g = fun x -> f x >>= g let inline (<=<) x = flip (>=>) x
使ってみる。３枚のコイン（イカサマコインが１つ混入している）がすべて裏が出る確率を出す。
module Program = open System open FSharpx.Monad.Probability type Coin = Heads | Tails let coin = [(Heads,1N/2N); (Tails,1N/2N)] let loadedCoin = [(Heads,1N/10N); (Tails,9N/10N)] let flipThree = prob { let! a = coin let! b = coin let! c = loadedCoin return List.forall (function |Tails->true |_->false) [a;b;c] } flipThree |> printfn "%A"
実行結果
[(false, 1/40N); (false, 9/40N); (false, 1/40N); (false, 9/40N); (false, 1/40N); (false, 9/40N); (false, 1/40N); (true, 9/40N)]
確率モナドによって、３枚とも裏が出る確率は、４０分の９であると導きだすことができた。すごいH本と同じ結果になりましたね。めでたしめでたし。
続いて、6面のサイコロを２回振ったとき、その出目の合計値ごとの確率を出してみる。
let d sides = [for i in [1 .. sides] -> (i, 1N/ BigRational.FromInt(sides))] let dice = d 6 let diceTwoSum = prob { let! a = dice let! b = dice return a+b } diceTwoSum |> printfn "%A"
実行結果
[(2, 1/36N); (3, 1/36N); (4, 1/36N); (5, 1/36N); (6, 1/36N); (7, 1/36N); (3, 1/36N); (4, 1/36N); (5, 1/36N); (6, 1/36N); (7, 1/36N); (8, 1/36N); (4, 1/36N); (5, 1/36N); (6, 1/36N); (7, 1/36N); (8, 1/36N); (9, 1/36N); (5, 1/36N); (6, 1/36N); (7, 1/36N); (8, 1/36N); (9, 1/36N); (10, 1/36N); (6, 1/36N); (7, 1/36N); (8, 1/36N); (9, 1/36N); (10, 1/36N); (11, 1/36N); (7, 1/36N); (8, 1/36N); (9, 1/36N); (10, 1/36N); (11, 1/36N); (12, 1/36N)]
ここまでがすごいH本で書かれている範囲でできること。これから先については、読者への演習問題としている。
上記の実行結果を見てわかるように、確率の結果がまとまっておらず、バラバラに出力されていて結果の内容がわかりにくい。これはひどい。
できれば、
[(false, 31/40N); (true, 9/40N)]
とか
[(2, 1/36N); (3, 1/18N); (4, 1/12N); (5, 1/9N); (6, 5/36N); (7, 1/6N); (8, 5/36N); (9, 1/9N); (10, 1/12N); (11, 1/18N); (12, 1/36N)]
というように、結果が一致する事象の確率については１つにまとめて出力してくれるのが分かり易くて理想だよね、と。せっかくなので、この演習問題をやってみましょう。
とりあえず、結果が一致する事象の確率を１つにまとめてみる
あまり何も考えずに、とりあえず実装してみた版。
let rec merge (k,p) xs = xs |> function | [] -> [] | (k,p)::kps -> kps |> function | [] -> [(k,p)] | (k',p')::kps' -> if k = k' then (k,p+p')::(merge (k,p) kps') else (k,p)::(merge (k',p') kps) let agglomerate f pd = let xs : ('b * BigRational) list = (probMap f pd) |> List.sort List.foldBack merge pd xs let agg pd = agglomerate id pd
使ってみる。
let flipThree = prob { let! a = coin let! b = coin let! c = loadedCoin return List.forall (function |Tails->true |_->false) [a;b;c] } flipThree |> agg |> printfn "%A" //let flipThree2 = agg <| lift3 (fun a b c -> List.forall (function |Tails->true |_->false) [a;b;c]) coin coin loadedCoin //flipThree2 |> printfn "%A"
実行結果
[(false, 31/40N); (true, 9/40N)]
使ってみる。
let d sides = [for i in [1 .. sides] -> (i, 1N/ BigRational.FromInt(sides))] let dice = d 6 let diceTwoSum = prob { let! a = dice let! b = dice return a+b } diceTwoSum |> agg |> printfn "%A" //let diceTwoSum2 = agg <| lift2 (+) dice dice //diceTwoSum2 |> printfn "%A"
実行結果
[(2, 1/36N); (3, 1/18N); (4, 1/12N); (5, 1/9N); (6, 5/36N); (7, 1/6N); (8, 5/36N); (9, 1/9N); (10, 1/12N); (11, 1/18N); (12, 1/36N)]
うん。とりあえず動いているね。これで一応目的は達成できているのだけど、なんだか冗長な感じがするしカッコ悪い。俺が欲しいのコレジャナイ感がぱない。もっとシンプルに行きたい。
結果が一致する事象の確率を１つにまとめる（改訂版）
どのあたりがコレジャナイ感を出しているのか。落ち着いて先ほどの実装をよく見てみてみよう。
let rec merge (k,p) xs = xs |> function | [] -> [] | (k,p)::kps -> kps |> function | [] -> [(k,p)] | (k',p')::kps' -> if k = k' then (k,p+p')::(merge (k,p) kps') else (k,p)::(merge (k',p') kps) let agglomerate f pd = let xs : ('b * BigRational) list = (probMap f pd) |> List.sort List.foldBack merge pd xs let agg pd = agglomerate id pd
List.sort でソートしたリストと、ソートする前のリストとを比較して、再帰でマージしながら結果をまとめあげる実装となっている。
そもそもここでやりたいことは、集合として確率の結果をまとめ上げたいということ。集合を扱いたい場合、F# では set が使える。また、コレジャナイ実装では、List.foldBack で入力要素を順々に受け取りながら marge 関数で確率の和を求めながら結果の状態を順次更新していっているが、set を使って集合化することができれば、集合の要素ごとの確率の和をそれぞれ算出してゆくだけでよいことになる。あ、それって List.reduce 使えばいんじゃね？ となる。
ところで、List.reduce とはなんだったのか。例えば、List.foldを用いてintのリストの和を求める場合を思い出してみよう。
List.fold (+) 0 [1;2;3]
のように書けるのでした。育てる種となる初期値の 0 を与えて、次々にリストを畳み込むことにより、結果 6 が得られる。
ここで、育てる種となる初期値の 0 を与えずにリストの和を求めるには、育てる種の初期値としてリストの最初の要素を採用すればよい。最初の要素と次の要素によって演算を開始するという処理を行えばよいことなる。
こう書く事ができる。
List.reduce (+) [1;2;3]
そう、List.fold が簡易化されたものが List.reduce ということだった。
ということで集合を扱える set と 育てる種を必要としない List.reduce を用いて実装すると次のように書ける。
let merge f (a,x) (b,y) : 'a * BigRational = f a b, x + y let agglomerate f pd = let d = pd |> List.map(fun (x,_) -> x) |> set |> Set.toList List.map (fun x -> List.filter(fun (y,b) -> x = y) pd |> List.reduce (merge f)) d let agg pd = agglomerate (fun _ x -> x) pd
ほむ。だいぶシンプルになりました。これはリハビリをして正解でしたね。
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>] // モナド則１： return x >>= f == f x member test.``01.モナド則1`` () = returnM x >>= f == f x [<Test>] // モナド則２: m >>= return == m member test.``02.モナド則2`` () = let m' = m >>= returnM m' == m [<Test>] // モナド則３: (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以外は嘘つきであるという結果が導きだせましたね！
おまけ：ダイハード３のやつ
なんだか、非決定計算の問題を解くのが面白くなってきちゃったので、せっかくなので限定継続（風）モナドでどんどん解いていきます。まずは、ダイハード３で出題された３ガロンと５ガロンの容器で４ガロンを量るってやつ。いわゆる、水差し問題とゆーやつですね。
これは、わざわざプログラミングで解くまでもないなぞなぞレベルの問いですが、書いてみます。
namespace PitcherProblem module Program = open System open Monad.DCont open Monad.DCont.Amb // ダイハード３の 3ガロンと５ガロンの水差し問題 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以外の応用例も書くつもりでしたが、積みゲー消化したいのでそれはまた別の機会に。たぶん。
F#で簡素なモゲマスコンプガチャシミュレータ
椎名林檎「自由へ道連れ」をヘビロテしすぎて脳内無限ループしている今日この頃ですが、皆様いかがお過ごしでしょうか。
時事ネタとしては旬を逃した感じですが、簡素なコンプガチャシミュレータをF#で書いてみました。
とは言っても、この記事で伝えたいことはコンプガチャの確率がどうのですとか、実社会におけるコンプガチャの問題点がどうのとかいうような話題を扱うものではなく、安直にモナド則を満たさないコンピューテーション式を作ってしまうよりかは、Identityモナド(恒等モナド)を使ってプログラミングをした方が、見通しが良くモジュール性の高いコードを書くことができるかもしれないよ、という話題を提供します。割とどうでもいい話題ですね。未だガラケーユーザーであり、スマホやソーシャルゲーとはほとんど縁のない私ですが（もちろんモゲマスもやったことない）、気が向いたのでちょっと書いてみました。なお、モゲマスおよびFSharpxのステマではありません。
シミュレートするコンプガチャの仕様
まずはシミュレートするコンプガチャの仕様について簡単に確認しておきましょう。今回実装してみるのは、モゲマスことモバゲー『アイドルマスター シンデレラガールズ』のコンプガチャ「パジャマパーティー」に近いコンプガチャのシミュレートを目的としてみます。
Google先生に聞いてきた モゲマス 「パジャマパーティー」コンプガチャの概要
時折行われる課金ガチャのイベント企画。1ガチャあたり300円を支払って利用するガチャです。1回に1枚のアイドルカードが得られます。実際の支払いは「モバコイン」ですが、モバコインは100G＝100円で購入して利用するため、便宜上こちらではそのまま円とします。イベント期間中以下の「レア」パジャマアイドルが確率テーブルに5枚追加され、その5枚を全て集めると、特典として限定「Sレア」カード「［眠れる姫君］星井美希」を獲得できるというもの。
コンプ対象パジャマアイドル
・[パジャマパーティー]緒方智絵里 コスト12 攻2880 守1600 キュート攻中アップ
・[パジャマパーティー]間中美里 コスト08 攻1240 守1440
・[パジャマパーティー]黒川千秋 コスト10 攻1860 守1560 クール攻中アップ
・[パジャマパーティー]川島瑞樹 コスト09 攻1400 守1680
・[パジャマパーティー]若林智香 コスト12 攻1600 守2680 パッション守中アップ
なお、バンナムによる公式の発表はないが、いずれかのパジャマアイドルが出現する確率は12%程度とのこと。
※ガチャのセット販売も行われているが、ここでは1回ずつガチャを行うこととする。
※なお、ネットで適当に拾ってきた情報のため正確ではない可能性あり。
内部の実装の詳細はわかりませんが、「今すぐモゲマスＰすべてにＳレアを授けてみせろッ！ ver. 0.141.33」というシミュレータが既にあるようです。
http://mugenmasakazu.plala.jp/cgi-bin/nijiuraIDOLMASTER/mogemaskillyourself.cgi
なお、コンプガチャがどうして危険と言われているのかの理由については、「コンプガチャの確率マジックを中学生にも分かるように説明するよ - てっく煮ブログ」の解説がわかりやすい。わたしが中学生にも分かるように説明するなら、例えばモンハンの素材であるところの「逆鱗(出現率2%)」が5種類あったとして、それらすべてを揃えないと作れない武器があったとき、それにかかる時間を想像してみると、コンプガチャへ挑む無謀さが割と想像しやすい、とか。欲しいと思う素材ほど出ないようになっているといわれる架空のシステム。いわゆる「センサー」の存在への疑い、とか。
簡素なコンプガチャシミュレータを愚直に書いてみる
まずは愚直に。細かいことは考えずにとりあえず実装してみたバージョン。
open System let tee x f = f x; x let (|>!) x f= tee x f let rand = new Random(DateTime.Now.Millisecond); type Rarity = |R of string |Other // ガチャアイテム let a,b,c,d,e,other = R("緒方智絵里"), R("間中美里"), R("黒川千秋"), R("川島瑞樹"), R("若林智香"), Other // コンプ let comp = [a;b;c;d;e] // コンプ対象が出る確率 let probability = 0.12 let shuffle source = let array = List.toArray source let rec loop i = i |> function | 1 -> () | _ -> let i = i - 1 let j = rand.Next(i) let temp = array.[i] array.[i] <- array.[j] array.[j] <- temp; loop i loop source.Length [for x in array do yield x] let completeGacha lst count total = let items = let dummy p = let e = ((float comp.Length) / p) |> int [for i in 1..(e-comp.Length) do yield Other] let target = comp@dummy probability target |> shuffle let gacha () = rand.Next(1, items.Length) |> fun i -> items.[i] let rec gacha' count total = let newitem = gacha () let current = count + 1 if List.exists (fun x -> x = newitem) comp |> not then (* でねぇ！！！*) gacha' current total elif List.forall (fun x -> x = newitem |> not) lst |> not then (* ダブりかよ...orz *) gacha' current total else (* よっしゃー！なんという引きの良さ！！！ *) lst@[newitem], current, (total + current), List.length (lst@[newitem]) = comp.Length gacha' count total let printGacha x = x |>! (fun (possession, n, total, complete) -> let g = sprintf "%d回：%d円 " n (300 * n) let sum = sprintf "合計%d円" (300 * total) let result = sprintf "%s" (if complete then "コンプ" else "未コンプ") printfn "%s %s %A %s" g sum possession result) let cut (a,b,c,d) = a,b,c completeGacha [] 0 0 |> printGacha |> cut |||> completeGacha |> printGacha |> cut |||> completeGacha |> printGacha |> cut |||> completeGacha |> printGacha |> cut |||> completeGacha |> printGacha |> cut |> fun _ -> printfn "［眠れる姫君］星井美希を手に入れた！" Console.ReadLine () |> ignore
ジェネリックもへったくれもない。いくら適当とはいえ愚直すぎて泣ける。
結果は当然実行ごとに毎回変わりますが、一応実行結果の例。
1回：300円 合計300円 [R "黒川千秋"] 未コンプ 8回：2400円 合計2700円 [R "黒川千秋"; R "緒方智絵里"] 未コンプ 38回：11400円 合計14100円 [R "黒川千秋"; R "緒方智絵里"; R "川島瑞樹"] 未コンプ 78回：23400円 合計37500円 [R "黒川千秋"; R "緒方智絵里"; R "川島瑞樹"; R "間中美里"] 未コンプ 108回：32400円 合計69900円 [R "黒川千秋"; R "緒方智絵里"; R "川島瑞樹"; R "間中美里"; R "若林智香"] コンプ ［眠れる姫君］星井美希を手に入れた！
1回目でレアカード"黒川千秋"を引き当てるという強運を発揮するも、2枚目のレア"緒方智絵里"を引き当てるには8回かかる。
そして、あらあらまあまあ最終的には合計69900円のぶっこみ。バンナムにかなり貢ぎましたな。
簡素なコンプガチャシミュレータをコンピューテーション式で
愚直にもほどがあるので、もうちょっとなんとかしてみましょう。
completeGacha [] 0 0 |> printGacha |> cut |||> completeGacha |> printGacha |> cut |||> completeGacha |> printGacha |> cut |||> completeGacha |> printGacha |> cut |||> completeGacha |> printGacha |> cut |> fun _ -> printfn "［眠れる姫君］星井美希を手に入れた！"
上記部分に着目すると、なんだか順々に関数を適用していく流れが見えます。なんだかコンピューテーション式にできそうです。
ということで、とりあえずコンピューテーション式にしてみる。
namespace Library1 [<AutoOpen>] module CompleteGacha = open System let tee x f = f x; x let inline (|>!) x f= tee x f let rand = new Random(DateTime.Now.Millisecond); let shuffle source = let array = List.toArray source let rec loop i = i |> function | 1 -> () | _ -> let i = i - 1 let j = rand.Next(i) let temp = array.[i] array.[i] <- array.[j] array.[j] <- temp; loop i loop (List.length source) [for x in array do yield x] let completeGacha comp d probability (lst:'a list) count total = let items = let dummy p = let e = ((float <| List.length comp) / p) |> int [for i in 1..(e - (List.length comp)) do yield d] let target = comp@(dummy probability) target |> shuffle let gacha () = let i = rand.Next(1, (List.length items)) items.[i] let rec gacha' count total = let newitem = gacha () let current = count + 1 if List.exists (fun x -> x = newitem) comp |> not then (* でねぇ！！！ *) gacha' current total elif List.forall (fun x -> x = newitem |> not) lst |> not then (* ダブりかよ...orz *) gacha' current total else (* よっしゃー！なんという引きの良さ！！！ *) lst@[newitem], current, (total + current), List.length (lst@[newitem]) = List.length comp gacha' count total type CompGacha<'a> = CompGacha of 'a type CompGachaBuilder () = member this.Bind(m, f) : CompGacha<_> = let (CompGacha (comp, d, p, lst,count,total,complete)) = m let lst,count,total,complete = completeGacha comp d p lst count total f (comp,d, p, lst,count,total,complete) member this.Return x = CompGacha(x) member this.ReturnFrom x = x let cg = new CompGachaBuilder() let printGacha price unit f x = x |>! (fun (comp, d, p, possession, n, total, complete) -> let g = sprintf "%d回：%d%s" n (price * n) unit let sum = sprintf "合計%d%s" (price * total) unit let result = sprintf "%s" (if complete then "コンプ" else "未コンプ") printfn "%s %s %A %s" g sum possession result if List.length comp = List.length possession then f()) open FSharpx open Operators let inline returnM x = returnM cg x let inline (>>=) m f = bindM cg m f let inline (=<<) f m = bindM cg m f let inline ap m f = f <*> m let inline map f m = liftM cg f m let inline (<!>) f m = map f m let inline lift2 f a b = returnM f <*> a <*> b let inline (>>.) m f = bindM cg m (fun _ -> f) let inline (>=>) f g = fun x -> f x >>= g let inline (<=<) x = flip (>=>) x
利用側
open System open Library1 type Rarity = |R of string |Other // ガチャアイテム let a,b,c,d,e,other = R("緒方智絵里"), R("間中美里"), R("黒川千秋"), R("川島瑞樹"), R("若林智香"), Other // コンプ let comp = [a;b;c;d;e] // コンプ対象アイテムが出る確率 let probability = 0.12 // 12% // １ガチャあたり300円 let printg = printGacha 300 "円" (fun () -> printfn "［眠れる姫君］星井美希を手に入れた！") let mogemasu x = cg { return x } >>= fun x -> cg { return x |> printg } >>= fun x -> cg { return x |> printg } >>= fun x -> cg { return x |> printg } >>= fun x -> cg { return x |> printg } >>= fun x -> cg { return x |> printg } // 別の書き方 //let mogemasu x = // cg { let! x = cg { return x } // let! x = cg { return x |> printg } // let! x = cg { return x |> printg } // let! x = cg { return x |> printg } // let! x = cg { return x |> printg } // return x |> printg } (comp, other, probability, [], 0, 0, false) |> mogemasu |> ignore Console.ReadLine () |> ignore
とりあえずコンピューテーション式にしました以外の何物でもない。愚直版に比べるとそこそこ抽象化こそされているが、まだ不十分。コンプ対象カード中何枚揃えるまでガチャを行うかの部分がハードコーディングされている（この場合は5回のBindをすることで5枚揃えるまでガチャしている）。ちなみに、このコンピューテーション式は「Functor且つApplicative且つモナド」を満たさない。「コンピューテーション式がモナドである必要は必ずしもない」が、このような実装ではモジュール性の低下は否めない。
簡素なコンプガチャシミュレータをIdentityモナドで
HaskellでIdentityモナド(恒等モナド)と言えば、一般的にはモナド変換子からモナドを導出するために使われることで知られている。内部処理を伴わない単なる関数適用をモナドで表現する目的でIdentityモナドを使うことは、Haskellではあまりしないのかもしれない。しかし、まったく意味がないというわけではない。モナドを利用することで、モジュール性が高まりプログラムの見通しが良くなる。「Functor且つApplicative且つモナド」ではないコンピューテーション式をわざわざ作るよりかは、Identityモナドを使った実装の方が見通しの良いプログラムが書けるかもしれない。
ではやってみよう。
FSharpxには標準で実装されていないため、まずはIdentityモナドをつくる必要がある。
module Identity = type M<'T> = M of 'T let mreturn x : M<'T> = M x type IdentityBuilder () = member this.Return (x) = mreturn x member this.Bind ((M x),f) : M<'U> = f x let identity = IdentityBuilder () open FSharpx open Operators let inline returnM x = returnM identity x let inline (>>=) m f = bindM identity m f let inline (=<<) f m = bindM identity m f let inline (<*>) f m = applyM identity identity f m let inline ap m f = f <*> m let inline map f m = liftM identity 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 identity m (fun _ -> f) let inline (>=>) f g = fun x -> f x >>= g let inline (<=<) x = flip (>=>) x
利用側
open System open Library1 open Library1.Identity type Rarity = |R of string |Other // ガチャアイテム let a,b,c,d,e,other = R("緒方智絵里"), R("間中美里"), R("黒川千秋"), R("川島瑞樹"), R("若林智香"), Other // コンプ let comp = [a;b;c;d;e] // コンプ対象アイテムが出る確率 let probability = 0.12 // 12% // １ガチャあたり300円 let printg = printGacha 300 "円" (fun () -> printfn "［眠れる姫君］星井美希を手に入れた！") let compGacha x = identity { let comp,d,probability,lst,count,total,r = x let lst,count,total,r = completeGacha comp d probability lst count total return (comp,d,probability,lst,count,total,r ) |> printg } let mogemasu () = (comp, other, probability, [], 0, 0, false) |> fun x -> compGacha x >>= compGacha >>= compGacha >>= compGacha >>= compGacha // 別の書き方 //let mogemasu () = // (comp, other, probability, [], 0, 0, false) |> fun x -> // identity { let! x = compGacha x // let! x = compGacha x // let! x = compGacha x // let! x = compGacha x // let! x = compGacha x // return x } mogemasu () |> ignore System.Console.ReadLine () |> ignore Console.ReadLine () |> ignore
Identityモナドを用いて実装することにより、冗長なコンピューテーション式をわざわざ作らなくても、見通しがよいコードを書くことができた。しかも、これはモナドであるためモジュール性が高い。その証拠にモナド則３の結合則から「何枚揃えるまでガチャを行うか」についての抽象を導き出すことができる。
例えばこうだ。
open System open Library1 open Library1.Identity type Rarity = |R of string |Other // ガチャアイテム let a,b,c,d,e,other = R("緒方智絵里"), R("間中美里"), R("黒川千秋"), R("川島瑞樹"), R("若林智香"), Other // コンプ let comp = [a;b;c;d;e] // コンプ対象アイテムが出る確率 let probability = 0.12 // 12% // １ガチャあたり300円 let printg = printGacha 300 "円" (fun () -> printfn "［眠れる姫君］星井美希を手に入れた！") let compGacha x = identity { let comp,d,probability,lst,count,total,r = x let lst,count,total,r = completeGacha comp d probability lst count total return (comp,d,probability,lst,count,total,r ) |> printg } let mogemasu n = (comp, other, probability, [], 0, 0, false) |> fun x -> let cg = [for i in 1..n-1 do yield compGacha] List.fold (fun m f -> m >>= f) (compGacha x) cg mogemasu 5 |> ignore System.Console.ReadLine () |> ignore Console.ReadLine () |> ignore
List.foldで必要回数分のモナドを結合することで、mogemasu関数を汎化することができた。
なお、List.foldでモナドを結合している部分は、下記のようにList.foldBackに書き直しても同様に動作する。このことからもモナド則３を満たしていることが確認できる。
let mogemasu n = (comp, other, probability, [], 0, 0, false) |> fun x -> let cg = [for i in 1..n-1 do yield compGacha] List.foldBack (fun m f -> f >>= m) cg (compGacha x)
まとめ
そのまま適用しただけでは何もしてくれないので、一見使いどころがなさそうなIdentityモナド。しかし、使えないようでいて実は割と使えるかもしれない、という話題でした。
読者の中には記事の誘導によってうまいこと騙されている人もいるかもしれないけど、
いや...、つーかさ。それ再帰で書けばいんじゃね？（核心
i l l ヽ ヽ＼＼
ヾy ‐-~~~ ヽ、 ＼ ヽ ヽ
ィ ヽ~＼ ヽ ヽ ｀、
/ ー-、 ＼ ｀、
/ ヽヾヽ＼ ヽ＼ ヽ、 、
// / |＼ ヽ、 ヽ ヽ | l｀、
/ | | l , 、＼＼＼＼ ＼ | l 丶
| ｌ |. 、! ＼ ＼ ー '''' ヽ、ヽ l | | `
. |.ｌ | ｒ'｝ 、 ＼,,、 、__,,、-‐''｀ヽ | | | |
l.ｌ | （ { ｀ー''丶 '''ー- '´ |/ヽ | | | ii |
l | ヽ; | |' ｉ| l | | | i
ヽ .l ｀i. i ノ, / / /// / ＿＿＿＿＿＿＿＿＿＿
＼. l ヽ. ヽ /｀" / // |~ヽ ／
ヽ. ヽ _,,,,,,_ /r、 ／ / | | ＜またつまらぬコードを書いてしまった。
＼ ／llヽ ‐-、｀' /1| ヽ ／ ／| | ＼＿＿＿＿＿＿＿＿＿＿
／ ||∧. ／ | | ＼-‐' | |
_ ,、 -／l ||{ ヽ,,,,,,,,,／ .| | |ヽ、、 | |
_,、- ' ´ |. ||｛ | | |ヽ、 ゛| |、,,_
関連記事
FizzBuzz問題から学ぶモナド
http://d.hatena.ne.jp/zecl/20110711/p1
ScalazのValidationもFSharpxのValidationもApplicative
ドラゴンズドグマが楽しみだったり、しおりを温めていたScala実践プログラミングの読書を再開したりな今日この頃。
ご多聞に漏れずわたくしも五月病なので軽めのネタで。とゆーかですね、FSharpxのステマです。
FSharpxのValidationでFizzBuzz
元ネタ
ScalazのValidationでFizzBuzz
http://d.hatena.ne.jp/terazzo/20111015/1318692810
続・ScalazのValidationでFizzBuzz
http://d.hatena.ne.jp/terazzo/20111018/1318959813
そもそものきっかけはこのあたり
2012-05-08 17:02:40 via web
ScalazのValidationの謎
http://d.hatena.ne.jp/terazzo/20111022/1319295098
勉強になります。ということで、「ScalazのValidationはモナドではない」であっていました。しかしながら、Scalazの場合は「動作を変えてモナドのインスタンスにすることもできる」んですね。でもそれってどうなの？エラー情報をaccumulateしないValidationって一体何。とっても意味ないんじゃー感がするんですが。できるというだけでやらないですね。
で、FSharpxというF#のOSSライブラリでも同じくValidationが実装されていまして、エラーをListMonoidとして扱ってエラー情報をaccumulateします。もちろんFSharpxのValidationもモナドではなくアプリカティブ(Applicative)として実装されています。ちょっと関連する以下のようなつぶやきも踏まえつつ、FSharpxと友達になるべくこれでFizzBuzzしてみましょう。
Choice<'T1,'T2>をEither<'T,'U>として使うべきか否かはfsharpxの中の人達の間でも議論が交わされたみたいだけど、非同期ワークフローで採用されているわけだし、結局は"使う"に落ち着いて、新たにEither作らない方向でってゆー。名前びみょいけどねえ
名前がびみょすぎる・・・
Choice<'T1,'T2>なのか・・・名前ェ・・・
2012-05-07 11:48:52 via web
タプルの汎用はそこそこありだけど Choice<> を生で使うのは極力避けたい派、というかダメじゃね。
FSharpxの中の人的には、Choice<'T1,'T2>が生で使われちゃうこともある程度許容しているような雰囲気もなくはないですが、
生でヤっちゃうといろいろとアレということで、判別供用体のChoice1Of2とChoice2Of2を申し訳程度にラップしておく。
let success = Choice1Of2 let failure = Choice2Of2 open FSharpx.Validation let createChoice d s = fun n -> if n % d = 0 |> not then success n else failure [s] let fizz = createChoice 3 "Fizz" let buzz = createChoice 5 "Buzz" let (<*) a b = lift2 (fun x _ -> x) a b let fizzbuzz n = fizz n <* buzz n |> function | Success n -> string n | Failure e -> List.fold (fun a b -> b + a) "" e [1..100] |> Seq.iter (fun x -> fizzbuzz x |> printfn "%s") System.Console.ReadLine () |> ignore
って、ちょっと待って。FSharpxにおいてもValidationはちゃーんとApplicative考慮されていますし、当然のようにプログラムをApplicativeスタイルで書くための(<*)演算子はValidationモジュールにすでに定義済みです。上でわざわざ書いたのは、lift2していますよということを強調したかっただけでした。あとついでといっちゃーなんですが、お気に入りの「にっこり演算子」もおまけで追加しておきましょう。
let success = Choice1Of2 let failure = Choice2Of2 let (^-^) x f = x f (* にっこり *) open FSharpx.Validation let createChoice d s = fun n -> if n % d = 0 |> not then success n else failure [s] let fizz = createChoice 3 "Fizz" let buzz = createChoice 5 "Buzz" let fizzbuzz n = fizz n <* buzz n |> function | Success n -> string n | Failure e -> List.fold (fun a b -> b + a) "" e [1..100] |> Seq.iter ^-^ fun x -> fizzbuzz x |> printfn "%s" System.Console.ReadLine () |> ignore
シンプル。Validation本来の使い方とはちとズレていますが、サンプルとしてはイメージがつかみやすく結構わかり良いんじゃないでしょうか。元ネタのterazzoさんナイスですね。
参考
Scala の Either についての考察http://d.hatena.ne.jp/xuwei/20110927/1317156625
Scalaz 6.0.4 と Haskell (GHC7.4.1) を比べてみることによってScalazのclassを分類して理解してみる
http://d.hatena.ne.jp/xuwei/20120204/1328377968
Retry Monad for Transient Fault Handling (Topaz + FSharpx)
4月14日に札幌で行われた第69回CLR/H勉強会にて、「Retry Monad for Transient Fault Handling - F#とWindows Azure と私 -」と題して、ライトニングトークで発表しました。
Retry monad for transient fault handling
View more presentations from zecl1231
Microsoft Enterprise Library 5.0 Integration Pack for Windows Azure(EL5 for Azure)のTopaz および FSharpx を利用してモナドを作りました。Topazを利用する理由は、再利用可能な再試行戦略およびWindows Azure向けの検出戦略が組み込み済みであり、それをそのまま利用したいからです。EL5 for AzureはOSSなので、どのような実装がなされているか実際に確認することができるので、すべてをF#で書き直すこともできますが、それでは車輪の再発明になってしまいます。Retry Monad for Transient Fault Handling は、一時的障害が発生するかもしれない計算について、それぞれ異なるRetryPolicyを適用しながら再試行処理を行います。一時的な障害に対するリトライ処理をひとつの計算として包括的に扱うことができるモナド実装です。このRetryモナドの計算結果は、Choice<’T1,’T2>型で得ることができ、これによりFSharpxで定義済みの Eitherモナドで扱うこともできます。
Retry Monad for Transient Fault Handling
namespace Monad.Retry open System [<AutoOpen>] module Retry = // #r "Microsoft.Practices.TransientFaultHandling.Core" // #r "FSharpx.Core" open Microsoft.Practices.TransientFaultHandling open FSharpx [<Sealed>] type TransientErrorCatchAllStrategy () = interface ITransientErrorDetectionStrategy with member this.IsTransient (ex : exn) = true [<Sealed>] type TransientErrorIgnoreStrategy () = interface ITransientErrorDetectionStrategy with member this.IsTransient (ex : exn) = false let defaultRetryStrategyName = "DefaultRetry" let defaultRetryCount = 3 let defaultMinBackoff = TimeSpan.FromSeconds(3.0) let defaultMaxBackoff = TimeSpan.FromSeconds(90.0) let defaultDeltaBackoff = TimeSpan.FromMilliseconds(30.0) let (<+) (rp:RetryPolicy<'TResultStrategy>) retrying = rp.Retrying |> Event.add(retrying) type RetryPolicies = static member NoRetry() = new RetryPolicy<TransientErrorIgnoreStrategy>(0, TimeSpan.Zero) static member Retry<'TTransientErrorCatchStrategy when 'TTransientErrorCatchStrategy : (new :unit -> 'TTransientErrorCatchStrategy) and 'TTransientErrorCatchStrategy :> ITransientErrorDetectionStrategy>(retryCount : int , retryInterval : TimeSpan) : RetryPolicy<'TTransientErrorCatchStrategy> = new RetryPolicy<'TTransientErrorCatchStrategy>(retryCount, retryInterval) static member Retry<'TTransientErrorCatchStrategy when 'TTransientErrorCatchStrategy : (new :unit -> 'TTransientErrorCatchStrategy) and 'TTransientErrorCatchStrategy :> ITransientErrorDetectionStrategy>(retryCount : int , initialInterval : TimeSpan, increment : TimeSpan) : RetryPolicy<'TTransientErrorCatchStrategy> = new RetryPolicy<'TTransientErrorCatchStrategy>(retryCount, initialInterval, increment) static member Retry<'TTransientErrorCatchStrategy when 'TTransientErrorCatchStrategy : (new :unit -> 'TTransientErrorCatchStrategy) and 'TTransientErrorCatchStrategy :> ITransientErrorDetectionStrategy>(retryStrategy : RetryStrategy) : RetryPolicy<'TTransientErrorCatchStrategy> = new RetryPolicy<'TTransientErrorCatchStrategy>(retryStrategy) static member RetryExponential<'TTransientErrorCatchStrategy when 'TTransientErrorCatchStrategy : (new :unit -> 'TTransientErrorCatchStrategy) and 'TTransientErrorCatchStrategy :> ITransientErrorDetectionStrategy>(retryCount : int , deltaBackoff : TimeSpan) : RetryPolicy<'TTransientErrorCatchStrategy> = let retryStrategy = new ExponentialBackoff(defaultRetryStrategyName, retryCount, defaultMinBackoff, defaultMaxBackoff , deltaBackoff) new RetryPolicy<'TTransientErrorCatchStrategy>(retryStrategy) static member RetryExponential<'TTransientErrorCatchStrategy when 'TTransientErrorCatchStrategy : (new :unit -> 'TTransientErrorCatchStrategy) and 'TTransientErrorCatchStrategy :> ITransientErrorDetectionStrategy>(retryCount : int , minBackoff : TimeSpan, maxBackoff : TimeSpan, deltaBackoff : TimeSpan) : RetryPolicy<'TTransientErrorCatchStrategy> = let retryStrategy = new ExponentialBackoff(defaultRetryStrategyName, retryCount, minBackoff, maxBackoff, deltaBackoff) new RetryPolicy<'TTransientErrorCatchStrategy>(retryStrategy) static member RetryDefault(?retryCount : int) : RetryPolicy<TransientErrorCatchAllStrategy>= let retryCount = defaultArg retryCount defaultRetryCount RetryPolicies.RetryExponential<TransientErrorCatchAllStrategy>(retryCount, defaultMinBackoff, defaultMaxBackoff, defaultDeltaBackoff) type Retry<'TResult> = Retry of (Lazy<unit -> 'TResult * LastException option>) and RetryResult<'TResult> = Choice<'TResult, LastException> and LastException = exn let exnHandler e = Retry(lazy(fun () -> Unchecked.defaultof<'TResult>, e |> Some)) type RetryBuilder (policy : RetryPolicy) = new(?retryCount : int, ?retrying) = let policy = let retryCount = defaultArg retryCount defaultRetryCount RetryPolicies.RetryDefault(retryCount) retrying |> function | None -> policy <+ (fun e -> printfn "%s" (sprintf "RetryPolicyName:%s, CurrentRetryCount:%d, LastException.Message:%s, Delay:%A" policy.RetryStrategy.Name e.CurrentRetryCount e.LastException.Message e.Delay)) | Some retrying ->policy <+ retrying RetryBuilder(policy) member this.Bind (m : Retry<'TResult>, bind : ('TResult) -> Retry<'UResult>) : Retry<'UResult> = Retry(lazy(fun () -> m |> function | Retry f -> f.Force() |> fun cont -> cont() ||> fun r _ -> r |> bind |> function | Retry f -> f.Force() |> fun cont -> policy.ExecuteAction(Func<_>(fun () -> cont() ||> fun r _ -> r,None)))) member this.Return (value : 'TResult) : Retry<'TResult> = Retry(lazy (fun () -> policy.ExecuteAction(L.F<_>(fun () -> value, None)))) member this.ReturnFrom (m : Retry<'TResult>) : Retry<'TResult> = m member this.Delay (f: unit -> Retry<unit -> 'TResult>) : Retry<unit -> 'TResult> = Retry(lazy (fun () -> policy.ExecuteAction(L.F<_>(fun () -> f() |> function | Retry f -> f.Force() |> fun cont -> cont() ||> fun f _ -> f(), None)) ||> fun r _ -> (fun () -> r), None)) member this.Zero () : Retry<'TResult> = this.Return(Unchecked.defaultof<'TResult>) member this.Combine(comp1:Retry<'TResult>, comp2:Retry<'TResult>) = this.Bind(comp1,(fun r -> comp2)) let retry = new RetryBuilder() open Operators let inline returnM x = returnM retry x let inline (>>=) m f = bindM retry m f let inline (=<<) f m = bindM retry m f let inline (<*>) f m = applyM retry retry f m let inline ap m f = f <*> m let inline map f m = liftM retry 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 retry m (fun _ -> f) let inline (>=>) f g = fun x -> f x >>= g let inline (<=<) x = flip (>=>) x let (|RetryResult|) = let rec result (r:RetryResult<'TResult>) = match r with | Choice1Of2 v -> v, None | Choice2Of2 e -> Unchecked.defaultof<'TResult>, Some(e) result let run (retryCont : Retry<unit -> 'TResult>) : RetryResult<'TResult> = try retryCont |> function |(Retry f) -> f.Force()() ||> fun r e -> e |> function |Some e -> e |> Choice2Of2 |None -> r() |> Choice1Of2 with e -> e |> Choice2Of2
一時的な障害：Windows Azure(クラウド)アプリケーションを開発するにあたって対処しなければならない課題のひとつ
他のクラウドサービスに依存するようなクラウドアプリケーションを開発する場合に開発者が対処しなければならない課題の一つに、“一時的な障害” があります。インフラストラクチャレベルの障害であったり、ネットワークの問題など一時的な条件のために発生する恐れのある障害のことです。この一時的に発生しうる障害は、ほとんどの場合は短い間隔で（ほんの数ミリ秒後に）リトライ処理を行うことで回避することができます。たとえば、Windows Azureで SQL Azureプラットフォームを利用する場合。SQL Azureサービスは、共有リソース上で大規模なマルチテナントデータベースとしてサービスが提供されるので、データベースを利用するすべての利用者に対して良好なエクスペリエンスを提供しなければなりません。そのため、SQL Azureは過剰なリソースの使用や、実行時間の長いトランザクションの発行された場合など、さまざまな理由でサービスへの接続数を抑制して、利用者が意図しないタイミングで接続を切断することがあります。これが、SQL Azureを利用した場合に生じる一時的な障害ということになります。このような障害が発生した場合であってもシームレスなユーザーエクスペリエンスを提供するために、Windows Azureアプリケーション(クラウドアプリケーション)では、一時的な障害によって処理が中断された場合にはリトライを試みるようにアプリケーションを実装する必要があります。
Microsoft Enterprise Library 5.0 Integration Pack for Windows Azureを利用する
一時的な障害に対応するアプリケーションを実装する場合、Microsoft Enterprise Library 5.0 Integration Pack for Windows Azure(以降 EL5 for Azure)を利用するのが有効です。EL5 for Azureは、マイクロソフトの pattern & practice チームによる、マイクロソフト製品やテクノロジを基として、アプリケーションを構築する上でのパターンやベストプラクティスを集めたライブラリの Windows Azure向けの拡張パックです。この拡張ライブラリが提供されるまでは、一時的障害を検知してリトライ処理を行う実装を開発者自身がおのおので組み込まなければなりませんでした。EL5 for Azureには、Transient Fault Handling Application Block (Topaz)という、Windows Azureのプラットフォームに含まれるサービス利用時に発生するさまざまな一時的な障害からWindows Azureアプリケーションを回復させるためのアプリケーションブロックが提供されています。これは、Windows Azure固有の一時的な障害のみならず、オンプレミスアプリケーションで発生するさまざまな一時的な障害に対するリトライ処理についても利用可能なように設計されており、リトライ処理について高いレベルで抽象化されたアプリケーションブロックです(Microsoft.Practices.TransientFaultHandling.Core.dllにまとめらえている)。特に、Windows Azureに特化した組み込みの実装については、SQL Azure、Windows Azure ストレージサービス、Windows Azure サービスバス、Windows Azure キャッシングサービス向けの検出戦略がそれぞれ提供されていて、Microsoft.Practices.EnterpriseLibrary.WindowsAzure.TransientFaultHandling.dllに含まれています。検出戦略と再試行戦略
検出戦略は、ITransientErrorDetectionStrategyインターフェイスを実装して作成することができます。public interface ITransientErrorDetectionStrategy { bool IsTransient(Exception ex); }
例外を引数で受け取り、その例外の種類や内部的なメッセージなどを判断して、リトライ処理を行うときは true、 リトライをせずに無視するときは falseを返すように実装するだけの非常にシンプルなインターフェイスです。Windows Azureの一時的な障害に対する4つの組み込み検出戦略として、SqlAzureTransientErrorDetectionStrategy、StorageTransientErrorDetectionStrategy、ServiceBusTransientErrorDetectionStrategy、CacheTransientErrorDetectionStrategyが提供されています。
再試行戦略は、RetryStrategy抽象クラスを継承して作成することができます。
public abstract class RetryStrategy { public static readonly int DefaultClientRetryCount = 10; public static readonly TimeSpan DefaultClientBackoff = TimeSpan.FromSeconds(10.0); public static readonly TimeSpan DefaultMaxBackoff = TimeSpan.FromSeconds(30.0); public static readonly TimeSpan DefaultMinBackoff = TimeSpan.FromSeconds(1.0); public static readonly TimeSpan DefaultRetryInterval = TimeSpan.FromSeconds(1.0); public static readonly TimeSpan DefaultRetryIncrement = TimeSpan.FromSeconds(1.0); public static readonly bool DefaultFirstFastRetry = true; public static readonly RetryStrategy NoRetry = new FixedInterval(0, DefaultRetryInterval); public static readonly RetryStrategy DefaultFixed = new FixedInterval(DefaultClientRetryCount, DefaultRetryInterval); public static readonly RetryStrategy DefaultProgressive = new Incremental(DefaultClientRetryCount, DefaultRetryInterval, DefaultRetryIncrement); public static readonly RetryStrategy DefaultExponential = new ExponentialBackoff(DefaultClientRetryCount, DefaultMinBackoff, DefaultMaxBackoff, DefaultClientBackoff); protected RetryStrategy(string name, bool firstFastRetry) { this.Name = name; this.FastFirstRetry = firstFastRetry; } public bool FastFirstRetry { get; set; } public string Name { get; private set; } public abstract ShouldRetry GetShouldRetry(); }
基本的な実装は、GetShouldRetryメソッドをオーバーライドし、リトライすべきタイミングか否かを表すShouldRetry デリゲートを返すように実装します。
public delegate bool ShouldRetry(int retryCount, Exception lastException, out TimeSpan delay);
ShouldRetry デリゲートは、リトライする回数と最後に発生した例外およびリトライを行うタイミングの遅延間隔を受け取り、リトライ処理を行うべきタイミングか否かを返します。組み込みで、Incremental(再試行と再試行間の増分の時間間隔数を制御する戦略)、FixedInterval(再試行と一定間隔の再試行間を制御する戦略)、ExponentialBackoff(指数関数的な遅延を計算するためのバックオフ戦略)が提供されています。
Transient Fault Handling Application Block (Topaz)によるリトライ処理の基本的な利用方法
Transient Fault Handling Application Block (Topaz)による基本的な利用方法(C#)は、検出戦略と再試行戦略を組み合わせて、RetryPolicyオブジェクトを作成し、そのRetryPolicyオブジェクトにリトライ中の処理を適宜設定し、RetryPolicyオブジェクトのExecuteActionメソッドを呼び出します。ExecuteActionメソッドへは、リトライを行いたい対象の処理を継続渡しスタイルで渡します。
var strategy = new Incremental("Incr1",10, TimeSpan.FromSeconds(1), TimeSpan.FromSeconds(1)); var policy = new RetryPolicy<SqlAzureTransientErrorDetectionStrategy>(strategy); policy.Retrying += (_, e) => { Console.WriteLine("{0:HH:mm:ss.fff} RetryCount: {1}, ErrorMessage: {2}, StackTrace: {3}", DateTime.Now, e.CurrentRetryCount, e.LastException.Message, e.LastException.StackTrace); }; var result = policy.ExecuteAction(() => { // SQL Azureへごにょごにょ return "クエリの結果などを返す"; });
EL5 for Azureはオブジェクト指向プログラミングで書かれているライブラリ、FSharpxは関数プログラミングで書かれているライブラリです。これら異なるパラダイムの部品を組み合わせてモナドを作る。とっても面白いですね。
モナドとは
モナドは単なる自己関手の圏におけるモノイド対象だよ。何か問題でも？ - フィリップ・ワドラー
圏論を少しかじったことがある人にとっては問題ない説明なのですが、そうではない場合「日本語でおｋ」と言わざるを得ません。
この説明だけでは少々乱暴すぎるので、MSDN - コンピューテーション式(F#)へのリンクと、F#とモナドの関係について参考になりそうな表を置いておきます。
コンピュテーション式 (F#)
http://msdn.microsoft.com/ja-jp/library/dd233182(v=vs.110).aspx
| Haskell | F# | 数学(圏論) |
|---|---|---|
| return | return | η（単位元：unit） |
| >>= | bind | (*)operator |
| 型クラスMonadのインスタンスであるように実装する | コンピューテーション式で少なくとも Return と Bind の２つのmemberを実装する | NA |
| Monad | Computation Expression, Workflow | モナドはKleisliトリプルと等価な定義。F# と Haskell の中で定義されるモナドの構造は実際にKleisliトリプル。 |
| functor through a type class definition | usually not mentioned | 関手(functor) |
| function | function (fun) | 射(morphism) |
| Haskellのデータ型のHask圏 | .Netデータ型の圏 | グループ、位相、グラフ、微分幾何学 |
| composable functions | composable functions | 2項演算とモノイド |
MSDN - Code Recipe - F#によるモナドの実装方法とモナド則を確認するユニットテスト。 Retry Monad for Transient Fault Handling
モナド則を確認するためのユニットテスト等を含む、このプログラムコードのソリューションファイル一式を、MSDN - Code Recipe よりダウンロードすることができます。
http://code.msdn.microsoft.com/F-Retry-Monad-for-35ee1e72
関連記事
快刀乱麻を断つモナド - F#とIOモナドとコンピューテーション式の奥義とhttp://d.hatena.ne.jp/zecl/20110703/p1
