Adding Joinad/Idiom F# examples for http://tomasp.net/blog/fsharp-var…

…iations-joinads.aspx

Blog 2011/Joinads/Futures.fsx

@@ -0,0 +1,97 @@
+#nowarn "26"
+open System
+open System.Threading
+open System.Threading.Tasks
+
+// --------------------------------------------------------------------------------------
+// Computation for Futures
+// --------------------------------------------------------------------------------------
+
+module Futures = 
+
+  // Implementation of joinad operations for working with tasks
+
+  let run f = f()
+  let delay f = f
+  let unit v = Task.Factory.StartNew(fun () -> v)
+  let bind f (v:Task<_>) = 
+    v.ContinueWith(fun (v:Task<_>) ->
+      let task : Task<_> = f(v.Result)
+      task).Unwrap()
+  let merge t1 t2 = 
+    t1 |> bind (fun v1 ->
+      t2 |> bind (fun v2 -> unit (v1, v2)))
+  let choose (t1:Task<'a>) (t2:Task<'a>) : Task<'a> = 
+    let tok = new CancellationTokenSource()
+    Task.Factory.ContinueWhenAny
+      ( [| t1 :> Task; t2 :> Task |],
+        (fun (t:Task) -> 
+            let res = (t :?> Task<'a>).Result
+            tok.Cancel()
+            res ),
+        tok.Token)
+  let fail () = 
+    let never = 
+      { new IAsyncResult with
+          member x.AsyncState = null
+          member x.AsyncWaitHandle = new AutoResetEvent(false) :> WaitHandle
+          member x.CompletedSynchronously = false
+          member x.IsCompleted = false }
+    Task.Factory.FromAsync(never, fun _ -> failwith "!") 
+
+  // Definition of the computation builder
+
+  type FutureBuilder() =
+    member x.Return(a) = unit a
+    member x.Bind(v, f) = bind f v
+    member x.Merge(f1, f2) = merge f1 f2
+    member x.Choose(f1, f2) = choose f1 f2
+    member x.Fail() = fail()
+    member x.Delay(f) = delay f
+    member x.Run(t) = run t
+
+  let future = new FutureBuilder()
+
+// --------------------------------------------------------------------------------------
+/// Examples of working with futures
+// --------------------------------------------------------------------------------------
+
+module FutureTests = 
+  open Futures
+
+  // Helper function for creating simple delayed tasks
+  let after t v = 
+    Task.Factory.StartNew(fun () -> 
+      Thread.Sleep(t:int)
+      v)
+
+  // Using applicative style for running two tasks in parallel
+  let f1 = future {
+    let! a = after 2000 1 
+    and b = after 2000 2
+    return a + b }
+
+  printfn "Result: %A" f1.Result
+
+  // Parallel OR 
+  let f2 = future {
+    match! after 10000 true, after 100 true with
+    | !true, _ -> return true
+    | _, !true -> return true
+    | !b1, !b2 -> return b1 || b2 }
+
+  printfn "Result: %b" f2.Result
+
+
+  // Classical joinads example - multiplying with shortcircuiting
+  // (Note: side-effects are only executed for the selected clause)
+  let f3 = future {
+    match! after 2000 10, after 500 0 with
+    | !0, _  -> printfn "(in 1)"
+                return "t1 returned 0"
+    | _, !0  -> printfn "(in 2)"
+                return "t2 returned 0"
+    | !a, !b -> printfn "(in 3)"
+                return sprintf "multiplied: %d" (a * b) }
+
+  printfn "Result: %A" f3.Result

Blog 2011/Joinads/Maybe.fsx

@@ -0,0 +1,64 @@
+#nowarn "26"
+// --------------------------------------------------------------------------------------
+
+type MaybeBuilder() =
+  // Standard monadic 'bind', 'return' and 'zero'
+  member x.Bind(v, f) = Option.bind f v
+  member x.Return(a) = Some a
+  member x.ReturnFrom(o) = o
+  member x.Fail() = None
+
+  // Combine two options into option of tuple 
+  member x.Merge(v1, v2) = 
+    match v1, v2 with
+    | Some a, Some b -> Some (a, b)
+    | _ -> None
+  // Return first option that contains value
+  member x.Choose(v1, v2) = 
+    match v1 with 
+    | Some(v1) -> Some(v1) 
+    | _ -> v2
+
+  // Creating & executing delayed computations
+  member x.Delay(f) = f
+  member x.Run(f) = f()
+
+// Create an instance of the computation builder
+let maybe = new MaybeBuilder()
+
+// --------------------------------------------------------------------------------------
+
+/// Logical 'or' operator for ternary (Kleene) logic
+let kleeneOr a b = maybe {
+  match! a, b with
+  | !true, _ -> return true
+  | _, !true -> return true 
+  | !a, !b -> return a || b }
+
+// Print truth table for the ternary operator
+for a in [Some true; None; Some false] do
+  for b in [Some true; None; Some false] do
+    printfn "%A or %A = %A" a b (kleeneOr a b)
+
+// --------------------------------------------------------------------------------------
+
+let a = Some true
+let b = Some true
+
+// Translation of individual clauses - inputs are combined 
+// using 'Merge' and body is wrapped using 'Delay'
+let cl1 = maybe.Bind(a, function 
+  | true -> maybe.Return(maybe.Delay(fun () -> maybe.Return(true)))
+  | _ -> maybe.Fail() )
+let cl2 = maybe.Bind(b, function 
+  | true -> maybe.Return(maybe.Delay(fun () -> maybe.Return(true)))
+  | _ -> maybe.Fail() )
+let cl3 = maybe.Bind(maybe.Merge(a, b), fun (a, b) -> 
+  maybe.Return(maybe.Delay(fun () -> maybe.Return(true))))
+
+// Clauses are combined using 'Choose' and selected
+// delayed clause is then evaluated using 'Run'
+maybe.Bind(maybe.Choose(maybe.Choose(cl1, cl2), cl3), fun r -> 
+  maybe.Run(r))
+
+// --------------------------------------------------------------------------------------

Blog 2011/Joinads/ZipListIdiom.fsx

@@ -0,0 +1,42 @@
+// --------------------------------------------------------------------------------------
+
+type ZipList() = 
+  // Unit of ZipList idiom is infinite sequence of values
+  member x.Return(a) = seq { while true do yield a }
+  // Standard projection for sequences
+  member x.Select(v, f) = Seq.map f v
+  // Zip values from two (possibly infinite) sequences
+  member x.Merge(u, v) = Seq.zip u v
+
+// Create instance of the computation builder
+let zip = ZipList()
+
+// --------------------------------------------------------------------------------------
+
+let rec transpose (matrix) = zip {
+  if Seq.length matrix = 0 then 
+    // Generate infinite sequence of empty lists
+    return Seq.empty
+  else 
+    // Zip elements of the first row with rows of recursively 
+    // transposed sub-matrix starting from the second row
+    let! xs = Seq.head matrix
+    and xss = transpose (Seq.skip 1 matrix)
+    return Seq.concat [ seq [ xs ]; xss ] }
+
+
+// Gives: [ [ 1; 4]; [2; 5]; [3; 6] ]
+transpose [ [ 1; 2; 3]; [ 4; 5; 6 ] ]
+
+// --------------------------------------------------------------------------------------
+
+let rec transpose (matrix) = 
+  // Two branches of 'if' are translated separately
+  if Seq.length matrix = 0 then 
+    zip.Return(Seq.empty)
+  else 
+    // Combine inputs using 'Merge' and then use 
+    // 'Select' to implement projection
+    zip.Select
+      ( zip.Merge(Seq.head matrix, transpose (Seq.skip 1 matrix)),
+        fun (xs, xss) -> Seq.concat [ seq [ xs ]; xss ])