[VirtualTree] Add visibility checkboxes

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
+
     [<AutoOpen>]
     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,15 +172,17 @@ 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))
                 }
 
             Incremental.div attributes <| alist {
                 let! v = value
+                yield spacer
                 yield collapseIcon
+                yield checkbox
                 yield itemNode item.Value v
             }
 

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
 
+[<Flags>]
+type Visibility =
+    | Hidden       = 1uy
+    | Visible      = 2uy
+    | Intermediate = 3uy
+
 [<ModelType>]
 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
 
         [<TreatAsValue>]
-        selected : HashSet<'Key>    // Adaptify does not support generic HashSets
+        selected : HashSet<'Key>   // Adaptify does not support generic HashSets
 
         [<NonAdaptive>]
-        lastClick : 'Key voption    // For range select
+        lastClick : 'Key voption   // For range select
     }
 
 module TreeView =
 
     [<RequireQualifiedAccess>]
     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 }
+            tree       = VirtualTree.ofTree flat
+            values     = values
+            visibility = Array.replicate flat.Count Visibility.Visible }

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
 [<AutoOpen>]
 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<FlatNode>, 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<FlatNode>, 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

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