{-# 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 { 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 =
    forall (m :: * -> *) a. (Run m -> m a) -> Simulation m a
Simulation forall a b. (a -> b) -> a -> b
$ \Run IO
r ->
    do Vector Double
xs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. Unboxed a => IO (Vector a)
UV.newVector
       Vector a
ms <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. IO (Vector a)
V.newVector
       Vector a
ys <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. IO (Vector a)
V.newVector
       forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Unboxed a => Vector a -> a -> IO ()
UV.appendVector Vector Double
xs forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Specs m -> Double
spcStartTime forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Run m -> Specs m
runSpecs Run IO
r
       forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> a -> IO ()
V.appendVector Vector a
ms a
a
       forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> a -> IO ()
V.appendVector Vector a
ys a
a
       SignalSource IO a
s  <- forall (m :: * -> *) a. Run m -> Simulation m a -> m a
invokeSimulation Run IO
r forall (m :: * -> *) a.
MonadDES m =>
Simulation m (SignalSource m a)
newSignalSource
       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 =
    forall (m :: * -> *) a.
EventQueueing m =>
EventProcessing -> Event m a -> Dynamics m a
runEventWith EventProcessing
CurrentEventsOrFromPast forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point IO
p ->
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
    do let xs :: Vector Double
xs = forall a. Var IO a -> Vector Double
varXS Var IO a
v
           ms :: Vector a
ms = forall a. Var IO a -> Vector a
varMS Var IO a
v
           ys :: Vector a
ys = forall a. Var IO a -> Vector a
varYS Var IO a
v
           t :: Double
t  = forall (m :: * -> *). Point m -> Double
pointTime Point IO
p
       Int
count <- forall a. Unboxed a => Vector a -> IO Int
UV.vectorCount Vector Double
xs
       let i :: Int
i = Int
count forall a. Num a => a -> a -> a
- Int
1
       Double
x <- forall a. Unboxed a => Vector a -> Int -> IO a
UV.readVector Vector Double
xs Int
i
       if Double
x forall a. Ord a => a -> a -> Bool
< Double
t
         then do a
a <- forall a. Vector a -> Int -> IO a
V.readVector Vector a
ys Int
i
                 forall a. Unboxed a => Vector a -> a -> IO ()
UV.appendVector Vector Double
xs Double
t
                 forall a. Vector a -> a -> IO ()
V.appendVector Vector a
ms a
a
                 forall a. Vector a -> a -> IO ()
V.appendVector Vector a
ys a
a
                 forall (m :: * -> *) a. Monad m => a -> m a
return a
a
         else if Double
x forall a. Eq a => a -> a -> Bool
== Double
t
              then forall a. Vector a -> Int -> IO a
V.readVector Vector a
ms Int
i
              else do Int
i <- forall a. (Unboxed a, Ord a) => Vector a -> a -> IO Int
UV.vectorBinarySearch Vector Double
xs Double
t
                      if Int
i forall a. Ord a => a -> a -> Bool
>= Int
0
                        then forall a. Vector a -> Int -> IO a
V.readVector Vector a
ms Int
i
                        else forall a. Vector a -> Int -> IO a
V.readVector Vector a
ms forall a b. (a -> b) -> a -> b
$ - (Int
i forall a. Num a => a -> a -> a
+ Int
1) 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 = 
    forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point IO
p ->
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
    do let xs :: Vector Double
xs = forall a. Var IO a -> Vector Double
varXS Var IO a
v
           ys :: Vector a
ys = forall a. Var IO a -> Vector a
varYS Var IO a
v
           t :: Double
t  = forall (m :: * -> *). Point m -> Double
pointTime Point IO
p
       Int
count <- forall a. Unboxed a => Vector a -> IO Int
UV.vectorCount Vector Double
xs
       let i :: Int
i = Int
count forall a. Num a => a -> a -> a
- Int
1
       Double
x <- forall a. Unboxed a => Vector a -> Int -> IO a
UV.readVector Vector Double
xs Int
i
       if Double
x forall a. Ord a => a -> a -> Bool
<= Double
t 
         then forall a. Vector a -> Int -> IO a
V.readVector Vector a
ys Int
i
         else do Int
i <- forall a. (Unboxed a, Ord a) => Vector a -> a -> IO Int
UV.vectorBinarySearch Vector Double
xs Double
t
                 if Int
i forall a. Ord a => a -> a -> Bool
>= Int
0
                   then forall a. Vector a -> Int -> IO a
V.readVector Vector a
ys Int
i
                   else forall a. Vector a -> Int -> IO a
V.readVector Vector a
ys forall a b. (a -> b) -> a -> b
$ - (Int
i forall a. Num a => a -> a -> a
+ Int
1) 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 =
    forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point IO
p ->
    do let xs :: Vector Double
xs = forall a. Var IO a -> Vector Double
varXS Var IO a
v
           ms :: Vector a
ms = forall a. Var IO a -> Vector a
varMS Var IO a
v
           ys :: Vector a
ys = forall a. Var IO a -> Vector a
varYS Var IO a
v
           t :: Double
t  = forall (m :: * -> *). Point m -> Double
pointTime Point IO
p
           s :: SignalSource IO a
s  = forall a. Var IO a -> SignalSource IO a
varChangedSource Var IO a
v
       Int
count <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Unboxed a => Vector a -> IO Int
UV.vectorCount Vector Double
xs
       let i :: Int
i = Int
count forall a. Num a => a -> a -> a
- Int
1
       Double
x <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Unboxed a => Vector a -> Int -> IO a
UV.readVector Vector Double
xs Int
i
       if Double
t forall a. Ord a => a -> a -> Bool
< Double
x 
         then forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot update the past data: writeVar."
         else if Double
t forall a. Eq a => a -> a -> Bool
== Double
x
              then forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> Int -> a -> IO ()
V.writeVector Vector a
ys Int
i forall a b. (a -> b) -> a -> b
$! a
a
              else forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
                   do forall a. Unboxed a => Vector a -> a -> IO ()
UV.appendVector Vector Double
xs Double
t
                      forall a. Vector a -> a -> IO ()
V.appendVector Vector a
ms forall a b. (a -> b) -> a -> b
$! a
a
                      forall a. Vector a -> a -> IO ()
V.appendVector Vector a
ys forall a b. (a -> b) -> a -> b
$! a
a
       forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point IO
p forall a b. (a -> b) -> a -> b
$ 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 =
    forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point IO
p ->
    do let xs :: Vector Double
xs = forall a. Var IO a -> Vector Double
varXS Var IO a
v
           ms :: Vector a
ms = forall a. Var IO a -> Vector a
varMS Var IO a
v
           ys :: Vector a
ys = forall a. Var IO a -> Vector a
varYS Var IO a
v
           t :: Double
t  = forall (m :: * -> *). Point m -> Double
pointTime Point IO
p
           s :: SignalSource IO a
s  = forall a. Var IO a -> SignalSource IO a
varChangedSource Var IO a
v
       Int
count <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Unboxed a => Vector a -> IO Int
UV.vectorCount Vector Double
xs
       let i :: Int
i = Int
count forall a. Num a => a -> a -> a
- Int
1
       Double
x <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Unboxed a => Vector a -> Int -> IO a
UV.readVector Vector Double
xs Int
i
       if Double
t forall a. Ord a => a -> a -> Bool
< Double
x
         then forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot update the past data: modifyVar."
         else if Double
t forall a. Eq a => a -> a -> Bool
== Double
x
              then do a
a <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> Int -> IO a
V.readVector Vector a
ys Int
i
                      let b :: a
b = a -> a
f a
a
                      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> Int -> a -> IO ()
V.writeVector Vector a
ys Int
i forall a b. (a -> b) -> a -> b
$! a
b
                      forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point IO
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. SignalSource m a -> a -> Event m ()
triggerSignal SignalSource IO a
s a
b
              else do a
a <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> Int -> IO a
V.readVector Vector a
ys Int
i
                      let b :: a
b = a -> a
f a
a
                      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Unboxed a => Vector a -> a -> IO ()
UV.appendVector Vector Double
xs Double
t
                      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> a -> IO ()
V.appendVector Vector a
ms forall a b. (a -> b) -> a -> b
$! a
b
                      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> a -> IO ()
V.appendVector Vector a
ys forall a b. (a -> b) -> a -> b
$! a
b
                      forall (m :: * -> *) a. Point m -> Event m a -> m a
invokeEvent Point IO
p forall a b. (a -> b) -> a -> b
$ 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 =
    forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event forall a b. (a -> b) -> a -> b
$ \Point IO
p ->
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
    do Array Int Double
xs <- forall a. Unboxed a => Vector a -> IO (Array Int a)
UV.freezeVector (forall a. Var IO a -> Vector Double
varXS Var IO a
v)
       Array Int a
ms <- forall a. Vector a -> IO (Array Int a)
V.freezeVector (forall a. Var IO a -> Vector a
varMS Var IO a
v)
       Array Int a
ys <- forall a. Vector a -> IO (Array Int a)
V.freezeVector (forall a. Var IO a -> Vector a
varYS Var IO a
v)
       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 = forall (m :: * -> *) a. SignalSource m a -> Signal m a
publishSignal (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 = forall (m :: * -> *) a b.
MonadDES m =>
(a -> b) -> Signal m a -> Signal m b
mapSignal (forall a b. a -> b -> a
const ()) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadVar m => Var m a -> Signal m a
varChanged Var IO a
v