{-# LANGUAGE RecursiveDo, MultiParamTypeClasses, FlexibleInstances #-}

-- |
-- Module     : Simulation.Aivika.Lattice.Internal.Estimate
-- 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
--
-- The module defines the 'Estimate' monad transformer which is destined for estimating
-- computations within lattice nodes. Such computations are separated from the 'Event'
-- computations. An idea is that the forward-traversing 'Event' computations provide with
-- something that can be observed, while the backward-traversing 'Estimate' computations
-- estimate the received information.
--
module Simulation.Aivika.Lattice.Internal.Estimate
       (-- * Estimate Monad
        Estimate(..),
        EstimateLift(..),
        invokeEstimate,
        runEstimateInStartTime,
        estimateTime,
        -- * Error Handling
        catchEstimate,
        finallyEstimate,
        throwEstimate,
        -- * Debugging
        traceEstimate) where

import Control.Exception
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Fix
import Control.Applicative

import Debug.Trace (trace)

import Simulation.Aivika.Trans.Exception
import Simulation.Aivika.Trans.Comp
import Simulation.Aivika.Trans.DES
import Simulation.Aivika.Trans.Internal.Types
import Simulation.Aivika.Trans.Parameter
import Simulation.Aivika.Trans.Dynamics
import Simulation.Aivika.Trans.Event
import Simulation.Aivika.Lattice.Internal.LIO

-- | A value in the 'Estimate' monad transformer represents something
-- that can be estimated within lattice nodes.
newtype Estimate m a = Estimate (Point m -> m a)

-- | Invoke the 'Estimate' computation.
invokeEstimate :: Point m -> Estimate m a -> m a
{-# INLINE invokeEstimate #-}
invokeEstimate :: forall (m :: * -> *) a. Point m -> Estimate m a -> m a
invokeEstimate Point m
p (Estimate Point m -> m a
m) = Point m -> m a
m Point m
p

instance Monad m => Monad (Estimate m) where

  {-# INLINE (>>=) #-}
  (Estimate Point m -> m a
m) >>= :: forall a b. Estimate m a -> (a -> Estimate m b) -> Estimate m b
>>= a -> Estimate m b
k =
    forall (m :: * -> *) a. (Point m -> m a) -> Estimate m a
Estimate forall a b. (a -> b) -> a -> b
$ \Point m
p -> 
    do a
a <- Point m -> m a
m Point m
p
       let Estimate Point m -> m b
m' = a -> Estimate m b
k a
a
       Point m -> m b
m' Point m
p

instance Functor m => Functor (Estimate m) where
  
  {-# INLINE fmap #-}
  fmap :: forall a b. (a -> b) -> Estimate m a -> Estimate m b
fmap a -> b
f (Estimate Point m -> m a
x) = forall (m :: * -> *) a. (Point m -> m a) -> Estimate m a
Estimate forall a b. (a -> b) -> a -> b
$ \Point m
p -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f forall a b. (a -> b) -> a -> b
$ Point m -> m a
x Point m
p

instance Applicative m => Applicative (Estimate m) where
  
  {-# INLINE pure #-}
  pure :: forall a. a -> Estimate m a
pure = forall (m :: * -> *) a. (Point m -> m a) -> Estimate m a
Estimate forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
  
  {-# INLINE (<*>) #-}
  (Estimate Point m -> m (a -> b)
x) <*> :: forall a b. Estimate m (a -> b) -> Estimate m a -> Estimate m b
<*> (Estimate Point m -> m a
y) = forall (m :: * -> *) a. (Point m -> m a) -> Estimate m a
Estimate forall a b. (a -> b) -> a -> b
$ \Point m
p -> Point m -> m (a -> b)
x Point m
p forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Point m -> m a
y Point m
p

instance MonadTrans Estimate where

  {-# INLINE lift #-}
  lift :: forall (m :: * -> *) a. Monad m => m a -> Estimate m a
lift = forall (m :: * -> *) a. (Point m -> m a) -> Estimate m a
Estimate forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const

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

instance MonadFix m => MonadFix (Estimate m) where

  {-# INLINE mfix #-}
  mfix :: forall a. (a -> Estimate m a) -> Estimate m a
mfix a -> Estimate m a
f = 
    forall (m :: * -> *) a. (Point m -> m a) -> Estimate m a
Estimate forall a b. (a -> b) -> a -> b
$ \Point m
p ->
    do { rec { a
a <- forall (m :: * -> *) a. Point m -> Estimate m a -> m a
invokeEstimate Point m
p (a -> Estimate m a
f a
a) }; forall (m :: * -> *) a. Monad m => a -> m a
return a
a }

instance Monad m => MonadCompTrans Estimate m where

  {-# INLINE liftComp #-}
  liftComp :: forall a. m a -> Estimate m a
liftComp = forall (m :: * -> *) a. (Point m -> m a) -> Estimate m a
Estimate forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const

-- | A type class to lift the 'Estimate' computations into other computations.
class EstimateLift t m where
  
  -- | Lift the specified 'Estimate' computation into another computation.
  liftEstimate :: Estimate m a -> t m a

instance Monad m => EstimateLift Estimate m where
  
  {-# INLINE liftEstimate #-}
  liftEstimate :: forall a. Estimate m a -> Estimate m a
liftEstimate = forall a. a -> a
id

instance Monad m => ParameterLift Estimate m where

  {-# INLINE liftParameter #-}
  liftParameter :: forall a. Parameter m a -> Estimate m a
liftParameter (Parameter Run m -> m a
x) = forall (m :: * -> *) a. (Point m -> m a) -> Estimate m a
Estimate forall a b. (a -> b) -> a -> b
$ Run m -> m a
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Point m -> Run m
pointRun

-- | Exception handling within 'Estimate' computations.
catchEstimate :: (MonadException m, Exception e) => Estimate m a -> (e -> Estimate m a) -> Estimate m a
{-# INLINABLE catchEstimate #-}
catchEstimate :: forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
Estimate m a -> (e -> Estimate m a) -> Estimate m a
catchEstimate (Estimate Point m -> m a
m) e -> Estimate m a
h =
  forall (m :: * -> *) a. (Point m -> m a) -> Estimate m a
Estimate forall a b. (a -> b) -> a -> b
$ \Point m
p -> 
  forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
m a -> (e -> m a) -> m a
catchComp (Point m -> m a
m Point m
p) forall a b. (a -> b) -> a -> b
$ \e
e ->
  let Estimate Point m -> m a
m' = e -> Estimate m a
h e
e in Point m -> m a
m' Point m
p
                           
-- | A computation with finalization part like the 'finally' function.
finallyEstimate :: MonadException m => Estimate m a -> Estimate m b -> Estimate m a
{-# INLINABLE finallyEstimate #-}
finallyEstimate :: forall (m :: * -> *) a b.
MonadException m =>
Estimate m a -> Estimate m b -> Estimate m a
finallyEstimate (Estimate Point m -> m a
m) (Estimate Point m -> m b
m') =
  forall (m :: * -> *) a. (Point m -> m a) -> Estimate m a
Estimate forall a b. (a -> b) -> a -> b
$ \Point m
p ->
  forall (m :: * -> *) a b. MonadException m => m a -> m b -> m a
finallyComp (Point m -> m a
m Point m
p) (Point m -> m b
m' Point m
p)

-- | Like the standard 'throw' function.
throwEstimate :: (MonadException m, Exception e) => e -> Estimate m a
{-# INLINABLE throwEstimate #-}
throwEstimate :: forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
e -> Estimate m a
throwEstimate e
e =
  forall (m :: * -> *) a. (Point m -> m a) -> Estimate m a
Estimate forall a b. (a -> b) -> a -> b
$ \Point m
p ->
  forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
e -> m a
throwComp e
e

-- | Run the 'Estimate' computation in the start time and return the estimate.
runEstimateInStartTime :: MonadDES m => Estimate m a -> Simulation m a
{-# INLINE runEstimateInStartTime #-}
runEstimateInStartTime :: forall (m :: * -> *) a.
MonadDES m =>
Estimate m a -> Simulation m a
runEstimateInStartTime (Estimate Point m -> m a
m) = forall (m :: * -> *) a. MonadDES m => Event m a -> Simulation m a
runEventInStartTime (forall (m :: * -> *) a. (Point m -> m a) -> Event m a
Event Point m -> m a
m)

-- | Like 'time' estimates the current modeling time.
-- It is more effcient than 'latticeTime'.
estimateTime :: MonadDES m => Estimate m Double
{-# INLINE estimateTime #-}
estimateTime :: forall (m :: * -> *). MonadDES m => Estimate m Double
estimateTime = forall (m :: * -> *) a. (Point m -> m a) -> Estimate m a
Estimate forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Point m -> Double
pointTime

-- | Show the debug message with the current simulation time and lattice node indices.
traceEstimate :: String -> Estimate LIO a -> Estimate LIO a
{-# INLINABLE traceEstimate #-}
traceEstimate :: forall a. String -> Estimate LIO a -> Estimate LIO a
traceEstimate String
message Estimate LIO a
m =
  forall (m :: * -> *) a. (Point m -> m a) -> Estimate m a
Estimate forall a b. (a -> b) -> a -> b
$ \Point LIO
p ->
  forall a. (LIOParams -> IO a) -> LIO a
LIO forall a b. (a -> b) -> a -> b
$ \LIOParams
ps ->
  forall a. String -> a -> a
trace (String
"t = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (m :: * -> *). Point m -> Double
pointTime Point LIO
p) forall a. [a] -> [a] -> [a]
++
         String
", lattice time index = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (LIOParams -> Int
lioTimeIndex LIOParams
ps) forall a. [a] -> [a] -> [a]
++
         String
", lattice member index = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (LIOParams -> Int
lioMemberIndex LIOParams
ps) forall a. [a] -> [a] -> [a]
++
         String
": " forall a. [a] -> [a] -> [a]
++ String
message) forall a b. (a -> b) -> a -> b
$
  forall a. LIOParams -> LIO a -> IO a
invokeLIO LIOParams
ps forall a b. (a -> b) -> a -> b
$
  forall (m :: * -> *) a. Point m -> Estimate m a -> m a
invokeEstimate Point LIO
p Estimate LIO a
m