diff --git a/src/ModelUpdateView/ActionLifting.fs b/src/ModelUpdateView/ActionLifting.fs new file mode 100644 index 0000000..8f7b3f7 --- /dev/null +++ b/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= + + 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 \ No newline at end of file diff --git a/src/ModelUpdateView/ActionLiftingModel.fs b/src/ModelUpdateView/ActionLiftingModel.fs new file mode 100644 index 0000000..b538bca --- /dev/null +++ b/src/ModelUpdateView/ActionLiftingModel.fs @@ -0,0 +1,34 @@ +namespace ActionLiftingModel + +open Aardvark.Base +open Aardvark.Base.Incremental +open Aardvark.UI.Primitives +open Boxes + +[] +type BoxesModel = { + boxes : plist + boxesSet : hset +} + +type BoxesAction = + | AddBox + | RemoveBox + +[] +type ActionLiftingModel = { + camera : CameraControllerState + boxes : BoxesModel + + boxHovered : option + selectedBoxes : hset + + colors : list +} + +type Action = + | CameraMessage of CameraControllerMessage + | BoxesMessage of BoxesAction + | Select of string + + diff --git a/src/ModelUpdateView/ActionLiftingModel.g.fs b/src/ModelUpdateView/ActionLiftingModel.g.fs new file mode 100644 index 0000000..a0b1d3d --- /dev/null +++ b/src/ModelUpdateView/ActionLiftingModel.g.fs @@ -0,0 +1,129 @@ +namespace ActionLiftingModel + +open System +open Aardvark.Base +open Aardvark.Base.Incremental +open ActionLiftingModel + +[] +module Mutable = + + + + type MBoxesModel(__initial : ActionLiftingModel.BoxesModel) = + inherit obj() + let mutable __current : Aardvark.Base.Incremental.IModRef = Aardvark.Base.Incremental.EqModRef(__initial) :> Aardvark.Base.Incremental.IModRef + 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 with + member x.Update v = x.Update v + + + + [] + module BoxesModel = + [] + module Lens = + let boxes = + { new Lens>() 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>() 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 = Aardvark.Base.Incremental.EqModRef(__initial) :> Aardvark.Base.Incremental.IModRef + 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 with + member x.Update v = x.Update v + + + + [] + module ActionLiftingModel = + [] + module Lens = + let camera = + { new Lens() 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() 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>() 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>() 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>() 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 } + } diff --git a/src/ModelUpdateView/BoxSelectionDemo_1.fs b/src/ModelUpdateView/BoxSelectionDemo_1.fs new file mode 100644 index 0000000..138f4d1 --- /dev/null +++ b/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 = + { + unpersist = Unpersist.instance + threads = fun model -> CameraController.threads model.camera |> ThreadPool.map CameraMessage + initial = initial + update = update + view = view + } + + let start () = App.start app \ No newline at end of file diff --git a/src/ModelUpdateView/BoxSelectionDemo_2.fs b/src/ModelUpdateView/BoxSelectionDemo_2.fs new file mode 100644 index 0000000..60bc2c6 --- /dev/null +++ b/src/ModelUpdateView/BoxSelectionDemo_2.fs @@ -0,0 +1,125 @@ +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_2 = + 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) + ] + ) + div [style "width:35%; height: 100%; float:right"] [ + div [clazz "ui buttons"] [ + button [clazz "ui button"; onMouseClick (fun _ -> AddBox)] [text "Add Box"] + button [clazz "ui button"; onMouseClick (fun _ -> RemoveBox)] [text "Remove Box"] + button [clazz "ui button"; onMouseClick (fun _ -> ClearSelection)] [text "Clear Selection"] + ] + ] + ] + ) + + let initial = + { + camera = CameraController.initial + boxHovered = None + boxes = 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 = + { + unpersist = Unpersist.instance + threads = fun model -> CameraController.threads model.camera |> ThreadPool.map CameraMessage + initial = initial + update = update + view = view + } + + let start () = App.start app \ No newline at end of file diff --git a/src/ModelUpdateView/BoxSelectionDemo_2Utils.fs b/src/ModelUpdateView/BoxSelectionDemo_2Utils.fs new file mode 100644 index 0000000..d7b78e9 --- /dev/null +++ b/src/ModelUpdateView/BoxSelectionDemo_2Utils.fs @@ -0,0 +1,43 @@ +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 Primitives = + open Boxes + + let hoverColor = C4b.Blue + let selectionColor = C4b.Red + let colors = [new C4b(166,206,227); new C4b(178,223,138); new C4b(251,154,153); new C4b(253,191,111); new C4b(202,178,214)] + let colorsBlue = [new C4b(241,238,246); new C4b(189,201,225); new C4b(116,169,207); new C4b(43,140,190); new C4b(4,90,141)] + + let mkNthBox i n = + let min = -V3d.One + let max = V3d.One + + let offset = 0.0 * (float n) * V3d.IOO + + new Box3d(min + V3d.IOO * 2.5 * (float i) - offset, max + V3d.IOO * 2.5 * (float i) - offset) + + let mkBoxes number = + [0..number-1] |> List.map (function x -> mkNthBox x number) + + let hoveredColor (model : MBoxSelectionDemoModel) (box : VisibleBox) = + model.boxHovered + |> Mod.map (fun h -> + match h with + | Some i -> if i = box.id then hoverColor else box.color + | None -> box.color) + + let mkVisibleBox (color : C4b) (box : Box3d) : VisibleBox = + { + id = Guid.NewGuid().ToString() + geometry = box + color = color + } \ No newline at end of file diff --git a/src/ModelUpdateView/BoxSelectionDemo_Empty.fs b/src/ModelUpdateView/BoxSelectionDemo_Empty.fs new file mode 100644 index 0000000..661ddef --- /dev/null +++ b/src/ModelUpdateView/BoxSelectionDemo_Empty.fs @@ -0,0 +1,96 @@ +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_Empty = + 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 } + | _ -> failwith "cant handle message yet" + + let mkColor (model : MBoxSelectionDemoModel) (box : MVisibleBox) = + Mod.constant C4b.Gray + + ///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 [ + //onclick select + //onenter enter + //onleave exit + ] + + let view (model : MBoxSelectionDemoModel) = + + let frustum = Mod.constant (Frustum.perspective 60.0 0.1 100.0 1.0) + + //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 (Mod.constant C4b.Gray) (Mod.constant Box3d.Unit) + |> Sg.shader { + do! DefaultSurfaces.trafo + do! DefaultSurfaces.vertexColor + do! DefaultSurfaces.simpleLighting + } + |> Sg.requirePicking + |> Sg.noEvents + //|> Sg.withEvents [ + // //onclick select + // //onenter enter + // //onleave exit + //] + ) + ] + //) + + 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 = + { + unpersist = Unpersist.instance + threads = fun model -> CameraController.threads model.camera |> ThreadPool.map CameraMessage + initial = initial + update = update + view = view + } + + let start () = App.start app \ No newline at end of file diff --git a/src/ModelUpdateView/BoxSelectionDemo_Finished.fs b/src/ModelUpdateView/BoxSelectionDemo_Finished.fs new file mode 100644 index 0000000..f7633d5 --- /dev/null +++ b/src/ModelUpdateView/BoxSelectionDemo_Finished.fs @@ -0,0 +1,150 @@ +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_Finished = + 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 } + | AddBox -> + let i = model.boxes.Count + let box = Primitives.mkNthBox i (i+1) |> Primitives.mkVisibleBox Primitives.colors.[i % 5] + + { model with boxes = PList.append box model.boxes } + | RemoveBox -> + let i = model.boxes.Count - 1 + let boxes = PList.removeAt i model.boxes + + {model with boxes = boxes} + | ClearSelection -> { model with selectedBoxes = HSet.empty} + + 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 Primitives.selectionColor else box.color) + + let color = + model.boxHovered |> Mod.bind ( + function x -> match x with + | Some k -> if k = id then Mod.constant Primitives.hoverColor else color + | None -> 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;" + ]) + ( + model.boxes + |> AList.toASet + |> ASet.map (function b -> mkISg model b) + |> Sg.set + |> Sg.noEvents + ) + div [style "width:35%; height: 100%; float:right"] [ + div [clazz "ui buttons"] [ + button [clazz "ui button"; onMouseClick (fun _ -> AddBox)] [text "Add Box"] + button [clazz "ui button"; onMouseClick (fun _ -> RemoveBox)] [text "Remove Box"] + button [clazz "ui button"; onMouseClick (fun _ -> ClearSelection)] [text "Clear Selection"] + ] + + Incremental.div + (AttributeMap.ofList [clazz "ui divided list"]) ( + alist { + for b in model.boxes do + let! c = mkColor model b + + let bgc = sprintf "background: %s" (Html.ofC4b c) + + yield div [clazz "item"; style bgc; + onClick(fun _ -> Select (b.id |> Mod.force)) + onMouseEnter(fun _ -> HoverIn (b.id |> Mod.force)) + onMouseLeave(fun _ -> HoverOut)] [ + i [clazz "medium File Outline middle aligned icon"][] + ] + } + ) + ] + ] + ) + + let initial = + { + camera = CameraController.initial + boxHovered = None + boxes = 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 = + { + unpersist = Unpersist.instance + threads = fun model -> CameraController.threads model.camera |> ThreadPool.map CameraMessage + initial = initial + update = update + view = view + } + + let start () = App.start app \ No newline at end of file diff --git a/src/ModelUpdateView/BoxSelectionModel.fs b/src/ModelUpdateView/BoxSelectionModel.fs new file mode 100644 index 0000000..8d42ed6 --- /dev/null +++ b/src/ModelUpdateView/BoxSelectionModel.fs @@ -0,0 +1,28 @@ +namespace BoxSelectionModel + +open Aardvark.Base +open Aardvark.Base.Incremental +open Aardvark.UI.Primitives +open Boxes + + +[] +type BoxSelectionDemoModel = { + camera : CameraControllerState + //rendering : RenderingParameters + + boxes : plist + boxesSet : hset + + boxHovered : option + selectedBoxes : hset +} + +type Action = + | CameraMessage of CameraControllerMessage + | Select of string + | ClearSelection + | HoverIn of string + | HoverOut + | AddBox + | RemoveBox \ No newline at end of file diff --git a/src/ModelUpdateView/BoxSelectionModel.g.fs b/src/ModelUpdateView/BoxSelectionModel.g.fs new file mode 100644 index 0000000..0d42871 --- /dev/null +++ b/src/ModelUpdateView/BoxSelectionModel.g.fs @@ -0,0 +1,83 @@ +namespace BoxSelectionModel + +open System +open Aardvark.Base +open Aardvark.Base.Incremental +open BoxSelectionModel + +[] +module Mutable = + + + + type MBoxSelectionDemoModel(__initial : BoxSelectionModel.BoxSelectionDemoModel) = + inherit obj() + let mutable __current : Aardvark.Base.Incremental.IModRef = Aardvark.Base.Incremental.EqModRef(__initial) :> Aardvark.Base.Incremental.IModRef + let _camera = Aardvark.UI.Primitives.Mutable.MCameraControllerState.Create(__initial.camera) + 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)) + let _boxHovered = MOption.Create(__initial.boxHovered) + let _selectedBoxes = MSet.Create(__initial.selectedBoxes) + + member x.camera = _camera + member x.boxes = _boxes :> alist<_> + member x.boxesSet = _boxesSet :> aset<_> + member x.boxHovered = _boxHovered :> IMod<_> + member x.selectedBoxes = _selectedBoxes :> aset<_> + + member x.Current = __current :> IMod<_> + member x.Update(v : BoxSelectionModel.BoxSelectionDemoModel) = + if not (System.Object.ReferenceEquals(__current.Value, v)) then + __current.Value <- v + + Aardvark.UI.Primitives.Mutable.MCameraControllerState.Update(_camera, v.camera) + MList.Update(_boxes, v.boxes) + MSet.Update(_boxesSet, v.boxesSet) + MOption.Update(_boxHovered, v.boxHovered) + MSet.Update(_selectedBoxes, v.selectedBoxes) + + + static member Create(__initial : BoxSelectionModel.BoxSelectionDemoModel) : MBoxSelectionDemoModel = MBoxSelectionDemoModel(__initial) + static member Update(m : MBoxSelectionDemoModel, v : BoxSelectionModel.BoxSelectionDemoModel) = m.Update(v) + + override x.ToString() = __current.Value.ToString() + member x.AsString = sprintf "%A" __current.Value + interface IUpdatable with + member x.Update v = x.Update v + + + + [] + module BoxSelectionDemoModel = + [] + module Lens = + let camera = + { new Lens() 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>() 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>() 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 } + } + let boxHovered = + { new Lens>() 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>() 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 } + } diff --git a/src/ModelUpdateView/BoxesApp.fs b/src/ModelUpdateView/BoxesApp.fs new file mode 100644 index 0000000..5ef60dd --- /dev/null +++ b/src/ModelUpdateView/BoxesApp.fs @@ -0,0 +1,72 @@ +namespace ActionLifting + +open Aardvark.Base +open Aardvark.Base.Incremental +open Aardvark.UI + +open ActionLiftingModel +open Boxes + +module BoxesApp = + open BoxSelectionDemo + + + let update (m:BoxesModel) (a:BoxesAction) = + match a with + | AddBox _ -> + let i = m.boxes.Count + let box = Primitives.mkNthBox i (i+1) |> Primitives.mkVisibleBox Primitives.colors.[i % 5] + + { m with boxes = PList.append box m.boxes } + | RemoveBox _ -> + let i = m.boxes.Count - 1 + let boxes = PList.removeAt i m.boxes + + { m with boxes = boxes } + + let view (m:MBoxesModel)(mkColor : MVisibleBox -> IMod) = + div[][ + div [clazz "ui buttons"] [ + button [clazz "ui button"; onMouseClick (fun _ -> AddBox)] [text "Add Box"] + button [clazz "ui button"; onMouseClick (fun _ -> RemoveBox)] [text "Remove Box"] + ] + + Incremental.div (AttributeMap.ofList [clazz "ui divided list"]) ( + alist { + for b in m.boxes do + let! c = mkColor b + + let bgc = sprintf "background: %s" (Html.ofC4b c) + + //onClick(fun _ -> Select (b.id |> Mod.force)) + yield div [clazz "item"; style bgc][ + i [clazz "medium File Outline middle aligned icon"][] + ] + } + ) + ] + + //let viewAnnotationsInGroup (path:list) (model:MDrawingModel)(select : MAnnotation -> 'outer)(lift : AnnotationGroups.Action -> 'outer) (annotations: alist) : alist> = + + let view' (m:MBoxesModel)(mkColor : MVisibleBox -> IMod) (select : MVisibleBox -> 'outer) (lift : BoxesAction -> 'outer) : DomNode<'outer>= + + div[][ + div [clazz "ui buttons"] [ + button [clazz "ui button"; onMouseClick (fun _ -> lift AddBox)] [text "Add Box"] + button [clazz "ui button"; onMouseClick (fun _ -> lift RemoveBox)] [text "Remove Box"] + ] + + Incremental.div (AttributeMap.ofList [clazz "ui divided list"]) ( + alist { + for b in m.boxes do + let! c = mkColor b + + let bgc = sprintf "background: %s" (Html.ofC4b c) + + let select = fun _ -> select b + yield div [clazz "item"; style bgc; onClick select][ + i [clazz "medium File Outline middle aligned icon"][] + ] + } + ) + ] diff --git a/src/ModelUpdateView/BoxesApp2.fs b/src/ModelUpdateView/BoxesApp2.fs new file mode 100644 index 0000000..74285f4 --- /dev/null +++ b/src/ModelUpdateView/BoxesApp2.fs @@ -0,0 +1,82 @@ +namespace ConfigLenses + +open Aardvark.Base +open Aardvark.Base.Incremental +open Aardvark.UI + +open ActionLiftingModel +open Boxes + +module BoxesApp = + open BoxSelectionDemo + + type InnerConfig<'a> = { + colors : Lens<'a, list> + } + + let update<'a> (outerConfig : 'a) (innerConfig : InnerConfig<'a>) (m:BoxesModel) (a:BoxesAction) = + match a with + | AddBox _ -> + let i = m.boxes.Count + let colors = innerConfig.colors.Get outerConfig + let box = + Primitives.mkNthBox i (i+1) + |> Primitives.mkVisibleBox colors.[i % 5] + + { m with boxes = PList.append box m.boxes } + | RemoveBox _ -> + let i = m.boxes.Count - 1 + let boxes = PList.removeAt i m.boxes + + { m with boxes = boxes } + + type MInnerConfig<'ma> = { + colors : 'ma -> IMod + } + + let view (m:MBoxesModel)(mkColor : MVisibleBox -> IMod) = + div[][ + div [clazz "ui buttons"] [ + button [clazz "ui button"; onMouseClick (fun _ -> AddBox)] [text "Add Box"] + button [clazz "ui button"; onMouseClick (fun _ -> RemoveBox)] [text "Remove Box"] + ] + + Incremental.div (AttributeMap.ofList [clazz "ui divided list"]) ( + alist { + for b in m.boxes do + let! c = mkColor b + + let bgc = sprintf "background: %s" (Html.ofC4b c) + + //onClick(fun _ -> Select (b.id |> Mod.force)) + yield div [clazz "item"; style bgc][ + i [clazz "medium File Outline middle aligned icon"][] + ] + } + ) + ] + + //let viewAnnotationsInGroup (path:list) (model:MDrawingModel)(select : MAnnotation -> 'outer)(lift : AnnotationGroups.Action -> 'outer) (annotations: alist) : alist> = + + let view' (m:MBoxesModel)(mkColor : MVisibleBox -> IMod) (select : MVisibleBox -> 'outer) (lift : BoxesAction -> 'outer) : DomNode<'outer>= + + div[][ + div [clazz "ui buttons"] [ + button [clazz "ui button"; onMouseClick (fun _ -> lift AddBox)] [text "Add Box"] + button [clazz "ui button"; onMouseClick (fun _ -> lift RemoveBox)] [text "Remove Box"] + ] + + Incremental.div (AttributeMap.ofList [clazz "ui divided list"]) ( + alist { + for b in m.boxes do + let! c = mkColor b + + let bgc = sprintf "background: %s" (Html.ofC4b c) + + let select = fun _ -> select b + yield div [clazz "item"; style bgc; onClick select][ + i [clazz "medium File Outline middle aligned icon"][] + ] + } + ) + ] diff --git a/src/ModelUpdateView/BoxesModel.fs b/src/ModelUpdateView/BoxesModel.fs new file mode 100644 index 0000000..42cd907 --- /dev/null +++ b/src/ModelUpdateView/BoxesModel.fs @@ -0,0 +1,14 @@ +namespace Boxes + +open Aardvark.Base +open Aardvark.Base.Incremental +open Aardvark.UI.Primitives + +[] +type VisibleBox = { + geometry : Box3d + color : C4b + + [] + id : string +} \ No newline at end of file diff --git a/src/ModelUpdateView/BoxesModel.g.fs b/src/ModelUpdateView/BoxesModel.g.fs new file mode 100644 index 0000000..0367fb9 --- /dev/null +++ b/src/ModelUpdateView/BoxesModel.g.fs @@ -0,0 +1,65 @@ +namespace Boxes + +open System +open Aardvark.Base +open Aardvark.Base.Incremental +open Boxes + +[] +module Mutable = + + + + type MVisibleBox(__initial : Boxes.VisibleBox) = + inherit obj() + let mutable __current : Aardvark.Base.Incremental.IModRef = Aardvark.Base.Incremental.EqModRef(__initial) :> Aardvark.Base.Incremental.IModRef + let _geometry = ResetMod.Create(__initial.geometry) + let _color = ResetMod.Create(__initial.color) + let _id = ResetMod.Create(__initial.id) + + member x.geometry = _geometry :> IMod<_> + member x.color = _color :> IMod<_> + member x.id = _id :> IMod<_> + + member x.Current = __current :> IMod<_> + member x.Update(v : Boxes.VisibleBox) = + if not (System.Object.ReferenceEquals(__current.Value, v)) then + __current.Value <- v + + ResetMod.Update(_geometry,v.geometry) + ResetMod.Update(_color,v.color) + _id.Update(v.id) + + + static member Create(__initial : Boxes.VisibleBox) : MVisibleBox = MVisibleBox(__initial) + static member Update(m : MVisibleBox, v : Boxes.VisibleBox) = m.Update(v) + + override x.ToString() = __current.Value.ToString() + member x.AsString = sprintf "%A" __current.Value + interface IUpdatable with + member x.Update v = x.Update v + + + + [] + module VisibleBox = + [] + module Lens = + let geometry = + { new Lens() with + override x.Get(r) = r.geometry + override x.Set(r,v) = { r with geometry = v } + override x.Update(r,f) = { r with geometry = f r.geometry } + } + let color = + { new Lens() with + override x.Get(r) = r.color + override x.Set(r,v) = { r with color = v } + override x.Update(r,f) = { r with color = f r.color } + } + let id = + { new Lens() with + override x.Get(r) = r.id + override x.Set(r,v) = { r with id = v } + override x.Update(r,f) = { r with id = f r.id } + } diff --git a/src/ModelUpdateView/ConfigLenses.fs b/src/ModelUpdateView/ConfigLenses.fs new file mode 100644 index 0000000..a06ecf1 --- /dev/null +++ b/src/ModelUpdateView/ConfigLenses.fs @@ -0,0 +1,99 @@ +namespace ConfigLenses + +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 ConfigLenses = + open Boxes + open BoxSelectionDemo + + let innerConfig : BoxesApp.InnerConfig = { colors = ActionLiftingModel.Lens.colors } + + 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 innerConfig 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= + + 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 = Primitives.colorsBlue + } + + 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 \ No newline at end of file diff --git a/src/ModelUpdateView/Lenses.fs b/src/ModelUpdateView/Lenses.fs new file mode 100644 index 0000000..5266ab9 --- /dev/null +++ b/src/ModelUpdateView/Lenses.fs @@ -0,0 +1,44 @@ +namespace Lenses + + + +open Aardvark.Base // for math such as V3d +open Aardvark.Base.Incremental // for Mods etc and [] +open Aardvark.Base.Rendering // for render attribs such as cullMode +open Aardvark.UI.Primitives // for primitives such as camera controller state + +open LensesModel + +module LensesStuff = + + let update (a : A)(v:string) = + { a with b = { a.b with c = { a.b.c with value = v }}} + + let updateValue(v : string) (c : C) = + { c with value = v } + + let updateC (c : C) (b : B)= + { b with c = c } + + let updateB (b : B) (a : A) = + { a with b = b } + + + let run = + let init = A1.initial + + let a' = + { init with b = { init.b with c = { init.b.c with value = "hello world1" }}} + + + let c' = init.b.c |> updateValue "hello world2" + let b' = init.b |> updateC c' + let a' = init |> updateB b' + + let l = A.Lens.b |. B.Lens.c |. C.Lens.value + let a' = l.Set(init, "hello world 3") + + a' + //let m = update + + diff --git a/src/ModelUpdateView/LensesModel.fs b/src/ModelUpdateView/LensesModel.fs new file mode 100644 index 0000000..23b12d7 --- /dev/null +++ b/src/ModelUpdateView/LensesModel.fs @@ -0,0 +1,31 @@ +namespace LensesModel + +open Aardvark.Base // for math such as V3d +open Aardvark.Base.Incremental // for Mods etc and [] +open Aardvark.Base.Rendering // for render attribs such as cullMode +open Aardvark.UI.Primitives // for primitives such as camera controller state + +[] +type C = { + value : string +} + +[] +type B = { + c : C +} + +[] +type A = { + b : B +} + +module A1 = + let initial = { + b = { + c = { + value = "initial" }}} + + + + diff --git a/src/ModelUpdateView/LensesModel.g.fs b/src/ModelUpdateView/LensesModel.g.fs new file mode 100644 index 0000000..130df32 --- /dev/null +++ b/src/ModelUpdateView/LensesModel.g.fs @@ -0,0 +1,121 @@ +namespace LensesModel + +open System +open Aardvark.Base +open Aardvark.Base.Incremental +open LensesModel + +[] +module Mutable = + + + + type MC(__initial : LensesModel.C) = + inherit obj() + let mutable __current : Aardvark.Base.Incremental.IModRef = Aardvark.Base.Incremental.EqModRef(__initial) :> Aardvark.Base.Incremental.IModRef + let _value = ResetMod.Create(__initial.value) + + member x.value = _value :> IMod<_> + + member x.Current = __current :> IMod<_> + member x.Update(v : LensesModel.C) = + if not (System.Object.ReferenceEquals(__current.Value, v)) then + __current.Value <- v + + ResetMod.Update(_value,v.value) + + + static member Create(__initial : LensesModel.C) : MC = MC(__initial) + static member Update(m : MC, v : LensesModel.C) = m.Update(v) + + override x.ToString() = __current.Value.ToString() + member x.AsString = sprintf "%A" __current.Value + interface IUpdatable with + member x.Update v = x.Update v + + + + [] + module C = + [] + module Lens = + let value = + { new Lens() with + override x.Get(r) = r.value + override x.Set(r,v) = { r with value = v } + override x.Update(r,f) = { r with value = f r.value } + } + + + type MB(__initial : LensesModel.B) = + inherit obj() + let mutable __current : Aardvark.Base.Incremental.IModRef = Aardvark.Base.Incremental.EqModRef(__initial) :> Aardvark.Base.Incremental.IModRef + let _c = MC.Create(__initial.c) + + member x.c = _c + + member x.Current = __current :> IMod<_> + member x.Update(v : LensesModel.B) = + if not (System.Object.ReferenceEquals(__current.Value, v)) then + __current.Value <- v + + MC.Update(_c, v.c) + + + static member Create(__initial : LensesModel.B) : MB = MB(__initial) + static member Update(m : MB, v : LensesModel.B) = m.Update(v) + + override x.ToString() = __current.Value.ToString() + member x.AsString = sprintf "%A" __current.Value + interface IUpdatable with + member x.Update v = x.Update v + + + + [] + module B = + [] + module Lens = + let c = + { new Lens() with + override x.Get(r) = r.c + override x.Set(r,v) = { r with c = v } + override x.Update(r,f) = { r with c = f r.c } + } + + + type MA(__initial : LensesModel.A) = + inherit obj() + let mutable __current : Aardvark.Base.Incremental.IModRef = Aardvark.Base.Incremental.EqModRef(__initial) :> Aardvark.Base.Incremental.IModRef + let _b = MB.Create(__initial.b) + + member x.b = _b + + member x.Current = __current :> IMod<_> + member x.Update(v : LensesModel.A) = + if not (System.Object.ReferenceEquals(__current.Value, v)) then + __current.Value <- v + + MB.Update(_b, v.b) + + + static member Create(__initial : LensesModel.A) : MA = MA(__initial) + static member Update(m : MA, v : LensesModel.A) = m.Update(v) + + override x.ToString() = __current.Value.ToString() + member x.AsString = sprintf "%A" __current.Value + interface IUpdatable with + member x.Update v = x.Update v + + + + [] + module A = + [] + module Lens = + let b = + { new Lens() with + override x.Get(r) = r.b + override x.Set(r,v) = { r with b = v } + override x.Update(r,f) = { r with b = f r.b } + } diff --git a/src/ModelUpdateView/ModelUpdateView.fsproj b/src/ModelUpdateView/ModelUpdateView.fsproj new file mode 100644 index 0000000..b33702c --- /dev/null +++ b/src/ModelUpdateView/ModelUpdateView.fsproj @@ -0,0 +1,55 @@ + + + Exe + netcoreapp2.0 + true + + + + bin\Debug\ + + + bin\Release\ + + + + $(OutputPath)\$(TargetFramework) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/src/ModelUpdateView/NumericControl.fs b/src/ModelUpdateView/NumericControl.fs new file mode 100644 index 0000000..3717a19 --- /dev/null +++ b/src/ModelUpdateView/NumericControl.fs @@ -0,0 +1,56 @@ +module NumericControl + +open Aardvark.Base // math stuff such as V3d, Trafo3d +open Aardvark.UI // the base infrastructure for elm style aardvark applications + +open NumericControlNs +open Aardvark.Base.Incremental + +type Action = Increment | Decrement + +let update (m : NumericModel) (a : Action) = + match a with + | Increment -> { m with value = m.value + 0.1 } + | Decrement -> { m with value = m.value - 0.1 } + +let view (m : MNumericModel) = + require Html.semui ( + body [] ( + [ + div [] [ + button [clazz "ui button"; onClick (fun _ -> Increment)] [text "+"] + button [clazz "ui button"; onClick (fun _ -> Decrement)] [text "-"] + br [] + text "my value:" + br [] + Incremental.text (m.value |> Mod.map(fun x -> x.ToString())) + ] + ] + ) + ) + +let view' (m : MNumericModel) = + require Html.semui ( + table [][ + tr[] [ + td[] [a [clazz "ui label circular Big"] [Incremental.text (m.value |> Mod.map(fun x -> sprintf "%.1f" x))]] + td[] [div[clazz "ui buttons"][ + button [clazz "ui icon button"; onClick (fun _ -> Increment)] [text "+"] + button [clazz "ui icon button"; onClick (fun _ -> Decrement)] [text "-"] + ] + ] + ] + ] + ) + +let app = + { + unpersist = Unpersist.instance //ignore for now + threads = fun _ -> ThreadPool.empty //ignore for now + initial = { value = 0.0 } + update = update + view = view + } + +let start() = App.start app + diff --git a/src/ModelUpdateView/NumericControlModel.fs b/src/ModelUpdateView/NumericControlModel.fs new file mode 100644 index 0000000..4e6bd66 --- /dev/null +++ b/src/ModelUpdateView/NumericControlModel.fs @@ -0,0 +1,16 @@ +namespace NumericControlNs + +open Aardvark.Base // for math such as V3d +open Aardvark.Base.Incremental // for Mods etc and [] +open Aardvark.Base.Rendering // for render attribs such as cullMode +open Aardvark.UI.Primitives // for primitives such as camera controller state + +[] // records can be marked as domaintypes +type NumericModel = { + value : float +} + +[] +module NumericModel = + let initial = { value = 1.0 } + diff --git a/src/ModelUpdateView/NumericControlModel.g.fs b/src/ModelUpdateView/NumericControlModel.g.fs new file mode 100644 index 0000000..b8a03b2 --- /dev/null +++ b/src/ModelUpdateView/NumericControlModel.g.fs @@ -0,0 +1,47 @@ +namespace NumericControlNs + +open System +open Aardvark.Base +open Aardvark.Base.Incremental +open NumericControlNs + +[] +module Mutable = + + + + type MNumericModel(__initial : NumericControlNs.NumericModel) = + inherit obj() + let mutable __current : Aardvark.Base.Incremental.IModRef = Aardvark.Base.Incremental.EqModRef(__initial) :> Aardvark.Base.Incremental.IModRef + let _value = ResetMod.Create(__initial.value) + + member x.value = _value :> IMod<_> + + member x.Current = __current :> IMod<_> + member x.Update(v : NumericControlNs.NumericModel) = + if not (System.Object.ReferenceEquals(__current.Value, v)) then + __current.Value <- v + + ResetMod.Update(_value,v.value) + + + static member Create(__initial : NumericControlNs.NumericModel) : MNumericModel = MNumericModel(__initial) + static member Update(m : MNumericModel, v : NumericControlNs.NumericModel) = m.Update(v) + + override x.ToString() = __current.Value.ToString() + member x.AsString = sprintf "%A" __current.Value + interface IUpdatable with + member x.Update v = x.Update v + + + + [] + module NumericModel = + [] + module Lens = + let value = + { new Lens() with + override x.Get(r) = r.value + override x.Set(r,v) = { r with value = v } + override x.Update(r,f) = { r with value = f r.value } + } diff --git a/src/ModelUpdateView/NumericControl_Empty.fs b/src/ModelUpdateView/NumericControl_Empty.fs new file mode 100644 index 0000000..d89273d --- /dev/null +++ b/src/ModelUpdateView/NumericControl_Empty.fs @@ -0,0 +1,32 @@ +module NumericControl_Empty + +open Aardvark.Base // math stuff such as V3d, Trafo3d +open Aardvark.UI // the base infrastructure for elm style aardvark applications +open Aardvark.Base.Incremental + +open NumericControlNs + +type Action = Increment | Decrement + +let update (m : NumericModel) (a : Action) = m + +let view (m : MNumericModel) = + require Html.semui ( + body [] ( + [ + div [] [text "hello world"] + ] + ) + ) + +let app = + { + unpersist = Unpersist.instance + threads = fun _ -> ThreadPool.empty + initial = { value = 0.0 } + update = update + view = view + } + +let start() = App.start app + diff --git a/src/ModelUpdateView/Program.fs b/src/ModelUpdateView/Program.fs new file mode 100644 index 0000000..54af3b4 --- /dev/null +++ b/src/ModelUpdateView/Program.fs @@ -0,0 +1,26 @@ +open Aardium +open Aardvark.UI +open Suave +open Aardvark.Application.Slim +open Aardvark.Base + +[] +let main args = + Ag.initialize() + Aardvark.Init() + Aardium.init() + + let app = new OpenGlApplication() + + WebPart.startServer 4321 [ + MutableApp.toWebPart' app.Runtime false (App.start VectorControl_Empty.app) + ] |> ignore + + Aardium.run { + title "Aardvark rocks \\o/" + width 1024 + height 768 + url "http://localhost:4321/" + } + + 0 \ No newline at end of file diff --git a/src/ModelUpdateView/SimpleScaleApp.fs b/src/ModelUpdateView/SimpleScaleApp.fs new file mode 100644 index 0000000..765eb7f --- /dev/null +++ b/src/ModelUpdateView/SimpleScaleApp.fs @@ -0,0 +1,59 @@ +module SimpleScaleApp_empty + +open SimpleScaleModel +open Aardvark.UI +open Aardvark.UI.Primitives +open Aardvark.Base.Incremental +open Aardvark.Base +open Aardvark.Base.Rendering +open VectorControlNs +open FShade.Imperative.CVecComponent + +type Action = + | CameraMessage of ArcBallController.Message + | ChangeScale of VectorControl.Action + +let update (model : Model) (act : Action) : Model = + match act with + | CameraMessage a -> { model with camera = ArcBallController.update model.camera a} + | ChangeScale a -> model //update scale via vector control + +let view (model : MModel) = + + let frustum = Mod.constant (Frustum.perspective 60.0 0.1 100.0 1.0) + + require (Html.semui) ( + div [clazz "ui"; style "background-color: #1B1C1E"] [ + ArcBallController.controlledControl model.camera CameraMessage frustum + (AttributeMap.ofList [ + attribute "style" "width:65%; height: 100%; float: left;" + ]) + ( + //make sg list + + [] |> Sg.ofList + |> Sg.shader { + do! DefaultSurfaces.trafo + do! DefaultSurfaces.vertexColor + do! DefaultSurfaces.simpleLighting + } + ) + + div [style "width:35%; height: 100%; float:right; background-color: #1B1C1E"] [ + div [] [ + text "add vector control to scale sgs" + ] + ] + ] + ) + +let app : App = + { + unpersist = Unpersist.instance + threads = fun model -> ArcBallController.threads model.camera |> ThreadPool.map CameraMessage + initial = Model.initial + update = update + view = view + } + +let start () = App.start app \ No newline at end of file diff --git a/src/ModelUpdateView/SimpleScaleApp_empty.fs b/src/ModelUpdateView/SimpleScaleApp_empty.fs new file mode 100644 index 0000000..f7873be --- /dev/null +++ b/src/ModelUpdateView/SimpleScaleApp_empty.fs @@ -0,0 +1,79 @@ +module SimpleScaleApp + +open SimpleScaleModel +open Aardvark.UI +open Aardvark.UI.Primitives +open Aardvark.Base.Incremental +open Aardvark.Base +open Aardvark.Base.Rendering +open VectorControlNs +open FShade.Imperative.CVecComponent + +type Action = + | CameraMessage of ArcBallController.Message + | ChangeScale of VectorControl.Action + +let update (model : Model) (act : Action) : Model = + match act with + | CameraMessage a -> { model with camera = ArcBallController.update model.camera a} + | ChangeScale a -> { model with scale = VectorControl.update model.scale a } + +let view (model : MModel) = + + let frustum = Mod.constant (Frustum.perspective 60.0 0.1 100.0 1.0) + + require (Html.semui) ( + div [clazz "ui"; style "background-color: #1B1C1E"] [ + ArcBallController.controlledControl model.camera CameraMessage frustum + (AttributeMap.ofList [ + attribute "style" "width:65%; height: 100%; float: left;" + ]) + ( + let boxGeometry = Box3d(-V3d.III, V3d.III) + let box = Mod.constant (boxGeometry) + + let localScaleTrafo = + adaptive { + let! x = model.scale.x.value + let! y = model.scale.y.value + let! z = model.scale.z.value + return Trafo3d.Scale(V3d(x,y,z)) + } + + let b = + Sg.box (Mod.constant C4b.Blue) box + + let s = + Sg.sphere 5 (Mod.constant C4b.Red) (Mod.constant 2.0) + |> Sg.trafo localScaleTrafo + + [b; s] + |> Sg.ofList + |> Sg.shader { + do! DefaultSurfaces.trafo + do! DefaultSurfaces.vertexColor + do! DefaultSurfaces.simpleLighting + } + |> Sg.fillMode (Mod.constant FillMode.Fill) + |> Sg.cullMode (Mod.constant CullMode.None) + |> Sg.noEvents + ) + + div [style "width:35%; height: 100%; float:right; background-color: #1B1C1E"] [ + div [] [ + yield VectorControl.view model.scale |> UI.map ChangeScale + ] + ] + ] + ) + +let app : App = + { + unpersist = Unpersist.instance + threads = fun model -> ArcBallController.threads model.camera |> ThreadPool.map CameraMessage + initial = Model.initial + update = update + view = view + } + +let start () = App.start app \ No newline at end of file diff --git a/src/ModelUpdateView/SimpleScaleModel.fs b/src/ModelUpdateView/SimpleScaleModel.fs new file mode 100644 index 0000000..990ab21 --- /dev/null +++ b/src/ModelUpdateView/SimpleScaleModel.fs @@ -0,0 +1,18 @@ +namespace SimpleScaleModel + +open Aardvark.Base.Incremental +open Aardvark.UI.Primitives +open Aardvark.UI +open Aardvark.Base +open VectorControlNs + +[] +type Model = + { + camera : CameraControllerState + scale : VectorModel + } + +[] +module Model = + let initial = { camera = { ArcBallController.initial with orbitCenter = Some V3d.Zero }; scale = VectorModel.initial } \ No newline at end of file diff --git a/src/ModelUpdateView/SimpleScaleModel.g.fs b/src/ModelUpdateView/SimpleScaleModel.g.fs new file mode 100644 index 0000000..5296d06 --- /dev/null +++ b/src/ModelUpdateView/SimpleScaleModel.g.fs @@ -0,0 +1,56 @@ +namespace SimpleScaleModel + +open System +open Aardvark.Base +open Aardvark.Base.Incremental +open SimpleScaleModel + +[] +module Mutable = + + + + type MModel(__initial : SimpleScaleModel.Model) = + inherit obj() + let mutable __current : Aardvark.Base.Incremental.IModRef = Aardvark.Base.Incremental.EqModRef(__initial) :> Aardvark.Base.Incremental.IModRef + let _camera = Aardvark.UI.Primitives.Mutable.MCameraControllerState.Create(__initial.camera) + let _scale = VectorControlNs.Mutable.MVectorModel.Create(__initial.scale) + + member x.camera = _camera + member x.scale = _scale + + member x.Current = __current :> IMod<_> + member x.Update(v : SimpleScaleModel.Model) = + if not (System.Object.ReferenceEquals(__current.Value, v)) then + __current.Value <- v + + Aardvark.UI.Primitives.Mutable.MCameraControllerState.Update(_camera, v.camera) + VectorControlNs.Mutable.MVectorModel.Update(_scale, v.scale) + + + static member Create(__initial : SimpleScaleModel.Model) : MModel = MModel(__initial) + static member Update(m : MModel, v : SimpleScaleModel.Model) = m.Update(v) + + override x.ToString() = __current.Value.ToString() + member x.AsString = sprintf "%A" __current.Value + interface IUpdatable with + member x.Update v = x.Update v + + + + [] + module Model = + [] + module Lens = + let camera = + { new Lens() 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 scale = + { new Lens() with + override x.Get(r) = r.scale + override x.Set(r,v) = { r with scale = v } + override x.Update(r,f) = { r with scale = f r.scale } + } diff --git a/src/ModelUpdateView/VectorControl.fs b/src/ModelUpdateView/VectorControl.fs new file mode 100644 index 0000000..a12bcbd --- /dev/null +++ b/src/ModelUpdateView/VectorControl.fs @@ -0,0 +1,76 @@ +module VectorControl + +open Aardvark.Base // math stuff such as V3d, Trafo3d +open Aardvark.Base.Incremental +open Aardvark.UI // the base infrastructure for elm style aardvark applications + +open VectorControlNs +open NumericControlNs + +type Action = + | UpdateX of NumericControl.Action + | UpdateY of NumericControl.Action + | UpdateZ of NumericControl.Action + | Normalize + | Reset + +let toVectorModel (v : V3d) = + let x : NumericModel = { value = v.X } + let y : NumericModel = { value = v.Y } + let z : NumericModel = { value = v.Z } + + { x = x; y = y; z = z } +// call update logic of indiviual numeric controls +let update (m : VectorModel) (a : Action) = + match a with + | UpdateX a -> { m with x = NumericControl.update m.x a } + | UpdateY a -> { m with y = NumericControl.update m.y a } + | UpdateZ a -> { m with z = NumericControl.update m.z a } + | Normalize -> + let v = V3d(m.x.value,m.y.value,m.z.value) + v.Normalized |> toVectorModel + | Reset -> VectorModel.initial + +let view (m : MVectorModel) = + require Html.semui ( + div[][ + table [] [ + tr[][ + td[][a [clazz "ui label circular Big"][text "X:"]] + td[][NumericControl.view' m.x |> UI.map UpdateX] + ] + tr[][ + td[][a [clazz "ui label circular Big"][text "Y:"]] + td[][NumericControl.view' m.y |> UI.map UpdateY] + ] + tr[][ + td[][a [clazz "ui label circular Big"][text "Z:"]] + td[][NumericControl.view' m.z |> UI.map UpdateZ] + ] + tr[][ + td[attribute "colspan" "2"][ + div[clazz "ui buttons small"][ + button [clazz "ui button"; onClick (fun _ -> Normalize)] [text "Norm"] + button [clazz "ui button"; onClick (fun _ -> Reset)] [text "Reset"] + ] + ] + ] + ] + ] + ) + +let app = + { + unpersist = Unpersist.instance + threads = fun _ -> ThreadPool.empty + initial = VectorModel.initial + update = update + view = view + } + +let start() = App.start app + + + + + diff --git a/src/ModelUpdateView/VectorControlModel.fs b/src/ModelUpdateView/VectorControlModel.fs new file mode 100644 index 0000000..1539645 --- /dev/null +++ b/src/ModelUpdateView/VectorControlModel.fs @@ -0,0 +1,20 @@ +namespace VectorControlNs + +open Aardvark.Base // for math such as V3d +open Aardvark.Base.Incremental // for Mods etc and [] +open Aardvark.Base.Rendering // for render attribs such as cullMode +open Aardvark.UI.Primitives // for primitives such as camera controller state +open NumericControlNs + +[] // records can be marked as domaintypes +type VectorModel = { + x : NumericModel + y : NumericModel + z : NumericModel +} + +[] +module VectorModel = + let initial = { x = NumericModel.initial; y = NumericModel.initial; z = NumericModel.initial } + + diff --git a/src/ModelUpdateView/VectorControlModel.g.fs b/src/ModelUpdateView/VectorControlModel.g.fs new file mode 100644 index 0000000..dd493ea --- /dev/null +++ b/src/ModelUpdateView/VectorControlModel.g.fs @@ -0,0 +1,65 @@ +namespace VectorControlNs + +open System +open Aardvark.Base +open Aardvark.Base.Incremental +open VectorControlNs + +[] +module Mutable = + + + + type MVectorModel(__initial : VectorControlNs.VectorModel) = + inherit obj() + let mutable __current : Aardvark.Base.Incremental.IModRef = Aardvark.Base.Incremental.EqModRef(__initial) :> Aardvark.Base.Incremental.IModRef + let _x = NumericControlNs.Mutable.MNumericModel.Create(__initial.x) + let _y = NumericControlNs.Mutable.MNumericModel.Create(__initial.y) + let _z = NumericControlNs.Mutable.MNumericModel.Create(__initial.z) + + member x.x = _x + member x.y = _y + member x.z = _z + + member x.Current = __current :> IMod<_> + member x.Update(v : VectorControlNs.VectorModel) = + if not (System.Object.ReferenceEquals(__current.Value, v)) then + __current.Value <- v + + NumericControlNs.Mutable.MNumericModel.Update(_x, v.x) + NumericControlNs.Mutable.MNumericModel.Update(_y, v.y) + NumericControlNs.Mutable.MNumericModel.Update(_z, v.z) + + + static member Create(__initial : VectorControlNs.VectorModel) : MVectorModel = MVectorModel(__initial) + static member Update(m : MVectorModel, v : VectorControlNs.VectorModel) = m.Update(v) + + override x.ToString() = __current.Value.ToString() + member x.AsString = sprintf "%A" __current.Value + interface IUpdatable with + member x.Update v = x.Update v + + + + [] + module VectorModel = + [] + module Lens = + let x = + { new Lens() with + override x.Get(r) = r.x + override x.Set(r,v) = { r with x = v } + override x.Update(r,f) = { r with x = f r.x } + } + let y = + { new Lens() with + override x.Get(r) = r.y + override x.Set(r,v) = { r with y = v } + override x.Update(r,f) = { r with y = f r.y } + } + let z = + { new Lens() with + override x.Get(r) = r.z + override x.Set(r,v) = { r with z = v } + override x.Update(r,f) = { r with z = f r.z } + } diff --git a/src/ModelUpdateView/VectorControl_empty.fs b/src/ModelUpdateView/VectorControl_empty.fs new file mode 100644 index 0000000..b8864a8 --- /dev/null +++ b/src/ModelUpdateView/VectorControl_empty.fs @@ -0,0 +1,64 @@ +module VectorControl_Empty + +open Aardvark.Base // math stuff such as V3d, Trafo3d +open Aardvark.Base.Incremental +open Aardvark.UI // the base infrastructure for elm style aardvark applications + +open VectorControlNs + +// reuse numeric actions +type Action = + | SetX of NumericControl.Action + | SetY of NumericControl.Action + | SetZ of NumericControl.Action + +// call update logic of indiviual numeric controls +let update (m : VectorModel) (a : Action) = + match a with + | _ -> m + +// uses a table to show the individual numeric controls +let view (m : MVectorModel) = + require Html.semui ( + body [] [ + div[][ + table [] [ + tr[][ + td[][a [clazz "ui label circular Big"][text "X:"]] + td[][] + ] + tr[][ + td[][a [clazz "ui label circular Big"][text "Y:"]] + td[][] + ] + tr[][ + td[][a [clazz "ui label circular Big"][text "Z:"]] + td[][] + ] + tr[][ + td[attribute "colspan" "2"][ + div[clazz "ui buttons small"][ + text "Normalize and ResetButton" + ] + ] + ] + ] + ] + ] + ) + +let app = + { + unpersist = Unpersist.instance + threads = fun _ -> ThreadPool.empty + initial = VectorModel.initial + update = update + view = view + } + +let start() = App.start app + + + + +