synchronise brush widget change across selection

MetaBrush.cabal

@@ -134,6 +134,8 @@ common extras
            >= 0.3.6.2    && < 0.3.8
       , stm
           ^>= 2.5.0.0
+      , tardis
+          ^>= 0.5.0
       , text
            >= 2.0        && < 3
       , unordered-containers

src/app/MetaBrush/Application/Action.hs

@@ -876,13 +876,17 @@ instance HandleAction MouseMove where
           -> do mbHoldAction <- STM.readTVar mouseHoldTVar
                 case mbHoldAction of
                   Just ( BrushWidgetAction { brushWidgetAction = brushAction } ) ->
-                    case applyBrushWidgetAction ( pressingControl modifiers ) pos ( Just brushAction ) doc of
+                    let
-                      Nothing ->
+                      ctrl = pressingControl modifiers
-                        pure Don'tModifyDoc
+                      alt  = pressingAlt modifiers
-                      Just ( newDocument, brushAction' ) -> do
+                    in
-                        STM.writeTVar mouseHoldTVar ( Just $ BrushWidgetAction pos brushAction' )
+                      case applyBrushWidgetAction ctrl alt pos ( Just brushAction ) doc of
-                        -- This is just for preview, so TrivialDiff.
+                        Nothing ->
-                        pure ( UpdateDoc $ UpdateDocumentTo newDocument TrivialDiff )
+                          pure Don'tModifyDoc
+                        Just ( newDocument, brushAction' ) -> do
+                          STM.writeTVar mouseHoldTVar ( Just $ BrushWidgetAction pos brushAction' )
+                          -- This is just for preview, so TrivialDiff.
+                          pure ( UpdateDoc $ UpdateDocumentTo newDocument TrivialDiff )
                   _ -> pure Don'tModifyDoc
           | otherwise
           -> pure Don'tModifyDoc
@@ -894,14 +898,19 @@ instance HandleAction MouseMove where
 
 selectionMode :: Foldable f => f Modifier -> SelectionMode
 selectionMode = foldMap \case
-  Alt   _ -> Subtract
+  Alt   {} -> Subtract
-  Shift _ -> Add
+  Shift {} -> Add
-  _       -> New
+  _        -> New
+
+pressingAlt :: Foldable f => f Modifier -> Bool
+pressingAlt = any \case
+  Alt {} -> True
+  _      -> False
 
 pressingControl :: Foldable f => f Modifier -> Bool
 pressingControl = any \case
   Control {} -> True
-  _ -> False
+  _          -> False
 
 -----------------
 -- Mouse click --
@@ -969,17 +978,24 @@ instance HandleAction MouseClick where
                                 Just ( BrushWidgetAction { brushWidgetAction } )
                                   -> Just brushWidgetAction
                                 _ -> Nothing
-                          case applyBrushWidgetAction ( pressingControl modifiers ) pos mbPrevWidgetAction doc of
+                              ctrl = pressingControl modifiers
-                            Just ( newDocument, actionState@( BrushWidgetActionState { brushWidgetAction = act } ) ) -> do
+                              alt  = pressingAlt modifiers
-                              STM.writeTVar mouseHoldTVar ( Just $ BrushWidgetAction pos actionState )
+                          case applyBrushWidgetAction ctrl alt pos mbPrevWidgetAction doc of
-                              let diff = HistoryDiff $ ContentDiff
+                            Just ( newDocument, anActionState@( ABrushWidgetActionState brushAction ) ) -> do
+                              STM.writeTVar mouseHoldTVar ( Just $ BrushWidgetAction pos anActionState )
+                              let BrushWidgetActionState
+                                    { brushWidgetAction = updAction
+                                    , brushWidgetStrokeUnique = updStrokeUnique
+                                    , brushWidgetPointIndex = updPointIndex
+                                    } = brushAction
+                                  diff = HistoryDiff $ ContentDiff
                                        $ UpdateBrushParameters
-                                          { updateBrushStroke = brushWidgetStrokeUnique actionState
+                                          { updateBrushStroke = updStrokeUnique
-                                          , updateBrushPoint  = brushWidgetPointIndex actionState
+                                          , updateBrushPoint  = updPointIndex
-                                          , updateBrushAction = act
+                                          , updateBrushAction = updAction
                                           }
                               return ( Just $ UpdateDoc $ UpdateDocumentTo newDocument diff )
-                            Nothing ->
+                            _ ->
                               return Nothing
                     -- If we are doing a brush widget action, don't attempt anything else.
                     -- Otherwise, move on to selection.

src/app/MetaBrush/Application/Context.hs

@@ -54,7 +54,7 @@ import Math.Root.Isolation
 
 -- MetaBrush
 import MetaBrush.Action
-  ( BrushWidgetActionState )
+  ( ABrushWidgetActionState(..) )
 import MetaBrush.Asset.Colours
   ( Colours )
 import MetaBrush.Brush
@@ -178,7 +178,7 @@ data HoldAction
       }
   | BrushWidgetAction
       { holdStartPos :: !( ℝ 2 )
-      , brushWidgetAction :: !BrushWidgetActionState
+      , brushWidgetAction :: !ABrushWidgetActionState
       }
   deriving stock Show
 

src/metabrushes/MetaBrush/Action.hs

@@ -1,5 +1,6 @@
-{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE OverloadedStrings    #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 module MetaBrush.Action
   ( -- * Subdividing a stroke
@@ -14,6 +15,7 @@ module MetaBrush.Action
   , deleteSelected
     -- * Brush widget actions
   , BrushWidgetActionState(..)
+  , ABrushWidgetActionState(..)
   , applyBrushWidgetAction
   ) where
 
@@ -28,6 +30,8 @@ import Data.Foldable
   ( for_, traverse_ )
 import Data.Functor
   ( (<&>) )
+import Data.Kind
+  ( Type )
 import qualified Data.List.NonEmpty as NE
 import Data.Maybe
   ( fromMaybe, isNothing, listToMaybe )
@@ -36,6 +40,12 @@ import Data.Semigroup
   ( Arg(..), Min(..) )
 import Data.Traversable
   ( for )
+import Data.Type.Equality
+  ( (:~:)(..) )
+import Data.Typeable
+  ( Typeable, eqT )
+import GHC.TypeLits
+  ( Symbol )
 
 -- acts
 import Data.Act
@@ -64,6 +74,11 @@ import Data.Group
 import Control.Lens
   ( set, over )
 
+-- tardis
+import Control.Monad.Tardis
+  ( Tardis )
+import qualified Control.Monad.Tardis as Tardis
+
 -- transformers
 import Control.Monad.Trans.Except
   ( Except )
@@ -899,21 +914,48 @@ dragUpdate _  p ( ClickedOnCurve { dragStrokeUnique, dragCurveIndex, dragCurvePa
 --------------------------------------------------------------------------------
 -- Brush widget
 
-data BrushWidgetActionState
+
+data ABrushWidgetActionState where
+  ABrushWidgetActionState ::
+    forall brushFields
+    .  ( Show ( Record brushFields ), Typeable brushFields )
+    => BrushWidgetActionState brushFields -> ABrushWidgetActionState
+deriving stock instance Show ABrushWidgetActionState
+
+type BrushWidgetActionState :: [ Symbol ] -> Type
+data BrushWidgetActionState brushFields
   = BrushWidgetActionState
-  { brushWidgetAction       :: !Brush.WidgetAction
+  { brushWidgetAction          :: !Brush.WidgetAction
-  , brushWidgetStrokeUnique :: !Unique
+  , brushWidgetStrokeUnique    :: !Unique
-  , brushWidgetPointIndex   :: !PointIndex
+  , brushWidgetPointIndex      :: !PointIndex
   , brushWidgetPointBeingMoved :: !( T ( ℝ 2 ) )
+  , brushWidgetPrevParams      :: !( Record brushFields )
+  , brushWidgetNewParams       :: !( Maybe ( Record brushFields ) )
   }
-  deriving stock ( Eq, Show )
+deriving stock instance Show ( Record brushFields ) => Show ( BrushWidgetActionState brushFields )
+deriving stock instance   Eq ( Record brushFields ) => Eq   ( BrushWidgetActionState brushFields )
+
+data WidgetFwd act =
+  WidgetFwd
+    { mbPastAction         :: !( Maybe act )
+    , changeInPrevCurve    :: !Bool
+    , pastActionPropagates :: !Bool
+    }
+
+data WidgetBwd act =
+  WidgetBwd
+    { mbFuturePropagatingAction :: !( Maybe act ) }
+
+
+type WidgetM :: Type -> Type -> Type
+type WidgetM act = Tardis ( WidgetBwd act ) ( WidgetFwd act )
 
 -- | Apply a brush widget action, e.g. rotating or scaling the brush at a particular stroke point.
-applyBrushWidgetAction :: Bool -> ℝ 2 -> Maybe BrushWidgetActionState -> Document -> Maybe ( Document, BrushWidgetActionState )
+applyBrushWidgetAction :: Bool -> Bool -> ℝ 2 -> Maybe ABrushWidgetActionState -> Document -> Maybe ( Document, ABrushWidgetActionState )
-applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentContent, documentMetadata } ) =
+applyBrushWidgetAction pressingCtrl pressingAlt c mbPrevAction doc@( Document { documentContent, documentMetadata } ) =
   let
-    ( newStrokes, ( mbAct, _ ) ) =
+    ( newStrokes, mbAct ) =
-      ( `State.runState` ( Nothing, False ) ) $
+      ( `State.runState` Nothing ) $
         forStrokeHierarchy
           ( layerMetadata documentMetadata )
           ( strokeHierarchy documentContent )
@@ -926,7 +968,7 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont
 
     zoom = documentZoom $ documentMetadata
 
-    updateStroke :: WithinParent Unique -> Stroke -> StrokeMetadata -> State ( Maybe BrushWidgetActionState, Bool ) UpdateStroke
+    updateStroke :: WithinParent Unique -> Stroke -> StrokeMetadata -> State ( Maybe ABrushWidgetActionState ) UpdateStroke
     updateStroke ( WithinParent _ u )
       ( Stroke { strokeBrush, strokeSpline = oldSpline :: StrokeSpline clo ( Record pointFields ) } )
       ( StrokeMetadata { strokeVisible, strokeLocked } )
@@ -934,35 +976,44 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont
       , not strokeLocked
         -- If we have already started a widget action, only continue an action
         -- for the stroke with the correct unique.
-      , case mbPrevAction of { Just act -> brushWidgetStrokeUnique act == u; Nothing -> True }
+      , case mbPrevAction of { Just ( ABrushWidgetActionState act ) -> brushWidgetStrokeUnique act == u; Nothing -> True }
         -- Don't touch strokes without brushes.
       , Just ( brush@( NamedBrush {} ) :: NamedBrush brushFields ) <- strokeBrush
       , Intersection { inject2 = updateBrushParams, project1 = ptParamsToUsedParams }
           <- intersect @pointFields @brushFields
       , Union @pointFields' unionWith
           <- union @pointFields @brushFields
-      = do  let defaultBrushParams = MkR $ defaultParams $ brushFunction brush
+      = do
-                embedUsedParams = updateBrushParams defaultBrushParams
+          let ( res, ( _bwd, WidgetFwd { mbPastAction = mbAction } ) ) =
-                toBrushParams = embedUsedParams . ptParamsToUsedParams
+                ( `Tardis.runTardis` ( WidgetBwd Nothing, WidgetFwd Nothing False False ) ) $ do
-                noUpdatePointParams :: Record pointFields -> Record pointFields'
+                  let defaultBrushParams = MkR $ defaultParams $ brushFunction brush
-                noUpdatePointParams p = unionWith ( \ pt _ -> pt ) p defaultBrushParams
+                      embedUsedParams = updateBrushParams defaultBrushParams
-                updatePointParams :: Record brushFields -> Record pointFields -> Record pointFields'
+                      toBrushParams = embedUsedParams . ptParamsToUsedParams
-                updatePointParams b p = unionWith ( \ _ brushParam' -> brushParam' ) p b
+                      noUpdatePointParams :: Record pointFields -> Record pointFields'
-            spline' <-
+                      noUpdatePointParams p = unionWith ( \ pt _ -> pt ) p defaultBrushParams
-              bitraverseSpline
+                      updatePointParams :: Record brushFields -> Record pointFields -> Record pointFields'
-                ( updateSplineCurve ( splineStart oldSpline ) brush toBrushParams noUpdatePointParams updatePointParams u )
+                      updatePointParams b p = unionWith ( \ _ brushParam' -> brushParam' ) p b
-                ( updateSplinePoint brush toBrushParams updatePointParams u FirstPoint )
+                  spline' <-
-                oldSpline
+                      bitraverseSpline
-            ( mbAct, _ ) <- State.get
+                        ( updateSplineCurve ( splineStart oldSpline ) brush toBrushParams noUpdatePointParams updatePointParams u )
-            case mbAct of
+                        ( updateSplinePoint brush toBrushParams noUpdatePointParams updatePointParams u FirstPoint )
-              Nothing -> return PreserveStroke
+                        oldSpline
-              Just {} -> return $ UpdateStrokeTo $ Stroke { strokeBrush, strokeSpline = spline' }
+                  WidgetFwd { mbPastAction = mbAct } <- Tardis.getPast
+                  case mbAct of
+                    Nothing -> return PreserveStroke
+                    Just {} -> return $ UpdateStrokeTo $ Stroke { strokeBrush, strokeSpline = spline' }
+          State.put $ ABrushWidgetActionState <$> mbAction
+          return res
       | otherwise
       = return PreserveStroke
 
     updateSplineCurve
       :: forall clo' pointParams brushFields pointParams'
-      .  ( SplineTypeI clo', Traversable ( NextPoint clo' ) )
+      .  ( SplineTypeI clo', Traversable ( NextPoint clo' )
+         , Typeable brushFields
+         , Show ( Record brushFields )
+         , Torsor ( T ( Record brushFields ) ) ( Record brushFields )
+         )
       => PointData pointParams
       -> NamedBrush brushFields
       -> ( pointParams -> Record brushFields )
@@ -970,48 +1021,51 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont
       -> ( Record brushFields -> pointParams -> pointParams' )
       -> Unique
       -> PointData pointParams -> Curve clo' ( CurveData RealWorld ) ( PointData pointParams )
-      -> State ( Maybe BrushWidgetActionState, Bool )
+      -> WidgetM ( BrushWidgetActionState brushFields ) ( Curve clo' ( CurveData RealWorld ) ( PointData pointParams' ) )
-            ( Curve clo' ( CurveData RealWorld ) ( PointData pointParams' ) )
     updateSplineCurve _start brush toBrushParams noUpdatePointParams updatePointParams uniq _sp0 curve = do
-      ( mbAct, prevCurveAct ) <- State.get
+      WidgetFwd { changeInPrevCurve } <- Tardis.getPast
-      -- We can only perform a brush widget update if:
+      -- There are two kinds of brush widget updates:
-      --   - we aren't already updating another point,
+      --
-      --   - either:
+      --   - Updating the current widget. This can only happen if:
-      --      - we are starting a new operation, or
+      --     - we aren't already starting a widget operation at another point,
-      --      - we are continuing an operation, and we have the right curve index
+      --     - either:
-      let canAct
+      --        - we are starting a new operation, or
-            | isNothing mbAct
+      --        - we are continuing an operation, and we have the right curve index
-            = case mbPrevAction of
+      --   - Synchronising an update on other selected points.
-                Just prevAct -> case ssplineType @clo' of
+      let updPt = updateSplinePoint brush toBrushParams noUpdatePointParams updatePointParams uniq
-                  SClosed -> pointCurve ( brushWidgetPointIndex prevAct ) == crvIx
+          updDat :: CurveData RealWorld -> WidgetM ( BrushWidgetActionState brushFields )( CurveData RealWorld )
-                  SOpen   -> pointCurve ( brushWidgetPointIndex prevAct ) == crvIx
+          updDat dat = do
-                Nothing -> True
+            WidgetFwd { changeInPrevCurve = newChange } <- Tardis.getPast
-            | otherwise
+            if newChange
-            = False
+            then return ( invalidateCache dat )
-      if canAct
+            else do
-      then do
+              let dat' = if changeInPrevCurve then invalidateCache dat else dat
-        case curve of
+              Tardis.modifyForwards ( \ fwd -> fwd { changeInPrevCurve = False } )
-          LineTo sp1 dat -> do
+              return dat'
-            sp1' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx PathPoint ) ) sp1
+      case curve of
-            pure ( LineTo { curveEnd = sp1', curveData = invalidateCache dat } )
+        LineTo sp1 dat -> do
-          Bezier2To sp1 sp2 dat -> do
+          sp1' <- traverse ( updPt ( PointIndex crvIx PathPoint ) ) sp1
-            sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx ( ControlPoint Bez2Cp ) ) sp1
+          dat' <- updDat dat
-            sp2' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx PathPoint ) ) sp2
+          pure ( LineTo { curveEnd = sp1', curveData = dat' } )
-            pure ( Bezier2To { controlPoint = sp1', curveEnd = sp2', curveData = invalidateCache dat } )
+        Bezier2To sp1 sp2 dat -> do
-          Bezier3To sp1 sp2 sp3 dat -> do
+          sp1' <- updPt ( PointIndex crvIx ( ControlPoint Bez2Cp ) ) sp1
-            sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx ( ControlPoint Bez3Cp1 ) ) sp1
+          sp2' <- traverse ( updPt ( PointIndex crvIx PathPoint ) ) sp2
-            sp2' <- updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx ( ControlPoint Bez3Cp2 ) ) sp2
+          dat' <- updDat dat
-            sp3' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx PathPoint ) ) sp3
+          pure ( Bezier2To { controlPoint = sp1', curveEnd = sp2', curveData = dat' } )
-            pure ( Bezier3To { controlPoint1 = sp1', controlPoint2 = sp2', curveEnd = sp3', curveData = invalidateCache dat } )
+        Bezier3To sp1 sp2 sp3 dat -> do
-      else do
+          sp1' <- updPt ( PointIndex crvIx ( ControlPoint Bez3Cp1 ) ) sp1
-        State.put ( mbAct, False )
+          sp2' <- updPt ( PointIndex crvIx ( ControlPoint Bez3Cp2 ) ) sp2
-        let curve' = if prevCurveAct
+          sp3' <- traverse ( updPt ( PointIndex crvIx PathPoint ) ) sp3
-                     then curve { curveData = invalidateCache $ curveData curve }
+          dat' <- updDat dat
-                     else curve
+          pure ( Bezier3To { controlPoint1 = sp1', controlPoint2 = sp2', curveEnd = sp3', curveData = dat' } )
-        return $ bimapCurve id ( \ _ -> fmap noUpdatePointParams ) curve'
       where
         crvIx = curveIndex ( curveData curve )
 
+    pointIsSelected :: Unique -> PointIndex -> Bool
+    pointIsSelected strokeUnique j =
+      let strokeSelPts = fromMaybe Set.empty $ Map.lookup strokeUnique ( strokePoints $ selectedPoints documentMetadata )
+      in j `Set.member` strokeSelPts
+
     inSelectionRange :: ℝ 2 -> T ( ℝ 2 ) -> Bool
     inSelectionRange p cp =
       inPointClickRange zoom c ( cp • p )
@@ -1024,61 +1078,137 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont
 
     updateSplinePoint
       :: forall pointParams brushFields pointParams'
-      .  NamedBrush brushFields
+      .  ( Show ( Record brushFields )
+         , Typeable brushFields
+         , Torsor ( T ( Record brushFields ) ) ( Record brushFields )
+         )
+      => NamedBrush brushFields
       -> ( pointParams -> Record brushFields )
+      -> ( pointParams -> pointParams' )
       -> ( Record brushFields -> pointParams -> pointParams' )
       -> Unique -> PointIndex
       -> PointData pointParams
-      -> State ( Maybe BrushWidgetActionState, Bool )
+      -> WidgetM ( BrushWidgetActionState brushFields ) ( PointData pointParams' )
-          ( PointData pointParams' )
+    updateSplinePoint brush toBrushParams noUpdatePointParams updatePointParams uniq j pt = do
-    updateSplinePoint brush toBrushParams updatePointParams uniq j pt = do
+      WidgetFwd
+        { mbPastAction = mbPastAct
+        , pastActionPropagates
+        } <- Tardis.getPast
       let
+        currentPointSelected = pointIsSelected uniq j
         currentBrushParams :: Record brushFields
         currentBrushParams = toBrushParams ( brushParams pt )
+
+        upd newParams = set ( field @"brushParams" ) ( updatePointParams newParams ( brushParams pt ) ) pt
+        noUpd         = set ( field @"brushParams" ) ( noUpdatePointParams $ brushParams pt ) pt
+
         brushWidgetElts :: Brush.WidgetElements
         brushWidgetElts = Brush.widgetElements ( brushWidget brush ) currentBrushParams
-        newBrushWidgetAction :: Maybe BrushWidgetActionState
+      case mbPrevAction of
-        ( newBrushWidgetAction, newBrushParams ) = case mbPrevAction of
+        Just ( ABrushWidgetActionState @brushFields'
-          -- Continue the current brush widget action.
+               prevAction@( BrushWidgetActionState
-          Just prevAction@( BrushWidgetActionState
+                          { brushWidgetPointBeingMoved = oldPt
-                            { brushWidgetPointBeingMoved = oldPt
+                          , brushWidgetPointIndex = j'
-                            , brushWidgetPointIndex = j'
+                          , brushWidgetAction = act } ) ) ->
-                            , brushWidgetAction = act }) ->
+          if
-            if j /= j'
+            | Just Refl <- eqT @brushFields @brushFields'
-              -- If we have already started a widget action, only continue an action
+            , j == j'
-              -- at the point with the correct index in the stroke.
+            -- Continue the current brush widget action,
-            then ( Nothing, currentBrushParams )
+            -- at the point with the correct index in the stroke.
-            else
+            -> do
-              let newPt = pointCoords pt --> c
+              let
-                  newParams =
+                newPt = pointCoords pt --> c
-                    Brush.widgetUpdate ( brushWidget brush ) act
+                newParams =
-                      ( oldPt, newPt )
+                  Brush.widgetUpdate ( brushWidget brush ) act
-                      currentBrushParams
+                    ( oldPt, newPt )
-              in ( Just $ prevAction { brushWidgetPointBeingMoved = newPt }, newParams )
+                    currentBrushParams
-          Nothing ->
+                newAction =
-            -- See if we can start a new brush widget action.
+                  prevAction
-            case listToMaybe $ filter ( inSelectionRange $ pointCoords pt ) ( Brush.widgetPoints brushWidgetElts ) of
+                    { brushWidgetPointBeingMoved = newPt
-              Just cp ->
+                    , brushWidgetPrevParams = currentBrushParams
-                let newAction =
+                    , brushWidgetNewParams = Just newParams
-                      BrushWidgetActionState
+                    }
-                        { brushWidgetPointBeingMoved = cp
+              Tardis.sendFuture $
-                        , brushWidgetStrokeUnique = uniq
+                WidgetFwd
-                        , brushWidgetPointIndex = j
+                  { mbPastAction         = Just newAction
-                        , brushWidgetAction = case brushWidget brush of
+                  , changeInPrevCurve    = True
-                            Brush.SquareWidget -> Brush.ScaleAction Brush.ScaleXY
+                  , pastActionPropagates = True -- currentPointSelected
-                            Brush.RotatableRectangleWidget ->
+                  }
-                              if pressingCtrl
+              Tardis.sendPast $
-                              then Brush.RotateAction
+                WidgetBwd
-                              else Brush.ScaleAction Brush.ScaleXY
+                  { mbFuturePropagatingAction =
-                        }
+                    --if currentPointSelected
-                in ( Just newAction, currentBrushParams )
+                    --then
-              Nothing -> ( Nothing, currentBrushParams )
+                      Just newAction
-                -- TODO: handle clicking on an edge.
+                    --else Nothing
-                -- case listToMaybe $ filter ( lineInSelectionRange $ pointCoords pt ) ( Brush.widgetLines brushWidgetElts ) of
+                  }
-                --   Just ln -> error "todo"
+              return $ upd newParams
-                --   Nothing -> Nothing
+            | currentPointSelected
-
+            -- Propagate the current brush widget action to other selected points.
-      case newBrushWidgetAction of
+            -> do
-        Just a -> State.put ( Just a, True )
+              ~( WidgetBwd { mbFuturePropagatingAction = mbFutureAct } )
-        _      -> State.modify' ( \ ( a, _ ) -> ( a, False ) )
+                  <- Tardis.getFuture
-      pure ( set ( field @"brushParams" ) ( updatePointParams newBrushParams ( brushParams pt ) ) pt )
+              return $
+                let
+                  propagatingAct :: Maybe ( BrushWidgetActionState brushFields )
+                  propagatingAct
+                    | Just a <- mbPastAct
+                    , pastActionPropagates
+                    = Just a
+                    | otherwise
+                    = mbFutureAct
+                in
+                  if
+                    | Just propAct <- propagatingAct
+                    , BrushWidgetActionState
+                        { brushWidgetAction = action
+                        , brushWidgetPrevParams = params0
+                        , brushWidgetNewParams = Just params1 }
+                          <- propAct
+                    , pointIsSelected uniq j
+                    ->
+                      let newParams =
+                            Brush.widgetUpdateSync
+                              pressingAlt
+                              ( brushWidget brush ) action
+                              ( params0, params1 ) currentBrushParams
+                      in upd newParams
+                    | otherwise
+                    -> noUpd
+            | otherwise
+            -> return noUpd
+        Nothing
+          | isNothing mbPastAct ->
+          -- See if we can start a new brush widget action.
+          case listToMaybe $ filter ( inSelectionRange $ pointCoords pt ) ( Brush.widgetPoints brushWidgetElts ) of
+            Just cp -> do
+              let newAction =
+                    BrushWidgetActionState
+                      { brushWidgetPointBeingMoved = cp
+                      , brushWidgetStrokeUnique = uniq
+                      , brushWidgetPointIndex = j
+                      , brushWidgetAction = case brushWidget brush of
+                          Brush.SquareWidget -> Brush.ScaleAction Brush.ScaleXY
+                          Brush.RotatableRectangleWidget ->
+                            if pressingCtrl
+                            then Brush.RotateAction
+                            else Brush.ScaleAction Brush.ScaleXY
+                      , brushWidgetPrevParams =
+                          currentBrushParams
+                      , brushWidgetNewParams =
+                          Nothing
+                      }
+              Tardis.sendFuture $
+                WidgetFwd
+                  { mbPastAction         = Just newAction
+                  , changeInPrevCurve    = False
+                  , pastActionPropagates = False
+                  }
+              return noUpd
+            Nothing ->
+              return noUpd
+              -- TODO: handle clicking on an edge.
+              -- case listToMaybe $ filter ( lineInSelectionRange $ pointCoords pt ) ( Brush.widgetLines brushWidgetElts ) of
+              --   Just ln -> error "todo"
+              --   Nothing -> Nothing
+        _ -> return noUpd

src/metabrushes/MetaBrush/Brush/Widget.hs

@@ -1,10 +1,12 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module MetaBrush.Brush.Widget
   ( Widget(..)
   , WidgetElements(..)
   , widgetElements
   , widgetUpdate
+  , widgetUpdateSync
   , WhatScale(..)
   , WidgetAction(..)
   , describeWidgetAction
@@ -21,6 +23,10 @@ import GHC.TypeLits
 import GHC.Generics
   ( Generic )
 
+-- acts
+import Data.Act
+  ( Act((•)), Torsor((-->)) )
+
 -- deepseq
 import Control.DeepSeq
   ( NFData )
@@ -125,7 +131,7 @@ widgetUpdate widget mode ( oldPt, newPt ) ( MkR oldFlds ) =
   case widget of
     SquareWidget
       | T ( ℝ2 x y ) <- newPt
-      -> MkR $ ℝ1 ( max ( abs x ) ( abs y ) )
+      -> MkR $ ℝ1 ( max 1e-6 $ max ( abs x ) ( abs y ) )
     RotatableRectangleWidget
       | ℝ3 w h θ <- oldFlds
       -> case mode of
@@ -149,3 +155,52 @@ widgetUpdate widget mode ( oldPt, newPt ) ( MkR oldFlds ) =
 
 nearestAngle :: Double -> Double -> Double
 nearestAngle θ0 θ = θ0 + ( ( θ - θ0 + pi ) `mod'` ( 2 * pi ) - pi )
+
+-- | Synchronise a brush widget update across other points.
+widgetUpdateSync
+  :: forall flds
+  .  Torsor ( T ( Record flds ) ) ( Record flds )
+  => Bool -> Widget flds -> WidgetAction
+  -> ( Record flds, Record flds )
+  -> Record flds
+  -> Record flds
+widgetUpdateSync pressingAlt widget mode ( params0, params1 ) currentParams =
+  let
+    diff :: T ( Record flds )
+    diff = params0 --> params1
+    newParams :: Record flds
+    newParams =
+      if pressingAlt
+      then
+        -- Alternate mode: synchronise the diff.
+        diff • currentParams
+      else
+        -- Normal mode: synchronise the fields.
+        params1
+  in
+    case widget of
+      SquareWidget ->
+        -- Synchronise the radius.
+        let
+          MkR ( ℝ1 r' ) = newParams
+        in
+          MkR ( ℝ1 $ max 1e-6 r' )
+      RotatableRectangleWidget ->
+        case mode of
+          ScaleAction whatScale ->
+            -- When scaling, only synchronise width/height.
+            let
+              MkR ( ℝ3 a b θ   ) = currentParams
+              MkR ( ℝ3 a' b' _ ) = newParams
+            in
+              MkR $
+                ℝ3 ( if whatScale == ScaleY then a else max 1e-6 a' )
+                   ( if whatScale == ScaleX then b else max 1e-6 b' )
+                   θ
+          RotateAction {} ->
+            -- When rotating, only synchronise the angle.
+            let
+              MkR ( ℝ3 a b _  ) = currentParams
+              MkR ( ℝ3 _ _ θ' ) = newParams
+            in
+              MkR $ ℝ3 a b θ'