mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
proper fix for brush widget action applying to all strokes
This commit is contained in:
parent
2e05731ffa
commit
61a33e30d2
|
@ -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
|
||||||
}
|
}
|
||||||
|
|
Loading…
Reference in a new issue