{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-}
module Simulation.Aivika.IO.Var.Unboxed () 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.Unboxed
import Simulation.Aivika.IO.DES
import Simulation.Aivika.Unboxed
import qualified Simulation.Aivika.Vector.Unboxed as UV
instance Unboxed a => MonadVar IO a where
{-# SPECIALISE instance MonadVar IO Double #-}
{-# SPECIALISE instance MonadVar IO Float #-}
{-# SPECIALISE instance MonadVar IO Int #-}
data Var IO a =
Var { forall a. Var IO a -> Vector Double
varXS :: UV.Vector Double,
forall a. Var IO a -> Vector a
varMS :: UV.Vector a,
forall a. Var IO a -> Vector a
varYS :: UV.Vector a,
forall a. Var IO a -> SignalSource IO a
varChangedSource :: SignalSource IO a }
{-# INLINABLE newVar #-}
newVar :: 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. Unboxed a => IO (Vector a)
UV.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. Unboxed a => IO (Vector a)
UV.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. Unboxed a => Vector a -> a -> IO ()
UV.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. Unboxed a => Vector a -> a -> IO ()
UV.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 :: 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. Unboxed a => Vector a -> Int -> IO a
UV.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. Unboxed a => Vector a -> a -> IO ()
UV.appendVector Vector a
ms a
a
Vector a -> a -> IO ()
forall a. Unboxed a => Vector a -> a -> IO ()
UV.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. Unboxed a => Vector a -> Int -> IO a
UV.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. Unboxed a => Vector a -> Int -> IO a
UV.readVector Vector a
ms Int
i
else Vector a -> Int -> IO a
forall a. Unboxed a => Vector a -> Int -> IO a
UV.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 :: 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. Unboxed a => Vector a -> Int -> IO a
UV.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. Unboxed a => Vector a -> Int -> IO a
UV.readVector Vector a
ys Int
i
else Vector a -> Int -> IO a
forall a. Unboxed a => Vector a -> Int -> IO a
UV.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 :: 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. Unboxed a => Vector a -> Int -> a -> IO ()
UV.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. Unboxed a => Vector a -> a -> IO ()
UV.appendVector Vector a
ms (a -> IO ()) -> a -> IO ()
forall a b. (a -> b) -> a -> b
$! a
a
Vector a -> a -> IO ()
forall a. Unboxed a => Vector a -> a -> IO ()
UV.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 :: 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. Unboxed a => Vector a -> Int -> IO a
UV.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. Unboxed a => Vector a -> Int -> a -> IO ()
UV.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. Unboxed a => Vector a -> Int -> IO a
UV.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. Unboxed a => Vector a -> a -> IO ()
UV.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. Unboxed a => Vector a -> a -> IO ()
UV.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 :: 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. Unboxed a => Vector a -> IO (Array Int a)
UV.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. Unboxed a => Vector a -> IO (Array Int a)
UV.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 :: 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_ :: 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 (m :: * -> *) a. MonadVar m a => Var m a -> Signal m a
varChanged Var IO a
v