curve dragging support

.gitignore

@@ -12,3 +12,5 @@ files/
 *.html
 hie.yaml
 *.mb
+*.prof
+*.eventlog

app/Main.hs

@@ -333,6 +333,7 @@ main = do
     viewportWidth  <- GTK.widgetGetAllocatedWidth  viewportDrawingArea
     viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
     mbRender <- STM.atomically $ withActiveDocument variables \ doc@( Document {..} ) -> do
+      modifiers      <- STM.readTVar modifiersTVar
       mbMousePos     <- STM.readTVar mousePosTVar
       mbHoldAction   <- STM.readTVar mouseHoldTVar
       mbPartialPath  <- STM.readTVar partialPathTVar
@@ -343,7 +344,7 @@ main = do
       pure do
         renderDocument
           colours fitParameters mode debug ( viewportWidth, viewportHeight )
-          mbMousePos mbHoldAction mbPartialPath
+          modifiers mbMousePos mbHoldAction mbPartialPath
           doc
         renderRuler
           colours ( viewportWidth, viewportHeight ) ViewportOrigin ( viewportWidth, viewportHeight )

src/app/MetaBrush/Action.hs

@@ -108,9 +108,10 @@ import MetaBrush.Document.History
 import MetaBrush.Document.Selection
   ( SelectionMode(..), selectionMode
   , selectAt, selectRectangle
-  , dragMoveSelect
+  , DragMoveSelect(..), dragMoveSelect
   , UpdateInfo(..)
-  , translateSelection, deleteSelected
+  , deleteSelected
+  , dragUpdate
   )
 import MetaBrush.Document.Serialise
   ( saveDocument, loadDocument )
@@ -695,10 +696,16 @@ instance HandleAction MouseClick where
                     case selectionMode modifiers of
                       -- Drag move: not holding shift or alt, click has selected something.
                       New
-                        | Just newDoc <- dragMoveSelect mode pos doc
+                        | Just ( dragMove, newDoc ) <- dragMoveSelect mode pos doc
                         -> do
-                          STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold  pos )
+                          STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos dragMove )
-                          pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc )
+                          case dragMove of
+                            ClickedOnSelected ->
+                              pure Don'tModifyDoc
+                            ClickedOnUnselected ->
+                              pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc )
+                            ClickedOnCurve {} ->
+                              pure Don'tModifyDoc
                       -- Rectangular selection.
                       _ -> do
                           STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
@@ -860,8 +867,8 @@ instance HandleAction MouseRelease where
                       && y <= viewportHeight
 
             _ -> do
-              tool      <- STM.readTVar toolTVar
+              tool <- STM.readTVar toolTVar
-              mode      <- STM.readTVar modeTVar
+              mode <- STM.readTVar modeTVar
               case tool of
 
                 Selection -> do
@@ -870,35 +877,14 @@ instance HandleAction MouseRelease where
                     selMode = selectionMode modifiers
                   case mbHoldPos of
                     Just hold
-                      | DragMoveHold  pos0 <- hold
+                      | DragMoveHold { holdStartPos = pos0, dragAction } <- hold
                       , pos0 /= pos
-                      -> do
+                      -> let
-                        let
+                            alternateMode :: Bool
-                          vec :: Vector2D Double
+                            alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers
-                          vec = pos0 --> pos
+                          in case dragUpdate mode pos0 pos dragAction alternateMode doc of
-                          newDocument :: Document
+                            Just upd -> pure $ UpdateDoc ( UpdateDocumentTo upd )
-                          updateInfo :: UpdateInfo
+                            Nothing  -> pure Don'tModifyDoc
-                          ( newDocument, updateInfo ) = translateSelection mode vec doc 
-                        case updateInfo of
-                          UpdateInfo { pathPointsAffected, controlPointsAffected, strokesAffected }
-                            | null strokesAffected
-                            -> pure Don'tModifyDoc
-                            | let
-                                ppMv, cpMv, changeText :: Text
-                                ppMv
-                                  | pathPointsAffected == 0
-                                  = ""
-                                  | otherwise
-                                  = Text.pack ( show pathPointsAffected ) <> " path points"
-                                cpMv
-                                  | controlPointsAffected == 0
-                                  = ""
-                                  | otherwise
-                                  = Text.pack ( show controlPointsAffected ) <> " control points"
-                                changeText =
-                                  "Translate " <> Text.intercalate " and" [ ppMv, cpMv ]
-                                  <> " across " <> Text.pack ( show $ length strokesAffected ) <> " strokes"
-                            -> pure $ UpdateDoc ( UpdateDocumentTo $ HistoryChange {..} )
                       | SelectionHold pos0 <- hold
                       , pos0 /= pos
                       -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectRectangle mode selMode pos0 pos doc )

src/app/MetaBrush/Context.hs

@@ -39,6 +39,8 @@ import MetaBrush.Document.Draw
   ( DrawAnchor )
 import MetaBrush.Document.History
   ( DocumentHistory(..) )
+import MetaBrush.Document.Selection
+  ( DragMoveSelect )
 import {-# SOURCE #-} MetaBrush.UI.FileBar
   ( FileBar )
 import {-# SOURCE #-} MetaBrush.UI.InfoBar
@@ -119,11 +121,13 @@ data GuideAction
 --
 --  - start a rectangular selection,
 --  - move objects by dragging,
---  - drawing a control point,
+--  - draw a control point,
 --  - create/modify a guide.
 data HoldAction
   = SelectionHold { holdStartPos :: !( Point2D Double ) }
-  | DragMoveHold  { holdStartPos :: !( Point2D Double ) }
+  | DragMoveHold  { holdStartPos :: !( Point2D Double )
+                  , dragAction   :: !DragMoveSelect
+                  }
   | DrawHold      { holdStartPos :: !( Point2D Double ) }
   | GuideAction   { holdStartPos :: !( Point2D Double )
                   , guideAction  :: !GuideAction        

src/app/MetaBrush/Context.hs-boot

@@ -1,5 +1,6 @@
 module MetaBrush.Context
-  ( UIElements, Variables )
+  ( UIElements, Variables
+  , Modifier(..), LR(..) )
   where
 
 --------------------------------------------------------------------------------
@@ -7,3 +8,10 @@ module MetaBrush.Context
 data UIElements
 
 data Variables
+
+data LR = L | R
+
+data Modifier
+  = Control LR
+  | Alt     LR
+  | Shift   LR

src/app/MetaBrush/Document/Selection.hs

@@ -5,28 +5,42 @@
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE FlexibleInstances   #-}
 {-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE MagicHash           #-}
 {-# LANGUAGE NamedFieldPuns      #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE PatternSynonyms     #-}
+{-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE ViewPatterns        #-}
 
 module MetaBrush.Document.Selection
   ( SelectionMode(..), selectionMode
   , selectAt, selectRectangle
-  , DragMoveSelect(..), dragMoveSelect
+  , DragMoveSelect(.., PointDrag), dragMoveSelect
   , UpdateInfo(..)
   , translateSelection, deleteSelected
+  , dragUpdate
   )
   where
 
 -- base
 import Control.Category
   ( (>>>) )
+import Control.Monad
+  ( guard )
 import Data.Functor
   ( ($>) )
 import Data.Functor.Identity
   ( runIdentity )
+import Data.Maybe
+  ( catMaybes )
 import Data.Monoid
   ( Sum(..) )
+import Data.Semigroup
+  ( Arg(..), Min(..) )
+import GHC.Exts
+  ( dataToTag#, (>#), (<#), isTrue# )
 import GHC.Generics
   ( Generic )
 
@@ -52,6 +66,10 @@ import Data.Generics.Product.Fields
 import Data.Generics.Product.Typed
   ( HasType )
 
+-- groups
+import Data.Group
+  ( invert )
+
 -- lens
 import Control.Lens
   ( view, set, over, mapped )
@@ -64,6 +82,12 @@ import qualified Control.Monad.Trans.Tardis as Tardis
   , getPast, getFuture, sendPast, sendFuture
   )
 
+-- text
+import Data.Text
+  ( Text )
+import qualified Data.Text as Text
+  ( intercalate, pack )
+
 -- transformers
 import Control.Monad.Trans.Class
   ( lift )
@@ -71,21 +95,29 @@ import Control.Monad.Trans.State.Strict
   ( StateT(..), State, runState, evalState
   , get, put, modify
   )
+import Control.Monad.Trans.Writer.CPS
+  ( WriterT, runWriterT, tell )
 
 -- MetaBrush
+import qualified Math.Bezier.Cubic as Cubic
+  ( Bezier(..), closestPoint, fromQuadratic, drag )
+import qualified Math.Bezier.Quadratic as Quadratic
+  ( Bezier(..), closestPoint, interpolate )
 import Math.Bezier.Stroke
   ( StrokePoint(..) )
 import Math.Module
-  ( squaredNorm )
+  ( squaredNorm, closestPointToSegment )
 import Math.Vector2D
   ( Point2D(..), Vector2D(..) )
-import MetaBrush.Context
+import {-# SOURCE #-} MetaBrush.Context
   ( Modifier(..) )
 import MetaBrush.Document
   ( Document(..), Stroke(..)
   , FocusState(..), _selection
   )
-import MetaBrush.UI.ToolBar
+import {-# SOURCE #-} MetaBrush.Document.Update
+  ( DocChange(..) )
+import {-# SOURCE #-} MetaBrush.UI.ToolBar
   ( Mode(..) )
 import MetaBrush.Unique
   ( Unique )
@@ -161,35 +193,54 @@ selectAt mode selMode c doc@( Document { zoomFactor } ) =
 
 -- | Type of a drag move selection:
 --
--- - user initiated drag by clicking on an already selected item: selection is preserved;
+-- - user initiated drag by clicking on an unselected point: select this point and deselect the previous selection,
--- - user initiated drag by clicking on an unselected item: select this item and deselect the previous selection.
+-- - user initiated drag by clicking on an already selected point: selection is preserved;
+-- - user initiated drag by clicking on an interior point of a curve: start a curve drag, selection is preserved.
 data DragMoveSelect
   = ClickedOnSelected
   | ClickedOnUnselected
+  | ClickedOnCurve
+    { dragStrokeUnique     :: !Unique
+    , dragSegmentIndex     :: !Int
+    , dragSegmentParameter :: !Double
+    , dragBrushCenter      :: !( Maybe ( Point2D Double ) )
+    }
   deriving stock Show
 
+{-# COMPLETE PointDrag, ClickedOnCurve #-}
+pattern PointDrag :: DragMoveSelect
+pattern PointDrag <- ( ( \x -> isTrue# ( dataToTag# x <# 2# ) ) -> True )
+
+instance Semigroup DragMoveSelect where
+  x <> y
+    | isTrue# ( dataToTag# x ># dataToTag# y )
+    = y
+    | otherwise
+    = x
+
 -- | Checks whether a mouse click can initiate a drag move event,
 -- and if so returns an updated document with the selection modified from the start of the drag move.
-dragMoveSelect :: Mode -> Point2D Double -> Document -> Maybe Document
+dragMoveSelect :: Mode -> Point2D Double -> Document -> Maybe ( DragMoveSelect, Document )
 dragMoveSelect mode c doc@( Document { zoomFactor } ) =
   let
-    res :: Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) Document
+    res :: WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) Document
     res = do
       newDoc <- ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc
-      Tardis.getPast >>= Tardis.sendPast
+      lift $ Tardis.getPast >>= Tardis.sendPast
       pure newDoc
-  in case runIdentity $ Tardis.runTardisT res ( Nothing, Nothing ) of
+  in case runIdentity . ( `Tardis.runTardisT` ( Nothing, Nothing ) ) . runWriterT $ res of
-    ( newDoc, ( _, Just _  ) ) -> Just newDoc
+    ( ( newDoc, Just dragMove ), _ )
-    ( _     , ( _, Nothing ) ) -> Nothing
+      -> Just ( dragMove, newDoc )
+    _ -> Nothing
 
   where
-    updateStroke :: Stroke -> Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) Stroke
+    updateStroke :: Stroke -> WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) Stroke
-    updateStroke stroke@( Stroke { strokeVisible } )
+    updateStroke stroke@( Stroke { strokeVisible, strokeUnique } )
       | Brush <- mode
       = ( field' @"strokePoints" . traverse )
           ( \ spt ->
             ( field' @"pointData" . field' @"brushShape" )
-              ( traverse ( updatePoint strokeVisible ( MkVector2D $ coords spt ) )
+              ( updateStrokePoints strokeVisible strokeUnique ( coords spt )
               >>> fmap matchEndpoints
               )
             spt
@@ -197,49 +248,11 @@ dragMoveSelect mode c doc@( Document { zoomFactor } ) =
           stroke
       | otherwise
       = ( field' @"strokePoints" )
-          ( traverse ( updatePoint strokeVisible ( Vector2D 0 0 ) )
+          ( updateStrokePoints strokeVisible strokeUnique ( Point2D 0 0 )
           >>> fmap matchEndpoints
           )
           stroke
-    updatePoint
+
-      :: HasType FocusState pt
-      => Bool
-      -> Vector2D Double
-      -> StrokePoint pt
-      -> Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ( StrokePoint pt )
-    updatePoint isVisible offset pt
-      | selected
-      = do
-          mbPreviousSelect <- Tardis.getPast
-          case mbPreviousSelect of
-            -- Already clicked on a point: don't select further points.
-            Just _  -> pure pt
-            -- First click on a point: record this.
-            Nothing -> do
-              case view _selection pt of
-                Selected -> Tardis.sendFuture ( Just ClickedOnSelected   )
-                _        -> Tardis.sendFuture ( Just ClickedOnUnselected )
-              -- Select this point (whether it was previously selected or not).
-              pure $ set _selection Selected pt
-      | otherwise
-      = do
-        mbDragClick <- Tardis.getFuture
-        let
-          -- needs to be lazy
-          newPointState :: FocusState
-          newPointState
-            -- User clicked on a selected point: preserve _selection.
-            | Just ClickedOnSelected <- mbDragClick
-            = view _selection pt
-            -- User clicked on an unselected point, or not on a point at all: discard selection.
-            | otherwise
-            = Normal
-        pure ( set _selection newPointState pt )
-      where
-        selected :: Bool
-        selected
-          | not isVisible = False
-          | otherwise     = squaredNorm ( c --> ( offset • coords pt ) :: Vector2D Double ) * zoomFactor ^ ( 2 :: Int ) < 16
     -- Ensure consistency of selection at endpoints for closed loops.
     matchEndpoints :: HasType FocusState pt => Seq ( StrokePoint pt ) -> Seq ( StrokePoint pt )
     matchEndpoints ( p0 :<| ( ps :|> pn ) )
@@ -247,6 +260,146 @@ dragMoveSelect mode c doc@( Document { zoomFactor } ) =
       = p0 :<| ( ps :|> set _selection ( view _selection p0 ) pn )
     matchEndpoints ps = ps
 
+    updateStrokePoints
+      :: forall pt
+      .  ( Show pt, HasType FocusState pt )
+      => Bool
+      -> Unique
+      -> Point2D Double
+      -> Seq ( StrokePoint pt )
+      -> WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) ( Seq ( StrokePoint pt ) )
+    updateStrokePoints _         _    _      Empty            = pure Empty
+    updateStrokePoints isVisible uniq offset ( spt :<| spts ) = go 0 spt spts
+      where
+        inSelectionRange :: Point2D Double -> Bool
+        inSelectionRange p
+          | not isVisible = False
+          | otherwise     = squaredNorm ( c --> ( MkVector2D offset • p ) :: Vector2D Double ) * zoomFactor ^ ( 2 :: Int ) < 16
+        go :: Int -> StrokePoint pt -> Seq ( StrokePoint pt )
+           -> WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) ( Seq ( StrokePoint pt ) )
+        go _ sp0 Empty = ( :<| Empty ) <$> updatePoint sp0
+        -- Line.
+        go i sp0 ( sp1 :<| sps )
+          | PathPoint {} <- sp1
+          = do
+            let
+              mbCurveDrag :: Maybe DragMoveSelect
+              mbCurveDrag = do
+                let
+                  t :: Double
+                  p :: Point2D Double
+                  ( t, p )
+                    = closestPointToSegment @( Vector2D Double ) ( invert ( MkVector2D offset ) • c ) ( coords sp0 ) ( coords sp1 )
+                guard ( inSelectionRange p )
+                pure $
+                  ClickedOnCurve
+                    { dragStrokeUnique     = uniq
+                    , dragSegmentIndex     = i
+                    , dragSegmentParameter = t
+                    , dragBrushCenter      = case mode of { Brush -> Just offset; _ -> Nothing }
+                    }
+            tell mbCurveDrag
+            sp0' <- updatePoint sp0
+            ( sp0' :<| ) <$> go ( i + 1 ) sp1 sps
+        -- Quadratic Bézier curve.
+        go i sp0 ( sp1 :<| sp2 :<| sps )
+          | ControlPoint {} <- sp1
+          , PathPoint    {} <- sp2
+          = do
+            let
+              mbCurveDrag :: Maybe DragMoveSelect
+              mbCurveDrag = do
+                let
+                  bez :: Quadratic.Bezier ( Point2D Double )
+                  bez = Quadratic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 )
+                  sq_d :: Double
+                  t :: Double
+                  Min ( Arg sq_d (t, _) )
+                    = Quadratic.closestPoint @( Vector2D Double ) bez ( invert ( MkVector2D offset ) • c )
+                guard ( t > 0 && t < 1 && sq_d * zoomFactor ^ ( 2 :: Int ) < 16 )
+                pure $
+                  ClickedOnCurve
+                    { dragStrokeUnique     = uniq
+                    , dragSegmentIndex     = i
+                    , dragSegmentParameter = t
+                    , dragBrushCenter      = case mode of { Brush -> Just offset; _ -> Nothing }
+                    }
+            tell mbCurveDrag
+            sp0' <- updatePoint sp0
+            sp1' <- updatePoint sp1
+            ( ( sp0' :<| ) . ( sp1' :<| ) ) <$> go ( i + 2 ) sp2 sps
+        -- Cubic Bézier curve.
+        go i sp0 ( sp1 :<| sp2 :<| sp3 :<| sps )
+          | ControlPoint {} <- sp1
+          , ControlPoint {} <- sp2
+          , PathPoint    {} <- sp3
+          = do
+            let
+              mbCurveDrag :: Maybe DragMoveSelect
+              mbCurveDrag = do
+                let
+                  bez :: Cubic.Bezier ( Point2D Double )
+                  bez = Cubic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ( coords sp3 )
+                  sq_d :: Double
+                  t :: Double
+                  Min ( Arg sq_d (t, _) )
+                    = Cubic.closestPoint @( Vector2D Double ) bez ( invert ( MkVector2D offset ) • c )
+                guard ( t > 0 && t < 1 && sq_d * zoomFactor ^ ( 2 :: Int ) < 16 )
+                pure $
+                  ClickedOnCurve
+                    { dragStrokeUnique     = uniq
+                    , dragSegmentIndex     = i
+                    , dragSegmentParameter = t
+                    , dragBrushCenter      = case mode of { Brush -> Just offset; _ -> Nothing }
+                    }
+            tell mbCurveDrag
+            sp0' <- updatePoint sp0
+            sp1' <- updatePoint sp1
+            sp2' <- updatePoint sp2
+            ( ( sp0' :<| ) . ( sp1' :<| ) . ( sp2' :<| ) ) <$> go ( i + 3 ) sp3 sps
+        go _ sp0 sps = error ( "dragMoveSelect: unrecognised stroke type\n" <> show ( sp0 :<| sps ) )
+        updatePoint
+          :: StrokePoint pt
+          -> WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) ( StrokePoint pt )
+        updatePoint pt
+          | inSelectionRange ( coords pt )
+          = do
+              mbPreviousSelect <- lift $ Tardis.getPast
+              case mbPreviousSelect of
+                -- Already clicked on a point: don't select further points.
+                Just dragSelect
+                  | ClickedOnSelected   <- dragSelect
+                  -> pure pt
+                  | ClickedOnUnselected <- dragSelect
+                  -> pure pt
+                -- First click on a point: record this.
+                _ -> do
+                  let
+                    mbDrag :: Maybe DragMoveSelect
+                    mbDrag = case view _selection pt of
+                      Selected -> Just ClickedOnSelected
+                      _        -> Just ClickedOnUnselected
+                  lift $ Tardis.sendFuture mbDrag
+                  tell mbDrag
+                  -- Select this point (whether it was previously selected or not).
+                  pure ( set _selection Selected pt )
+          | otherwise
+          = do
+            mbDragClick <- lift $ Tardis.getFuture
+            let
+              -- needs to be lazy
+              newPointState :: FocusState
+              newPointState = case mbDragClick of
+                -- User clicked on a selected point or a curve segment: preserve selection.
+                Just dragMove
+                  | ClickedOnSelected <- dragMove
+                  -> view _selection pt
+                  | ClickedOnCurve {} <- dragMove
+                  -> view _selection pt
+                -- User clicked on an unselected point, or not on a point at all: discard selection.
+                _ -> Normal
+            pure ( set _selection newPointState pt )
+
 -- | Updates the selected objects on a rectangular selection event.
 selectRectangle :: Mode -> SelectionMode -> Point2D Double -> Point2D Double -> Document -> Document
 selectRectangle mode selMode ( Point2D x0 y0 ) ( Point2D x1 y1 )
@@ -409,3 +562,164 @@ deleteSelected mode doc = deletionResult
       where
         selectionState :: FocusState
         selectionState = view _selection p
+
+-- | Perform a drag move action on a document.
+dragUpdate :: Mode -> Point2D Double -> Point2D Double -> DragMoveSelect -> Bool -> Document -> Maybe DocChange
+dragUpdate mode p0 p PointDrag _ doc = case updateInfo of
+  UpdateInfo { pathPointsAffected, controlPointsAffected, strokesAffected }
+    | null strokesAffected
+    -> Nothing
+    | let
+        ppMv, cpMv :: Maybe Text
+        ppMv
+          | pathPointsAffected == 0
+          = Nothing
+          | otherwise
+          = Just ( Text.pack ( show pathPointsAffected ) <> " path points" )
+        cpMv
+          | controlPointsAffected == 0
+          = Nothing
+          | otherwise
+          = Just ( Text.pack ( show controlPointsAffected ) <> " control points" )
+        changeText :: Text
+        changeText =
+          "Translate " <> Text.intercalate " and " ( catMaybes [ ppMv, cpMv ] )
+          <> " across " <> Text.pack ( show $ length strokesAffected ) <> " strokes"
+    -> Just ( HistoryChange { newDocument, changeText } )
+  where
+    newDocument :: Document
+    updateInfo :: UpdateInfo
+    ( newDocument, updateInfo ) = translateSelection mode ( p0 --> p ) doc
+dragUpdate mode _ p ( ClickedOnCurve {..} ) alternateMode doc
+  | Just name <- mbStrokeName
+  , let
+      changeText :: Text
+      changeText = "Drag curve segment of " <> name
+  = Just ( HistoryChange { newDocument, changeText } )
+  | otherwise
+  = Nothing
+  where
+    newDocument :: Document
+    mbStrokeName :: Maybe Text
+    ( newDocument, mbStrokeName )
+      = ( `runState` Nothing )
+      $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc
+    updateStroke :: Stroke -> State ( Maybe Text ) Stroke
+    updateStroke stroke@( Stroke { strokeUnique, strokeName } )
+      | strokeUnique /= dragStrokeUnique
+      = pure stroke
+      | Brush <- mode
+      = ( field' @"strokePoints" . traverse )
+          ( \ spt ->
+            if dragBrushCenter /= Just ( coords spt )
+            then -- only update the correct brush path
+              pure spt
+            else
+              ( field' @"pointData" . field' @"brushShape" )
+                ( updateStrokePoints strokeName ( MkVector2D $ coords spt ) )
+              spt
+          )
+          stroke
+      | otherwise
+      = ( field' @"strokePoints" )
+          ( updateStrokePoints strokeName ( Vector2D 0 0 ) )
+          stroke
+    updateStrokePoints
+      :: forall pt. Show pt
+      => Text -> Vector2D Double
+      -> Seq ( StrokePoint pt ) -> State ( Maybe Text ) ( Seq ( StrokePoint pt ) )
+    updateStrokePoints _    _      Empty            = pure Empty
+    updateStrokePoints name offset ( spt :<| spts ) = go 0 spt spts
+      where
+        p_eff :: Point2D Double
+        p_eff = invert offset • p
+        go :: Int -> StrokePoint pt -> Seq ( StrokePoint pt ) -> State ( Maybe Text ) ( Seq ( StrokePoint pt ) )
+        go _ sp0 Empty = pure ( sp0 :<| Empty )
+        -- Line.
+        go i sp0 ( sp1 :<| sps )
+          | PathPoint {} <- sp1
+          = case compare i dragSegmentIndex of
+              GT -> pure ( sp0 :<| sp1 :<| sps )
+              LT -> ( sp0 :<| ) <$> go ( i + 1 ) sp1 sps
+              EQ -> do
+                put ( Just name )
+                if alternateMode
+                then
+                  let
+                    p1 :: Point2D Double
+                    Quadratic.Bezier { p1 } =
+                      Quadratic.interpolate @( Vector2D Double ) ( coords sp0 ) ( coords sp1 ) dragSegmentParameter p_eff
+                    cp :: StrokePoint pt
+                    cp = ControlPoint { coords = p1, pointData = pointData sp0 } -- TODO: interpolate
+                  in pure ( sp0 :<| cp :<| sp1 :<| sps )
+                else
+                  let
+                    bez :: Cubic.Bezier ( Point2D Double )
+                    bez = Cubic.Bezier ( coords sp0 ) ( coords sp0 ) ( coords sp1 ) ( coords sp1 )
+                    p1, p2 :: Point2D Double
+                    Cubic.Bezier { p1, p2 } =
+                      Cubic.drag @( Vector2D Double ) bez dragSegmentParameter p_eff
+                    cp1, cp2 :: StrokePoint pt
+                    cp1 = ControlPoint { coords = p1, pointData = pointData sp0 } -- TODO: interpolate
+                    cp2 = ControlPoint { coords = p2, pointData = pointData sp1 } -- TODO: interpolate
+                  in pure ( sp0 :<| cp1 :<| cp2 :<| sp1 :<| sps )
+        -- Quadratic Bézier curve.
+        go i sp0 ( sp1 :<| sp2 :<| sps )
+          | ControlPoint {} <- sp1
+          , PathPoint    {} <- sp2
+          = case compare i dragSegmentIndex of
+              GT -> pure ( sp0 :<| sp1 :<| sp2 :<| sps )
+              LT -> ( ( sp0 :<| ) . ( sp1 :<| ) ) <$> go ( i + 2 ) sp2 sps
+              EQ -> do
+                put ( Just name )
+                if not alternateMode -- switch alternate mode for quadratic Bézier case...
+                then
+                  let
+                    p1 :: Point2D Double
+                    Quadratic.Bezier { p1 } =
+                      Quadratic.interpolate @( Vector2D Double ) ( coords sp0 ) ( coords sp2 ) dragSegmentParameter p_eff
+                    cp :: StrokePoint pt
+                    cp = ControlPoint { coords = p1, pointData = pointData sp0 } -- TODO: interpolate
+                  in pure ( sp0 :<| cp :<| sp2 :<| sps )
+                else
+                  let
+                    bez :: Cubic.Bezier ( Point2D Double )
+                    bez = Cubic.fromQuadratic @( Vector2D Double ) ( Quadratic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) )
+                    p1, p2 :: Point2D Double
+                    Cubic.Bezier { p1, p2 } =
+                      Cubic.drag @( Vector2D Double ) bez dragSegmentParameter p_eff
+                    cp1, cp2 :: StrokePoint pt
+                    cp1 = sp1 { coords = p1 } -- TODO: interpolate
+                    cp2 = sp1 { coords = p2 } -- TODO: interpolate
+                  in pure ( sp0 :<| cp1 :<| cp2 :<| sp2 :<| sps )
+        -- Cubic Bézier curve.
+        go i sp0 ( sp1 :<| sp2 :<| sp3 :<| sps )
+          | ControlPoint {} <- sp1
+          , ControlPoint {} <- sp2
+          , PathPoint    {} <- sp3
+          = case compare i dragSegmentIndex of
+              GT -> pure ( sp0 :<| sp1 :<| sp2 :<| sp3 :<| sps )
+              LT -> ( ( sp0 :<| ) . ( sp1 :<| ) . ( sp2 :<| ) ) <$> go ( i + 3 ) sp3 sps
+              EQ -> do
+                put ( Just name )
+                if alternateMode
+                then
+                  let
+                    p1 :: Point2D Double
+                    Quadratic.Bezier { p1 } =
+                      Quadratic.interpolate @( Vector2D Double ) ( coords sp0 ) ( coords sp3 ) dragSegmentParameter p_eff
+                    cp :: StrokePoint pt
+                    cp = ControlPoint { coords = p1, pointData = pointData sp0 } -- TODO: interpolate
+                  in pure ( sp0 :<| cp :<| sp3 :<| sps )
+                else
+                  let
+                    bez :: Cubic.Bezier ( Point2D Double )
+                    bez = Cubic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ( coords sp3 )
+                    p1, p2 :: Point2D Double
+                    Cubic.Bezier { p1, p2 } =
+                      Cubic.drag @( Vector2D Double ) bez dragSegmentParameter p_eff
+                    cp1, cp2 :: StrokePoint pt
+                    cp1 = sp1 { coords = p1 } -- TODO: interpolate
+                    cp2 = sp2 { coords = p2 } -- TODO: interpolate
+                  in pure ( sp0 :<| cp1 :<| cp2 :<| sp3 :<| sps )
+        go _ sp0 sps = error ( "dragUpdate: unrecognised stroke type\n" <> show ( sp0 :<| sps ) )

src/app/MetaBrush/Document/SubdivideStroke.hs

@@ -102,12 +102,13 @@ subdivide mode c doc@( Document { zoomFactor } ) = ( updatedDoc , ) <$> mbSubdiv
           | PathPoint {} <- sp1
           , let
               p0, p1, s :: Point2D Double
+              t :: Double
               p0 = coords sp0
               p1 = coords sp1
-              s = closestPointToSegment @( Vector2D Double ) ( invert offset • c ) p0 p1
+              ( t, s ) = closestPointToSegment @( Vector2D Double ) ( invert offset • c ) p0 p1
               sqDist :: Double
               sqDist = quadrance @( Vector2D Double ) c ( offset • s )
-          = if sqDist * zoomFactor ^ ( 2 :: Int ) < 16
+          = if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
             then do
               put ( Just txt )
               -- TODO: interpolate brush instead of using these arbitrary intermediate points

src/app/MetaBrush/Document/Update.hs-boot

@@ -0,0 +1,36 @@
+module MetaBrush.Document.Update
+  ( DocChange(..), DocumentUpdate(..)
+  , PureDocModification(..), DocModification(..)
+  )
+where
+
+-- text
+import Data.Text
+  ( Text )
+
+-- MetaBrush
+import MetaBrush.Document
+  ( Document(..) )
+
+--------------------------------------------------------------------------------
+
+data DocChange
+  = TrivialChange { newDocument :: !Document }
+  | HistoryChange { newDocument :: !Document, changeText :: !Text }
+
+data DocumentUpdate
+  = CloseDocument
+  | SaveDocument     !( Maybe FilePath )
+  | UpdateDocumentTo !DocChange
+
+data PureDocModification
+  = Don'tModifyDoc
+  | UpdateDoc !DocumentUpdate
+
+data DocModification
+  = Don'tModifyDocAndThen
+    { postModifAction :: IO () }
+  | UpdateDocAndThen
+    { modifDocument   :: !DocumentUpdate
+    , postModifAction :: IO ()
+    }

src/app/MetaBrush/Render/Document.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE DerivingVia           #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE LambdaCase            #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns        #-}
 {-# LANGUAGE NegativeLiterals      #-}
@@ -45,6 +46,8 @@ import Data.Sequence
   ( Seq(..) )
 import qualified Data.Sequence as Seq
   ( fromList )
+import Data.Set
+  ( Set )
 
 -- generic-data
 import Generic.Data
@@ -81,7 +84,9 @@ import Math.Vector2D
 import MetaBrush.Asset.Colours
   ( Colours, ColourRecord(..) )
 import MetaBrush.Context
-  ( HoldAction(..), PartialPath(..) )
+  ( Modifier(..)
+  , HoldAction(..), PartialPath(..)
+  )
 import MetaBrush.Document
   ( Document(..), DocumentContent(..)
   , mkAABB
@@ -91,7 +96,9 @@ import MetaBrush.Document
   , _selection
   )
 import MetaBrush.Document.Selection
-  ( translateSelection )
+  ( dragUpdate )
+import MetaBrush.Document.Update
+  ( DocChange(..) )
 import MetaBrush.UI.ToolBar
   ( Mode(..) )
 import MetaBrush.Util
@@ -124,12 +131,12 @@ blankRender ( Colours {..} ) = pure ()
 
 renderDocument
   :: Colours -> FitParameters -> Mode -> Bool -> ( Int32, Int32 )
-  -> Maybe ( Point2D Double ) -> Maybe HoldAction -> Maybe PartialPath
+  -> Set Modifier -> Maybe ( Point2D Double ) -> Maybe HoldAction -> Maybe PartialPath
   -> Document 
   -> Cairo.Render ()
 renderDocument
   cols params mode debug ( viewportWidth, viewportHeight ) 
-  mbMousePos mbHoldEvent mbPartialPath
+  modifiers mbMousePos mbHoldEvent mbPartialPath
   doc@( Document { viewportCenter = Point2D cx cy, zoomFactor, documentContent = content } )
   = do
 
@@ -150,10 +157,14 @@ renderDocument
 
       modifiedStrokes :: [ Stroke ]
       modifiedStrokes
-        | Just ( DragMoveHold p0 ) <- mbHoldEvent
+        | Just ( DragMoveHold { holdStartPos = p0, dragAction } ) <- mbHoldEvent
         , Just p1 <- mbMousePos
         , p0 /= p1
-        = strokes . documentContent . fst $ translateSelection mode ( p0 --> p1 ) doc
+        , let
+            alternateMode :: Bool
+            alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers
+        , Just docUpdate <- dragUpdate mode p0 p1 dragAction alternateMode doc
+        = strokes . documentContent $ newDocument docUpdate
         | Just ( PartialPath p0 cp0 _ _ ) <- mbPartialPath
         , let
             mbFinalPoint :: Maybe ( Point2D Double )

src/app/MetaBrush/UI/Coordinates.hs

@@ -55,7 +55,7 @@ closestPoint c ( Stroke { strokePoints = pt0 :<| pts, strokeVisible = True } ) =
     -- Line.
     go ( PathPoint { coords = p0 } )
       ( sp1@( PathPoint { coords = p1 } ) :<| ps )
-      = res ( closestPointToSegment @( Vector2D Double ) c p0 p1 )
+      = res ( snd $ closestPointToSegment @( Vector2D Double ) c p0 p1 )
       <> go sp1 ps
     -- Quadratic Bézier curve.
     go ( PathPoint { coords = p0 } )

src/app/MetaBrush/UI/ToolBar.hs-boot

@@ -13,11 +13,15 @@ data Tool
   = Selection
   | Pen
 
+instance Show Tool
+
 data Mode
   = Path
   | Brush
   | Meta
 
+instance Show Mode
+
 data ToolBar
   = ToolBar
   { selectionTool, penTool, pathTool, brushTool, metaTool :: !GTK.RadioButton

src/lib/Math/Module.hs

@@ -82,14 +82,14 @@ projC x y = x ^.^ y / squaredNorm y
 closestPointToSegment
   :: forall v r p
   . ( Inner r v, Torsor v p, Fractional r, Ord r )
-  => p -> p -> p -> p
+  => p -> p -> p -> ( r, p )
 closestPointToSegment c p0 p1
   | t <= 0
-  = p0
+  = ( 0, p0 )
   | t >= 1
-  = p1
+  = ( 1, p1 )
   | otherwise
-  = ( t *^ v01 ) • p0
+  = ( t, ( t *^ v01 ) • p0 )
   where
     v01 :: v
     v01 = p0 --> p1