F# FRP practice

FSharp_FRP_practice.fsx

My practice script:

#r @"O:\gdrive_anighost\FsReactive\Common\bin\Debug\Common.dll"
#r @"O:\gdrive_anighost\FsReactive\FsReactive\bin\Debug\FsReactive.dll"
#r @"O:\gdrive_anighost\FsReactive\packages\MonoGame.Framework.WindowsDX.3.4.0.459\lib\net40\MonoGame.Framework.dll"
#r @"C:\Program Files (x86)\Reference Assemblies\Microsoft\Framework\.NETFramework\v4.6\System.dll"
#r @"C:\Program Files (x86)\Reference Assemblies\Microsoft\Framework\.NETFramework\v4.6\System.Core.dll"
#r @"C:\Program Files (x86)\Reference Assemblies\Microsoft\Framework\.NETFramework\v4.6\System.Numerics.dll"
#r @"O:\gdrive_anighost\FsReactive\Xna\bin\Debug\Xna.dll"

open FsReactive.Misc
open FsReactive.FsReactive
open FsReactive.Integration
open FsReactive.DynCol
open FsReactive.Lib
open System
open Common.Vector
open Common.Random
open Xna.Main

open Microsoft.Xna.Framework
open Microsoft.Xna.Framework.Graphics
open Microsoft.Xna.Framework.Input

module Rendering = 
    
    open Microsoft.Xna.Framework
    open Microsoft.Xna.Framework.Graphics
    open Common.Vector
    open System
    
    let drawBrick x y (gd:GraphicsDevice) = 
        let ds = [(0.0, 0.0); (0.2, 0.0); (0.2, 0.1); (0.0, 0.1); (0.0, 0.0)]
        let n_verts = List.length ds
        let random_vert _ =  Graphics.VertexPositionColor(Vector3(0.f, 0.f, 0.f), Color.White)
        let vertex = Array.init n_verts random_vert
        let f x y = List.iteri (fun i (dx, dy) -> 
                                    let (x', y') = (x+dx, y+dy)
                                    vertex.[i].Position <- Vector3(float32 x', float32 y', 0.f))        
                                ds
        f x y
        gd.DrawUserPrimitives(PrimitiveType.LineStrip, vertex, 0, n_verts-1)
        
          
    let drawBall x y ballRadius (gd:GraphicsDevice)  = 

        let angles = [for i in 1 .. 11 -> Math.PI * 2.0 * float i / 10.0]
        let pts = List.map (fun a -> Vector.rot Vector.unit a * ballRadius) angles
        let n_verts = List.length pts
        let random_vert _ = Graphics.VertexPositionColor(Vector3(0.f, 0.f, 0.f), Color.White)
        let vertex = Array.init n_verts random_vert
        let iter f = List.iteri (fun i (Vector(x,y)) -> 
                                        let x', y' = f x y
                                        vertex.[i].Position <- Vector3(float32 x', float32 y', 0.f))
                                     pts
        let f x' y' = x + x', y + y'
        iter f
        gd.DrawUserPrimitives(PrimitiveType.LineStrip, vertex, 0, n_verts-1)
        

    let drawPaddle (x:float) (paddleY:float) (paddleHalfLength:float) (gd:GraphicsDevice)  = 
        let random_vert _ = Graphics.VertexPositionColor(Vector3(0.f, 0.f, 0.f), Color.White)
        let vertex = Array.init 2 random_vert
        vertex.[0].Position <- Vector3(float32 (x-paddleHalfLength), float32 paddleY, 0.f)
        vertex.[1].Position <- Vector3(float32 (x+paddleHalfLength), float32 paddleY, 0.f)
        gd.DrawUserPrimitives(PrimitiveType.LineStrip, vertex, 0, 1)

type Time = float


// (Time -> 'a * (unit -> 'a Behavior)) -> 'a Behavior
// let rec timeB = Beh (fun t -> (t, fun() -> timeB))

////The constant 1	
//let oneB = Beh (fun _ -> 1.0)
////The constant "hello world!"	
//let helloB = Beh (fun _ -> "Hello World!")
//
////The time itself	
//let timeB = Beh (fun t -> t)
//
////The time times 3	
//let time3B = Beh (fun t -> t * 3.0)
//
////Sine of the time	
//let sinB = Beh (fun t -> System.Math.Sin t)
////Sine of the triple of the time	
//let sin3B = Beh (fun t -> System.Math.Sin (t * 3.0))

let constB v = 
    let bf t = v
    Beh bf

let rec oneB = 
    let ll = fun () -> oneB
    constB (1, ll)

let rec helloB = constB ("Hello World!", (fun () -> helloB))

//in dll: union case Behavior.Beh: (Time -> 'a * (unit -> 'a Behavior)) -> 'a Behavior
//in blog: type 'a Beh  = Beh of (Time -> ('a * 'a Beh))

//let time3B = 
//    let (Beh bf) = timeB
//    //let ll = fun () -> oneB
//    let lbf = 
//        fun (t : Time) -> 
//            let tt = bf (3.0 * t)
//            tt
//    Beh lbf



// val liftB : ('a -> 'b) -> 'a Behavior -> 'b Behavior
let liftB (f : 'a -> 'b) (ab : 'a Behavior) : 'b Behavior = 
    let (Beh bf) = ab
    let rec lbf (t : Time) : 'b * (unit -> 'b Behavior) = 
            let a, abf = bf t
            let b = f a
            let _, bbf = lbf t
            (b, bbf)
    Beh lbf

let time3B = 
//    let liftB f b = 
//        let (Beh bf) = b
//        let lbf = 
//            fun t -> f (bf t)
//        Beh lbf

    liftB ((*) 3.0) timeB


let sinB = liftB System.Math.Sin timeB
let sin3B = liftB System.Math.Sin (liftB ((*) 3.0) timeB)

let sinF = liftB System.Math.Sin
let sinB2 = sinF timeB

let tripleF = liftB ((*) 3.0)
let sin3B2 = sinF (tripleF timeB)

//val lift2B : ('a -> 'b -> 'c) -> 'a Behavior -> 'b Behavior -> 'c Behavior
//let lift2B f a b = 
//    let (Beh bf1) = a
//    let (Beh bf2) = b
//    let nbf t = f (bf1 t) (bf2 t)
//    Beh nbf

let lift2B (f : 'a -> 'b -> 'c) (a : 'a Behavior) (b :'b Behavior) : 'c Behavior = 
    let (Beh bf1) = a
    let (Beh bf2) = b
    let rec nbf (t : Time) : 'c * (unit -> 'c Behavior) = 
        let a1, ub1 = bf1 t
        let b2, ub2 = bf2 t
        let c = f a1 b2
        let _, cc = nbf t
        c, cc
    Beh nbf

//let lift2B f a b = 
//    let (Beh bf1) = a
//    let (Beh bf2) = b
//    let nbf t = f (bf1 t) (bf2 t)
//    Beh nbf

//val lift3B : ('a -> 'b -> 'c -> 'd) -> 'a Behavior -> 'b Behavior -> 'c Behavior -> 'd Behavior

//let lift3B f a b c = 
//    let (Beh bf1) = a
//    let (Beh bf2) = b
//    let (Beh bf3) = c
//    let nbf t = f (bf1 t) (bf2 t) (bf3 t)
//    Beh nbf

let lift3B (f : 'a -> 'b -> 'c -> 'd) (a : 'a Behavior) (b :'b Behavior) (c : 'c Behavior) : 'd Behavior = 
    let (Beh bf1) = a
    let (Beh bf2) = b
    let (Beh bf3) = c
    let rec nbf (t : Time) : 'd * (unit -> 'd Behavior) = 
        let a1, _ = bf1 t
        let b2, _ = bf2 t
        let c3, _ = bf3 t
        let d = f a1 b2 c3
        let _, dd = nbf t
        d, dd
    Beh nbf




// val ( .* ) : (int Behavior -> int Behavior -> int Behavior)

let (.*) = lift2B (*)

// val ( ./ ) : (int Behavior -> int Behavior -> int Behavior)

let (./) = lift2B (/)

// val mapB : ('a -> 'b) Behavior -> 'a list Behavior -> 'b list Behavior

let mapB f b = (lift2B List.map) f b


type 'a StateMachine = unit -> 'a

let TogglingMachine =
     let state = ref true
     let bf evt = 
        state := not (!state)
        !state
     bf :bool StateMachine

let eventList = [(); (); (); ()]

let r = List.map TogglingMachine eventList

type 'a StateMachine2 = unit option -> 'a


let CountingMachine : int StateMachine2 =
    let nbNone = ref 0
    let bf evt = 
        match evt with
        |None -> 
            nbNone := !nbNone + 1
            -1
        |Some _ -> 
            let res = !nbNone
            nbNone := 0
            res
    bf

let eventList2 = [None; None; Some(); None; Some(); Some(); None]

let r2 = List.map CountingMachine eventList2


type StateMachine3 = int -> unit option -> (int * int)


let CountingMachine3 : StateMachine3 =
    let bf previousCount evt =
         match evt with
         |None ->  (-1, previousCount+1)
         |Some _ -> (previousCount, 0)
    bf

let rec runList previousCount machine events =
    match events with
    | [] -> []
    | event::t -> 
        let (nextRes, nextCount) = 
            machine previousCount event
        nextRes :: runList nextCount machine t

let eventList3 = [None; None; Some(); None; Some(); Some(); None]
let r3 = runList 0 CountingMachine3 eventList3


type StateMachine4<'a, 'state> = 'state -> unit option -> ('a * 'state)
type 'a StateMachine5 = SM of (unit option -> ('a * 'a StateMachine5))
let AlwaysTrueMachine = 
    let rec bf evt = (true, SM bf)
    SM bf


let rec AlwaysTrueMachine2 = 
    let bf evt = (true, AlwaysTrueMachine2)
    SM bf

let TogglingMachine5 = 
    let rec bf previous evt = (previous, SM (bf (not previous)))
    SM (bf true)


let rec runList5 (SM bf) events =
    match events with
    | [] -> []
    | h::t -> 
        let (r, nb) = bf h
        r :: runList5 nb t

let eventList5 = [None; None; Some(); None; Some(); Some(); None]
let r5 = runList5 TogglingMachine5 eventList5


let rec runList6 (Beh bf) times =
    match times with
    | [] -> []
    | t::timetail -> 
        let (a, nab) = bf t
        let nabv = nab ()
        a :: (runList6 nabv timetail)

let rec doubleB =
    let bf (t : Time) = (2.0 * t, fun () -> doubleB)
    Beh bf

let rec twoB =
   let bf t = (2, fun () -> twoB)
   Beh bf

let rec timeB = Beh (fun t -> (t, fun () -> timeB))


// val liftB : ('a -> 'b) -> 'a Beh -> 'b Beh

let rec liftB2 f (Beh bf1)=
    let bf t = 
        let (r1, nb1) = bf1 t
        let bv = nb1 ()
        (f r1, fun () -> liftB2 f bv)
    Beh bf

// val lift2B : ('a -> 'b -> 'c) -> 'a Beh -> 'b Beh -> 'c Beh

let rec lift2B2 f (Beh bf1) (Beh bf2)=
    let bf t = 
        let (r1, nb1) = bf1 t
        let (r2, nb2) = bf2 t

        (f r1 r2, fun () -> lift2B2 f (nb1 ()) (nb2 ()))
    Beh bf

let makeB f = (liftB2 f) timeB

let makeB2 f =
   let rec bf t = (f t, fun () -> Beh bf)
   Beh bf

// val makeWithStateB : ('state -> Time -> 'a * 'state) -> 'state -> 'a Beh

let rec makeWithStateB f (previousState:'state) =
    let bf t = 
        let (a1, nextState) = f previousState t  // call f with the previous state
        (a1, fun () -> makeWithStateB f nextState)         // pass the next state, returned by f to the next Behavior
    Beh bf

let f t0 t : Time * Time = 
    if (t-t0 < 10.0)
    then (t-t0, t0)
    else (0.0, t)

let fB = makeWithStateB f 0.0

let times = Seq.toList (seq { for i in 0 .. 100 -> float i })

let r6 = runList6 fB times


let rec run7 (Beh bf) l =
    match l with
    | [] -> []
    | h::t -> 
        let (r, nb) = bf h
        r::(run7 (nb ()) t)


type Color = White|Black

// a constant Behavior that is always Black
let rec blackB = Beh (fun t -> (Black, fun () -> blackB))

let rec colorB =
    let bf (t : Time) =  
        if (t < 10.0)
        then (White, fun () -> colorB)
        else 
            //let rec blackB = Beh (fun t -> (Black, fun () -> blackB))
            (Black, fun () -> blackB)
    Beh bf

let s = Seq.toList (seq { for x in 1 .. 15 -> (float) x})

let r7 = run7 colorB s



let rec colorB2 =
    let cond t = 
        if (t < 10.0)
        then None
        else 
            Some blackB
    let bf t =  
        match cond t with
        | None -> (White, fun () -> colorB2)
        | Some (Beh newColorB) -> 
            newColorB t
    Beh bf

let r8 = run7 colorB2 s

// val createColor : (Time -> Color Beh option) -> Color Beh

let rec createColor cond =
    let bf t = 
        match cond t with
        | None -> (White, fun () -> createColor cond)
        | Some (Beh newColorB) -> 
            newColorB t
    Beh bf

// val cond : float -> Color Beh option
let cond t = 
    if (t<10.0)
    then None
    else 
        Some blackB

let colorB3 = createColor cond

let r9 = run7 colorB3 s










let rec condB =
    let bf t = 
        if (t<10.0)
        then (None, fun () -> condB)
        else 
            //let rec blackB = Beh (fun t -> (Black, blackB))
            (Some blackB, fun () -> condB)
    Beh bf
// val condB : Color Behavior option Behavior
// val createColor : Color Beh option Beh -> Color Beh
// val condf : (Time -> 'a Behavior option * (unit -> 'a Behavior option Behavior))
// bf => val bf : (Time -> Color * (unit -> Color Behavior))
let rec createColor2 (Beh condf) =
    let bf t = 
        match condf t with
        | (None, ncond) -> 
            (White, fun () -> 
                        let ncbob = ncond ()
                        createColor2 ncbob)
        | (Some (Beh newColorB), ncond) -> 
            let ncb, _ = newColorB t
            (ncb, fun () -> 
                        let ncbob = ncond ()
                        createColor2 ncbob) 
    Beh bf

let colorB4 = createColor2 condB

let r10 = run7 colorB4 s




// val switchB : 'a Beh -> 'a Beh option Beh -> 'a Beh

let rec switchB (Beh bfInit) (Beh condf) =
    let bf t = 
        match condf t with
        | (None, ncond) -> 
            let (rInit, nBInit) = bfInit t
            rInit, switchB (nBInit ()) (ncond ())
        | (Some (Beh newBehavior), ncond) -> 
            newBehavior t
            
    fun () -> Beh bf
    

let rec whiteB = Beh (fun t -> (White, fun () -> whiteB))

let colorB5 = switchB whiteB condB

let r11 = run7 (colorB5 ()) s

// 嘗試把 () 拿掉， 失敗，維持同上
let rec switchB2 (Beh bfInit) (Beh condf) =
    let bf t = 
        match condf t with
        | (None, ncond) -> 
            let (rInit, nBInit) = bfInit t
            rInit, switchB2 (nBInit ()) (ncond ())
        | (Some (Beh newBehavior), ncond) -> 
            newBehavior t
            
    fun () -> Beh bf
    

let colorB6 = switchB2 whiteB condB

let r12 = run7 (colorB6 ()) s




// definition of event
//type 'a Behavior =  Beh of (Time ->  'a         * (unit -> 'a Behavior)) 
type 'a Event    =  Evt of (Time -> ('a option  * (unit -> 'a Event)))

// not required
let rec blackE = Evt (fun t -> (Some Black, fun () -> blackE))


let rec condB2 : Color Behavior Event=
    let bf t = 
        if (t<10.0)
        then (None, fun () -> condB2)
        else 
            //let rec blackB = Beh (fun t -> (Black, blackB))
            (Some blackB, fun () -> condB2)
    Evt bf

// val switchB : 'a Beh -> 'a Beh Event -> 'a Beh

let rec switchB3 (Beh bfInit) (Evt condf) =
    let bf t = 
        match condf t with
        | (None, ncond) -> 
            let (rInit, nBInit) = bfInit t
            (rInit, switchB3 (nBInit ()) (ncond ()))
        | (Some (Beh newB), ncond) -> 
            newB t
    fun () -> Beh bf

let colorB7 = switchB3 whiteB condB2

let r13 = run7 (colorB7 ()) s