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.
module Contracts -- (renderEx, renderExDefault, ExContr(ExContr)) -- limit exports for use from HAppS where
import List import Numeric import Control.Monad import System import Text.XHtml.Strict import Data.Unique
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
data Currency = USD | GBP | EUR | ZAR | KYD | CHF deriving (Eq, Show)
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 0This simplifies some aspects of the implementation, discussed further under Support actual dates and times.
data Contract = Zero | One Currency | Give Contract | And Contract Contract | Or Contract Contract | Cond (Obs Bool) Contract Contract | Scale (Obs Double) Contract | When (Obs Bool) Contract | Anytime (Obs Bool) Contract | Until (Obs Bool) Contract deriving Show
"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:
newtype Obs a = Obs (Date -> PR a)
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 ++ ")"
zero :: Contract zero = Zero
one :: Currency -> Contract one = One
give :: Contract -> Contract give = Give
cAnd :: Contract -> Contract -> Contract cAnd = And
cOr :: Contract -> Contract -> Contract cOr = Or
cond :: Obs Bool -> Contract -> Contract -> Contract cond = Cond
scale :: Obs Double -> Contract -> Contract scale = Scale
cWhen :: Obs Bool -> Contract -> Contract cWhen = When
anytime :: Obs Bool -> Contract -> Contract anytime = Anytime
cUntil :: Obs Bool -> Contract -> Contract cUntil = Until
andGive :: Contract -> Contract -> Contract andGive c d = c `cAnd` give d
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 signumOne quirk is that we need to define a stub for Eq to support the Num instance.
instance Eq a => Eq (Obs a) where (==) = undefinedWe 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 (>)
european :: Date -> Contract -> Contract european t u = cWhen (at t) (u `cOr` zero)
american :: (Date, Date) -> Contract -> Contract american (t1, t2) u = anytime (between t1 t2) u
between :: Date -> Date -> Obs Bool between t1 t2 = lift2 (&&) (date %>= (konst t1)) (date %<= (konst t2))
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.
type RV a = [a]
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.
data Model = Model { modelStart :: Date, disc :: Currency -> (PR Bool, PR Double) -> PR Double, exch :: Currency -> Currency -> PR Double, absorb :: Currency -> (PR Bool, PR Double) -> PR Double, rateModel :: Currency -> PR Double }Define a specific model which defines the model functions given in the paper. This would normally be defined in a separate module.
exampleModel :: CalendarTime -> Model exampleModel modelDate = Model { modelStart = (modelDate,0), disc = disc, exch = exch, absorb = absorb, rateModel = rateModel }
where
The example model's functions are defined in the following sections. Note that these definitions are local to the 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 : restprevSlice 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."
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
exch :: Currency -> Currency -> PR Double exch k1 k2 = PR (konstSlices 1)The definition of the
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 slsTo 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.)
evalC :: Model -> Currency -> Contract -> PR Double evalC (Model modelDate disc exch absorb rateModel) k = eval -- punning on record fieldnames for conciseness where eval Zero = bigK 0 eval (One k2) = 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 (c1 `Or` 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 (Anytime o c) = snell k (evalO o, eval c) eval (Until o c) = absorb k (evalO o, eval c)
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
bigK :: a -> PR a bigK x = PR (konstSlices x)
konstSlices x = nextSlice [x] where nextSlice sl = sl : (nextSlice (x:sl))
datePr :: PR Date datePr = PR $ timeSlices [time0]
timeSlices sl@((s,t):_) = sl : timeSlices [(s,t+1) | _ <- [0..t+1]]
condPr :: PR Bool -> PR a -> PR a -> PR a condPr = lift3Pr (\b tru fal -> if b then tru else fal)
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 cA version of zipWith that handles input lists of different lengths. This is used to support lifted binary operations such as (+).
zipWithAll :: (a -> a -> a) -> [a] -> [a] -> [a] zipWithAll f (a:as) (b:bs) = f a b : zipWithAll f as bs zipWithAll f as@(_:_) [] = as zipWithAll f [] bs@(_:_) = bs 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 max
instance Eq a => Eq (PR a) where (PR a) == (PR b) = a == b
xm :: Model xm = exampleModel ()Define an evaluator specific to the example model and the USD currency.
evalX :: Contract -> PR Double evalX = evalC xm USDThe by-now-infamous zero-coupon bond:
zcb :: Date -> Double -> Currency -> Contract zcb t x k = cWhen (at t) (scale (konst x) (one k))A contract using the ZCB:
c1 :: Contract c1 = zcb t1 10 USDThe test date for the bond is
horizon timesteps from the model's current date:
t1 :: Date t1 = mkDate t1Horizon
t1Horizon = 3 :: TimeStepA 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 c1Access the underlying lattice (list of slices):
tr1 = unPr pr1Test 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.
zcbImage = latticeImage pr1 "fig9" "png"
c1ExpectedValueUrl = chartUrl $ expectedValuePr pr1
rateEvolution = latticeImage (takePr (t1Horizon + 1) $ rateModel xm USD) "fig8" "png"
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.001Test 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 < toleranceTest 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]
prToTable pr@(PR rvs) = table << (snd $ foldl renderSlice (0, noHtml) rvs) where
horizon = horizonPr pr renderSlice (n, rows) rv = (n+1, rows +++ (tr $ td << (show n) +++ (spacer $ horizon - n) +++ (concatHtml (map renderCell rv)) +++ (spacer $ horizon - n + 1)))
renderCell v = td ! [theclass "cell", colspan 2] << (showFFloat (Just 2) v "")
spacer 0 = noHtml spacer n = td ! [theclass "sp", colspan n] << noHtml
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 imageTypeSupports 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 rvsConvert 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] lshowNodes 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 ++ ";"
chartUrl :: [Double] -> String chartUrl vs = "http://chart.apis.google.com/chart?chs=300x200&cht=lc&chxt=x,y&chg=20,25,2,5&chxr=0,0," ++ (show $ length vs - 1) ++ "|1," ++ (showFFloat (Just 1) ymin ",") ++ (showFFloat (Just 1) ymax "&chd=t:") ++ (concat $ intersperse "," $ map (\y -> showFFloat (Just 1) y "") ys) where (ymin, ymax, ys) = chartScale vs 100Scale specified list of values to a range between 0 and
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.
newtype ExContr = ExContr (String, [Double], Bool) deriving (Read,Show,Eq)
useLatticeImage (ExContr (_, _, b)) = b webPath = "/home/anton/usr/happs.org/public/" -- webPath = "/home/anton/happs91/HAppS-Begin/public/" tmpImgPath = "imgtmp/" baseDotFilename = "pr-lattice" pageTitle = "Composing contracts - simple charts"
mkUniqueName :: String -> IO String mkUniqueName baseName = do u <- newUnique return $ baseName ++ (show $ hashUnique u)
renderEx :: ExContr -> IO Html renderEx exSpec@(ExContr (contractId, args, lattice)) = let pr = evalEx exSpec expValChart = if contractId == "probs" then noHtml -- expected value is meaningless for the probabilities it relies on else h3 << "Expected value" +++ image ! [src (chartUrl $ expectedValuePr pr)] imageType = "png" in if useLatticeImage exSpec then do baseName <- mkUniqueName baseDotFilename exitCode <- latticeImage pr (webPath ++ tmpImgPath ++ baseName) imageType let pageContents = case exitCode of ExitSuccess -> renderExampleForm exSpec (image ! [src latticeUrl, border 1]) expValChart where latticeUrl = "/" ++ tmpImgPath ++ baseName ++ "." ++ imageType _ -> p << "renderEx: error generating lattice image" return $ renderExamplePage pageContents else return $ renderExamplePage $ renderExampleForm exSpec (prToTable pr) expValChart
renderExDefault = renderExamplePage $ renderExampleForm (ExContr ("zcb"