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 >= 0.3.6.2 && < 0.3.8
, stm , stm
^>= 2.5.0.0 ^>= 2.5.0.0
, tardis
^>= 0.5.0
, text , text
>= 2.0 && < 3 >= 2.0 && < 3
, unordered-containers , unordered-containers

View file

@ -876,13 +876,17 @@ instance HandleAction MouseMove where
-> do mbHoldAction <- STM.readTVar mouseHoldTVar -> do mbHoldAction <- STM.readTVar mouseHoldTVar
case mbHoldAction of case mbHoldAction of
Just ( BrushWidgetAction { brushWidgetAction = brushAction } ) -> 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 _ -> pure Don'tModifyDoc
| otherwise | otherwise
-> pure Don'tModifyDoc -> pure Don'tModifyDoc
@ -894,14 +898,19 @@ instance HandleAction MouseMove where
selectionMode :: Foldable f => f Modifier -> SelectionMode selectionMode :: Foldable f => f Modifier -> SelectionMode
selectionMode = foldMap \case 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 :: Foldable f => f Modifier -> Bool
pressingControl = any \case pressingControl = any \case
Control {} -> True Control {} -> True
_ -> False _ -> False
----------------- -----------------
-- Mouse click -- -- Mouse click --
@ -969,17 +978,24 @@ instance HandleAction MouseClick where
Just ( BrushWidgetAction { brushWidgetAction } ) Just ( BrushWidgetAction { brushWidgetAction } )
-> Just brushWidgetAction -> Just brushWidgetAction
_ -> Nothing _ -> 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 $ UpdateBrushParameters
{ updateBrushStroke = brushWidgetStrokeUnique actionState { updateBrushStroke = updStrokeUnique
, updateBrushPoint = brushWidgetPointIndex actionState , updateBrushPoint = updPointIndex
, updateBrushAction = act , updateBrushAction = updAction
} }
return ( Just $ UpdateDoc $ UpdateDocumentTo newDocument diff ) return ( Just $ UpdateDoc $ UpdateDocumentTo newDocument diff )
Nothing -> _ ->
return Nothing return Nothing
-- If we are doing a brush widget action, don't attempt anything else. -- If we are doing a brush widget action, don't attempt anything else.
-- Otherwise, move on to selection. -- Otherwise, move on to selection.

View file

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

View file

@ -1,5 +1,6 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
module MetaBrush.Action module MetaBrush.Action
( -- * Subdividing a stroke ( -- * Subdividing a stroke
@ -14,6 +15,7 @@ module MetaBrush.Action
, deleteSelected , deleteSelected
-- * Brush widget actions -- * Brush widget actions
, BrushWidgetActionState(..) , BrushWidgetActionState(..)
, ABrushWidgetActionState(..)
, applyBrushWidgetAction , applyBrushWidgetAction
) where ) where
@ -28,6 +30,8 @@ import Data.Foldable
( for_, traverse_ ) ( for_, traverse_ )
import Data.Functor import Data.Functor
( (<&>) ) ( (<&>) )
import Data.Kind
( Type )
import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty as NE
import Data.Maybe import Data.Maybe
( fromMaybe, isNothing, listToMaybe ) ( fromMaybe, isNothing, listToMaybe )
@ -36,6 +40,12 @@ import Data.Semigroup
( Arg(..), Min(..) ) ( Arg(..), Min(..) )
import Data.Traversable import Data.Traversable
( for ) ( for )
import Data.Type.Equality
( (:~:)(..) )
import Data.Typeable
( Typeable, eqT )
import GHC.TypeLits
( Symbol )
-- acts -- acts
import Data.Act import Data.Act
@ -64,6 +74,11 @@ import Data.Group
import Control.Lens import Control.Lens
( set, over ) ( set, over )
-- tardis
import Control.Monad.Tardis
( Tardis )
import qualified Control.Monad.Tardis as Tardis
-- transformers -- transformers
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
( Except ) ( Except )
@ -899,21 +914,48 @@ dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragCurveIndex, dragCurvePa
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Brush widget -- 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 = BrushWidgetActionState
{ brushWidgetAction :: !Brush.WidgetAction { brushWidgetAction :: !Brush.WidgetAction
, brushWidgetStrokeUnique :: !Unique , brushWidgetStrokeUnique :: !Unique
, brushWidgetPointIndex :: !PointIndex , brushWidgetPointIndex :: !PointIndex
, brushWidgetPointBeingMoved :: !( T ( 2 ) ) , 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. -- | 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 let
( newStrokes, ( mbAct, _ ) ) = ( newStrokes, mbAct ) =
( `State.runState` ( Nothing, False ) ) $ ( `State.runState` Nothing ) $
forStrokeHierarchy forStrokeHierarchy
( layerMetadata documentMetadata ) ( layerMetadata documentMetadata )
( strokeHierarchy documentContent ) ( strokeHierarchy documentContent )
@ -926,7 +968,7 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont
zoom = documentZoom $ documentMetadata 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 ) 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 } )
@ -934,35 +976,44 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont
, not strokeLocked , not strokeLocked
-- If we have already started a widget action, only continue an action -- If we have already started a widget action, only continue an action
-- for the stroke with the correct unique. -- 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. -- Don't touch strokes without brushes.
, Just ( brush@( NamedBrush {} ) :: NamedBrush brushFields ) <- strokeBrush , Just ( brush@( NamedBrush {} ) :: NamedBrush brushFields ) <- strokeBrush
, Intersection { inject2 = updateBrushParams, project1 = ptParamsToUsedParams } , Intersection { inject2 = updateBrushParams, project1 = ptParamsToUsedParams }
<- intersect @pointFields @brushFields <- intersect @pointFields @brushFields
, Union @pointFields' unionWith , Union @pointFields' unionWith
<- union @pointFields @brushFields <- 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 | otherwise
= return PreserveStroke = return PreserveStroke
updateSplineCurve updateSplineCurve
:: forall clo' pointParams brushFields pointParams' :: 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 => PointData pointParams
-> NamedBrush brushFields -> NamedBrush brushFields
-> ( pointParams -> Record brushFields ) -> ( pointParams -> Record brushFields )
@ -970,48 +1021,51 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont
-> ( 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 )
-> 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 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 where
crvIx = curveIndex ( curveData curve ) 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 :: 2 -> T ( 2 ) -> Bool
inSelectionRange p cp = inSelectionRange p cp =
inPointClickRange zoom c ( cp p ) inPointClickRange zoom c ( cp p )
@ -1024,61 +1078,137 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont
updateSplinePoint updateSplinePoint
:: forall pointParams brushFields pointParams' :: forall pointParams brushFields pointParams'
. NamedBrush brushFields . ( Show ( Record brushFields )
, Typeable brushFields
, Torsor ( T ( Record brushFields ) ) ( Record brushFields )
)
=> NamedBrush brushFields
-> ( pointParams -> Record brushFields ) -> ( pointParams -> Record brushFields )
-> ( pointParams -> pointParams' )
-> ( Record brushFields -> pointParams -> pointParams' ) -> ( Record brushFields -> pointParams -> pointParams' )
-> Unique -> PointIndex -> Unique -> PointIndex
-> PointData pointParams -> 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 let
currentPointSelected = pointIsSelected uniq j
currentBrushParams :: Record brushFields currentBrushParams :: Record brushFields
currentBrushParams = toBrushParams ( brushParams pt ) 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
brushWidgetElts = Brush.widgetElements ( brushWidget brush ) currentBrushParams 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

View file

@ -1,10 +1,12 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module MetaBrush.Brush.Widget module MetaBrush.Brush.Widget
( Widget(..) ( Widget(..)
, WidgetElements(..) , WidgetElements(..)
, widgetElements , widgetElements
, widgetUpdate , widgetUpdate
, widgetUpdateSync
, WhatScale(..) , WhatScale(..)
, WidgetAction(..) , WidgetAction(..)
, describeWidgetAction , describeWidgetAction
@ -21,6 +23,10 @@ import GHC.TypeLits
import GHC.Generics import GHC.Generics
( Generic ) ( Generic )
-- acts
import Data.Act
( Act(()), Torsor((-->)) )
-- deepseq -- deepseq
import Control.DeepSeq import Control.DeepSeq
( NFData ) ( NFData )
@ -125,7 +131,7 @@ widgetUpdate widget mode ( oldPt, newPt ) ( MkR oldFlds ) =
case widget of case widget of
SquareWidget SquareWidget
| T ( 2 x y ) <- newPt | T ( 2 x y ) <- newPt
-> MkR $ 1 ( max ( abs x ) ( abs y ) ) -> MkR $ 1 ( max 1e-6 $ max ( abs x ) ( abs y ) )
RotatableRectangleWidget RotatableRectangleWidget
| 3 w h θ <- oldFlds | 3 w h θ <- oldFlds
-> case mode of -> case mode of
@ -149,3 +155,52 @@ widgetUpdate widget mode ( oldPt, newPt ) ( MkR oldFlds ) =
nearestAngle :: Double -> Double -> Double nearestAngle :: Double -> Double -> Double
nearestAngle θ0 θ = θ0 + ( ( θ - θ0 + pi ) `mod'` ( 2 * pi ) - pi ) 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 θ'