{-# LANGUAGE TypeFamilies #-}
module Simulation.Aivika.IO.Var () where
import Control.Monad.Trans
import Data.Array
import Simulation.Aivika.Trans.DES
import Simulation.Aivika.Trans.Internal.Specs
import Simulation.Aivika.Trans.Internal.Simulation
import Simulation.Aivika.Trans.Internal.Dynamics
import Simulation.Aivika.Trans.Internal.Event
import Simulation.Aivika.Trans.Ref
import Simulation.Aivika.Trans.Signal
import Simulation.Aivika.Trans.Var
import Simulation.Aivika.IO.DES
import qualified Simulation.Aivika.Vector as V
import qualified Simulation.Aivika.Vector.Unboxed as UV
instance MonadVar IO where
{-# SPECIALISE instance MonadVar IO #-}
data Var IO a =
Var { forall a. Var IO a -> Vector Double
varXS :: UV.Vector Double,
forall a. Var IO a -> Vector a
varMS :: V.Vector a,
forall a. Var IO a -> Vector a
varYS :: V.Vector a,
forall a. Var IO a -> SignalSource IO a
varChangedSource :: SignalSource IO a }
{-# INLINABLE newVar #-}
newVar :: forall a. a -> Simulation IO (Var IO a)
newVar a
a =
(Run IO -> IO (Var IO a)) -> Simulation IO (Var IO a)
forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation ((Run IO -> IO (Var IO a)) -> Simulation IO (Var IO a))
-> (Run IO -> IO (Var IO a)) -> Simulation IO (Var IO a)
forall a b. (a -> b) -> a -> b
$ \Run IO
r ->
do Vector Double
xs <- IO (Vector Double) -> IO (Vector Double)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Vector Double)
forall a. Unboxed a => IO (Vector a)
UV.newVector
Vector a
ms <- IO (Vector a) -> IO (Vector a)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Vector a)
forall a. IO (Vector a)
V.newVector
Vector a
ys <- IO (Vector a) -> IO (Vector a)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Vector a)
forall a. IO (Vector a)
V.newVector
IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Vector Double -> Double -> IO ()
forall a. Unboxed a => Vector a -> a -> IO ()
UV.appendVector Vector Double
xs (Double -> IO ()) -> Double -> IO ()
forall a b. (a -> b) -> a -> b
$ Specs IO -> Double
forall (m :: * -> *). Specs m -> Double
spcStartTime (Specs IO -> Double) -> Specs IO -> Double
forall a b. (a -> b) -> a -> b
$ Run IO -> Specs IO
forall (m :: * -> *). Run m -> Specs m
runSpecs Run IO
r
IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Vector a -> a -> IO ()
forall a. Vector a -> a -> IO ()
V.appendVector Vector a
ms a
a
IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Vector a -> a -> IO ()
forall a. Vector a -> a -> IO ()
V.appendVector Vector a
ys a
a
SignalSource IO a
s <- Run IO
-> Simulation IO (SignalSource IO a) -> IO (SignalSource IO a)
forall (m :: * -> *) a. Run m -> Simulation m a -> m a
invokeSimulation Run IO
r Simulation IO (SignalSource IO a)
forall (m :: * -> *) a.
MonadDES m =>
Simulation m (SignalSource m a)
newSignalSource
Var IO a -> IO (Var IO a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Var { varXS :: Vector Double
varXS = Vector Double
xs,
varMS :: Vector a
varMS = Vector a
ms,
varYS :: Vector a
varYS = Vector a
ms,
varChangedSource :: SignalSource IO a
varChangedSource = SignalSource IO a
s }
{-# INLINABLE varMemo #-}
varMemo :: forall a. Var IO a -> Dynamics IO a
varMemo Var IO a
v =
EventProcessing -> Event IO a -> Dynamics IO a
forall a. EventProcessing -> Event IO a -> Dynamics IO a
forall (m :: * -> *) a.
EventQueueing m =>
EventProcessing -> Event m a -> Dynamics m a
runEventWith EventProcessing
CurrentEventsOrFromPast (Event IO a -> Dynamics IO a) -> Event IO a -> Dynamics IO a
forall a b. (a -> b) -> a -> b
$
(Point IO -> IO a) -> Event IO a
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point IO -> IO a) -> Event IO a)
-> (Point IO -> IO a) -> Event IO a
forall a b. (a -> b) -> a -> b
$ \Point IO
p ->
IO a -> IO a
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$
do let xs :: Vector Double
xs = Var IO a -> Vector Double
forall a. Var IO a -> Vector Double
varXS Var IO a
v
ms :: Vector a
ms = Var IO a -> Vector a
forall a. Var IO a -> Vector a
varMS Var IO a
v
ys :: Vector a
ys = Var IO a -> Vector a
forall a. Var IO a -> Vector a
varYS Var IO a
v
t :: Double
t = Point IO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point IO
p
Int
count <- Vector Double -> IO Int
forall a. Unboxed a => Vector a -> IO Int
UV.vectorCount Vector Double
xs
let i :: Int
i = Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
Double
x <- Vector Double -> Int -> IO Double
forall a. Unboxed a => Vector a -> Int -> IO a
UV.readVector Vector Double
xs Int
i
if Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
t
then do a
a <- Vector a -> Int -> IO a
forall a. Vector a -> Int -> IO a
V.readVector Vector a
ys Int
i
Vector Double -> Double -> IO ()
forall a. Unboxed a => Vector a -> a -> IO ()
UV.appendVector Vector Double
xs Double
t
Vector a -> a -> IO ()
forall a. Vector a -> a -> IO ()
V.appendVector Vector a
ms a
a
Vector a -> a -> IO ()
forall a. Vector a -> a -> IO ()
V.appendVector Vector a
ys a
a
a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
else if Double
x Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
t
then Vector a -> Int -> IO a
forall a. Vector a -> Int -> IO a
V.readVector Vector a
ms Int
i
else do Int
i <- Vector Double -> Double -> IO Int
forall a. (Unboxed a, Ord a) => Vector a -> a -> IO Int
UV.vectorBinarySearch Vector Double
xs Double
t
if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0
then Vector a -> Int -> IO a
forall a. Vector a -> Int -> IO a
V.readVector Vector a
ms Int
i
else Vector a -> Int -> IO a
forall a. Vector a -> Int -> IO a
V.readVector Vector a
ms (Int -> IO a) -> Int -> IO a
forall a b. (a -> b) -> a -> b
$ - (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
{-# INLINABLE readVar #-}
readVar :: forall a. Var IO a -> Event IO a
readVar Var IO a
v =
(Point IO -> IO a) -> Event IO a
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point IO -> IO a) -> Event IO a)
-> (Point IO -> IO a) -> Event IO a
forall a b. (a -> b) -> a -> b
$ \Point IO
p ->
IO a -> IO a
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$
do let xs :: Vector Double
xs = Var IO a -> Vector Double
forall a. Var IO a -> Vector Double
varXS Var IO a
v
ys :: Vector a
ys = Var IO a -> Vector a
forall a. Var IO a -> Vector a
varYS Var IO a
v
t :: Double
t = Point IO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point IO
p
Int
count <- Vector Double -> IO Int
forall a. Unboxed a => Vector a -> IO Int
UV.vectorCount Vector Double
xs
let i :: Int
i = Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
Double
x <- Vector Double -> Int -> IO Double
forall a. Unboxed a => Vector a -> Int -> IO a
UV.readVector Vector Double
xs Int
i
if Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
t
then Vector a -> Int -> IO a
forall a. Vector a -> Int -> IO a
V.readVector Vector a
ys Int
i
else do Int
i <- Vector Double -> Double -> IO Int
forall a. (Unboxed a, Ord a) => Vector a -> a -> IO Int
UV.vectorBinarySearch Vector Double
xs Double
t
if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0
then Vector a -> Int -> IO a
forall a. Vector a -> Int -> IO a
V.readVector Vector a
ys Int
i
else Vector a -> Int -> IO a
forall a. Vector a -> Int -> IO a
V.readVector Vector a
ys (Int -> IO a) -> Int -> IO a
forall a b. (a -> b) -> a -> b
$ - (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
{-# INLINABLE writeVar #-}
writeVar :: forall a. Var IO a -> a -> Event IO ()
writeVar Var IO a
v a
a =
(Point IO -> IO ()) -> Event IO ()
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point IO -> IO ()) -> Event IO ())
-> (Point IO -> IO ()) -> Event IO ()
forall a b. (a -> b) -> a -> b
$ \Point IO
p ->
do let xs :: Vector Double
xs = Var IO a -> Vector Double
forall a. Var IO a -> Vector Double
varXS Var IO a
v
ms :: Vector a
ms = Var IO a -> Vector a
forall a. Var IO a -> Vector a
varMS Var IO a
v
ys :: Vector a
ys = Var IO a -> Vector a
forall a. Var IO a -> Vector a
varYS Var IO a
v
t :: Double
t = Point IO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point IO
p
s :: SignalSource IO a
s = Var IO a -> SignalSource IO a
forall a. Var IO a -> SignalSource IO a
varChangedSource Var IO a
v
Int
count <- IO Int -> IO Int
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> IO Int) -> IO Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Vector Double -> IO Int
forall a. Unboxed a => Vector a -> IO Int
UV.vectorCount Vector Double
xs
let i :: Int
i = Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
Double
x <- IO Double -> IO Double
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Double -> IO Double) -> IO Double -> IO Double
forall a b. (a -> b) -> a -> b
$ Vector Double -> Int -> IO Double
forall a. Unboxed a => Vector a -> Int -> IO a
UV.readVector Vector Double
xs Int
i
if Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
x
then [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot update the past data: writeVar."
else if Double
t Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
x
then IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Vector a -> Int -> a -> IO ()
forall a. Vector a -> Int -> a -> IO ()
V.writeVector Vector a
ys Int
i (a -> IO ()) -> a -> IO ()
forall a b. (a -> b) -> a -> b
$! a
a
else IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
do Vector Double -> Double -> IO ()
forall a. Unboxed a => Vector a -> a -> IO ()
UV.appendVector Vector Double
xs Double
t
Vector a -> a -> IO ()
forall a. Vector a -> a -> IO ()
V.appendVector Vector a
ms (a -> IO ()) -> a -> IO ()
forall a b. (a -> b) -> a -> b
$! a
a
Vector a -> a -> IO ()
forall a. Vector a -> a -> IO ()
V.appendVector Vector a
ys (a -> IO ()) -> a -> IO ()
forall a b. (a -> b) -> a -> b
$! a
a
Point IO -> Event IO () -> IO ()
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point IO
p (Event IO () -> IO ()) -> Event IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ SignalSource IO a -> a -> Event IO ()
forall (m :: * -> *) a. SignalSource m a -> a -> Event m ()
triggerSignal SignalSource IO a
s a
a
{-# INLINABLE modifyVar #-}
modifyVar :: forall a. Var IO a -> (a -> a) -> Event IO ()
modifyVar Var IO a
v a -> a
f =
(Point IO -> IO ()) -> Event IO ()
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point IO -> IO ()) -> Event IO ())
-> (Point IO -> IO ()) -> Event IO ()
forall a b. (a -> b) -> a -> b
$ \Point IO
p ->
do let xs :: Vector Double
xs = Var IO a -> Vector Double
forall a. Var IO a -> Vector Double
varXS Var IO a
v
ms :: Vector a
ms = Var IO a -> Vector a
forall a. Var IO a -> Vector a
varMS Var IO a
v
ys :: Vector a
ys = Var IO a -> Vector a
forall a. Var IO a -> Vector a
varYS Var IO a
v
t :: Double
t = Point IO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point IO
p
s :: SignalSource IO a
s = Var IO a -> SignalSource IO a
forall a. Var IO a -> SignalSource IO a
varChangedSource Var IO a
v
Int
count <- IO Int -> IO Int
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> IO Int) -> IO Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Vector Double -> IO Int
forall a. Unboxed a => Vector a -> IO Int
UV.vectorCount Vector Double
xs
let i :: Int
i = Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
Double
x <- IO Double -> IO Double
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Double -> IO Double) -> IO Double -> IO Double
forall a b. (a -> b) -> a -> b
$ Vector Double -> Int -> IO Double
forall a. Unboxed a => Vector a -> Int -> IO a
UV.readVector Vector Double
xs Int
i
if Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
x
then [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot update the past data: modifyVar."
else if Double
t Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
x
then do a
a <- IO a -> IO a
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ Vector a -> Int -> IO a
forall a. Vector a -> Int -> IO a
V.readVector Vector a
ys Int
i
let b :: a
b = a -> a
f a
a
IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Vector a -> Int -> a -> IO ()
forall a. Vector a -> Int -> a -> IO ()
V.writeVector Vector a
ys Int
i (a -> IO ()) -> a -> IO ()
forall a b. (a -> b) -> a -> b
$! a
b
Point IO -> Event IO () -> IO ()
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point IO
p (Event IO () -> IO ()) -> Event IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ SignalSource IO a -> a -> Event IO ()
forall (m :: * -> *) a. SignalSource m a -> a -> Event m ()
triggerSignal SignalSource IO a
s a
b
else do a
a <- IO a -> IO a
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ Vector a -> Int -> IO a
forall a. Vector a -> Int -> IO a
V.readVector Vector a
ys Int
i
let b :: a
b = a -> a
f a
a
IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Vector Double -> Double -> IO ()
forall a. Unboxed a => Vector a -> a -> IO ()
UV.appendVector Vector Double
xs Double
t
IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Vector a -> a -> IO ()
forall a. Vector a -> a -> IO ()
V.appendVector Vector a
ms (a -> IO ()) -> a -> IO ()
forall a b. (a -> b) -> a -> b
$! a
b
IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Vector a -> a -> IO ()
forall a. Vector a -> a -> IO ()
V.appendVector Vector a
ys (a -> IO ()) -> a -> IO ()
forall a b. (a -> b) -> a -> b
$! a
b
Point IO -> Event IO () -> IO ()
forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point IO
p (Event IO () -> IO ()) -> Event IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ SignalSource IO a -> a -> Event IO ()
forall (m :: * -> *) a. SignalSource m a -> a -> Event m ()
triggerSignal SignalSource IO a
s a
b
{-# INLINABLE freezeVar #-}
freezeVar :: forall a.
Var IO a -> Event IO (Array Int Double, Array Int a, Array Int a)
freezeVar Var IO a
v =
(Point IO -> IO (Array Int Double, Array Int a, Array Int a))
-> Event IO (Array Int Double, Array Int a, Array Int a)
forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event ((Point IO -> IO (Array Int Double, Array Int a, Array Int a))
-> Event IO (Array Int Double, Array Int a, Array Int a))
-> (Point IO -> IO (Array Int Double, Array Int a, Array Int a))
-> Event IO (Array Int Double, Array Int a, Array Int a)
forall a b. (a -> b) -> a -> b
$ \Point IO
p ->
IO (Array Int Double, Array Int a, Array Int a)
-> IO (Array Int Double, Array Int a, Array Int a)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Array Int Double, Array Int a, Array Int a)
-> IO (Array Int Double, Array Int a, Array Int a))
-> IO (Array Int Double, Array Int a, Array Int a)
-> IO (Array Int Double, Array Int a, Array Int a)
forall a b. (a -> b) -> a -> b
$
do Array Int Double
xs <- Vector Double -> IO (Array Int Double)
forall a. Unboxed a => Vector a -> IO (Array Int a)
UV.freezeVector (Var IO a -> Vector Double
forall a. Var IO a -> Vector Double
varXS Var IO a
v)
Array Int a
ms <- Vector a -> IO (Array Int a)
forall a. Vector a -> IO (Array Int a)
V.freezeVector (Var IO a -> Vector a
forall a. Var IO a -> Vector a
varMS Var IO a
v)
Array Int a
ys <- Vector a -> IO (Array Int a)
forall a. Vector a -> IO (Array Int a)
V.freezeVector (Var IO a -> Vector a
forall a. Var IO a -> Vector a
varYS Var IO a
v)
(Array Int Double, Array Int a, Array Int a)
-> IO (Array Int Double, Array Int a, Array Int a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Array Int Double
xs, Array Int a
ms, Array Int a
ys)
{-# INLINE varChanged #-}
varChanged :: forall a. Var IO a -> Signal IO a
varChanged Var IO a
v = SignalSource IO a -> Signal IO a
forall (m :: * -> *) a. SignalSource m a -> Signal m a
publishSignal (Var IO a -> SignalSource IO a
forall a. Var IO a -> SignalSource IO a
varChangedSource Var IO a
v)
{-# INLINE varChanged_ #-}
varChanged_ :: forall a. MonadDES IO => Var IO a -> Signal IO ()
varChanged_ Var IO a
v = (a -> ()) -> Signal IO a -> Signal IO ()
forall (m :: * -> *) a b.
MonadDES m =>
(a -> b) -> Signal m a -> Signal m b
mapSignal (() -> a -> ()
forall a b. a -> b -> a
const ()) (Signal IO a -> Signal IO ()) -> Signal IO a -> Signal IO ()
forall a b. (a -> b) -> a -> b
$ Var IO a -> Signal IO a
forall a. Var IO a -> Signal IO a
forall (m :: * -> *) a. MonadVar m => Var m a -> Signal m a
varChanged Var IO a
v