subdivide paths by double-clicking on them

* still WIP:
    - path mode: does not correctly interpolate brushes
    - brush mode: does not propagate subdivision to other brushes

MetaBrush.cabal

@@ -112,6 +112,7 @@ executable MetaBrush
       , MetaBrush.Document.Guide
       , MetaBrush.Document.Selection
       , MetaBrush.Document.Serialise
+      , MetaBrush.Document.SubdivideStroke
       , MetaBrush.Event
       , MetaBrush.Render.Document
       , MetaBrush.Time

src/app/MetaBrush/Action.hs

@@ -107,6 +107,8 @@ import MetaBrush.Document.Selection
   )
 import MetaBrush.Document.Serialise
   ( saveDocument, loadDocument )
+import MetaBrush.Document.SubdivideStroke
+  ( subdivide )
 import MetaBrush.UI.Coordinates
   ( toViewportCoordinates )
 import MetaBrush.UI.InfoBar
@@ -564,14 +566,19 @@ data ActionOrigin
   | RulerOrigin Ruler
   deriving stock Show
 
-data MouseClick = MouseClick ActionOrigin Word32 ( Point2D Double )
+data MouseClickType
+  = SingleClick
+  | DoubleClick
+  deriving stock Show
+
+data MouseClick = MouseClick ActionOrigin MouseClickType Word32 ( Point2D Double )
   deriving stock Show
 
 instance HandleAction MouseClick where
   handleAction
     uiElts@( UIElements { viewport = Viewport {..} } )
     vars@( Variables {..} )
-    ( MouseClick actionOrigin button mouseClickCoords )
+    ( MouseClick actionOrigin ty button mouseClickCoords )
     = case button of
 
       -- Left mouse button.
@@ -587,51 +594,69 @@ instance HandleAction MouseClick where
           STM.writeTVar mousePosTVar ( Just pos )
           case actionOrigin of
 
-            ViewportOrigin -> do
+            ViewportOrigin -> case ty of
-              modifiers <- STM.readTVar modifiersTVar
-              tool <- STM.readTVar toolTVar
-              mode <- STM.readTVar modeTVar
-              case tool of
-                -- Selection mode mouse hold:
-                --
-                --   - If holding shift or alt, mouse hold initiates a rectangular selection.
-                --   - If not holding shift or alt:
-                --      - if mouse click selected an object, initiate a drag move,
-                --      - otherwise, initiate a rectangular selection.
-                Selection ->
-                  case selectionMode modifiers of
-                    -- Drag move: not holding shift or alt, click has selected something.
-                    New
-                      | Just newDoc <- dragMoveSelect mode pos doc
-                      -> do
-                        STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold  pos )
-                        pure ( UpdateDocTo $ Just newDoc )
-                    -- Rectangular selection.
-                    _ -> do
-                        STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
-                        pure Don'tModifyDoc
 
-                -- Pen tool: start or continue a drawing operation.
+              SingleClick -> do
-                Pen -> do
+                modifiers <- STM.readTVar modifiersTVar
-                  mbPartialPath <- STM.readTVar partialPathTVar
+                tool <- STM.readTVar toolTVar
-                  STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos )
+                mode <- STM.readTVar modeTVar
-                  case mbPartialPath of
+                case tool of
-                    -- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke).
+                  -- Selection mode mouse hold:
-                    Nothing -> do
+                  --
-                      ( newDoc, drawAnchor, anchorPt ) <- getOrCreateDrawAnchor uniqueSupply pos doc
+                  --   - If holding shift or alt, mouse hold initiates a rectangular selection.
-                      STM.writeTVar partialPathTVar
+                  --   - If not holding shift or alt:
-                        ( Just $ PartialPath
+                  --      - if mouse click selected an object, initiate a drag move,
-                          { partialStartPos     = anchorPt
+                  --      - otherwise, initiate a rectangular selection.
-                          , partialControlPoint = Nothing
+                  Selection ->
-                          , partialPathAnchor   = drawAnchor
+                    case selectionMode modifiers of
-                          , firstPoint          = True
+                      -- Drag move: not holding shift or alt, click has selected something.
-                          }
+                      New
-                        )
+                        | Just newDoc <- dragMoveSelect mode pos doc
-                      pure ( UpdateDocTo $ Just newDoc )
+                        -> do
-                    -- Path already started: indicate that we are continuing a path.
+                          STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold  pos )
-                    Just pp -> do
+                          pure ( UpdateDocTo $ Just newDoc )
-                      STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } )
+                      -- Rectangular selection.
-                      pure Don'tModifyDoc
+                      _ -> do
+                          STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
+                          pure Don'tModifyDoc
+
+                  -- Pen tool: start or continue a drawing operation.
+                  Pen -> do
+                    mbPartialPath <- STM.readTVar partialPathTVar
+                    STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos )
+                    case mbPartialPath of
+                      -- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke).
+                      Nothing -> do
+                        ( newDoc, drawAnchor, anchorPt ) <- getOrCreateDrawAnchor uniqueSupply pos doc
+                        STM.writeTVar partialPathTVar
+                          ( Just $ PartialPath
+                            { partialStartPos     = anchorPt
+                            , partialControlPoint = Nothing
+                            , partialPathAnchor   = drawAnchor
+                            , firstPoint          = True
+                            }
+                          )
+                        pure ( UpdateDocTo $ Just newDoc )
+                      -- Path already started: indicate that we are continuing a path.
+                      Just pp -> do
+                        STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } )
+                        pure Don'tModifyDoc
+              
+              DoubleClick -> do
+                tool <- STM.readTVar toolTVar
+                mode <- STM.readTVar modeTVar
+                case tool of
+                  Selection -> do
+                    STM.writeTVar mouseHoldTVar Nothing
+                    let
+                      mbSubdivide :: Maybe Document
+                      mbSubdivide = subdivide mode pos doc
+                    case mbSubdivide of
+                      Nothing     -> pure Don'tModifyDoc
+                      Just newDoc -> pure ( UpdateDocTo $ Just newDoc )
+
+                  -- Ignore double click event otherwise.
+                  _ -> pure Don'tModifyDoc
 
             RulerOrigin ruler -> do
               let
@@ -717,11 +742,10 @@ instance HandleAction MouseRelease where
                       && x <= viewportWidth
                       && y <= viewportHeight
               pure ( UpdateDocTo ( Just newDoc ) )
-            _ -> do
 
+            _ -> do
               tool      <- STM.readTVar toolTVar
               mode      <- STM.readTVar modeTVar
-
               case tool of
 
                 Selection -> do

src/app/MetaBrush/Document/SubdivideStroke.hs

@@ -0,0 +1,156 @@
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE NamedFieldPuns      #-}
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
+
+module MetaBrush.Document.SubdivideStroke
+  ( subdivide )
+  where
+
+-- base
+import Data.Semigroup
+  ( Min(..), Arg(..) )
+
+-- acts
+import Data.Act
+  ( Act((•)) )
+
+-- containers
+import Data.Sequence
+  ( Seq(..) )
+
+-- generic-lens
+import Data.Generics.Product.Fields
+  ( field' )
+
+-- groups
+import Data.Group
+  ( invert )
+
+-- transformers
+import Control.Monad.Trans.State.Strict
+  ( State, runState, put )
+
+-- MetaBrush
+import qualified Math.Bezier.Cubic as Cubic
+  ( Bezier(..), closestPoint, subdivide )
+import qualified Math.Bezier.Quadratic as Quadratic
+  ( Bezier(..), closestPoint, subdivide )
+import Math.Bezier.Stroke
+  ( StrokePoint(..) )
+import Math.Module
+  ( quadrance, closestPointToSegment )
+import Math.Vector2D
+  ( Point2D(..), Vector2D(..) )
+import MetaBrush.Document
+  ( Document(..), Stroke(..) )
+import MetaBrush.UI.ToolBar
+  ( Mode(..) )
+
+--------------------------------------------------------------------------------
+
+-- | Subdivide a path at the given center, provided a path indeed lies there.
+subdivide :: Mode -> Point2D Double -> Document -> Maybe Document
+subdivide mode c doc@( Document { zoomFactor } )
+  | subdivOccurred
+  = Just updatedDoc
+  | otherwise
+  = Nothing
+    where
+
+      updatedDoc :: Document
+      subdivOccurred :: Bool
+      ( updatedDoc, subdivOccurred ) = ( `runState` False ) $ field' @"strokes" ( traverse updateStroke ) doc
+
+      updateStroke :: Stroke -> State Bool Stroke
+      updateStroke stroke@( Stroke { strokeVisible } )
+        | Brush <- mode
+        = ( field' @"strokePoints" . traverse )
+            ( \ spt ->
+              ( field' @"pointData" . field' @"brushShape" )
+                ( subdivideStroke strokeVisible ( MkVector2D $ coords spt ) )
+              spt
+            )
+            stroke
+        | otherwise
+        = ( field' @"strokePoints" )
+            ( subdivideStroke strokeVisible ( Vector2D 0 0 ) )
+            stroke
+
+      subdivideStroke
+        :: forall pt
+        .  Show pt
+        => Bool
+        -> Vector2D Double
+        -> Seq ( StrokePoint pt )
+        -> State Bool ( Seq ( StrokePoint pt ) )
+      subdivideStroke False _      pts   = pure pts
+      subdivideStroke True  _      Empty = pure Empty
+      subdivideStroke True  offset ( spt :<| spts ) = go spt spts
+        where
+          go :: StrokePoint pt -> Seq ( StrokePoint pt ) -> State Bool ( Seq ( StrokePoint pt ) )
+          go sp0 Empty = pure ( sp0 :<| Empty )
+          -- Line.
+          go sp0 ( sp1 :<| sps )
+            | PathPoint {} <- sp1
+            , let
+                p0, p1, s :: Point2D Double
+                p0 = coords sp0
+                p1 = coords sp1
+                s = closestPointToSegment @( Vector2D Double ) ( invert offset • c ) p0 p1
+                sqDist :: Double
+                sqDist = quadrance @( Vector2D Double ) c ( offset • s )
+            = if sqDist * zoomFactor ^ ( 2 :: Int ) < 16
+              then do
+                put True
+                -- TODO: interpolate brush instead of using these arbitrary intermediate points
+                pure ( sp0 :<| sp0 { coords = s } :<| sp1 :<| sps )
+              else ( sp0 :<| ) <$> go sp1 sps
+          -- Quadratic Bézier curve.
+          go sp0 ( sp1 :<| sp2 :<| sps )
+            | ControlPoint {} <- sp1
+            , PathPoint    {} <- sp2
+            , let
+                p0, p1, p2, s :: Point2D Double
+                p0 = coords sp0
+                p1 = coords sp1
+                p2 = coords sp2
+                bez :: Quadratic.Bezier ( Point2D Double )
+                bez = Quadratic.Bezier {..}
+                sqDist :: Double
+                Min ( Arg sqDist ( t, s ) )
+                  = Quadratic.closestPoint @( Vector2D Double ) bez ( invert offset • c )
+            = if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
+              then case Quadratic.subdivide @( Vector2D Double ) bez t of
+                ( Quadratic.Bezier _ q1 _, Quadratic.Bezier _ r1 _ ) -> do
+                  put True
+                  -- TODO: interpolate brush instead of using these arbitrary intermediate points
+                  pure ( sp0 :<| sp1 { coords = q1 } :<| sp2 { coords = s } :<| sp1 { coords = r1 } :<| sp2 :<| sps )
+              else ( ( sp0 :<| ) . ( sp1 :<| ) ) <$> go sp2 sps
+          -- Cubic Bézier curve.
+          go sp0 ( sp1 :<| sp2 :<| sp3 :<| sps )
+            | ControlPoint {} <- sp1
+            , ControlPoint {} <- sp2
+            , PathPoint    {} <- sp3
+            , let
+                p0, p1, p2, p3, s :: Point2D Double
+                p0 = coords sp0
+                p1 = coords sp1
+                p2 = coords sp2
+                p3 = coords sp3
+                bez :: Cubic.Bezier ( Point2D Double )
+                bez = Cubic.Bezier {..}
+                Min ( Arg sqDist ( t, s ) )
+                  = Cubic.closestPoint @( Vector2D Double ) bez ( invert offset • c )
+            = if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
+              then case Cubic.subdivide @( Vector2D Double ) bez t of
+                ( Cubic.Bezier _ q1 q2 _, Cubic.Bezier _ r1 r2 _ ) -> do
+                  put True
+                  -- TODO: interpolate brush instead of using these arbitrary intermediate points
+                  pure
+                    ( sp0 :<| sp1 { coords = q1 } :<| sp1 { coords = q2 } :<| sp3 { coords = s }
+                    :<| sp2 { coords = r1 } :<| sp2 { coords = r2 } :<| sp3 :<| sps
+                    )
+              else ( ( sp0 :<| ) . ( sp1 :<| ) . ( sp2 :<| ) ) <$> go sp3 sps
+          go sp0 sps = error ( "subdivideStroke: unrecognised stroke type\n" <> show ( sp0 :<| sps ) )

src/app/MetaBrush/Event.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BlockArguments     #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE RecordWildCards    #-}
 {-# LANGUAGE TypeApplications   #-}
@@ -9,6 +10,8 @@ module MetaBrush.Event
 -- base
 import Control.Monad
   ( void )
+import Data.Foldable
+  ( for_ )
 
 -- gi-gdk
 import qualified GI.Gdk as GDK
@@ -22,7 +25,7 @@ import Math.Vector2D
 import MetaBrush.Action
   ( HandleAction(..)
   , ActionOrigin(..)
-  , MouseMove(..), MouseClick(..), MouseRelease(..)
+  , MouseMove(..), MouseClick(..), MouseClickType(..), MouseRelease(..)
   , Scroll(..), KeyboardPress(..), KeyboardRelease(..)
   , quitEverything
   )
@@ -80,11 +83,19 @@ handleScrollEvent elts vars eventOrigin scrollEvent = do
 
 handleMouseButtonEvent :: UIElements -> Variables -> ActionOrigin -> GDK.EventButton -> IO Bool
 handleMouseButtonEvent elts vars eventOrigin mouseClickEvent = do
-  button <- GDK.getEventButtonButton mouseClickEvent
+  ty <- GDK.getEventButtonType mouseClickEvent
-  x <- GDK.getEventButtonX mouseClickEvent
+  let
-  y <- GDK.getEventButtonY mouseClickEvent
+    mbClick :: Maybe MouseClickType
-  mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y )
+    mbClick = case ty of
-  handleAction elts vars ( MouseClick eventOrigin button mousePos )
+      GDK.EventTypeButtonPress  -> Just SingleClick
+      GDK.EventType2buttonPress -> Just DoubleClick
+      _                         -> Nothing
+  for_ mbClick \ click -> do
+    button <- GDK.getEventButtonButton mouseClickEvent
+    x  <- GDK.getEventButtonX mouseClickEvent
+    y  <- GDK.getEventButtonY mouseClickEvent
+    mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y )
+    handleAction elts vars ( MouseClick eventOrigin click button mousePos )
   pure False
 
 handleMouseButtonRelease :: UIElements -> Variables -> ActionOrigin -> GDK.EventButton -> IO Bool