継続モナド (Contモナド) をF# のコンピュテーション式で書く

Haskellの「モナドのすべて (All About Monads)」チュートリアルの、継続モナドの部分を参考に、F# で Contモナドを書いてみます。

F# の標準機能にはモナド型クラスがなく、モナドトランスフォーマー関連の便利関数もないので、今回は ContT を使わない定義としました。

type Cont<'a, 'r> = { runCont: ('a -> 'r) -> 'r }

HaskellのContモナド関連関数で使いそうなものをモジュールに定義しておきます。

module Cont =
    let toCont c = { runCont = c }
    let runCont { runCont = c } = c
    let return' a = toCont (fun k -> k a)

    let (>>=) { runCont = c } f =
        toCont (fun k -> c (fun a -> runCont (f a) k))

    let when' b s = if b then s () else return' ()

    let bind m f = m >>= f

    let callCC f =
        toCont (fun k -> runCont (f (fun a -> toCont (fun _ -> k a))) k)

callCC を定義しました。さて、期待通りに動くでしょうか。

その前に、せっかく F# で書くわけですから、コンピュテーション式のビルダーも書いておきましょう。

module Cont =
    // ...

    type Builder() =
        member _.Bind(m, f) = m >>= f
        member _.Return(v) = return' v
        member _.ReturnFrom(m) = m
        member _.Zero() = return' ()
        member _.Delay(f) = fun () -> f ()
        member _.Run(funcToRun) = funcToRun ()
        member _.Combine(m1, f) = m1 >>= fun _ -> f ()

    let cont = Builder()

• ReturnFrom をサポートしておくと、callCC から脱出するコードが書きやすくなります。
• Delay と Run に対応させて、 ZeroとCombine をサポートしておくと、when' 関数の代わりに if が使えます。

では、チュートリアルのexample18.hsをコンピュテーション式で書いてみましょう。こうなりました。

open Cont

let toIntList (s: string) =
    s |> Seq.toList |> List.map (fun c -> int c - int '0')

let fromIntList (ns: int list) =
    ns
    |> List.skipWhile (fun n -> n = 0)
    |> List.map (fun n -> '0' + char n)
    |> List.toArray
    |> System.String

(*
   Continuation モナドを使って，コードブロックからの「脱出」を行います
   この関数は以下のような処理の複雑な制御構造を実装します

   Input (n)       Output                       List Shown
   =========       ======                       ==========
   0-9             n                            none
   10-199          number of digits in (n/2)    digits of (n/2)
   200-19999       n                            digits of (n/2)
   20000-1999999   (n/2) backwards              none
   >= 2000000      sum of digits of (n/2)       digits of (n/2)
*)

let f (n: int) =
    let c: Cont<string, string> =
        cont {
            let! str =
                callCC (fun exit1 ->
                    cont {
                        if n < 10 then
                            return! exit1 $"%d{n}"

                        let ns = toIntList (string (n / 2))

                        let! n' =
                            callCC (fun exit2 ->
                                cont {
                                    let len = List.length ns

                                    if len < 3 then
                                        return! exit2 len

                                    if len < 5 then
                                        return! exit2 n

                                    if len < 7 then
                                        let ns' = List.rev ns
                                        return! exit1 (fromIntList ns')

                                    return List.sum ns
                                })

                        return $"(ns = %A{ns}) %d{n'}"
                    })

            return $"Answer: {str}"
        }

    runCont c id

printfn "%s" (f 2)       // Answer: 2
printfn "%s" (f 24)      // Answer: (ns = [1; 2]) 2
printfn "%s" (f 2468)    // Answer: (ns = [1; 2; 3; 4]) 2468
printfn "%s" (f 24680)   // Answer: 4321
printfn "%s" (f 2468024) // Answer: (ns = [1; 2; 3; 4; 0; 1; 2]) 13