mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
synchronise brush widget change across selection
This commit is contained in:
parent
0223c92a85
commit
5adcb34de6
|
@ -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
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 θ'
|
||||
|
|
Loading…
Reference in a new issue