FsAdvent 2017 Code

app.fs

let application nav =       
    // Start pruning "loop" via Executor type
    let prune = new Executor<_,_>(pruneHandler)
    prune.Start()
    // Start our application, and attach the executor so messages dispatch to the application
    Framework.application Forest.empty Forest.update forestComponent nav
    |> Framework.withDispatcher prune

forestComponent.fs

// Create binding for entire application.  This will output all of our messages.
let forestComponent =
    Component.create<Forest,unit,ForestMessage> [
        <@ forestDesign.Forest @> |> Bind.collection id treeComponent UpdateTree
        <@ forestDesign.Add @>    |> Bind.cmdParam Add
    ]

main.fs

let main _ =  
    // Run using the WPF wrappers around the basic application framework    
    let nav = Gjallarhorn.Wpf.Navigation.singleView System.Windows.Application MainWindow
    let app = Program.application nav.Navigate
    Gjallarhorn.Wpf.Framework.RunApplication<Forest,unit,ForestMessage> (nav, app)
    0

pruneHandler.fs

let pruneHandler (dispatch : Dispatch<_>) token =        
    // Handle pruning of the forest - 
    // Twice per second, send a prune message to remove a tree if there are more than max
    let rec pruneForever max =
        async {
            do! Async.Sleep 500                
            Prune max |> dispatch
            return! pruneForever max 
        }

    // Start prune loop in the background asynchronously
    Async.Start(pruneForever 10, token)

treeComponent.fs

let treeComponent =
        Component.create<Tree,unit,TreeMessage> [
            <@ treeDesign.Tree @>     |> Bind.oneWay id
            <@ treeDesign.Decorate @> |> Bind.cmd
            <@ treeDesign.Light @>    |> Bind.cmd
        ]

treevm.fs

type TreeVM =
    {
        Tree     : Tree
        Decorate : VmCmd<TreeMessage>
        Light    : VmCmd<TreeMessage>
    }
let treeDesign = { Tree = { Position = { X = 0.0 ; Y = 0.0 } ; Height = 1.0 ; Decorated = true ; Lit = true } ; Decorate = Vm.cmd Decorate ; Light = Vm.cmd Light }