synchronise brush widget change across selection

This commit is contained in:
sheaf 2024-10-19 15:51:45 +02:00
parent 0223c92a85
commit 5adcb34de6
5 changed files with 342 additions and 139 deletions

View file

@ -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

View file

@ -876,7 +876,11 @@ 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
ctrl = pressingControl modifiers
alt = pressingAlt modifiers
in
case applyBrushWidgetAction ctrl alt pos ( Just brushAction ) doc of
Nothing ->
pure Don'tModifyDoc
Just ( newDocument, brushAction' ) -> do
@ -894,10 +898,15 @@ instance HandleAction MouseMove where
selectionMode :: Foldable f => f Modifier -> SelectionMode
selectionMode = foldMap \case
Alt _ -> Subtract
Shift _ -> Add
Alt {} -> Subtract
Shift {} -> Add
_ -> New
pressingAlt :: Foldable f => f Modifier -> Bool
pressingAlt = any \case
Alt {} -> True
_ -> False
pressingControl :: Foldable f => f Modifier -> Bool
pressingControl = any \case
Control {} -> True
@ -969,17 +978,24 @@ instance HandleAction MouseClick where
Just ( BrushWidgetAction { brushWidgetAction } )
-> Just brushWidgetAction
_ -> Nothing
case applyBrushWidgetAction ( pressingControl modifiers ) pos mbPrevWidgetAction doc of
Just ( newDocument, actionState@( BrushWidgetActionState { brushWidgetAction = act } ) ) -> do
STM.writeTVar mouseHoldTVar ( Just $ BrushWidgetAction pos actionState )
let diff = HistoryDiff $ ContentDiff
ctrl = pressingControl modifiers
alt = pressingAlt modifiers
case applyBrushWidgetAction ctrl alt pos mbPrevWidgetAction doc of
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
, updateBrushPoint = brushWidgetPointIndex actionState
, updateBrushAction = act
{ updateBrushStroke = updStrokeUnique
, updateBrushPoint = updPointIndex
, 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.

View file

@ -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

View file

@ -1,5 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# 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
, brushWidgetStrokeUnique :: !Unique
, 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 pressingCtrl c mbPrevAction doc@( Document { documentContent, documentMetadata } ) =
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, False ) ) $
( newStrokes, mbAct ) =
( `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,14 +976,17 @@ 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
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'
@ -951,18 +996,24 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont
spline' <-
bitraverseSpline
( updateSplineCurve ( splineStart oldSpline ) brush toBrushParams noUpdatePointParams updatePointParams u )
( updateSplinePoint brush toBrushParams updatePointParams u FirstPoint )
( updateSplinePoint brush toBrushParams noUpdatePointParams updatePointParams u FirstPoint )
oldSpline
( mbAct, _ ) <- State.get
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 )
( Curve clo' ( CurveData RealWorld ) ( PointData pointParams' ) )
-> WidgetM ( BrushWidgetActionState brushFields ) ( Curve clo' ( CurveData RealWorld ) ( PointData pointParams' ) )
updateSplineCurve _start brush toBrushParams noUpdatePointParams updatePointParams uniq _sp0 curve = do
( mbAct, prevCurveAct ) <- State.get
-- We can only perform a brush widget update if:
-- - we aren't already updating another point,
WidgetFwd { changeInPrevCurve } <- Tardis.getPast
-- There are two kinds of brush widget updates:
--
-- - Updating the current widget. This can only happen if:
-- - we aren't already starting a widget operation at another point,
-- - either:
-- - we are starting a new operation, or
-- - we are continuing an operation, and we have the right curve index
let canAct
| isNothing mbAct
= case mbPrevAction of
Just prevAct -> case ssplineType @clo' of
SClosed -> pointCurve ( brushWidgetPointIndex prevAct ) == crvIx
SOpen -> pointCurve ( brushWidgetPointIndex prevAct ) == crvIx
Nothing -> True
| otherwise
= False
if canAct
then do
-- - Synchronising an update on other selected points.
let updPt = updateSplinePoint brush toBrushParams noUpdatePointParams updatePointParams uniq
updDat :: CurveData RealWorld -> WidgetM ( BrushWidgetActionState brushFields )( CurveData RealWorld )
updDat dat = do
WidgetFwd { changeInPrevCurve = newChange } <- Tardis.getPast
if newChange
then return ( invalidateCache dat )
else do
let dat' = if changeInPrevCurve then invalidateCache dat else dat
Tardis.modifyForwards ( \ fwd -> fwd { changeInPrevCurve = False } )
return dat'
case curve of
LineTo sp1 dat -> do
sp1' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx PathPoint ) ) sp1
pure ( LineTo { curveEnd = sp1', curveData = invalidateCache dat } )
sp1' <- traverse ( updPt ( PointIndex crvIx PathPoint ) ) sp1
dat' <- updDat dat
pure ( LineTo { curveEnd = sp1', curveData = dat' } )
Bezier2To sp1 sp2 dat -> do
sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx ( ControlPoint Bez2Cp ) ) sp1
sp2' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx PathPoint ) ) sp2
pure ( Bezier2To { controlPoint = sp1', curveEnd = sp2', curveData = invalidateCache dat } )
sp1' <- updPt ( PointIndex crvIx ( ControlPoint Bez2Cp ) ) sp1
sp2' <- traverse ( updPt ( PointIndex crvIx PathPoint ) ) sp2
dat' <- updDat dat
pure ( Bezier2To { controlPoint = sp1', curveEnd = sp2', curveData = dat' } )
Bezier3To sp1 sp2 sp3 dat -> do
sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx ( ControlPoint Bez3Cp1 ) ) sp1
sp2' <- updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx ( ControlPoint Bez3Cp2 ) ) sp2
sp3' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx PathPoint ) ) sp3
pure ( Bezier3To { controlPoint1 = sp1', controlPoint2 = sp2', curveEnd = sp3', curveData = invalidateCache dat } )
else do
State.put ( mbAct, False )
let curve' = if prevCurveAct
then curve { curveData = invalidateCache $ curveData curve }
else curve
return $ bimapCurve id ( \ _ -> fmap noUpdatePointParams ) curve'
sp1' <- updPt ( PointIndex crvIx ( ControlPoint Bez3Cp1 ) ) sp1
sp2' <- updPt ( PointIndex crvIx ( ControlPoint Bez3Cp2 ) ) sp2
sp3' <- traverse ( updPt ( PointIndex crvIx PathPoint ) ) sp3
dat' <- updDat dat
pure ( Bezier3To { controlPoint1 = sp1', controlPoint2 = sp2', curveEnd = sp3', curveData = dat' } )
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,41 +1078,110 @@ 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 )
( PointData pointParams' )
updateSplinePoint brush toBrushParams updatePointParams uniq j pt = do
-> WidgetM ( BrushWidgetActionState brushFields ) ( PointData pointParams' )
updateSplinePoint brush toBrushParams noUpdatePointParams 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
( newBrushWidgetAction, newBrushParams ) = case mbPrevAction of
-- Continue the current brush widget action.
Just prevAction@( BrushWidgetActionState
case mbPrevAction of
Just ( ABrushWidgetActionState @brushFields'
prevAction@( BrushWidgetActionState
{ brushWidgetPointBeingMoved = oldPt
, brushWidgetPointIndex = j'
, brushWidgetAction = act }) ->
if j /= j'
-- If we have already started a widget action, only continue an action
, brushWidgetAction = act } ) ) ->
if
| Just Refl <- eqT @brushFields @brushFields'
, j == j'
-- Continue the current brush widget action,
-- at the point with the correct index in the stroke.
then ( Nothing, currentBrushParams )
else
let newPt = pointCoords pt --> c
-> do
let
newPt = pointCoords pt --> c
newParams =
Brush.widgetUpdate ( brushWidget brush ) act
( oldPt, newPt )
currentBrushParams
in ( Just $ prevAction { brushWidgetPointBeingMoved = newPt }, newParams )
Nothing ->
newAction =
prevAction
{ brushWidgetPointBeingMoved = newPt
, brushWidgetPrevParams = currentBrushParams
, brushWidgetNewParams = Just newParams
}
Tardis.sendFuture $
WidgetFwd
{ mbPastAction = Just newAction
, changeInPrevCurve = True
, pastActionPropagates = True -- currentPointSelected
}
Tardis.sendPast $
WidgetBwd
{ mbFuturePropagatingAction =
--if currentPointSelected
--then
Just newAction
--else Nothing
}
return $ upd newParams
| currentPointSelected
-- Propagate the current brush widget action to other selected points.
-> do
~( WidgetBwd { mbFuturePropagatingAction = mbFutureAct } )
<- Tardis.getFuture
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 ->
Just cp -> do
let newAction =
BrushWidgetActionState
{ brushWidgetPointBeingMoved = cp
@ -1070,15 +1193,22 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont
if pressingCtrl
then Brush.RotateAction
else Brush.ScaleAction Brush.ScaleXY
, brushWidgetPrevParams =
currentBrushParams
, brushWidgetNewParams =
Nothing
}
in ( Just newAction, currentBrushParams )
Nothing -> ( Nothing, currentBrushParams )
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
case newBrushWidgetAction of
Just a -> State.put ( Just a, True )
_ -> State.modify' ( \ ( a, _ ) -> ( a, False ) )
pure ( set ( field @"brushParams" ) ( updatePointParams newBrushParams ( brushParams pt ) ) pt )
_ -> return noUpd

View file

@ -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 θ'