[WIP] Revert ModelUpdateView example

src/ModelUpdateView/ActionLifting.fs

@@ -0,0 +1,97 @@
+namespace ActionLifting
+
+open System
+open Aardvark.UI.Primitives
+open Aardvark.UI
+open Aardvark.Base.Rendering
+open Aardvark.Base.Incremental
+open Aardvark.Base
+open Aardvark.SceneGraph.``Sg Picking Extensions``
+
+open ActionLiftingModel
+
+module ActionLifting =        
+    open Boxes
+    open BoxSelectionDemo
+
+    let update (model : ActionLiftingModel) (act : Action) =
+        match act with
+            | CameraMessage m -> 
+                { model with camera = CameraController.update model.camera m }
+            | BoxesMessage m ->
+                { model with boxes = BoxesApp.update model.boxes m }
+            | Select id-> 
+                let selection = 
+                    if HSet.contains id model.selectedBoxes 
+                    then HSet.remove id model.selectedBoxes 
+                    else HSet.add id model.selectedBoxes
+
+                { model with selectedBoxes = selection }
+
+    let mkColor (model : MActionLiftingModel) (box : MVisibleBox) =  
+        let id = box.id |> Mod.force
+        model.selectedBoxes 
+            |> ASet.contains id
+            |> Mod.bind (function x -> if x then Mod.constant Primitives.selectionColor else box.color)       
+
+    let mkISg (model : MActionLiftingModel) (box : MVisibleBox) =
+
+        let color = mkColor model box
+
+        Sg.box color box.geometry
+            |> Sg.shader {
+                do! DefaultSurfaces.trafo
+                do! DefaultSurfaces.vertexColor
+                do! DefaultSurfaces.simpleLighting
+                }                
+            |> Sg.requirePicking
+            |> Sg.noEvents
+            |> Sg.withEvents [
+                Sg.onClick (fun _  -> Select (box.id |> Mod.force))                    
+            ]
+
+    let view (model : MActionLiftingModel) : DomNode<Action>=
+
+        let frustum = 
+            Mod.constant (Frustum.perspective 60.0 0.1 100.0 1.0)
+
+        let mkColor = 
+            fun box -> mkColor model box
+
+        require (Html.semui) (
+            div [clazz "ui"; style "background: #1B1C1E"] [
+                CameraController.controlledControl model.camera CameraMessage frustum
+                    (AttributeMap.ofList [
+                        attribute "style" "width:65%; height: 100%; float: left;"
+                    ])
+                    (
+                         model.boxes.boxes 
+                            |> AList.toASet 
+                            |> ASet.map (function b -> mkISg model b)
+                            |> Sg.set                          
+                            |> Sg.noEvents
+                    )
+                div [style "width:35%; height: 100%; float:right"] [
+                    BoxesApp.view model.boxes mkColor |> UI.map BoxesMessage
+                    //BoxesApp.view' model.boxes mkColor (fun b -> Select (b.id |> Mod.force)) (fun a -> BoxesMessage a)
+                ]
+            ]
+        )
+
+    let initial = {
+        camera          = CameraController.initial
+        boxHovered      = None
+        boxes           = { boxes = Primitives.mkBoxes 3 |> List.mapi (fun i k -> Primitives.mkVisibleBox Primitives.colors.[i % 5] k) |> PList.ofList; boxesSet = HSet.empty }
+        selectedBoxes   = HSet.empty  
+        colors          = []
+    }
+
+    let app = {
+        unpersist = Unpersist.instance
+        threads = fun model -> CameraController.threads model.camera |> ThreadPool.map CameraMessage
+        initial = initial
+        update = update
+        view = view
+    }
+
+    let start () = App.start app

src/ModelUpdateView/ActionLiftingModel.fs

@@ -0,0 +1,34 @@
+namespace ActionLiftingModel
+
+open Aardvark.Base
+open Aardvark.Base.Incremental
+open Aardvark.UI.Primitives
+open Boxes
+
+[<DomainType>]
+type BoxesModel = {
+    boxes : plist<VisibleBox>
+    boxesSet : hset<VisibleBox>    
+}
+
+type BoxesAction =
+    | AddBox
+    | RemoveBox
+
+[<DomainType>]
+type ActionLiftingModel = {
+    camera : CameraControllerState        
+    boxes : BoxesModel
+
+    boxHovered : option<string>
+    selectedBoxes : hset<string>
+
+    colors : list<C4b>
+}
+
+type Action =
+    | CameraMessage    of CameraControllerMessage
+    | BoxesMessage     of BoxesAction
+    | Select           of string                          
+
+

src/ModelUpdateView/ActionLiftingModel.g.fs

@@ -0,0 +1,129 @@
+namespace ActionLiftingModel
+
+open System
+open Aardvark.Base
+open Aardvark.Base.Incremental
+open ActionLiftingModel
+
+[<AutoOpen>]
+module Mutable =
+
+
+
+    type MBoxesModel(__initial : ActionLiftingModel.BoxesModel) =
+        inherit obj()
+        let mutable __current : Aardvark.Base.Incremental.IModRef<ActionLiftingModel.BoxesModel> = Aardvark.Base.Incremental.EqModRef<ActionLiftingModel.BoxesModel>(__initial) :> Aardvark.Base.Incremental.IModRef<ActionLiftingModel.BoxesModel>
+        let _boxes = MList.Create(__initial.boxes, (fun v -> Boxes.Mutable.MVisibleBox.Create(v)), (fun (m,v) -> Boxes.Mutable.MVisibleBox.Update(m, v)), (fun v -> v))
+        let _boxesSet = MSet.Create((fun (v : Boxes.VisibleBox) -> v.id :> obj), __initial.boxesSet, (fun v -> Boxes.Mutable.MVisibleBox.Create(v)), (fun (m,v) -> Boxes.Mutable.MVisibleBox.Update(m, v)), (fun v -> v))
+
+        member x.boxes = _boxes :> alist<_>
+        member x.boxesSet = _boxesSet :> aset<_>
+
+        member x.Current = __current :> IMod<_>
+        member x.Update(v : ActionLiftingModel.BoxesModel) =
+            if not (System.Object.ReferenceEquals(__current.Value, v)) then
+                __current.Value <- v
+
+                MList.Update(_boxes, v.boxes)
+                MSet.Update(_boxesSet, v.boxesSet)
+
+
+        static member Create(__initial : ActionLiftingModel.BoxesModel) : MBoxesModel = MBoxesModel(__initial)
+        static member Update(m : MBoxesModel, v : ActionLiftingModel.BoxesModel) = m.Update(v)
+
+        override x.ToString() = __current.Value.ToString()
+        member x.AsString = sprintf "%A" __current.Value
+        interface IUpdatable<ActionLiftingModel.BoxesModel> with
+            member x.Update v = x.Update v
+
+
+
+    [<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
+    module BoxesModel =
+        [<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
+        module Lens =
+            let boxes =
+                { new Lens<ActionLiftingModel.BoxesModel, Aardvark.Base.plist<Boxes.VisibleBox>>() with
+                    override x.Get(r) = r.boxes
+                    override x.Set(r,v) = { r with boxes = v }
+                    override x.Update(r,f) = { r with boxes = f r.boxes }
+                }
+            let boxesSet =
+                { new Lens<ActionLiftingModel.BoxesModel, Aardvark.Base.hset<Boxes.VisibleBox>>() with
+                    override x.Get(r) = r.boxesSet
+                    override x.Set(r,v) = { r with boxesSet = v }
+                    override x.Update(r,f) = { r with boxesSet = f r.boxesSet }
+                }
+
+
+    type MActionLiftingModel(__initial : ActionLiftingModel.ActionLiftingModel) =
+        inherit obj()
+        let mutable __current : Aardvark.Base.Incremental.IModRef<ActionLiftingModel.ActionLiftingModel> = Aardvark.Base.Incremental.EqModRef<ActionLiftingModel.ActionLiftingModel>(__initial) :> Aardvark.Base.Incremental.IModRef<ActionLiftingModel.ActionLiftingModel>
+        let _camera = Aardvark.UI.Primitives.Mutable.MCameraControllerState.Create(__initial.camera)
+        let _boxes = MBoxesModel.Create(__initial.boxes)
+        let _boxHovered = MOption.Create(__initial.boxHovered)
+        let _selectedBoxes = MSet.Create(__initial.selectedBoxes)
+        let _colors = ResetMod.Create(__initial.colors)
+
+        member x.camera = _camera
+        member x.boxes = _boxes
+        member x.boxHovered = _boxHovered :> IMod<_>
+        member x.selectedBoxes = _selectedBoxes :> aset<_>
+        member x.colors = _colors :> IMod<_>
+
+        member x.Current = __current :> IMod<_>
+        member x.Update(v : ActionLiftingModel.ActionLiftingModel) =
+            if not (System.Object.ReferenceEquals(__current.Value, v)) then
+                __current.Value <- v
+
+                Aardvark.UI.Primitives.Mutable.MCameraControllerState.Update(_camera, v.camera)
+                MBoxesModel.Update(_boxes, v.boxes)
+                MOption.Update(_boxHovered, v.boxHovered)
+                MSet.Update(_selectedBoxes, v.selectedBoxes)
+                ResetMod.Update(_colors,v.colors)
+
+
+        static member Create(__initial : ActionLiftingModel.ActionLiftingModel) : MActionLiftingModel = MActionLiftingModel(__initial)
+        static member Update(m : MActionLiftingModel, v : ActionLiftingModel.ActionLiftingModel) = m.Update(v)
+
+        override x.ToString() = __current.Value.ToString()
+        member x.AsString = sprintf "%A" __current.Value
+        interface IUpdatable<ActionLiftingModel.ActionLiftingModel> with
+            member x.Update v = x.Update v
+
+
+
+    [<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
+    module ActionLiftingModel =
+        [<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
+        module Lens =
+            let camera =
+                { new Lens<ActionLiftingModel.ActionLiftingModel, Aardvark.UI.Primitives.CameraControllerState>() with
+                    override x.Get(r) = r.camera
+                    override x.Set(r,v) = { r with camera = v }
+                    override x.Update(r,f) = { r with camera = f r.camera }
+                }
+            let boxes =
+                { new Lens<ActionLiftingModel.ActionLiftingModel, ActionLiftingModel.BoxesModel>() with
+                    override x.Get(r) = r.boxes
+                    override x.Set(r,v) = { r with boxes = v }
+                    override x.Update(r,f) = { r with boxes = f r.boxes }
+                }
+            let boxHovered =
+                { new Lens<ActionLiftingModel.ActionLiftingModel, Microsoft.FSharp.Core.Option<System.String>>() with
+                    override x.Get(r) = r.boxHovered
+                    override x.Set(r,v) = { r with boxHovered = v }
+                    override x.Update(r,f) = { r with boxHovered = f r.boxHovered }
+                }
+            let selectedBoxes =
+                { new Lens<ActionLiftingModel.ActionLiftingModel, Aardvark.Base.hset<System.String>>() with
+                    override x.Get(r) = r.selectedBoxes
+                    override x.Set(r,v) = { r with selectedBoxes = v }
+                    override x.Update(r,f) = { r with selectedBoxes = f r.selectedBoxes }
+                }
+            let colors =
+                { new Lens<ActionLiftingModel.ActionLiftingModel, Microsoft.FSharp.Collections.List<Aardvark.Base.C4b>>() with
+                    override x.Get(r) = r.colors
+                    override x.Set(r,v) = { r with colors = v }
+                    override x.Update(r,f) = { r with colors = f r.colors }
+                }

src/ModelUpdateView/BoxSelectionDemo_1.fs

@@ -0,0 +1,118 @@
+namespace BoxSelectionDemo
+
+open System
+open BoxSelectionModel
+open Aardvark.UI.Primitives
+open Aardvark.UI
+open Aardvark.Base.Rendering
+open Aardvark.Base.Incremental
+open Aardvark.Base
+open Aardvark.SceneGraph.``Sg Picking Extensions``
+
+module BoxSelectionDemo_1 =
+    open Boxes
+
+    let mkVisibleBox (color : C4b) (box : Box3d) : VisibleBox = 
+        {
+            id = Guid.NewGuid().ToString()
+            geometry = box
+            color = color           
+        }
+
+    let update (model : BoxSelectionDemoModel) (act : Action) =
+        match act with
+            | CameraMessage m -> 
+                     { model with camera = CameraController.update model.camera m }
+            | Select id-> 
+                let selection = 
+                    if HSet.contains id model.selectedBoxes 
+                    then HSet.remove id model.selectedBoxes 
+                    else HSet.add id model.selectedBoxes
+
+                { model with selectedBoxes = selection } 
+            | HoverIn id -> { model with boxHovered = Some id }            
+            | HoverOut   -> { model with boxHovered = None }        
+            | _ -> model
+
+    let mkColor (model : MBoxSelectionDemoModel) (box : MVisibleBox) = 
+        let id = box.id |> Mod.force
+
+        let color =  
+            model.selectedBoxes 
+                |> ASet.contains id 
+                |> Mod.bind (function x -> if x then Mod.constant C4b.Red else box.color)
+
+        color
+
+    ///Specifies how to draw a single box
+    let mkISg (model : MBoxSelectionDemoModel) (box : MVisibleBox) =
+
+            let color = mkColor model box
+
+            Sg.box color box.geometry
+                    |> Sg.shader {
+                        do! DefaultSurfaces.trafo
+                        do! DefaultSurfaces.vertexColor
+                        do! DefaultSurfaces.simpleLighting
+                        }                
+                    |> Sg.requirePicking
+                    |> Sg.noEvents
+                    |> Sg.withEvents [
+                        Sg.onClick (fun _  -> Select (box.id |> Mod.force))
+                        Sg.onEnter (fun _  -> HoverIn (box.id |> Mod.force))
+                        Sg.onLeave (fun () -> HoverOut)
+                    ]
+
+    let view (model : MBoxSelectionDemoModel) =
+
+        let frustum = Mod.constant (Frustum.perspective 60.0 0.1 100.0 1.0)
+
+        let color = 
+            model.boxHovered |> Mod.map (
+                function x -> match x with
+                                | Some k -> if k = "box" then C4b.Blue else C4b.Gray
+                                | None -> C4b.Gray)
+
+        //require (Html.semui) (
+        div [clazz "ui"; style "background: #1B1C1E"] [
+            CameraController.controlledControl model.camera CameraMessage frustum
+                (AttributeMap.ofList [
+                    attribute "style" "width:65%; height: 100%; float: left;"
+                ])
+                (
+                    Sg.box color (Mod.constant Box3d.Unit)
+                        |> Sg.shader {
+                            do! DefaultSurfaces.trafo
+                            do! DefaultSurfaces.vertexColor
+                            do! DefaultSurfaces.simpleLighting
+                            }                
+                        |> Sg.requirePicking
+                        |> Sg.noEvents
+                        |> Sg.withEvents [
+                            Sg.onClick (fun _  -> Select ("box"))
+                            Sg.onEnter (fun _  -> HoverIn ("box"))
+                            Sg.onLeave (fun () -> HoverOut)
+                        ]
+                )
+        ]
+        //)
+
+    let initial =
+        {
+            camera          = CameraController.initial
+            boxHovered      = None
+            boxes           = plist.Empty // Primitives.mkBoxes 3 |> List.mapi (fun i k -> Primitives.mkVisibleBox Primitives.colors.[i % 5] k) |> PList.ofList
+            selectedBoxes   = HSet.empty         
+            boxesSet        = HSet.empty            
+        }
+
+    let app : App<BoxSelectionDemoModel,MBoxSelectionDemoModel,Action> =
+            {
+                unpersist = Unpersist.instance
+                threads = fun model -> CameraController.threads model.camera |> ThreadPool.map CameraMessage
+                initial = initial
+                update = update
+                view = view
+            }
+
+    let start () = App.start app