2013-03-31

ステップアップでわかるコンピュテーション式。TryWith や TryFinally などの実装にぜひ活用したい Delayと Run

全国１億２千万人の F# ファンの皆様いかがお過ごしでしょうか。理解できるわけもないとわかっていながらも調子に乗って「型システム入門プログラミング言語と型の理論」を買ってしまった系の痛いおじさんです。１０年後、２０年後にわかることができてたらいいなくらいのノリで読んでいます。が、早くも挫折の兆しです。歩道の雪はまだまだ残ってるながらも極寒の地もようやく春めいてきました。最近やけに眠いです。春眠暁をなんとやら。プライベートな時間に勉強をするモチベーションがあまりないので、最近は映画観たりゲームばっかりやっています（下り坂）。

読む・・・！読むが・・・今回まだその時と理解度の指定まではしていない。そのことをどうか諸君らも思い出していただきたいつまり・・・我々がその気になれば理解は１０年後、２０年後ということも可能だろう・・・ということ・・・！
2013-03-04 09:07:42 via Tween

自分が理解していることについてちょっと書いてみたい

わたしの誤字ツイートがかなり恥ずかしい感じですが、こんなやり取りがありました。

コンピューテーション式のTryWith とか TryFinally にかかわるその他もろもろの部分の実装は Delay でそのまま遅延しておいて、と Run で評価するのが一番わかいがよいし楽っぽい希ガス。となると、MSDNに書いているシグネチャはことごとく無視することになる。
2013-03-29 15:29:44 via Silver Bird Plus
@zecl MSDNぅ？　はあ？　トマスピに聞け！　ですねわかります。
2013-03-29 15:38:42 via Twitter for iPhone to @zecl
@igeta Mr.えふしゃーぷサマサマですね。ところで、Stateモナ..コンピューテーション式の記事はかどってますか
2013-03-29 15:52:32 via Silver Bird Plus to @igeta
@zecl 書くかどうか、というか書けるかどうかわかりませんが、書くんだったらコンピュテーション式のモッナード側面全般の記事にしたいっすね。
2013-03-29 19:47:55 via Twitter for iPhone to @zecl
@zecl DelayとRunを使ったほうが楽になる理由ってなんでしょうか？利点があればぜひ知りたいです。
2013-03-29 20:58:15 via HootSuite to @zecl

F# 専用の DBアクセスライブラリ「Tranq」を開発なさっている、ナイス F#er のなかむらさん(@nakamura_to)にリアクションを頂いたので、ある程度の前提知識がある方向け（？）にちょっと書いてみます。ガブさん(@gab_km)の「できる！コンピュテーション式」あたりを理解していることが望ましいです。モナド的なお話はあまりありません。モッナード側面のお話はいげ太さん(@igeta)がしてくれるらしい（？）

Delay と Run を使ったほうがなぜ楽になるのか。その答えは「なぜ Delayメソッドがコンピュテーション式の基本メソッドとして提供されているのか。」の理由を紐解くとおのずと見えてきます。結論から言うと、「{| try cexpr with | pattern_i -> expr_i |}」の cexpr の部分などは、コンピュテーション式そのものが評価された後で評価されて欲しいからです。その答えはF#の言語仕様およびコンパイラのソースコードの中にあります。Delay には、他のメソッドとは少し違う特徴があります。この記事では Maybeモナドを例に、コンピュテーション式が標準でサポートする各メソッドはなんのために用意されているのか？その明確な意味について、順を追ってゆる〜く見て行きたいと思います。「ステップアップでわかるコンピュテーション式」的な何かです。

Step1 : 背景にモナドを持つ Bind と Return メソッド

Bind と Return メソッド、その背景にはモナドがあります。
ですが、"モナドとはまったく関係なく自由に利用することができるメソッドである" ということをあらかじめ申し上げておきます。

くどいと思われる方は読みとばしていただいて結構です。Delay と TryWith 関連の詳細な話題は Step5 以降で扱っています。

Step2 : 一手間を省く ReturnFromメソッド

Step3 : コンピュテーション式の流れをコントロールする Delay と Combineメソッド

Step4 : 「if式のelseを省略したい！」 Zeroメソッド

Step5 : 「try...with 式を使いたい！」 TryWithメソッド

Step6 : 「{| try cexpr with | pattern_i -> expr_i |}」の cexpr の評価を遅延する

Step7 : 最終的なコンピュテーション式の型を決定する Runメソッド

Step8 : 「try...finaly式を使いたい！」TryFinallyメソッド

寄り道 : F#3.0のコンパイラのソースコードを読もう

Step9 : 「use 束縛を使いたい！」Usingメソッド

Step10 : 「while...do式を使いたい！」Whileメソッド

Step11 : 「for...do式を使いたい！」Forメソッド

コンピュテーション式で Maybeモナドを表現すると、以下のようになります。

  type MaybeBuilder() =
    member b.Bind(m, f) = Option.bind f m
    member b.Return(a) = Some a

  let maybe = new MaybeBuilder()

いわゆる「ビルダークラス」と呼ばれるクラスを定義し、そのインスタンスを使ってコンピュテーション式として使えるようにしたものです。たとえば以下のように Maybe の文脈の計算を簡単に、しかも読みやすく書くことができるようになります。

  maybe { 
    let! a = Some 15
    let! b = Some 20
    return a + b }
  |> printfn "%A" 
  // Some 35

  maybe { 
    let! a = Some "F#!"
    return a + a }
  |> printfn "%A" 
  // Some "F#!F#!"

Bindメソッドは、コンピュテーション式の let! および do! に対して呼び出されるものです。let! キーワードで値を束縛して次の計算に渡したり、do! キーワードで処理を行えるようになります。Returnメソッドは、コンピュテーション式の return に対して呼び出されるものです。Maybeモナドのようにコンテナ（ここではOption型）を扱うような場合、いわゆるコンテナに値を包むような操作を定義します*1。Bindメソッドは、Haskellの Monad の(>>=)演算子に。Returnメソッドは、Haskellの Monad の return に対応するように意識されて用意されたものです。

Haskell Monad の定義を見てみましょう。

class Monad m where
   (>>=) :: m a -> (a -> m b) -> m b
   return :: a -> m a

コンピュテーション式 (F#) - MSDNライブラリのページでは、Bind と Retrun のシグネチャは以下のように示されています。
http://msdn.microsoft.com/ja-jp/library/vstudio/dd233182.aspx

引数と対応付けて書くと、こうですね。

builder.Bind(m:M<'T>, f:('T -> M<'U>)) : M<'U> 
builder.Return(a:'T) : M<'T>

もちろんMaybeBuilderはこのシグネチャにそっています。

  type MaybeBuilder() =
    member b.Bind(m:option<'a>, f:('a -> option<'b>)) : option<'b> = Option.bind f m
    member b..Return(a:'a) : option<'a> = Some a

F# には Haskellでいう型クラスはありません。ですから、Haskell の m a と F# の M<'T> はまったく同じものを意味するわけではありませんが、
コンピュテーション式が提供された背景として、Haskell の Monad があることがわかります。

そういや、MSDN のコンピューテーション式 URL の説明って、基本モナドベースで書かれているし、シグネチャとかそんなに制限あるわけでもないし、若干もにょる。
2013-03-29 15:26:23 via Silver Bird Plus

コンピュテーション式は、モナドを表現するのにとても都合がいいように設計されています。でも実際には、Bind や Return などのコンピュテーション式で利用可能な各メソッドのシグネチャにそのような制約はありません。ビルダークラスの各メソッドの定義には、引数の数のみが制限されます。なので、わりかし自由度の高い計算の構築ができるようになっています。制限がゆるいおかげでいろいろ好き勝手ができます。コンピュテーション式はモナドだけのための構文ではないのです。

  type HogeBuilder() =
    member b.Return(a:int->int) : int -> int = a
    member b.Bind(m:int -> int, f: (int -> int)-> (int -> int)) = f m
  let hoge = new HogeBuilder()

  hoge { 
    let! a = fun x -> 5 + x
    let! b = fun x -> 20 - x
    return a >> b  }
  |> fun f-> f 0 |>  printfn "%A" 
  // 15

自由とはときとして不自由である。という話もあります。

Step2 : 一手間を省く ReturnFromメソッド

ReturnFrom は定義をしなくても別段困ることはありませんが、あると便利です。

  type MaybeBuilder() =
    member b.Bind(m, f) = Option.bind f m
    member b.Return(a) = Some a

    // add
    member b.ReturnFrom(m) = m

  let maybe = new MaybeBuilder()

  maybe { 
    return! None }
  |> printfn "%A" 
  // <null> ※None

  maybe { 
    let! a = Some "F# is fun!"
    return a }
  |> printfn "%A" 
  // Some "F# is fun!"

  maybe { 
    return! Some "F# is fun!" }
  |> printfn "%A" 
  // Some "F# is fun!"

一度 Bind (!let)で受けてから、Return(return)をするという手間を省くことができるようになります。
コンピュテーション式をより書きやすくするためにあるもの。という位置づけのものと考えて差し支えないでしょう。

Step3 : コンピュテーション式の流れをコントロールする Delay と Combineメソッド

~~コンピュテーション式で、「if式を使いたい！」というモチベーションが発生したら、Combineメソッドを実装しましょう。~~
コンピュテーション式の式の流れをコントロールしたい場合は、Combineメソッドを実装しましょう。その名の意味のとおり、計算式を結合するためのものです。

※コメントでNobuhisaさん(@nobuhisa_k)からツッコミをいただきました。ありがとうございます！

修正前、Combineメソッドを実装していないと、コンピュテーション式の中で if式そのものが利用できないという誤解を与える記述がありましたが、それは誤りです。
if式をただ使うだけであれば、Combineメソッドを実装する必要はありません。以下のように利用することができます。

  type MaybeBuilder() =
    member b.Bind(m, f) = Option.bind f m
    member b.Return(a) = Some a
    member b.ReturnFrom(m) = m

  let maybe = new MaybeBuilder()

  maybe { 
    let! c = Some "C#"
    let! fs = Some "F#"
    let! vb = Some "VB"
    let! cpp = Some "C++"

    if (fs > vb) && (vb > c) then
      return vb
    elif c > vb then
      return c
    else
      return fs}
  |> printfn "%A" 
  // Some "F#"

しかし、if式の後にも式を続けて記述したい場合はどうでしょう？

if 式だけで式の流れが完結している場合は問題ありませんが、コンピュテーション式の中で式の流れの制御が必要になった場合、Combineメソッドの実装が必要となります。
これは if式の利用に限ったことではなく、極端な話、以下のような記述をするためには Combineメソッドを実装する必要があります。

  type MaybeBuilder() =
    member b.Bind(m, f) = Option.bind f m
    member b.Return(a) = Some a
    member b.ReturnFrom(m) = m

    // add
    member b.Combine(x, y) = x |> ignore; y

  let maybe = new MaybeBuilder()

これは一体どういうことえだってばよ！？
F#3.0の言語仕様によると、Combineはコンパイラによって以下のように展開されるので、Delayが必須だということですね。

T(ce1; ce2, V, C, q) = C(b.Combine({| ce1 |}0, b.Delay(fun () -> {| ce2 |}0)))

6.3.10Computation Expressions - The F# 3.0 Language Specification
http://research.microsoft.com/en-us/um/cambridge/projects/fsharp/manual/spec.html#_Toc335818835

  type MaybeBuilder() =
    member b.Bind(m, f) = Option.bind f m
    member b.Return(a) = Some a
    member b.ReturnFrom(m) = m
    member b.Combine(x, y) = x |> ignore; y

    // add
    member b.Delay (f) = f()

  let maybe = new MaybeBuilder()

  maybe { 
    let! c = Some "C#"
    let! fs = Some "F#"
    let! vb = Some "VB"
    let! cpp = Some "C++"

    if (fs > vb) && (vb > c) then
      return vb
    elif c > vb then
      return c
    else
      return cpp
    return fs
    }
  |> printfn "%A" 
  // Some "F#" 

  maybe { 
    let! c = Some "C#"
    let! fs = Some "F#"
    let! vb = Some "VB"
    let! cpp = Some "C++"

    return c
    return vb
    return cpp
    return fs}
  |> printfn "%A" 
  // Some "F#"

コンピュテーション式の計算式の流れは、上から下へ（左から右へ）流れています、その流れを制御するのが Combineメソッドです。Combineメソッドは、Haskell の MonadPlus の mplus にあたるものとして解釈される場合もありますが、コンピュテーション式の中の式の流れを制御するためのものと理解するとよいでしょう。

Step4 : 「if式のelseを省略したい！」 Zeroメソッド

コンピュテーション式で、「if式のelse以下を省略したい！」というモチベーションが発生したら、Zeroメソッドを実装しましょう。

  type MaybeBuilder() =
    member b.Bind(m, f) = Option.bind f m
    member b.Return(a) = Some a
    member b.ReturnFrom(m) = m
    member b.Combine(x, y) = x |> ignore; y
    member b.Delay (f) = f()

    // add
    member b.Zero() = None

  let maybe = new MaybeBuilder()

  maybe { 
    if false then
      return "F#" }
  |>  printfn "%A" 
  // <null> ※None

  maybe { 
    if true then
      return "F#" }
  |> printfn "%A" 
  // Some "F#"

コンピュテーション式の計算式の流れのなかで式が省略されたとき、None が流れていることがわかります。Zeroメソッドは、Haskell の MonadPlus の mzero の意味として解釈される場合もありますが、コンピュテーション式においては、上（左）の計算式が省略された場合に利用される既定値を表すものと理解するとよいでしょう。

Step5 : 「try...with 式を使いたい！」 TryWithメソッド

コンピュテーション式で、「try...with 式を使いたい！」というモチベーションが発生したら、TryWithメソッドを実装しましょう。

  type MaybeBuilder() =
    member b.Bind(m, f) = Option.bind f m
    member b.Return(a) = Some a
    member b.ReturnFrom(m) = m
    member b.Combine(x, y) = x |> ignore; y
    member b.Delay(f) = f() 
    member b.Zero() = None

    // add
    member b.TryWith (m, hander) = try m with ex -> hander ex

  let maybe = new MaybeBuilder()

  maybe { 
    let! x = None
    try 
      return x / 0
    with
    | e -> return 0
  }
  |> printfn "%A" 
  // <null> ※None

  maybe { 
    let! x = Some 10
    try 
      return x / 0
    with
    | ex -> printf "%s" ex.Message 
            return 0
  }
  |> printfn "%A" 
  // 例外が発生するがキャッチできない

「0 で除算しようとしました。Some 0」と出力されてされて欲しいところですが、コンピュテーション式そのものの評価がされる前に、0除算が先に評価されてしまっている。Delay、TryWith いずれのメソッドのシグネチャも、MSDN に書いてある通りに実装したのに、この有様です。それもそのはず。「member b.Delay(f:unit-> option<'a>) = f() 」を見れば明らか。そもそも Delay されていた処理を、即時評価してしまっているのですから、こうなります。

builder { cexpr } は、どのように展開されるか？これについては、本家の F#3.0 の言語仕様を参照しましょう。

6.3.10Computation Expressions - The F# 3.0 Language Specification
http://research.microsoft.com/en-us/um/cambridge/projects/fsharp/manual/spec.html#_Toc335818835

Combineメソッドのときもそうでしたが、コンピュテーション式がコンパイラによって変換されたときに、自動的に Delay メソッドが挿入されるタイミングが他にもいくつかある。それが以下のとおり、

T(e, V, C, q) where e : the computation expression being translated
　　　　　　　　　　V : a set of scoped variables
　　　　　　　　　　C : continuation (or context where “e” occurs,
　　　　　　　　　　　　up to a hole to be filled by the result of translating “e”)
　　　　　　　　　　q : Boolean that indicates whether a custom operator is allowed

T(while e do ce, V, C, q) = T(ce, V, lv.C(b.While(fun () -> e, b.Delay(fun () -> v))), q)
T(try ce with pi -> cei, V, C, q) =
Assert(not q); C(b.TryWith(b.Delay(fun () -> {| ce |}0), fun pi -> {| cei |}0))
T(try ce finally e, V, C, q) =
Assert(not q); C(b.TryFinally(b.Delay(fun () -> {| ce |}0), fun () -> e))
T(ce1; ce2, V, C, q) = C(b.Combine({| ce1 |}0, b.Delay(fun () -> {| ce2 |}0)))

これが示しているのは、while...do 式に対応する、Whileメソッド。try...with 式に対応するTryWithメソッド。try...finally式に対応するTryFinallyメソッド。そして、式の流れをコントロールする Combineメソッドの４つの式を変換するときに、暗黙的にDelayメソッドの呼び出しが挿入されることを意味している。F# は正確評価の言語なので、「member b.Delay(f:unit-> option<'a>) : unit -> option<'a> = f 」という様に、この時点では評価をせずにそのまま式を遅延した状態を維持しないと、コンピュテーション式そのものが評価される前に「{| try cexpr with | pattern_i -> expr_i |}」の cexpr の部分が評価されてしまうので、うまくない。ということです。MSDNで示されているシグネチャは、標準的なモナドベースで書かれていて、実用的なコンピュテーション式の書き方については言及していない感があり、わかりにくいところがあります。

これを踏まえて、次のステップへ行ってみましょう。

Step6 : 「{| try cexpr with | pattern_i -> expr_i |}」の cexpr の評価を遅延する

Step5 を踏まえて、次のように実装を変更してみましょう。

  type MaybeBuilder() =
    member b.Bind(m, f) = Option.bind f m
    member b.Return(a) = Some a
    member b.ReturnFrom(m) = m
    member b.Zero() = None

    // modify
    member b.Delay(f:unit -> option<'a>) = f
    member b.TryWith (c:unit -> option<'a>, hander:exn -> option<'a>) = try c() with ex -> hander ex
    member b.Combine(x:option<'a>, y:unit -> option<'a>) = if Option.isSome x then x else y()

  let maybe = new MaybeBuilder()

TryWithメソッドだけではなく、Combineメソッドにも変更が必要ということに注目です。
Delayメソッドの中で処理の遅延をそのままにするかわりに、「{| try cexpr with | pattern_i -> expr_i |}」の cexpr の部分で、unit を適用して評価するように実装します。TryWith では、式が上から下（左から右）へ流れます。その式が Combineメソッドでも遅延されているので、このとき評価するように実装します。

  let a : unit -> option<int> = maybe { 
    let! x = None
    try 
      return x / 0
    with
    | e -> return 0
  }
  a |> printfn "%A" 
  // <fun:a@16>
  a () |> printfn "%A" 
  // <null> ※None

  let b : unit -> option<int> = maybe { 
    let! x = Some 10
    try 
      return x / 0
    with
    | ex -> printf "%s" ex.Message
            return 0
  }
  b |> printfn "%A" 
  // <fun:b@26>
  b () |> printfn "%A" 
  // 0 で除算しようとしました。Some 0

となります。try...with式が思った通りの挙動をするようになりました。
しかし、Delay によって unit を引数にとる関数になったままだと、どうも具合がよくありません。これは、Step7 で解決します。

Step7 : 最終的なコンピュテーション式の型を決定する Runメソッド

Step5 で、評価が遅延されるべき計算は、Delayメソッドによって包まれている(unitを引数にとる関数として)ことがわかりました。
しかし、遅延されたままだと具合がよくありません。そこで、Runメソッドの出番です。

6.3.10Computation Expressions - The F# 3.0 Language Specification
http://research.microsoft.com/en-us/um/cambridge/projects/fsharp/manual/spec.html#_Toc335818835

let b = builder-expr in b.Run (<@ {| cexpr |}C >@)

F#3.0 の言語仕様にありますように、Runメソッドは、ビルダークラスが評価されるときに呼びだされます。
つまり、「member b.Delay(f:unit-> option<'a>) = f 」に対して必要なRunメソッドの実装は「member b.Run(f:unit-> 'c) : 'c = f()」という感じになります。

  type MaybeBuilder() =
    member b.Bind(m, f) = Option.bind f m
    member b.Return(a) = Some a
    member b.ReturnFrom(m) = m
    member b.Combine(x, y) = if Option.isSome x then x else y()
    member b.Zero() = None
    member b.Delay(f) = f
    member b.TryWith (c, hander) = try c() with ex -> hander ex

    // add
    member b.Run(f) = f() 

  let maybe = new MaybeBuilder()

  maybe { 
    let! x = None
    try 
      return x / 0
    with
    | e -> return 0
  }
  |> printfn "%A" 
  // <null>

  maybe { 
    let! x = Some 10
    try 
      x / 0 |> printf "%d"
    with
    | ex -> printf "%s" ex.Message
    return "ここまで"
  }
  |> printfn "%A" 
  // 0 で除算しようとしました。Some "ここまで"

コンピューテーション式のTryWith とか TryFinally にかかわるその他もろもろの部分の実装は Delay でそのまま遅延しておいて、と Run で評価するのが一番わかいがよいし楽っぽい希ガス。となると、MSDNに書いているシグネチャはことごとく無視することになる。
2013-03-29 15:29:44 via Silver Bird Plus

ということで、このツイートで言いたかったのはこういうことでした。
大した話でもないのにダラダラと書いてしまいました。でもまだ続きもあるのでよろしければ。

Step8 : 「try...finally式を使いたい！」TryFinallyメソッド

さて、try...finally式も利用できるように実装してみましょう。Step6 と Step7を踏まえれば難しくないですね。
また、DelayメソッドとRunメソッドがどのように呼ばれているのかを確認するために、printf を入れてみました。

  type MaybeBuilder() =
    member b.Bind(m, f) = Option.bind f m
    member b.Return(a) = Some a
    member b.ReturnFrom(m) = m
    member b.Combine(x, y) = if Option.isSome x then x else y()
    member b.Zero() = None
    member b.TryWith (c, hander) = try c() with ex -> hander ex

    // add
    member b.TryFinally (c, f) = try c() finally f()

    // modify
    member b.Delay(f) = 
      #if DEBUG
      printf "%s" "delay;"
      #endif
      f
    member b.Run(f) = f() |> fun x ->  
      #if DEBUG
        printf "%s" "run;" 
      #endif
        x 

  let maybe = new MaybeBuilder()

  maybe { 
    try 
      try
        printf "%s" "try"
      finally
        printf "%s" "finally1;"
    finally
      printf "%s" "finally2;"
    return "ここまで"
  }
  |> printfn "%A" 
  // Debug : delay;delay;delay;tryfinally1;finally2;delay;run;Some "ここまで"
  // Relese: tryfinally1;finally2;Some "ここまで"

Debugモードで実行すると、「delay;delay;delay;tryfinally1;finally2;delay;run;Some "ここまで"」と出力されます。try...finally式を2回使っています。ここでDelayが2回呼ばれます。外側のtry...finally式で unit が返されますので、その後で既定値となる Zeroメソッドが呼ばれます。そのZeroメソッドで返された「None」と、「return "ここまで"」がCombineメソッドで結合されるので、ここでも Delayが呼ばれます。Delayが呼ばれるのは、合計3回ですか？でも、実際には合計4回呼ばれています。どういうことだってばよ？

このあたりのことは、言語仕様を読めばちゃんと書いてありますね。

6.3.10Computation Expressions - The F# 3.0 Language Specification
http://research.microsoft.com/en-us/um/cambridge/projects/fsharp/manual/spec.html#_Toc335818835

let b = builder-expr in b.Run (<@ b.Delay(fun () -> {| cexpr |}C) >@)

ビルダークラスに Delayメソッドが実装されているときに限り、上記のように評価されるのです。いつDelayメソッドが呼ばれるかを把握しておくことは大事です。暗黙的にDelayメソッドが呼ばれるタイミングは、Whileメソッド、TryWithメソッド、TryFinallyメソッド、Combineメソッド、Runメソッド、の５つです。これ以外にDelayメソッドが呼ばれるタイミングは、自分で明示的に呼ぶように実装した場合のみになります。ここテストに出ます！ちなみに、Runメソッドについてもビルダークラスに実装されている場合に限り呼び出しが行われます。

寄り道 : F#3.0のコンパイラのソースコードを読もう

Step9へ行く、その前にちょっと寄り道。F#3.0のコンパイラのソースコードを読もうのコーナー。

F#3.0のコンパイラのコンピュテーション式の分析をしているところのソースコードについて、いくつかピックアップして見てみる。
http://fsharppowerpack.codeplex.com/SourceControl/changeset/view/71313#1230866

まずはここらへん。ふむふむなるほど。コンピュテーション式の呼び出しを生成している関数のようです。

/// Make a builder.Method(...) call
let mkSynCall nm (m:range) args = 
    let m = m.MakeSynthetic() // Mark as synthetic so the language service won't pick it up.
    let args = 
        match args with 
        | [] -> SynExpr.Const(SynConst.Unit,m)
        | [arg] -> SynExpr.Paren(SynExpr.Paren(arg,range0,None,m),range0,None,m)
        | args -> SynExpr.Paren(SynExpr.Tuple(args,[],m),range0,None,m)
            
    let builderVal = mkSynIdGet m builderValName
    mkSynApp1 (SynExpr.DotGet(builderVal,range0,LongIdentWithDots([mkSynId m nm],[]), m)) args m

Whileメソッドを生成するとき、mkSynCall関数の引数に"Delay"が渡されているのか確認できます。ここで自動的に Delayメソッドが呼び出される構成が作られているんですね。

        | SynExpr.While (spWhile,guardExpr,innerComp,_) -> 
            let mGuard = guardExpr.Range
            let mWhile = match spWhile with SequencePointAtWhileLoop(m) -> m | _ -> mGuard
            if isQuery then error(Error(FSComp.SR.tcNoWhileInQuery(),mWhile))
            if isNil (TryFindIntrinsicOrExtensionMethInfo cenv env mWhile ad "While" builderTy) then error(Error(FSComp.SR.tcRequireBuilderMethod("While"),mWhile))
            if isNil (TryFindIntrinsicOrExtensionMethInfo cenv env mWhile ad "Delay" builderTy) then error(Error(FSComp.SR.tcRequireBuilderMethod("Delay"),mWhile))
            Some(trans true q varSpace innerComp (fun holeFill -> translatedCtxt (mkSynCall "While" mWhile [mkSynDelay2 guardExpr; mkSynCall "Delay" mWhile [mkSynDelay innerComp.Range holeFill]])) )

同様に、TryWithメソッド。

        | SynExpr.TryWith (innerComp,_mTryToWith,clauses,_mWithToLast,mTryToLast,spTry,_spWith) ->
            let mTry = match spTry with SequencePointAtTry(m) -> m | _ -> mTryToLast
            
            if isQuery then error(Error(FSComp.SR.tcTryWithMayNotBeUsedInQueries(),mTry))
            if q then error(Error(FSComp.SR.tcTryWithMayNotBeUsedWithCustomOperators(),mTry))
            let clauses = clauses |> List.map (fun (Clause(pat,cond,clauseComp,patm,sp)) -> Clause(pat,cond,transNoQueryOps clauseComp,patm,sp))
            let consumeExpr = SynExpr.MatchLambda(true,mTryToLast,clauses,NoSequencePointAtStickyBinding,mTryToLast)
            if isNil (TryFindIntrinsicOrExtensionMethInfo cenv env  mTry ad "TryWith" builderTy) then error(Error(FSComp.SR.tcRequireBuilderMethod("TryWith"),mTry))
            if isNil (TryFindIntrinsicOrExtensionMethInfo cenv env mTry ad "Delay" builderTy) then error(Error(FSComp.SR.tcRequireBuilderMethod("Delay"),mTry))
            Some(translatedCtxt (mkSynCall "TryWith" mTry [mkSynCall "Delay" mTry [mkSynDelay2 (transNoQueryOps innerComp)]; consumeExpr]))

同様に、TryFinallyメソッド。

        | SynExpr.TryFinally (innerComp,unwindExpr,mTryToLast,spTry,_spFinally) ->

            let mTry = match spTry with SequencePointAtTry(m) -> m | _ -> mTryToLast
            if isQuery then error(Error(FSComp.SR.tcNoTryFinallyInQuery(),mTry))
            if q then error(Error(FSComp.SR.tcTryFinallyMayNotBeUsedWithCustomOperators(),mTry))
            if isNil (TryFindIntrinsicOrExtensionMethInfo cenv env mTry ad "TryFinally" builderTy) then error(Error(FSComp.SR.tcRequireBuilderMethod("TryFinally"),mTry))
            if isNil (TryFindIntrinsicOrExtensionMethInfo cenv env mTry ad "Delay" builderTy) then error(Error(FSComp.SR.tcRequireBuilderMethod("Delay"),mTry))
            Some (translatedCtxt (mkSynCall "TryFinally" mTry [mkSynCall "Delay" mTry [mkSynDelay innerComp.Range (transNoQueryOps innerComp)]; mkSynDelay2 unwindExpr]))

同様に、Combineメソッド。

        | SynExpr.Sequential(sp,true,innerComp1,innerComp2,m) -> 

            // Check for 'where x > y' and other mis-applications of infix operators. If detected, give a good error message, and just ignore innerComp1
          if isQuery && checkForBinaryApp innerComp1 then 
            Some (trans true q varSpace innerComp2 translatedCtxt) 

          else
            
            if isQuery && not(innerComp1.IsArbExprAndThusAlreadyReportedError) then 
                match innerComp1 with 
                | SynExpr.JoinIn _ ->  () // an error will be reported later when we process innerComp1 as a sequential
                | _ -> errorR(Error(FSComp.SR.tcUnrecognizedQueryOperator(),innerComp1.RangeOfFirstPortion))

            match tryTrans true false varSpace innerComp1 id with 
            | Some c -> 
                // "cexpr; cexpr" is treated as builder.Combine(cexpr1,cexpr1)
                // This is not pretty - we have to decide which range markers we use for the calls to Combine and Delay
                // NOTE: we should probably suppress these sequence points altogether
                let m1 = 
                    match innerComp1 with 
                    | SynExpr.IfThenElse (_,_,_,_,_,mIfToThen,_m) -> mIfToThen
                    | SynExpr.Match (SequencePointAtBinding mMatch,_,_,_,_) -> mMatch
                    | SynExpr.TryWith (_,_,_,_,_,SequencePointAtTry mTry,_) -> mTry
                    | SynExpr.TryFinally (_,_,_,SequencePointAtTry mTry,_)  -> mTry
                    | SynExpr.For (SequencePointAtForLoop mBind,_,_,_,_,_,_) -> mBind
                    | SynExpr.ForEach (SequencePointAtForLoop mBind,_,_,_,_,_,_) -> mBind
                    | SynExpr.While (SequencePointAtWhileLoop mWhile,_,_,_) -> mWhile
                    | _ -> innerComp1.Range
                if isNil (TryFindIntrinsicOrExtensionMethInfo cenv env m ad "Combine" builderTy) then error(Error(FSComp.SR.tcRequireBuilderMethod("Combine"),m))
                if isNil (TryFindIntrinsicOrExtensionMethInfo cenv env m ad "Delay" builderTy) then error(Error(FSComp.SR.tcRequireBuilderMethod("Delay"),m))
                Some (translatedCtxt (mkSynCall "Combine" m1 [c; mkSynCall "Delay" m1 [mkSynDelay innerComp2.Range (transNoQueryOps innerComp2)]]))

Step5 にあったとおりコンピュテーション式の中で、try...with式を利用するためには、TryWithメソッドに加えて、Delayメソッドも実装しなければなりませんでした。例えば TryWithメソッドがビルダークラスに実装されている場合、TryWithメソッドの呼び出しの中で Delayメソッドの呼び出しがコンパイラによって暗黙的に挟み込まれるということがわかります。「{| try cexpr with | pattern_i -> expr_i |}」の cexpr の部分にちょうど挿入されます。これは「このタイミングで挿入される Delayメソッドの呼び出しを利用して処理を遅延してね！」といわんばかりです。つまり、MSDNで示されている「通常のシグネチャ」はガン無視していただいて構わないということです。

ところで、ビルダークラスが評価されるタイミングについても、同じような挙動をするのでした。Runメソッドが実装されている場合のみ Runメソッドが呼び出されるようコンパイラさんがよろしくやってくれて、そのRunメソッドの中で、Delayメソッド呼ばれるかどうかについても、Delayメソッドが実装されているか否かによって判断されると、言語仕様に書いてありました。コンパイラさんのことは、コンパイラさんが一番よく知っているって、じっちゃんが言ってた。

関係ありそうなところを以下にピックアップ。

let mkSynDelay2 (e: SynExpr) =  mkSynDelay (e.Range.MakeSynthetic()) e

let delayedExpr = 
        match TryFindIntrinsicOrExtensionMethInfo cenv env mBuilderVal ad "Delay" builderTy with 
        | [] -> basicSynExpr
        | _ -> mkSynCall "Delay" mBuilderVal [(mkSynDelay2 basicSynExpr)]

let quotedSynExpr = 
    if isAutoQuote then 
        SynExpr.Quote(mkSynIdGet (mBuilderVal.MakeSynthetic()) (CompileOpName "<@ @>"), (*isRaw=*)false, delayedExpr, (*isFromQueryExpression=*)true, mWhole) 
    else delayedExpr

let runExpr = 
    match TryFindIntrinsicOrExtensionMethInfo cenv env mBuilderVal ad "Run" builderTy with 
    | [] -> quotedSynExpr
    | _ -> mkSynCall "Run" mBuilderVal [quotedSynExpr]

runExprを見ると、Runメソッドがビルダークラスに実装されている場合のみ Runの呼び出しが生成され、同じく delayedExprを見ると、Delayメソッドが実装されている場合のみ内部にDelay の呼び出しが生成される、と。

実際そのようになっているようです。コンパイラのソースを見れば...、いろいろとわかる（こともある）。オープンソースな F# いいね！

Step9 : 「use 束縛を使いたい！」Usingメソッド

少しばかり寄り道をしてしまいましたが、気を取り直して最後まで一気に駆け抜けましょう。

「use 束縛を使いたい！」そんなあなたは、Usingメソッドを実装しましょう。use 束縛は、C# や VBの using ステートメントにあたる働きをします。.NET開発者であれば、ご存知のとおり、IDisposableインターフェイスを実装しているオブジェクトについてリソースを解放をする働きがあるものです。

  open System
  type MaybeBuilder() =
    member b.Bind(m, f) = Option.bind f m
    member b.Return(a) = Some a
    member b.ReturnFrom(m) = m
    member b.Combine(x, y) = if Option.isSome x then x else y()
    member b.Zero() = None
    member b.Delay(f) = f 
    member b.TryWith (c, hander) = try c() with ex -> hander ex
    member b.Run(f) = f()
    member b.TryFinally (c, f) = try c() finally f()

    // add
    member b.Using(res:#IDisposable, body:#IDisposable -> option<'a>) : option<_>= 
      b.TryFinally((fun ()-> body res), fun () -> match res with null -> () | x -> x.Dispose())

  let maybe = new MaybeBuilder()

リソースの解放は、use キーワードで束縛した値のスコープが外れた場合。つまり式が最後まで評価された、あるいは例外が発生してスコープを外れた場合が考えられます。この実装には、先ほど実装した TryFinallyメソッドをそのまま利用することができます。TryFinallyメソッド使って簡単に実装しましょう。もちろん、「{| try cexpr with | pattern_i -> expr_i |}」の cexpr の部分には、コンパイラによって Delayメソッドの呼び出しが暗黙的に挿入されることになるので処理の呼び出しが遅延されます。

  let createDisposable f = { new IDisposable with member x.Dispose() = f() }
  maybe { 
    use res = createDisposable (fun () -> printf "%A" "Disposeされたよ;") 
    return "おわり"
  }
  |> printfn "%A" 
  // "Disposeされたよ";Some "おわり"

  maybe { 
    try
      use outp = IO.File.CreateText(@"C:\test\playlist.txt")
      outp.WriteLine("口がすべって")
      outp.WriteLine("君が好き")
      outp.WriteLine("言わせてみてぇもんだ")
    with ex -> printf "%A" ex
  } 
  |> printfn "%A" 
  // <null>

use 束縛は、let 束縛と同じ機能が提供されているだけでなく、束縛した値がスコープの外に出ると対象のオブジェクトの Dispose が呼び出されます。
また、コンパイラによって値の null チェックが挿入されますので、値が null の場合には Dispose の呼び出しは行われません。

Step10 : 「while...do式を使いたい！」Whileメソッド

コンピュテーション式で、「while...do式を使いたい！」という場合は、Whileメソッドを実装します。

  open System
  type MaybeBuilder() =
    member b.Bind(m, f) = Option.bind f m
    member b.Return(a) = Some a
    member b.ReturnFrom(m) = m
    member b.Combine(x, y) = if Option.isSome x then x else y()
    member b.Zero() = None
    member b.Delay(f) = f 
    member b.TryWith (c, hander) = try c() with ex -> hander ex
    member b.Run(f) = f()
    member b.TryFinally (c, f) = try c() finally f()
    member b.Using(res:#IDisposable, body:#IDisposable -> option<'a>) : option<_>= 
      b.TryFinally((fun ()-> body res), fun () -> match res with null -> () | x -> x.Dispose())

    // add
    member b.While(guard:unit -> bool, f:unit -> option<'a>) =
      if not (guard()) then b.Zero() 
      else b.Bind(f(), fun _ -> b.While(guard, f))

  let maybe = new MaybeBuilder()

実装をご覧いただくとわかるように、Zeroメソッド、Bindメソッド、Whileメソッド（自身）を呼び出しています。指定した条件が falseとなったときループを抜けて、上から下（左から右）へ計算式が流れていきます。ここで Zeroメソッドを呼び出すことで既定値の計算式を下（右）へ流しています。条件が true の場合は、上（左）から流れてきた計算式の計算結果と、以後に継続されるループを表す式を、Bindメソッドによって束縛と関数適用を繰り返すことで計算を再帰的につなぎ合わせています。ループの実装は、対象とする文脈によって特に実装内容が大きく異なってきますが、基本的にはこのような流れで実装することになるでしょう。

  maybe { 
    let i = ref 0
    while !i < 10 do
      printf "%d;" !i 
      incr i
  }
  |> printfn "%A" 
  // 0;<null>

  maybe { 
    let i = ref 0
    while !i < 10 do
      printf "%d" !i 
      incr i
      return! Some (printf "%s" "個;" )
    return "ここまで"
  }
  |> printfn "%A" 
  // 0個;1個;2個;3個;4個;5個;6個;7個;8個;9個;Some "ここまで"

  maybe { 
    let i = ref 10
    while !i >= 0 do
      try
        printf "%d;" <| 10 / !i 
        decr i
        return ()
      with
      | ex -> printf "%s" ex.Message 
    return 999
  }
  |> printfn "%A" 
  // 1;1;1;1;1;2;2;3;5;10;0 で除算しようとしました。Some 999

Step11 : 「for...do式を使いたい！」Forメソッド

コンピュテーション式で、「for...do式を使いたい！」というニーズは結構多いのではないかと思います。
これまでのStepの中で実装してきたメソッドを活かしながら Forメソッドを実装してみましょう。

  open System
  type MaybeBuilder() =
    member b.Bind(m, f) = Option.bind f m
    member b.Return(a) = Some a
    member b.ReturnFrom(m) = m
    member b.Combine(x, y) = if Option.isSome x then x else y()
    member b.Zero() = None
    member b.Delay(f) = f 
    member b.TryWith (c, hander) = try c() with ex -> hander ex
    member b.Run(f) = f()
    member b.TryFinally (c, f) = try c() finally f()
    member b.Using(res:#IDisposable, body:#IDisposable -> option<'a>) : option<_>= 
      b.TryFinally((fun ()-> body res), fun () -> match res with null -> () | x -> x.Dispose())
    member b.While(guard:unit -> bool, f:unit -> option<'a>) =
      if not (guard()) then b.Zero() else
      b.Bind(f(), fun _ -> b.While(guard, f))

    // add
    member this.For(sequence:#seq<_>, body) =
      this.Using(sequence.GetEnumerator(),
                fun enum -> this.While(enum.MoveNext, 
                                       (fun () -> body enum.Current)))

  let maybe = new MaybeBuilder()

シーケンスのリソースは解放する必要があるので、実装済みのUsingメソッドを利用します。ループの表現には先程実装したWhileメソッドを利用します。Usingメソッドと、Whileメソッドを利用して、Forを実装することができました。

  maybe { 
    for i in [1..5] do
      printf "%d;" i
      return "Combineで式が結合されてコレは捨てられます"
    return "おしまい"
  }
  |> printfn "%A" 
  // 1;2;3;4;5;Some "おしまい"

  maybe { 
    for i in [1..5] do
      return printf "%d;" i
    return "おしまい"
  }
  |> printfn "%A" 
  // 1;2;3;4;5;Some "おしまい"

残るは、Yieldメソッドと YieldFromメソッドの実装。と言いたいところですが、Maybeモナドの文脈では、Yieldメソッドおよび YieldFromメソッドを実装する意味はありませんので省略します*2。ということで、すべてのステップが終了しました。これでおしまいです。以上、「ステップアップでわかるコンピュテーション式」でした。何かの参考になれば幸いです。

おまけ：FsControlを拡張してお遊び

Gustavo Leon氏(@gmpl)のGJ(グッジョブ)であるところの、fsharp-typeclasses
https://code.google.com/p/fsharp-typeclasses/

を、新しく構成しなおしたプロジェクト FsControl が面白くてニヤニヤしながらたまーに見ていたりします。
https://github.com/gmpl/FsControl

そのキモとなるのが、InlinHelperモジュール。

[<AutoOpen>]
module InlineHelper

module Overloads =
    let inline instance_1 (a:^a                         ) = 
        ( ^a                                : (static member instance: ^a                     -> _) (a          ))
    let inline instance_2 (a:^a,b:^b                    ) =                                                      
        ((^a or ^b                        ) : (static member instance: ^a* ^b                 -> _) (a,b        ))
    let inline instance_3 (a:^a,b:^b,c:^c               ) =                                                          
        ((^a or ^b or ^c                  ) : (static member instance: ^a* ^b* ^c             -> _) (a,b,c      ))
    let inline instance_4 (a:^a,b:^b,c:^c,d:^d          ) =                                                          
        ((^a or ^b or ^c or ^d            ) : (static member instance: ^a* ^b* ^c* ^d         -> _) (a,b,c,d    ))
    let inline instance_5 (a:^a,b:^b,c:^c,d:^d,e:^e     ) =                                                          
        ((^a or ^b or ^c or ^d or ^e      ) : (static member instance: ^a* ^b* ^c* ^d* ^e     -> _) (a,b,c,d,e  ))
    let inline instance_6 (a:^a,b:^b,c:^c,d:^d,e:^e,f:^f) =                                   
        ((^a or ^b or ^c or ^d or ^e or ^f) : (static member instance: ^a* ^b* ^c* ^d* ^e* ^f -> _) (a,b,c,d,e,f))

open Overloads

type Inline = Inline with
    static member inline instance (                            ) = fun (x:'x) -> instance_1(          Unchecked.defaultof<'r>) x :'r
    static member inline instance (a:'a                        ) = fun (x:'x) -> instance_2(a        ,Unchecked.defaultof<'r>) x :'r
    static member inline instance (a:'a, b:'b                  ) = fun (x:'x) -> instance_3(a,b      ,Unchecked.defaultof<'r>) x :'r
    static member inline instance (a:'a, b:'b, c:'c            ) = fun (x:'x) -> instance_4(a,b,c    ,Unchecked.defaultof<'r>) x :'r
    static member inline instance (a:'a, b:'b, c:'c, d:'d      ) = fun (x:'x) -> instance_5(a,b,c,d  ,Unchecked.defaultof<'r>) x :'r
    static member inline instance (a:'a, b:'b, c:'c, d:'d, e:'e) = fun (x:'x) -> instance_6(a,b,c,d,e,Unchecked.defaultof<'r>) x :'r

これがなんとも黒魔術的であり、メシウマ状態であり。その一方で"今の F#"の限界を感じたり。

で、FsControl では、fsharp-typeclasses にあった、DoNotationBuilderを提供する do' が internalで宣言されていたり、DoPlusNotationBuilderとそのインスタンスを提供する doPlus がなくなっていたり、いろいろ変更が加えられている。また、FsControlというプロジェクトからは、なみなみならぬ Haskell愛を感じるわけだけど、F# 愛の成分が不足しているように感じる。というのも、この記事で取り上げたコンピュテーション式内で利用できる for式や try...with 式などの Haskell にはない機能についての利用は考えられていないからだ。FsControl はあくまで Haskell 的な関数型プログラミングのエミュレートを提供するという思想で作られているのかもしれない、とかなんとか。

ということで、お遊び程度でちょっとゴニョゴニョしてみました。なんか表示が崩れてしまうので埋め込みはしません。
https://gist.github.com/zecl/5280535

Whileメソッド以下については、ちょっと工夫しないと厳しそうな気がします。なので宿題とします（ｷﾘｯ

*1:圏論で自然変換と呼ばれるやつ

*2:仮に実装したとしても、Return, ReturnFromと同じになる。

2013-01-14

すごいH本の素朴な確率モナド

プログラミング Haskell F# FSharpx Monad モナド

年末年始の連休から中五日あっての三連休で、正月ボケをぶり返してしまいそうな今日この頃ですが、いかがお過ごしでしょうか。

すごいH本こと、書籍「すごいHaskellたのしく学ぼう！」の最後のほう、第１４章「もうちょっとだけモナド」の 14.8 (P356)にて、素朴な確率モナドが紹介されています。

すごいHaskellたのしく学ぼう!

作者: 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

ほむ。だいぶシンプルになりました。これはリハビリをして正解でしたね。

2012-08-09

圏論でアハ体験

プログラミング Haskell F# 勉強会モナド代数的構造圏論アハ体験 Code

もう1週間以上前になりますが、Code2012という合宿イベントに参加してきました。いろいろな方との交流あり、温泉あり、クラウディアさんありと大変楽しかったので、ぜひ来年も参加したいです。

で、VBerのくせにそちらで「5分じゃわからないモナド - 圏論なんて華麗にスルー」というタイトルでLTをしてきました。なぜか、宴会の後にLTをやるという謎なタイムスケジュールとなっていたため、十分にアルコールが回った状態でお話をしました。時間通りにジャスト5分で話しきれたのは奇跡です。来年はそのあたり考慮してもらいたいかも...しれません。LTの後にいくつか質問をいただいて、モナドや圏やF#についてなんだか結構な時間追加でしゃべったような気がします。

LTの要点としましては、「モナドを使うのに圏論の知識は必要ない。」という意見はまったくそのとおりなのだけど、だからといって関数型言語を学ぶ人が圏論に触れることを無駄とは言えないということ。「プログラミングでモナドを使えるようになってから関数型言語の数学的背景であるところの圏論に触れてみることは、ぜんぜん無駄ではなかったし、むしろ思っていた以上に収穫があった！」という体験について伝えたい。「モナドは単なる自己関手の圏におけるモノイド対象だよ。」の意味を理解できるのとできないのとでは、見える景色がだいぶ違ってくる。圏論にはアハ体験があります。ある程度根気は必要だけど...ということを伝えたかったというものです。

当日話した内容とまったく同じではありませんが、大体以下のような内容でしゃべってきました。こわい人にこわいこわいされるのがこわいので、当初Webにはアップしないでおこうと考えていたのですが、いろいろと思うところが有り、思い直して現時点の自分の考えを晒しておくことにしました。かなり端折り気味な内容ですが雰囲気だけでも。

5分じゃわからないモナド - 圏論なんて華麗にスルー

5分じゃわからないモナド　始めさせていただきます。

ぜくるです。
静的型付け関数型言語が大好きです。　F#が大好きです。

美しいコードは好きですか？

もちろん大好きですよね！！！

美しいコードを書きたければ、より多くの良いコードを読まなければなりません。

ならば、関数型言語が読めないのは、あまりにも損です。

じゃいつやるか？今でしょ！

モナド。みなさん聞いたことくらいはありますよね。

モナドは単なる自己関手の圏におけるモノイド対象だよ。何か問題でも？

どういうことだってばよ！？

関数型言語を成り立たせている構造がそもそも圏だよ。
プログラミングとは、だいたいクライスリ圏の射を作ることらしいよ。

数学由来の抽象であるところの、代数的な構造をプログラミングに応用したらしいよ。

「モナドは単なる自己関手の圏におけるモノイド対象だよ。何か問題でも？」
の意味がなんでわからんのかというと、そもそも専門用語がわからんからにほかならない。

4年くらい関数型言語を勉強してきた中で、わたしがモナドをわかるまでにやったこと。

まずは具体的にモナドを使ったプログラムを書きまくります。
野性的なプログラマはだいたい体で覚えます。

慣れてくると自分で定義します。より理解が深まります。
自分で考えた新しいモナドを定義することもできるようにもなります。

モナドを使うだけなら、高度な理論は全く必要ないんです。
モナドを使いこなすのに「圏論の知識なんて必要ない」そのとおりだと思います。

でも、最小限把握しておいたほうがよい用語や概念があります。
俺達プログラマは好奇心旺盛だもんね！

少し遠回りをしてもいいんじゃないか。
モナドの数学的な背景すべてを知らなくても、おおまかに概観を把握するだけで見える景色が違ってくる。

圏論に触れてみることにしました。

とりあえず、専門書に当たってみる。今年の正月からコツコツと勉強しています。
でも、この本はジャンル的に少し偏っているし、１，２章でお腹いっぱいです。

で、気づいたのが、そもそも群の知識がないと圏論を理解するのは困難ということです。

基礎の基礎が大事です。

集合や群を理解するために、代数を勉強をします。この時点でかなり遠回り。でも、いいんです。

圏論の本にも頻出する集合や群に関する記号の意味を理解するのに役立つ。穴埋めの練習問題形式。
やさしい入門書ですが、基本的なことや記号の意味を把握するだけならこれで十分だと思いました。
でも、マグマとか半群とかモノイドの説明はないので、それらは別の書籍などで補う必要がある。
思いの他おもしろかったので、気持ちに余裕があったら高度な内容にも挑戦してみたいかも。

群と言えばガロア。置換群もプログラミングに関係が深いと感じました。
解説がわかりやすいだけではなく、数学の歴史的な背景も合わせて読めるからお得。
タイトル通り、中１でも読める内容なので安心です。でも後半は結構面倒くさいです。

代数的構造とはなんなのか。具体例を交えてわかりやすく解説してくれます。群の教科書。
こちらおすすめです。寝る前に読んだら、ぐっすり眠れます。

で、群・環・体...と、代数的構造にも色々とありますが、結局プログラミングに関係の深いのは、モノイドという構造です。
どうやら、プログラマ的には、モノイド以外の代数的構造については華麗にスルーしても問題なさそうです。

で、圏とはなんだったのか。
対象と射の集まりのことです。

ただし、ひとつの恒等射が必要。

また、合成射について、結合律を満たす必要があります。

モナド則ととっても似ていますね。
というかむしろ、モノイドの構造そのものです。

「圏」と同時に最小限知っておかなきゃなんないのが、「関手」です。
圏から圏への写像のことです。

自己関手。同一の圏から圏への関手のこと。
そのまんまですね。

Haskellプログラムは、圏（Hask圏）の中で動いています

F#のプログラムは、.NETの圏の中で動いています

どういうことなの？

F#のコードです。FSharpxというライブラリのMaybeモナドを使ってモナド則をコードで表現してみます。

モナド則を満たすわけですから、これは単位律と結合律を満たします。

モナドを使わずに、ただの関数で同様の表現をしてみます。
恒等射はidですね。

同じく単位律と結合律を満たします。

完全に一致！！！
いずれも、圏の条件を満たしており、それぞれが圏だということがわります。

圏空気すぎワロタ

F#の世界の値と関数は、.NETの圏からMaybeモナドの圏への写像であるところの「関手」return によって、 Maybeモナドの圏の値と関数に写像することができる。
で、Maybeの圏はこのとき.NETの圏に含まれていますから、自己関手の圏になるわけですね。で、Maybeという代数的データ型はモノイドの構造を持っているモノイド対象ということですね。

つまり、プログラミングのモナドというのは、関手 return を使うことで、.NETの圏の中で、自己関手の圏であるところのさまざまなモナドの圏を扱えるようになるんですね。

圏論なんて華麗にスルーして、まずモナドを使えるようになったほうがいいです。

ほら、5分じゃわからなかったでしょう？

2012-06-30

F#で shift／reset プログラミング。限定継続（風）モナドで四天王問題を解く。

プログラミング F# F#2.0 FSharpx 限定継続 delimited continuation Scala モナド

発売されてすぐに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以外の応用例も書くつもりでしたが、積みゲー消化したいのでそれはまた別の機会に。たぶん。

2012-05-15

F#で簡素なモゲマスコンプガチャシミュレータ

プログラミング F# FSharpx コンピューテーション式モナド息抜きネタ

椎名林檎「自由へ道連れ」をヘビロテしすぎて脳内無限ループしている今日この頃ですが、皆様いかがお過ごしでしょうか。
時事ネタとしては旬を逃した感じですが、簡素なコンプガチャシミュレータを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

上記記事で利用しているモナドもIdentityモナド。

2012-04-16

Retry Monad for Transient Fault Handling (Topaz + FSharpx)

プログラミング F# C# Windows Azure Enterprise Library 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

2011-07-24

F#で順列(Permutation)と組み合わせ(Combination)。YOU、Listモナドしちゃいなよ。集合モナドもあるよ。

プログラミング Haskell F#2.0 F# モナド

以前、C#で順列(Permutation)と組み合わせ(Combination)をすべて列挙してみようという記事を書きました。
今見ると、前に思っていた以上に「しょっぱいなぁ」と思わざるを得ませんが、C#で書き直すつもりになれません。

今回は、超イケてる言語のF#で書きます。
そして、最近わたしがモナドにハマっているということもあり、非決定性計算を得意とするListモナドを利用したいと思います。

非決定性計算に役立つ Listモナド

Listモナドは非決定性を持つ計算について合成する戦略を持つモナドです。

ということなのですが、「非決定性計算」という言葉の意味するところを知らない場合、「お前は何を言っているんだ。」と思わざるを得ません。
一体どういうことを言っているのかというと、要は総当たりする何かの計算と思ってさしつかえないと思います。
つまり、あるリストの全要素について任意の計算を適用しながら、リストを合成して、新しいリストを作り出すための戦略がListモナドということになります。
モナドの性質をうまく利用していて、ループが複数ネストしてしまうような総当たり計算であっても、
あたかもフラットであるかのような宣言的な記述方法で、曖昧性を解決する計算を構築しやすくしてくれる。

C#、VB プログラマであれば、LINQによる総当たり処理を思い浮かべてみるとイメージしやすいでしょう。
この件については、のいえさん(@neuecc)が、Linqと総当り - neue ccという記事を書いています。ぜひ参考にしてください。

Listモナドは大変便利なので、F#にもぜひ欲しい。

でもちょっと待って。そもそもF#にはシーケンス式があるよ

でも、ちょっと待ってください。
F#には、もともとシーケンス式というナイスな構文が用意されているじゃないか。
なので「F#にListモナドなんて別にいらないんじゃね？」と思われるかもしれません。確かにそうかもしれません。
が、書き易さや可読性、メンテナンス性の観点から、私はコンピューテーション式でListモナドを用意しておきたい派です。

シーケンス式でFizzBuzzを書くとこう。

let fizzbuzz = 
  [for x in [1..100] -> 
    let f,b = "Fizz", "Buzz"
    match x % 3, x % 5 with
    | 0,0 -> f + b
    | 0,_ -> f
    | _,0 -> b
    | _   -> string x]

List.iter (fun x -> printfn "%A" x) fizzbuzz

これは、ループがひとつなので特に気になりません。

では、覆面算　SEND MORE MONEYを書いてみましょう。

let solve () =
  let digits = Set.ofList [0..9]
  let inline toInt xs  = List.fold (fun x y -> x * 10 + y) (0) xs
  [for s in digits - Set.singleton 0 do
     for e in digits - Set.singleton s do
       for n in digits - Set.ofList [s;e] do
         for d in digits - Set.ofList [s;e;n] do
           for m in digits - Set.ofList [s;e;n;d;0] do
             for o in digits - Set.ofList [s;e;n;d;m] do
               for r in digits - Set.ofList [s;e;n;d;m;o] do
                 for y in digits - Set.ofList [s;e;n;d;m;o;r] do
                   let send = toInt[s;e;n;d]
                   let more = toInt[m;o;r;e]
                   let money = toInt[m;o;n;e;y]
                   if send + more = money then
                     yield! [send; more; money]]

これはひどい。ネストが深くなってしまいました。

でも、実はインデントを下げる必要はなくて、

let solve () =
  let digits = Set.ofList [0..9]
  let inline toInt xs  = List.fold (fun x y -> x * 10 + y) (0) xs
  [for s in digits - Set.singleton 0 do
   for e in digits - Set.singleton s do
   for n in digits - Set.ofList [s;e] do
   for d in digits - Set.ofList [s;e;n] do
   for m in digits - Set.ofList [s;e;n;d;0] do
   for o in digits - Set.ofList [s;e;n;d;m] do
   for r in digits - Set.ofList [s;e;n;d;m;o] do
   for y in digits - Set.ofList [s;e;n;d;m;o;r] do
   let send = toInt[s;e;n;d]
   let more = toInt[m;o;r;e]
   let money = toInt[m;o;n;e;y]
   if send + more = money then
     yield! [send; more; money]]

と、上記のようにフラットに書くこともできます。とはいえ、決して書き易いとは言えませんし、
可読性やメンテナンス性の観点から言って欠点が多く、ある程度複雑なリストを表現するような場合は適さないと考えます。
シンプルなリストを構築する場合にシーケンス式はとても有用ですが、その他の場合ではちょっと扱いにくいでしょう。

F#で Listモナド

そこで、コンピューテーション式でListモナドを用意しておきます。

まず、Haskell での定義を。
Listモナドは型クラスMonadとMonadPlusのインスタンスとかなんとか。

instance  Monad []  where
    m >>= k  = concat (map k m)
    return x  = [x]
    fail s       = []

instance  MonadPlus []  where
    mzero =  []
    mplus = (++)

F#のコンピューテーション式で書いてみます。

type ListBuilder() =
  let concatMap f m = List.concat( List.map (fun x -> f x) m )
  member this.Bind (m, f) = concatMap (fun x -> f x) m 
  member this.Return (x) = [x]
  member this.ReturnFrom (x) = x
  member this.Zero () = []
  member this.Combine (a,b) = a@b

let list = ListBuilder()

とりあえずまぁこんなところでしょう。
より多くの機能が欲しければ、各メソッドを実装していけばよいかと。
ListモナドのBindがなぜ複数のネストしたループを表現することができるのかは、実装を見れば明らかですが、
よくわからないという場合は、「リストモナドの動作原理を考える」を参照するとよいかもしれません。

ということで、覆面算SEND MORE MONEYを、コンピューテーション式によるListモナドで。

let solve' () =
  let digits = [0..9]
  let inline toInt xs  = List.fold (fun x y -> x * 10 + y) (0) xs
  let inline (-) a b = a |> List.filter (fun x -> List.forall (fun y -> x <> y) b)
  list { let! s = digits - [0]
         let! e = digits - [s] 
         let! n = digits - [s;e]
         let! d = digits - [s;e;n]
         let! m = digits - [s;e;n;d] - [0]
         let! o = digits - [s;e;n;d;m]
         let! r = digits - [s;e;n;d;m;o]
         let! y = digits - [s;e;n;d;m;o;r]
         let send = toInt[s;e;n;d]
         let more = toInt[m;o;r;e]
         let money = toInt[m;o;n;e;y]
         if send + more = money then
           return! [send; more; money]}

とても書き易く可読性もよいですね。コンピューテーション式によるモナドなので、
モジュール性が確保されていて、シーケンス式のfor - doよりもメンテナンス性が高いです。
別途コンピューテーション式でListモナドを用意しておくことは意味のあることです。

Listモナドで順列(Permutation)と組み合わせ(Combination)

ということで、タイトルにあったように、Listモナドで順列(Permutation)と組み合わせ(Combination)を実装してみた。

F# Snippentsに投稿しました。
http://fssnip.net/6C

F# Snippet: Permutation and Combination URL #fsharp
2011-07-24 14:35:03 via dlvr.it

open System

type ListBuilder() =
  let concatMap f m = List.concat( List.map (fun x -> f x) m )
  member this.Bind (m, f) = concatMap (fun x -> f x) m 
  member this.Return (x) = [x]
  member this.ReturnFrom (x) = x
  member this.Zero () = []
  member this.Combine (a,b) = a@b
  member this.Delay f = f ()

let list = ListBuilder()

let rec permutations n lst = 
  let rec selections = function
      | []    -> []
      | x::xs -> (x,xs) :: list { let! y,ys = selections xs 
                                  return y,x::ys }
  (n, lst) |> function
  | 0, _ -> [[]]
  | _, [] -> []
  | _, x::[] -> [[x]]
  | n, xs -> list { let! y,ys = selections xs
                    let! zs = permutations (n-1) ys 
                    return y::zs }

let rec combinations n lst = 
  let rec findChoices = function 
    | []    -> [] 
    | x::xs -> (x,xs) :: list { let! y,ys = findChoices xs 
                                return y,ys } 
  list { if n = 0 then return! [[]]
         else
           let! z,r = findChoices lst
           let! zs = combinations (n-1) r 
           return z::zs }

let x4P0 = permutations 0 [1;2;3;4]
printfn "4P0 = %d" x4P0.Length
x4P0 |> Seq.iter (fun x -> printfn "%A" x)
Console.WriteLine ("-----") |> ignore

let x4P2 = permutations 2 [1;2;3;4]
printfn "4P2 = %d" x4P2.Length
x4P2 |> Seq.iter (fun x -> printfn "%A" x)
Console.WriteLine ("-----") |> ignore

let x4C0 = combinations 0 [1;2;3;4]
printfn "4C0 = %d" x4C0.Length
x4C0 |> Seq.iter (fun x -> printfn "%A" x)
Console.WriteLine ("-----") |> ignore

let x4C2 = combinations 2 [1;2;3;4]
printfn "4C2 = %d" x4C2.Length
x4C2 |> Seq.iter (fun x -> printfn "%A" x)
Console.ReadLine () |> ignore

コード短すぎワロスwww さすが俺たちのF#さん！！

笑わない数学者「5つのビリヤード玉問題」

笑わない数学者からの挑戦状
http://r27.jp/quiz/mathematical-goodbye/

さっそく利用してみる。笑わない数学者「5つのビリヤード玉問題」を解いてみましょう。

// 5つのビリヤード玉問題
let billiardsProblem = 
  let judge (xs:int list) = 
    let a,b,c,d,e = (xs.[0],xs.[1],xs.[2],xs.[3],xs.[4])
    [a;b;c;d;e]@
    [a+b;b+c;c+d;d+e;e+a]@
    [a+b+c;b+c+d;c+d+e;d+e+a;e+a+b]@
    [a+b+c+d;b+c+d+e;c+d+e+a;d+e+a+b;e+a+b+c]@
    [a+b+c+d+e] 
    |> List.sort 
  list { let! xs = permutations 5 [1..11] 
         if [1..21] = judge xs then          
           return xs}

billiardsProblem |> printfn "%A"

実行結果

[[1; 3; 10; 2; 5]; [1; 5; 2; 10; 3]; [2; 5; 1; 3; 10]; [2; 10; 3; 1; 5];
 [3; 1; 5; 2; 10]; [3; 10; 2; 5; 1]; [5; 1; 3; 10; 2]; [5; 2; 10; 3; 1];
 [10; 2; 5; 1; 3]; [10; 3; 1; 5; 2]]

おまけ：集合モナド

Collections.Set<'T> クラス (F#)
http://msdn.microsoft.com/ja-jp/library/ee353619.aspx

Collections.Set Module (F#)
http://msdn.microsoft.com/ja-jp/library/ee340244.aspx

はい。あいかわらず機械翻訳が残念なことになっていますが、
上記のとおりF#では集合を扱うクラスとモジュールが用意されています。
Listだけじゃなく、集合もモナドになってたらいんじゃね？という単純すぎる発想です。
とはいえ、基本的にListで代用できてしまうので、ありがたみは少ししかないかもしれませんが…。

集合モナド

type SetBuilder() =
  let unionManyMap f m = Set.unionMany ( Set.map (fun x -> f x) m )
  member this.Bind (m, f) = unionManyMap (fun x -> f x) m 
  member this.Return (x) = Set.ofList x
  member this.ReturnFrom (x) = x
  member this.Zero () = Set.empty
  member this.Combine (a,b) = Set.union a b

let set = SetBuilder ()

Listモナドを集合用に単純に書き換えただけですね。
Listモナドで言うところのconcatMapがunionManyMapとなっています。
積集合や対称差のための関数や演算子を用意するなどして、モジュールを充実させるとより扱いやすくなるかも。

集合モナドと他の方法とで、非決定性計算の速度を比較してみる。

let getProcessingTime f = 
  let s = new System.Diagnostics.Stopwatch ()
  s.Start()
  let r = f ()  
  s.Stop ()
  r,s.Elapsed 

Console.WriteLine ("----- send + more = money -- for Set")
let solve () =
  let digits = Set.ofList [0..9]
  let inline toInt xs  = List.fold (fun x y -> x * 10 + y) (0) xs
  [for s in digits - Set.singleton 0 do
   for e in digits - Set.singleton s do
   for n in digits - Set.ofList [s;e] do
   for d in digits - Set.ofList [s;e;n] do
   for m in digits - Set.ofList [s;e;n;d;0] do
   for o in digits - Set.ofList [s;e;n;d;m] do
   for r in digits - Set.ofList [s;e;n;d;m;o] do
   for y in digits - Set.ofList [s;e;n;d;m;o;r] do
   let send = toInt[s;e;n;d]
   let more = toInt[m;o;r;e]
   let money = toInt[m;o;n;e;y]
   if send + more = money then
     yield! [send; more; money]]
printfn "%A" <| getProcessingTime solve

Console.WriteLine ("----- send + more = money -- Listモナド")
let solve' () =
  let digits = [0..9]
  let inline toInt xs  = List.fold (fun x y -> x * 10 + y) (0) xs
  let inline (-) a b = a |> List.filter (fun x -> List.forall (fun y -> x <> y) b)
  list { let! s = digits - [0]
         let! e = digits - [s] 
         let! n = digits - [s;e]
         let! d = digits - [s;e;n]
         let! m = digits - [s;e;n;d] - [0]
         let! o = digits - [s;e;n;d;m]
         let! r = digits - [s;e;n;d;m;o]
         let! y = digits - [s;e;n;d;m;o;r]
         let send = toInt[s;e;n;d]
         let more = toInt[m;o;r;e]
         let money = toInt[m;o;n;e;y]
         if send + more = money then
           return! [send; more; money]}

printfn "%A" <| getProcessingTime solve'

Console.WriteLine ("----- send + more = money -- Setモナド")
let solve'' () =
  let digits = Set.ofList [0..9]
  let inline toInt xs  = List.fold (fun x y -> x * 10 + y) (0) xs
  set { let! s = digits - Set.singleton 0
        let! e = digits - Set.singleton s
        let! n = digits - Set.ofList [s;e]
        let! d = digits - Set.ofList [s;e;n;]
        let! m = digits - Set.ofList [s;e;n;d;0]
        let! o = digits - Set.ofList [s;e;n;d;m]
        let! r = digits - Set.ofList [s;e;n;d;m;o]
        let! y = digits - Set.ofList [s;e;n;d;m;o;r]
        let send = toInt[s;e;n;d]
        let more = toInt[m;o;r;e]
        let money = toInt[m;o;n;e;y]
        if send + more = money then
          return [send; more; money]}

printfn "%A" <| getProcessingTime solve''

Console.WriteLine ("----- send + more = money -- Seq")
let solve''' () =
  let digits = Set.ofList [0..9]
  let inline toInt xs  = List.fold (fun x y -> x * 10 + y) (0) xs
  seq {for s in digits - Set.singleton 0 do
       for e in digits - Set.singleton s do
       for n in digits - Set.ofList [s;e] do
       for d in digits - Set.ofList [s;e;n] do
       for m in digits - Set.ofList [s;e;n;d;0] do
       for o in digits - Set.ofList [s;e;n;d;m] do
       for r in digits - Set.ofList [s;e;n;d;m;o] do
       for y in digits - Set.ofList [s;e;n;d;m;o;r] do
       let send = toInt[s;e;n;d]
       let more = toInt[m;o;r;e]
       let money = toInt[m;o;n;e;y]
       if send + more = money then
         yield! [send; more; money] }
printfn "%A" <| getProcessingTime solve'''

Console.ReadLine () |> ignore

実行結果(マシンスペック等はお察しください)

----- send + more = money -- for Set
([9567; 1085; 10652], 00:00:04.2887953)
----- send + more = money -- Listモナド
([9567; 1085; 10652], 00:00:02.1857583)
----- send + more = money -- Setモナド
(set [1085; 9567; 10652], 00:00:05.1224592)
----- send + more = money -- Seq
(seq [9567; 1085; 10652], 00:00:00.0014052)

「集合モナド遅せーじゃん。」って、なってしまうわけですが、それは問題の性質や領域によって変わってくるお話。
この覆面算については扱う集合があまりにも単純すぎて、リストで扱った方が高速になるが、
より複雑な集合問題を扱う場合は、集合モナドを利用した方がよりシンプルに書くことができて、高速に処理できます。たぶん。
まぁ、多くの場合はListモナドで事足りてしまうような気がするので、集合モナドの活躍の場はあんまりないかも（えっ。
そして一見、「seq が圧倒的パフォーマンスを見せつけているぞ！」と思うかもしれませんが、それはぜんぜん違うくて、
単に遅延評価が働いているだけです。今回の時間の計測方法では早いように見えるだけです。seq は IEnumerable ですからね。お間違えのないように。

ということで、Listモナドで順列(Permutation)と組み合わせ(Combination)を実装しなおしてみたら、
C#と比較にならないくらい短く書けましたよ！というご報告でした。俺達のF#がふつくしすぎる。

自分が理解していることについてちょっと書いてみたい

Step1 : 背景にモナドを持つ Bind と Return メソッド

Step2 : 一手間を省く ReturnFromメソッド

Step3 : コンピュテーション式の流れをコントロールする Delay と Combineメソッド

Step4 : 「if式のelseを省略したい！」 Zeroメソッド

Step5 : 「try...with 式を使いたい！」 TryWithメソッド

Step6 : 「{| try cexpr with | pattern_i -> expr_i |}」の cexpr の評価を遅延する

Step7 : 最終的なコンピュテーション式の型を決定する Runメソッド

Step8 : 「try...finally式を使いたい！」TryFinallyメソッド

寄り道 : F#3.0のコンパイラのソースコードを読もう

Step9 : 「use 束縛を使いたい！」Usingメソッド

Step10 : 「while...do式を使いたい！」Whileメソッド

Step11 : 「for...do式を使いたい！」Forメソッド

おまけ：FsControlを拡張してお遊び

確率を表現するための有理数を表す型

F# で素朴な確率モナド

とりあえず、結果が一致する事象の確率を１つにまとめてみる

結果が一致する事象の確率を１つにまとめる（改訂版）

5分じゃわからないモナド - 圏論なんて華麗にスルー

限定継続と shift/resetプログラミング

限定継続（風）モナド

限定継続（風）モナドを利用してみる

限定継続（風）モナドで四天王問題

おまけ：ダイハード３のやつ

おまけ：地図の塗り分け

おまけ：狼とヤギとキャベツ

おまけ：順列と組み合わせ

シミュレートするコンプガチャの仕様

簡素なコンプガチャシミュレータを愚直に書いてみる

簡素なコンプガチャシミュレータをコンピューテーション式で

簡素なコンプガチャシミュレータをIdentityモナドで

まとめ

関連記事

Retry Monad for Transient Fault Handling

一時的な障害：Windows Azure(クラウド)アプリケーションを開発するにあたって対処しなければならない課題のひとつ

Microsoft Enterprise Library 5.0 Integration Pack for Windows Azureを利用する

検出戦略と再試行戦略

Transient Fault Handling Application Block (Topaz)によるリトライ処理の基本的な利用方法

モナドとは

MSDN - Code Recipe - F#によるモナドの実装方法とモナド則を確認するユニットテスト。 Retry Monad for Transient Fault Handling

関連記事

非決定性計算に役立つ Listモナド

でもちょっと待って。そもそもF#にはシーケンス式があるよ

F#で Listモナド

Listモナドで順列(Permutation)と組み合わせ(Combination)

笑わない数学者「5つのビリヤード玉問題」

おまけ：集合モナド