module Simulation.Aivika.Distributed.Optimistic.Internal.UndoableLog
(UndoableLog,
newUndoableLog,
writeLog,
rollbackLog,
reduceLog,
logSize) where
import Data.IORef
import qualified Data.Vector.Mutable as V
import qualified Data.Vector.Unboxed.Mutable as UV
import Control.Monad
import Control.Monad.Trans
import qualified Simulation.Aivika.DoubleLinkedList as DLL
import Simulation.Aivika.Trans.Comp
import Simulation.Aivika.Trans.Internal.Types
import Simulation.Aivika.Distributed.Optimistic.Internal.Priority
import Simulation.Aivika.Distributed.Optimistic.Internal.DIO
import Simulation.Aivika.Distributed.Optimistic.Internal.IO
data UndoableLog =
UndoableLog { UndoableLog -> DoubleLinkedList UndoableItemChunk
logItemChunks :: DLL.DoubleLinkedList UndoableItemChunk
}
data UndoableItemChunk =
UndoableItemChunk { UndoableItemChunk -> IORef Int
chunkItemStart :: IORef Int,
UndoableItemChunk -> IORef Int
chunkItemEnd :: IORef Int,
UndoableItemChunk -> IOVector Double
chunkItemTimes :: UV.IOVector Double,
UndoableItemChunk -> IOVector (DIO ())
chunkItemUndo :: V.IOVector (DIO ())
}
chunkItemCapacity :: Int
chunkItemCapacity = Int
512
newUndoableLog :: DIO UndoableLog
newUndoableLog :: DIO UndoableLog
newUndoableLog =
do DoubleLinkedList UndoableItemChunk
xs <- IO (DoubleLinkedList UndoableItemChunk)
-> DIO (DoubleLinkedList UndoableItemChunk)
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe IO (DoubleLinkedList UndoableItemChunk)
forall a. IO (DoubleLinkedList a)
DLL.newList
UndoableLog -> DIO UndoableLog
forall a. a -> DIO a
forall (m :: * -> *) a. Monad m => a -> m a
return UndoableLog { logItemChunks :: DoubleLinkedList UndoableItemChunk
logItemChunks = DoubleLinkedList UndoableItemChunk
xs }
writeLog :: UndoableLog -> DIO () -> Event DIO ()
{-# INLINABLE writeLog #-}
writeLog :: UndoableLog -> DIO () -> Event DIO ()
writeLog UndoableLog
log DIO ()
h =
(Point DIO -> DIO ()) -> Event DIO ()
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point DIO -> DIO ()) -> Event DIO ())
-> (Point DIO -> DIO ()) -> Event DIO ()
forall a b. (a -> b) -> a -> b
$ \Point DIO
p ->
do let t :: Double
t = Point DIO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point DIO
p
IO () -> DIO ()
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO () -> DIO ()) -> IO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
do Bool
f <- DoubleLinkedList UndoableItemChunk -> IO Bool
forall a. DoubleLinkedList a -> IO Bool
DLL.listNull (UndoableLog -> DoubleLinkedList UndoableItemChunk
logItemChunks UndoableLog
log)
if Bool
f
then do UndoableItemChunk
ch <- Double -> DIO () -> IO UndoableItemChunk
newItemChunk Double
t DIO ()
h
DoubleLinkedList UndoableItemChunk -> UndoableItemChunk -> IO ()
forall a. DoubleLinkedList a -> a -> IO ()
DLL.listAddLast (UndoableLog -> DoubleLinkedList UndoableItemChunk
logItemChunks UndoableLog
log) UndoableItemChunk
ch
else do UndoableItemChunk
ch <- DoubleLinkedList UndoableItemChunk -> IO UndoableItemChunk
forall a. DoubleLinkedList a -> IO a
DLL.listLast (UndoableLog -> DoubleLinkedList UndoableItemChunk
logItemChunks UndoableLog
log)
Int
e <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef (UndoableItemChunk -> IORef Int
chunkItemEnd UndoableItemChunk
ch)
Double
t0 <- MVector (PrimState IO) Double -> Int -> IO Double
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
UV.read (UndoableItemChunk -> IOVector Double
chunkItemTimes UndoableItemChunk
ch) (Int
e Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
t0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
[Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
[Char]
"The logging data are not sorted by time (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
Double -> [Char]
forall a. Show a => a -> [Char]
show Double
t [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" < " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
Double -> [Char]
forall a. Show a => a -> [Char]
show Double
t0 [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"): writeLog"
if Int
e Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
chunkItemCapacity
then do UndoableItemChunk
ch <- Double -> DIO () -> IO UndoableItemChunk
newItemChunk Double
t DIO ()
h
DoubleLinkedList UndoableItemChunk -> UndoableItemChunk -> IO ()
forall a. DoubleLinkedList a -> a -> IO ()
DLL.listAddLast (UndoableLog -> DoubleLinkedList UndoableItemChunk
logItemChunks UndoableLog
log) UndoableItemChunk
ch
else do let e' :: Int
e' = Int
e Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
MVector (PrimState IO) Double -> Int -> Double -> IO ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
UV.write (UndoableItemChunk -> IOVector Double
chunkItemTimes UndoableItemChunk
ch) Int
e Double
t
MVector (PrimState IO) (DIO ()) -> Int -> DIO () -> IO ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
V.write (UndoableItemChunk -> IOVector (DIO ())
chunkItemUndo UndoableItemChunk
ch) Int
e DIO ()
h
Int
e' Int -> IO () -> IO ()
forall a b. a -> b -> b
`seq` IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (UndoableItemChunk -> IORef Int
chunkItemEnd UndoableItemChunk
ch) Int
e'
rollbackLog :: UndoableLog -> Double -> Bool -> DIO ()
rollbackLog :: UndoableLog -> Double -> Bool -> DIO ()
rollbackLog UndoableLog
log Double
t Bool
including =
do
DIO ()
loop
where
loop :: DIO ()
loop =
do Bool
f <- IO Bool -> DIO Bool
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Bool -> DIO Bool) -> IO Bool -> DIO Bool
forall a b. (a -> b) -> a -> b
$ DoubleLinkedList UndoableItemChunk -> IO Bool
forall a. DoubleLinkedList a -> IO Bool
DLL.listNull (UndoableLog -> DoubleLinkedList UndoableItemChunk
logItemChunks UndoableLog
log)
Bool -> DIO () -> DIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
f (DIO () -> DIO ()) -> DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
do UndoableItemChunk
ch <- IO UndoableItemChunk -> DIO UndoableItemChunk
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO UndoableItemChunk -> DIO UndoableItemChunk)
-> IO UndoableItemChunk -> DIO UndoableItemChunk
forall a b. (a -> b) -> a -> b
$ DoubleLinkedList UndoableItemChunk -> IO UndoableItemChunk
forall a. DoubleLinkedList a -> IO a
DLL.listLast (UndoableLog -> DoubleLinkedList UndoableItemChunk
logItemChunks UndoableLog
log)
Int
s <- IO Int -> DIO Int
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Int -> DIO Int) -> IO Int -> DIO Int
forall a b. (a -> b) -> a -> b
$ IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef (UndoableItemChunk -> IORef Int
chunkItemStart UndoableItemChunk
ch)
let inner :: Int -> DIO ()
inner Int
e =
if Int
e Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
s
then do IO () -> DIO ()
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO () -> DIO ()) -> IO () -> DIO ()
forall a b. (a -> b) -> a -> b
$ DoubleLinkedList UndoableItemChunk -> IO ()
forall a. DoubleLinkedList a -> IO ()
DLL.listRemoveLast (UndoableLog -> DoubleLinkedList UndoableItemChunk
logItemChunks UndoableLog
log)
DIO ()
loop
else do let e' :: Int
e' = Int
e Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
Double
t0 <- Int
e' Int -> DIO Double -> DIO Double
forall a b. a -> b -> b
`seq` IO Double -> DIO Double
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Double -> DIO Double) -> IO Double -> DIO Double
forall a b. (a -> b) -> a -> b
$ MVector (PrimState IO) Double -> Int -> IO Double
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
UV.read (UndoableItemChunk -> IOVector Double
chunkItemTimes UndoableItemChunk
ch) Int
e'
Bool -> DIO () -> DIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
t0) Bool -> Bool -> Bool
|| (Bool
including Bool -> Bool -> Bool
&& Double
t Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
t0)) (DIO () -> DIO ()) -> DIO () -> DIO ()
forall a b. (a -> b) -> a -> b
$
do DIO ()
h <- IO (DIO ()) -> DIO (DIO ())
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO (DIO ()) -> DIO (DIO ())) -> IO (DIO ()) -> DIO (DIO ())
forall a b. (a -> b) -> a -> b
$ MVector (PrimState IO) (DIO ()) -> Int -> IO (DIO ())
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
V.read (UndoableItemChunk -> IOVector (DIO ())
chunkItemUndo UndoableItemChunk
ch) Int
e'
IO () -> DIO ()
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO () -> DIO ()) -> IO () -> DIO ()
forall a b. (a -> b) -> a -> b
$ MVector (PrimState IO) (DIO ()) -> Int -> DIO () -> IO ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
V.write (UndoableItemChunk -> IOVector (DIO ())
chunkItemUndo UndoableItemChunk
ch) Int
e' DIO ()
forall a. HasCallStack => a
undefined
IO () -> DIO ()
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO () -> DIO ()) -> IO () -> DIO ()
forall a b. (a -> b) -> a -> b
$ IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (UndoableItemChunk -> IORef Int
chunkItemEnd UndoableItemChunk
ch) Int
e'
DIO ()
h
Int -> DIO ()
inner Int
e'
Int
e <- IO Int -> DIO Int
forall a. IO a -> DIO a
forall (m :: * -> *) a. MonadIOUnsafe m => IO a -> m a
liftIOUnsafe (IO Int -> DIO Int) -> IO Int -> DIO Int
forall a b. (a -> b) -> a -> b
$ IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef (UndoableItemChunk -> IORef Int
chunkItemEnd UndoableItemChunk
ch)
Int -> DIO ()
inner Int
e
reduceLog :: UndoableLog -> Double -> IO ()
reduceLog :: UndoableLog -> Double -> IO ()
reduceLog UndoableLog
log Double
t =
do Bool
f <- DoubleLinkedList UndoableItemChunk -> IO Bool
forall a. DoubleLinkedList a -> IO Bool
DLL.listNull (UndoableLog -> DoubleLinkedList UndoableItemChunk
logItemChunks UndoableLog
log)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
f (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
do UndoableItemChunk
ch <- DoubleLinkedList UndoableItemChunk -> IO UndoableItemChunk
forall a. DoubleLinkedList a -> IO a
DLL.listFirst (UndoableLog -> DoubleLinkedList UndoableItemChunk
logItemChunks UndoableLog
log)
Int
e <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef (UndoableItemChunk -> IORef Int
chunkItemEnd UndoableItemChunk
ch)
Double
t0 <- MVector (PrimState IO) Double -> Int -> IO Double
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
UV.read (UndoableItemChunk -> IOVector Double
chunkItemTimes UndoableItemChunk
ch) (Int
e Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
if Double
t0 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
t
then do DoubleLinkedList UndoableItemChunk -> IO ()
forall a. DoubleLinkedList a -> IO ()
DLL.listRemoveFirst (UndoableLog -> DoubleLinkedList UndoableItemChunk
logItemChunks UndoableLog
log)
UndoableLog -> Double -> IO ()
reduceLog UndoableLog
log Double
t
else do let loop :: Int -> IO ()
loop Int
s =
if Int
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
e
then [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"The log is corrupted: reduceLog"
else do Double
t0 <- MVector (PrimState IO) Double -> Int -> IO Double
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> m a
UV.read (UndoableItemChunk -> IOVector Double
chunkItemTimes UndoableItemChunk
ch) Int
s
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Double
t0 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
t) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
do let s' :: Int
s' = Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
MVector (PrimState IO) (DIO ()) -> Int -> DIO () -> IO ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
V.write (UndoableItemChunk -> IOVector (DIO ())
chunkItemUndo UndoableItemChunk
ch) Int
s DIO ()
forall a. HasCallStack => a
undefined
Int
s' Int -> IO () -> IO ()
forall a b. a -> b -> b
`seq` IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (UndoableItemChunk -> IORef Int
chunkItemStart UndoableItemChunk
ch) Int
s'
Int -> IO ()
loop Int
s'
Int
s <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef (UndoableItemChunk -> IORef Int
chunkItemStart UndoableItemChunk
ch)
Int -> IO ()
loop Int
s
logSize :: UndoableLog -> IO Int
logSize :: UndoableLog -> IO Int
logSize UndoableLog
log =
do Int
n <- DoubleLinkedList UndoableItemChunk -> IO Int
forall a. DoubleLinkedList a -> IO Int
DLL.listCount (UndoableLog -> DoubleLinkedList UndoableItemChunk
logItemChunks UndoableLog
log)
if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
then Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
else do Int
n1 <- UndoableLog -> IO Int
firstItemChunkSize UndoableLog
log
Int
n2 <- UndoableLog -> IO Int
lastItemChunkSize UndoableLog
log
if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
then if Int
n1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n2
then Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n1
else [Char] -> IO Int
forall a. HasCallStack => [Char] -> a
error [Char]
"The log is corrupted: logSize"
else Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
n1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
chunkItemCapacity Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n2)
newItemChunk :: Double -> DIO () -> IO UndoableItemChunk
{-# INLINABLE newItemChunk #-}
newItemChunk :: Double -> DIO () -> IO UndoableItemChunk
newItemChunk Double
t DIO ()
h =
do IOVector Double
times <- Int -> IO (MVector (PrimState IO) Double)
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
Int -> m (MVector (PrimState m) a)
UV.new Int
chunkItemCapacity
IOVector (DIO ())
undo <- Int -> IO (MVector (PrimState IO) (DIO ()))
forall (m :: * -> *) a.
PrimMonad m =>
Int -> m (MVector (PrimState m) a)
V.new Int
chunkItemCapacity
IORef Int
start <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
0
IORef Int
end <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef Int
1
MVector (PrimState IO) Double -> Int -> Double -> IO ()
forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
UV.write IOVector Double
MVector (PrimState IO) Double
times Int
0 Double
t
MVector (PrimState IO) (DIO ()) -> Int -> DIO () -> IO ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
V.write IOVector (DIO ())
MVector (PrimState IO) (DIO ())
undo Int
0 DIO ()
h
UndoableItemChunk -> IO UndoableItemChunk
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return UndoableItemChunk { chunkItemStart :: IORef Int
chunkItemStart = IORef Int
start,
chunkItemEnd :: IORef Int
chunkItemEnd = IORef Int
end,
chunkItemTimes :: IOVector Double
chunkItemTimes = IOVector Double
times,
chunkItemUndo :: IOVector (DIO ())
chunkItemUndo = IOVector (DIO ())
undo }
itemChunkSize :: UndoableItemChunk -> IO Int
itemChunkSize :: UndoableItemChunk -> IO Int
itemChunkSize UndoableItemChunk
ch =
do Int
s <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef (UndoableItemChunk -> IORef Int
chunkItemStart UndoableItemChunk
ch)
Int
e <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef (UndoableItemChunk -> IORef Int
chunkItemEnd UndoableItemChunk
ch)
Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
e Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
s)
firstItemChunkSize :: UndoableLog -> IO Int
firstItemChunkSize :: UndoableLog -> IO Int
firstItemChunkSize UndoableLog
log =
do Bool
f <- DoubleLinkedList UndoableItemChunk -> IO Bool
forall a. DoubleLinkedList a -> IO Bool
DLL.listNull (UndoableLog -> DoubleLinkedList UndoableItemChunk
logItemChunks UndoableLog
log)
if Bool
f
then Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
else do UndoableItemChunk
ch <- DoubleLinkedList UndoableItemChunk -> IO UndoableItemChunk
forall a. DoubleLinkedList a -> IO a
DLL.listFirst (UndoableLog -> DoubleLinkedList UndoableItemChunk
logItemChunks UndoableLog
log)
UndoableItemChunk -> IO Int
itemChunkSize UndoableItemChunk
ch
lastItemChunkSize :: UndoableLog -> IO Int
lastItemChunkSize :: UndoableLog -> IO Int
lastItemChunkSize UndoableLog
log =
do Bool
f <- DoubleLinkedList UndoableItemChunk -> IO Bool
forall a. DoubleLinkedList a -> IO Bool
DLL.listNull (UndoableLog -> DoubleLinkedList UndoableItemChunk
logItemChunks UndoableLog
log)
if Bool
f
then Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
else do UndoableItemChunk
ch <- DoubleLinkedList UndoableItemChunk -> IO UndoableItemChunk
forall a. DoubleLinkedList a -> IO a
DLL.listLast (UndoableLog -> DoubleLinkedList UndoableItemChunk
logItemChunks UndoableLog
log)
UndoableItemChunk -> IO Int
itemChunkSize UndoableItemChunk
ch