{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-}

-- |
-- Module     : Simulation.Aivika.IO.Var.Unboxed
-- 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 can be an instance of 'MonadVar'.
--
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

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

  {-# SPECIALISE instance MonadVar IO Double #-}
  {-# SPECIALISE instance MonadVar IO Float #-}
  {-# SPECIALISE instance MonadVar IO Int #-}

  -- | 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    :: 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 =
    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. Unboxed a => IO (Vector a)
UV.newVector
       Vector a
ys <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. Unboxed a => IO (Vector a)
UV.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. Unboxed a => Vector a -> a -> IO ()
UV.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. Unboxed a => Vector a -> a -> IO ()
UV.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 :: 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. Unboxed a => Vector a -> Int -> IO a
UV.readVector Vector a
ys Int
i
                 forall a. Unboxed a => Vector a -> a -> IO ()
UV.appendVector Vector Double
xs Double
t
                 forall a. Unboxed a => Vector a -> a -> IO ()
UV.appendVector Vector a
ms a
a
                 forall a. Unboxed a => Vector a -> a -> IO ()
UV.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. Unboxed a => Vector a -> Int -> IO a
UV.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. Unboxed a => Vector a -> Int -> IO a
UV.readVector Vector a
ms Int
i
                        else forall a. Unboxed a => Vector a -> Int -> IO a
UV.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 :: 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. Unboxed a => Vector a -> Int -> IO a
UV.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. Unboxed a => Vector a -> Int -> IO a
UV.readVector Vector a
ys Int
i
                   else forall a. Unboxed a => Vector a -> Int -> IO a
UV.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 :: 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. Unboxed a => Vector a -> Int -> a -> IO ()
UV.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. Unboxed a => Vector a -> a -> IO ()
UV.appendVector Vector a
ms forall a b. (a -> b) -> a -> b
$! a
a
                      forall a. Unboxed a => Vector a -> a -> IO ()
UV.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 :: 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. Unboxed a => Vector a -> Int -> IO a
UV.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 -> Int -> a -> IO ()
UV.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. Unboxed a => Vector a -> Int -> IO a
UV.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. Unboxed a => Vector a -> a -> IO ()
UV.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. Unboxed a => Vector a -> a -> IO ()
UV.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 :: 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. Unboxed a => Vector a -> IO (Array Int a)
UV.freezeVector (forall a. Var IO a -> Vector a
varMS Var IO a
v)
       Array Int a
ys <- forall a. Unboxed a => Vector a -> IO (Array Int a)
UV.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 :: 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_ :: 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 a => Var m a -> Signal m a
varChanged Var IO a
v