F# Transaction Monad. Examples.

Ich habe jetzt bei der Arbeit so ein Fall, wo Transaction Monad alternativ zur aktuellen Programmlogik eingesetzt werden könnte, vorausgesetzt wir verwenden F#.
Es sind zwei unterschiedliche Datenbanksysteme im Einsatz und die Programmlogik sollte für die richtige Transaktionabwicklung sorgen.
Daraus ergeben sich zwei Transaktion Fällen.

1. Innere Transaktion.

open TransactionM.Type
open TransactionM.Builder
open TransactionM.Helpers
open System.Data
open System.Data.SqlClient
open System.Threading.Tasks


type Params = {conn : SqlConnection; statements : string list; simulateCancel : bool}
type Either<'a,'b> = 
    | Result of 'a
    | Fail of 'b

let dbCommit (tr:SqlTransaction) =
    tr.Commit()
    tr

let dbRollback (tr:SqlTransaction) =
    tr.Rollback()
    tr

let beginDBTransaction (cnn:SqlConnection) cancel = 
    match cancel with
    | false -> cnn.BeginTransaction()
    | true -> failwith "error beginDBTransaction"

//check : string -> string -> string -> string -> seq<'a * 'b>
// select data from table to the seq.
let inline check dataSource db userId pswd = seq{
    let connStr =   
        new SqlConnectionStringBuilder(DataSource = dataSource,
                InitialCatalog = db, UserID = userId, Password = pswd)
    use conn = new SqlConnection(connStr.ConnectionString)
    conn.Open()
    use comm = new SqlCommand("SELECT Value1, Value2 FROM TEST_TABLE", conn)
    use reader = comm.ExecuteReader()
    while reader.Read() do
        yield unbox reader.["Value1"], unbox reader.["Value2"] }

let inline execNonQuery conn tr s=
    use comm = new SqlCommand(s, conn, tr)
    let res = comm.ExecuteNonQuery() 
    res

let inline deleteAll dataSource db userId pswd = 
    let connStr =   
        new SqlConnectionStringBuilder(DataSource = dataSource,
                InitialCatalog = db, UserID = userId, Password = pswd)
    use conn = new SqlConnection(connStr.ConnectionString)
    conn.Open()
    use comm = new SqlCommand("DELETE FROM TEST_TABLE", conn)
    comm.ExecuteNonQuery()    

//createTransaction: Params -> TransactionM<'a,'b,TransactionState<string,SqlTransaction>>
let createTransaction p =
    transaction {
                    try 
                        let tr = beginDBTransaction p.conn p.simulateCancel
                        try
                            match Seq.forall (((<) 0) << execNonQuery p.conn tr) p.statements with
                            | true -> 
                                return Commit tr
                            | false ->                
                                return Rollback tr
                        with
                        | e ->   
                            printfn " catch %A" (e.Message)
                            return Rollback tr
                    with
                        | e ->   
                            printfn " catch %A" (e.Message)
                            return Abort (Some e.Message)
                }

//createTransactionWithResult: Params -> TransactionM<'a,'b,TransactionState<string,(SqlTransaction * int)>>
let createTransactionWithResult p  = transaction {
        try 
            let tr = beginDBTransaction p.conn p.simulateCancel
            try
                let l = List.map (execNonQuery p.conn tr) p.statements
                match Seq.forall ((<) 0) l with
                | true -> 
                    return Commit (tr, List.rev l |> List.head)
                | _ ->             
                    return Rollback (tr, 0)
            with
            | e ->   
                printfn " catch %A" (e.Message)
                return Rollback (tr, 0)
        with
            | e ->   
                printfn " catch %A" (e.Message)
                return Abort (Some e.Message)

    }

//createOuterTransaction: 
//  TransactionM<'a,'b,TransactionState<'c,('d * 'e)>> -> 
//      Params -> 
//          TransactionHandle<'a,'b,TransactionState<string,(Either<SqlTransaction,'f> * Either<'d,'c option>)>> -> 
//              TransactionM<'a,'b,('g -> 'g)>
let createOuterTransaction inner parms handle =
    transaction 
        {
            try
                //begin outer DB transaction.
                let outer = (beginDBTransaction parms.conn parms.simulateCancel)
                try
                    // start statement from outer transaction. 
                    match execNonQuery parms.conn outer (parms.statements.Item 0)  with
                    | r when r > 0 -> 
                        //get inner transaction monad.
                        let! innerTransactionState = inner
                        match innerTransactionState with
                        | Commit (innerTransaction, result) -> 
                            // final statement from outer transaction.
                            match execNonQuery parms.conn outer ((parms.statements.Item 1).Replace("$$", result.ToString())) with
                            |  r when r > 0 -> 
                                //commit outer and inner transaction.
                                return! commit handle (Result outer, Result innerTransaction)
                            | _ -> 
                                return! rollback handle (Result outer, Result innerTransaction)
                        | Abort m ->
                            return! rollback handle (Result outer, Fail m)
                        | Rollback (innerTransaction, _) -> 
                            return! rollback handle (Result outer, Result innerTransaction)
                        | _ ->
                            return! rollback handle (Result outer, Fail None)
                    | _ -> 
                        return! rollback handle (Result outer, Fail None)
                with
                | e ->   
                    printfn " catch outer %A" (e.Message)
                    return! rollback handle (Result outer, Fail None)
            with
            | e ->   
                printfn " catch %A" (e.Message)
                return! abort handle (Some e.Message)
        }
//runOuterInnerTransaction : string list -> bool -> string list -> bool -> string
let runOuterInnerTransaction innerStatements innerCancel outeStatements outerCancel =
    let connStr =   
        new SqlConnectionStringBuilder(DataSource = "SOURCE1",
                InitialCatalog ="TESTDB",UserID="USER",Password="PWD")
    let connStr1 =   
        new SqlConnectionStringBuilder(DataSource = "SOURCE2",
                InitialCatalog ="TESTDB",UserID="USER",Password="PWD")
    use con = new SqlConnection(connStr.ConnectionString)
    con.Open()

    use con1 = new SqlConnection(connStr1.ConnectionString)
    con1.Open()

    let innerTr = createTransactionWithResult {conn     =       con ; 
                            statements =     innerStatements;
                            simulateCancel = innerCancel }  
    let outerTr = beginT (createOuterTransaction innerTr {conn     =       con1 ; 
                                                           statements =     outeStatements;
                                                           simulateCancel = outerCancel })
    match runTransactionState outerTr () with
    | Commit (Result outer, Result inner)-> 
        dbCommit inner |> ignore
        dbCommit outer |> ignore  
        "commit."
    | Rollback (Result outer, Result inner)-> 
        dbRollback inner |> ignore
        dbRollback outer |> ignore
        "rollback inner and outer."
    | Rollback (Result outer, Fail (Some m)) ->
        dbRollback outer |> ignore
        "rollback outer." + m
    | Rollback (Result outer, Fail None) ->
        dbRollback outer |> ignore
        "rollback outer." 
    | Rollback (Fail _, Result inner) ->
        failwith "rollback inner without outer."  
    | Abort (Some message) -> 
        message + " abort outer." 
    | Abort None ->
        "abort outer." 
    | _ -> failwith "error."

2. Parallele Transaktionen.

//parallelTasksTransaction : Params -> Params -> bool * string
let parallelTasksTransaction p1 p2 =
    let task p = Task.Factory.StartNew(fun () -> runTransactionState (createTransaction p) ())
    let tasks = [task p1; task p2] |> List.toArray
    let result = 
        Task.Factory.ContinueWhenAll(
                    tasks,
                    (fun (ts:Task<TransactionState<string, SqlTransaction>> []) -> 
                        match ts.[0].Result, ts.[1].Result with
                        | Commit t1, Commit t2 -> 
                            dbCommit t1|>ignore
                            dbCommit t2|>ignore
                            true, "commit."
                        | Commit t1, Rollback t2 -> 
                            dbRollback t1|>ignore
                            dbRollback t2|>ignore
                            false, "rollback. (commit task 1, rollback task 2)"
                        | Rollback t1, Commit t2 -> 
                            dbRollback t1|>ignore
                            dbRollback t2|>ignore
                            false, "rollback. (rollback task 1, commit task 2)"
                        | Rollback t1, Rollback t2 -> 
                            dbRollback t1|>ignore
                            dbRollback t2|>ignore
                            false, "rollback. (rollback task 1, rollback task 2)"
                        | Rollback t1, Abort (Some m) -> 
                            dbRollback t1|>ignore
                            false, "rollback. (rollback task 1, abort task 2)" + m
                        | Abort (Some m), Rollback t2 -> 
                            dbRollback t2|>ignore    
                            false, "rollback. (abort task 1, rollback task 2)." + m
                        | Commit t1, Abort (Some m) -> 
                            dbRollback t1|>ignore
                            false, "rollback. (Commit task 1, abort task 2)" + m
                        | Abort (Some m), Commit t2 -> 
                            dbRollback t2|>ignore    
                            false, "rollback. (abort task 1, Commit task 2)." + m
                        | Abort (Some m1), Abort (Some m2) ->   
                            false, "abort." + m1 + ". " + m2
                        | _ -> failwith "execution error."))
    result.Result

//runParallelTasksTransaction : string list -> bool -> string list -> bool -> bool * string
let runParallelTasksTransaction statements1 cancel1 statements2 cancel2= 
    let connStr =   
        new SqlConnectionStringBuilder(DataSource = "SOURCE1",
                InitialCatalog ="TESTDB",UserID="USER",Password="PWD")
    let connStr1 =   
        new SqlConnectionStringBuilder(DataSource = "SOURCE2",
                InitialCatalog ="TESTDB",UserID="USER",Password="PWD")
    use con = new SqlConnection(connStr.ConnectionString)
    con.Open()

    use con1 = new SqlConnection(connStr1.ConnectionString)
    con1.Open()
    parallelTasksTransaction {conn = con; statements = statements1; simulateCancel = cancel1} 
                             {conn = con1 ; statements = statements2; simulateCancel = cancel2}

Ein Paar Tests.

//test : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a -> 'b -> 'c -> 'd -> unit
let test f a b c d =
    deleteAll "SOURCE1" "TESTDB" "USER" "PWD" |>ignore
    deleteAll "SOURCE2" "TESTDB" "USER" "PWD"  |>ignore
    let res = f a b c d
    let check1 = check "SOURCE1" "TESTDB" "USER" "PWD"
    let check2 = check "SOURCE2" "TESTDB" "USER" "PWD"
    printfn "result: %A" res
    printfn "check data in db1: %A" check1
    printfn "check data in db2: %A" check2
    printfn "%s" (String.replicate 30 "+")

printfn "%s" (String.replicate 50 "-")
printfn "run inner transaction tests."
printfn "test Commit." 
test runOuterInnerTransaction ["INSERT INTO TEST_TABLE  (Value1,Value2 ) VALUES (2, 'start inner 2') ";
                               "INSERT INTO TEST_TABLE  (Value1,Value2 ) VALUES (3, 'start inner 3')";
                               "INSERT INTO TEST_TABLE  (Value1,Value2 ) VALUES (2, 'start inner 4')";
                               "UPDATE TEST_TABLE  SET Value1 = 5, Value2 ='end inner 5'  WHERE Value1 =2"] 
                              false
                              ["INSERT INTO TEST_TABLE  (Value1,Value2 ) VALUES (10, 'start outer')";
                               "INSERT INTO TEST_TABLE  (Value1,Value2 ) VALUES ($$, 'end outer. inner updated $$.') " ] 
                              false
printfn "test Rollback 1." 
test runOuterInnerTransaction ["INSERT INTO NONE"] 
                              false
                              ["INSERT INTO TEST_TABLE  (Value1,Value2 ) VALUES (10, 'outer 10')";
                               "INSERT INTO TEST_TABLE  (Value1,Value2 ) VALUES (20, 'outer 20') " ] 
                              false


printfn "test Rollback 2." 
test runOuterInnerTransaction ["INSERT INTO TEST_TABLE  (Value1,Value2 ) VALUES (2, 'inner 2') "] false
                              ["INSERT INTO TEST_TABLE  (Value1,Value2 ) VALUES (10, 'outer 10')";
                               "INSERT INTO NONE " ] false
// simulate error in BeginTransaction.
printfn "test Abort inner." 
test runOuterInnerTransaction ["INSERT INTO TEST_TABLE  (Value1,Value2 ) VALUES (2, 'inner 2') "] true
                              ["INSERT INTO TEST_TABLE  (Value1,Value2 ) VALUES (10, 'outer 10')";
                               "INSERT INTO TEST_TABLE  (Value1,Value2 ) VALUES (20, 'outer 20') " ] false
// simulate error in BeginTransaction.
printfn "test Abort outer." 
test runOuterInnerTransaction ["INSERT INTO TEST_TABLE  (Value1,Value2 ) VALUES (2, 'start inner 2') ";
                               "INSERT INTO TEST_TABLE  (Value1,Value2 ) VALUES (3, 'start inner 3')";
                               "INSERT INTO TEST_TABLE  (Value1,Value2 ) VALUES (2, 'start inner 4')";
                               "UPDATE TEST_TABLE  SET Value1 =5, Value2 ='end inner 5'  WHERE Value1 =2"] 
                              false
                              ["INSERT INTO TEST_TABLE  (Value1,Value2 ) VALUES (10, 'start outer')";
                               "INSERT INTO TEST_TABLE  (Value1,Value2 ) VALUES ($$, 'end outer. inner updated $$.') " ] 
                              true

printfn "%s" (String.replicate 50 "-")
printfn "run parallel tasks tests."
printfn "test Commit." 
test runParallelTasksTransaction 
        [for i in 0..100 -> 
            "INSERT INTO TEST_TABLE  (Value1,Value2 ) VALUES (" + i.ToString() + ", 'Task 1 (" + i.ToString() + ")')"] 
        false
        [for i in 100..150 -> 
            "INSERT INTO TEST_TABLE  (Value1,Value2 ) VALUES (" + i.ToString() + ", 'Task 2 (" + i.ToString() + ")')"] 
        false

printfn "test Rollback 1." 
test runParallelTasksTransaction 
        ["INSERT INTO NONE"] 
        false
        [for i in 100..150 -> 
            "INSERT INTO TEST_TABLE  (Value1,Value2 ) VALUES (" + i.ToString() + ", 'Task 2 (" + i.ToString() + ")')"] 
        false

printfn "test Rollback 2." 
test runParallelTasksTransaction 
        [for i in 100..200 -> 
            "INSERT INTO TEST_TABLE  (Value1,Value2 ) VALUES (" + i.ToString() + ", 'Task 1 (" + i.ToString() + ")')"] 
        false
        ["INSERT INTO NONE"] 
        false
// simulate error in BeginTransaction.
printfn "test Abort." 
test runParallelTasksTransaction 
        [for i in 0..100 -> 
            "INSERT INTO TEST_TABLE  (Value1,Value2 ) VALUES (" + i.ToString() + ", 'Task 1 (" + i.ToString() + ")')"] 
        false
        [for i in 100..150 -> 
            "INSERT INTO TEST_TABLE  (Value1,Value2 ) VALUES (" + i.ToString() + ", 'Task 2 (" + i.ToString() + ")')"] 
        true

--------------------------------------------------
run inner transaction tests.
test Commit.

result: "commit."
check data in db1: seq [(5, "end inner 5"); (3, "start inner 3"); (5, "end inner 5")]
check data in db2: seq [(10, "start outer"); (2, "end outer. inner updated 2.")]

++++++++++++++++++++++++++++++
test Rollback 1.

 catch "Falsche Syntax in der Nähe von 'NONE'."
result: "rollback inner and outer."
check data in db1: seq []
check data in db2: seq []

++++++++++++++++++++++++++++++
test Rollback 2.

 catch "Falsche Syntax in der Nähe von 'NONE'."
result: "rollback inner and outer."
check data in db1: seq []
check data in db2: seq []

++++++++++++++++++++++++++++++
test Abort inner.

 catch "error beginDBTransaction"
result: "rollback outer.error beginDBTransaction"
check data in db1: seq []
check data in db2: seq []

++++++++++++++++++++++++++++++
test Abort outer.

 catch "error beginDBTransaction"
result: "error beginDBTransaction abort outer."
check data in db1: seq []
check data in db2: seq []

++++++++++++++++++++++++++++++
--------------------------------------------------
run parallel tasks tests.
test Commit.

result: (true, "commit.")
check data in db1: seq
  [(0, "Task 1 (0)"); (1, "Task 1 (1)"); (2, "Task 1 (2)"); (3, "Task 1 (3)");
   ...]
check data in db2: seq
  [(100, "Task 2 (100)"); (101, "Task 2 (101)"); (102, "Task 2 (102)");
   (103, "Task 2 (103)"); ...]

++++++++++++++++++++++++++++++
test Rollback 1.

 catch "Falsche Syntax in der Nähe von 'NONE'."
result: (false, "rollback. (rollback task 1, commit task 2)")
check data in db1: seq []
check data in db2: seq []

++++++++++++++++++++++++++++++
test Rollback 2.

 catch "Falsche Syntax in der Nähe von 'NONE'."
result: (false, "rollback. (commit task 1, rollback task 2)")
check data in db1: seq []
check data in db2: seq []

++++++++++++++++++++++++++++++
test Abort.

 catch "error beginDBTransaction"
result: (false, "rollback. (Commit task 1, abort task 2)error beginDBTransaction
")
check data in db1: seq []
check data in db2: seq []

++++++++++++++++++++++++++++++

F# Transaction Monad.

Nachdem ich sehr interessante Beiträge über die verschiedensten F# Monads begeistert gelesen habe, überlegte ich mir, ob man so was wie eine Transaction Monad implementieren kann.
Und tatsächlich gibt es bereits eine Haskell Version. Hundertprozentig ist die Funktionsweise von der Monad für mich noch nicht klar, aber soweit ich es beurteilen kann ist die Transaktion ein Hybrid aus der Continuation und der State Monad.

Erstmal ein paar Tests:

open TransactionM
// 5 ways you can leave the monad.
// handle : transaction handle.
let test0 handle = 
    transaction {
      let! s = get
      do! set 99
      match s with
        | 0 -> return id
        | 1 -> return! abort    handle (Some s)
        | 2 -> return! dirty    handle (Some s.)
        | 3 -> return! rollback handle  "rollback!"
        | _ -> return! commit   handle  "commit"
    }
// return TransactionState<int,string> * int. second item is result of transaction.
let runTest0  = 
    let run = runTransaction_ (beginT test0)
    List.map run [0..4]

val test0 :
  TransactionM.TransactionHandle<'a,int,
                                 TransactionM.TransactionState<int,string>> ->
    TransactionM.TransactionM<'a,int,('b -> 'b)>

val runTest0 : (TransactionM.TransactionState<int,string> * int) list =

  [ (Abort null, 0); 
    (Abort (Some 1), 1); 
    (Dirty (Some 2), 99);
    (Rollback "rollback!", 3);
    (Commit "commit", 99) ]

Einfache Listenmanipulation als eine Transaktion.

// Simple list manipulation as transaction.
// p : some condition
// l : init list
// handle : transaction handle.
let testList p l handle = transaction {
        do! set l
        do! modify (fun xs-> 6::xs)
        do! modify (fun xs-> 7::xs)       
        match p  with
        | false -> return! rollback handle  "rollback!" 
        | true -> return! commit   handle   "commit."
    }
// Only if both transactions are successful then concatenate the two lists and commit all transactions.
// rollback otherwise.
// m1, m2 - transactions.
// handle : transaction handle.
let merge m1 m2 handle = 
    transaction {
            let! state1 = m1
            match state1 with
            | Commit a ->  
                let! firstList = get
                printfn "    first list: %A" firstList 

                let! state2 = m2
                match state2 with
                | Commit b   ->  
                    let! secondList = get
                    printfn "    second list: %A" secondList
                    do! set (firstList @ secondList)
                    return! commit   handle  b

                | Rollback b ->  return! rollback   handle  b
                | _          ->  return! abort      handle (Some "abort")

            | Rollback a    ->   return! rollback   handle  a                        
            | _             ->   return! abort      handle (Some "abort")
        }
//return TransactionState<string,'b> * 'c list. second item is result of transaction.
let runMerge i m1 m2 = 
    printfn "Start runMerge %A." i
    let m = beginT (merge m1 m2)
    runTransaction_ m [] 
// ls : list of list.
// return TransactionState<string,string> * int list. second item is result of transaction.
let runList ls = 
    printfn "Start runList."
    let m = List.fold (fun acc (l, p) -> beginT (merge acc (beginT (testList p l)))) (alwaysCommit "commit") ls
    runTransaction_ m []

printfn "runMerge 1: %A " (runMerge 1 (beginT (testList true  [0..3] )) (beginT (testList true  [10..13])))
printfn "runMerge 2: %A " (runMerge 2 (beginT (testList false [0..3] )) (beginT (testList true  [10..13])))

printfn "%A" (runList  [([0..3], true); ([10..13], true); ([20..23], true)])
printfn "%A" (runList  [([0..3], true); ([10..13], true); ([20..23], false)])

val testList :
  bool ->
    int list ->
      TransactionM.TransactionHandle<'a,int list,
                                     TransactionM.TransactionState<'b,string>> ->
        TransactionM.TransactionM<'a,int list,('c -> 'c)>
val merge :
  TransactionM.TransactionM<'a,'b list,TransactionM.TransactionState<'c,'d>> ->
    TransactionM.TransactionM<'a,'b list,TransactionM.TransactionState<'e,'d>> ->
      TransactionM.TransactionHandle<'a,'b list,
                                     TransactionM.TransactionState<string,'d>> ->
        TransactionM.TransactionM<'a,'b list,('f -> 'f)>
val runMerge :
  'a ->
    TransactionM.TransactionM<(TransactionM.TransactionState<string,'b> *
                               'c list),'c list,
                              TransactionM.TransactionState<'d,'b>> ->
      TransactionM.TransactionM<(TransactionM.TransactionState<string,'b> *
                                 'c list),'c list,
                                TransactionM.TransactionState<'e,'b>> ->
        TransactionM.TransactionState<string,'b> * 'c list
val runList :
  (int list * bool) list ->
    TransactionM.TransactionState<string,string> * int list

Start runMerge 1.
    first list: [7; 6; 0; 1; 2; 3]
    second list: [7; 6; 10; 11; 12; 13]
runMerge 1: (Commit "commit.", [7; 6; 0; 1; 2; 3; 7; 6; 10; 11; 12; 13]) 

Start runMerge 2.
runMerge 2: (Rollback "rollback!", []) 

Start runList.
    first list: []
    second list: [7; 6; 0; 1; 2; 3]
    first list: [7; 6; 0; 1; 2; 3]
    second list: [7; 6; 10; 11; 12; 13]
    first list: [7; 6; 0; 1; 2; 3; 7; 6; 10; 11; 12; 13]
    second list: [7; 6; 20; 21; 22; 23]
(Commit "commit.",
 [7; 6; 0; 1; 2; 3; 7; 6; 10; 11; 12; 13; 7; 6; 20; 21; 22; 23])

Start runList.
    first list: []
    second list: [7; 6; 0; 1; 2; 3]
    first list: [7; 6; 0; 1; 2; 3]
    second list: [7; 6; 10; 11; 12; 13]
    first list: [7; 6; 0; 1; 2; 3; 7; 6; 10; 11; 12; 13]
(Rollback "rollback!", [])

Interessant ist ob die Transaktionen asynchron ausgeführt werden können. Ich habe es leider nicht hingekriegt.

Hier ist meine F# Implementierung von der Transaktion Monad.

// from http://hackage.haskell.org/packages/archive/monad-tx/0.0.1/doc/html/Control-Monad-Tx.html
module TransactionM 

open System

// 'e : error type
// 'a : transaction state type
type TransactionState<'e,'a> =
    | Begin
    | Abort of ('e option)
    | Dirty of ('e option)
    | Rollback of 'a
    | Commit of 'a

// 's : state
// 'a : TransactionState
// 'r : result 
// ('s -> 'a -> 'r) : continuation
type TransactionM<'r, 's, 'a> = TransactionM of ('s -> ('s -> 'a -> 'r) -> 'r)

type TransactionHandle<'r, 's, 'a> = TransactionHandle of (('a * TransactionHandle<'r, 's, 'a>) -> TransactionM<'r, 's, unit>)

let inline runTransaction (TransactionM g) s k = g s k

// result is of type (TransactionState * state)
let inline runTransaction_ (TransactionM g) s = g s (fun s' a ->  (a, s'))
// result is of type TransactionState
let inline runTransactionState (TransactionM g) s = g s (fun _ a ->  a)

let inline withCommit f = 
    TransactionM (fun s k -> 
                    let (TransactionM g) = f (fun a -> TransactionM (fun s' _ ->  k s' a)) 
                    g s k)

let inline withRollback f = 
    TransactionM (fun s k -> 
                    let (TransactionM g) = (f (fun a -> TransactionM (fun _ _ -> k s a))) 
                    g s k)

let inline bind (TransactionM g) f = 
    TransactionM(fun s k -> 
                    g s (fun s' a ->
                            let (TransactionM g') = f a
                            g' s' k))
//computation workflow builder.
type TransactionBuilder() =
    member this.Return(a)                               = TransactionM(fun s k -> k s a) 
    member this.Bind(m, k)                              = bind m k
    member this.Zero ()                                 = this.Return ()
    member this.Combine(r1, r2)                         = this.Bind(r1, fun _ -> r2) 
    member this.ReturnFrom(m : TransactionM<_,_,_>)     = m
    member this.Delay(f)                                = this.Bind(this.Return (), f)
    
    member this.TryFinally(computation, compensation) =
        TransactionM(fun s k -> 
            try
                runTransaction computation s k
            finally
                compensation())

    member this.Using(res: #IDisposable, body) =
        this.TryFinally(body res,
            (fun () -> match res with null -> () | disp -> disp.Dispose()))

    member this.TryWith(computation, handler) =
        TransactionM(fun s k ->
            try
                runTransaction computation s k
            with e -> runTransaction (handler e) s k)

let transaction = new TransactionBuilder()

let inline bindM builder m f = (^M: (member Bind: 'd -> ('e -> 'c) -> 'c) (builder, m, f))

let inline (>>.) m n = bindM transaction m (fun _ ->  n)

let inline isBegin t =
    match t with
    | Begin -> true
    | _ -> false

let inline fmap f (TransactionM g) = TransactionM (fun s k -> g s (fun s' a -> k s' (f a)))
//begin transaction.
let inline beginT f =
    let checkpoint  = 
        withCommit (fun fcommit ->
            withRollback (fun frollback ->
                transaction {
                    let go (transactionState, handle) =
                        match transactionState with
                        | Begin         -> failwith     "nested"
                        | Abort e       -> frollback    (Abort e,       handle)
                        | Dirty e       -> fcommit      (Dirty e,       handle)
                        | Rollback a    -> frollback    (Rollback a,    handle)
                        | Commit a      -> fcommit      (Commit a,      handle)
                    return (Begin, TransactionHandle go) 
                    } ))

    withRollback (fun fabort ->
        transaction {
                    let! (transactionState, handle)  = checkpoint
                    if isBegin transactionState then
                        return!  (f  handle >>. fabort (Abort None))
                    return transactionState
                 })

//a bunch of helpers, which allow to access and manipulate transaction.

let inline alwaysCommit a = TransactionM(fun s k -> k s (Commit a))

let inline jump (TransactionHandle k) stat = 
    (k (stat, TransactionHandle k)) >>. TransactionM(fun s k -> k s id)

let inline abort    handle e = jump handle (Abort e)

let inline dirty    handle e = jump handle (Dirty e)

let inline rollback handle a = jump handle (Rollback a)

let inline commit   handle a = jump handle (Commit a)

let get = TransactionM (fun s k -> k s s)

let inline gets f = TransactionM (fun s k -> k s (f s))

let inline set s = 
    TransactionM (fun _ k -> k s ())

let inline modify f = TransactionM(fun s k -> k (f s) ())

F# Monad Transformers Library.

FML.

Funktionale Animation. Teil 4.

Teil 1.
Teil 2.
Teil 3.


Es ist soweit. Ich kann endlich eine kleine animierte Statistik generieren.
Nehmen wir an, es gibt eine Firma, die die verschiedene Produkte über Amazon verkauft. Für diese Firma wird z.B eine Statistik über Gewinn, Kosten und Amazon-Rating von einzelnen Produkten im Verlauf der Zeit erstellt.

• Gewinn - Y-Achse
• Kosten - X-Achse
• Rating - Kreisdurchmesser

Die Daten werden einfach von der Random-Funktion generiert und danach weiter interpoliert so, dass letztendlich eine Sequenz folgendes Formates herauskommt.
data: (int * string * float * float * 'color) seq

(Zeitangabe, Produktname, Gewinn, Kosten, Farbe)
oder für die Rating-Werte
(Zeitangabe, Produktname, Rating, der Feld wird ignoriert , Farbe)

Einfachheitshalber werden als Zeitangabe ausschließlich Jahreswerte angegeben, die in fortlaufenden Nummern umgewandelt werden.

[(1,"Produkt A",70.50, 64.00, Brushes.Black );
(1,"Produkt B",80.50, 144.00, Brushes.Red );
(1,"Produkt C",187.50, 54.00, Brushes.Green);
(2,"Produkt A",70.55, 106.05, Brushes.Black );
(2,"Produkt B",80.55, 44.00, Brushes.Red );
(2,"Produkt C",45.50, 54.00, Brushes.Green)]

Der Code für die Datenerstellung befindet sich hier (Data.fsx).

//Behavior.fs
module BehaviorDrawing  =
   open System.Drawing
   open Demo.Drawing
   open Demo.DrawingFunctions
   open Demo.Data
   
   ...

    //Erstellt die Daten für XY-Achsen.
    let createDataXYAxis (data: (int * string * float * float * 'a) seq) =
        behavior{
            let! createdData = 
                 filterData data 
                            (fun (_,text,posx,posy,_)->
                                 let fposx,fposy = (float32 posx),(float32 posy)
                                 text,fposx,fposy
                            )
                            (fun (text,_,_)->text)
            return createdData
        }

    //Erstellt aus der Daten die Kreise.
    let createDataCircle (data: (int * string * float * float * 'a) seq) =
        behavior{
            let! createdData = 
                 filterData data 
                            (fun (_,text,diameter,_,color)->
                                 let fdiameter = float32 diameter
                                 text, circle color fdiameter fdiameter text
                            )
                            (fun (text,_)->text)
            return createdData|>Seq.map snd
        }

    //Alles zusammenfügen.
    let dataDrawing dataXY dataCircle=
        behavior{
            let! xy = dataXY
            let! c = dataCircle
            match Seq.isEmpty xy,Seq.isEmpty c with
            |false,false-> 
                return (
                    Seq.zip xy c
                    |>Seq.map (fun ((_,fposx,fposy),circle)->
                        let moveCircle = translate fposx fposy circle        
                        let textX = drawText (fposy.ToString()) (20.0f) -fposy
                        let lineX = textX
                                    |>compose (lineDraw 40.f -fposy fposx -fposy)
                        let textY = drawText (fposx.ToString()) fposx (-20.0f)
                        let lineY = textY
                                    |>compose (lineDraw fposx -40.f fposx -fposy) 
                        Seq.fold compose moveCircle (lineX::[lineY]))
                    |>Seq.fold compose emptyDrawing)
            |_-> return emptyDrawing
        }

    //Anzeige der Jahresüberschrift.
    let animationYearText duration init =
        let year timeStep = 
            //let td = t % duration
            //let o= (td*255/duration)%255
            let year = init + (timeStep  / duration)
            ("Jahr " + (year.ToString()))
        behavior{
            let! t = time
            return  (drawText (year t) 300.f (-570.f))
        }

    let animationPart4 duration init=
       //Initialisiere die Funktion mit der Dauer und dem Startwert.
       let fInterpolation = createInterpolation duration init
       //Erstelle die Daten im angegebenen Bereich 
       //für den Kreisdurchmesser. 
       let circles = fInterpolation  20 70
       //Erstelle die Daten im angegebenen Bereich 
       //für die X- Y-Achsen.
       let xyAxis = fInterpolation  40 500
       behavior{
           //Erstelle das komplette Bild.
           let! all = 
               dataDrawing  (createDataXYAxis xyAxis) (createDataCircle circles)
           return all
           }
    let singelton=
        let one duration init = behavior{
              let! a = animationPart4 duration init//animation
              let! animYear = animationYearText duration init 
              return (compose a animYear)
              }
        one

Dequeue.fs
Data.fsx
Drawing.fs
BehaviorPart4.fsx
AnimationPart4.fsx
mainPart4.fs

Funktionale Animation. Teil 3. Like a satellite.

Teil 1
Teil 2


Als Nächstes möchte ich eine Art von einfacher Planetenbewegung simulieren. Sagen wir, drei Kreise sollen sich mit unterschiedlicher Geschwindigkeit bewegen, und jeder Kreis besitzt noch einen eigenen Satellit.

Die rotate-Funktion wird erweitert.

let rotate speed radius = behavior {
   let fast = faster speed time
   let! posx = fast|>wiggle
   let! posy = fast|>wait 0.5f|>wiggle
   return posx * radius, posy * radius
   }

Dann brauche ich eine leere Behavior-Animation.

let forever a = Behavior(fun _->a)

let emptyBehavior = forever emptyDrawing 

Wie man sieht, egal zu welchem Zeitpunkt, gibt die forever-Funktion immer den gleichen Wert zurück.
Die Komposition zweier Drawing-Werte ist bereits in Drawing.fs definiert. Zur Erinnerung:

//Drawing.fs
...
let compose (img1:Drawing) (img2:Drawing) =
    drawing(fun g ->
      img1.Draw(g)
      img2.Draw(g) )

Das Gleiches implementiere ich für die Behavior-Werte und zwar als ein Operator. Der Vorteil dabei ist, dass in F# der Operator in der Infix- und Präfixnotation geschrieben werden kann. z.B

//let sum = 1 + 2
//let sum = (+) 1 2

let (--) a b =
    behavior {
        let! x = a
        let! y = b
        return compose x y
    } 

Die Verschiebefunktion.

let rotateAndTranslate speed radius drawingBehavior =
    behavior {
        let! x,y = rotate speed radius
        let! image = drawingBehavior
        return translate x y image
    } 

Und schließlich kann die Animation-Funktion geschrieben werden.

let animationPart3 =
    let satellite = rotateAndTranslate 0.8f 45.0f<<forever<<circle Brushes.DimGray 20.0f 20.0f
    let folder (acc,count) (color, speed) =
        let planet =
            rotateAndTranslate speed 70.0f<<(--) (satellite "moon")<<forever<<circle color 40.0f 40.0f
        let result = acc -- (count.ToString()|>planet)
        result,count+1
    [(Brushes.Black,0.1f);(Brushes.OliveDrab,0.3f);(Brushes.SteelBlue,0.6f)]
    |>Seq.fold folder (emptyBehavior,1)
    |>fst

Gehen wir den Code jetzt Schritt für Schritt durch.

 let satellite = rotateAndTranslate 0.8f 45.0f<<forever<<circle Brushes.DimGray 20.0f 20.0f

Am einfachsten liest man diesen Ausdruck der Funktionskomposition von rechts nach links. (<<) ist der Funktionskomposition-Operator.

1. circle Brushes.DimGray 20.0f 20.0f - Erstelle einen Kreis mit den übergebenen Parametern. Mit der Hilfe von Currying bekommen wir eine reduzierte Funktion, die noch das letzte Argument verlangt und Drawing zurückliefert. Die Typ-Signatur ist - (string->Drawing).
   
2. forever-Funktion wandelt Drawing in Behavior<Drawing>. Die Typ-Signatur - (string->Behavior<Drawing>).
   
3. Verschiebe den in Behavior "versteckten" Drawing-Wert mit der angegebenen Geschwindigkeit auf der Laufbahn vom angegebenen Halbmesser. Die Typ-Signatur - (string->Behavior<Drawing>)
   

Die folder-Funktion folgt später.

     [(Brushes.Black,0.1f);(Brushes.OliveDrab,0.3f);(Brushes.SteelBlue,0.6f)]
    |>Seq.fold folder (emptyBehavior,1)
    |>fst

Hier wird die Liste von Paaren mit der Farbe und der Geschwindigkeit an der Seq.fold übergeben. (|>) ist der Pipe-Operator. Der Wert vom linken Ausdruck wird an das letzte Argument des rechten Ausdruckes übergeben. Das Resultat von fold ist ein Tupel, von dem wird mit der fst-Funktion (fst für "first") der erste Wert genommen.
Nun zur folder-Funktion. Das Prinzip ist hier und speziell für F# Seq.fold erklärt.

let folder (acc,count) (color, speed) =
        let planet = rotateAndTranslate speed 70.0f<<(--) (satellite "moon")<<forever<<circle color 40.0f 40.0f
        let result = acc -- (count.ToString()|>planet)
        result,count+1

Wie beschrieben, folder wird auf jeden Element - (color, speed) - der oben genannten Liste angewendet. Der Akkumulator (ich kenne keinen besseren Namen) ist (acc, count), wobei acc - wie man beim Funktionsaufruf sieht - am Anfang emptyBehavior ist und count gleich 1 ist.

let planet = 
    rotateAndTranslate speed 70.0f<<(--) (satellite "moon")<<forever<<circle color 40.0f 40.0f

Hier is das gleiche wie beim satellite-Ausdruck. Anders ist nur, dass vor dem Verschieben der Kreis vom Planet mit dem Satellit zusammengesetzt wird. Dann setzen wir den Planet mit dem Akkumulator zusammen, dadurch wird am Ende des Fold-Prozesses ein allen Elementen enthaltener, akkumulierter Behavior-Wert entstehen. Der Zähler count ist für die Durchnummerierung von Kreisen auf dem Formular da.
Alles zusammen.

//Behavior.fsx
...
let rotate speed radius= behavior{
  let fast = faster speed time
  let! posx = fast|>wiggle
  let! posy = fast|>wait 0.5f|>wiggle
  return posx * radius, posy * radius}

module BehaviorDrawing  =
open Demo.Drawing
open Demo.DrawingFunctions
let emptyBehavior = forever emptyDrawing
let (--) a b =
    behavior{
        let! x = a
        let! y = b
        return compose x y
    }
let rotateAndTranslate speed radius drawingBehavior =
    behavior{
        let! x,y = rotate speed radius
        let! image = drawingBehavior
        return translate x y image
    }

let animationPart3 =
    let satellite = rotateAndTranslate 0.8f 45.0f<<forever<<circle Brushes.DimGray 20.0f 20.0f
    let folder (acc,count) (color, speed) =
        let planet = rotateAndTranslate speed 70.0f<<(--) (satellite "moon")<<forever<<circle color 40.0f 40.0f
        let result = acc -- (count.ToString()|>planet)
        result,count + 1
    [(Brushes.Black,0.1f);(Brushes.OliveDrab,0.3f);(Brushes.SteelBlue,0.6f)]
    |>Seq.fold folder (emptyBehavior,1)
    |>fst

let singelton =
    let one =behavior{
          let! a = animationPart3
          return a
          }
    one

Drawing.fs
Behavior.fsx
Animation.fsx
main.fs

Funktionale Animation. Teil 2.

Bevor ich mit der Behavior-Monade aus Teil 1 fortfahre, brauche ich erstmal die Windows-Form, auf der die Animation stattfinden soll.

//Animation.fsx
module Demo.Animations
#load @"C:\Temp\Behavior.fsx"
open System
open System.Drawing
open System.Drawing.Imaging
open System.Windows.Forms
open Demo.Behavior

type AnimationForm() as x =
  inherit Form()
  let mutable startTime = DateTime.Now
  let anim = singelton //hier wird die Behavior-Animation zugewiesen.

  do
    x.SetStyle(ControlStyles.AllPaintingInWmPaint  ControlStyles.OptimizedDoubleBuffer, true)
    let tmr = new Timers.Timer(Interval = 25.0)
    tmr.Elapsed.Add(fun _ -> x.Invalidate() )
    tmr.Start()
 
  // Gets or sets the currently displayed animation
  member x.Animation
    with get() = anim
  override x.OnPaint(e) = 
      let wid, hgt = x.ClientSize.Width, x.ClientSize.Height
      e.Graphics.FillRectangle(Brushes.White, 0, 0, wid, hgt)
      e.Graphics.TranslateTransform(float32 wid/2.0f, float32 hgt/2.0f) 
      let elapsed = (DateTime.Now - startTime).TotalSeconds
      //Hier wird die Animation ausgeführt.
      let drawing = runBehavior anim {Time=float32 elapsed}
      drawing.Draw(e.Graphics) startTime).TotalSeconds

Zurück zur Behavior-Monade. Nun ist es möglich verschiedene Behavior-Funktionen zu definieren. Zuerst die wichtigste Zeitfunktion, die direkt über den Behavior-Typkonstruktor erstellt wird.

//Behavior.fsx
...
let behavior = new BehaviorBuilder()

let time = Behavior(fun context -> context.Time)

Spaßeshalber definiere ich die Funktion auch "monadisch".

let time = behavior{
    let! t = Behavior(fun context -> context.Time)
    return t}

und weitere Funktionen.

let wait (delay:float32) a = behavior{
    let! t = a
    return delay + t}

let faster (speed:float32) a = behavior{
    let! t = a
    return speed * t}

let wiggle b = behavior{
    let! t = b
    return sin (t * float32 Math.PI)}

let rotate= behavior{
  let! posx = wiggle time
  let! posy = time|>wait 0.5f|>wiggle
  return posx * 100.0f, posy * 100.0f}

Die Funktionen für die Animation.

module BehaviorDrawing  =
    open Demo.DrawingFunctions
    open System.Drawing
    let animation = 
        let moon  = circle Brushes.DimGray 20.0f 20.0f "moon"
        behavior{
            let! x,y = rotate
            return translate x y moon
            }
    let singelton=
        let one = behavior{
              let! a = animation
              return a
              }
        one

Zuletzt Main().

//main.fs
#load @"C:\Temp\Animation.fsx"
open Demo.Animations
open System
open System.Drawing
open System.Windows.Forms

let test =
    let af = new AnimationForm(ClientSize = Size(1000, 1000), Visible=true)
    af
let main() =
    test |> ignore
[]
    do main()

Hier der Beweis.

Alle Dateien zum Download:
Drawing.fs
Behavior.fsx
Animation.fsx
main.fs

Funktionale Animation. Teil 1. Ich sehe was, was du nicht siehst, und das ist die Monade.

Seit einem halben Jahr beschäftige ich mich mit F# und funktionaler Programmierung.

Ich habe diverse Bücher studiert bis ich auf Real World Functional Programming gestoßen bin, wo in Kapitel 15 ein sehr eleganter Lösungsansatz für die funktionale Animation beschrieben ist.

Ich wollte das Beispiel sofort ausprobieren und zu einer Art animierte Statistik bzw. Reports erweitern. In diesem Blog beschreibe ich die einzelnen Schritte zu diesem Ziel.

Der Ausgangspunkt ist der originale Code aus dem Buch hier. Die Idee ist sehr einfach wenn nicht sogar trivial.

Animations can be elegantly modeled using time-varying values. In Fran, these values are called behaviors and
we'll follow this naming. The following note explains what a behavior is.
WHAT IS A BEHAVIOR?
Behavior is a time-varying value. It can be represented as a composite value, whose
actual value may be different depending on the time. ….
Similarly, we'll have a type

Behavior<int>

, whose actual integer value can be different depending on the time.
Behaviors are an essential part of our animation framework, because we can use them
for specifying locations of objects. When the location changes depending on the time, it
means that the whole object will be moving.

Erstmal brauchen wir unsere Grafikfunktionen.

//Drawing.fs
module Demo

open System
open System.Drawing
open System.Drawing.Imaging
open System.Drawing.Drawing2D

module Drawing =
  type Drawing =
    abstract Draw : Graphics -> unit

  let drawing f =
    { new Drawing with
        member x.Draw(gr) = f(gr) }

  let emptyDrawing =
    { new Drawing with
        member x.Draw(gr) = () }

open Drawing

module DrawingFunctions=
    let translate x y (img:Drawing) =
      drawing (fun g ->
        g.TranslateTransform(x, -y)
        img.Draw(g)
        g.TranslateTransform(-x, y) )
    
    let rectangle (t1, p1) =
      drawing(fun g ->
         use font = new Font ("Calibri",14.0f)
         g.DrawString(t1,font,Brushes.Black,950.0f,p1))
    
    let circle brush size arg text=
      drawing(fun g ->
         g.SmoothingMode <- SmoothingMode.AntiAlias
         g.FillEllipse(brush, -arg/2.0f, -size/2.0f, arg, size)
         use font = new Font ("Calibri",10.0f)
         g.DrawString(text,font,Brushes.Black,size/2.0f, size/2.0f))

    let compose (img1:Drawing) (img2:Drawing) =
      drawing(fun g ->
         img1.Draw(g)
         img2.Draw(g) )

Der Code sofort in die F#-Konsole kopieren oder laden und dann sehen wir bereits die Typ-Signaturen.

Also bisher nichts wildes. Weiter geht es mit dem Behavior-Typ. Den wollte ich unbedingt als eine Monade implementieren. In F# nennt man eine Monade "Computation expression, was ein bisschen verwirrt.

//Behavior.fsx
module Demo.Behavior
//Laden Grafikfunktionen
#load @"C:\Temp\Drawing.fs"

open System
type BehaviorContext = { Time : float32 }

// Single case discriminated union
type Behavior<'a> = Behavior of (BehaviorContext -> 'a)

let runBehavior (Behavior fBehavior) t = fBehavior t

BehaviorContext ist "record type". So ein Typ hat mehrere benannte Elemente, in unserem Fall ist das nur eins. Am Anfang habe ich ihm aus Bequemlichkeit als float32 definiert, richtiger wäre es den Typ zu parametrisieren.
Bei Behavior<'a> sieht man, was mir im OOP-Welt öfter fehlte, eine "Unterscheidungs-Union" aka Tagged union aka ADT. "Behavior" nach dem "type" Schlüsselwort ist der Typ-Konstruktor, "Behavior" nach Gleichhetzeichen ist ein Daten-Konstruktor. Unser Behavior-Typ ist nichts anderes als eine Funktion, die als Parameter BehaviorContext-Typ - also letztendlich die Zeit - nimmt und den 'a -Typ zurückgibt.

runBehavior wendet dann Behavior zu einem konkreten Zeitpunkt an. Was da in Klammer steht ist nichts Wenigeres als Pattern Matching eines Funktionsargumentes. Jetzt kann die Monade gebaut werden, aber vorerst die Signaturen.


Ich würde von mir nicht behaupten, dass ich das Konzept von der Monade halbwegs verstanden habe. Das stört mir aber nicht, da an die Monade auch ganz formal herangegangen werden kann.

F# braucht für die Monade-Erstellung einen bestimmten Typ mit wenigstens zwei Membern Return und Bind.

member Return : 'a -> M<'a>
member Bind :M <'a> * ('a -> M<'b>) -> M<'b>

Return ist schnell abgehakt.

//member Return : 'a -> Behavior<'a>
type BehaviorBuilder() =
  member this.Return a = Behavior(fun _->a)//in Klammer steht ein Lambda-Ausdruck

Mit der Bind-Funktion habe ich eine gute Stunde gekämpft.

//member Bind : Bahavior<'a> * ('a -> Behavior<'b>) -> Behavior<'b>
let bind (Behavior fBehavior) generator = ?...

Wir haben als Input Behavior vom Typ 'a mit seiner fBehavior Funktion vom Typ (BehaviorContext->'a) und eine Generator-Funktion, die aus 'a den neuen Behavior vom Typ 'b erzeugt. Als Resultat kommt Behavior vom 'b heraus. Also schreibe ich:

let bind (Behavior fBehavior) generator = Behavior(fun behaviorContext->'b?)

Typ 'b kann uns eigentlich nur die runBehavior-Funktion liefern.

let bind (Behavior fBehavior) generator = Behavior(fun behaviorContext->runBehavior arg1?  arg2?)

runBehavior erwartet als Parameter Behavior und BehaviorContext. Was für ein Glück, den Kontext habe ich parat.

let bind (Behavior fBehavior) generator =
    Behavior(fun behaviorContext->runBehavior arg1?  behaviorContext)

Nicht genutzt sind fBehavior und generator. Von beiden kann ausschließlich generator uns der benötigte Behavior-Typ bereitstellen.

let bind (Behavior fBehavior) generator = 
    Behavior(fun behaviorContext->runBehavior (generator arg1?)  behaviorContext)

Ab hier ist es ein bloßes Kinderspiel.

let bind (Behavior fBehavior) generator =
    Behavior(fun behaviorContext->runBehavior (generator (fBehavior behaviorContext))  behaviorContext)

Überall wird gesagt, dass man Lambdas möglichst durch Currying ersetzen werden sollte. Die hässliche Klammern lassen mir auch keine Ruhe. Die vertreibt man mit Funktionskomposition.

let applyDoubly f a = f a a

let bind (Behavior fBehavior) generator =
    Behavior(runBehavior<<generator<<fBehavior|>applyDoubly)

Nun haben wir alles.

type BehaviorContext = { Time : float32 }

// Single case discriminated union
type Behavior<'a> = Behavior of (BehaviorContext -> 'a)

let runBehavior (Behavior fBehavior) t = fBehavior t

let applyDoubly f a = f a a

let bind (Behavior fBehavior) generator =
    Behavior(runBehavior<<generator<<fBehavior|>applyDoubly)

type BehaviorBuilder()=
 member this.Return a = Behavior(fun _->a)
 member this.Bind (m, k) = bind m k
 //ein Paar Hilfsfunktionen
 member this.Zero () = Behavior(fun _->())
 member this.ReturnFrom m = m

let behavior = new BehaviorBuilder()

behavior ist die zu verwendende Monade.

Wozu eigentlich die ganze Mühe? Siehe nächsten Einträge.
Teil 2