diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,9 @@ +Version 0.6 +----- + +* Added the newRandomLatticeWithProb function. + Version 0.5 ----- diff --git a/Simulation/Aivika/Lattice/Estimate.hs b/Simulation/Aivika/Lattice/Estimate.hs --- a/Simulation/Aivika/Lattice/Estimate.hs +++ b/Simulation/Aivika/Lattice/Estimate.hs @@ -151,7 +151,7 @@ estimateAt :: Int -- ^ the lattice time index -> Int - -- ^ the lattice size index + -- ^ the lattice member index -> Estimate LIO a -- ^ the computation -> Estimate LIO a diff --git a/Simulation/Aivika/Lattice/Internal/LIO.hs b/Simulation/Aivika/Lattice/Internal/LIO.hs --- a/Simulation/Aivika/Lattice/Internal/LIO.hs +++ b/Simulation/Aivika/Lattice/Internal/LIO.hs @@ -17,6 +17,7 @@ LIOLattice(..), lattice, newRandomLattice, + newRandomLatticeWithProb, invokeLIO, runLIO, lioParams, diff --git a/Simulation/Aivika/Lattice/Internal/Lattice.hs b/Simulation/Aivika/Lattice/Internal/Lattice.hs --- a/Simulation/Aivika/Lattice/Internal/Lattice.hs +++ b/Simulation/Aivika/Lattice/Internal/Lattice.hs @@ -12,7 +12,8 @@ module Simulation.Aivika.Lattice.Internal.Lattice (LIOLattice(..), lattice, - newRandomLattice) where + newRandomLattice, + newRandomLatticeWithProb) where import Control.Monad import Control.Monad.Trans @@ -30,9 +31,11 @@ -- ^ Tha lattice size. } --- | Create a new random lattice by the specified size. -newRandomLattice :: Int -> IO LIOLattice -newRandomLattice m = +-- | Create a new random lattice by the specified probability and size, +-- where the probabilty defines whether the interior child node derives +-- from the right parent. +newRandomLatticeWithProb :: Double -> Int -> IO LIOLattice +newRandomLatticeWithProb p m = do g <- MWC.withSystemRandom (return :: MWC.GenIO -> IO MWC.GenIO) xss0 <- forM [0 .. m] $ \i -> do xs0 <- forM [0 .. i] $ \k -> @@ -41,7 +44,7 @@ else if k == i then return (k - 1) else do x <- MWC.uniform g :: IO Double - if x <= 0.5 + if x > p then return (k - 1) else return k return $ listArray (0, i) xs0 @@ -49,6 +52,11 @@ return LIOLattice { lioParentMemberIndex = \i k -> (xss ! i) ! k, lioSize = m } + +-- | Create a new random lattice by the specified size with equal probabilities, +-- whether the interior child node derives from the left or right parents. +newRandomLattice :: Int -> IO LIOLattice +newRandomLattice = newRandomLatticeWithProb 0.5 -- | Return a lattice by the specifed size and the parent member function. lattice :: Int diff --git a/Simulation/Aivika/Lattice/LIO.hs b/Simulation/Aivika/Lattice/LIO.hs --- a/Simulation/Aivika/Lattice/LIO.hs +++ b/Simulation/Aivika/Lattice/LIO.hs @@ -14,6 +14,7 @@ LIOLattice, lattice, newRandomLattice, + newRandomLatticeWithProb, runLIO, latticeTimeIndex, latticeMemberIndex, diff --git a/aivika-lattice.cabal b/aivika-lattice.cabal --- a/aivika-lattice.cabal +++ b/aivika-lattice.cabal @@ -1,5 +1,5 @@ name: aivika-lattice -version: 0.5 +version: 0.6 synopsis: Nested discrete event simulation module for the Aivika library using lattice description: This experimental package extends the aivika-transformers [1] library and allows @@ -20,6 +20,7 @@ tested-with: GHC == 7.10.3 extra-source-files: CHANGELOG.md + examples/BinomialPricingModel.hs tests/Distribution.hs tests/MachRep1.hs tests/TraversingLattice1.hs @@ -55,8 +56,8 @@ containers >= 0.4.0.0, random >= 1.0.0.3, mwc-random >= 0.13.0.0, - aivika >= 5.2, - aivika-transformers >= 5.2 + aivika >= 5.4, + aivika-transformers >= 5.4 extensions: TypeFamilies, MultiParamTypeClasses, diff --git a/examples/BinomialPricingModel.hs b/examples/BinomialPricingModel.hs new file mode 100644 --- /dev/null +++ b/examples/BinomialPricingModel.hs @@ -0,0 +1,90 @@ + +{- + A binomial option pricing model + + Assume a put option with strike price $110 currently trading at $100 and + expiring in one year. Annual risk free rate is at 5%. Price is expected + to increase 20% and decrease 15% every six months. It is necessary to estimate + the price of the put option. + -} + +import Control.Monad +import Control.Monad.Trans + +import Simulation.Aivika.Trans +import Simulation.Aivika.Lattice +import Simulation.Aivika.Experiment.Histogram + +-- the lattice size +n = 50 + +-- the up and down factors +u0 = 1.2 +d0 = 0.85 + +-- corrected factors for the lattice size +u = exp (log u0 / (fromIntegral n / 2)) +d = exp (log d0 / (fromIntegral n / 2)) + +-- initial stock price +s0 = 100.0 + +-- strike price for put option +strikePrice = 110.0 + +-- risk free rate +r = 0.05 + +specs = Specs { spcStartTime = 0.0, + spcStopTime = 1.0, + spcDT = 0.1, + spcMethod = RungeKutta4, + spcGeneratorType = SimpleGenerator } + +model :: Simulation LIO Double +model = + do -- stock price + s <- newRef s0 + + -- calculate the stock price tree + runEventInStartTime $ + enqueueEventWithLatticeTimes $ + do k <- liftComp latticeMemberIndex + k0 <- liftComp latticeParentMemberIndex + case k0 of + Nothing -> return () + Just k0 | k == k0 -> + modifyRef s (\x -> x * u) + Just k0 | k == k0 + 1 -> + modifyRef s (\x -> x * d) + + -- the lattice time step + dt <- liftParameter latticeTimeStep + + -- calculate the up move probability + let p = (exp (- r * dt) - d) / (u - d) + + -- estimate the option price in the end time + let leaf :: Estimate LIO Double + leaf = + do x <- readObservable s + -- this is a put option + return $ max (strikePrice - x) 0 + + -- estimate the option price by the forecast + let reduce :: Double -> Double -> Estimate LIO Double + reduce x1 x2 = + return $ + exp (- r * dt) * (p * x1 + (1 - p) * x2) + + price <- foldEstimate reduce leaf + + runEstimateInStartTime price + +main :: IO () +main = + do lat <- newRandomLattice n + e <- runLIO lat $ + runSimulation model specs + putStrLn "Estimation:" + putStrLn (show e)