diff --git a/src/Scratch/31 - VirtualTree/TreeView/TreeViewApp.fs b/src/Scratch/31 - VirtualTree/TreeView/TreeViewApp.fs index 33db8f35..b20d1e82 100644 --- a/src/Scratch/31 - VirtualTree/TreeView/TreeViewApp.fs +++ b/src/Scratch/31 - VirtualTree/TreeView/TreeViewApp.fs @@ -2,6 +2,7 @@ open Aardvark.UI open FSharp.Data.Adaptive +open System open TreeView.Model open VirtualTree.Model @@ -10,8 +11,8 @@ open VirtualTree.Utilities module TreeView = + // TODO: Remove when updated to >= Aardvark.Base 5.2.26 module private ArraySegment = - open System let inline contains (value : 'T) (segment : ArraySegment<'T>) = let mutable state = false @@ -23,17 +24,59 @@ module TreeView = state + let inline reduce (reduction : 'T -> 'T -> 'T) (segment : ArraySegment<'T>)= + let f = OptimizedClosures.FSharpFunc<_, _, _>.Adapt (reduction) + let mutable res = segment.[0] + + for i = 1 to segment.Count - 1 do + res <- f.Invoke(res, segment.[i]) + + res + [] module private Events = - let disablePropagation event = - sprintf "$('#__ID__').on('%s', function(e) { e.stopPropagation(); } ); " event + let disableClickPropagation = + sprintf "$('#__ID__').on('click', function(e) { e.stopPropagation(); } ); " let onClickModifiers (cb : KeyModifiers -> 'msg) = onEvent "onclick" ["{ shift: event.shiftKey, alt: event.altKey, ctrl: event.ctrlKey }"] (List.head >> Pickler.json.UnPickleOfString >> cb) + let update (message : TreeView.Message<'Key>) (model : TreeView<'Key, 'Value>) = match message with + | TreeView.Message.Toggle key -> + match model.tree.hierarchy |> FlatTree.tryIndexOf key with + | ValueSome index -> + let count = model.tree.hierarchy |> FlatTree.descendantCount key + let buffer = Array.copy model.visibility + + // Set state for self and descendants + let state = + if buffer.[index] = Visibility.Visible then + Visibility.Hidden + else + Visibility.Visible + + for i = index to index + count - 1 do + buffer.[i] <- state + + // Check and adjust ancestors based on their descendants + let path = model.tree.hierarchy |> FlatTree.rootPath key + + for i = path.Length - 2 downto 0 do + let curr = path.[i] + let index = model.tree.hierarchy |> FlatTree.indexOf curr + let count = model.tree.hierarchy |> FlatTree.descendantCount curr + + if count > 1 then + buffer.[index] <- ArraySegment(buffer, index + 1, count - 1) |> ArraySegment.reduce (|||) + + { model with visibility = buffer} + + | _ -> + model + | TreeView.Message.Hover key -> { model with hovered = ValueSome key } @@ -71,6 +114,32 @@ module TreeView = let value = model.values |> AMap.find item.Value let indent = item.Depth * 16 + let checkbox = + let attributes = + AttributeMap.ofAMap <| amap { + let! visibility = model.visibility + let! hierarchy = model.tree.hierarchy + + let index = + hierarchy |> FlatTree.indexOf item.Value + + let icon = + match visibility.[index] with + | Visibility.Hidden -> "square" + | Visibility.Visible -> "check square outline" + | _ -> "minus square outline" + + yield clazz $"{icon} inverted link icon" + yield onClick (fun _ -> message <| TreeView.Message.Toggle item.Value) + } + + onBoot disableClickPropagation ( + Incremental.i attributes AList.empty + ) + + let spacer = + div [style $"width: {indent}px"] [] + let collapseIcon = let icon = if item.IsCollapsed then "caret right" else "caret down" @@ -84,8 +153,8 @@ module TreeView = TreeView.Message.Collapse item.Value |> message - onBoot (disablePropagation "click") ( - i [ clazz $"{icon} link icon"; style "color: white"; onClick (fun _ -> collapseMessage) ] [] + onBoot disableClickPropagation ( + i [ clazz $"{icon} link inverted icon"; onClick (fun _ -> collapseMessage) ] [] ) let attributes = @@ -103,7 +172,7 @@ module TreeView = |> String.concat " " yield clazz classes - yield style $"display: flex; justify-content: flex-start; align-items: center; padding: 5px; padding-left: {indent + 5}px" + yield style $"display: flex; justify-content: flex-start; align-items: center; padding: 5px" yield onMouseEnter (fun _ -> message <| TreeView.Message.Hover item.Value) yield onMouseLeave (fun _ -> message TreeView.Message.Unhover) yield onClickModifiers (fun modifiers -> message <| TreeView.Message.Click (item.Value, modifiers)) @@ -111,7 +180,9 @@ module TreeView = Incremental.div attributes <| alist { let! v = value + yield spacer yield collapseIcon + yield checkbox yield itemNode item.Value v } diff --git a/src/Scratch/31 - VirtualTree/TreeView/TreeViewModel.fs b/src/Scratch/31 - VirtualTree/TreeView/TreeViewModel.fs index 638c1d2f..85553950 100644 --- a/src/Scratch/31 - VirtualTree/TreeView/TreeViewModel.fs +++ b/src/Scratch/31 - VirtualTree/TreeView/TreeViewModel.fs @@ -3,28 +3,37 @@ open Aardvark.UI open FSharp.Data.Adaptive open Adaptify +open System open VirtualTree.Model open VirtualTree.Utilities +[] +type Visibility = + | Hidden = 1uy + | Visible = 2uy + | Intermediate = 3uy + [] type TreeView<'Key, 'Value> = { - tree : VirtualTree<'Key> - values : HashMap<'Key, 'Value> - hovered : 'Key voption + tree : VirtualTree<'Key> + values : HashMap<'Key, 'Value> + hovered : 'Key voption + visibility : Visibility[] // Visibility state for each flat tree node [] - selected : HashSet<'Key> // Adaptify does not support generic HashSets + selected : HashSet<'Key> // Adaptify does not support generic HashSets [] - lastClick : 'Key voption // For range select + lastClick : 'Key voption // For range select } module TreeView = [] type Message<'Key> = + | Toggle of key: 'Key | Hover of key: 'Key | Unhover | Click of key : 'Key * modifers: KeyModifiers @@ -46,22 +55,25 @@ module TreeView = Virtual <| VirtualTree.Message.UncollapseAll let empty<'Key, 'Value> : TreeView<'Key, 'Value> = - { tree = VirtualTree.empty - values = HashMap.empty - hovered = ValueNone - selected = HashSet.empty - lastClick = ValueNone } + { tree = VirtualTree.empty + values = HashMap.empty + visibility = Array.empty + hovered = ValueNone + selected = HashSet.empty + lastClick = ValueNone } let set (getChildren : 'Key -> #seq<'Key>) (values : HashMap<'Key, 'Value>) (root : 'Key) (tree : TreeView<'Key, 'Value>) = let flat = root |> FlatTree.ofHierarchy getChildren { empty with - tree = tree.tree |> VirtualTree.set flat - values = values } + tree = tree.tree |> VirtualTree.set flat + values = values + visibility = Array.replicate flat.Count Visibility.Visible } let initialize (getChildren : 'Key -> #seq<'Key>) (values : HashMap<'Key, 'Value>) (root : 'Key) = let flat = root |> FlatTree.ofHierarchy getChildren { empty with - tree = VirtualTree.ofTree flat - values = values } \ No newline at end of file + tree = VirtualTree.ofTree flat + values = values + visibility = Array.replicate flat.Count Visibility.Visible } \ No newline at end of file diff --git a/src/Scratch/31 - VirtualTree/VirtualTree/FlatTree.fs b/src/Scratch/31 - VirtualTree/VirtualTree/FlatTree.fs index 3a581f4a..47dbed65 100644 --- a/src/Scratch/31 - VirtualTree/VirtualTree/FlatTree.fs +++ b/src/Scratch/31 - VirtualTree/VirtualTree/FlatTree.fs @@ -6,6 +6,7 @@ open System.Text open FSharp.Data.Adaptive open Aardvark.Base +// TODO: Replace with Dict.tryFindV when updated to >= Aardvark.Base 5.2.26 [] module internal DictionaryExtensions = @@ -17,6 +18,7 @@ module internal DictionaryExtensions = else ValueNone +// TODO: Remove when updated to >= Aardvark.Base 5.2.26 module internal ArraySegment = let inline mapArray (mapping : 'T1 -> 'T2) (segment : ArraySegment<'T1>) = @@ -78,9 +80,13 @@ type FlatTree<'T> internal (nodes : ArraySegment, values : ArraySegmen FlatItem(values.[index], n.Depth, n.IsLeaf) /// Returns the index of the given node if it exists. - member x.IndexOf(value : 'T) = + member x.TryIndexOf(value : 'T) = indices.TryFindV value + /// Returns the index of the given node. + member x.IndexOf(value : 'T) = + indices.[value] + /// Returns all values that are within the index range spanned by the given values. member x.Range(input : #seq<'T>) = let mutable minIndex = Int32.MaxValue @@ -138,6 +144,12 @@ type FlatTree<'T> internal (nodes : ArraySegment, values : ArraySegmen | _ -> Array.empty + /// Returns the node's number of descendants plus 1, or 0 if it does not exist. + member x.DescendantCount(value : 'T) = + match indices.TryFindV value with + | ValueSome i -> nodes.[i].Count + | _ -> 0 + /// Returns the value and its descendants, if it exists in the tree. member x.Descendants(value : 'T) = match indices.TryFindV value with @@ -368,6 +380,10 @@ module FlatTree = let inline isRoot (value : 'T) (tree : FlatTree<'T>) = tree.IsRoot value + /// Returns the index of the given node if it exists. + let inline tryIndexOf (value : 'T) (tree : FlatTree<'T>) = + tree.TryIndexOf value + /// Returns the index of the given node if it exists. let inline indexOf (value : 'T) (tree : FlatTree<'T>) = tree.IndexOf value @@ -388,6 +404,10 @@ module FlatTree = let inline rootPath (value : 'T) (tree : FlatTree<'T>) = tree.RootPath value + /// Returns the node's number of descendants plus 1, or 0 if it does not exist. + let inline descendantCount (value : 'T) (tree : FlatTree<'T>) = + tree.DescendantCount value + /// Returns the value and its descendants, if it exists in the tree. let inline descendants (value : 'T) (tree : FlatTree<'T>) = tree.Descendants value diff --git a/src/Scratch/31 - VirtualTree/VirtualTree/VirtualTreeApp.fs b/src/Scratch/31 - VirtualTree/VirtualTree/VirtualTreeApp.fs index 5c322bf2..b3c5b0a0 100644 --- a/src/Scratch/31 - VirtualTree/VirtualTree/VirtualTreeApp.fs +++ b/src/Scratch/31 - VirtualTree/VirtualTree/VirtualTreeApp.fs @@ -43,7 +43,7 @@ module VirtualTree = tree ) - match tree.current |> FlatTree.indexOf target with + match tree.current |> FlatTree.tryIndexOf target with | ValueSome i -> { tree with scrollTarget = i * tree.height.itemHeight } | _ -> tree