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
|
>= 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
|
||||||
|
|
|
@ -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.
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 θ'
|
||||||
|
|
Loading…
Reference in a new issue