From 5adcb34de60c381e741de9a97f2eed23bbd20c06 Mon Sep 17 00:00:00 2001 From: sheaf Date: Sat, 19 Oct 2024 15:51:45 +0200 Subject: [PATCH] synchronise brush widget change across selection --- MetaBrush.cabal | 2 + src/app/MetaBrush/Application/Action.hs | 54 ++-- src/app/MetaBrush/Application/Context.hs | 4 +- src/metabrushes/MetaBrush/Action.hs | 364 +++++++++++++++------- src/metabrushes/MetaBrush/Brush/Widget.hs | 57 +++- 5 files changed, 342 insertions(+), 139 deletions(-) diff --git a/MetaBrush.cabal b/MetaBrush.cabal index 5b3ce46..8b258f1 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -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 diff --git a/src/app/MetaBrush/Application/Action.hs b/src/app/MetaBrush/Application/Action.hs index b64a009..424fb83 100644 --- a/src/app/MetaBrush/Application/Action.hs +++ b/src/app/MetaBrush/Application/Action.hs @@ -876,13 +876,17 @@ 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 - Nothing -> - 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 ) + 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 + STM.writeTVar mouseHoldTVar ( Just $ BrushWidgetAction pos brushAction' ) + -- This is just for preview, so TrivialDiff. + pure ( UpdateDoc $ UpdateDocumentTo newDocument TrivialDiff ) _ -> pure Don'tModifyDoc | otherwise -> pure Don'tModifyDoc @@ -894,14 +898,19 @@ instance HandleAction MouseMove where selectionMode :: Foldable f => f Modifier -> SelectionMode selectionMode = foldMap \case - Alt _ -> Subtract - Shift _ -> Add - _ -> New + 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 - _ -> False + _ -> False ----------------- -- Mouse click -- @@ -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. diff --git a/src/app/MetaBrush/Application/Context.hs b/src/app/MetaBrush/Application/Context.hs index 5dc5d03..b9bff99 100644 --- a/src/app/MetaBrush/Application/Context.hs +++ b/src/app/MetaBrush/Application/Context.hs @@ -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 diff --git a/src/metabrushes/MetaBrush/Action.hs b/src/metabrushes/MetaBrush/Action.hs index d4c433c..2a37cd1 100644 --- a/src/metabrushes/MetaBrush/Action.hs +++ b/src/metabrushes/MetaBrush/Action.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# 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 + { 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,35 +976,44 @@ 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 - embedUsedParams = updateBrushParams defaultBrushParams - toBrushParams = embedUsedParams . ptParamsToUsedParams - noUpdatePointParams :: Record pointFields -> Record pointFields' - noUpdatePointParams p = unionWith ( \ pt _ -> pt ) p defaultBrushParams - updatePointParams :: Record brushFields -> Record pointFields -> Record pointFields' - updatePointParams b p = unionWith ( \ _ brushParam' -> brushParam' ) p b - spline' <- - bitraverseSpline - ( updateSplineCurve ( splineStart oldSpline ) brush toBrushParams noUpdatePointParams updatePointParams u ) - ( updateSplinePoint brush toBrushParams updatePointParams u FirstPoint ) - oldSpline - ( mbAct, _ ) <- State.get - case mbAct of - Nothing -> return PreserveStroke - Just {} -> return $ UpdateStrokeTo $ Stroke { strokeBrush, strokeSpline = spline' } + = 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' + noUpdatePointParams p = unionWith ( \ pt _ -> pt ) p defaultBrushParams + updatePointParams :: Record brushFields -> Record pointFields -> Record pointFields' + updatePointParams b p = unionWith ( \ _ brushParam' -> brushParam' ) p b + spline' <- + bitraverseSpline + ( updateSplineCurve ( splineStart oldSpline ) brush toBrushParams noUpdatePointParams updatePointParams u ) + ( updateSplinePoint brush toBrushParams noUpdatePointParams updatePointParams u FirstPoint ) + oldSpline + 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, - -- - 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 - 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 } ) - 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 } ) - 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' + 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 + -- - 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 ( updPt ( PointIndex crvIx PathPoint ) ) sp1 + dat' <- updDat dat + pure ( LineTo { curveEnd = sp1', curveData = dat' } ) + Bezier2To sp1 sp2 dat -> do + 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' <- 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,61 +1078,137 @@ 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 - { brushWidgetPointBeingMoved = oldPt - , brushWidgetPointIndex = j' - , brushWidgetAction = act }) -> - if j /= j' - -- If we have already started a widget action, only continue an action - -- at the point with the correct index in the stroke. - then ( Nothing, currentBrushParams ) - else - let newPt = pointCoords pt --> c - newParams = - Brush.widgetUpdate ( brushWidget brush ) act - ( oldPt, newPt ) - currentBrushParams - in ( Just $ prevAction { brushWidgetPointBeingMoved = newPt }, newParams ) - Nothing -> - -- See if we can start a new brush widget action. - case listToMaybe $ filter ( inSelectionRange $ pointCoords pt ) ( Brush.widgetPoints brushWidgetElts ) of - Just cp -> - 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 - } - in ( Just newAction, currentBrushParams ) - Nothing -> ( Nothing, currentBrushParams ) - -- 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 ) + case mbPrevAction of + Just ( ABrushWidgetActionState @brushFields' + prevAction@( BrushWidgetActionState + { brushWidgetPointBeingMoved = oldPt + , brushWidgetPointIndex = j' + , 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. + -> do + let + newPt = pointCoords pt --> c + newParams = + Brush.widgetUpdate ( brushWidget brush ) act + ( oldPt, newPt ) + currentBrushParams + 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 -> 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 diff --git a/src/metabrushes/MetaBrush/Brush/Widget.hs b/src/metabrushes/MetaBrush/Brush/Widget.hs index bf66db1..36318d4 100644 --- a/src/metabrushes/MetaBrush/Brush/Widget.hs +++ b/src/metabrushes/MetaBrush/Brush/Widget.hs @@ -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 θ'