Create a gist now

Instantly share code, notes, and snippets.

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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment