{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE InstanceSigs           #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE NamedFieldPuns         #-}
{-# LANGUAGE QuantifiedConstraints  #-}
{-# LANGUAGE RecordWildCards        #-}
{-# LANGUAGE ScopedTypeVariables    #-}

module Q.MonteCarlo where
import           Control.Monad.State
import           Data.RVar
import           Q.Stochastic.Discretize
import           Q.Stochastic.Process
import           Control.Monad
import           Q.ContingentClaim
import Data.Random
import Q.Time
import Data.Time
import Statistics.Distribution (cumulative)
import Statistics.Distribution.Normal (standard)
import Q.ContingentClaim.Options
import Q.Types

type Path b = [(Time, b)]

-- |Summary type class aggregates all priced values of paths
class (PathPricer p)  => Summary m p | m->p where
  -- | Updates summary with given priced pathes
  sSummarize      :: m -> [p] -> m

  -- | Defines a metric, i.e. calculate distance between 2 summaries
  sNorm           :: m -> m -> Double

-- | Path generator is a stochastic path generator
class PathGenerator m where
  pgMkNew         :: m->IO m
  pgGenerate      :: Integer -> m -> Path b

-- | Path pricer provides a price for given path
class PathPricer m where
  ppPrice :: m -> Path b -> m


type MonteCarlo s a = StateT [(Time, s)] RVar a


-- | Generate a single trajectory stopping at each provided time.
trajectory :: forall a b d. (StochasticProcess a b, Discretize d b) =>
             d        -- ^ Discretization scheme
           -> a        -- ^ The stochastic process
           -> b        -- ^ \(S(0)\)
           -> [Time]   -- ^ Stopping points \(\{t_i\}_i^n \) where \(t_i > 0\)
           -> [RVar b] -- ^ \(dW\)s. One for each stopping point.
           -> RVar [b] -- ^ \(S(0) \cup \{S(t_i)\}_i^n \) 
trajectory :: d -> a -> b -> [Time] -> [RVar b] -> RVar [b]
trajectory d
disc a
p b
s0 [Time]
times [RVar b]
dws = [b] -> [b]
forall a. [a] -> [a]
reverse ([b] -> [b]) -> RVar [b] -> RVar [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT [(Time, b)] RVar [b] -> [(Time, b)] -> RVar [b]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT ([Time] -> [RVar b] -> StateT [(Time, b)] RVar [b]
onePath [Time]
times [RVar b]
dws) [(Time, b)]
initState' where
  initState' :: [(Time, b)]
  initState' :: [(Time, b)]
initState' = [(Time
0, b
s0)]

  onePath :: [Time] -> [RVar b] -> MonteCarlo b [b]
  onePath :: [Time] -> [RVar b] -> StateT [(Time, b)] RVar [b]
onePath [] [RVar b]
_ = do
    [(Time, b)]
s <- StateT [(Time, b)] RVar [(Time, b)]
forall s (m :: * -> *). MonadState s m => m s
get
    [b] -> StateT [(Time, b)] RVar [b]
forall (m :: * -> *) a. Monad m => a -> m a
return ([b] -> StateT [(Time, b)] RVar [b])
-> [b] -> StateT [(Time, b)] RVar [b]
forall a b. (a -> b) -> a -> b
$ ((Time, b) -> b) -> [(Time, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (Time, b) -> b
forall a b. (a, b) -> b
snd [(Time, b)]
s
  onePath (Time
t1:[Time]
tn) (RVar b
dw1:[RVar b]
dws) = do
    [(Time, b)]
s <- StateT [(Time, b)] RVar [(Time, b)]
forall s (m :: * -> *). MonadState s m => m s
get
    let t0 :: (Time, b)
t0 = [(Time, b)] -> (Time, b)
forall a. [a] -> a
head [(Time, b)]
s
    b
b <- RVar b -> StateT [(Time, b)] RVar b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (RVar b -> StateT [(Time, b)] RVar b)
-> RVar b -> StateT [(Time, b)] RVar b
forall a b. (a -> b) -> a -> b
$ a -> d -> (Time, b) -> Time -> RVar b -> RVar b
forall a b d.
(StochasticProcess a b, Discretize d b) =>
a -> d -> (Time, b) -> Time -> RVar b -> RVar b
pEvolve a
p d
disc (Time, b)
t0 Time
t1 RVar b
dw1
    [(Time, b)] -> StateT [(Time, b)] RVar ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ([(Time, b)] -> StateT [(Time, b)] RVar ())
-> [(Time, b)] -> StateT [(Time, b)] RVar ()
forall a b. (a -> b) -> a -> b
$ (Time
t1, b
b) (Time, b) -> [(Time, b)] -> [(Time, b)]
forall a. a -> [a] -> [a]
: [(Time, b)]
s
    [Time] -> [RVar b] -> StateT [(Time, b)] RVar [b]
onePath [Time]
tn [RVar b]
dws

-- | Generate multiple trajectories. See 'trajectory'
trajectories:: forall a b d. (StochasticProcess a b, Discretize d b) =>
             Int        -- ^Num of trajectories
           -> d          -- ^Discretization scheme
           -> a          -- ^The stochastic process
           -> b          -- ^\(S(0)\)
           -> [Time]     -- ^Stopping points \(\{t_i\}_i^n \) where \(t_i > 0\)
           -> [RVar b]   -- ^\(dW\)s. One for each stopping point.
           -> RVar [[b]] -- ^\(S(0) \cup \{S(t_i)\}_i^n \) 
trajectories :: Int -> d -> a -> b -> [Time] -> [RVar b] -> RVar [[b]]
trajectories Int
n d
disc a
p b
initState [Time]
times [RVar b]
dws = Int -> RVarT Identity [b] -> RVar [[b]]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (RVarT Identity [b] -> RVar [[b]])
-> RVarT Identity [b] -> RVar [[b]]
forall a b. (a -> b) -> a -> b
$ d -> a -> b -> [Time] -> [RVar b] -> RVarT Identity [b]
forall a b d.
(StochasticProcess a b, Discretize d b) =>
d -> a -> b -> [Time] -> [RVar b] -> RVar [b]
trajectory d
disc a
p b
initState [Time]
times [RVar b]
dws

observationTimes :: ContingentClaim a -> [Day]
observationTimes :: ContingentClaim a -> [Day]
observationTimes = ContingentClaim a -> [Day]
forall a. HasCallStack => a
undefined

class Model a b | a -> b where
  discountFactor :: a -> YearFrac -> YearFrac -> RVar Rate
  evolve   :: a -> YearFrac -> StateT (YearFrac, b) RVar Double