draggable gravity centers

elm.json

@@ -12,6 +12,7 @@
             "elm/json": "1.0.0",
             "elm/svg": "1.0.1",
             "elm/time": "1.0.0",
+            "elm-community/dict-extra": "2.4.0",
             "elm-community/graph": "6.0.0",
             "elm-community/intdict": "3.0.0",
             "ianmackenzie/elm-geometry": "1.2.1",

src/Main.elm

@@ -197,7 +197,7 @@ initialModel user =
     { userUL = UL.fresh ( "Started with empty graph", user )
 
     --
-    , distractionFree = False
+    , distractionFree = True
 
     --
     , simulationState = user |> User.simulation
@@ -329,6 +329,9 @@ type Msg
     | MouseDownOnEdge EdgeId
     | MouseUpOnEdge EdgeId
       --
+    | MouseDownOnGravityCenter (List VertexId)
+    | MouseDownOnDefaultGravityCenter
+      --
     | ToggleTableOfVertices
     | ToggleTableOfEdges
       --
@@ -984,6 +987,12 @@ update msg m =
                 _ ->
                     m
 
+        MouseDownOnGravityCenter idList ->
+            { m | selectedVertices = Set.fromList idList }
+
+        MouseDownOnDefaultGravityCenter ->
+            { m | selectedVertices = Set.empty }
+
         InputBagLabel bagId str ->
             let
                 updateLabel bag =
@@ -3750,6 +3759,7 @@ mainSvg m =
         , viewVertices (presentUser m)
         , maybeBrushedSelector
         , maybeRectAroundSelectedVertices
+        , viewGravityCenters (presentUser m)
         ]
 
 
@@ -3933,8 +3943,7 @@ viewHulls user =
                 (Polygon2d.convexHull positions)
 
         hulls =
-            user
-                |> User.getBagsWithVertices
+            User.getBagsWithVertices user
                 |> Dict.values
                 |> List.filter (\( bP, _ ) -> bP.hasConvexHull)
                 |> List.map
@@ -3944,3 +3953,26 @@ viewHulls user =
                     )
     in
     S.g [] hulls
+
+
+viewGravityCenters : User -> Html Msg
+viewGravityCenters user =
+    let
+        viewGC ( coordinates, idList ) =
+            Geometry.Svg.circle2d
+                [ SA.fill (Colors.toString Colors.highlightPink)
+                , SE.onMouseDown (MouseDownOnGravityCenter idList)
+                ]
+                (Point2d.fromCoordinates coordinates |> Circle2d.withRadius 10)
+
+        viewDefaultGC =
+            Geometry.Svg.circle2d
+                [ SA.fill (Colors.toString Colors.highlightPink)
+                , SA.opacity "0.2"
+                , SE.onMouseDown MouseDownOnDefaultGravityCenter
+                ]
+                (.gravityCenter (User.getDefaultVertexProperties user) |> Circle2d.withRadius 10)
+    in
+    S.g [] <|
+        viewDefaultGC
+            :: (User.pullCentersWithVertices user |> Dict.toList |> List.map viewGC)

src/User.elm

@@ -34,6 +34,7 @@ module User exposing
     , getVerticesInBag
     , inducedEdges
     , inducedVertices
+    , pullCentersWithVertices
     , removeBag
     , removeEdges
     , removeVertices
@@ -54,6 +55,7 @@ import BoundingBox2d exposing (BoundingBox2d)
 import Circle2d exposing (Circle2d)
 import Colors
 import Dict exposing (Dict)
+import Dict.Extra
 import Element exposing (Color)
 import Force exposing (Force, ForceGraph)
 import Graph exposing (Edge, Graph, Node, NodeContext, NodeId)
@@ -198,12 +200,12 @@ mapBags f (User p) =
 
 getVertices : User -> List (Node VertexProperties)
 getVertices (User { graph }) =
-    graph |> Graph.nodes
+    Graph.nodes graph
 
 
 getEdges : User -> List (Edge EdgeProperties)
 getEdges (User { graph }) =
-    graph |> Graph.edges
+    Graph.edges graph
 
 
 getBags : User -> List Bag
@@ -602,3 +604,10 @@ duplicateSubgraph vs es ((User p) as user) =
     , Set.fromList nvs
     , Set.fromList nes
     )
+
+
+pullCentersWithVertices : User -> Dict ( Float, Float ) (List VertexId)
+pullCentersWithVertices (User { graph }) =
+    Graph.nodes graph
+        |> Dict.Extra.groupBy (.label >> .gravityCenter >> Point2d.coordinates)
+        |> Dict.map (\_ nodeList -> List.map .id nodeList)