{-# 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 :: 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 return #-}
  return :: a -> Estimate m a
return a
a = (Point m -> m a) -> Estimate m a
forall (m :: * -> *) a. (Point m -> m a) -> Estimate m a
Estimate ((Point m -> m a) -> Estimate m a)
-> (Point m -> m a) -> Estimate m a
forall a b. (a -> b) -> a -> b
$ \Point m
p -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

  {-# INLINE (>>=) #-}
  (Estimate Point m -> m a
m) >>= :: Estimate m a -> (a -> Estimate m b) -> Estimate m b
>>= a -> Estimate m b
k =
    (Point m -> m b) -> Estimate m b
forall (m :: * -> *) a. (Point m -> m a) -> Estimate m a
Estimate ((Point m -> m b) -> Estimate m b)
-> (Point m -> m b) -> Estimate m b
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 :: (a -> b) -> Estimate m a -> Estimate m b
fmap a -> b
f (Estimate Point m -> m a
x) = (Point m -> m b) -> Estimate m b
forall (m :: * -> *) a. (Point m -> m a) -> Estimate m a
Estimate ((Point m -> m b) -> Estimate m b)
-> (Point m -> m b) -> Estimate m b
forall a b. (a -> b) -> a -> b
$ \Point m
p -> (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) -> m a -> m b
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 :: a -> Estimate m a
pure = (Point m -> m a) -> Estimate m a
forall (m :: * -> *) a. (Point m -> m a) -> Estimate m a
Estimate ((Point m -> m a) -> Estimate m a)
-> (a -> Point m -> m a) -> a -> Estimate m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> Point m -> m a
forall a b. a -> b -> a
const (m a -> Point m -> m a) -> (a -> m a) -> a -> Point 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 (<*>) #-}
  (Estimate Point m -> m (a -> b)
x) <*> :: Estimate m (a -> b) -> Estimate m a -> Estimate m b
<*> (Estimate Point m -> m a
y) = (Point m -> m b) -> Estimate m b
forall (m :: * -> *) a. (Point m -> m a) -> Estimate m a
Estimate ((Point m -> m b) -> Estimate m b)
-> (Point m -> m b) -> Estimate m b
forall a b. (a -> b) -> a -> b
$ \Point m
p -> Point m -> m (a -> b)
x Point m
p m (a -> b) -> m a -> m b
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 :: m a -> Estimate m a
lift = (Point m -> m a) -> Estimate m a
forall (m :: * -> *) a. (Point m -> m a) -> Estimate m a
Estimate ((Point m -> m a) -> Estimate m a)
-> (m a -> Point m -> m a) -> m a -> Estimate m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> Point m -> m a
forall a b. a -> b -> a
const

instance MonadIO m => MonadIO (Estimate m) where
  
  {-# INLINE liftIO #-}
  liftIO :: IO a -> Estimate m a
liftIO = (Point m -> m a) -> Estimate m a
forall (m :: * -> *) a. (Point m -> m a) -> Estimate m a
Estimate ((Point m -> m a) -> Estimate m a)
-> (IO a -> Point m -> m a) -> IO a -> Estimate m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> Point m -> m a
forall a b. a -> b -> a
const (m a -> Point m -> m a) -> (IO a -> m a) -> IO a -> Point 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 MonadFix m => MonadFix (Estimate m) where

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

instance Monad m => MonadCompTrans Estimate m where

  {-# INLINE liftComp #-}
  liftComp :: m a -> Estimate m a
liftComp = (Point m -> m a) -> Estimate m a
forall (m :: * -> *) a. (Point m -> m a) -> Estimate m a
Estimate ((Point m -> m a) -> Estimate m a)
-> (m a -> Point m -> m a) -> m a -> Estimate m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> Point m -> m a
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 :: Estimate m a -> Estimate m a
liftEstimate = Estimate m a -> Estimate m a
forall a. a -> a
id

instance Monad m => ParameterLift Estimate m where

  {-# INLINE liftParameter #-}
  liftParameter :: Parameter m a -> Estimate m a
liftParameter (Parameter Run m -> m a
x) = (Point m -> m a) -> Estimate m a
forall (m :: * -> *) a. (Point m -> m a) -> Estimate m a
Estimate ((Point m -> m a) -> Estimate m a)
-> (Point m -> m a) -> Estimate m a
forall a b. (a -> b) -> a -> b
$ Run m -> m a
x (Run m -> m a) -> (Point m -> Run m) -> Point m -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point m -> Run m
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 :: Estimate m a -> (e -> Estimate m a) -> Estimate m a
catchEstimate (Estimate Point m -> m a
m) e -> Estimate m a
h =
  (Point m -> m a) -> Estimate m a
forall (m :: * -> *) a. (Point m -> m a) -> Estimate m a
Estimate ((Point m -> m a) -> Estimate m a)
-> (Point m -> m a) -> Estimate m a
forall a b. (a -> b) -> a -> b
$ \Point m
p -> 
  m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
m a -> (e -> m a) -> m a
catchComp (Point m -> m a
m Point m
p) ((e -> m a) -> m a) -> (e -> m a) -> m a
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 :: Estimate m a -> Estimate m b -> Estimate m a
finallyEstimate (Estimate Point m -> m a
m) (Estimate Point m -> m b
m') =
  (Point m -> m a) -> Estimate m a
forall (m :: * -> *) a. (Point m -> m a) -> Estimate m a
Estimate ((Point m -> m a) -> Estimate m a)
-> (Point m -> m a) -> Estimate m a
forall a b. (a -> b) -> a -> b
$ \Point m
p ->
  m a -> m b -> m a
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 :: e -> Estimate m a
throwEstimate e
e =
  (Point m -> m a) -> Estimate m a
forall (m :: * -> *) a. (Point m -> m a) -> Estimate m a
Estimate ((Point m -> m a) -> Estimate m a)
-> (Point m -> m a) -> Estimate m a
forall a b. (a -> b) -> a -> b
$ \Point m
p ->
  e -> m a
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 :: Estimate m a -> Simulation m a
runEstimateInStartTime (Estimate Point m -> m a
m) = Event m a -> Simulation m a
forall (m :: * -> *) a. MonadDES m => Event m a -> Simulation m a
runEventInStartTime ((Point m -> m a) -> Event m a
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 :: Estimate m Double
estimateTime = (Point m -> m Double) -> Estimate m Double
forall (m :: * -> *) a. (Point m -> m a) -> Estimate m a
Estimate ((Point m -> m Double) -> Estimate m Double)
-> (Point m -> m Double) -> Estimate m Double
forall a b. (a -> b) -> a -> b
$ Double -> m Double
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> m Double) -> (Point m -> Double) -> Point m -> m Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point m -> Double
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 :: String -> Estimate LIO a -> Estimate LIO a
traceEstimate String
message Estimate LIO a
m =
  (Point LIO -> LIO a) -> Estimate LIO a
forall (m :: * -> *) a. (Point m -> m a) -> Estimate m a
Estimate ((Point LIO -> LIO a) -> Estimate LIO a)
-> (Point LIO -> LIO a) -> Estimate LIO a
forall a b. (a -> b) -> a -> b
$ \Point LIO
p ->
  (LIOParams -> IO a) -> LIO a
forall a. (LIOParams -> IO a) -> LIO a
LIO ((LIOParams -> IO a) -> LIO a) -> (LIOParams -> IO a) -> LIO a
forall a b. (a -> b) -> a -> b
$ \LIOParams
ps ->
  String -> IO a -> IO a
forall a. String -> a -> a
trace (String
"t = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Double -> String
forall a. Show a => a -> String
show (Point LIO -> Double
forall (m :: * -> *). Point m -> Double
pointTime Point LIO
p) String -> String -> String
forall a. [a] -> [a] -> [a]
++
         String
", lattice time index = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (LIOParams -> Int
lioTimeIndex LIOParams
ps) String -> String -> String
forall a. [a] -> [a] -> [a]
++
         String
", lattice member index = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (LIOParams -> Int
lioMemberIndex LIOParams
ps) String -> String -> String
forall a. [a] -> [a] -> [a]
++
         String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
message) (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$
  LIOParams -> LIO a -> IO a
forall a. LIOParams -> LIO a -> IO a
invokeLIO LIOParams
ps (LIO a -> IO a) -> LIO a -> IO a
forall a b. (a -> b) -> a -> b
$
  Point LIO -> Estimate LIO a -> LIO a
forall (m :: * -> *) a. Point m -> Estimate m a -> m a
invokeEstimate Point LIO
p Estimate LIO a
m