module Valuation where
import Prelude hiding (or, min, abs, negate, not, read, until)
import Contract hiding (and, max)
import Observable hiding(max)
import Numeric
import Data.Time
import Data.Monoid
import System.Process
import System.Exit
newtype PR a = PR { unPr :: [RV a] } deriving Show
type RV a = [a]
takePr :: Int -> PR a -> PR a
takePr n (PR rvs) = PR $ take n rvs
horizonPr :: PR a -> Int
horizonPr (PR rvs) = length rvs
andPr :: PR Bool -> Bool
andPr (PR rvs) = and (map and rvs)
liftPr :: (a -> b) -> PR a -> PR b
liftPr f (PR a) = PR $ map (map f) a
lift2Pr :: (a -> b -> c) -> PR a -> PR b -> PR c
lift2Pr f (PR a) (PR b) = PR $ zipWith (zipWith f) a b
lift2PrAll :: (a -> a -> a) -> PR a -> PR a -> PR a
lift2PrAll f (PR a) (PR b) = PR $ zipWithAll (zipWith f) a b
lift3Pr :: (a -> b -> c -> d) -> PR a -> PR b -> PR c -> PR d
lift3Pr f (PR a) (PR b) (PR c) = PR $ zipWith3 (zipWith3 f) a b c
zipWithAll :: (a -> a -> a) -> [a] -> [a] -> [a]
zipWithAll f (x:xs) (y:ys) = f x y : zipWithAll f xs ys
zipWithAll f xs@(_:_) [] = xs
zipWithAll f [] ys@(_:_) = ys
zipWithAll _ _ _ = []
instance Num a => Num (PR a) where
fromInteger i = bigK (fromInteger i)
(+) = lift2PrAll (+)
(-) = lift2PrAll (-)
(*) = lift2PrAll (*)
abs = liftPr abs
signum = liftPr signum
instance Ord a => Ord (PR a) where
max = lift2Pr (Prelude.max)
instance Eq a => Eq (PR a) where
(PR a) == (PR b) = a == b
data Model = Model {
modelStart :: Time,
exch :: Currency -> Currency -> PR Double
}
simpleModel :: Time -> Model
simpleModel modelDate = Model {
modelStart = modelDate,
exch = exch
}
where
exch :: Currency -> Currency -> PR Double
exch k1 k2 = PR (konstSlices 1)
rateModels = [((Currency "CHF"), rates 7 0.8)
,((Currency "EUR"), rates 6.5 0.25)
,((Currency "GBP"), rates 8 0.5)
,((Currency "KYD"), rates 11 1.2)
,((Currency "USD"), rates 5 1)
,((Currency "ZAR"), rates 15 1.5)]
rateModel k =
case lookup k rateModels of
Just x -> x
Nothing -> error $ "rateModel: currency not found " ++ (show k)
bigK :: a -> PR a
bigK x = PR (konstSlices x)
konstSlices x = nextSlice [x]
where nextSlice sl = sl : (nextSlice (x:sl))
condPr :: PR Bool -> PR a -> PR a -> PR a
condPr = lift3Pr (\b tru fal -> if b then tru else fal)
disc :: Currency -> (PR Bool, PR Double) -> PR Double
disc k (PR bs, PR rs) = PR $ discCalc bs rs (unPr $ rateModel k)
where
discCalc :: [RV Bool] -> [RV Double] -> [RV Double] -> [RV Double]
discCalc (bRv:bs) (pRv:ps) (rateRv:rs) =
if and bRv
then [pRv]
else let rest@(nextSlice:_) = discCalc bs ps rs
discSlice = zipWith (\x r -> x / (1 + r/100)) (prevSlice nextSlice) rateRv
thisSlice = zipWith3 (\b p q -> if b then p else q)
bRv pRv discSlice
in thisSlice : rest
absorb :: Currency -> (PR Bool, PR Double) -> PR Double
absorb k (PR bSlices, PR rvs) =
PR $ zipWith (zipWith $ \o p -> if o then 0 else p)
bSlices rvs
snell :: Currency -> (PR Bool, PR Double) -> PR Double
snell k (PR bs, prd) = prd
prevSlice :: RV Double -> RV Double
prevSlice [] = []
prevSlice (_:[]) = []
prevSlice (n1:rest@(n2:_)) = (n1+n2)/2 : prevSlice rest
rates :: Double -> Double -> PR Double
rates rateNow delta = PR $ makeRateSlices rateNow 1
where
makeRateSlices rateNow n = (rateSlice rateNow n) : (makeRateSlices (rateNow-delta) (n+1))
rateSlice minRate n = take n [minRate, minRate+(delta*2) ..]
probabilityLattice :: [RV Double]
probabilityLattice = probabilities pathCounts
where
probabilities :: [RV Integer] -> [RV Double]
probabilities (sl:sls) = map (\n -> (fromInteger n) / (fromInteger (sum sl))) sl : probabilities sls
pathCounts :: [RV Integer]
pathCounts = paths [1] where paths sl = sl : (paths (zipWith (+) (sl++[0]) (0:sl)))
expectedValue :: RV Double -> RV Double -> Double
expectedValue outcomes probabilities = sum $ zipWith (*) outcomes probabilities
expectedValuePr :: PR Double -> [Double]
expectedValuePr (PR rvs) = zipWith expectedValue rvs probabilityLattice
evalC :: Model -> Currency -> Contract -> PR Double
evalC (Model modelDate exch) k = eval
where eval Zero = bigK 0
eval (One (Financial k2 cft _)) = exch k k2
eval (Give c) = -(eval c)
eval (o `Scale` c) = (evalO o) * (eval c)
eval (c1 `And` c2) = (eval c1) + (eval c2)
eval (Or _ c1 c2) = max (eval c1) (eval c2)
eval (Cond o c1 c2) = condPr (evalO o) (eval c1) (eval c2)
eval (When o c) = disc k (evalO o, eval c)
eval (Until o c) = absorb k (evalO o, eval c)
eval (Anytime l o c) = snell k (evalO o, eval c)
evalO :: Obs a -> PR a
evalO (Const v) = bigK v
latticeImage :: PR Double -> String -> String -> IO ExitCode
latticeImage pr baseName imageType =
do writeTreeAsDot baseName pr
runDot baseName imageType
printTree :: PR Double -> IO ()
printTree pr = mapM_ putStrLn (dotGraph (prToDot pr))
writeTreeAsDot :: String -> PR Double -> IO ()
writeTreeAsDot baseName pr = writeFile (baseName ++ dotExt) $ unlines (dotGraph (prToDot pr))
runDot :: String -> String -> IO ExitCode
runDot baseName fileType =
system $ concat ["dot -T", fileType,
" -o ", baseName, ".", fileType, " ",
baseName, dotExt]
prToDot :: PR Double -> [String]
prToDot (PR rvs) = rvsToDot rvs
rvsToDot :: [RV Double] -> [String]
rvsToDot rvs = let numberedRvs = assignIds rvs 1
in showNodes numberedRvs ++ treeToDot numberedRvs
dotExt = ".dot"
assignIds :: [RV a] -> Int -> [RV (Int, a)]
assignIds [] n = []
assignIds (rv:rvs) n = numberList (reverse rv) n : assignIds rvs (n + length rv)
numberList :: [a] -> Int -> [(Int, a)]
numberList l n = zip [n .. n + length l] l
showNodes :: [RV (Int, Double)] -> [String]
showNodes numberedRvs = concatMap showSlice (numberList numberedRvs 0)
where showSlice (n, sl) = ("subgraph Slice" ++ show n ++ " { rank=same")
: (map (\(n,s) -> show n ++ nodeLabel s) sl)
++ ["SL" ++ (show n) ++ " [label=\"" ++ show n ++ "\" style=solid peripheries=0] }"]
nodeLabel :: Double -> String
nodeLabel s = " [label=\"" ++ (showFFloat (Just 2) s "\"]")
treeToDot :: [RV (Int, a)] -> [String]
treeToDot [a] = []
treeToDot (a:b:rest) = dotJoin a (take (length a) b)
++ dotJoin a (tail b)
++ treeToDot (b:rest)
dotJoin :: RV (Int, a) -> RV (Int, a) -> [String]
dotJoin a b = zipWith (\(m,a) (n,b) -> (show m) ++ " -- " ++ (show n)) a b
dotGraph :: [String] -> [String]
dotGraph body = dotGraphHdr ++ (map formatDotStmt body) ++ ["}"]
dotGraphHdr :: [String]
dotGraphHdr = ["graph contract_lattice {"
," rankdir=LR;"
," dir=none;"
," node [style=filled color=pink shape=box fontsize=10 width=0.5 height=0.4];"]
formatDotStmt :: String -> String
formatDotStmt s = " " ++ s ++ ";"