Pricing options with a binary tree approximation (CRR). Branches with very small differences in share price (beyond the precision of 64bit floats) are treated as equal and thus not recomputed.

BinTreeOptions.hs

import Text.Printf
import Control.Monad.State.Strict
import qualified Data.HashMap.Strict as HM
 
data OptType = Call | Put deriving (Show, Enum)
data Continent = Am | Eur deriving (Show, Enum)
 
optPrice optType continent s k sigma rf dt n divPayments = let
    u = exp (sigma * sqrt dt)
    d = 1 / u
    df = exp (-rf*dt)
    pu = (1 / df - d) / (u - d)
    pd = 1 - pu
     
    intrVal = max 0 . ([negate, id] !! fromEnum optType) . (-) k
    divf s t = maybe s ($s) (HM.lookup t divPayments)
     
    eurOpt (s, t) = go eurOpt (divf s t, t)
    amOpt (s, t) = do
        let s' = divf s t
        nxt <- go amOpt (s', t)
        return $ maximum [nxt, intrVal s, intrVal s']
     
    memoize k arg = gets (HM.lookup arg) >>=
        maybe (do res <- k arg
                  modify (HM.insert arg res)
                  return res)
              (return)
     
    go k (s, t) | t == n = return $ intrVal s
    go k (s, t) = do
    [down, up] <- mapM (memoize k) [(d*s, t + 1), (u*s, t + 1)]
    return $ (pd*down + pu*up) * df
     
    in evalState (([amOpt, eurOpt] !! fromEnum continent) (s, 0)) (HM.empty)
 
test :: [(Integer, (Double -> Double))] -> IO ()
test divs = sequence_ [printf "%s %s: %.3f\n" (show a) (show b) price |
    a <- [Am, Eur], b <- [Call, Put],
    let price = optPrice b a 150 200 0.2 0.09 0.5 100 (HM.fromList divs)]
 
main = do
    printf "---- Options ---- \n\n"
    printf "No dividend:\n"
    test []
    printf "\nVariable dividend:\n"
    test [(2, (*0.9)), (10, (*0.8))]
    printf "\nFix dividend:\n"
    test [(2, subtract 15)]