mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
fix time-travel issue in deletion code
This commit is contained in:
parent
dc11c1af15
commit
087c29aef3
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue