diff --git a/src/app/MetaBrush/Document/Selection.hs b/src/app/MetaBrush/Document/Selection.hs index 7c4c0a7..0b3d0b5 100644 --- a/src/app/MetaBrush/Document/Selection.hs +++ b/src/app/MetaBrush/Document/Selection.hs @@ -58,7 +58,7 @@ import Control.Lens -- tardis import Control.Monad.Trans.Tardis - ( Tardis, TardisT ) + ( Tardis ) import qualified Control.Monad.Trans.Tardis as Tardis ( TardisT(..) , getPast, getFuture, sendPast, sendFuture @@ -68,8 +68,8 @@ import qualified Control.Monad.Trans.Tardis as Tardis import Control.Monad.Trans.Class ( lift ) import Control.Monad.Trans.State.Strict - ( StateT(..) - , State, runState, evalState, get, put, modify' + ( StateT(..), State, runState, evalState + , get, put, modify ) -- MetaBrush @@ -296,15 +296,24 @@ data UpdateInfo deriving ( Semigroup, Monoid ) via Generically UpdateInfo -recordPointUpdate :: Unique -> StrokePoint d -> State UpdateInfo () -recordPointUpdate uniq ( PathPoint {} ) = modify' - ( over ( field' @"pathPointsAffected" ) (<>1) - . over ( field' @"strokesAffected" ) ( Set.insert uniq ) - ) -recordPointUpdate uniq ( ControlPoint {} ) = modify' +-- Update the info to record a modification. +-- +-- Needs to be lazy in the given Boolean, to avoid time paradoxes. +recordPointUpdate :: Monad m => Bool -> Unique -> StrokePoint d -> StateT UpdateInfo m () +recordPointUpdate doUpdate uniq ( PathPoint {} ) = modify $ + if doUpdate + then + ( over ( field' @"pathPointsAffected" ) (<>1) + . over ( field' @"strokesAffected" ) ( Set.insert uniq ) + ) + else id +recordPointUpdate doUpdate uniq ( ControlPoint {} ) = modify $ + if doUpdate + then ( over ( field' @"controlPointsAffected" ) (<>1) . over ( field' @"strokesAffected" ) ( Set.insert uniq ) ) + else id -- | Translate all selected points by the given vector. -- @@ -330,7 +339,7 @@ translateSelection mode t doc = updateStrokePoint :: HasType FocusState pt => Unique -> StrokePoint pt -> State UpdateInfo ( StrokePoint pt ) updateStrokePoint uniq pt | Selected <- view _selection pt - = recordPointUpdate uniq pt + = recordPointUpdate True uniq pt $> pt { coords = t • coords pt } | otherwise = pure pt @@ -339,16 +348,15 @@ translateSelection mode t doc = -- -- Returns the updated document, together with info about how many points were deleted. deleteSelected :: Mode -> Document -> ( Document, UpdateInfo ) -deleteSelected mode doc = ( newDoc, updateInfo ) +deleteSelected mode doc = deletionResult where - newDoc :: Document - updateInfo :: UpdateInfo - ( ( newDoc, _ ), updateInfo ) - = runIdentity . ( `runStateT` mempty ) . ( `Tardis.runTardisT` ( False, False ) ) + deletionResult :: ( Document, UpdateInfo ) + deletionResult + = fst . runIdentity . ( `Tardis.runTardisT` ( False, False ) ) . ( `runStateT` mempty ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc - updateStroke :: Stroke -> TardisT Bool Bool ( State UpdateInfo ) Stroke + updateStroke :: Stroke -> StateT UpdateInfo ( Tardis Bool Bool ) Stroke updateStroke stroke@( Stroke { strokeVisible, strokeUnique } ) | not strokeVisible = pure stroke @@ -365,24 +373,24 @@ deleteSelected mode doc = ( newDoc, updateInfo ) :: forall pt . HasType FocusState pt => Unique -> Seq ( StrokePoint pt ) - -> TardisT Bool Bool ( State UpdateInfo ) ( Seq ( StrokePoint pt ) ) + -> StateT UpdateInfo ( Tardis Bool Bool ) ( Seq ( StrokePoint pt ) ) updateStrokePoints _ Empty = pure Empty updateStrokePoints uniq ( p :<| ps ) = case p of PathPoint {} | Selected <- selectionState -> do - Tardis.sendPast True - Tardis.sendFuture True - lift ( recordPointUpdate uniq p ) + lift ( Tardis.sendPast True ) + lift ( Tardis.sendFuture True ) + recordPointUpdate True uniq p updateStrokePoints uniq ps | otherwise -> do - Tardis.sendPast False - Tardis.sendFuture False + lift ( Tardis.sendPast False ) + lift ( Tardis.sendFuture False ) ( p :<| ) <$> updateStrokePoints uniq ps _ -> do - prevPathPointDeleted <- Tardis.getPast - nextPathPointDeleted <- Tardis.getFuture + prevPathPointDeleted <- lift Tardis.getPast + nextPathPointDeleted <- lift Tardis.getFuture rest <- updateStrokePoints uniq ps let -- Control point must be deleted: @@ -391,17 +399,13 @@ deleteSelected mode doc = ( newDoc, updateInfo ) -- - if the next path point is going to be deleted. -- -- Need to be lazy in "nextPathPointDeleted" to avoid looping. - res :: Seq ( StrokePoint pt ) - stateAction :: State UpdateInfo () - ( res, stateAction ) - | selectionState == Selected + needsDeletion :: Bool + needsDeletion + = selectionState == Selected || prevPathPointDeleted || nextPathPointDeleted - = ( rest, recordPointUpdate uniq p ) - | otherwise - = ( p :<| rest, pure () ) - lift stateAction - pure res + recordPointUpdate needsDeletion uniq p + pure $ if needsDeletion then rest else ( p :<| rest ) where selectionState :: FocusState selectionState = view _selection p