This document is an unofficial example implementation of the system originally described in the paper Composing contracts: an adventure in financial engineering, by Simon Peyton Jones, Jean-Marc Eber, and Julian Seward. Familiarity with both versions of this paper is assumed.
This example implementation is a literate Haskell program, Contracts.lhs. Don't be put off by the embedded HTML — it is an executable Haskell program. It can be executed directly and experimented with in an interactive Haskell environment such as GHCI.
The program is completely self contained, depending only on a few GHC libraries. Compatibility with other Haskell implementations has not been tested.
A web interface to some of the examples is also available.
Please note that this program is an example, intended only for educational use in its current form. The core implementation is only 215 lines of code, excluding examples and user interface. As such, it has many limitations. See the Future work section for further information.
This document and program was developed by, and is copyright © 2007 by Anton van Straaten. It may be freely used and copied for educational purposes. For other uses, please contact the author (this is mainly because it seems like overkill to release under a more general license at this point).
There are a few significant differences between the first and second papers. The change with the most impact on the implementation relates to the representation of contract horizons.
In A:5.3, entitled "Implementation in Haskell", a value process representation is described in which the lattice for a value process is stored as a list of random variables "in reverse time order", i.e. horizon first, along with the horizon's timestep number. This is possible because the first paper uses a simple, definite approach to representing horizons: they are specified by a single date.
However, this implementation is not compatible with some of the design decisions described in the second paper (B). Since the horizon of a contract can depend on observables other than the date, the second paper introduces a more sophisticated approach to representing horizons: horizons are specified by boolean value processes (type PR Bool) that define contract acquisition regions.
This allows the horizon of a contract to cross over more than one time step, depending on the value of the observable(s) that define the horizon. The use of boolean value processes "to describe the 'region' in which one can acquire a contract" is described as a "breakthrough" in section 3.6 of the second paper.
Since contracts can have indefinite horizons, and also because some value processes may have no horizon, it's not possible in general to represent a value process horizon-first, as suggested in the first paper.
Since the second paper does not provide an explicit description of the Haskell representation, our implementation uses a variation on the one described in the first paper, with some changes to support the second paper's design.
Most references in this document are of the form P:S.s, where e.g. A:3.5 refers to paper A, section 3.5. The papers are listed in the References section. Papers A and B are the first and second versions of the Composing Contracts paper, and paper C is a paper about the functional reactive programming system Fran.
Notational conventions from B:Fig.1:
c, d, u : Contract
o : Observable
t, s : Date, time
k : Currency
x : Dimensionless real value
p : Value process
v : Random variable
A Date is represented as a pair consisting of the start date/time of a contract, represented by a value of type CalendarTime, and an integer representing the number of time steps since the start of a contract. For example purposes, the time steps are of unspecified duration, and the CalendarTime type is stubbed out.
Representing the time step as a separate integer is useful when manipulating trees representing the evolution of a process over time, where the time step corresponds to an index into a list.
> type Date = (CalendarTime, TimeStep) > type TimeStep = Int > type CalendarTime = () Since the example doesn't use real dates, mkDate cheats and creates a Date from a TimeStep. > mkDate :: TimeStep -> Date > mkDate s = ((),s) Because real dates aren't used, all value processes are assumed to begin at the same time, the zeroth time step,time0.
> time0 :: Date
> time0 = mkDate 0
This simplifies some aspects of the implementation, discussed further under Support actual dates and times.
"In general, a value of type Obs d represents a time-varying quantity of type d." (A:3.3)
An obvious implementation might involve a function of type (Date -> a). However, a "quantity" in this context is not a single value, but rather a random variable, i.e. a set of possible values. This suggests a function of type (Date -> RV a). This would allow an arbitrary observable to be converted to a value process during evaluation of a contract, by applying successive dates to the observable's function. This would be a valid implementation, but in order to take maximum advantage of the lazy list representation used for value processes, we will actually use the following type:
An observable is thus represented as a function from a starting date to a value process. The "time-varying" nature of an observable is captured primarily by the value process itself (PR a); the Date in the function's type is simply used to specify the start date for the resulting value process.
For development and debugging purposes, Obs will be showable. Since it is a function type, this is achieved by applying it to a dummy date and displaying the first slice of the resulting process. This is only useful for getting a rough idea of the definition of a contract. See Enhance observable representation for further discussion of this.
> instance Show a => Show (Obs a) where > show (Obs o) = let (PR (rv:_)) = o time0 in "(Obs " ++ show rv ++ ")"konst x is an observable that has value x at any time.
> konst :: a -> Obs a
> konst k = Obs (\t -> bigK k)
lift f o is the observable whose value is the result of applying f to the value of the observable o.
> lift :: (a -> b) -> Obs a -> Obs b
> lift f (Obs o) = Obs (\t -> PR $ map (map f) (unPr $ o t))
lift2 o1 o2 is the observable whose value is the result of applying
f to the values of the observables o1 o2.
> lift2 :: (a -> b -> c) -> Obs a -> Obs b -> Obs c
> lift2 f (Obs o1) (Obs o2) = Obs (\t -> PR $ zipWith (zipWith f) (unPr $ o1 t) (unPr $ o2 t))
"The value of the observable date at date t is just t."
> date :: Obs Date
> date = Obs (\t -> PR $ timeSlices [t])
"All numeric operations lift to the Obs type. The implementation is simple, using lift and
lift2."
> instance Num a => Num (Obs a) where
> fromInteger i = konst (fromInteger i)
> (+) = lift2 (+)
> (-) = lift2 (-)
> (*) = lift2 (*)
> abs = lift abs
> signum = lift signum
One quirk is that we need to define a stub for Eq to support the Num instance.
> instance Eq a => Eq (Obs a) where
> (==) = undefined
We can't implement Eq on an Observable's function, but we can provide a lifted version of equality:
> (==*) :: Ord a => Obs a -> Obs a -> Obs Bool
> (==*) = lift2 (==)
at is a boolean observable that becomes True at time t (B:3.2)
> at :: Date -> Obs Bool
> at t = date ==* (konst t)
Typeclasses don't work so well for relational operators, so define a separate family of them (B:3.3)
> (%<), (%<=), (%=), (%>=), (%>) :: Ord a => Obs a -> Obs a -> Obs Bool
> (%<) = lift2 (<)
> (%<=) = lift2 (<=)
> (%=) = lift2 (==)
> (%>=) = lift2 (>=)
> (%>) = lift2 (>)
PR a is represented as a list of random variables RV a, with the random variable corresponding to the earliest time step appearing first in the list.
> newtype PR a = PR { unPr :: [RV a] } deriving Show
Note that the "informal type definition" of a value process is given in B:4.1 as PR a = Date -> RV a. However, this definition should not be taken literally. Among other things, it is not amenable to efficient list-based recursive processing of entire value processes, since it requires a lookup for access to each successive date. (This was discovered the hard way in an earlier implementation of this code — thanks to Chung-chieh Shan for pointing out the advantages of relying pervasively on a lazy list implementation, during the presentation of the earlier version of this code in NYC.)
A random variable RV a describes the possible values for a value process at a particular time step. For example, the random variable describing the outcome of a dice throw would be [1,2,3,4,5,6]. Random variables are therefore implemented as simple lists.
takePr truncates a (possibly infinite) value process.
> takePr :: Int -> PR a -> PR a
> takePr n (PR rvs) = PR $ take n rvs
horizonPr determines the number of time steps in a value process. Only terminates for finite value processes.
> horizonPr :: PR a -> Int
> horizonPr (PR rvs) = length rvs
andPr returns True if every value in a value process is true, false otherwise. Only terminates for finite value processes.
> andPr :: PR Bool -> Bool
> andPr (PR rvs) = and (map and rvs)
The model specifies the particular semantics for underlying observables such as the evolution of interest rates, exchange rates, and the types of calculation used. The contract evaluation function, evalC, is parameterized over a model to allow different models to be easily used.
The model itself is implemented as a record of model-specific data and functions which can easily be instantiated by a function such as exampleModel below. Essentially, this amounts to a poor man's higher-order module.
exampleModel record definition (due to the where clause above).
See B:5.1. This constructs a lattice containing possible interest rates given a starting rate and an increment per time step. This "unrealistically regular" model matches that shown in B:Fig.8. However, it is so simple that some interest rates go negative after a small number of time steps. A better model is needed for real applications. Don't use this to model your retirement fund!
> 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) ..] Each currency has different parameters for the interest rate model. Since the model is not realistic, these parameters are currently entirely arbitrary. > rateModels = [(CHF, rates 7 0.8) > ,(EUR, rates 6.5 0.25) > ,(GBP, rates 8 0.5) > ,(KYD, rates 11 1.2) > ,(USD, rates 5 1) > ,(ZAR, rates 15 1.5) > ] > rateModel k = > case lookup k rateModels of > Just x -> x > Nothing -> error $ "rateModel: currency not found " ++ (show k)
The primitive (disc t k) maps a real-valued random variable at date T, expressed in currency k, to its "fair" equivalent stochastic value process in the same currency k. See B:4.4 and B:Fig.7.
A simplifying assumption is that at some point, the boolean-valued process becomes True for an entire RV. This provides a simple termination condition for the discounting process.
> 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 -- test for horizon > 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) -- allow for partially discounted slices > bRv pRv discSlice > in thisSlice : rest prevSlice calculates a previous slice in a lattice by averaging each adjacent pair of values in the specified slice > prevSlice :: RV Double -> RV Double > prevSlice [] = [] > prevSlice (_:[]) = [] > prevSlice (n1:rest@(n2:_)) = (n1+n2)/2 : prevSlice rest
"Given a boolean-valued process o, the primitive absorbk(o,p)
transforms the real-valued process p, expressed in currency k, into another
real-valued process. For any state, the result is the expected value of receiving p's
value if the region o will never be True, and receiving zero in the contrary.
In states where o is True, the result is therefore zero."
exampleModel ends here.
absorb above does not obviously deal with the expected value mentioned in the spec. This is because the expected value of each random variable is implicit in the value process lattice representation: each node in the lattice is associated with a probability, and the expected value at a particular date is simply the sum of the product of the value at each node and its associated probability. The following functions implement this calculation.
> expectedValue :: RV Double -> RV Double -> Double
> expectedValue outcomes probabilities = sum $ zipWith (*) outcomes probabilities
> expectedValuePr :: PR Double -> [Double]
> expectedValuePr (PR rvs) = zipWith expectedValue rvs probabilityLattice
snellk(o,p) is the smallest process q (under an ordering relation mention briefly at the end of B:4.6) such that:
forall o' . (o => o') => q >= snellk(o',q)
That is, an American option is the least upper bound of any of the deterministic acquisition choices specified by o', where o' is a sub-region of o.
Each node in a value process lattice is associated with a probability.
"...in our very simple setting the number of paths from the root to the node is proportional to the probability that the variable will take that value."
> 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 To calculate the number of paths to each node in a lattice, simply add the number of paths to the pair of parent nodes. This needs to work with Integers as opposed to Ints, because:findIndex (\sl -> maximum sl > (fromIntegral (maxBound::Int))) pathCounts ==> Just 67
> pathCounts :: [RV Integer]
> pathCounts = paths [1] where paths sl = sl : (paths (zipWith (+) (sl++[0]) (0:sl)))
See B:Fig.4. A Haskell type signature for eval is specified in A:5.3. It has been modified here to return a PR Double, as specified in the semantics in Figure 4, instead of a ValProc. (In this implementation, the PR Double type is essentially equivalent to the first paper's ValProc type.)
evalO, converts an observable's function to a value process by applying the function to a start date.
> evalO :: Obs a -> PR a
> evalO (Obs o) = o time0
horizon timesteps from the model's current date:
> t1 :: Date
> t1 = mkDate t1Horizon
> t1Horizon = 3 :: TimeStep
A stripped-down versions of the European option from B:3.4. That example uses real dates that range over more than two years. This is a smaller version. Its results have not been checked.
> c11 :: Contract
> c11 = european (mkDate 2)
> (zcb (mkDate 20) 0.4 USD `cAnd`
> zcb (mkDate 30) 9.3 USD `cAnd`
> zcb (mkDate 40) 109.3 USD `cAnd`
> give (zcb (mkDate 12) 100 USD))
Evaluate the contract c1, in dollars, to produce a value process:
> pr1 :: PR Double
> pr1 = evalX c1
Access the underlying lattice (list of slices):
> tr1 = unPr pr1
Test of 'cUntil' - implementation of absorbEx is similar to zcb, but uses cUntil instead of cWhen.
> absorbEx t x k = cUntil (konst t %> date) (scale (konst x) (one k))
There is no main function. This program is intended to be run in an interactive Haskell environment such as GHCI, where the above examples, combinators, and evaluation functions can be examined and experimented with.
A web interface to some of the examples is also available.
The following diagram shows the value process lattice for the contract (zcb (mkDate 3) 10 USD).
It matches B:Fig.9, except for minor details such as the fetching shade of pink. It was generated using
GraphViz, by the following code.
As described in Basic data types, time is currently modeled using abstract integer time steps. Adding basic support for real dates and times should not be difficult. Since many financial contracts do not need to be concerned with time steps smaller than days, the following description will focus only on date handling, but the same design applies to support for real times.
Adding date support requires changes in the following areas:
time0, particularly the observable evalution function evalO and the date process datePr, should instead use the start date of the contract evaluator's Model parameter. This can be achieved by converting the contract evaluator evalC from direct style to monadic style (see next subsection), which will allow the functions in question access to the model's start date.
The evaluator for contracts is currently a very simple, direct-style implementation. This is possible in part because of simplifying choices such as the use of time steps without actual dates, as mentioned above.
Many other kinds of enhancements to the implementation are likely to require a more sophisticated evaluator design. Converting to a monadic evaluator would support such enhancements. Aside from providing primitives direct access to the model, it would also allow alternate monads and monad transformers to be used to parameterize the evaluator semantics. Jeff Polakow pointed out that a probability monad could be useful, for example.
Show instance for the Observable data type demonstrates, the representation of observables as functions limits the ability to inspect contract definitions. With an embedded DSL, if metadata is not stored along with the DSL terms, then the host language source code may be the only complete specification of embedded terms that involve functions. This could be addressed by the use of a tag to identify observables. This might take the form of a sum type representing primitive observables such as constants and dates, with provision for arbitrary named functions for more complex observables. Such a representation is hinted at in the description of the valuation semantics for observables in B:Fig.5.
The second paper's use of boolean value processes to represent acquisition regions is very general. The full generality of this model is not exploited by the current implementation. For example, the disc primitive assumes that the horizon of a contract corresponds to a single random variable. However, contract horizons may be based on more complex observables than the date, and composed contracts may also result in complex scenarios in which a contract's horizon crosses more than one random variable.
In addition, some value processes are infinite and have no horizons. The system should track this to allow it to prevent attempts to perform non-terminating operations on such contracts. This may also help in implementing operations that combine contracts with different horizons.
A few small tests that came up during development.
> tolerance = 0.001 Test of constant process: > testK = andPr $ liftPr (== 100) $ takePr 10 (bigK 100) Test that a slice in the probability lattice adds up to probability 1.0: > testProb = (sum $ probabilityLattice !! 100) - 1 < tolerance Test the result of evaluating the c1 contract > testPr1 = andPr $ lift2Pr (\a b -> (abs (a - b)) < tolerance) > pr1 > (PR [[8.641], [9.246,8.901], [9.709,9.524,9.346], [10,10,10,10]]) Run all tests (all three of them!) > tests = and [testK > ,testProb > ,testPr1]
This code generates graphs which represent a value process lattice. Currently assumes Double values, constrained by showNode's formatting of the value.
Write out tree as Dot file and run Dot to generate image:
> latticeImage :: PR Double -> String -> String -> IO ExitCode > latticeImage pr baseName imageType = > do writeTreeAsDot baseName pr > runDot baseName imageType Supports interactive display of generated Dot code. > printTree :: PR Double -> IO () > printTree pr = mapM_ putStrLn (dotGraph (prToDot pr)) Write a value process out as a Dot file. > writeTreeAsDot :: String -> PR Double -> IO () > writeTreeAsDot baseName pr = writeFile (baseName ++ dotExt) $ unlines (dotGraph (prToDot pr)) Run Dot on a file with the specified base name, and generate a graphic file with the specified type. > runDot :: String -> String -> IO ExitCode > runDot baseName fileType = > system $ concat ["dot -T", fileType, > " -o ", baseName, ".", fileType, " ", > baseName, dotExt] Convert a (PR Double) to a list of dot node relationships. > prToDot :: PR Double -> [String] > prToDot (PR rvs) = rvsToDot rvs Convert lattice to list of dot node relationships. > rvsToDot :: [RV Double] -> [String] > rvsToDot rvs = let numberedRvs = assignIds rvs 1 > in showNodes numberedRvs ++ treeToDot numberedRvs > dotExt = ".dot" Number each of the nodes in a lattice. > 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 returns a list of "primary" Dot representations of numbered RV nodes, with each node's value specified as the node's label. These nodes can then be referenced repeatedly in the generated Dot code without specifying a label. > 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 "\"]") generate Dot code for relationships between numbered RV nodes. > 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 ++ ";"upper.
> chartScale ys upper =
> let ymin = minimum ys
> ymax = maximum ys
> yrange = ymax - ymin
> yscale = upper/yrange
> in (ymin, ymax, map (\y -> (y - ymin) * yscale ) ys)
The following code implements a very simple web interface, which allows a few canned examples to be run and displays the resulting value process lattice images along with a chart of expected value (where appropriate).
At the time of writing, the web interface is running at http://contracts.scheming.org/contractEx. This URL may change in future.
examples list which is used in generating the web form.
> evalEx :: ExContr -> PR Double
> evalEx (ExContr (name, args, f)) =
> case lookup name examples of
> Just (desc, defaultArgs, f) -> if length args >= length defaultArgs -- ignore extra args
> then f args -- TODO: could handle argument defaulting here? See getArg.
> else dummyContract
> _ -> dummyContract
> where
> dummyContract = evalX $ zcb time0 0 USD -- TODO: proper error reporting (to web page if appropriate)
Limit server abuse - disallow large lattices in web interface. The program can easily handle thousands of time steps, but generating a graphic of the resulting lattice produces large files and consumes CPU resources. To experiment with larger trees, run Contracts.lhs on your own machine.
> sanitize r = min (truncate r) 20
Map an example id to a description, default arguments, and an evaluation function.
> examples =
> -- Contracts
> [("zcb", ("Zero-coupon bond", [t1Horizon, 10],
> (\(r:x:_) -> evalX $ zcb (mkDate $ sanitize r) x USD)))
> ,("c11", ("European option", [], (\_ -> evalX c11)))
> -- Underlyings
> ,("probs", ("Probability lattice", [9], (\(r:_) -> let n = sanitize r + 1 in PR $ take n probabilityLattice)))
> ,("rates", ("Interest rate model", [9], (\(r:_) -> let n = sanitize r + 1 in takePr n $ rateModel xm USD)))]
> renderExampleForm (ExContr (contractId, args, showImage)) chart1 chart2 =
> form ! [method "GET", action "/contractEx"]
> << table << ((tr << (td << "Contract" +++ td << "Horizon" +++ td << "Value" +++ td << "Output"))
> +++ (tr << ((td $ select ! [name "contract"]
> << (map (\(id, (desc, defaultArgs, _)) ->
> attrIf (id == contractId) selected (option ! [value id]) << desc)
> examples))
> +++ (td << textfield "arg1" ! [value $ getArg contractId args 0, size "10"])
> +++ (td << textfield "arg2" ! [value $ getArg contractId args 1, size "10"])
> +++ (td << (attrIf showImage checked (radio "image" "True") +++ "Image"))))
> +++ (tr << (td << submit "submit" "Draw" +++ spacer 2
> +++ td << (attrIf (not showImage) checked (radio "image" "False") +++ "Table"))))
> +++ chart1 +++ hr +++ chart2
Retrieve the nth argument from the argument array; if not present, retrieve from default args for specified example.
> getArg id l n = if n < length l then show $ l !! n
> else case lookup id examples of
> Just (_, args, _) -> if n < length args
> then show $ args !! n else ""
attrIf adds the specified attribute to the Html element if the condition is true.
Useful for checked and selected attributes.
> attrIf False attr el = el
> attrIf True attr el = el ! [attr]
The following module can be used to integrate with the HAppS application server. This provides a web interface to the system.
This code is not an executable part of Contracts.lhs. To use it, it should be extracted to its own file and built with HAppS. The import Contracts line imports Contracts.lhs (this file).
module Main where
import HAppS.Server.AlternativeHTTP
import HAppS.Server.HTTP.AltFileServe
import Control.Monad.State
import Numeric
import Contracts
instance FromData ExContr where
fromData = do c <- look "contract"
arg1 <- look "arg1"
arg2 <- look "arg2"
img <- look "image"
return $ ExContr (c, map fst $ readFloat arg1
++ readFloat arg2, read img)
main :: IO ()
main = do simpleHTTP [dir "contractEx"
[withData $ \(ExContr t) ->
[anyRequest $ liftIO $ liftM toResponse =<< renderEx (ExContr t)]
,anyRequest $ ok $ toResponse renderExDefault]
,fileServe ["Contracts.html"] "public" -- fileserving
]
First, thanks to the authors of the original papers - Simon Peyton Jones, Jean-Marc Eber, and Julian Seward - for some fascinating and useful papers.
Thanks also to Thomas Hartman, Jeff Polakow, Adam Peacock, Chung-Chieh Shan and the organizers and members of the New York Functional Programmers Meetup Group for their encouragement and support.
The HTML version of this document was generated from Contracts.lhs using hscolour with the -lit and -css options to color only the code fragments. Worked like a charm. (The rest of the HTML was written by hand.)