fix time-travel issue in deletion code

This commit is contained in:
sheaf 2020-09-11 00:37:39 +02:00
parent dc11c1af15
commit 087c29aef3

View file

@ -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