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