proper fix for brush widget action applying to all strokes

This commit is contained in:
sheaf 2024-10-20 17:49:26 +02:00
parent 2e05731ffa
commit 61a33e30d2

View file

@ -112,11 +112,16 @@ import MetaBrush.Document
import MetaBrush.Document.Diff import MetaBrush.Document.Diff
import MetaBrush.Hover import MetaBrush.Hover
( inPointClickRange ) ( inPointClickRange )
import MetaBrush.Layer
( Parent, WithinParent (..) )
import MetaBrush.Records import MetaBrush.Records
import MetaBrush.Stroke import MetaBrush.Stroke
import MetaBrush.Unique import MetaBrush.Unique
( Unique ) ( Unique )
import MetaBrush.Layer (Parent, WithinParent (..))
import Debug.Utils
( trace )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Subdivision. -- Subdivision.
@ -935,32 +940,32 @@ data BrushWidgetActionState brushFields
deriving stock instance Show ( Record brushFields ) => Show ( BrushWidgetActionState brushFields ) deriving stock instance Show ( Record brushFields ) => Show ( BrushWidgetActionState brushFields )
deriving stock instance Eq ( Record brushFields ) => Eq ( BrushWidgetActionState brushFields ) deriving stock instance Eq ( Record brushFields ) => Eq ( BrushWidgetActionState brushFields )
data WidgetFwd act = data WidgetFwd =
WidgetFwd WidgetFwd
{ mbPastAction :: !( Maybe act ) { mbPastAction :: !( Maybe ABrushWidgetActionState )
, changeInPrevCurve :: !Bool , changeInPrevCurve :: !Bool
, pastActionPropagates :: !Bool , pastActionPropagates :: !Bool
} }
data WidgetBwd act = data WidgetBwd =
WidgetBwd WidgetBwd
{ mbFuturePropagatingAction :: !( Maybe act ) } { mbFuturePropagatingAction :: !( Maybe ABrushWidgetActionState ) }
type WidgetM :: Type -> Type -> Type type WidgetM :: Type -> Type
type WidgetM act = Tardis ( WidgetBwd act ) ( WidgetFwd act ) type WidgetM = Tardis WidgetBwd WidgetFwd
-- | Apply a brush widget action, e.g. rotating or scaling the brush at a particular stroke point. -- | Apply a brush widget action, e.g. rotating or scaling the brush at a particular stroke point.
applyBrushWidgetAction :: Bool -> Bool -> 2 -> Maybe ABrushWidgetActionState -> Document -> Maybe ( Document, ABrushWidgetActionState ) applyBrushWidgetAction :: Bool -> Bool -> 2 -> Maybe ABrushWidgetActionState -> Document -> Maybe ( Document, ABrushWidgetActionState )
applyBrushWidgetAction pressingCtrl pressingAlt c mbPrevAction doc@( Document { documentContent, documentMetadata } ) = applyBrushWidgetAction pressingCtrl pressingAlt c mbPrevAction doc@( Document { documentContent, documentMetadata } ) =
let let
( newStrokes, mbAct ) = ( newStrokes, ( _bwd, WidgetFwd { mbPastAction = mbNewAction } ) ) =
( `State.runState` Nothing ) $ ( `Tardis.runTardis` ( WidgetBwd Nothing, WidgetFwd mbPrevAction False False ) ) $
forStrokeHierarchy forStrokeHierarchy
( layerMetadata documentMetadata ) ( layerMetadata documentMetadata )
( strokeHierarchy documentContent ) ( strokeHierarchy documentContent )
updateStroke updateStroke
in mbAct <&> \ act -> in mbNewAction <&> \ act ->
( set ( field' @"documentContent" . field' @"strokeHierarchy" ) newStrokes doc ( set ( field' @"documentContent" . field' @"strokeHierarchy" ) newStrokes doc
, act , act
) )
@ -968,7 +973,7 @@ applyBrushWidgetAction pressingCtrl pressingAlt c mbPrevAction doc@( Document {
zoom = documentZoom $ documentMetadata zoom = documentZoom $ documentMetadata
updateStroke :: WithinParent Unique -> Stroke -> StrokeMetadata -> State ( Maybe ABrushWidgetActionState ) UpdateStroke updateStroke :: WithinParent Unique -> Stroke -> StrokeMetadata -> WidgetM UpdateStroke
updateStroke ( WithinParent _ u ) updateStroke ( WithinParent _ u )
( Stroke { strokeBrush, strokeSpline = oldSpline :: StrokeSpline clo ( Record pointFields ) } ) ( Stroke { strokeBrush, strokeSpline = oldSpline :: StrokeSpline clo ( Record pointFields ) } )
( StrokeMetadata { strokeVisible, strokeLocked } ) ( StrokeMetadata { strokeVisible, strokeLocked } )
@ -981,26 +986,22 @@ applyBrushWidgetAction pressingCtrl pressingAlt c mbPrevAction doc@( Document {
, Union @pointFields' unionWith , Union @pointFields' unionWith
<- union @pointFields @brushFields <- union @pointFields @brushFields
= do = do
let ( res, ( _bwd, WidgetFwd { mbPastAction = mbAction } ) ) = let defaultBrushParams = MkR $ defaultParams $ brushFunction brush
( `Tardis.runTardis` ( WidgetBwd Nothing, WidgetFwd Nothing False False ) ) $ do embedUsedParams = updateBrushParams defaultBrushParams
let defaultBrushParams = MkR $ defaultParams $ brushFunction brush toBrushParams = embedUsedParams . ptParamsToUsedParams
embedUsedParams = updateBrushParams defaultBrushParams noUpdatePointParams :: Record pointFields -> Record pointFields'
toBrushParams = embedUsedParams . ptParamsToUsedParams noUpdatePointParams p = unionWith ( \ pt _ -> pt ) p defaultBrushParams
noUpdatePointParams :: Record pointFields -> Record pointFields' updatePointParams :: Record brushFields -> Record pointFields -> Record pointFields'
noUpdatePointParams p = unionWith ( \ pt _ -> pt ) p defaultBrushParams updatePointParams b p = unionWith ( \ _ brushParam' -> brushParam' ) p b
updatePointParams :: Record brushFields -> Record pointFields -> Record pointFields' spline' <-
updatePointParams b p = unionWith ( \ _ brushParam' -> brushParam' ) p b bitraverseSpline
spline' <- ( updateSplineCurve ( splineStart oldSpline ) brush toBrushParams noUpdatePointParams updatePointParams u )
bitraverseSpline ( updateSplinePoint brush toBrushParams noUpdatePointParams updatePointParams u FirstPoint )
( updateSplineCurve ( splineStart oldSpline ) brush toBrushParams noUpdatePointParams updatePointParams u ) oldSpline
( updateSplinePoint brush toBrushParams noUpdatePointParams updatePointParams u FirstPoint ) WidgetFwd { mbPastAction = mbAct } <- Tardis.getPast
oldSpline case mbAct of
WidgetFwd { mbPastAction = mbAct } <- Tardis.getPast Nothing -> return PreserveStroke
case mbAct of Just {} -> return $ UpdateStrokeTo $ Stroke { strokeBrush, strokeSpline = spline' }
Nothing -> return PreserveStroke
Just {} -> return $ UpdateStrokeTo $ Stroke { strokeBrush, strokeSpline = spline' }
State.put $ ABrushWidgetActionState <$> mbAction
return res
| otherwise | otherwise
= return PreserveStroke = return PreserveStroke
@ -1018,7 +1019,7 @@ applyBrushWidgetAction pressingCtrl pressingAlt c mbPrevAction doc@( Document {
-> ( Record brushFields -> pointParams -> pointParams' ) -> ( Record brushFields -> pointParams -> pointParams' )
-> Unique -> Unique
-> PointData pointParams -> Curve clo' ( CurveData RealWorld ) ( PointData pointParams ) -> PointData pointParams -> Curve clo' ( CurveData RealWorld ) ( PointData pointParams )
-> WidgetM ( BrushWidgetActionState brushFields ) ( Curve clo' ( CurveData RealWorld ) ( PointData pointParams' ) ) -> WidgetM ( Curve clo' ( CurveData RealWorld ) ( PointData pointParams' ) )
updateSplineCurve _start brush toBrushParams noUpdatePointParams updatePointParams uniq _sp0 curve = do updateSplineCurve _start brush toBrushParams noUpdatePointParams updatePointParams uniq _sp0 curve = do
WidgetFwd { changeInPrevCurve } <- Tardis.getPast WidgetFwd { changeInPrevCurve } <- Tardis.getPast
-- There are two kinds of brush widget updates: -- There are two kinds of brush widget updates:
@ -1030,7 +1031,7 @@ applyBrushWidgetAction pressingCtrl pressingAlt c mbPrevAction doc@( Document {
-- - we are continuing an operation, and we have the right curve index -- - we are continuing an operation, and we have the right curve index
-- - Synchronising an update on other selected points. -- - Synchronising an update on other selected points.
let updPt = updateSplinePoint brush toBrushParams noUpdatePointParams updatePointParams uniq let updPt = updateSplinePoint brush toBrushParams noUpdatePointParams updatePointParams uniq
updDat :: CurveData RealWorld -> WidgetM ( BrushWidgetActionState brushFields )( CurveData RealWorld ) updDat :: CurveData RealWorld -> WidgetM ( CurveData RealWorld )
updDat dat = do updDat dat = do
WidgetFwd { changeInPrevCurve = newChange } <- Tardis.getPast WidgetFwd { changeInPrevCurve = newChange } <- Tardis.getPast
if newChange if newChange
@ -1085,7 +1086,7 @@ applyBrushWidgetAction pressingCtrl pressingAlt c mbPrevAction doc@( Document {
-> ( Record brushFields -> pointParams -> pointParams' ) -> ( Record brushFields -> pointParams -> pointParams' )
-> Unique -> PointIndex -> Unique -> PointIndex
-> PointData pointParams -> PointData pointParams
-> WidgetM ( BrushWidgetActionState brushFields ) ( PointData pointParams' ) -> WidgetM ( PointData pointParams' )
updateSplinePoint brush toBrushParams noUpdatePointParams updatePointParams uniq j pt = do updateSplinePoint brush toBrushParams noUpdatePointParams updatePointParams uniq j pt = do
WidgetFwd WidgetFwd
{ mbPastAction = mbPastAct { mbPastAction = mbPastAct
@ -1130,7 +1131,7 @@ applyBrushWidgetAction pressingCtrl pressingAlt c mbPrevAction doc@( Document {
} }
Tardis.sendFuture $ Tardis.sendFuture $
WidgetFwd WidgetFwd
{ mbPastAction = Just newAction { mbPastAction = Just $ ABrushWidgetActionState newAction
, changeInPrevCurve = True , changeInPrevCurve = True
, pastActionPropagates = True -- currentPointSelected , pastActionPropagates = True -- currentPointSelected
} }
@ -1139,7 +1140,7 @@ applyBrushWidgetAction pressingCtrl pressingAlt c mbPrevAction doc@( Document {
{ mbFuturePropagatingAction = { mbFuturePropagatingAction =
--if currentPointSelected --if currentPointSelected
--then --then
Just newAction Just $ ABrushWidgetActionState newAction
--else Nothing --else Nothing
} }
return $ upd newParams return $ upd newParams
@ -1150,7 +1151,7 @@ applyBrushWidgetAction pressingCtrl pressingAlt c mbPrevAction doc@( Document {
<- Tardis.getFuture <- Tardis.getFuture
return $ return $
let let
propagatingAct :: Maybe ( BrushWidgetActionState brushFields ) propagatingAct :: Maybe ABrushWidgetActionState
propagatingAct propagatingAct
| Just a <- mbPastAct | Just a <- mbPastAct
, pastActionPropagates , pastActionPropagates
@ -1159,7 +1160,8 @@ applyBrushWidgetAction pressingCtrl pressingAlt c mbPrevAction doc@( Document {
= mbFutureAct = mbFutureAct
in in
if if
| Just propAct <- propagatingAct | Just ( ABrushWidgetActionState @brushFields'' propAct ) <- propagatingAct
, Just Refl <- eqT @brushFields @brushFields''
, BrushWidgetActionState , BrushWidgetActionState
{ brushWidgetAction = action { brushWidgetAction = action
, brushWidgetPrevParams = params0 , brushWidgetPrevParams = params0
@ -1200,7 +1202,7 @@ applyBrushWidgetAction pressingCtrl pressingAlt c mbPrevAction doc@( Document {
} }
Tardis.sendFuture $ Tardis.sendFuture $
WidgetFwd WidgetFwd
{ mbPastAction = Just newAction { mbPastAction = Just $ ABrushWidgetActionState newAction
, changeInPrevCurve = False , changeInPrevCurve = False
, pastActionPropagates = False , pastActionPropagates = False
} }