-- |
-- Module     : Simulation.Aivika.RealTime.Internal.RT
-- Copyright  : Copyright (c) 2016-2017, David Sorokin <david.sorokin@gmail.com>
-- License    : BSD3
-- Maintainer : David Sorokin <david.sorokin@gmail.com>
-- Stability  : experimental
-- Tested with: GHC 8.0.1
--
-- This module defines a soft real-time computation based on 'IO'.
--
module Simulation.Aivika.RealTime.Internal.RT
       (RT(..),
        RTParams(..),
        RTContext(..),
        RTScaling(..),
        invokeRT,
        runRT,
        defaultRTParams,
        newRTContext,
        rtParams,
        rtChannel,
        rtScale) where

import Control.Applicative
import Control.Monad
import Control.Monad.Trans

import Simulation.Aivika.Trans.Exception
import Simulation.Aivika.Trans.Internal.Types

import Simulation.Aivika.RealTime.Internal.Channel

-- | How the modeling time is scaled to a real time.
data RTScaling = RTLinearScaling Double
                 -- ^ one unit of modeling time interval matches
                 -- the specified amount of real seconds
               | RTLogScaling Double
                 -- ^ the logarithm of one unit of modeling time
                 -- interval matches the specified amount of
                 -- real seconds
               | RTScalingFunction (Double -> Double -> Double)
                 -- ^ we explicitly define how many real seconds
                 -- will we receive for the interval specified by
                 -- the provided start time and current modeling time

-- | Scale the modeling time to a real time.
rtScale :: RTScaling
           -- ^ the scaling method
           -> Double
           -- ^ the start modeling time
           -> Double
           -- ^ the current modeling time
           -> Double
           -- ^ the real time interval
rtScale :: RTScaling -> Double -> Double -> Double
rtScale (RTLinearScaling Double
k) Double
t0 Double
t = Double
k Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
t Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
t0)
rtScale (RTLogScaling Double
k) Double
t0 Double
t = Double
k Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
forall a. Floating a => a -> a
log (Double
t Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
t0)
rtScale (RTScalingFunction Double -> Double -> Double
f) Double
t0 Double
t = Double -> Double -> Double
f Double
t0 Double
t

-- | The parameters for the 'RT' computation.
data RTParams =
  RTParams { RTParams -> RTScaling
rtScaling :: RTScaling,
             -- ^ The scaling of the modeling time to a real time.
             RTParams -> Double
rtIntervalDelta :: Double
             -- ^ The real time interval accuracy in seconds.
           }

-- | The soft real-time computation based on 'IO'-derived computation @m@.
newtype RT m a = RT { RT m a -> RTContext m -> m a
unRT :: RTContext m -> m a
                      -- ^ Unwrap the computation.
                    }

-- | The context of the 'RT' computation.
data RTContext m =
  RTContext { RTContext m -> Channel (Event (RT m) ())
rtChannel0 :: Channel (Event (RT m) ()),
              -- ^ The channel of pending actions.
              RTContext m -> RTParams
rtParams0 :: RTParams
              -- ^ The parameters of the computation.
            }

instance Monad m => Monad (RT m) where

  {-# INLINE return #-}
  return :: a -> RT m a
return = (RTContext m -> m a) -> RT m a
forall (m :: * -> *) a. (RTContext m -> m a) -> RT m a
RT ((RTContext m -> m a) -> RT m a)
-> (a -> RTContext m -> m a) -> a -> RT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> RTContext m -> m a
forall a b. a -> b -> a
const (m a -> RTContext m -> m a)
-> (a -> m a) -> a -> RTContext m -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return

  {-# INLINE (>>=) #-}
  (RT RTContext m -> m a
m) >>= :: RT m a -> (a -> RT m b) -> RT m b
>>= a -> RT m b
k = (RTContext m -> m b) -> RT m b
forall (m :: * -> *) a. (RTContext m -> m a) -> RT m a
RT ((RTContext m -> m b) -> RT m b) -> (RTContext m -> m b) -> RT m b
forall a b. (a -> b) -> a -> b
$ \RTContext m
ctx ->
    RTContext m -> m a
m RTContext m
ctx m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a ->
    let m' :: RTContext m -> m b
m' = RT m b -> RTContext m -> m b
forall (m :: * -> *) a. RT m a -> RTContext m -> m a
unRT (a -> RT m b
k a
a) in RTContext m -> m b
m' RTContext m
ctx

instance Applicative m => Applicative (RT m) where

  {-# INLINE pure #-}
  pure :: a -> RT m a
pure = (RTContext m -> m a) -> RT m a
forall (m :: * -> *) a. (RTContext m -> m a) -> RT m a
RT ((RTContext m -> m a) -> RT m a)
-> (a -> RTContext m -> m a) -> a -> RT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> RTContext m -> m a
forall a b. a -> b -> a
const (m a -> RTContext m -> m a)
-> (a -> m a) -> a -> RTContext m -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

  {-# INLINE (<*>) #-}
  (RT RTContext m -> m (a -> b)
f) <*> :: RT m (a -> b) -> RT m a -> RT m b
<*> (RT RTContext m -> m a
m) = (RTContext m -> m b) -> RT m b
forall (m :: * -> *) a. (RTContext m -> m a) -> RT m a
RT ((RTContext m -> m b) -> RT m b) -> (RTContext m -> m b) -> RT m b
forall a b. (a -> b) -> a -> b
$ \RTContext m
ctx -> RTContext m -> m (a -> b)
f RTContext m
ctx m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RTContext m -> m a
m RTContext m
ctx  

instance Functor m => Functor (RT m) where

  {-# INLINE fmap #-}
  fmap :: (a -> b) -> RT m a -> RT m b
fmap a -> b
f (RT RTContext m -> m a
m) = (RTContext m -> m b) -> RT m b
forall (m :: * -> *) a. (RTContext m -> m a) -> RT m a
RT ((RTContext m -> m b) -> RT m b) -> (RTContext m -> m b) -> RT m b
forall a b. (a -> b) -> a -> b
$ (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (m a -> m b) -> (RTContext m -> m a) -> RTContext m -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RTContext m -> m a
m 

instance MonadIO m => MonadIO (RT m) where

  {-# INLINE liftIO #-}
  liftIO :: IO a -> RT m a
liftIO = (RTContext m -> m a) -> RT m a
forall (m :: * -> *) a. (RTContext m -> m a) -> RT m a
RT ((RTContext m -> m a) -> RT m a)
-> (IO a -> RTContext m -> m a) -> IO a -> RT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> RTContext m -> m a
forall a b. a -> b -> a
const (m a -> RTContext m -> m a)
-> (IO a -> m a) -> IO a -> RTContext m -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
  
instance MonadException m => MonadException (RT m) where

  {-# INLINE catchComp #-}
  catchComp :: RT m a -> (e -> RT m a) -> RT m a
catchComp (RT RTContext m -> m a
m) e -> RT m a
h = (RTContext m -> m a) -> RT m a
forall (m :: * -> *) a. (RTContext m -> m a) -> RT m a
RT ((RTContext m -> m a) -> RT m a) -> (RTContext m -> m a) -> RT m a
forall a b. (a -> b) -> a -> b
$ \RTContext m
ctx ->
    m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
m a -> (e -> m a) -> m a
catchComp (RTContext m -> m a
m RTContext m
ctx) (\e
e -> RT m a -> RTContext m -> m a
forall (m :: * -> *) a. RT m a -> RTContext m -> m a
unRT (e -> RT m a
h e
e) RTContext m
ctx)

  {-# INLINE finallyComp #-}
  finallyComp :: RT m a -> RT m b -> RT m a
finallyComp (RT RTContext m -> m a
m1) (RT RTContext m -> m b
m2) = (RTContext m -> m a) -> RT m a
forall (m :: * -> *) a. (RTContext m -> m a) -> RT m a
RT ((RTContext m -> m a) -> RT m a) -> (RTContext m -> m a) -> RT m a
forall a b. (a -> b) -> a -> b
$ \RTContext m
ctx ->
    m a -> m b -> m a
forall (m :: * -> *) a b. MonadException m => m a -> m b -> m a
finallyComp (RTContext m -> m a
m1 RTContext m
ctx) (RTContext m -> m b
m2 RTContext m
ctx)

  {-# INLINE throwComp #-}
  throwComp :: e -> RT m a
throwComp e
e = (RTContext m -> m a) -> RT m a
forall (m :: * -> *) a. (RTContext m -> m a) -> RT m a
RT ((RTContext m -> m a) -> RT m a) -> (RTContext m -> m a) -> RT m a
forall a b. (a -> b) -> a -> b
$ \RTContext m
ctx ->
    e -> m a
forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
e -> m a
throwComp e
e

-- | Invoke the 'RT' computation.
invokeRT :: RTContext m -> RT m a -> m a
{-# INLINE invokeRT #-}
invokeRT :: RTContext m -> RT m a -> m a
invokeRT RTContext m
ctx (RT RTContext m -> m a
m) = RTContext m -> m a
m RTContext m
ctx

-- | The default parameters for the 'RT' computation,
-- where one unit of modeling time matches one real second
-- and the real time interval is specified with precision of
-- one millisecond.
defaultRTParams :: RTParams
defaultRTParams :: RTParams
defaultRTParams =
  RTParams :: RTScaling -> Double -> RTParams
RTParams { rtScaling :: RTScaling
rtScaling = Double -> RTScaling
RTLinearScaling Double
1,
             rtIntervalDelta :: Double
rtIntervalDelta = Double
0.001
           }

-- | Return the parameters of the current computation.
rtParams :: Monad m => RT m RTParams
{-# INLINE rtParams #-}
rtParams :: RT m RTParams
rtParams = (RTContext m -> m RTParams) -> RT m RTParams
forall (m :: * -> *) a. (RTContext m -> m a) -> RT m a
RT ((RTContext m -> m RTParams) -> RT m RTParams)
-> (RTContext m -> m RTParams) -> RT m RTParams
forall a b. (a -> b) -> a -> b
$ RTParams -> m RTParams
forall (m :: * -> *) a. Monad m => a -> m a
return (RTParams -> m RTParams)
-> (RTContext m -> RTParams) -> RTContext m -> m RTParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RTContext m -> RTParams
forall (m :: * -> *). RTContext m -> RTParams
rtParams0

-- | Return the chanel of pending actions.
rtChannel :: Monad m => RT m (Channel (Event (RT m) ()))
{-# INLINE rtChannel #-}
rtChannel :: RT m (Channel (Event (RT m) ()))
rtChannel = (RTContext m -> m (Channel (Event (RT m) ())))
-> RT m (Channel (Event (RT m) ()))
forall (m :: * -> *) a. (RTContext m -> m a) -> RT m a
RT ((RTContext m -> m (Channel (Event (RT m) ())))
 -> RT m (Channel (Event (RT m) ())))
-> (RTContext m -> m (Channel (Event (RT m) ())))
-> RT m (Channel (Event (RT m) ()))
forall a b. (a -> b) -> a -> b
$ Channel (Event (RT m) ()) -> m (Channel (Event (RT m) ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Channel (Event (RT m) ()) -> m (Channel (Event (RT m) ())))
-> (RTContext m -> Channel (Event (RT m) ()))
-> RTContext m
-> m (Channel (Event (RT m) ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RTContext m -> Channel (Event (RT m) ())
forall (m :: * -> *). RTContext m -> Channel (Event (RT m) ())
rtChannel0

-- | Run the computation using the specified context.
runRT :: RT m a -> RTContext m -> m a
runRT :: RT m a -> RTContext m -> m a
runRT = RT m a -> RTContext m -> m a
forall (m :: * -> *) a. RT m a -> RTContext m -> m a
unRT

-- | Create a new real-time computation context.
newRTContext :: RTParams -> IO (RTContext m)
newRTContext :: RTParams -> IO (RTContext m)
newRTContext RTParams
ps =
  do Channel (Event (RT m) ())
channel <- IO (Channel (Event (RT m) ()))
forall a. IO (Channel a)
newChannel
     RTContext m -> IO (RTContext m)
forall (m :: * -> *) a. Monad m => a -> m a
return RTContext :: forall (m :: * -> *).
Channel (Event (RT m) ()) -> RTParams -> RTContext m
RTContext { rtChannel0 :: Channel (Event (RT m) ())
rtChannel0 = Channel (Event (RT m) ())
channel,
                        rtParams0 :: RTParams
rtParams0 = RTParams
ps }