{-# LANGUAGE TypeFamilies #-}

-- |
-- Module     : Simulation.Aivika.IO.Var
-- Copyright  : Copyright (c) 2009-2017, David Sorokin <david.sorokin@gmail.com>
-- License    : BSD3
-- Maintainer : David Sorokin <david.sorokin@gmail.com>
-- Stability  : experimental
-- Tested with: GHC 8.0.1
--
-- The 'IO' monad is an instance of 'MonadVar'.
--
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

-- | The 'IO' monad is an instance of 'MonadVar'.
instance MonadVar IO where
-- instance (Monad m, MonadDES m, MonadIO m, MonadTemplate m) => MonadVar m where

  {-# SPECIALISE instance MonadVar IO #-}

  -- | A template-based implementation of the variable.
  data Var IO a = 
    Var { Var IO a -> Vector Double
varXS    :: UV.Vector Double,
          Var IO a -> Vector a
varMS    :: V.Vector a,
          Var IO a -> Vector a
varYS    :: V.Vector 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 (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 (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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Vector a)
forall a. IO (Vector a)
V.newVector
       IO () -> IO ()
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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
return Var :: forall a.
Vector Double
-> Vector a -> Vector a -> SignalSource IO a -> Var IO a
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 (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 (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 (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 :: 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 (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 :: 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 (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 (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 (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 (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 :: 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 (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 (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 (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 (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 (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 (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 (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 (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 :: 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 (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 (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_ :: 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 => Var m a -> Signal m a
varChanged Var IO a
v