ようこそ。睡眠不足なプログラマのチラ裏です。

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


発売されてすぐにPSVitaのP4Gをダウンロードしたのだが、どちらかというとエヴィディ・ヤングライフ・VB6♪な生活を送っていてなかなかプレイする暇がなくてつらい。今日はGoAzureのゆーすと見たり、この記事をこしらえていたりな休日を過ごしていましたが、皆さんいかがお過ごしでしょうか。


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

少し前に書籍「Scala実践プログラミング」のChapter10-2 継続のところ読んでいて、限定継続面白いなー shift/reset プログラミング面白いなーと思っていたので、shift/reset プログラミングについて検索してみました。すると、書籍「プログラミングの基礎」でも有名な、お茶の水女子大学の浅井健一氏の「shift/reset プログラミング入門」が出てきました。いきなり当たりを引いた!今日のおれはツイてるな!(テッテレー)と言う感じで、こちらとてもわかりやすくて素晴らしい資料です。関数型プログラミングや限定継続に興味のある方はぜひご一読を。




Scalaでは限定継続のサポートにより、以下のように shift/resetプログラミングをすることができます。

// result: 11
reset {
    shift { k: (Int=>Int) =>  k(10)
    } + 1
}

継続を限定しているreset部分について、shiftでその継続を取り出して k に束縛していて、 その k に 10 を適用することによって、1が加算されるので、結果は11になります。限定継続ってなんぞ?これの何が嬉しいのかわからないだって?まぁまぁそうおっしゃらずに。とりあえず「shift/reset プログラミング入門」を読みましょう。話はそれから。



ところで、Scala 2.8からサポートされたらしい限定継続ですが、F#にはいまのところそのような機能はないですし今後もサポートされる可能性は低そうです。でも、F#でちょっと真似してみたくなるよね。 shift/reset プログラミングちょっとあこがれちゃうよね。ということで、限定継続(風)モナドを作って F#でshift/reset プログラミングの雰囲気を感じてみましょう。



限定継続(風)モナド
ここで示すモナドはまぎれもなくモナドであるし、限定継続を意識した shift/reset なスタイルでプログラミングをすることができるようになるけど、いわゆるcall/cc的なことはしていませんので厳密には限定継続とは言えないので、限定継続(風)であるということに注意してください。F#でのモナド表現には、コンピューテーション式および、とてもCoolなライブラリFSharpxを利用しました。

namespace Monad.DCont

// 限定継続()モナド
[<AutoOpen>]
module DCont =
  open FSharpx

  type DCont<'a,'b,'c> = DCont of (('c -> 'a) -> 'b) 

  let dcontreturn x = fun k -> k x
  let shift f = fun k -> f (fun s -> dcontreturn <| k s) id

  type DContBuilder() =
    member this.Return(x) = dcontreturn x
    member this.ReturnFrom(m) = m
    member this.Bind(m, bind) =
      fun k -> m <| fun s -> bind s k 
    member this.Zero() = shift(fun _ -> id)
    member this.Combine(c1, c2) = this.Bind(c1, fun _ -> c2)
    member this.Delay(f) = f()
    member this.For(seq, f) = 
      Seq.fold
        (fun cc elem -> this.Combine(cc, f elem))
        (f <| Seq.head seq) <| Seq.skip 1 seq

  let reset = DContBuilder()
  let runDCont (f) = f id

  open Operators
  let inline returnM x = returnM reset x 
  let inline (>>=) m f = bindM reset m f
  let inline (=<<) f m = bindM reset m f
  let inline (<*>) f m = applyM reset reset f m
  let inline ap m f = f <*> m
  let inline map f m = liftM reset f m
  let inline (<!>) f m = map f m
  let inline lift2 f a b = returnM f <*> a <*> b
  let inline ( *>) x y = lift2 (fun _ z -> z) x y
  let inline ( <*) x y = lift2 (fun z _ -> z) x y
  let inline (>>.) m f = bindM reset m (fun _ -> f)
  let inline (>=>) f g = fun x -> f x >>= g
  let inline (<=<) x = flip (>=>) x

  let dcont f = fun x -> returnM <| f x 
  let shift' k = fun x -> 
    reset { let! a = k x
            return a}


モナド則の確認とか

namespace MonadicRetry.Test
open System

[<AutoOpen>]
module Tests = 
  open NUnit.Framework
  open FsUnit
  open Monad.DCont
      
  [<TestFixture>]
  type ``モナド関連確認`` () =
    let x = 1
    let m = reset { return 8 }
    let f x = reset { return 4 + x }
    let g x = reset { return 3 * x }

    let assertEqual (left, right) = 
      reset {let! a1 = left
             let! a2 = right
             let r = (a1 |> should equal (a2))
             printfn "%s" (sprintf "%d = %d , Result :%b" a1 a2 ((a1) = (a2)))
             return fun () -> 0} |> runDCont |> ignore

    let (==) left right = assertEqual (left, right)

    [<Test>] 
    // モナド則1: return x >>= f == f x
    member test.``01.モナド則1`` () =
      returnM x >>= f == f x 

    [<Test>] 
    // モナド則2: m >>= return == m
    member test.``02.モナド則2`` () =
      let m' = m >>= returnM
      m' == m

    [<Test>] 
    // モナド則3: (m >>= f) >>= g == m >>= (\x -> f x >>= g)
    member test.``03.モナド則3`` () =
      (m >>= f) >>= g == (m >>= (fun x -> f x >>= g))

    // Functor(関手)
    [<Test>] 
    //fmap id == id
    member test.``04.関手:functor1`` () =
      map id m == m

    [<Test>] 
    //fmap (f.g) == fmap f . fmap g
    member test.``05.関手:functor2`` () =
      let f x = x * 2 
      let g x = x + 2 
      m |> map (f >> g) == (m |> (map f >> map g))

    [<Test>] 
    // fmap :: (a -> b) -> f a -> f b
    // fmap f m == m >>= return . f
    member test.``06.関手:functor3`` () =
      let f x = x * 2 
      (map f m) == (m >>= (f >> returnM))

    // アプリカティブ: f <!> m1 <*> m2 == m1 >>= fun x -> m2 >>= fun y -> return f x y
    [<Test>] 
    member test.``07.アプリカティブ:applicative1`` () =
      let f x y = x * 2 + y * 2
      let m1 = reset { return 6 }
      let m2 = reset { return 9 }
      f <!> m1 <*> m2 == reset { let! a = m1
                                 let! b = m2
                                 return f a b }

    [<Test>] 
    member test.``08.アプリカティブ:applicative2`` () =
      let f x y z = x * 2 + y * 2 - z
      let m1 = reset { return 6 }
      let m2 = reset { return 9 }
      let m3 = reset { return 20 }
      f <!> m1 <*> m2 <*> m3 == reset { let! a = m1
                                        let! b = m2
                                        let! c = m3
                                        return f a b c}

    // Kleisli[<Test>] 
    member test.``09.クライスリ圏:kleisli composition1`` () =
      let x = 10
      let f x = 
          if x > 5
              then reset { return "hello" }
              else reset { return "world" }
      let g x =
          if x = "hello"
              then reset { return 777 }
              else reset { return 0 }
      (f x >>= g) == (f >=> g <| x)

  // nunit-gui-runner
  let main () = NUnit.Gui.AppEntry.Main([|System.Windows.Forms.Application.ExecutablePath|]) |> ignore
  main ()


ホンモノの限定継続モナドは、きっと腕の立つF#マスター達が実装してくれるんじゃないかな。期待しましよう。



限定継続(風)モナドを利用してみる

さっそく利用してみる。さきほどのScalaの限定継続の例を、限定継続(風)モナドをつかって、F#で書いてみます。

reset {let! a = shift(fun k -> k 10) 
       return a + 1 } 
|> runDCont |> printfn "%d"


意図通りに、11って出力される。コンピューテーション式でモナドを表現しているので、根本的には違うものの割とScalaと似たようなスタイルで記述できていい感じ。なんとなく雰囲気が醸し出せているね。雰囲気重視だよ!!!



限定継続(風)モナドで四天王問題


元ネタ
Scalaの限定継続で四天王問題を解いてみた - papamitra
http://d.hatena.ne.jp/papamitra/20100912/continuations


おお、あの四天王問題ですか。限定継続でAbmへの応用とかって面白いですね。



四天王問題

A「Dがやられたようだな…」B「ククク…奴は我ら四天王の中でも最弱…」C「私はBよりも弱い…」A「そして私は最強ではない…」B「四天王の中に私よりも弱いものが最低でも二人いる…」C「私はAよりも強い…」 ※以上の条件から四天王を強い順に並べよ(5点)


これを限定継続(風)モナドでF#で書くとこう

namespace TheBigFourProblem

module Program =
  open System
  open Monad.DCont
  open Monad.DCont.Amb

  let abcd () =
    reset {
      let numbers = [1;2;3;4]
      let! a = amb numbers
      let! b = amb numbers
      let! c = amb numbers
      let! d = amb numbers

      // 同じ強さではないことを仮定
      do! distinct [a;b;c;d] |> require

      // ADがやられたようだな…」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

      // // ADがやられたようだな…」B「ククク…奴は我ら四天王の中でも最弱…」
      do! ((bt && d = 4) || (bt |> not && d = 4 |> not)) |> require

      // C「私はBよりも強い」
      do! ((ct && c < b) || (ct |> not &&  b < c))  |> require

      // A「私は最強ではないが最弱でもない」
      do! ((at &&  (a = 1 |> not && a = 4 |> not)) || (at |> not && (a = 1 || a = 4))) |> require

      // B「私はAより強いぞ」
      do! ((bt && b < a) || (bt |> not && a < b)) |> require

      // C「四天王NO.3は嘘つき」
      do! (c = 3 |> not) |> require
      do! ((ct && ((at |> not && a=3) || (bt |> not && b=3) || (dt |> not && d=3))) || (ct |> not && ((at && a=3) || (bt && b=3) || (dt && d=3))))  |> require

      // A「私とCとの実力差は離れている」
      // 順位が隣合っていないと解釈する.
      do! ((at && (abs(a-c) = 1 |> not)) || (at |> not && (abs(a-c) = 1))) |> require

      // ※以上の条件から四天王ABCDを強い順に並べよ
      printfn "%s" <| sprintf "A:%A,B:%A,C:%A,D:%A" (a,at) (b,bt) (c,ct) (d,dt)
    } 

  abcd2 ()
  |> runDCont
  |> ignore

実行結果

A:(1, false),B:(4, false),C:(2, true),D:(3, false)


ちゃんと、四天王の強さの順番と、C以外は嘘つきであるという結果が導きだせましたね!




おまけ:ダイハード3のやつ
なんだか、非決定計算の問題を解くのが面白くなってきちゃったので、せっかくなので限定継続(風)モナドでどんどん解いていきます。


まずは、ダイハード3で出題された3ガロンと5ガロンの容器で4ガロンを量るってやつ。いわゆる、水差し問題とゆーやつですね。
これは、わざわざプログラミングで解くまでもないなぞなぞレベルの問いですが、書いてみます。

namespace PitcherProblem

module Program =
  open System
  open Monad.DCont
  open Monad.DCont.Amb

  // ダイハード3の 3ガロンと5ガロンの水差し問題
  let maxa = 5
  let maxb = 3

  let geta state = fst state
  let getb state = snd state

  let private action =
    [ // Aを満杯にする
      fun state -> maxa, getb state;
      // Aを空にする
      fun state -> 0, getb state;
      // AからBへ移す
      fun state -> 
        let a = geta state
        let b = getb state
        let w = maxb - b
        if a <= w then
          // 全部移しきった場合
          0, a + b
        else
          // Aに水が残る場合
          a - w, b + w;

      // Bを満杯にする
      fun state -> geta state, maxb;
      // Bを空にする
      fun state -> geta state, 0;
      // BからAへ移す
      fun state ->
        let a = geta state
        let b = getb state
        let w = maxa - a
        if b <= w then
          // 全部移しきった場合
          a + b, 0
        else
          // Aに水が残る場合
          a + w, b - w; ]
 
  let private solve answer = 
    let rec solve' n answer move =
      let x = (List.length move) - 1
      let prev = move.Item x 
      reset {
        if n = 0 && prev |> fst = answer || prev |> snd = answer then
            return! shift(fun k -> k move)
        else
            let! act = amb action
            let newstate = act prev
            let contains s list = List.exists(fun x -> x = s) list
            if prev = newstate || contains newstate move then
              return! shift(fun _ -> returnM move)
            else
              return! solve' (n-1) answer (move@[newstate]) }

    let m = List.length action
    solve' m answer [(0,0)]

  let pitcherProblem answer =
    let result = ref []
    reset {
      let! xs = solve answer
      result := !result@[xs]
      return xs
    } |> runDCont |> ignore
    !result

  pitcherProblem 4
  |> fun x -> x |> Seq.iter (printfn "%A")
              printfn "%s" <| sprintf "%d通り" x.Length


おまけ:地図の塗り分け

いかなる地図も、隣接する領域が異なる色になるように塗るには4色あれば十分DAZEという、いわゆる四色定理とゆーやつ。
実際に塗り分けしてみよう。

namespace ColorMapProblem

module Program =
  open System
  open Monad.DCont
  open Monad.DCont.Amb

  let colorMapProblem () =
    reset {
      let colors = ["red";"yellow";"green";"blue"]
      let! p = amb colors // Portugal:ポルトガル
      let! e = amb colors // Spain:スペイン
      let! f = amb colors // France:フランス
      let! b = amb colors // Belgium:ベルギー
      let! h = amb colors // Holland:オランダ
      let! g = amb colors // Germany:ドイツ
      let! l = amb colors // Luxemb:ルクセンブルク
      let! i = amb colors // Italy:イタリア
      let! s = amb colors // Switz:スイス
      let! a = amb colors // Austria:オーストリア

      let notcontains s list = List.exists(fun x -> x = s) list |> not
      // ポルトガルは、[スペイン]の色と違うよ
      do! notcontains p [e] |> require
      // スペインは、[フランス;ポルトガル]の色と違うよ
      do! notcontains e [f;p] |> require
      // 以下コメント略
      do! notcontains f [e;i;s;b;g;l] |> require
      do! notcontains b [f;h;l;g] |> require
      do! notcontains h [b;g] |> require
      do! notcontains g [f;a;s;h;b;l] |> require
      do! notcontains l [f;b;g] |> require
      do! notcontains i [f;a;s] |> require
      do! notcontains s [f;i;a;g] |> require
      do! notcontains a [i;s;g] |> require

      // 4色で塗り分ける組み合わせ
      printfn "%s" <| sprintf "Portugal:%s,Spain:%s,France:%s,Belgium:%s,Holland:%s,Germany:%s,Luxemb:%s,Italy:%s,Switz:%s,Austria:%s" p e f b h g l i s a
    } 

  colorMapProblem ()
  |> runDCont
  |> ignore


想像以上に塗り分けれるね!



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

いわゆる川渡り問題。

オオカミとヤギを連れキャベツを持った農夫が川岸にいる。川にはボートがあるが農夫の他には動物一頭かキャベツ一玉しか乗せられない。農夫がいなければオオカミはヤギを襲うし、ヤギはキャベツを食べてしまう。すべてを無事に対岸に渡すにはどうしたらよいか?

namespace FarmerGoatWolfCabbage

module Program =
  open System
  open Monad.DCont
  open Monad.DCont.Amb

  type Position = 
    | Left of Kind 
    | Right of Kind
  and Kind =
    | Farmer
    | Goat
    | Wolf 
    | Cabbage
  
  let swap = function | Left x -> Right(x) | Right x -> Left(x)
  let init = Left(Farmer), Left(Goat), Left(Wolf), Left(Cabbage)
  let ans = Right(Farmer), Right(Goat), Right(Wolf), Right(Cabbage)
  
  let (==) x y =
    match x,y with
    | Left _, Left _   -> true
    | Right _, Right _ -> true
    | _,_ -> false

  let private action =
    [ 
      // 農夫のみ移動
      fun state -> let f, g, w, c = state
                   swap f, g, w, c;
      // 農夫とヤギ
      fun state -> let f, g, w, c = state
                   swap f, swap g, w, c;
      // 農夫と狼
      fun state -> let f, g, w, c = state
                   swap f, g, swap w, c;
      // 農夫とキャベツ
      fun state -> let f, g, w, c = state
                   swap f, g, w, swap c;
      ]

  let safe state =
    let safegote = 
      let f,g,w,c = state
      if f == g then true
      else g == w |> not
    let safecabbage = 
      let f,g,w,c = state
      if f == c then true
      else g == c |> not
    safegote && safecabbage

  let private solve () = 
    let rec solve' move =
      let x = (List.length move) - 1
      let prev = move.Item x 
      reset {
        if prev = ans then
            return! shift(fun k -> k move)
        else
            let! act = amb action
            let newstate = act prev
            let contains s list = List.exists(fun x -> x = s) list
            if prev = newstate then  
              return! shift(fun _ -> returnM move)
            elif contains newstate move then
              return! shift(fun _ -> returnM move)
            elif  (safe newstate |> not) then
              return! shift(fun _ -> returnM move)
            else
              return! solve' (move@[newstate]) }

    let m = List.length action
    solve' [init]

  let farmerGoatWolfCabbageProblem () =
    let result = ref []
    reset {
      let! a = solve ()
      result := a
      return a
    } |> runDCont |> ignore
    !result

  farmerGoatWolfCabbageProblem ()
  |> fun x -> x |> Seq.iter(fun x ->
    let f,g,w,c = x
    let result = [f;g;w;c]
    printf "["
    result |> Seq.filter (fun x -> x |> function | Left _ -> true | _ -> false) 
           |> Seq.map (fun x -> x |> function | Left x -> x | Right x -> x)  
           |> Seq.iter (printf "%A;" )
    printf "] : "

    printf "["
    result |> Seq.filter (fun x -> x |> function | Right _ -> true | _ -> false) 
           |> Seq.map (fun x -> x |> function | Left x -> x | Right x -> x)  
           |> Seq.iter (printf "%A;")
    printfn "]"
    )


実行結果

[Farmer;Goat;Wolf;Cabbage;] : []
[Wolf;Cabbage;] : [Farmer;Goat;]
[Farmer;Wolf;Cabbage;] : [Goat;]
[Wolf;] : [Farmer;Goat;Cabbage;]
[Farmer;Goat;Wolf;] : [Cabbage;]
[Goat;] : [Farmer;Wolf;Cabbage;]
[Farmer;Goat;] : [Wolf;Cabbage;]
[] : [Farmer;Goat;Wolf;Cabbage;]


わーい、無事に川を渡れたよ!



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

今度はちょっと趣向を変えて。書いているうちに、だんだんshift/reset スタイルなプログラミングに慣れてきたかもな気がするよ!

namespace PermutationAndCombination

module Program =
  open System
  open Monad.DCont
  open Monad.DCont.Amb

  let rec private selections n m lst result =
    let contains s list = List.exists(fun x -> x = s) list
    reset {
      if m = 0 || lst = [] then
        return! shift(fun k -> k result)
      else
        return! reset {
          let! x = amb [0..n-1]
          if contains (lst.Item x) result then
            return! shift(fun _ -> returnM result)
          else
            return! selections n (m-1) lst (result@[lst.Item x])}
    }  

  // 順列
  let permutations m lst =
    let n = List.length lst
    let result = ref []
    reset {
      let! xs = selections n m lst []
      xs.Length = m |> function 
        | false -> ()
        | true -> result := !result@[xs]
      return xs
    } |> runDCont |> ignore
    !result

  permutations 4 ['A'..'F']
  |> fun x -> x |> Seq.iter (printfn "%A")
              printfn "%s" <| sprintf "%d通り" x.Length


  // 組み合わせ
  let combinations m (lst: 'a list) =
    let n = List.length lst
    let contains r sourece = 
      sourece |> Seq.map  (fun x -> (set x, set r) ||> Set.difference = Set.empty)
              |> Seq.exists id

    let result = ref []
    reset {
      let! xs = selections n m lst []
      contains xs !result |> function
      | true   -> ()
      | false  -> result := !result@[xs]
      return xs
    } |> runDCont |> ignore
    !result

  combinations 4 ['A'..'F']
  |> fun x -> x |> Seq.iter (printfn "%A")
              printfn "%s" <| sprintf "%d通り" x.Length


なんか、おまけの方が多くなっちゃいましたね。てへぺろ☆(・ω<)
Amb以外の応用例も書くつもりでしたが、積みゲー消化したいのでそれはまた別の機会に。たぶん。