gistfile1.fs

open System
open System.Collections.Generic
open System.Threading
open System.Windows.Forms
open System.Drawing

module CpsSample1 =

  let f1 a0 (continuation : _ -> unit) = continuation (2 * a0)
  let f2 a1 (continuation : _ -> unit) = continuation (a1 + 1)
  let f3 a2 (continuation : _ -> unit) = continuation (-a2)

  let main () =
    let a0 = 3
    f1 a0 (fun a1 ->
    f2 a1 (fun a2 ->
    f3 a2 (fun a3 -> printfn "a3 = %d" a3)))


module CpsSample2 =

  type Callback<'a> = 'a -> unit
  type Cont<'a> = Callback<'a> -> unit

  let f1 a0 : Cont<_> = fun continuation -> continuation (2 * a0)
  let f2 a1 : Cont<_> = fun continuation -> continuation (a1 + 1)
  let f3 a2 : Cont<_> = fun continuation -> continuation (-a2)

  let main1 () =
    let a0 = 3
    f1 a0 (fun a1 ->
    f2 a1 (fun a2 ->
    f3 a2 (fun a3 -> printfn "a3 = %d" a3)))


  // f1 と f2 をくっつける
  let f12  a0 : Cont<_> = fun continuation -> f1  a0 (fun a1 -> f2 a1 continuation)

  let main2 () =
    let a0 = 3
    f12 a0 (fun a2 ->
    f3  a2 (fun a3 -> printfn "a3 = %d" a3))
    

  // f12 と f3 をくっつける
  let f123 a0 : Cont<_> = fun continuation -> f12 a0 (fun a2 -> f3 a2 continuation)

  let main3 () =
    let a0 = 3
    f123 a0 (fun a3 -> printfn "a3 = %d" a3)


  (* 「くっつける」操作だけを取り出した関数 *)
  let bind (f : 'a1 -> Cont<'a2>) (x : Cont<'a1>) : Cont<'a2> =
    fun (continuation : Callback<'a2>) ->
      x (fun a1 -> f a1 continuation) 

  let main4 () =
    let a0 = 3

    (* bind を使うと呼び出し側のコードはこうなる *)
    let a1 = f1 a0
    let a2 = bind f2 a1
    let a3 = bind f3 a2
    a3 (fun a3 -> printfn "a3 = %d" a3)

    (* パイプライン演算子を使うとこうなる *)
    (f1 a0 |> bind f2 |> bind f3) (fun a3 -> printfn "a3 = %d" a3)


////////////////////////////////////////////////////////////////////////////


type Callback<'a> = Callback  of ('a -> unit)
type Cont<'a>     = Cont      of (Callback<'a> -> unit)

module Cont =

  let inline run (Cont invoke) = invoke (Callback (fun () -> ()))

  let inline bind binder (Cont invoke) =
    Cont <| fun callback ->
      invoke <| Callback (fun a -> let (Cont invoke) = binder a in invoke callback)

  let inline map mapping (Cont invoke) =
    Cont <| fun (Callback callback) ->
      invoke <| Callback (fun a -> mapping a |> callback)

  let inline ofFun f =
    Cont <| fun (Callback callback) -> f () |> callback

  let inline ofValue x =
    Cont <| fun (Callback callback) -> callback x

  let inline ofOption x =
    Cont <| fun (Callback callback) -> x |> Option.iter callback

  let inline guard condition =
    Cont <| fun (Callback callback) -> if condition then callback ()

  let ofAsync (cts : CancellationTokenSource) computation =
    Cont <| fun (Callback callback) ->
      let con = SynchronizationContext.Current
      let cts = if cts = null then new CancellationTokenSource () else cts
      Async.StartWithContinuations (
        async {
          do! Async.SwitchToThreadPool ()
          return! computation cts.Token
        },
        (fun a -> con.Post ((fun _ -> callback a), null)), ignore, ignore, cts.Token)

  let ofObservable o =
    Cont <| fun (Callback callback) ->
      let subscr  = ref Option<IDisposable>.None
      subscr := o |> Observable.subscribe (fun a ->
        callback a
        !subscr |> Option.iter (fun d -> d.Dispose (); subscr := None)) |> Some

  type Builder () =
    member __.Bind (x, f)  = x |> bind f
    member __.ReturnFrom x = x
    member __.Return x  = ofValue x
    member __.Zero ()   = ofValue ()

    // Delay と Run はコンピュテーション式の評価を遅延させるための仕掛け
    member __.Delay f = f
    member __.Run   f = ofValue () |> bind f

    // Combine は例えば if による条件分岐の後に続けて処理を書きたいときに必要になる
    // - x の後に「継続」して f を実行する。その際、x の結果の値は無視する。
    // - 第二引数の f が関数なのは Delay によって処理が遅延されているから（たぶん…）
    member __.Combine (x, f) = x |> bind (fun _ -> f ())

    // use 構文が使えるようにする。
    // f x で得られる計算処理の終了時に x.Dispose () を呼べば良いはず。
    // しかし例外が起きた時には対応できていない。
    member __.Using (x: #IDisposable, f : _ -> Cont<_>) =
      Cont <| fun (Callback callback) ->
        let (Cont invoke) = f x
        invoke <| Callback (fun a -> x.Dispose(); callback a)


let cont = Cont.Builder ()

////////////////////////////////////////////////////////////////////////////

[<EntryPoint>]
let main argv = 
  CpsSample1.main ()
  CpsSample2.main1 ()
  CpsSample2.main2 ()
  CpsSample2.main3 ()
  CpsSample2.main4 ()

  let form =
    let form = new Form ()

    // drawObjs に描画関数を登録しておくと form に描画される仕組み
    let drawObjs = List<Graphics -> unit> ()
    form.Paint |> Event.add (fun e -> for draw in drawObjs do draw e.Graphics)

    // 2点クリックして直線作図（普通のイベントハンドラによる実装）
    let menuDrawLine1 = new ToolStripMenuItem "draw line (by event handler)"
    menuDrawLine1.Click |> Observable.add (fun _ ->
      let firstPos = ref None
      let subscription = ref Option<IDisposable>.None
      subscription :=
        form.MouseClick |> Observable.subscribe (fun e ->
          match !firstPos with
          | None -> firstPos := Some e.Location
          | Some p ->
            drawObjs.Add (fun g -> g.DrawLine (Pens.Blue, p, e.Location))
            form.Invalidate ()
            !subscription |> Option.iter (fun d -> d.Dispose ())
            subscription := None
            firstPos := None
        ) |> Some)

    // 2点クリックして直線作図（継続モナドによる実装）
    let menuDrawLine2 = new ToolStripMenuItem "draw line (by cont monad)"
    menuDrawLine2.Click |> Observable.add (fun _ ->
      cont {
        let! click1 = form.MouseClick |> Cont.ofObservable
        let! click2 = form.MouseClick |> Cont.ofObservable
        drawObjs.Add (fun g -> g.DrawLine (Pens.Orange, click1.Location, click2.Location))
        form.Invalidate ()
      } |> Cont.run)

    // モードレスダイアログを表示させた後に「継続」してメッセージボックスを表示
    let menuModelessDialog = new ToolStripMenuItem "modeless dialog"
    menuModelessDialog.Click |> Observable.add (fun _ ->
      cont {
        let dialog = new Form (Text = "dialog")
        let! _ =
          let btnOK = new Button (Text = "OK")
          dialog.Controls.Add btnOK
          dialog.Show ()
          btnOK.Click |> Cont.ofObservable
        dialog.Close ()
        MessageBox.Show "OK" |> ignore
        return ()
      } |> Cont.run)

    // 非同期計算をした後に「継続」してメッセージボックスを表示
    let progressBar = new ProgressBar (Dock = DockStyle.Bottom)
    let menuAsyncCalc = new ToolStripMenuItem "async calc"
    menuAsyncCalc.Click |> Observable.add (fun _ ->
      cont {
        let ui = SynchronizationContext.Current
        let! result = Cont.ofAsync null (fun token ->
          async {
            for i = 1 to 10 do
              Thread.Sleep 100
              printf "."
              ui.Post ((fun _ -> progressBar.Value <- progressBar.Maximum * i / 10), null)
            return "Async calculation result"
          })
        MessageBox.Show result |> ignore
        progressBar.Value <- 0
      } |> Cont.run)

    // 上で定義したサンプルを全部ちゃんぽんしたもの
    let menuChanpon = new ToolStripMenuItem "全部ちゃんぽん"
    menuChanpon.Click |> Observable.add (fun _ ->
      cont {
        // クリックイベントを取得
        let! click = form.MouseClick |> Cont.ofObservable
        printfn "clicked: Location = %A" click.Location

        // モードレスダイアログを表示
        let dialog = new Form (Text = "dialog")
        let! _ =
          let btnOK = new Button (Text = "OK")
          dialog.Controls.Add btnOK
          dialog.Show ()
          btnOK.Click |> Cont.ofObservable
        dialog.Close ()

        // 非同期計算
        let ui = SynchronizationContext.Current
        do! Cont.ofAsync null (fun _ ->
          async {
            for i = 1 to 10 do
              Thread.Sleep 100
              ui.Post ((fun _ -> progressBar.Value <- progressBar.Maximum * i / 10), null)
          })

        // 最後にメッセージを表示
        MessageBox.Show "done" |> ignore
        progressBar.Value <- 0
      } |> Cont.run)

    let menu =
      let menu = new Windows.Forms.MenuStrip ()
      let rootItem = new ToolStripMenuItem "menu"
      ignore <| menu.Items.Add rootItem
      ignore <| rootItem.DropDownItems.Add menuDrawLine1
      ignore <| rootItem.DropDownItems.Add menuDrawLine2
      ignore <| rootItem.DropDownItems.Add menuModelessDialog
      ignore <| rootItem.DropDownItems.Add menuAsyncCalc
      ignore <| rootItem.DropDownItems.Add menuChanpon
      menu
    form.Controls.Add menu
    form.Controls.Add progressBar
    form
  Application.Run form
  0