diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/BasketOption.contract b/examples/BasketOption.contract new file mode 100644 --- /dev/null +++ b/examples/BasketOption.contract @@ -0,0 +1,21 @@ +import Options + +contract = + option "opt" exerciseDetails CallOption emptyOptionAttrs underlying + + where + -- A currency basket option in GBP on USD and EUR + -- By exercising the option the holder gets 100 EUR and 100 USD + -- for 200 GBP times the strike price + + underlying sp = (financial quantity usd cash) `and` (financial quantity eur cash) + `and` give (financial (sp * 2 * quantity) gbp cash) + quantity = 100 + + -- simple european exercise + + exerciseDetails = europeanExercise (date 2013 06 01) strikePrice + + -- the strike price can be set at e.g. the weighted value of the basket currencies in gbp + + strikePrice = 0.78 diff --git a/examples/ChooserRangeAccrual.contract b/examples/ChooserRangeAccrual.contract new file mode 100644 --- /dev/null +++ b/examples/ChooserRangeAccrual.contract @@ -0,0 +1,11 @@ +import Common +import Observable + +dailySch1 = [mkdate 2011 1 d | d <- [1..2]] +dailySch2 = [mkdate 2011 2 d | d <- [1..2]] +dailySch3 = [mkdate 2011 3 d | d <- [1..2]] + +--contract = chooserLeg 80 500 (last dailySch1) dailySch1 (Currency "EUR") (primVar "LIBOR.EUR.6M") (CashFlowType "initialMargin") +contract = chooserNote [chooserLeg 80 500 (last dailySch1) dailySch1 (Currency "EUR") (primVar "LIBOR.EUR.6M") (CashFlowType "initialMargin"), + chooserLeg 45 450 (last dailySch2) dailySch2 (Currency "EUR") (primVar "LIBOR.EUR.6M") (CashFlowType "initialMargin"), + chooserLeg 50 550 (last dailySch3) dailySch3 (Currency "EUR") (primVar "LIBOR.EUR.6M") (CashFlowType "initialMargin")] diff --git a/examples/ChooserRangeAccrual.hs b/examples/ChooserRangeAccrual.hs new file mode 100644 --- /dev/null +++ b/examples/ChooserRangeAccrual.hs @@ -0,0 +1,72 @@ +module ChooserRangeAccrual where + +import Prelude hiding (and, or, until, read, all, any, max, min, negate, abs) +import Common +import Contract +import DecisionTree +import Interpreter +import Data.Time +import List hiding (and) + +import Display + +type Price = Double + +financial = financial' . konst +financial' o cur = Scale o (One (Financial cur)) + +m = (*1000000) + +dailySch1 = [date 2011 1 d | d <- [1..2]] +dailySch2 = [date 2011 2 d | d <- [1..2]] +dailySch3 = [date 2011 3 d | d <- [1..2]] + +chooserLeg :: Int -- range for observation period + -> Int -- index strike for observation period + -> Time -- coupon settlement date + -> Schedule -- dates for observation period + -> Contract + +chooserLeg range strike setD sch = + + foldr daily settlementDate sch (konst 0) + + where + daily (day) next daysWithinRange = + when (at day) $ + read "daysWithinRange" + (daysWithinRange %+ indexInRange strike range) + (next (var "daysWithinRange")) + + settlementDate couponAmount = when (at setD) $ financial' paymentDue (Currency "eur") + where + -- bit of a cheat here. should be a count of actual business days, not total number of days + paymentDue = primVar "LIBOR.EUR.6M" %* var "daysWithinRange" %/ konst (fromIntegral(length sch)) + + -- If the 6M Euro libor rate is within strike +/- range then increase days within range + -- otherwise dont increase days within range + indexInRange strike range = + + ifthen (primVar "LIBOR.EUR.6M" %<= konst (fromIntegral(strike + range)) + %&& primVar "LIBOR.EUR.6M" %> konst (fromIntegral(strike - range))) + (konst 1) (konst 0) + + +ex1 = chooserLeg 80 500 (last dailySch1) dailySch1 + +chooserNote :: [Int] + -> [Int] + -> [Schedule] + -> Contract +chooserNote rangeList strikeList schedules = + allOf + [ chooserLeg range strike (last sch) sch + | (range, strike, sch) <- zip3 rangeList strikeList schedules ] + + + +ex3 :: Contract +ex3 = chooserNote + [80,45,50] + [500,450, 550] + [dailySch1,dailySch2,dailySch3] diff --git a/examples/Common.hs b/examples/Common.hs new file mode 100644 --- /dev/null +++ b/examples/Common.hs @@ -0,0 +1,272 @@ +-- Copyright ©2011 Netrium Ltd. All rights reserved. +module Common where + +import Prelude hiding (and, or, min, max, abs, negate, not, read, all, until) +import Contract +import Data.Time + +-- +-- Common types +-- + +type Price = Obs Double +type Volume = Obs Double + +data Market = Market Commodity Unit Location +data Product = Product Market Schedule + +type Index = Obs Double + +type Schedule = [Time] + + +-- +-- Dates and times +-- + +-- | Midnight on a given day +date :: Integer -> Int -> Int -> Time +date year month day = + UTCTime (fromGregorian year month day) 0 + +-- | A point in time on a given day +datetime :: Integer -> Int -> Int + -> Int -> Int + -> Time +datetime year month day hours minutes = + UTCTime (fromGregorian year month day) + (timeOfDayToTime (TimeOfDay hours minutes 0)) + + +hours, minutes, seconds :: Int -> Duration +seconds s = Duration s +minutes m = seconds (m * 60) +hours h = minutes (h * 60) + + +data DateOffset = DateOffset Int Int Int -- years, months, days + deriving (Eq, Show) + +instance Num DateOffset where + DateOffset y1 m1 d1 + DateOffset y2 m2 d2 = + DateOffset (y1+y2) (m1+m2) (d1+d2) + + DateOffset y1 m1 d1 - DateOffset y2 m2 d2 = + DateOffset (y1-y2) (m1-m2) (d1-d2) + + (*) = error "Multiplying date offsets makes no sense" + + negate (DateOffset y1 m1 d1) = + DateOffset (negate y1) (negate m1) (negate d1) + + abs (DateOffset y1 m1 d1) = + DateOffset (abs y1) (abs m1) (abs d1) + + signum = error "signum is not defines for date offsets" + fromInteger n = DateOffset 0 0 (fromIntegral n) + +offsetDate :: Time -> DateOffset -> Time +offsetDate (UTCTime day tod) (DateOffset y m d) = UTCTime (adj day) tod + where + adj = addDays (fromIntegral d) + . addGregorianMonthsClip (fromIntegral m) + . addGregorianYearsClip (fromIntegral y) + +days, months, quarters, years, seasons :: Int -> DateOffset + +days n = DateOffset 0 0 n +months n = DateOffset 0 n 0 +quarters n = months (3*n) +years n = DateOffset n 0 0 +seasons n = error "TODO: definition for seasons" + + +-- +-- Extra combinators +-- + +allOf :: [Contract] -> Contract +allOf [] = zero +allOf xs = foldr1 and xs + +--anyOneOf :: [(ChoiceLabel, Contract)] -> Contract +--anyOneOf + + +-- +-- Simple trades +-- + +physical :: Volume -> Market -> Contract +physical vol (Market comod unit loc) = + scale vol (one (Physical comod unit loc Nothing)) + +physicalWithDuration :: Volume -> Market -> Duration -> Contract +physicalWithDuration vol (Market comod unit loc) dur = + scale vol (one (Physical comod unit loc (Just dur))) + +financial :: Price -> Currency -> Contract +financial pr cur = + scale pr (one (Financial cur)) + +fixedPrice :: Double -> Price +fixedPrice pr = konst pr + +floatingPrice :: Obs Double -> Price +floatingPrice pr = pr + + +-- +-- More complex trades +-- + +zcb :: Time -> Price -> Currency -> Contract +zcb t pr cur = when (at t) (financial pr cur) + +forward :: FeeCalc + -> Market + -> Volume + -> Price -> Currency + -> Schedule + -> Contract +forward fee market vol pr cur sch = + give (calcFee fee vol pr cur sch) + `and` + allOf + [ when (at t) $ physical vol market + `and` give (financial (vol * pr) cur) + | t <- sch ] + +-- Basic commodity swap: simultaneous swap of commodity A for commodity B for +-- a nominal cost over a delivery schedule (same cost for each delivery period) +commoditySwap :: (Market, Market) + -> (Volume, Volume) + -> Price -> Currency + -> Schedule + -> Contract +commoditySwap (market1, market2) (vol1, vol2) pr cur sch = + allOf + [ when (at t) $ physical vol1 market1 + `and` give (physical vol2 market2 + `and` (financial pr cur)) + | t <- sch ] + + +commoditSwing :: FeeCalc + -> Market + -> Price -> Currency + -> (Volume, Volume, Volume) -- ^ (low, normal, high) delivery volumes + -> Int -- ^ number of exercise times + -> DateOffset -- ^ how far the option is in advance + -> Schedule + -> Contract +commoditSwing fee market pr cur (lowVol,normalVol, highVol) + exerciseCount optTimeDiff sch = + allOf + [ give (calcFee fee normalVol pr cur sch) + , read "count" (konst (fromIntegral exerciseCount)) $ + foldr leg zero sch + ] + where + leg delTime remainder = + when (at optTime) $ + cond (var "count" %<= konst 0) + normal + (or "normal" normal + (or "low-high" low high)) + where + optTime = offsetDate delTime (abs optTimeDiff) + normal = when (at delTime) $ + allOf [ delivery normalVol + , remainder + ] + low = when (at delTime) $ + allOf [ delivery lowVol + , read "count" (var "count" %- konst 1) remainder + ] + high = when (at delTime) $ + allOf [ delivery highVol + , read "count" (var "count" %- konst 1) remainder + ] + + delivery vol = and (physical vol market) + (give (financial (vol * pr) cur)) + + +-- +-- Trade metadata +-- + +newtype CounterParty = CounterParty String deriving (Show, Eq) +newtype Trader = Trader String deriving (Show, Eq) +newtype Book = Book String deriving (Show, Eq) + + +-- +-- Types for margining, fixing, netting, settlement +-- + +type MarginingSchedule = Schedule +type FixingSchedule = Schedule + +type SettlementSchedule = Schedule +type SettlementVolumeVariance = Obs Double +data SettlementAgreement = SettlementAgreement Market SettlementSchedule + +data MarketNettingAgreement = MarketNettingAgreement CounterParty Market +data CrossMarketNettingAgreement = CrossMarketNettingAgreement CounterParty + + +-- +-- Fee calculations +-- + +newtype FeeCalc = FeeCalc (Volume -> Price -> Schedule -> Price) + +calcFee :: FeeCalc + -> Volume -> Price -> Currency -> Schedule + -> Contract +calcFee (FeeCalc fc) vol pr cur sch = financial (fc vol pr sch) cur + +zeroFee :: FeeCalc +zeroFee = FeeCalc $ \_ _ _ -> 0 + +initialMarginFee :: FeeCalc +initialMarginFee = + FeeCalc $ \vol pr sch -> + let numdays = fromIntegral (length sch) + in vol * pr * konst numdays +--TODO: this assumes the schedule has just one entry +-- per-day which may not be true. + +computedFee :: Price -> FeeCalc +computedFee pr = FeeCalc $ \_ _ _ -> pr + +fixedFee :: Double -> FeeCalc +fixedFee = computedFee . konst + +exchangeFee :: Price -> FeeCalc +exchangeFee = computedFee + +andFee :: FeeCalc -> FeeCalc -> FeeCalc +andFee (FeeCalc fc1) (FeeCalc fc2) = + FeeCalc $ \vol pr sch -> fc1 vol pr sch + + fc2 vol pr sch + + +-- +-- Options +-- + +european :: Time -> Contract -> Contract +european exTime c = when (at exTime) $ or "choice" c zero + + +-- +-- Unknown +-- + +type TradedDate = Obs Time + +data Direction = Give | Take + diff --git a/examples/CreditDefaultSwap.contract b/examples/CreditDefaultSwap.contract new file mode 100644 --- /dev/null +++ b/examples/CreditDefaultSwap.contract @@ -0,0 +1,14 @@ +import Calendar +import Swaps + +-- First define the underlying asset, in this example a simple zcb +underlying = zcb (date 2014 06 01) 100000000 (Currency "USD") (CashFlowType "cash") + +-- CDS +-- Notional amount of $10M, 3 yearly payment at a given rate +contract = creditDefaultSwap cEvents 1000000 [date 2012 01 01, date 2013 01 01, date 2014 01 01] (Currency "USD") cpardfRate (CashFlowType "cash") (90/360) underlying +-- 2 credit events in this example: +-- - Bankruptcy, which would cause a physical settlement and a termination of the contract +-- - Failure to pay, which would cause a cash settlement of $1M but not terminate the contract + where cEvents = [("Bankruptcy", True, 'P', 50000000, (Currency "USD"), cparbEvent1), + ("Failure to Pay", False, 'C', 1000000, (Currency "USD"), cparbEvent2) ] diff --git a/examples/CreditDefaultSwap.obsdb.xml b/examples/CreditDefaultSwap.obsdb.xml new file mode 100644 --- /dev/null +++ b/examples/CreditDefaultSwap.obsdb.xml @@ -0,0 +1,6 @@ + + + + + + diff --git a/examples/DarkSpreadOption.contract b/examples/DarkSpreadOption.contract new file mode 100644 --- /dev/null +++ b/examples/DarkSpreadOption.contract @@ -0,0 +1,39 @@ +import Options +import Calendar + +-- Daily exercise at 15:00 on the day preceding the supply day +-- (this is supposed to be on every fourth EEX business day but for now it does every fourth calendar day - to be updated when we have a proper calendar) +contract = commoditySpreadOption "choice" legs + (calendarDaysEarlier calendar 4 <> atTimeOfDay 15 00) + (calendarDaysLater calendar 5) + CallOption + strikePrice gbp (CashFlowType "initialMargin") + premium gbp + where strikePrice = 7 * powerVol + premium = 3 + calendar = getBusinessDayCalendar "EEX Power" + +legs = [coalLeg, carbonLeg, electricityLeg] +months = [1..1] -- Should be [1..12], but cut down to reduce runtime + +-- API2 coal: monthly delivery (assumption is 1st of the month) +coalLeg = + ( Market (Commodity "Coal") (Unit "MWh") (Location "ARA"), coalVol + , coalPrice, (Currency "USD"), (CashFlowType "initialMargin") + , [ [datetime 2011 m 1 0 0 ] | m <- months ] + , exchangeFee 50 + ) + +-- Carbon: yearly certificates split into monthly deliveries at 12:00 +carbonLeg = + ( Market (Commodity "Carbon") (Unit "t") (Location "EU"), carbonVol + , carbonPrice, (Currency "GBP"), (CashFlowType "initialMargin") + , [ [datetime 2011 m 1 12 0 ] | m <- months ] + , exchangeFee 75) + +-- CE Power: delivery every 15 minutes +electricityLeg = + ( Market (Commodity "Electricity") (Unit "MWh") (Location "Amprion HVG"), powerVol + , powerPrice, (Currency "EUR"), (CashFlowType "initialMargin") + , [ [datetime 2011 m d h i | d <- [1..31], h <- [0..23], i <- [0,15,30,45] ] | m <- months ] + , exchangeFee 100 ) diff --git a/examples/DarkSpreadOption.obsdb.xml b/examples/DarkSpreadOption.obsdb.xml new file mode 100644 --- /dev/null +++ b/examples/DarkSpreadOption.obsdb.xml @@ -0,0 +1,9 @@ + + + + + + + + + diff --git a/examples/DarkSpreadOption.timeseries.xml b/examples/DarkSpreadOption.timeseries.xml new file mode 100644 --- /dev/null +++ b/examples/DarkSpreadOption.timeseries.xml @@ -0,0 +1,8 @@ + + + + + + + + diff --git a/examples/DarkSpreadOptionTemplate.hs b/examples/DarkSpreadOptionTemplate.hs new file mode 100644 --- /dev/null +++ b/examples/DarkSpreadOptionTemplate.hs @@ -0,0 +1,105 @@ +module Main where + +import Prelude hiding (and, or, min, max, abs, negate, not, read, until) + +import Contract +import Common +import Options +import Calendar + +import qualified Text.XML.HaXml.XmlContent as XML +import qualified Text.XML.HaXml.Pretty as XML.PP +import qualified Text.PrettyPrint as PP + + +------------------------------------------------------------------------------- +-- Template program main +-- + +main = do + + -- read the contract template parameters from the program stdin + -- one paramater per line, in Haskell 'Read' syntax + -- For this example the following input file would do: + -- + -- 7 + -- 3 + + -- the contract xml is written on program stdout + -- invoke as so: + -- ./DarkSpreadOptionTemplate < templateInputs.txt > contract.xml + + powerPrice <- readLn + premium <- readLn + + let contract = contractTemplate (konst powerPrice) (konst premium) + + putStr (renderXml contract) + +renderXml = PP.renderStyle PP.style { PP.mode = PP.OneLineMode } + . XML.PP.document + . XML.toXml False + +------------------------------------------------------------------------------- +-- Contrac template function itself +-- + +-- Daily exercise at 15:00 on the day preceding the supply day +-- (this is supposed to be on every fourth EEX business day but for now it does every fourth calendar day - to be updated when we have a proper calendar) + +contractTemplate powerPrice premium + = commoditySpreadOption "choice" legs + (workingDaysEarlier calendar 4 <> atTimeOfDay 15 00) + (workingDaysLater calendar 5) + CallOption + strikePrice (Currency "GBP") (CashFlowType "initialMargin") + premium (Currency "GBP") + where strikePrice = powerPrice * powerVol + calendar = getCalendar "EEX Power" + +legs = [coalLeg, carbonLeg, electricityLeg] + +-- API2 coal: monthly delivery (assumption is 1st of the month) +coalLeg = + ( Market (Commodity "Coal") (Unit "MWh") (Location "ARA"), coalVol + , coalPrice, (Currency "USD"), (CashFlowType "initialMargin") + , [ [datetime 2011 m 1 0 0 ] | m <- [1..12] ] + , exchangeFee 50 + ) + +-- Carbon: yearly certificates split into monthly deliveries at 12:00 +carbonLeg = + ( Market (Commodity "Carbon") (Unit "t") (Location "EU"), carbonVol + , carbonPrice, (Currency "GBP"), (CashFlowType "initialMargin") + , [ [datetime 2011 m 1 12 0 ] | m <- [1..12] ] + , exchangeFee 75) + +-- CE Power: delivery every 15 minutes +electricityLeg = + ( Market (Commodity "Electricity") (Unit "MWh") (Location "Amprion HVG"), powerVol + , powerPrice, (Currency "EUR"), (CashFlowType "initialMargin") + , [ [datetime 2011 m d h i | d <- [1..31], h <- [0..23], i <- [0,15,30,45] ] | m <- [1] ] + , exchangeFee 100 ) + + +------------------------------------------------------------------------------- +-- Generated +-- + +-- This part would be generated automatically by a variation of the normalise +-- program. For ordinary (non-template) contracts the normalise program +-- generate these automatically. We will eventually want something similar for +-- templates. + +coalVol :: Obs Double +coalVol = primVar "coalVol" +coalPrice :: Obs Double +coalPrice = primVar "coalPrice" +carbonVol :: Obs Double +carbonVol = primVar "carbonVol" +carbonPrice :: Obs Double +carbonPrice = primVar "carbonPrice" +powerVol :: Obs Double +powerVol = primVar "powerVol" +powerPrice :: Obs Double +powerPrice = primVar "powerPrice" diff --git a/examples/DemoContractAST.hs b/examples/DemoContractAST.hs new file mode 100644 --- /dev/null +++ b/examples/DemoContractAST.hs @@ -0,0 +1,318 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module DemoContractAST where + +import Data.Time +import Data.List (transpose) +import Data.Monoid (Monoid (..)) +import System.Locale +import Text.XML.HaXml.Types +import Text.XML.HaXml.XmlContent.Parser + +import Common (DiffDateTime, adjustDateTime, DateTime, FeeCalc) +import Calendar + +newtype Location = Location String deriving Show +newtype Commodity = Commodity String deriving Show + +type Volume = Double +type Price = Double + +data Market = Market Commodity Unit Location deriving Show + +data OptionDirection = CallOption | PutOption deriving Show + +newtype Unit = Unit String deriving Show +newtype Currency = Currency String deriving Show +newtype CashFlowType = CashFlowType String deriving Show + +data Product a = Product a DeliverySchedule deriving Show + +type SegmentedSchedule = [DeliverySchedule] +newtype DeliverySchedule = DeliverySchedule [DeliveryScheduleBlock] deriving (Monoid, Show) + +data DeliveryScheduleBlock = DeliveryScheduleBlock + { startDateTime :: DateTime + , endDateTime :: DateTime + , deliveryDays :: [DateTime] + , deliveryShape :: DeliveryShape + } deriving Show + +deliverySchedule :: DateTime -> DateTime + -> Calendar -- ^ What days to deliver on + -> DeliveryShape + -> DeliverySchedule +deliverySchedule start end cal shape = + DeliverySchedule [DeliveryScheduleBlock start end days shape] + where + days = calendarDaysInPeriod cal (start, end) + +newtype DeliveryShape = DeliveryShape [DiffTime] deriving (Monoid, Show) + +deliverAtTimeOfDay :: Int -> Int -> DeliveryShape +deliverAtTimeOfDay hour minute = DeliveryShape + [timeOfDayToTime (TimeOfDay hour minute 0)] + +deliverAtMidnight :: DeliveryShape +deliverAtMidnight = deliverAtTimeOfDay 0 0 + +complexDeliveryShape :: [DeliveryShape] -> DeliveryShape +complexDeliveryShape = mconcat + +data Contract + = NamedContract String Contract + | AndContract [Contract] + | GiveContract Contract + | ProductBasedContract ProductBasedContract + | OptionContract + { optionDirection :: OptionDirection + , premium :: PremiumPrice + , exerciseDetails :: ExerciseDetails + , underlying :: Contract + } + deriving Show + +data ProductBasedContract + = PhysicalContract Double (Product Market) + | FinancialContract Double (Product Currency) (Maybe CashFlowType) + deriving Show + +type StrikePrice = (Double, Currency) +type PremiumPrice = (Double, Currency) + +data ExerciseDetails + = European StrikePrice (DateTime, DateTime) + | American StrikePrice (DateTime, DateTime) + | Bermudan StrikePrice [(DateTime, DateTime)] Int + deriving Show + +-------------------------------------------------------------------------------- + + +forward :: FeeCalc -- ^Fees + -> Market -- ^Market, e.g. NBP Gas + -> Volume -- ^Notional volume + -> Price -- ^Price + -> Currency -- ^Payment currency + -> CashFlowType -- ^Cashflow type + -> DeliverySchedule -- ^Schedule for physical settlement + -> DeliverySchedule -- ^Schedule for financial settlement + -> Contract +forward _fee market vol pr cur cft pSch fSch = NamedContract "Forward" $ + AndContract [ ProductBasedContract physicalLeg + , GiveContract $ ProductBasedContract financialLeg] + where + physicalLeg = PhysicalContract vol physicalProduct + physicalProduct = Product market pSch + financialLeg = FinancialContract (vol * pr) financialProduct (Just cft) + financialProduct = Product cur fSch + + +-- * Option template +-- | Basic option template. Flexibility is achieved through 'ExerciseDetails'. +option :: ExerciseDetails -- ^Details of when and at what price the option can be exercised + -> OptionDirection -- ^Direction of the option (call or put) + -> PremiumPrice + -> Contract -- ^Underlying asset + -> Contract +option exerciseDetails direction premium underlyingContract = + OptionContract direction premium exerciseDetails underlyingContract + +namedContract :: String -> Contract -> Contract +namedContract = NamedContract + +europeanExercise :: (DateTime, DateTime) -> StrikePrice -> ExerciseDetails +europeanExercise = flip European + +americanExercise :: (DateTime, DateTime) -> StrikePrice -> ExerciseDetails +americanExercise = flip American + +allOf :: [Contract] -> Contract +allOf = AndContract + + +commoditySpreadOption :: + [( Market + , Volume + , Price, Currency, CashFlowType + , SegmentedSchedule + , FeeCalc + )] -- ^List of underlying legs + -> DiffDateTime -- ^Exercise start date offset (relative to leg) + -> DiffDateTime -- ^Exercise stop date offset (relative to leg) + -> OptionDirection -- ^Option direction (put or call) + -> StrikePrice -- ^Strike price of the option + -> CashFlowType -- ^Cashflow type of the strike price + -> PremiumPrice + -> Contract +commoditySpreadOption legs exerciseDiffTimeStart exerciseDiffTimeStop opDir strikePrice cftype premium = + allOf + [ legOption groupedLeg $ + allOf [ forward fee m vol pr cur cft seg seg + | (m, vol, pr, cur, cft, seg, fee) <- groupedLeg ] + | groupedLeg <- groupedLegs ] + + where + groupedLegs :: [[(Market, Volume, Price, Currency, CashFlowType, DeliverySchedule, FeeCalc)]] + groupedLegs = + transpose + [ [ (m, vol, pr, cur, cft, seg, fee) | seg <- sch ] + | (m, vol, pr, cur, cft, sch, fee) <- legs ] + + legOption :: [(Market, Volume, Price, Currency, CashFlowType, DeliverySchedule, FeeCalc)] -> Contract -> Contract + legOption groupedLeg underlying = + option exerciseDetails opDir premium underlying + + where + exerciseDetails = europeanExercise exerciseTime strikePrice + exerciseTime = ( adjustDateTime earliestDeliveryTime exerciseDiffTimeStart + , adjustDateTime earliestDeliveryTime exerciseDiffTimeStop + ) + where + earliestDeliveryTime = + minimum [ earliestDelivery seg | (_, _, _, _, _, seg, _) <- groupedLeg ] + +earliestDelivery :: DeliverySchedule -> DateTime +earliestDelivery (DeliverySchedule blocks) = + minimum [ day | block <- blocks, day <- deliveryDays block] + +-------------------------------------------------------------------------------- + +toXml :: XmlContent' a => Bool -> a -> Document () +toXml _ value = + Document (Prolog (Just (XMLDecl "1.0" Nothing Nothing)) + [] Nothing []) + emptyST + ( case toContents' value of + [] -> Elem "empty" [] [] + [CElem e ()] -> e + (CElem _ ():_) -> error "too many XML elements in document" ) + [] + +class XmlContent' a where + toContents' :: a -> [Content ()] + +instance XmlContent' Contract where + toContents' (NamedContract name contract) = + [ CElem (Elem "Contract" [mkAttr "type" name] (toContents' contract)) () ] + toContents' (AndContract contracts) = + [ mkElemC "And" (concatMap toContents' contracts) ] + toContents' (GiveContract contract) = + [ mkElemC "Give" (toContents' contract) ] + toContents' (ProductBasedContract contract) = + toContents' contract + toContents' (OptionContract dir (premiumQty, premiumCcy) det und) = + [ mkElemC "Option" $ concat + [ toContents' dir + , toContents' det + , [ mkElemC "Premium" $ concat + [ [ mkElemC "Quantity" (toText . show $ premiumQty) ] + , toContents' premiumCcy + ] + ] + , [ mkElemC "Underlying" (toContents' und) ] + ] + ] + +instance XmlContent' OptionDirection where + toContents' CallOption = [mkElemC "OptionDirection" $ toText "Call"] + toContents' PutOption = [mkElemC "OptionDirection" $ toText "Put"] + +instance XmlContent' ExerciseDetails where + toContents' (European strike window) = + [ CElem (Elem "ExerciseDetails" [mkAttr "type" "European"] $ concat + [ [ mkExerciseWindow [window] + , mkStrikePrice strike + , mkElemC "Premium" [] ] + ]) () ] + toContents' (American strike window) = + [ CElem (Elem "ExerciseDetails" [mkAttr "type" "American"] $ concat + [ [ mkExerciseWindow [window] + , mkStrikePrice strike + , mkElemC "Premium" [] ] + ]) () ] + toContents' (Bermudan strike windows _limit) = + [ CElem (Elem "ExerciseDetails" [mkAttr "type" "American"] $ concat + [ [ mkExerciseWindow windows + , mkStrikePrice strike + , mkElemC "Premium" [] ] + ]) () ] + +mkStrikePrice (strikeQty, strikeCcy) = + mkElemC "StrikePrice" $ concat + [ [ mkElemC "Quantity" (toText . show $ strikeQty) ] + , toContents' strikeCcy + ] + +mkExerciseWindow :: [(DateTime, DateTime)] -> Content () +mkExerciseWindow windows = + mkElemC "ExerciseWindow" $ map mkExerciseWindowElement windows + +mkExerciseWindowElement :: (DateTime, DateTime) -> Content () +mkExerciseWindowElement (startDateTime, endDateTime) = + mkElemC "ExerciseWindowElement" + [ mkElemC "StartDateTime" $ toText . showDate $ startDateTime + , mkElemC "EndDateTime" $ toText . showDate $ endDateTime + ] + +instance XmlContent' Currency where + toContents' (Currency ccy) = [mkElemC "Currency" (toText ccy)] + +instance XmlContent' ProductBasedContract where + toContents' (PhysicalContract qty prod) = + [ CElem (Elem "Contract" [mkAttr "type" "Physical"] $ concat + [ toContents' prod + , [ mkElemC "Quantity" $ toText . show $ qty ] + ]) () ] + -- TODO: Is there a need for the mCashFlowType here? + toContents' (FinancialContract qty prod _mCashFlowType) = + [ CElem (Elem "Contract" [mkAttr "type" "Financial"] $ concat + [ toContents' prod + , [ mkElemC "Quantity" $ toText . show $ qty ] + ]) () ] + +instance XmlContent' a => XmlContent' (Product a) where + toContents' (Product market schedule) = + [ mkElemC "Product" $ toContents' market ++ toContents' schedule ] + +instance XmlContent' Market where + toContents' (Market commodity unit location) = + [ mkElemC "Market" $ concat + [ toContents' commodity + , toContents' unit + , toContents' location + ] + ] + +instance XmlContent' Commodity where + toContents' (Commodity commodity) = [mkElemC "Commodity" $ toText commodity ] + +instance XmlContent' Unit where + toContents' (Unit unit) = [mkElemC "Unit" $ toText unit ] + +instance XmlContent' Location where + toContents' (Location location) = [mkElemC "Location" $ toText location ] + +instance XmlContent' DeliverySchedule where + toContents' (DeliverySchedule scheds) = + [ mkElemC "DeliverySchedule" $ concatMap toContents' scheds ] + +instance XmlContent' DeliveryScheduleBlock where + toContents' (DeliveryScheduleBlock startDateTime endDateTime days shape) = + [ mkElemC "DeliveryScheduleElement" $ concat + [ [ mkElemC "StartDateTime" $ toText . showDate $ startDateTime ] + , [ mkElemC "EndDateTime" $ toText . showDate $ endDateTime ] + , map (mkElemC "DeliveryDay" . toText . showDay) days + , toContents' shape + ] + ] + +instance XmlContent' DeliveryShape where + toContents' (DeliveryShape times) = + [ mkElemC "DeliveryShape" $ concatMap + (return . mkElemC "DeliveryShapeElement" . toText . showTime) times + ] + +showDate = formatTime defaultTimeLocale "%d/%m/%Y %H:%M:%S" +showDay = formatTime defaultTimeLocale "%d/%m/%Y" +showTime = formatTime defaultTimeLocale "%H:%M:%S" . timeToTimeOfDay diff --git a/examples/DirtySparkSpreadOption.hs b/examples/DirtySparkSpreadOption.hs new file mode 100644 --- /dev/null +++ b/examples/DirtySparkSpreadOption.hs @@ -0,0 +1,96 @@ +module Main where + +import Prelude hiding (and, or, min, max, abs, negate, not, read, until) + +import DemoContractAST +import Contract (Obs, primVar) +import Common (atTimeOfDay, date, datetime, exchangeFee, (<>)) +-- import Options (OptionDirection(CallOption)) +import Calendar + +import qualified Text.XML.HaXml.XmlContent as XML +import qualified Text.XML.HaXml.Pretty as XML.PP +import qualified Text.PrettyPrint as PP + +------------------------------------------------------------------------------- +-- Contract template function itself +-- + +-- Daily exercise at 15:00 on the day preceding the supply day +-- (this is supposed to be on every fourth EEX business day but for now it does every fourth calendar day - to be updated when we have a proper calendar) + +contract + = namedContract "Commodity Spread Option" $ commoditySpreadOption legs + (calendarDaysEarlier calendar 4 <> atTimeOfDay 07 00) + (calendarDaysEarlier calendar 4 <> atTimeOfDay 15 00) + CallOption + strike + (CashFlowType "initialMargin") + premium + where calendar = getBusinessDayCalendar "EEX Power" + strike = (strikePrice, Currency "GBP") + strikePrice = powerPrice * powerVol + premium = (2, Currency "GBP") + +coalVol :: Double +coalVol = 5000 +coalPrice :: Double +coalPrice = 12 +carbonVol :: Double +carbonVol = 100 +carbonPrice :: Double +carbonPrice = 70 +powerVol :: Double +powerVol = 50 +powerPrice :: Double +powerPrice = 16 + +legs = [coalLeg, carbonLeg, electricityLeg] + +-- API2 coal: monthly delivery (assumption is 1st of the month) +coalLeg = + ( Market (Commodity "Coal") (Unit "MWh") (Location "ARA"), coalVol + , coalPrice, (Currency "USD"), (CashFlowType "initialMargin") + , [ schedule ] + , exchangeFee 50 + ) + where + schedule = deliverySchedule (date 2011 1 1) (date 2011 12 31) + calendar deliverAtMidnight + calendar = newCalendar "carbonCalendar" [(date 2011 m 1, BusinessDay) | m <- [1..12]] + +-- Carbon: yearly certificates split into monthly deliveries at 12:00 +carbonLeg = + ( Market (Commodity "Carbon") (Unit "t") (Location "EU"), carbonVol + , carbonPrice, (Currency "EUR"), (CashFlowType "initialMargin") + , [ schedule ] + , exchangeFee 75) + where + schedule = deliverySchedule (date 2011 1 1) (date 2011 12 31) + calendar deliverAtMidnight + calendar = newCalendar "carbonCalendar" [(date 2011 m 1, BusinessDay) | m <- [1..12]] + +-- CE Power: delivery every 15 minutes +electricityLeg = + ( Market (Commodity "Electricity") (Unit "MWh") (Location "Amprion HVG"), powerVol + , powerPrice, (Currency "GBP"), (CashFlowType "initialMargin") + , [ schedule ] + , exchangeFee 100 ) + where + calendar = getBusinessDayCalendar "EEX Power" + schedule = deliverySchedule (date 2011 1 1) (date 2011 12 31) + calendar shape + shape = complexDeliveryShape [deliverAtTimeOfDay h m | h <- [0..23], m <- [0,15,30,45]] + + +------------------------------------------------------------------------------- +-- Template program main +-- + +main = do + putStr (renderXml contract) + where + -- renderXml = show + renderXml = PP.renderStyle PP.style { PP.mode = PP.OneLineMode } + . XML.PP.document + . toXml False diff --git a/examples/FXBarrierOption.contract b/examples/FXBarrierOption.contract new file mode 100644 --- /dev/null +++ b/examples/FXBarrierOption.contract @@ -0,0 +1,21 @@ +import Options + +-- Knockin down and in call option with european exercise. + +contract = option "selection[exercise-option]" exerciseDetails CallOption 100 (Currency "EUR") underlying + where + + exerciseDetails = + barrierDownAndIn cpardUSDEUR floorPrice $ + europeanExercise (date 2011 06 01) strikePrice + + underlying strikePrice = + allOf[ + financial 10000 (Currency "USD") (CashFlowType "cash"), + give $ financial 6500 (Currency "EUR") (CashFlowType "cash") + ] + + strikePrice = 2.5 * quantity + quantity = 10 + floorPrice = 0.7 + diff --git a/examples/FXBarrierOption.obsdb.xml b/examples/FXBarrierOption.obsdb.xml new file mode 100644 --- /dev/null +++ b/examples/FXBarrierOption.obsdb.xml @@ -0,0 +1,4 @@ + + + + diff --git a/examples/ForwardTrade1.contract b/examples/ForwardTrade1.contract new file mode 100644 --- /dev/null +++ b/examples/ForwardTrade1.contract @@ -0,0 +1,9 @@ + +contract = + forward + (initialMarginFee <> exchangeFee 100) + (Market gas thm nbp) + vol1 + 0.45 gbp cash + [ date 2011 1 d | d <- [2..3] ] + [ date 2011 1 d | d <- [2..3] ] diff --git a/examples/ForwardTrade1.obsdb.xml b/examples/ForwardTrade1.obsdb.xml new file mode 100644 --- /dev/null +++ b/examples/ForwardTrade1.obsdb.xml @@ -0,0 +1,4 @@ + + + + diff --git a/examples/ForwardTrade1.timeseries.xml b/examples/ForwardTrade1.timeseries.xml new file mode 100644 --- /dev/null +++ b/examples/ForwardTrade1.timeseries.xml @@ -0,0 +1,18 @@ + + + + + + + + + 3 + + + + + + diff --git a/examples/ForwardTrade2.contract b/examples/ForwardTrade2.contract new file mode 100644 --- /dev/null +++ b/examples/ForwardTrade2.contract @@ -0,0 +1,31 @@ + +contract = + forward' + (initialMarginFee <> exchangeFee 100) + (Market gas thm nbp) + vol1 + 0.45 gbp cash + -- delivering gas every 30 minutes, with a 30 min duration. + [ datetime 2011 1 day hour min + | day <- [1..31] + , hour <- [0..23] + , min <- [0, 30] ] + (duration 0 30 0) + + +forward' :: FeeCalc + -> Market + -> Volume + -> Price -> Currency -> CashFlowType + -> Schedule -> Duration + -> Contract +forward' fee market vol pr cur cft sch dur = + give (calcFee fee vol pr cur sch) + `and` + allOf + [ when (at t) $ physicalWith vol market (withDuration dur) + `and` give (financial (vol * pr) cur cft) + | t <- sch ] + + + diff --git a/examples/ForwardTrade2.obsdb.xml b/examples/ForwardTrade2.obsdb.xml new file mode 100644 --- /dev/null +++ b/examples/ForwardTrade2.obsdb.xml @@ -0,0 +1,4 @@ + + + + diff --git a/examples/ForwardTrade2.timeseries.xml b/examples/ForwardTrade2.timeseries.xml new file mode 100644 --- /dev/null +++ b/examples/ForwardTrade2.timeseries.xml @@ -0,0 +1,18 @@ + + + + + + + + + 3 + + + + + + diff --git a/examples/GasSwing.contract b/examples/GasSwing.contract new file mode 100644 --- /dev/null +++ b/examples/GasSwing.contract @@ -0,0 +1,54 @@ + +contract = + gasSwing + (initialMarginFee <> exchangeFee 100) + (Market gas thm nbp) + (900, 1000, 1100) + 0.45 gbp cash + 1 + [ (datetime 2011 1 (d-1) 16 00, date 2011 1 d) | d <- [2..3] ] + + +----------------------------------------------------------------------- + +--TODO: change this to use the ordinary Schedule type, +-- and calculate the option time differently: +type Schedule' = [(Time, Time)] -- option time, delivery time + +gasSwing :: FeeCalc + -> Market + -> (Volume, Volume, Volume) -- ^ (low, normal, high) delivery volumes + -> Price -> Currency -> CashFlowType + -> Int -- ^ number of exercise times + -> Schedule' + -> Contract +gasSwing fee market (lowVol,normalVol, highVol) pr cur cft exerciseCount sch = + allOf [ give (calcFee fee normalVol pr cur (map snd sch)) + , letin "count" (konst (fromIntegral exerciseCount)) $ \count0 -> + foldr leg (\_ -> zero) sch count0 + ] + + where + leg (optTime, delTime) remainder count = + when (at optTime) $ + cond (count %<= 0) + normal + (or "normal" normal + (or "low-high" low high)) + where + normal = when (at delTime) $ + allOf [ delivery normalVol + , remainder count + ] + low = when (at delTime) $ + allOf [ delivery lowVol + , letin "count" (count - 1) (\count' -> remainder count') + ] + high = when (at delTime) $ + allOf [ delivery highVol + , letin "count" (count - 1) (\count' -> remainder count') + ] + + delivery vol = and (physical vol market) + (give (financial (vol * pr) cur cft)) + diff --git a/examples/GasSwing.timeseries.xml b/examples/GasSwing.timeseries.xml new file mode 100644 --- /dev/null +++ b/examples/GasSwing.timeseries.xml @@ -0,0 +1,18 @@ + + + + + + + + + + + + + + + + + + diff --git a/examples/IndexAmortisingSwap.contract b/examples/IndexAmortisingSwap.contract new file mode 100644 --- /dev/null +++ b/examples/IndexAmortisingSwap.contract @@ -0,0 +1,8 @@ +import Common +import Observable +import Swaps + +cSch = [mkdate 2011 m 31 | m <- [3,6,9,12] ] +amortTable = [(300, 1.0), (500, 0.6), (600, 0.4), (800, 0.2), (1200, 0.1)] + +contract = indexAmortisingSwap 6000000 cSch (Currency "EUR", Currency "EUR") (CashFlowType "initialMargin", CashFlowType "initialMargin") amortTable (90/360) (primVar "USD.LIBOR.6M") (primVar "USD.LIBOR.SPOT") diff --git a/examples/IndexAmortisingSwap.timeseries.xml b/examples/IndexAmortisingSwap.timeseries.xml new file mode 100644 --- /dev/null +++ b/examples/IndexAmortisingSwap.timeseries.xml @@ -0,0 +1,27 @@ + + + + + + + + + 3 + + + + + + 4 + + + + + + + diff --git a/examples/JulienExample.hs b/examples/JulienExample.hs new file mode 100644 --- /dev/null +++ b/examples/JulienExample.hs @@ -0,0 +1,37 @@ +import Contract +import Common +import Options +import Data.List (transpose) + +commoditySpreadOption :: ChoiceId + -> [( Market + , Volume + , Price, Currency, CashFlowType + , SegmentedSchedule + , FeeCalc )] + -> DiffDateTime + -> OptionDirection + -> StrikePrice + -> Contract +commoditySpreadOption cid legs optionDiffTime opDir strikePrice = + allOf + [ legOption groupedLeg $ \strikePrice -> + -- do something here with strikePrice, else it's never used! + allOf [ forward fee m pr cur cft vol seg + | (m, pr, cur, cft, vol, seg, fee) <- groupedLeg ] + | groupedLeg <- groupedLegs ] + + where + groupedLegs = + transpose + [ [ (m, pr, cur, cft, vol, seg, fee) | seg <- sch ] + | (m, pr, cur, cft, vol, sch, fee) <- legs ] + + legOption groupedLeg = + option cid (europeanExercise (optionTime groupedLeg) strikePrice) opDir + + optionTime groupedLeg = + adjustDateTime earliestDeliveryTime optionDiffTime + where + earliestDeliveryTime = + minimum [ t | (_, _, _, _, _, (t:_), _) <- groupedLeg ] diff --git a/examples/Observables.obsdb.xml b/examples/Observables.obsdb.xml new file mode 100644 --- /dev/null +++ b/examples/Observables.obsdb.xml @@ -0,0 +1,5 @@ + + + + diff --git a/examples/OilSwapTrade.contract b/examples/OilSwapTrade.contract new file mode 100644 --- /dev/null +++ b/examples/OilSwapTrade.contract @@ -0,0 +1,10 @@ + +import Swaps + +contract = + commoditySwap + ((Market gasoil bbl us), (Market brentoil bbl uk)) + (vol1, vol2) + 5000 gbp cash + [ date 2011 m 20 | m <- [1..12] ] + diff --git a/examples/OilSwapTrade.obsdb.xml b/examples/OilSwapTrade.obsdb.xml new file mode 100644 --- /dev/null +++ b/examples/OilSwapTrade.obsdb.xml @@ -0,0 +1,5 @@ + + + + + diff --git a/examples/OilSwapTrade.timeseries.xml b/examples/OilSwapTrade.timeseries.xml new file mode 100644 --- /dev/null +++ b/examples/OilSwapTrade.timeseries.xml @@ -0,0 +1,23 @@ + + + + + + + + + 3 + + + + + + 4 + + + + + diff --git a/examples/Option.contract b/examples/Option.contract new file mode 100644 --- /dev/null +++ b/examples/Option.contract @@ -0,0 +1,32 @@ +import Options + +contract = + option "opt" exerciseDetails CallOption emptyOptionAttrs underlying + + where + -- note that the underlying contract describes *both* what we recieve and + -- how much we pay for it (which depends on the strike price). + -- of course for a vanilla european option the strike price is fixed, + -- but with something like an asian option, it's calculated, + -- which is why here the strike price is a paramater to underlying rather + -- than us just using the 'strikePrice' variable defined below. + + underlying sp = physical quantity (Market gas thm nbp) + `and` give (financial (sp * quantity) gbp cash) + quantity = 10 + + -- Note also, that this 'sp' (strike price) paramater can be used as the + -- basis for multiple cash flows, e.g. regular payments, rather than just + -- a payment at the time the option is exercised. + + + -- here we have a barrier condition on a different index to the price of + -- the underlying, the barrier is based on the temperature where as the + -- the underlying is for gas. + + exerciseDetails = + barrierDownAndIn temperatureUK floorTemp $ + europeanExercise (date 2011 06 01) strikePrice + + strikePrice = 2.5 + floorTemp = 5 --degrees diff --git a/examples/Option.obsdb.xml b/examples/Option.obsdb.xml new file mode 100644 --- /dev/null +++ b/examples/Option.obsdb.xml @@ -0,0 +1,4 @@ + + + + diff --git a/examples/Option.timeseries.xml b/examples/Option.timeseries.xml new file mode 100644 --- /dev/null +++ b/examples/Option.timeseries.xml @@ -0,0 +1,21 @@ + + + + + + + + 6 + 5 + 6 + + + + + + + + + + + diff --git a/examples/Product1.contract b/examples/Product1.contract new file mode 100644 --- /dev/null +++ b/examples/Product1.contract @@ -0,0 +1,30 @@ +import ScheduledProduct +import Calendar + +contract = + scheduledProductRelative (date 2011 08 01) vol productUkPowerDayAheadPeak + where + -- the volume is specified at the point when the product is acquired + vol = 30 + + +productUkPowerDayAheadPeak :: ScheduledProductRelative Volume +productUkPowerDayAheadPeak = + defineScheduledProductRelative + (\vol -> physical vol (Market electricity mwh uk)) + (relativeDeliverySchedule + (daysLater 1) -- first day + (daysLater 1) -- last day (same for single day product) + cal + deliveryShape) + + where + -- should the volume be part of the product or should it be specified at + -- the point when the product is acquired? + vol = 30 + + cal = getBusinessDayCalendar "EEX Power" + + -- half hour delivery between 7am -- 7pm (last delivery at 6:30pm) + deliveryShape = + complexDeliveryShape [ deliverAtTimeOfDay hr ms | hr <- [7..18], ms <- [0,30] ] diff --git a/examples/Product1.timeseries.xml b/examples/Product1.timeseries.xml new file mode 100644 --- /dev/null +++ b/examples/Product1.timeseries.xml @@ -0,0 +1,8 @@ + + + + + + + + diff --git a/examples/SparkSpreadOption.contract b/examples/SparkSpreadOption.contract new file mode 100644 --- /dev/null +++ b/examples/SparkSpreadOption.contract @@ -0,0 +1,41 @@ +import Options + +-- Daily exercise at 9:00 on the day preceding the supply day +-- (this is supposed to be on every EEX business day but for now it does every calendar day - to be updated when we have a proper calendar) +contract = commoditySpreadOption "choice" + legs + exerciseDate + paymentDate + CallOption + strikePrice gbp (CashFlowType "initialMargin") + premium gbp + where + strikePrice = 2 * powerVol + exerciseDate = daysEarlier 1 <> atTimeOfDay 9 00 + paymentDate = exerciseDate + premium = 0 + + legs = [gasLeg, carbonLeg, electricityLeg] + +-- TTF gas: daily delivery at 6:00 CET +-- All months have 31 days - to be updated when we have a proper calendar +gasLeg = + ( Market (Commodity "Gas") (Unit "MWh") (Location "TTF"), gasVol + , gasPrice, (Currency "GBP"), (CashFlowType "initialMargin") + , [ [datetime 2011 m d 6 0 ] | m <- [1..12], d <- [1..31] ] + , exchangeFee 50 + ) + +-- Carbon: yearly certificates split into daily deliveries at 12:00 +carbonLeg = + ( Market (Commodity "Carbon") (Unit "t") (Location "EU"), carbonVol + , carbonPrice, (Currency "GBP"), (CashFlowType "initialMargin") + , [ [datetime 2011 m d 12 0 ] | m <- [1..12], d <- [1..31] ] + , exchangeFee 75) + +-- CE Power: delivery every 15 minutes +electricityLeg = + ( Market (Commodity "Electricity") (Unit "MWh") (Location "Amprion HVG"), powerVol + , powerPrice, (Currency "EUR"), (CashFlowType "initialMargin") + , [ [datetime 2011 m d h i | h <- [0..23], i <- [0,15,30,45] ] | m <- [1], d <- [1..31] ] + , exchangeFee 100 ) diff --git a/examples/SparkSpreadOption.obsdb.xml b/examples/SparkSpreadOption.obsdb.xml new file mode 100644 --- /dev/null +++ b/examples/SparkSpreadOption.obsdb.xml @@ -0,0 +1,11 @@ + + + + + + + + + + + diff --git a/examples/SparkSpreadOption.timeseries.xml b/examples/SparkSpreadOption.timeseries.xml new file mode 100644 --- /dev/null +++ b/examples/SparkSpreadOption.timeseries.xml @@ -0,0 +1,14 @@ + + + + + + + + + + + + + + diff --git a/examples/Test.contract b/examples/Test.contract new file mode 100644 --- /dev/null +++ b/examples/Test.contract @@ -0,0 +1,20 @@ + +contract = ex3 + +ex2 = anytime "%1" (between (date 2011 1 2) (date 2011 1 3) + %|| between (date 2011 1 5) (date 2011 1 6)) (one quid) + +ex3 = anytime "%1" foo (one quid) +ex4 = anytime "%1" (konst True) (one quid) + +ex5 = until (at (date 2011 1 2)) + (anytime "%1" foo (one quid)) + +ex6 = or "%1" (one quid) + (scale (konst 3) (one quid)) + + +ex7 = cond foo (one quid) + (scale (konst 2) (one quid)) + +quid = Financial gbp cash Nothing diff --git a/examples/Test.obsdb.xml b/examples/Test.obsdb.xml new file mode 100644 --- /dev/null +++ b/examples/Test.obsdb.xml @@ -0,0 +1,4 @@ + + + + diff --git a/examples/Test.timeseries.xml b/examples/Test.timeseries.xml new file mode 100644 --- /dev/null +++ b/examples/Test.timeseries.xml @@ -0,0 +1,62 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + %1 + foo + + + gbpcash + + + 1.0 + + + + + + + diff --git a/examples/Units.db.xml b/examples/Units.db.xml new file mode 100644 --- /dev/null +++ b/examples/Units.db.xml @@ -0,0 +1,42 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/examples/VarianceSwap.contract b/examples/VarianceSwap.contract new file mode 100644 --- /dev/null +++ b/examples/VarianceSwap.contract @@ -0,0 +1,14 @@ +import Calendar +import Swaps + +-- Variance swap +contract = varianceSwap strikePrice vegaAmount varianceAmount + [date 2011 01 01, date 2011 01 06] + (primVar "SPX Index") [10,11,10.5,13,15] + (Currency "USD") (CashFlowType "cash") + (daysLater 3) calendar + where + strikePrice = 16 + vegaAmount = 100000 + varianceAmount = vegaAmount / (strikePrice * 2) + calendar = getBusinessDayCalendar "EEX Power" diff --git a/examples/VarianceSwap.timeseries.xml b/examples/VarianceSwap.timeseries.xml new file mode 100644 --- /dev/null +++ b/examples/VarianceSwap.timeseries.xml @@ -0,0 +1,8 @@ + + + + + + + + diff --git a/examples/WeatherContingent.contract b/examples/WeatherContingent.contract new file mode 100644 --- /dev/null +++ b/examples/WeatherContingent.contract @@ -0,0 +1,141 @@ + +contract = + weatherContingentMonthLeg + monthlyPremium buyersAggregateLimitAmount sellersAggregateLimitAmount + notionalAmount dailyDeductable weatherIndex gasIndexStrikeLevel + previousAggregatePayment + dailySch calcDate + where + monthlyPremium = 10 + buyersAggregateLimitAmount = m 14.5 + sellersAggregateLimitAmount = m 11 + notionalAmount = k 330 + dailyDeductable = k 137.5 + gasIndexStrikeLevel = 80 + previousAggregatePayment = konst 0 + weatherIndex = [ 4.03, 4.02, 4.01 ] + dailySch = [ date 2011 1 d | d <- [1..3] ] + calcDate = date 2011 2 5 + +m = (*1000000) +k = (*1000) + +----------------------------------------------------------------------- + +weatherContingentMonthLeg + monthlyPremium buyersAggregateLimitAmount sellersAggregateLimitAmount + notionalAmount dailyDeductable + weatherIndexStrikeSchedule gasIndexStrikeLevel + previousAggregatePayment + dailySch calcDate = + + foldr daily monthEnd (zip dailySch weatherIndexStrikeSchedule) (konst 0) + + where + daily (day, weatherIndexStrikeLevel) next dailyPaymentSum = + when (at day) $ + letin "dailyPaymentSum" + (dailyPaymentSum + %+ dailyPayment notionalAmount dailyDeductable + weatherIndexStrikeLevel gasIndexStrikeLevel) + (\dailyPaymentSum' -> next dailyPaymentSum') + + monthEnd dailyPaymentSum = + when (at calcDate) $ + financial paymentDue gbp cash + + where + -- Aggregate Payment Amount: + -- For a given Calculation Date, if the sum of the Daily Payment Amounts in + -- the period from the Effective Date to the last Day of the month prior to + -- such Calculation Date is: + -- (i) positive, then the Aggregate Payment Amount will equal the minimum + -- of; (a) the sum of the Daily Payment Amounts, and (b) the Buyer's + -- Aggregate Limit Amount, or + -- + -- (ii) negative, then the Aggregate Payment Amount will equal the maximum + -- of (a) the sum of the Daily Payment Amounts, and (b) the Seller's + -- Aggregate Limit Amount multiplied by negative one. + -- + aggregatePayment = + ifthen (dailyPaymentSum %>= konst 0) + (min dailyPaymentSum (konst buyersAggregateLimitAmount)) + (max dailyPaymentSum (konst sellersAggregateLimitAmount)) + + -- Payment Amount: + -- On each Payment Date the Payment Amount will equal the Aggregate Payment + -- Amount for the respective Calculation Date less the Aggregate Payment + -- Amount for the previous Calculation Date apart from the first Payment + -- Date where the Payment Amount will be the Aggregate Payment Amount. + paymentAmount = aggregatePayment %- previousAggregatePayment + + paymentDue = + -- If the Payment Amount is: + -- (i) positive, and Payment Amount less the Monthly Premium is positive + -- then Seller shall pay Buyer a sum equal to Payment Amount less + -- the Monthly Premium in GBP, or + ifthen (paymentAmount %> konst 0 + %&& (paymentAmount %- konst monthlyPremium) %>= konst 0) + (negate (paymentAmount %- konst monthlyPremium)) $ + + -- (ii) positive, and Payment Amount less the Monthly Premium is negative + -- then Buyer shall pay Seller a sum equal to Monthly Premium less + -- the Payment Amount. + ifthen (paymentAmount %> konst 0 + %&& (paymentAmount %- konst monthlyPremium) %< konst 0) + (konst monthlyPremium %- paymentAmount) $ + + -- (iii) negative, then Buyer shall pay Seller an amount equal to the + -- absolute value of the Payment Amount in GBP plus the Monthly + -- Premium, or + ifthen (paymentAmount %< konst 0) + (abs (paymentAmount %+ konst monthlyPremium)) + + -- (iv) zero, the Buyer shall pay Seller the Monthly Premium. + (konst monthlyPremium) + + + dailyPayment notionalAmount dailyDeductable + weatherIndexStrikeLevel gasIndexStrikeLevel = + + -- Daily Payment Amount: + -- Where Daily Accrual Amount is positive the Daily Payment Amount due to + -- the Buyer shall be calculated as follows: + ifthen (dailyAccrual %> konst 0) + -- Daily Payment Amount = + -- Max ((Daily Accrual Amount - Daily Deductible),0) + (max (dailyAccrual %- konst dailyDeductable) (konst 0)) + + -- Where Daily Accrual Amount is negative the Daily Payment Amount due to + -- the Seller shall be calculated as follows: + -- + -- Daily Payment Amount = Daily Accrual Amount + (negate dailyAccrual) + + where + -- Daily Accrual Amount: + dailyAccrual = + -- If: + -- Natural Gas Settlement Price < Natural Gas Index Strike Level + ifthen + (gas_settlement_price %< konst gasIndexStrikeLevel) + -- Daily Accrual Amount shall be: + -- + -- Relevant Notional Amount + -- * [Weather Index - Weather Index Strike Level] + -- * [Natural Gas Index Strike Level - Natural Gas Settlement Price] + (konst notionalAmount + %* (weather_metro_grp_CWV %- konst weatherIndexStrikeLevel) + %* (konst gasIndexStrikeLevel %- gas_settlement_price )) + + -- Where Relevant Notional Amount relates to the Notional Amount applicable + -- to the month in which the relevant Daily Accrual Amount falls. + -- + -- A positive result is a Daily Accrual Amount in favour of the Buyer and + -- a negative result is a Daily Accrual Amount in favour of the Seller. + + -- If: + -- Natural Gas Settlement Price > or = Natural Gas Index Strike Level + -- then, Daily Accrual Amount shall be zero. + (konst 0) + diff --git a/examples/WeatherContingent.obsdb.xml b/examples/WeatherContingent.obsdb.xml new file mode 100644 --- /dev/null +++ b/examples/WeatherContingent.obsdb.xml @@ -0,0 +1,5 @@ + + + + + diff --git a/examples/WeatherContingent.timeseries.xml b/examples/WeatherContingent.timeseries.xml new file mode 100644 --- /dev/null +++ b/examples/WeatherContingent.timeseries.xml @@ -0,0 +1,24 @@ + + + + + + + + + 85 + 86 + 89 + + + + + 4 + + + + + + + diff --git a/generate-docs.hs b/generate-docs.hs new file mode 100644 --- /dev/null +++ b/generate-docs.hs @@ -0,0 +1,40 @@ +#!/usr/bin/runghc + +-- On Unix/MacOSX run as: +-- ./generate-docs.hs +-- +-- On Windows: +-- runghc generate-docs.hs +-- +-- Then point your browser at ./doc/index.html + +import System.Process +import System.Directory +import System.FilePath +import System.Exit +import Control.Monad +import Data.Char + +outDir = "doc" +shareDir = "share" +srcDir = "src" + +main = do + libmodules <- getLibModules + exitcode <- rawSystem "haddock" (haddockArgs libmodules) + when (exitcode /= ExitSuccess) $ + putStrLn "Generating 'haddock' documentation failed" + exitWith exitcode + +getLibModules :: IO [FilePath] +getLibModules = do + files <- getDirectoryContents shareDir + return [ shareDir file + | file <- files + , takeExtension file == ".hs", isUpper (head file) ] + +haddockArgs libmodules = + [ "--html" + , "-o", outDir + , "--optghc=-i" ++ srcDir ] + ++ libmodules diff --git a/license.txt b/license.txt new file mode 100644 --- /dev/null +++ b/license.txt @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2009-2015 Anthony Waite, Dave Hewett, Shaun Laurens and other contributors + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/netrium.cabal b/netrium.cabal new file mode 100644 --- /dev/null +++ b/netrium.cabal @@ -0,0 +1,85 @@ +name: netrium +version: 0.6.0 +synopsis: Contract normaliser and simulator +description: Netrium enables financial engineers to precisely describe and execute both simple and exotic contracts with both financial and physical delivery. +category: Finance +author: Well-Typed LLP +maintainer: Well-Typed LLP +copyright: 2009-2015 Anthony Waite, Dave Hewett, Shaun Laurens and other contributors +license: MIT +license-file: license.txt + +build-type: Simple +cabal-version: >= 1.8 + +data-dir: share +data-files: normalise-wrapper.hs + Common.hs + Options.hs + Calendar.hs + Swaps.hs + Credit.hs + Settlement.hs + ScheduledProduct.hs +extra-source-files: examples/Units.db.xml + examples/*.hs + examples/*.contract + examples/*.obsdb.xml + examples/*.timeseries.xml + regression-test.sh + generate-docs.hs + +library + hs-source-dirs: src + exposed-modules: WriteDotGraph + Display + Observable + ObservableDB + UnitsDB + Observations + Contract + DecisionTree + DecisionTreeSimplify + Interpreter + XmlUtils + Valuation + build-depends: base >= 3.0 && < 5, + containers >= 0.3 && < 1, + process >= 1.0 && < 2, + time >= 1.1 && < 2, + HaXml == 1.25.* + +executable normalise + hs-source-dirs: tool + main-is: Normalise.hs + build-depends: netrium, + base >= 3.0 && < 5, + process >= 1.0 && < 2, + filepath >= 1.1 && < 2, + directory >= 1.0 && < 2, + HaXml == 1.25.* + +executable simulate + hs-source-dirs: tool + main-is: Simulate.hs + build-depends: netrium, + base >= 3.0 && < 5, + containers >= 0.3 && < 1, + HaXml == 1.25.*, + pretty == 1.1.3.*, + directory >= 1.0 && < 2, + filepath + +executable visualise + hs-source-dirs: tool + main-is: Visualise.hs + build-depends: netrium, + base >= 3.0 && < 5, + directory >= 1.0 && < 2, + filepath, + process >= 1.0 && < 2, + HaXml == 1.25.* + +source-repository head + type: git + location: https://github.com/netrium/Netrium diff --git a/regression-test.sh b/regression-test.sh new file mode 100644 --- /dev/null +++ b/regression-test.sh @@ -0,0 +1,51 @@ +#!/bin/bash + +CONTRACTS="$@" + +if test "${CONTRACTS}" = "" +then + echo "Usage: ./regression-test [contract...]" + echo "One or more .contract files, for example:" + echo "$ ./regression-test examples/*.contract" + exit +fi + +for CONTRACT in ${CONTRACTS}; do + echo -n "${CONTRACT}: " + + CONTRACT_DIR="$(dirname ${CONTRACT})" + CONTRACT_BASE=${CONTRACT%%.contract} + + if test -f ${CONTRACT_BASE}.obsdb.xml + then + OBSDB="--obs-db=${CONTRACT_BASE}.obsdb.xml" + else + OBSDB=; + fi + if test -f "${CONTRACT_DIR}/Units.db.xml" + then + UNITSDB="--units-db=${CONTRACT_DIR}/Units.db.xml" + else + UNITSDB= + fi + + if normalise ${UNITSDB} ${OBSDB} ${CONTRACT} ${CONTRACT}.xml --fast \ + > normalise-out.log 2>&1 + then + echo -n "compiled OK" + if simulate ${CONTRACT}.xml ${CONTRACT_BASE}.timeseries.xml ${CONTRACT_BASE}.out \ + > simulate-out.log 2>&1 + then + echo ", simulate OK" + cat normalise-out.log + cat simulate-out.log + else + echo ", simulate FAILED:" + cat simulate-out.log + fi + else + echo "compile FAILED:" + cat normalise-out.log + fi +done +rm -f normalise-out.log simulate-out.log diff --git a/share/Calendar.hs b/share/Calendar.hs new file mode 100644 --- /dev/null +++ b/share/Calendar.hs @@ -0,0 +1,651 @@ +-- |Netrium is Copyright Anthony Waite, Dave Hetwett, Shaun Laurens 2009-2015, and files herein are licensed +-- |under the MIT license, the text of which can be found in license.txt +-- +-- Date functions that are sensitive to various kinds of calendars. +-- +-- A 'Calendar' type is provided which allows us to define various kinds of +-- calendars including business days, working days, delivery schedules etc. +-- +{-# LANGUAGE BangPatterns, Rank2Types #-} +module Calendar ( + + -- * Calendar type + Calendar, + + -- ** Date adjustment functions + calendarDayFirst, + calendarDayNext, + calendarDayPrevious, + calendarDaysEarlier, + calendarDaysLater, + + -- ** Other utilities + dayInCalendar, + calendarDaysInPeriod, + calendarFirstDay, + calendarLastDay, + + -- ** Constructing calendars + getBusinessDayCalendar, + newCalendar, + DayType(..), + + -- ** Deprecated + firstWorkingDay, + nextWorkingDay, + previousWorkingDay, + workingDaysEarlier, + workingDaysLater, + isWorkingDay, + workingDaysInPeriod, + getCalendar, + ) where + +import Common + +import Data.Time +import Data.Array.Unboxed + +-- * Calendar types + +-- | A calendar is a set of days. +-- +-- For example a working days calendar is a set of working days. This lets +-- us do date calculations that are sensitive to holidays etc. +-- +-- We can also define or calculate calendars for special purposes, like +-- all the delivery days in a contract delivery schedule. +-- +-- Note that calendars are not contigious sets of days, that is they are not +-- date ranges, they usually do contain gaps. Calendars are finite, that is +-- there is a first and a last day that are listed in the calendar. +-- +data Calendar = Calendar !String -- calendar name (for error messages) + !(UArray Day Bool) -- bitmap of day -> workday + -- very compact: 46 bytes per year + +-- In future we might want infinte calendars to allow for weekday or weekend, +-- or monthly calendars. These would be useful in calculations, if not directly +-- on their own. But then these would not be suitable for use as delivery +-- schedules. We might need to distinguish finite range calendars. Or just make +-- it a runtime error. + +calendarRange :: Calendar -> (Day, Day) +calendarRange (Calendar _ daybitmap) = bounds daybitmap + +-- | The first day that is listed in the calendar. +-- +calendarFirstDay :: Calendar -> DateTime +calendarFirstDay cal = UTCTime first 0 where (first, _) = calendarRange cal + +-- | The last day that is listed in the calendar. +-- +calendarLastDay :: Calendar -> DateTime +calendarLastDay cal = UTCTime first 0 where (first, _) = calendarRange cal + +-- | Is the given date listed in the given calendar. +-- +dayInCalendar :: Calendar -> DateTime -> Bool +dayInCalendar cal@(Calendar _ daybitmap) (UTCTime day _) + | inRange (calendarRange cal) day = daybitmap ! day + | otherwise = False + +-- | The days within the given time period that are listed in the calendar. +-- +calendarDaysInPeriod :: Calendar + -> (DateTime, DateTime) -- ^ @(start, end)@ datetimes + -> [DateTime] +calendarDaysInPeriod (Calendar _ daybitmap) + (UTCTime rangeStart _, UTCTime rangeEnd _) = + [ UTCTime day 0 | day <- [start..end], daybitmap ! day ] + where + start = max calStart rangeStart + end = min calEnd rangeEnd + (calStart, calEnd) = bounds daybitmap + +-- | A date change: a number of calendar days later. Days that are not listed +-- in the calendar are skipped. +-- +-- For example, for a working day calendar, @calendarDaysLater cal 2@ is the +-- 2nd working day, not including the current day and taking into account +-- weekends and holidays. This works because a working day calendar lists only +-- working days, and omits the weekends and holidays. +-- +calendarDaysLater :: Calendar -> Int -> DiffDateTime +calendarDaysLater _ n0 | n0 < 0 = error "calendarDaysLater: negative days are invalid" +calendarDaysLater cal n0 = + modifyDate $ \day0 -> + let dayError = dateError ("calendarDaysLater" ++ show (day0,n0)) cal + in succCalendarDays dayError cal n0 day0 + +-- | A date change: a number of calendar days previous. Days that are not listed +-- in the calendar are skipped. +-- +-- For example, for a working day calendar, @calendarDaysEarlier cal 1@ is the +-- previous working day, taking into account weekends and holidays (as +-- specified by the given calendar). +-- +calendarDaysEarlier :: Calendar -> Int -> DiffDateTime +calendarDaysEarlier _ n0 | n0 < 0 = error "calendarDaysEarlier: negative days are invalid" +calendarDaysEarlier cal n0 = + modifyDate $ \day0 -> + let dayError = dateError ("calendarDaysEarlier" ++ show (day0,n0)) cal + in predCalendarDays dayError cal n0 day0 + +-- | A date change: the first of the subsequent days that is listed in the +-- calendar. That is, the current day is not included. +-- +-- This is the same as @calendarDaysLater cal 1@ +-- +calendarDayNext :: Calendar -> DiffDateTime +calendarDayNext cal = + modifyDate $ \day0 -> + let dayError = dateError ("calendarDayNext(" ++ show day0 ++ ")") cal + in succCalendarDays dayError cal 1 day0 + +-- | A date change: the first of the current or subsequent days that is a +-- listed in the calendar day. This is the current day if the current day is +-- listed in the calendar. +-- +-- This is the same as @calendarDaysLater cal 0@ +-- +-- Example (for a workday calendar): first working day of the year: +-- +-- > inMonth 1 <> onDayOfMonth 1 <> calendarDayFirst cal +-- +-- Example (for a workday calendar): first working day in a month's time: +-- +-- > monthsLater 1 <> calendarDayFirst cal +-- +calendarDayFirst :: Calendar -> DiffDateTime +calendarDayFirst cal = + modifyDate $ \day0 -> + let dayError = dateError ("calendarDayFirst(" ++ show day0 ++ ")") cal + in succCalendarDays dayError cal 0 day0 + +-- | A date change: the first of the previous days that is listed in the +-- calendar. +-- +-- That is, the current day is not included. +-- +-- This is the same as @calendarDaysEarlier cal 1@ +-- +calendarDayPrevious :: Calendar -> DiffDateTime +calendarDayPrevious cal = + modifyDate $ \day0 -> + let dayError = dateError ("calendarDayPrevious(" ++ show day0 ++ ")") cal + in predCalendarDays dayError cal 1 day0 + +-- internal worker & helper functions: + +badDay :: Calendar -> Day -> Bool +badDay (Calendar _ daybitmap) = not . inRange (bounds daybitmap) + +dateError :: String -> Calendar -> Day -> a +dateError fname (Calendar name daybitmap) day = + error $ fname ++ ": " ++ "the date " ++ show day + ++ " is out of range for the calendar " ++ name + ++ " " ++ show (bounds daybitmap) + +succCalendarDays :: (forall a. Day -> a) -> Calendar -> Int -> Day -> Day +succCalendarDays dayError cal@(Calendar _ daybitmap) = later + where + later _ !day | badDay cal day = dayError day + later !0 !day | daybitmap ! day = day + | otherwise = succCalendarDay day + later !1 !day = succCalendarDay day + later !n !day = later (n-1) (succCalendarDay day) + + succCalendarDay = go . succ + where + go !day | badDay cal day = dayError day + | daybitmap ! day = day + | otherwise = go (succ day) + +predCalendarDays :: (forall a. Day -> a) -> Calendar -> Int -> Day -> Day +predCalendarDays dayError cal@(Calendar _ daybitmap) = earlier + where + earlier _ !day | badDay cal day = dayError day + earlier !0 !day | daybitmap ! day = day + | otherwise = predCalendarDay day + earlier !1 !day = predCalendarDay day + earlier !n !day = earlier (n-1) (predCalendarDay day) + + predCalendarDay = go . pred + where + go !day | badDay cal day = dayError day + | daybitmap ! day = day + | otherwise = go (pred day) + +--------------- +-- Deprecated +-- + +{-# DEPRECATED firstWorkingDay "Use calendarDayFirst instead" #-} +{-# DEPRECATED nextWorkingDay "Use calendarDayNext instead" #-} +{-# DEPRECATED previousWorkingDay "Use calendarDayPrevious instead" #-} +{-# DEPRECATED workingDaysEarlier "Use calendarDaysEarlier instead" #-} +{-# DEPRECATED workingDaysLater "Use calendarDaysLater instead" #-} + +{-# DEPRECATED isWorkingDay "Use dayInCalendar instead" #-} +{-# DEPRECATED workingDaysInPeriod "Use calendarDaysInPeriod instead" #-} +{-# DEPRECATED getCalendar "Use getBusinessDayCalendar instead" #-} + +firstWorkingDay = calendarDayFirst +nextWorkingDay = calendarDayNext +previousWorkingDay = calendarDayPrevious +workingDaysEarlier = calendarDaysEarlier +workingDaysLater = calendarDaysLater +isWorkingDay = dayInCalendar +workingDaysInPeriod = calendarDaysInPeriod +getCalendar = getBusinessDayCalendar + +--------------------------- +-- Constructing calendars +-- + +newCalendar :: String -> [(DateTime, DayType)] -> Calendar +newCalendar name days = Calendar name daybitmap + where + daybitmap :: UArray Day Bool + daybitmap = array (lbound, ubound) + [ (day, isBusinessDay daytype) + | (UTCTime day _, daytype) <- days ] + UTCTime lbound _ = minimum [ day | (day,_) <- days] + UTCTime ubound _ = maximum [ day | (day,_) <- days] + + +-- | Day types +data DayType = BusinessDay -- ^ a normal working weekday + | Holiday -- ^ a weekday that is a non-working day, e.g. holiday + | Weekend -- ^ a weekend + deriving (Show, Eq) + +isBusinessDay :: DayType -> Bool +isBusinessDay BusinessDay = True +isBusinessDay _ = False + +-- * Calendar instances +-- | Get a given business day calendar. For now, calendars are manually +-- populated here. Ideally this will done using a service and parsed here. +getBusinessDayCalendar :: String -> Calendar +getBusinessDayCalendar "EEX Power" = eexPower +getBusinessDayCalendar name = error $ "getCalendar: unknown calendar " ++ show name + + + +eexPower :: Calendar +eexPower = newCalendar "EEX Power" + [(date 2010 12 25, Weekend) + ,(date 2010 12 26, Weekend) + ,(date 2010 12 27, BusinessDay) + ,(date 2010 12 28, BusinessDay) + ,(date 2010 12 29, BusinessDay) + ,(date 2010 12 30, BusinessDay) + ,(date 2010 12 31, BusinessDay) + ,(date 2011 01 01, Weekend) + ,(date 2011 01 02, Weekend) + ,(date 2011 01 03, BusinessDay) + ,(date 2011 01 04, BusinessDay) + ,(date 2011 01 05, BusinessDay) + ,(date 2011 01 06, BusinessDay) + ,(date 2011 01 07, BusinessDay) + ,(date 2011 01 08, Weekend) + ,(date 2011 01 09, Weekend) + ,(date 2011 01 10, BusinessDay) + ,(date 2011 01 11, BusinessDay) + ,(date 2011 01 12, BusinessDay) + ,(date 2011 01 13, BusinessDay) + ,(date 2011 01 14, BusinessDay) + ,(date 2011 01 15, Weekend) + ,(date 2011 01 16, Weekend) + ,(date 2011 01 17, BusinessDay) + ,(date 2011 01 18, BusinessDay) + ,(date 2011 01 19, BusinessDay) + ,(date 2011 01 20, BusinessDay) + ,(date 2011 01 21, BusinessDay) + ,(date 2011 01 22, Weekend) + ,(date 2011 01 23, Weekend) + ,(date 2011 01 24, BusinessDay) + ,(date 2011 01 25, BusinessDay) + ,(date 2011 01 26, BusinessDay) + ,(date 2011 01 27, BusinessDay) + ,(date 2011 01 28, BusinessDay) + ,(date 2011 01 29, Weekend) + ,(date 2011 01 30, Weekend) + ,(date 2011 01 31, BusinessDay) + ,(date 2011 02 01, BusinessDay) + ,(date 2011 02 02, BusinessDay) + ,(date 2011 02 03, BusinessDay) + ,(date 2011 02 04, BusinessDay) + ,(date 2011 02 05, Weekend) + ,(date 2011 02 06, Weekend) + ,(date 2011 02 07, BusinessDay) + ,(date 2011 02 08, BusinessDay) + ,(date 2011 02 09, BusinessDay) + ,(date 2011 02 10, BusinessDay) + ,(date 2011 02 11, BusinessDay) + ,(date 2011 02 12, Weekend) + ,(date 2011 02 13, Weekend) + ,(date 2011 02 14, BusinessDay) + ,(date 2011 02 15, BusinessDay) + ,(date 2011 02 16, BusinessDay) + ,(date 2011 02 17, BusinessDay) + ,(date 2011 02 18, BusinessDay) + ,(date 2011 02 19, Weekend) + ,(date 2011 02 20, Weekend) + ,(date 2011 02 21, BusinessDay) + ,(date 2011 02 22, BusinessDay) + ,(date 2011 02 23, BusinessDay) + ,(date 2011 02 24, BusinessDay) + ,(date 2011 02 25, BusinessDay) + ,(date 2011 02 26, Weekend) + ,(date 2011 02 27, Weekend) + ,(date 2011 02 28, BusinessDay) + ,(date 2011 03 01, BusinessDay) + ,(date 2011 03 02, BusinessDay) + ,(date 2011 03 03, BusinessDay) + ,(date 2011 03 04, BusinessDay) + ,(date 2011 03 05, Weekend) + ,(date 2011 03 06, Weekend) + ,(date 2011 03 07, BusinessDay) + ,(date 2011 03 08, BusinessDay) + ,(date 2011 03 09, BusinessDay) + ,(date 2011 03 10, BusinessDay) + ,(date 2011 03 11, BusinessDay) + ,(date 2011 03 12, Weekend) + ,(date 2011 03 13, Weekend) + ,(date 2011 03 14, BusinessDay) + ,(date 2011 03 15, BusinessDay) + ,(date 2011 03 16, BusinessDay) + ,(date 2011 03 17, BusinessDay) + ,(date 2011 03 18, BusinessDay) + ,(date 2011 03 19, Weekend) + ,(date 2011 03 20, Weekend) + ,(date 2011 03 21, BusinessDay) + ,(date 2011 03 22, BusinessDay) + ,(date 2011 03 23, BusinessDay) + ,(date 2011 03 24, BusinessDay) + ,(date 2011 03 25, BusinessDay) + ,(date 2011 03 26, Weekend) + ,(date 2011 03 27, Weekend) + ,(date 2011 03 28, BusinessDay) + ,(date 2011 03 29, BusinessDay) + ,(date 2011 03 30, BusinessDay) + ,(date 2011 03 31, BusinessDay) + ,(date 2011 04 01, BusinessDay) + ,(date 2011 04 02, Weekend) + ,(date 2011 04 03, Weekend) + ,(date 2011 04 04, BusinessDay) + ,(date 2011 04 05, BusinessDay) + ,(date 2011 04 06, BusinessDay) + ,(date 2011 04 07, BusinessDay) + ,(date 2011 04 08, BusinessDay) + ,(date 2011 04 09, Weekend) + ,(date 2011 04 10, Weekend) + ,(date 2011 04 11, BusinessDay) + ,(date 2011 04 12, BusinessDay) + ,(date 2011 04 13, BusinessDay) + ,(date 2011 04 14, BusinessDay) + ,(date 2011 04 15, BusinessDay) + ,(date 2011 04 16, Weekend) + ,(date 2011 04 17, Weekend) + ,(date 2011 04 18, BusinessDay) + ,(date 2011 04 19, BusinessDay) + ,(date 2011 04 20, BusinessDay) + ,(date 2011 04 21, BusinessDay) + ,(date 2011 04 22, Holiday) + ,(date 2011 04 23, Weekend) + ,(date 2011 04 24, Weekend) + ,(date 2011 04 25, Holiday) + ,(date 2011 04 26, BusinessDay) + ,(date 2011 04 27, BusinessDay) + ,(date 2011 04 28, BusinessDay) + ,(date 2011 04 29, BusinessDay) + ,(date 2011 04 30, Weekend) + ,(date 2011 05 01, Weekend) + ,(date 2011 05 02, BusinessDay) + ,(date 2011 05 03, BusinessDay) + ,(date 2011 05 04, BusinessDay) + ,(date 2011 05 05, BusinessDay) + ,(date 2011 05 06, BusinessDay) + ,(date 2011 05 07, Weekend) + ,(date 2011 05 08, Weekend) + ,(date 2011 05 09, BusinessDay) + ,(date 2011 05 10, BusinessDay) + ,(date 2011 05 11, BusinessDay) + ,(date 2011 05 12, BusinessDay) + ,(date 2011 05 13, BusinessDay) + ,(date 2011 05 14, Weekend) + ,(date 2011 05 15, Weekend) + ,(date 2011 05 16, BusinessDay) + ,(date 2011 05 17, BusinessDay) + ,(date 2011 05 18, BusinessDay) + ,(date 2011 05 19, BusinessDay) + ,(date 2011 05 20, BusinessDay) + ,(date 2011 05 21, Weekend) + ,(date 2011 05 22, Weekend) + ,(date 2011 05 23, BusinessDay) + ,(date 2011 05 24, BusinessDay) + ,(date 2011 05 25, BusinessDay) + ,(date 2011 05 26, BusinessDay) + ,(date 2011 05 27, BusinessDay) + ,(date 2011 05 28, Weekend) + ,(date 2011 05 29, Weekend) + ,(date 2011 05 30, BusinessDay) + ,(date 2011 05 31, BusinessDay) + ,(date 2011 06 01, BusinessDay) + ,(date 2011 06 02, Holiday) + ,(date 2011 06 03, BusinessDay) + ,(date 2011 06 04, Weekend) + ,(date 2011 06 05, Weekend) + ,(date 2011 06 06, BusinessDay) + ,(date 2011 06 07, BusinessDay) + ,(date 2011 06 08, BusinessDay) + ,(date 2011 06 09, BusinessDay) + ,(date 2011 06 10, BusinessDay) + ,(date 2011 06 11, Weekend) + ,(date 2011 06 12, Weekend) + ,(date 2011 06 13, Holiday) + ,(date 2011 06 14, BusinessDay) + ,(date 2011 06 15, BusinessDay) + ,(date 2011 06 16, BusinessDay) + ,(date 2011 06 17, BusinessDay) + ,(date 2011 06 18, Weekend) + ,(date 2011 06 19, Weekend) + ,(date 2011 06 20, BusinessDay) + ,(date 2011 06 21, BusinessDay) + ,(date 2011 06 22, BusinessDay) + ,(date 2011 06 23, BusinessDay) + ,(date 2011 06 24, BusinessDay) + ,(date 2011 06 25, Weekend) + ,(date 2011 06 26, Weekend) + ,(date 2011 06 27, BusinessDay) + ,(date 2011 06 28, BusinessDay) + ,(date 2011 06 29, BusinessDay) + ,(date 2011 06 30, BusinessDay) + ,(date 2011 07 01, BusinessDay) + ,(date 2011 07 02, Weekend) + ,(date 2011 07 03, Weekend) + ,(date 2011 07 04, BusinessDay) + ,(date 2011 07 05, BusinessDay) + ,(date 2011 07 06, BusinessDay) + ,(date 2011 07 07, BusinessDay) + ,(date 2011 07 08, BusinessDay) + ,(date 2011 07 09, Weekend) + ,(date 2011 07 10, Weekend) + ,(date 2011 07 11, BusinessDay) + ,(date 2011 07 12, BusinessDay) + ,(date 2011 07 13, BusinessDay) + ,(date 2011 07 14, BusinessDay) + ,(date 2011 07 15, BusinessDay) + ,(date 2011 07 16, Weekend) + ,(date 2011 07 17, Weekend) + ,(date 2011 07 18, BusinessDay) + ,(date 2011 07 19, BusinessDay) + ,(date 2011 07 20, BusinessDay) + ,(date 2011 07 21, BusinessDay) + ,(date 2011 07 22, BusinessDay) + ,(date 2011 07 23, Weekend) + ,(date 2011 07 24, Weekend) + ,(date 2011 07 25, BusinessDay) + ,(date 2011 07 26, BusinessDay) + ,(date 2011 07 27, BusinessDay) + ,(date 2011 07 28, BusinessDay) + ,(date 2011 07 29, BusinessDay) + ,(date 2011 07 30, Weekend) + ,(date 2011 07 31, Weekend) + ,(date 2011 08 01, BusinessDay) + ,(date 2011 08 02, BusinessDay) + ,(date 2011 08 03, BusinessDay) + ,(date 2011 08 04, BusinessDay) + ,(date 2011 08 05, BusinessDay) + ,(date 2011 08 06, Weekend) + ,(date 2011 08 07, Weekend) + ,(date 2011 08 08, BusinessDay) + ,(date 2011 08 09, BusinessDay) + ,(date 2011 08 10, BusinessDay) + ,(date 2011 08 11, BusinessDay) + ,(date 2011 08 12, BusinessDay) + ,(date 2011 08 13, Weekend) + ,(date 2011 08 14, Weekend) + ,(date 2011 08 15, BusinessDay) + ,(date 2011 08 16, BusinessDay) + ,(date 2011 08 17, BusinessDay) + ,(date 2011 08 18, BusinessDay) + ,(date 2011 08 19, BusinessDay) + ,(date 2011 08 20, Weekend) + ,(date 2011 08 21, Weekend) + ,(date 2011 08 22, BusinessDay) + ,(date 2011 08 23, BusinessDay) + ,(date 2011 08 24, BusinessDay) + ,(date 2011 08 25, BusinessDay) + ,(date 2011 08 26, BusinessDay) + ,(date 2011 08 27, Weekend) + ,(date 2011 08 28, Weekend) + ,(date 2011 08 29, BusinessDay) + ,(date 2011 08 30, BusinessDay) + ,(date 2011 08 31, BusinessDay) + ,(date 2011 09 01, BusinessDay) + ,(date 2011 09 02, BusinessDay) + ,(date 2011 09 03, Weekend) + ,(date 2011 09 04, Weekend) + ,(date 2011 09 05, BusinessDay) + ,(date 2011 09 06, BusinessDay) + ,(date 2011 09 07, BusinessDay) + ,(date 2011 09 08, BusinessDay) + ,(date 2011 09 09, BusinessDay) + ,(date 2011 09 10, Weekend) + ,(date 2011 09 11, Weekend) + ,(date 2011 09 12, BusinessDay) + ,(date 2011 09 13, BusinessDay) + ,(date 2011 09 14, BusinessDay) + ,(date 2011 09 15, BusinessDay) + ,(date 2011 09 16, BusinessDay) + ,(date 2011 09 17, Weekend) + ,(date 2011 09 18, Weekend) + ,(date 2011 09 19, BusinessDay) + ,(date 2011 09 20, BusinessDay) + ,(date 2011 09 21, BusinessDay) + ,(date 2011 09 22, BusinessDay) + ,(date 2011 09 23, BusinessDay) + ,(date 2011 09 24, Weekend) + ,(date 2011 09 25, Weekend) + ,(date 2011 09 26, BusinessDay) + ,(date 2011 09 27, BusinessDay) + ,(date 2011 09 28, BusinessDay) + ,(date 2011 09 29, BusinessDay) + ,(date 2011 09 30, BusinessDay) + ,(date 2011 10 01, Weekend) + ,(date 2011 10 02, Weekend) + ,(date 2011 10 03, Holiday) + ,(date 2011 10 04, BusinessDay) + ,(date 2011 10 05, BusinessDay) + ,(date 2011 10 06, BusinessDay) + ,(date 2011 10 07, BusinessDay) + ,(date 2011 10 08, Weekend) + ,(date 2011 10 09, Weekend) + ,(date 2011 10 10, BusinessDay) + ,(date 2011 10 11, BusinessDay) + ,(date 2011 10 12, BusinessDay) + ,(date 2011 10 13, BusinessDay) + ,(date 2011 10 14, BusinessDay) + ,(date 2011 10 15, Weekend) + ,(date 2011 10 16, Weekend) + ,(date 2011 10 17, BusinessDay) + ,(date 2011 10 18, BusinessDay) + ,(date 2011 10 19, BusinessDay) + ,(date 2011 10 20, BusinessDay) + ,(date 2011 10 21, BusinessDay) + ,(date 2011 10 22, Weekend) + ,(date 2011 10 23, Weekend) + ,(date 2011 10 24, BusinessDay) + ,(date 2011 10 25, BusinessDay) + ,(date 2011 10 26, BusinessDay) + ,(date 2011 10 27, BusinessDay) + ,(date 2011 10 28, BusinessDay) + ,(date 2011 10 29, Weekend) + ,(date 2011 10 30, Weekend) + ,(date 2011 10 31, BusinessDay) + ,(date 2011 11 01, BusinessDay) + ,(date 2011 11 02, BusinessDay) + ,(date 2011 11 03, BusinessDay) + ,(date 2011 11 04, BusinessDay) + ,(date 2011 11 05, Weekend) + ,(date 2011 11 06, Weekend) + ,(date 2011 11 07, BusinessDay) + ,(date 2011 11 08, BusinessDay) + ,(date 2011 11 09, BusinessDay) + ,(date 2011 11 10, BusinessDay) + ,(date 2011 11 11, BusinessDay) + ,(date 2011 11 12, Weekend) + ,(date 2011 11 13, Weekend) + ,(date 2011 11 14, BusinessDay) + ,(date 2011 11 15, BusinessDay) + ,(date 2011 11 16, BusinessDay) + ,(date 2011 11 17, BusinessDay) + ,(date 2011 11 18, BusinessDay) + ,(date 2011 11 19, Weekend) + ,(date 2011 11 20, Weekend) + ,(date 2011 11 21, BusinessDay) + ,(date 2011 11 22, BusinessDay) + ,(date 2011 11 23, BusinessDay) + ,(date 2011 11 24, BusinessDay) + ,(date 2011 11 25, BusinessDay) + ,(date 2011 11 26, Weekend) + ,(date 2011 11 27, Weekend) + ,(date 2011 11 28, BusinessDay) + ,(date 2011 11 29, BusinessDay) + ,(date 2011 11 30, BusinessDay) + ,(date 2011 12 01, BusinessDay) + ,(date 2011 12 02, BusinessDay) + ,(date 2011 12 03, Weekend) + ,(date 2011 12 04, Weekend) + ,(date 2011 12 05, BusinessDay) + ,(date 2011 12 06, BusinessDay) + ,(date 2011 12 07, BusinessDay) + ,(date 2011 12 08, BusinessDay) + ,(date 2011 12 09, BusinessDay) + ,(date 2011 12 10, Weekend) + ,(date 2011 12 11, Weekend) + ,(date 2011 12 12, BusinessDay) + ,(date 2011 12 13, BusinessDay) + ,(date 2011 12 14, BusinessDay) + ,(date 2011 12 15, BusinessDay) + ,(date 2011 12 16, BusinessDay) + ,(date 2011 12 17, Weekend) + ,(date 2011 12 18, Weekend) + ,(date 2011 12 19, BusinessDay) + ,(date 2011 12 20, BusinessDay) + ,(date 2011 12 21, BusinessDay) + ,(date 2011 12 22, BusinessDay) + ,(date 2011 12 23, BusinessDay) + ,(date 2011 12 24, Weekend) + ,(date 2011 12 25, Weekend) + ,(date 2011 12 26, Holiday) + ,(date 2011 12 27, BusinessDay) + ,(date 2011 12 28, BusinessDay) + ,(date 2011 12 29, BusinessDay) + ,(date 2011 12 30, BusinessDay) + ,(date 2011 12 31, Weekend) + ] diff --git a/share/Common.hs b/share/Common.hs new file mode 100644 --- /dev/null +++ b/share/Common.hs @@ -0,0 +1,492 @@ +-- |Netrium is Copyright Anthony Waite, Dave Hetwett, Shaun Laurens 2009-2015, and files herein are licensed +-- |under the MIT license, the text of which can be found in license.txt +-- +-- Module for common types and functions +module Common where + +import Prelude hiding (and, or, min, max, abs, negate, not, read, until) +import Contract + +import Data.List (transpose) +import Data.Time +import Data.Monoid +import Data.Maybe + +-- * Common types +-- | A price is modelled as an observable double +type Price = Obs Double +-- | A volume is modelled as an observable double +type Volume = Obs Double +-- | A price curve is a list of prices +type PriceCurve = [Price] + +-- | Markets, e.g. UK Power (Electricity MWh UK), NBP Gas (Gas TH UK) +data Market = Market Commodity Unit Location + +-- | Index, e.g. SPX +type Index = Obs Double + +-- | Basic schedule, defined as a ist of date times +type Schedule = [DateTime] +-- | Advanced schedule, defined as a list of time ranges +type SegmentedSchedule = [[DateTime]] +-- | Amortisation table, defined as a list of amortisation rates and +-- observation rates +type AmortisationTable = [(Double, Double)] + +-- | Day count conventions, e.g. 90/360 +type DayCountConvention = Double + +-- | Underlying assets +type Underlying = Contract + +-- * Dates and times +-- | Use the UTC format +type DateTime = UTCTime + +-- | Midnight on a given day +date :: Integer -> Int -> Int -> DateTime +date year month day = + UTCTime (fromGregorian year month day) 0 + +-- | A point in time on a given day +datetime :: Integer -> Int -> Int + -> Int -> Int + -> DateTime +datetime year month day hours minutes = + UTCTime (fromGregorian year month day) + (timeOfDayToTime (TimeOfDay hours minutes 0)) + +-- | The difference between 2 date times +newtype DiffDateTime = DiffDateTime (DateTime -> DateTime) + +infixr 5 <> + +-- | Used to combine various things. +-- +-- For example for 'DiffDateTime' it combines date/time differences, +-- e.g. @daysEarlier 3 <> atTimeOfDay 15 00@ means 3 days earlier at 3pm. +(<>) :: Monoid a => a -> a -> a +a <> b = mappend a b + +instance Monoid DiffDateTime where + mempty = DiffDateTime id + mappend (DiffDateTime a) (DiffDateTime b) = DiffDateTime (b . a) + +-- | Adjust a date time by a given date time difference +adjustDateTime :: DateTime -> DiffDateTime -> DateTime +adjustDateTime d (DiffDateTime adj) = adj d + +modifyDate adj = DiffDateTime (\(UTCTime day tod) -> UTCTime (adj day) tod) +modifyTime adj = DiffDateTime (\(UTCTime day tod) -> UTCTime day (adj tod)) + +-- | Return a positive time difference of a given number of days +daysLater :: Int -> DiffDateTime +daysLater n = modifyDate (addDays (fromIntegral n)) + +-- | Return a negative time difference of a given number of days +daysEarlier :: Int -> DiffDateTime +daysEarlier = daysLater . negate + +-- | Return a positive time difference of a given number of months +monthsEarlier :: Int -> DiffDateTime +monthsEarlier n = modifyDate (addGregorianMonthsClip (fromIntegral n)) + +-- | Return a negative time difference of a given number of months +monthsLater :: Int -> DiffDateTime +monthsLater = monthsEarlier . negate + +-- | Return a negative time difference of a given number of quarters +quartersLater :: Int -> DiffDateTime +quartersLater n = monthsEarlier (n*3) + +-- | Return a positive time difference of a given number of quarters +quartersEarlier :: Int -> DiffDateTime +quartersEarlier = quartersEarlier . negate + +-- | Return a positive time difference of a given number of years +yearsEarlier :: Int -> DiffDateTime +yearsEarlier n = modifyDate (addGregorianYearsClip (fromIntegral n)) + +-- | Return a negative time difference of a given number of years +yearsLater :: Int -> DiffDateTime +yearsLater = yearsEarlier . negate + +-- | Return a time difference of a given number of seasons +-- +-- Not implemented yet +seasons :: Int -> DiffDateTime +seasons n = error "TODO: definition for seasons" + +-- | Return the time difference between midnight and a given time +atTimeOfDay :: Int -- ^Hours + -> Int -- ^Minutes + -> DiffDateTime +atTimeOfDay h m = modifyTime $ \_ -> timeOfDayToTime (TimeOfDay h m 0) + +-- | A date difference that sets the day of the month +-- (offset from the begining of the month, starting with 1). +onDayOfMonth :: Int -> DiffDateTime +onDayOfMonth d = + modifyDate $ \day -> + let (y, m, _) = toGregorian day + in fromGregorian y m d + +-- | A date difference that sets the month of the year +-- (offset from the begining of the month, starting with 1). +inMonth :: Int -> DiffDateTime +inMonth m = + modifyDate $ \day -> + let (y, _, d) = toGregorian day + in fromGregorian y m d + +-- | Define a time duration, in terms of hours, minutes and seconds. +duration :: Int -- ^Hours + -> Int -- ^Minutes + -> Int -- ^Seconds + -> Duration +duration h m s = Duration ((h * 60 + m) * 60 + s) + +-- | Double conversion - e.g. FX, unit conversion +convertDouble :: Obs Double -- ^Double to convert + -> Obs Double -- ^Conversion factor + -> Obs Double +convertDouble toConvert factor = toConvert * factor + +-- * Extra combinators +-- | Combine a list of contract into a contract +allOf :: [Contract] -> Contract +allOf [] = zero +allOf xs = foldr1 and xs + +--anyOneOf :: [(ChoiceLabel, Contract)] -> Contract +--anyOneOf + +-- | Choice between a contract and a zero contract (used for options) +orZero :: ChoiceId -> Contract -> Contract +orZero cid c = or cid c zero + +-- | Like 'give' but to a named third party rather than the implicit +-- counterparty. +-- +giveTo :: PartyName -> Contract -> Contract +giveTo p = party p . give + +-- | Acquire a sub-contract where the counterparty is a named third party +-- rather than the usual implicit counterparty. +-- +recieveFrom :: PartyName -> Contract -> Contract +recieveFrom p = party p + +-- * Simple contract templates +-- | Basic physical leg +physical :: Volume -> Market -> Contract +physical vol (Market comod unit loc) = + scale vol (one (Physical comod unit loc Nothing Nothing)) + +-- | Basic financial leg +financial :: Price -> Currency -> CashFlowType -> Contract +financial pr cur cft = + scale pr (one (Financial cur cft Nothing)) + +-- | A physical leg with additional trade attributes. +-- +-- Example +-- +-- > physicalWith vol market (withDuration duration <> withPortfolio "example") +-- +physicalWith :: Volume -> Market -> TradeAttrs -> Contract +physicalWith vol (Market comod unit loc) (TradeAttr modifyAttrs) = + scale vol . one . modifyAttrs $ Physical comod unit loc Nothing Nothing + +-- | A physical leg with additional trade attributes. +-- +-- Example +-- +-- > financialWith vol market (withPortfolio "example") +-- +financialWith :: Price -> Currency -> CashFlowType -> TradeAttrs -> Contract +financialWith pr cur cft (TradeAttr modifyAttrs) = + scale pr . one . modifyAttrs $ Financial cur cft Nothing + +-- | Additional optional attributes of a trade. +-- See 'physicalWith' and 'financialWith'. +-- +newtype TradeAttrs = TradeAttr (Tradeable -> Tradeable) + +instance Monoid TradeAttrs where + mempty = TradeAttr id + mappend (TradeAttr a) (TradeAttr b) = TradeAttr (b . a) + +withPortfolio :: String -> TradeAttrs +withPortfolio portfolio = TradeAttr setPortfolio + where + setPortfolio (Physical comod unit loc dur _) = + Physical comod unit loc dur (Just (Portfolio portfolio)) + + setPortfolio (Financial cur cft _) = + Financial cur cft (Just (Portfolio portfolio)) + +withDuration :: Duration -> TradeAttrs +withDuration duration = TradeAttr setDuration + where + setDuration (Physical comod unit loc _ portfolio) = + Physical comod unit loc (Just duration) portfolio + + setDuration (Financial {}) = + error "withDuration only applies to physical trades" + +-- | A physical leg with a duration +physicalWithDuration :: Volume -> Market -> Duration -> Contract +physicalWithDuration vol (Market comod unit loc) dur = + scale vol (one (Physical comod unit loc (Just dur) Nothing)) + +{-# DEPRECATED physicalWithDuration "Use physicalWith vol market (withDuration d)" #-} + +{- TODO: not used, will it ever be used or can we delete it? +-- A physical contract with a delivery/settlement schedule +physicalWithSchedule :: Volume -> Market -> Maybe Schedule -> Maybe Duration -> Contract +physicalWithSchedule vol m sch dur = + if (isNothing sch) then (physicalWithDuration vol m dur) else (allOf [when (at t) $ (physicalWithDuration vol m dur) | t <- (fromJust sch)]) +-} + + +{- TODO: not used, will it ever be used or can we delete it? +-- A financial contract with a delivery/settlement schedule +financialWithSchedule :: Price -> Currency -> CashFlowType -> Maybe Schedule -> Contract +financialWithSchedule pr cur cft sch = + if (isNothing sch) then (financial pr cur cft) else (allOf [when (at t) $ (financial pr cur cft) | t <- (fromJust sch)]) +-} + +-- | A fixed price: transform a double into an observable +fixedPrice :: Double -> Price +fixedPrice pr = konst pr + +-- | A floating price +floatingPrice :: Obs Double -> Price +floatingPrice pr = pr + +-- | Aquire a contract multiple times according to a schedule. +-- +-- For example this can be used to apply a settlement/delivery schedule. +-- +scheduled :: Contract -> Schedule -> Contract +scheduled c sch = + allOf [ when (at t) $ c | t <- sch ] + +scheduledContract :: Contract -> Schedule -> Contract +scheduledContract = scheduled +{-# DEPRECATED scheduledContract "Use simply 'scheduled' instead." #-} + +-- * More complex trades +-- | A zero coupon bond: delivery of a notional amount at a given time +zcb :: DateTime -- ^Delivery date time + -> Price -- ^Notional amount + -> Currency -- ^Payment currency + -> CashFlowType -- ^Cashflow type + -> Contract +zcb t pr cur cft = when (at t) (financial pr cur cft) + +-- More 'advanced' bonds +-- | Chooser Range +-- +-- The note pays a coupon based on the number of days that e.g. 6-month LIBOR +-- sits within an e.g. [80bps] range. +-- The range is chosen by the buyer at the beginning of each coupon period. +chooserLeg :: Int -- ^Range for observation period + -> Int -- ^Index strike for observation period + -> Time -- ^Coupon settlement date + -> Schedule -- ^Dates for observation period + -> Currency -- ^Payment currency + -> Index -- ^Coupon rate + -> CashFlowType -- ^Cashflow type + -> Contract + +chooserLeg range strike setD sch cur cRate cft = + + foldr daily settlementDate sch (konst 0) + + where + daily (day) next daysWithinRange = + when (at day) $ + letin "daysWithinRange" + (daysWithinRange %+ indexInRange strike range) + (\daysWithinRange -> next daysWithinRange) + + settlementDate couponAmount = when (at setD) $ financial paymentDue cur cft + where + -- bit of a cheat here. should be a count of actual business days, not total + -- number of days + paymentDue = cRate %* var "daysWithinRange" %/ konst (fromIntegral(length sch)) + + -- If the coupon rate is within strike +/- range then increase days within + -- range otherwise don't increase days within range + indexInRange strike range = + + ifthen (cRate %<= konst (fromIntegral(strike + range)) + %&& cRate %> konst (fromIntegral(strike - range))) + (konst 1) (konst 0) + +-- | A chooser note has a set of 'chooserLeg' +chooserNote :: [Contract] -> Contract +chooserNote c = allOf c + +-- | Forward: agreement to buy or sell an asset at a pre-agreed future point +forward :: FeeCalc -- ^Fees + -> Market -- ^Market, e.g. NBP Gas + -> Volume -- ^Notional volume + -> Price -- ^Price + -> Currency -- ^Payment currency + -> CashFlowType -- ^Cashflow type + -> Schedule -- ^Schedule for physical settlement + -> Schedule -- ^Schedule for financial settlement + -> Contract +forward fee market vol pr cur cft pSch fSch = + give (calcFee fee vol pr cur fSch) + `and` + (scheduled (physical vol market) pSch) `and` (scheduled (give (financial (vol * pr) cur cft)) fSch) + +-- | Commodity swing: a contract guaranteeing one of two parties periodic +-- delivery of a certain amount of commodity (the nominated amount) +-- on certain dates in the future, within a given delivery period, at a +-- stipulated constant price (the strike price). +-- +-- The party can also change ("swing") the amount delivered from the nominated +-- amount to a new amount on a short notice, for a limited number of times +commoditySwing :: FeeCalc -- ^Fees + -> Market -- ^Market, e.g. NBP Gas + -> Price -- ^Price + -> Currency -- ^Payment currency + -> CashFlowType -- ^Cashflow type + -> (Volume, Volume, Volume) -- ^(low, normal, high) delivery volumes + -> Int -- ^Number of exercise times + -> DiffDateTime -- ^How far the option is in advance + -> SegmentedSchedule -- ^Delivery schedule + -> Contract +commoditySwing fee market pr cur cft (lowVol,normalVol, highVol) + exerciseCount optionDiffTime sched = + allOf + [ give (calcFee fee normalVol pr cur sched) + , letin "count" (konst (fromIntegral exerciseCount)) $ \count0 -> + foldr leg (\_ -> zero) sched count0 + ] + where + leg deliverySegment remainder count = + when (at optionTime) $ + cond (count %<= 0) + normal + (or "normal" normal + (or "low-high" low high)) + where + optionTime = firstDeliveryTime `adjustDateTime` optionDiffTime + firstDeliveryTime = head deliverySegment + + normal = and (delivery deliverySegment normalVol) (remainder count) + low = and (delivery deliverySegment lowVol) + (letin "count" (count - 1) (\count' -> remainder count')) + high = and (delivery deliverySegment highVol) + (letin "count" (count - 1) (\count' -> remainder count')) + + delivery sch vol = scheduledContract (and (physical vol market) (give (financial (vol * pr) cur cft))) sch + +-- * Trade metadata +-- | Counterparty +newtype CounterParty = CounterParty String deriving (Show, Eq) +-- | Trader +newtype Trader = Trader String deriving (Show, Eq) +-- | Book +newtype Book = Book String deriving (Show, Eq) + + +-- * Types for margining, fixing, netting, settlement +-- | Margining schedule +type MarginingSchedule = Schedule +-- | Fixing schedule +type FixingSchedule = Schedule + +-- | Settlement schedule +type SettlementSchedule = Schedule +-- | Settlement volume variance (for actuals) +type SettlementVolumeVariance = Obs Double +-- | Settlement agreement +data SettlementAgreement = SettlementAgreement Market SettlementSchedule + +-- | Market netting agreement +data MarketNettingAgreement = MarketNettingAgreement CounterParty Market +-- | Cross-market netting agreement +data CrossMarketNettingAgreement = CrossMarketNettingAgreement CounterParty + + +-- * Fee calculations +-- | Type for fee calculations +newtype FeeCalc = FeeCalc (Volume -> Price -> Currency -> Int -> Contract) + +instance Monoid FeeCalc where + mempty = zeroFee + mappend = andFee + +-- | Function to calculate fees +calcFee :: FeeCalc -- ^Function to apply to calculate the fees + -> Volume -- ^Contract notional volume + -> Price -- ^Contract price + -> Currency -- ^Contract currency + -> [a] -- ^The schedule + -> Contract +calcFee (FeeCalc fc) vol pr cur sch = fc vol pr cur (length sch) + +-- | No fee +zeroFee :: FeeCalc +zeroFee = FeeCalc $ \_ _ _ _ -> zero + +-- | Fees for initial margin +initialMarginFee :: FeeCalc +initialMarginFee = + FeeCalc $ \vol pr cur numDeliveries -> + financial (vol * pr * konst (fromIntegral (numDeliveries))) cur cft + where + cft = CashFlowType "initialMargin" + +-- | Basic calculated fees +computedFee :: CashFlowType -> Price -> FeeCalc +computedFee cft pr = FeeCalc $ \_ _ cur _ -> financial pr cur cft + +-- | Fixed fees +fixedFee :: CashFlowType -> Double -> FeeCalc +fixedFee cft = computedFee cft . konst + +-- | Exchange fees +exchangeFee :: Price -> FeeCalc +exchangeFee = computedFee cft + where + cft = CashFlowType "exchange" + +-- | Append 2 fee calculations +andFee :: FeeCalc -> FeeCalc -> FeeCalc +andFee (FeeCalc fc1) (FeeCalc fc2) = + FeeCalc $ \vol pr cur sch -> fc1 vol pr cur sch + `and` fc2 vol pr cur sch + +-- Not used yet +-- | Traded date +type TradedDate = Obs DateTime +-- | Contract direction (give or take) +data Direction = DGive | DTake + +-- * Utilities +-- | Function to determine amortisation rate from an amortisation table and an +-- observable rate +getAmRate :: Obs Double -> AmortisationTable -> Obs Double +getAmRate rate [] = konst 0 +getAmRate rate ((x1,x2):xs) = ifthen (rate %< konst x1) + (konst x2) $ + getAmRate rate xs + +-- * List helper functions +-- | Extract n last elements from a list +lastn :: Int -> [a] -> [a] +lastn n l = reverse (take n (reverse l)) + +-- * Basic math functions +-- | Square a double +square :: Num n => n -> n +square x = x * x diff --git a/share/Credit.hs b/share/Credit.hs new file mode 100644 --- /dev/null +++ b/share/Credit.hs @@ -0,0 +1,30 @@ +-- |Netrium is Copyright Anthony Waite, Dave Hetwett, Shaun Laurens 2009-2015, and files herein are licensed +-- |under the MIT license, the text of which can be found in license.txt +-- +-- Module for credit +module Credit where + +import Prelude hiding (and, or, min, max, abs, negate, not, read, until) +import Contract +import Common +import Calendar + +import Data.Time +import Data.Monoid + +-- |Type for credit events +type CreditEvent = (String, -- Name of the event + Bool, -- True if contract if terminated as a result of the event + Char, -- Settlement type (C for cash, P for physical) + Price, -- Capital payment as a result of the event + Currency, -- Currency of the capital payment + Obs Bool) -- True if the event has happened + +-- |Function that returns True if any of the given credit events have happened and are terminal +terminContract :: [CreditEvent] + -> Obs Bool +terminContract [] = konst False +terminContract ((_, cTermin, _, _, _, cHasHappened):xs) = + ifthen (cHasHappened %&& konst cTermin) + (konst True) + (terminContract xs) diff --git a/share/Options.hs b/share/Options.hs new file mode 100644 --- /dev/null +++ b/share/Options.hs @@ -0,0 +1,222 @@ +-- |Netrium is Copyright Anthony Waite, Dave Hetwett, Shaun Laurens 2009-2015, and files herein are licensed +-- |under the MIT license, the text of which can be found in license.txt +-- +-- Module for options +-- +-- Options are built up as follows: +-- +-- In general terms, an option is a contract that gives you the right, under +-- certain conditions, to buy (call) or sell (put) some underlying asset. +-- +-- There are two separate aspects to an \"underlying\": +-- +-- * There are the rights (ie a contract) you get when you choose to exercise +-- the option (e.g. the right to buy some physical or financial asset) +-- +-- * An observable, usually related to the spot price of the physical or +-- financial asset that the option involves. +-- +module Options where + +import Prelude hiding (and, or, min, max, abs, negate, not, read, until) +import Contract +import Common +import Data.List (transpose) +import Data.Monoid + +-- * Types +-- | Add an exercise condition to a contract, e.g. to add a barrier condition +type ExerciseCondition = Contract -> Contract +-- | Define a time window when a condition applies as a set of time ranges +type ConditionWindow = [(DateTime, DateTime)] +-- | An expiration condition +type ExpirationCondition = Contract -> Contract + +-- | The spot price of the underlying asset +type UnderlyingPrice = Price + +-- | The rights to acquire the underlying asset. This must include +-- any payments (which may depend on the option strike price). +-- +type UnderlyingContract = StrikePrice -> Contract + +-- | The price the option owner pays to acquire the underlying +type StrikePrice = Price + +-- | The direction of the option (put or call) +data OptionDirection = CallOption -- ^ Option to buy underlying + | PutOption -- ^ Option to sell underlying + +-- | Option contracts differ in the detail of when and at what price the +-- option can be exercised. +-- +newtype ExerciseDetails + = ExerciseDetails (ChoiceId -> (StrikePrice -> Contract) -> Contract) + +-- * Option template +-- | Basic option template. Flexibility is achieved through 'ExerciseDetails'. +option :: ChoiceId -- ^Choice label + -> ExerciseDetails -- ^Details of when and at what price the option can be exercised + -> OptionDirection -- ^Direction of the option (call or put) + -> OptionAttrs -- ^Extra option attributes / features + -> UnderlyingContract -- ^Underlying asset + -> Contract +option cid (ExerciseDetails exerciseDetails) + optionDirection (OptionAttrs attrs) underlyingContract + + = attrs $ exerciseDetails cid $ \strikePrice -> + + case optionDirection of + CallOption -> underlyingContract strikePrice + PutOption -> give (underlyingContract strikePrice) + + +-- ** Option atributes +-- | Additional optional attributes of an 'option'. +-- +newtype OptionAttrs = OptionAttrs (Contract -> Contract) + +instance Monoid OptionAttrs where + mempty = OptionAttrs id + mappend (OptionAttrs a) (OptionAttrs b) = OptionAttrs (b . a) + +emptyOptionAttrs :: OptionAttrs +emptyOptionAttrs = mempty + +-- | Pay the given premium on aquiring the option. +-- +withPremium :: Price -> Currency -> OptionAttrs +withPremium premium cur = + OptionAttrs (and payPremium) + where + payPremium = give $ financial premium cur (CashFlowType "premium") + +-- | Pay the given premium multiple times acording to the payment schedule. +-- +withPremiumSchedule :: Price -> Currency -> Schedule -> OptionAttrs +withPremiumSchedule premium cur schedule = + OptionAttrs (and payPremium) + where + payPremium = scheduled payInstallment schedule + payInstallment = give $ financial premium cur (CashFlowType "premium") + + +-- * Templates for option parameters +-- ** Exercise time +-- | European exercise: option may be exercised only at the expiry date of the +-- option, i.e. at a single pre-defined point in time. +europeanExercise :: DateTime -> StrikePrice -> ExerciseDetails +europeanExercise exTime strikePrice = + ExerciseDetails $ \cid c -> + when (at exTime) (orZero cid (c strikePrice)) + +-- | American exercise: option may be exercised at any time before the +-- expiry date. +americanExercise :: (DateTime, DateTime) -> StrikePrice -> ExerciseDetails +americanExercise (t1, t2) strikePrice = + ExerciseDetails $ \cid c -> + anytime cid (after t1 %&& before t2) (c strikePrice) + +-- | Bermudan exercise: option may be exercised at a set (always discretely +-- spaced) number of times. +bermudanExercise :: [(DateTime, DateTime)] -> StrikePrice -> ExerciseDetails +bermudanExercise exerciseWindows strikePrice = + ExerciseDetails $ \cid c -> + allOf + [ anytime cid (after t1 %&& before t2) (c strikePrice) + | (t1, t2) <- exerciseWindows ] + +-- ** Payoff +-- | Asian exercise: option where the payoff is not determined by the underlying +-- price at maturity +-- but by the average underlying price over some pre-set period of time. +asianExercise :: UnderlyingPrice -> Schedule -> ExerciseDetails +asianExercise underlyingPrice sch = + ExerciseDetails $ \cid c -> + foldr sample (final cid c) sch 0 + where + sample t remainder sum = + when (at t) $ + letin "sum" (sum + underlyingPrice) $ \sum -> + remainder sum + + final cid c sum = orZero cid (c strikePrice) + where + strikePrice = sum / fromIntegral (length sch) + +-- ** Exercise conditions +-- | Barrier knock-in: options that start their lives worthless and only become +-- active in the event a predetermined knock-in barrier price is breached +-- Barrier options become activated or, on the contrary, null and void only if +-- the underlier reaches a predetermined level (barrier). +barrierKnockIn :: Obs Bool -> ExerciseDetails -> ExerciseDetails +barrierKnockIn condition (ExerciseDetails exerciseDetails) = + ExerciseDetails $ \cid c -> + when condition (exerciseDetails cid c) + +-- | Barrier up-and-in: spot price starts below the barrier level and has to +-- move up for the option to become activated +barrierUpAndIn :: Index -> Price -> ExerciseDetails -> ExerciseDetails +barrierUpAndIn index ceiling = barrierKnockIn (index %>= ceiling) + +-- | Barrier down-and-in: spot price starts above the barrier level and has to +-- move down for the option to become activated. +barrierDownAndIn :: Index -> Price -> ExerciseDetails -> ExerciseDetails +barrierDownAndIn index floor = barrierKnockIn (index %<= floor) + +-- * More advanced option templates +-- | Commodity Spread Option: a strip of options with a spread underlying +-- (e.g. with x legs) +-- +-- Exercise is determined by an offset to the earliest delivery date of the +-- underlying for each given option +-- +-- Generic so: +-- +-- * Options can be daily, monthly or any grain/combination of grains +-- +-- * Underlying can have any number of legs (the grain of the leg does +-- not have to be the same) +commoditySpreadOption :: ChoiceId -- ^Choice label + -> [( Market + , Volume + , Price, Currency, CashFlowType + , SegmentedSchedule + , FeeCalc )] -- ^List of underlying legs + -> DiffDateTime -- ^Exercise date offset (relative to leg) + -> DiffDateTime -- ^Payment date offset (relative to exercise) + -> OptionDirection -- ^Option direction (put or call) + -> StrikePrice -- ^Strike price of the option + -> Currency -- ^Currency of the strike price + -> CashFlowType -- ^Cashflow type of the strike price + -> Obs Double -- ^Premium + -> Currency -- ^Currency for the premium + -> Contract +commoditySpreadOption cid legs exerciseDiffTime paymentDiffTime opDir strikePrice currency cftype premium pCur = + allOf + [ legOption groupedLeg $ + allOf [ forward fee m pr cur cft vol seg seg + | (m, pr, cur, cft, vol, seg, fee) <- groupedLeg ] + | groupedLeg <- groupedLegs ] + + where + groupedLegs = + transpose + [ [ (m, pr, cur, cft, vol, seg, fee) | seg <- sch ] + | (m, pr, cur, cft, vol, sch, fee) <- legs ] + + legOption groupedLeg underlying = + + option cid exerciseDetails opDir optionPremium $ \strikePrice -> + give (financial strikePrice currency cftype) + `and` underlying + + where + exerciseDetails = europeanExercise exerciseTime strikePrice + exerciseTime = adjustDateTime earliestDeliveryTime exerciseDiffTime + where + earliestDeliveryTime = + minimum [ t | (_, _, _, _, _, (t:_), _) <- groupedLeg ] + + optionPremium = withPremiumSchedule premium pCur [premiumTime] + premiumTime = adjustDateTime exerciseTime paymentDiffTime diff --git a/share/ScheduledProduct.hs b/share/ScheduledProduct.hs new file mode 100644 --- /dev/null +++ b/share/ScheduledProduct.hs @@ -0,0 +1,193 @@ +-- |Netrium is Copyright Anthony Waite, Dave Hetwett, Shaun Laurens 2009-2015, and files herein are licensed +-- |under the MIT license, the text of which can be found in license.txt +-- +-- Scheduled products: products delivered according to a schedule. +-- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module ScheduledProduct ( + + -- * Scheduled products + ScheduledProduct, + scheduledProduct, + + -- ** Defining scheduled products + defineScheduledProduct, + DeliverySchedule, + deliverySchedule, + + -- ** Delivery shape + DeliveryShape, + deliverAtMidnight, + deliverAtTimeOfDay, + complexDeliveryShape, + + -- * Relative scheduled product type + ScheduledProductRelative, + scheduledProductRelative, + setScheduledProductDate, + defineScheduledProductRelative, + DeliveryScheduleRelative, + relativeDeliverySchedule, + + ) where + +import Contract +import Common +import Calendar + +import Data.Monoid + + +-- | A scheduled product is a contract to repeatedly acquire a quantity of an +-- underlying product according to a delivery schedule. +-- +-- Use 'productQuantity' to acquire a scheduled product and specify the +-- quantity of the underlying product to recieve each time. +-- +data ScheduledProduct q = ScheduledProduct (q -> Contract) DeliverySchedule + +-- | A relative product is a product using a relative delivery schedule. +-- Use 'setProductDate' to fix the delivery schedule. +-- +data ScheduledProductRelative q = ScheduledProductRelative (q -> Contract) DeliveryScheduleRelative + +-- | A delivery schedule for some product. +-- +-- This is an absolute schedule (e.g. June 2011, which delivers +-- from 01/06/2011 to 30/06/2011 according to a given calendar). +-- +newtype DeliverySchedule + = DeliverySchedule + [([DateTime] -- delivery days + , DateTime -- start date + , DateTime -- end date + ,DeliveryShape + )] + deriving Monoid + +-- | A relative delivery schedule for some product. +-- +-- This is a relative schedule (e.g. day ahead, month + 1, balance of month... +-- - once again according to a given calendar). +-- +newtype DeliveryScheduleRelative + = DeliveryScheduleRelative + [(DiffDateTime -- start date/time relative to acquire + ,DiffDateTime -- end date/time relative to acquire + ,Calendar -- delivery days + ,DeliveryShape + )] + deriving Monoid + +-- | The daily delivery shape says how often and when during the day the +-- product is acquired. +-- +-- The simple cases are once daily at midnight using 'deliverAtMidnight', or +-- once daily at a particular time of day using 'deliverAtTimeOfDay'. +-- +-- Complex delivery shapes can be constructed by combining multiple +-- deliveries using the '(<>)' operator, or by using 'complexDeliveryShape'. +-- +-- For exmple, two daily deliveries, 6am and 6pm: +-- +-- > deliverAtTimeOfDay 6 0 <> deliverAtTimeOfDay 18 0 +-- +-- Or, half-hourly delivery between 7am and 7pm: +-- +-- > complexDeliveryShape [ deliverAtTimeOfDay hr ms | hr <- [7..18], ms <- [0,30] ] +-- +newtype DeliveryShape = DeliveryShape [DiffDateTime] + deriving Monoid + + +-- | A contract to acquire a scheduled product using a given quantity of the +-- underlying product. +-- +scheduledProduct :: q -> ScheduledProduct q -> Contract +scheduledProduct quantity (ScheduledProduct underlying (DeliverySchedule blocks)) + = allOf + [ when (at t) (underlying quantity) + | (days, _, _, DeliveryShape deliverySegments) <- blocks + , day <- days + , offset <- deliverySegments + , let t = adjustDateTime day offset ] + +-- | A contract to acquire a relative scheduled product at a given date using a +-- given quantity of the underlying product. +-- +scheduledProductRelative :: DateTime -> q -> ScheduledProductRelative q -> Contract +scheduledProductRelative acquireDate quantity product = + scheduledProduct quantity (setScheduledProductDate acquireDate product) + +-- | Turn a product with a relative schedule into a product with an +-- absolute schedule. +-- +setScheduledProductDate :: DateTime -> ScheduledProductRelative q -> ScheduledProduct q +setScheduledProductDate acquireDate + (ScheduledProductRelative p (DeliveryScheduleRelative relShedule)) + = ScheduledProduct p $ DeliverySchedule + [ (days, startDate, endDate, shape) + | (startOffset, endOffset, cal, shape) <- relShedule + , let startDate = adjustDateTime acquireDate startOffset + endDate = adjustDateTime acquireDate endOffset + days = calendarDaysInPeriod cal (startDate, endDate) + ] + + +-- | Define a scheduled product based on an underlying contract to acquire a +-- given quantity of a product. +-- +defineScheduledProduct :: (q -> Contract) -> DeliverySchedule -> ScheduledProduct q +defineScheduledProduct = ScheduledProduct + +-- | Define a scheduled product with a schedule that is relative to some date. +-- +defineScheduledProductRelative :: (q -> Contract) -> DeliveryScheduleRelative -> ScheduledProductRelative q +defineScheduledProductRelative = ScheduledProductRelative + + +-- | Define a delivery schedule using absolute dates. +-- +-- A delivery schedule with multiple different blocks can be defined by +-- combining schedules by using the '(<>)' operator. +-- +deliverySchedule :: DateTime -> DateTime + -> Calendar -- ^ What days to deliver on + -> DeliveryShape + -> DeliverySchedule +deliverySchedule start end cal shape = + DeliverySchedule [(days, start, end, shape)] + where + days = calendarDaysInPeriod cal (start, end) + +-- | Define a delivery schedule using dates relative to the acquisition date. +-- +-- A delivery schedule with multiple different blocks can be defined by +-- combining schedules by using the '(<>)' operator. +-- +relativeDeliverySchedule :: DiffDateTime -> DiffDateTime + -> Calendar -- ^ What days to deliver on + -> DeliveryShape + -> DeliveryScheduleRelative +relativeDeliverySchedule start end cal shape = + DeliveryScheduleRelative [(start, end, cal, shape)] + + +-- | Single delivery at midnight. +-- +deliverAtMidnight :: DeliveryShape +deliverAtMidnight = deliverAtTimeOfDay 0 0 + +-- | Single delivery at a particular time of day. +-- +deliverAtTimeOfDay :: Int -> Int -> DeliveryShape +deliverAtTimeOfDay hs ms = DeliveryShape [atTimeOfDay hs ms] + +-- | Defines a complex intra-day delivery shape as a sequence of deliveries. +-- +-- For exmple, half-hourly delivery between 7am and 7pm: +-- +-- > complexDeliveryShape [ deliverAtTimeOfDay hr ms | hr <- [7..18], ms <- [0,30] ] +-- +complexDeliveryShape :: [DeliveryShape] -> DeliveryShape +complexDeliveryShape = mconcat diff --git a/share/Settlement.hs b/share/Settlement.hs new file mode 100644 --- /dev/null +++ b/share/Settlement.hs @@ -0,0 +1,10 @@ +-- |Netrium is Copyright Anthony Waite, Dave Hetwett, Shaun Laurens 2009-2015, and files herein are licensed +-- |under the MIT license, the text of which can be found in license.txt +-- +module Settlement where + +import Prelude hiding (and, or, min, max, abs, negate, not, read, until) +import Contract +import Common +import Calendar + diff --git a/share/Swaps.hs b/share/Swaps.hs new file mode 100644 --- /dev/null +++ b/share/Swaps.hs @@ -0,0 +1,129 @@ +-- |Netrium is Copyright Anthony Waite, Dave Hetwett, Shaun Laurens 2009-2015, and files herein are licensed +-- |under the MIT license, the text of which can be found in license.txt +-- +-- Module for swap contracts +module Swaps where + +import Prelude hiding (and, or, min, max, abs, negate, not, read, until) +import Contract +import Common +import Calendar +import Credit + +import Data.List (transpose) +import Data.Time +import Data.Monoid + +-- | Basic commodity swap: simultaneous swap of commodity A for commodity B for +-- a nominal cost over a delivery schedule (same cost for each delivery period) +commoditySwap :: (Market, Market) + -> (Volume, Volume) + -> Price -> Currency -> CashFlowType + -> Schedule + -> Contract +commoditySwap (market1, market2) (vol1, vol2) pr cur cft sch = + scheduled (physical vol1 market1 `and` give (physical vol2 market2 `and` (financial pr cur cft))) sch + +-- | Variance swap +-- +-- A variance swap is an instrument which allows investors to trade future +-- realized (or historical) volatility against current implied volatility. +-- Only variance —the squared volatility— can be replicated with a static +-- hedge. +varianceSwap :: Price -- ^Notional amount + -> Obs Double -- ^Vega amount + -> Obs Double -- ^Variance amount + -> Schedule -- ^Observation schedule + -> Index -- ^Placeholder for index, currently not used + -> [Price] -- ^Official closing prices of the underlying over the observation period + -> Currency -- ^Payment currency + -> CashFlowType -- ^Payment cashflow type + -> DiffDateTime -- ^Settlement offset + -> Calendar -- ^Calendar to use + -> Contract +varianceSwap strikePrice vegaAmount varianceAmount sch underlyingIndex priceCurve cur cft sDiffTime cal = + when (at settlementTime) $ + -- If the Equity Amount is negative the Variance Buyer will + -- pay the Variance Seller an amount equal to the absolute + --value of the Equity Amount + cond (finalEquityAmount %<= konst 0) + (give (financial (abs(finalEquityAmount)) cur cft)) + -- If the Equity Amount is positive the Variance Seller will pay + -- the Variance Buyer the Equity Amount + (financial finalEquityAmount cur cft) + + where + settlementTime = last(sch) `adjustDateTime` sDiffTime + finalEquityAmount = varianceAmount * (square(finalRealisedVolatility) - square(strikePrice)) + finalRealisedVolatility :: Price + finalRealisedVolatility = + 100 * sqrt ((252 * sumLnPt priceCurve) / fromIntegral numBusinessDays) + where + numBusinessDays = length $ calendarDaysInPeriod cal (head sch, last sch) + + -- Function needed to calculate the final realised volatility + sumLnPt :: [Price] -> Price + sumLnPt [] = 0 + sumLnPt [x] = 0 + sumLnPt (x1:x2:xs) = square(logBase (exp 1) (x2 / x1)) + sumLnPt (x2:xs) + +-- | Index Amortising Swap +-- +-- Swap Buyer receives the following coupons: +-- Buyer rate paid e.g. quarterly (according to specified day count convention) +-- on the principal amount, amortised according to the values of the buyer rate +-- +-- Swap Seller receives seller rate on same coupon dates. +indexAmortisingSwap :: Price -- ^Notional amount + -> Schedule -- ^Coupon dates + -> (Currency, Currency) -- ^Currencies respectively for swap buyer and seller + -> (CashFlowType, CashFlowType) -- ^Cashflow types respectively for cash buyer and seller + -> AmortisationTable -- ^Amortisation table + -> DayCountConvention -- ^Day count convention, e.g. 90/360 + -> Index -- ^Buyer rate + -> Index -- ^Seller rate + -> Contract +indexAmortisingSwap notional cSch (cur1, cur2) (cft1, cft2) amTable dcc bRate sRate = + foldr cAmt zero cSch + + where + -- need to ensure fixing date is two days before coupon date + cAmt cDate next = when (at cDate) $ allOf [cCalc, next] + where + cCalc = allOf[ + financial (getAmRate bRate amTable %* notional %* konst dcc) cur1 cft1, + give $ financial (sRate %* notional %* konst dcc) cur2 cft2 + ] + +-- |Credit Default Swap +-- +-- CDS buyer pays an agreed rate on an agreed basis on the principal amount +-- +-- CDS seller makes capital payments if and when credit events happen +creditDefaultSwap :: [CreditEvent] -- ^List of credit events + -> Price -- ^Notional amount + -> Schedule -- ^Payment schedule + -> Currency -- ^Payment currency + -> Index -- ^Payment rate + -> CashFlowType -- ^Payment cashflow type + -> DayCountConvention -- ^Day count convention, e.g. 90/360 + -> Underlying -- ^Underlying asset + -> Contract +creditDefaultSwap cEvents notional cSch cur pRate cft dcc underlying = + and +-- CDS buyer pays an agreed rate on an agreed basis on the principal amount +-- First, check if any credit events that would cause a termination of the contract has happened + (cond(terminContract cEvents) + zero + (foldr cAmt zero cSch)) + +-- CDS seller makes capital payments if and when credit events happen + (foldr capPay zero cEvents) + + where + cAmt cDate next = when (at cDate) $ allOf [(financial (pRate %* notional %* konst dcc) cur cft), next] + capPay (_, cTermin, sType, capPay, cCur, cHasHappened) next = when (cHasHappened) $ allOf[ + (if (sType == 'C') + then (give (financial capPay cCur (CashFlowType "cash"))) + else (give underlying)) + , next] diff --git a/share/normalise-wrapper.hs b/share/normalise-wrapper.hs new file mode 100644 --- /dev/null +++ b/share/normalise-wrapper.hs @@ -0,0 +1,12 @@ +-- |Netrium is Copyright Anthony Waite, Dave Hetwett, Shaun Laurens 2009-2015, and files herein are licensed +-- |under the MIT license, the text of which can be found in license.txt +-- +module Main where + +import Prelude hiding (and, or, min, max, abs, negate, not, read, until) +import Contract +import Common + +import qualified Text.XML.HaXml.XmlContent as XML +import qualified Text.XML.HaXml.Pretty as XML.PP +import qualified Text.PrettyPrint as PP diff --git a/src/Contract.hs b/src/Contract.hs new file mode 100644 --- /dev/null +++ b/src/Contract.hs @@ -0,0 +1,305 @@ +-- |Netrium is Copyright Anthony Waite, Dave Hetwett, Shaun Laurens 2009-2015, and files herein are licensed +-- |under the MIT license, the text of which can be found in license.txt +-- +-- The definition of the basic contract language +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Contract ( + -- * Contracts + -- ** The contract type and primitives + Contract(..), + zero, one, + and, give, party, + or, cond, + scale, ScaleFactor, + when, anytime, until, + read, letin, + + -- ** Tradable items + Tradeable(..), + Commodity(..), Unit(..), Location(..), Duration(..), + Currency(..), CashFlowType(..), Portfolio(..), + + -- ** Choice identifiers + ChoiceId, PartyName, + + -- * Observables + Obs, + konst, var, primVar, primCond, + Time, + at, before, after, between, + ifthen, negate, max, min, abs, + (%==), + (%>), (%>=), (%<), (%<=), + (%&&), (%||), + (%+), (%-), (%*), (%/), + ) where + +import Observable + ( Time, mkdate + , Obs, konst, var, primVar, primCond, at, before, after, between + , (%==), (%>), (%>=), (%<), (%<=) + , (%&&), (%||), (%+), (%-), (%*), (%/) + , ifthen, negate, not, max, min, abs + , parseObsCond, parseObsReal, printObs ) +import Display +import XmlUtils + +import Prelude hiding (product, read, until, and, or, min, max, abs, not, negate) +import Control.Monad hiding (when) +import Text.XML.HaXml.Namespaces (localName) +import Text.XML.HaXml.Types (QName(..)) +import Text.XML.HaXml.XmlContent + +-- * Contract type definition +-- | A canonical tradeable element, physical or financial +data Tradeable = Physical Commodity Unit Location (Maybe Duration) (Maybe Portfolio) + | Financial Currency CashFlowType (Maybe Portfolio) + deriving (Eq, Show) + +-- | A duration is a span of time, measured in seconds. +-- +newtype Duration = Duration Int {- in sec -} deriving (Eq, Show, Num) +-- | Commodity, e.g. Gas, Electricity +newtype Commodity = Commodity String deriving (Eq, Show) +-- | Unit, e.g. tonnes, MWh +newtype Unit = Unit String deriving (Eq, Show) +-- | Location, e.g. UK, EU +newtype Location = Location String deriving (Eq, Show) +-- | Currency, e.g. EUR, USD, GBP +newtype Currency = Currency String deriving (Eq, Show) +-- | Cashflow type, e.g. cash, premium +newtype CashFlowType = CashFlowType String deriving (Eq, Show) +-- | Portfolio name +newtype Portfolio = Portfolio String deriving (Eq, Show) + +-- | Scaling factor (used to scale the 'One' contract) +type ScaleFactor = Double + +-- | Choice label, used for options +type ChoiceId = String + +-- | Name of a third party mentioned in a contract +type PartyName = String + +-- | The main contract data type +-- +data Contract + = Zero + | One Tradeable + + | Give Contract + | Party PartyName Contract + | And Contract Contract + + | Or ChoiceId Contract Contract + | Cond (Obs Bool) Contract Contract + + | Scale (Obs Double) Contract + | Read Var (Obs Double) Contract + + | When (Obs Bool) Contract + | Anytime ChoiceId (Obs Bool) Contract + | Until (Obs Bool) Contract + deriving (Eq, Show) + +-- | A variable +type Var = String + +-- | The @zero@ contract has no rights and no obligations. +zero :: Contract +zero = Zero + +-- | If you acquire @one t@ you immediately recieve one unit of the +-- 'Tradeable' @t@. +one :: Tradeable -> Contract +one = One + +-- | Swap the rights and obligations of the party and counterparty. +give :: Contract -> Contract +give = Give + +-- | Make a contract with a named 3rd party as the counterparty. +party :: PartyName -> Contract -> Contract +party = Party + +-- | If you acquire @c1 `and` c2@ you immediately acquire /both/ @c1@ and @c2@. +and :: Contract -> Contract -> Contract +and = And + +-- | If you acquire @c1 `or` c2@ you immediately acquire your choice of +-- /either/ @c1@ or @c2@. +or :: ChoiceId -> Contract -> Contract -> Contract +or = Or +--TODO: document the ChoiceId + +-- | If you acquire @cond obs c1 c2@ then you acquire @c1@ if the observable +-- @obs@ is true /at the moment of acquistion/, and @c2@ otherwise. +cond :: Obs Bool -> Contract -> Contract -> Contract +cond = Cond + +-- | If you acquire @scale obs c@, then you acquire @c@ at the same moment +-- except that all the subsequent trades of @c@ are multiplied by the value +-- of the observable @obs@ /at the moment of acquistion/. +scale :: Obs ScaleFactor -> Contract -> Contract +scale = Scale + +read :: Var -> Obs Double -> Contract -> Contract +read = Read +{-# DEPRECATED read "Use 'letin' instead." #-} + +-- | If you acquire @when obs c@, you must acquire @c@ as soon as observable +-- @obs@ subsequently becomes true. +when :: Obs Bool -> Contract -> Contract +when = When + +-- | Once you acquire @anytime obs c@, you /may/ acquire @c@ at any time the +-- observable @obs@ is true. +anytime :: ChoiceId -> Obs Bool -> Contract -> Contract +anytime = Anytime + +-- | Once acquired, @until obs c@ is exactly like @c@ except that it /must be +-- abandoned/ when observable @obs@ becomes true. +until :: Obs Bool -> Contract -> Contract +until = Until + + +-- | Observe the value of an observable now and save its value to use later. +-- +-- Currently this requires a unique variable name. +-- +-- Example: +-- +-- > letin "count" (count-1) $ \count' -> +-- > ... +-- +letin :: String -- ^ A unique variable name + -> Obs Double -- ^ The observable to observe now + -> (Obs Double -> Contract) -- ^ The contract using the observed value + -> Contract +letin vname obs c = read vname obs (c (var vname)) + + +-- Display tree instances +instance Display Contract where + toTree Zero = Node "zero" [] + toTree (One t) = Node "one" [Node (show t) []] + toTree (Give c) = Node "give" [toTree c] + toTree (Party p c) = Node ("party " ++ p)[toTree c] + toTree (And c1 c2) = Node "and" [toTree c1, toTree c2] + toTree (Or cid c1 c2) = Node ("or " ++ cid) [toTree c1, toTree c2] + toTree (Cond o c1 c2) = Node "cond" [toTree o, toTree c1, toTree c2] + toTree (Scale o c) = Node "scale" [toTree o, toTree c] + toTree (Read n o c) = Node ("read " ++ n) [toTree o, toTree c] + toTree (When o c) = Node "when" [toTree o, toTree c] + toTree (Anytime cid o c) = Node ("anytime" ++ cid) [toTree o, toTree c] + toTree (Until o c) = Node "until" [toTree o, toTree c] + +-- XML instances +instance HTypeable Tradeable where + toHType _ = Defined "Tradeable" [] [] + +instance XmlContent Tradeable where + parseContents = do + e@(Elem t _ _) <- element ["Physical","Financial"] + commit $ interior e $ case localName t of + "Physical" -> liftM5 Physical parseContents parseContents + parseContents parseContents + parseContents + "Financial" -> liftM3 Financial parseContents parseContents + parseContents + + toContents (Physical c u l d p) = + [mkElemC "Physical" (toContents c ++ toContents u + ++ toContents l ++ toContents d + ++ toContents p)] + toContents (Financial c t p) = + [mkElemC "Financial" (toContents c ++ toContents t + ++ toContents p)] + +instance HTypeable Duration where + toHType _ = Defined "Duration" [] [] + +instance XmlContent Duration where + parseContents = inElement "Duration" (liftM Duration readText) + toContents (Duration sec) = [mkElemC "Duration" (toText (show sec))] + +instance HTypeable Commodity where + toHType _ = Defined "Commodity" [] [] + +instance XmlContent Commodity where + parseContents = inElement "Commodity" (liftM Commodity text) + toContents (Commodity name) = [mkElemC "Commodity" (toText name)] + +instance HTypeable Unit where + toHType _ = Defined "Unit" [] [] + +instance XmlContent Unit where + parseContents = inElement "Unit" (liftM Unit text) + toContents (Unit name) = [mkElemC "Unit" (toText name)] + +instance HTypeable Location where + toHType _ = Defined "Location" [] [] + +instance XmlContent Location where + parseContents = inElement "Location" (liftM Location text) + toContents (Location name) = [mkElemC "Location" (toText name)] + +instance HTypeable Currency where + toHType _ = Defined "Currency" [] [] + +instance XmlContent Currency where + parseContents = inElement "Currency" (liftM Currency text) + toContents (Currency name) = [mkElemC "Currency" (toText name)] + +instance HTypeable CashFlowType where + toHType _ = Defined "CashFlowType" [] [] + +instance XmlContent CashFlowType where + parseContents = inElement "CashFlowType" (liftM CashFlowType text) + toContents (CashFlowType name) = [mkElemC "CashFlowType" (toText name)] + +instance HTypeable Portfolio where + toHType _ = Defined "Portfolio" [] [] + +instance XmlContent Portfolio where + parseContents = inElement "Portfolio" (liftM Portfolio text) + toContents (Portfolio name) = [mkElemC "Portfolio" (toText name)] + +instance HTypeable Contract where + toHType _ = Defined "Contract" [] [] + +instance XmlContent Contract where + parseContents = do + e@(Elem t _ _) <- element ["Zero","When","Until","Scale","Read" + ,"Or","One","Give","Party","Cond","Anytime","And"] + commit $ interior e $ case localName t of + "Zero" -> return Zero + "One" -> liftM One parseContents + "Give" -> liftM Give parseContents + "Party" -> liftM2 Party (attrStr (N "name") e) parseContents + "And" -> liftM2 And parseContents parseContents + "Or" -> liftM3 Or (attrStr (N "choiceid") e) parseContents parseContents + "Cond" -> liftM3 Cond parseObsCond parseContents parseContents + "Scale" -> liftM2 Scale parseObsReal parseContents + "Read" -> liftM3 Read (attrStr (N "var") e) parseObsReal parseContents + "When" -> liftM2 When parseObsCond parseContents + "Anytime" -> liftM3 Anytime (attrStr (N "choiceid") e) parseObsCond parseContents + "Until" -> liftM2 Until parseObsCond parseContents + + toContents Zero = [mkElemC "Zero" []] + toContents (One t) = [mkElemC "One" (toContents t)] + toContents (Give c) = [mkElemC "Give" (toContents c)] + toContents (Party p c) = [mkElemAC (N "Party") [(N "name", str2attr p)] + (toContents c)] + toContents (And c1 c2) = [mkElemC "And" (toContents c1 ++ toContents c2)] + toContents (Or cid c1 c2) = [mkElemAC (N "Or") [(N "choiceid", str2attr cid)] + (toContents c1 ++ toContents c2)] + toContents (Cond o c1 c2) = [mkElemC "Cond" (printObs o : toContents c1 ++ toContents c2)] + toContents (Scale o c) = [mkElemC "Scale" (printObs o : toContents c)] + toContents (Read n o c) = [mkElemAC (N "Read") [(N "var", str2attr n)] + (printObs o : toContents c)] + toContents (When o c) = [mkElemC "When" (printObs o : toContents c)] + toContents (Anytime cid o c) = [mkElemAC (N "Anytime") [(N "choiceid", str2attr cid)] + (printObs o : toContents c)] + toContents (Until o c) = [mkElemC "Until" (printObs o : toContents c)] diff --git a/src/DecisionTree.hs b/src/DecisionTree.hs new file mode 100644 --- /dev/null +++ b/src/DecisionTree.hs @@ -0,0 +1,501 @@ +-- |Netrium is Copyright Anthony Waite, Dave Hetwett, Shaun Laurens 2009-2015, and files herein are licensed +-- |under the MIT license, the text of which can be found in license.txt +-- +{-# LANGUAGE DeriveFunctor, GADTs, PatternGuards #-} + +module DecisionTree where + +import Contract +import Observable (Steps(..)) +import qualified Observable as Obs +import Display + +import Prelude hiding (product, until, and) +import Data.List hiding (and) +import Control.Monad hiding (when) +import Text.XML.HaXml.Namespaces (localName) +import Text.XML.HaXml.XmlContent + +-- --------------------------------------------------------------------------- +-- * Contract decision trees +-- --------------------------------------------------------------------------- + +-- | A single step in a decision tree +-- +data DecisionStep x = Done + | Trade TradeDir Double Tradeable x + + | Choose Party ChoiceId x x + | ObserveCond (Obs Bool) x x + | ObserveValue (Obs Double) (Double -> x) + + -- Waiting for any observable to become true, + -- or alternativly we can exercise an option that is + -- available in the current state + | Wait [(Obs Bool, Time -> x)] [(ChoiceId, Time -> x)] + deriving Functor + +data Party = FirstParty | Counterparty | ThirdParty PartyName + deriving (Eq, Show) + +-- See also data TradeDir below + +-- | A full decision tree +-- +data DecisionTree = DecisionTree Time (DecisionStep DecisionTree) + +unfoldDecisionTree :: (a -> (DecisionStep a, Time)) -> a -> DecisionTree +unfoldDecisionTree next = unfold + where + unfold x = case next x of + (step, time) -> DecisionTree time (fmap unfold step) + +decisionTree :: Time -> Contract -> DecisionTree +decisionTree t c = unfoldDecisionTree + (\pst@(PSt t' _ _) -> (decisionStep pst, t')) + (initialProcessState t c) + +-- --------------------------------------------------------------------------- +-- * Basic step +-- --------------------------------------------------------------------------- + +-- | Current time, blocked, and runnable 'ThreadState's +data ProcessState = PSt Time -- current time + [Blocked ThreadState] -- blocked + [ThreadState] -- runnable + deriving (Show, Eq) + +-- | Remaining contract, 'until' conditions, inherited scaling, and direction of trade +data ThreadState = TSt Contract -- remaining contract + [Obs Bool] -- 'until' conditions + ScaleFactor -- inherited scaling + TradeDir -- direction of trade + deriving (Show, Eq) + +data Blocked c = + + -- | waiting for obs to become True + BlockedOnWhen (Obs Bool) c + + -- | waiting for obs to become value v + | BlockedOnAnytime Bool ChoiceId (Obs Bool) c + deriving (Show, Eq) + + +initialProcessState :: Time -> Contract -> ProcessState +initialProcessState time contract = + let initialThread = TSt contract [] 1 TradeDir2To1 + in PSt time [] [initialThread] + + +currentContract :: ProcessState -> Contract +currentContract (PSt _time blocked runnable) = + allOf + [ evalTradeDir tradeDir + (scaleBy scaleFactor + (foldr until contract untilObss)) + | let threads = runnable ++ map unBlocked blocked + , TSt contract untilObss scaleFactor tradeDir <- threads + , contract /= zero ] + where + scaleBy 1.0 c = c + scaleBy s c = scale (konst s) c + + unBlocked (BlockedOnWhen o cth) = update (when o) cth + unBlocked (BlockedOnAnytime _ cid o cth) = update (anytime cid o) cth + update f (TSt c uos sf d) = TSt (f c) uos sf d + + allOf [] = zero + allOf xs = foldr1 and xs + + +decisionStep :: ProcessState -> DecisionStep ProcessState +decisionStep (PSt time blocked runnable) = + go blocked runnable + + where + -- We have at least one runnable thread + go bs (TSt c uos sf d:rs) = case c of + Zero -> go bs rs + + One t -> Trade d sf t (PSt time bs rs) + + Give c1 -> let r' = TSt c1 uos sf (flipTradeDir d) + in go bs (r':rs) + + Party p c1 -> let d' = setThirdParty p d + r' = TSt c1 uos sf d' + in go bs (r':rs) + + And c1 c2 -> let r1 = TSt c1 uos sf d + r2 = TSt c2 uos sf d + in go bs (r1:r2:rs) + + Or cid c1 c2 -> let r1 = TSt c1 uos sf d + r2 = TSt c2 uos sf d + (p,_) = tradeDirParties d + in Choose p cid (PSt time bs (r1:rs)) + (PSt time bs (r2:rs)) + + Cond o c1 c2 -> let r1 = TSt c1 uos sf d + r2 = TSt c2 uos sf d + in ObserveCond o (PSt time bs (r1:rs)) + (PSt time bs (r2:rs)) + + Scale o c1 -> let r' v = TSt c1 uos (v * sf) d + in ObserveValue o (\v -> PSt time bs (r' v:rs)) + + Read n o c1 -> let r' v = TSt (subst n v c1) uos sf d + in ObserveValue o (\v -> PSt time bs (r' v:rs)) + + When o c1 -> let b = BlockedOnWhen o (TSt c1 uos sf d) + in go (b:bs) rs + + Anytime cid o c1 -> let b = BlockedOnAnytime True cid o (TSt c1 uos sf d) + in go (b:bs) rs + + Until o c1 -> let r' = TSt c1 (o:uos) sf d + in ObserveCond o (PSt time bs rs) + (PSt time bs (r':rs)) + + -- No threads at all, we're done + go [] [] = Done + + -- All threads are blocked + go bs [] = Wait (whens ++ untils) opts + + where + -- the threads blocked on 'when'/'anytime' + whens = [ ( blockedObs b + , case nextThread b of + Left r' -> \time' -> PSt time' bs' [r'] + Right b' -> \time' -> PSt time' (b':bs') [] ) + | (b, bs') <- each bs ] + + -- some blocked threads also have 'until' conditions + untils = [ ( uo + , \time' -> PSt time' bs' [] ) + | (b, bs') <- each bs + , let TSt _ uos _ _ = blockedThr b + , uo <- uos ] + + -- blocked 'anytime' threads, for which their observable is currently + -- true, give us an option that we may choose to exercise + -- Note: BlockedOnAnytime False means waiting for it to *become* False + opts = [ (cid, \time' -> PSt time' bs' [r']) + | (BlockedOnAnytime False cid _ r', bs') <- each bs ] + + -- the observable that it is blocking on, + -- remember that we're waiting for the obs to become True + blockedObs (BlockedOnWhen o _) = o + blockedObs (BlockedOnAnytime True _ o _) = o + -- so invert for blocked anytime threads where we're waiting for False: + blockedObs (BlockedOnAnytime False _ o _) = Obs.not o + + blockedThr (BlockedOnWhen _ x) = x + blockedThr (BlockedOnAnytime _ _ _ x) = x + + -- either the new runnable thread or new blocked thread + nextThread (BlockedOnWhen _ r) = Left r + nextThread (BlockedOnAnytime v cid o b) = + Right (BlockedOnAnytime (not v) cid o b) + +subst :: String -> Double -> Contract -> Contract +subst n v c = case c of + Zero -> c + One _ -> c + Give c1 -> Give (subst n v c1) + Party p c1 -> Party p (subst n v c1) + And c1 c2 -> And (subst n v c1) (subst n v c2) + Or id c1 c2 -> Or id (subst n v c1) (subst n v c2) + Cond o c1 c2 -> Cond (Obs.subst n v o) (subst n v c1) (subst n v c2) + Scale o c1 -> Scale (Obs.subst n v o) (subst n v c1) + Read n' o c1 + | n == n' -> Read n' (Obs.subst n v o) c1 + | otherwise-> Read n' (Obs.subst n v o) (subst n v c1) + When o c1 -> When (Obs.subst n v o) (subst n v c1) + Anytime cid o c1 -> Anytime cid (Obs.subst n v o) (subst n v c1) + Until o c1 -> Until (Obs.subst n v o) (subst n v c1) + + +each :: [a] -> [(a, [a])] +each xs = [ (xs !! n, [ x' | (n',x') <- nxs, n' /= n ] ) + | n <- [0..length xs-1] ] + where + nxs = zip [0..] xs + + +-- --------------------------------------------------------------------------- +-- * Trade directions +-- --------------------------------------------------------------------------- + +-- Warning: whis is all rather subtle. + +-- It is for handling the 'party' contract combinator and its interactions with +-- the 'give' combinator. The point of 'party' is to transfer the rights and +-- obligations of the implicit counterparty to an explicit named third party. +-- Using various combinations of 'party' and 'give' we can construct trades in +-- either direction between any pair of 1st, 2nd and named 3rd parties. +-- +-- There is an algebra relating the combinators, in particular the laws: +-- +-- > give . give = id +-- > party q . party p = party p +-- +-- and a more subtle one: +-- +-- > give . party q . give . party p = party q . give . party p +-- +-- This says that once we have a trade between two third parties it is no +-- longer affected by 'give', because 'give' only swaps between the 1st and 2nd +-- parties. +-- +-- Combined, this means that there's actually only a finite number of +-- combinations of 'give' and 'party', the following eight: + +data TradeDir + = TradeDir2To1 -- id 2nd --> 1st party + | TradeDir1To2 -- give . id 1st --> 2nd party + + | TradeDirPTo1 PartyName -- party p named 3rd --> 1st party + | TradeDirPTo2 PartyName -- give . party p named 3rd --> 2nd party + + | TradeDir1ToP PartyName -- party p . give 1st --> named 3rd party + | TradeDir2ToP PartyName -- give . party p . give 2nd --> named 3rd party + + | TradeDirPToQ PartyName PartyName -- party q . give . party p p --> q + | TradeDirQToP PartyName PartyName -- party q . give . party p . give q --> p + deriving (Show, Eq) + +-- | Give the interpretation of a TradeDir as a combination +-- of 'party' and 'give'. +-- +evalTradeDir :: TradeDir -> (Contract -> Contract) +evalTradeDir TradeDir2To1 = id +evalTradeDir TradeDir1To2 = give +evalTradeDir (TradeDirPTo1 p) = party p +evalTradeDir (TradeDirPTo2 p) = give . party p +evalTradeDir (TradeDir1ToP p) = party p . give +evalTradeDir (TradeDir2ToP p) = give . party p . give +evalTradeDir (TradeDirPToQ p q) = party q . give . party p +evalTradeDir (TradeDirQToP p q) = party q . give . party p . give + +-- | Precompose a TradeDir with 'party' to get a new combined TradeDir. +-- +-- That is, it respects the law: +-- +-- > evalTradeDir (setThirdParty p dir) = evalTradeDir dir . party p +-- +setThirdParty :: PartyName -> TradeDir -> TradeDir +setThirdParty p TradeDir2To1 = TradeDirPTo1 p -- id . party p ~~ TradeDirPTo1 p +setThirdParty p TradeDir1To2 = TradeDirPTo2 p -- give . party p ~~ TradeDirPTo2 p +setThirdParty p (TradeDirPTo1 q) = TradeDirPTo1 p -- party q . party p = party p ~~ TradeDirPTo1 p +setThirdParty p (TradeDirPTo2 q) = TradeDirPTo2 p -- give . party q . party p = give . party p ~~ TradeDirPTo2 p +setThirdParty p (TradeDir1ToP q) = TradeDirPToQ p q -- party q . give . party p ~~ TradeDirPToQ p q +setThirdParty p (TradeDir2ToP q) = TradeDirPToQ p q -- give . party q . give . party p = party q . give . party p ~~ TradeDirPToQ p q +setThirdParty p (TradeDirPToQ q r) = TradeDirPToQ p r -- party r . give . party q . party p = party r . give . party p ~~ TradeDirPToQ p r +setThirdParty p (TradeDirQToP q r) = TradeDirPToQ p q -- party r . give . party q . give . party p = party q . give . party p ~~ TradeDirPToQ p q + +-- | Precompose a TradeDir with 'give' to get a new combined TradeDir. +-- +-- That is, it respects the law: +-- +-- > evalTradeDir (flipTradeDir dir) = evalTradeDir dir . give +-- +flipTradeDir :: TradeDir -> TradeDir +flipTradeDir TradeDir2To1 = TradeDir1To2 -- id . give = give +flipTradeDir TradeDir1To2 = TradeDir2To1 -- give . give = id +flipTradeDir (TradeDirPTo1 p) = TradeDir1ToP p -- party p . give +flipTradeDir (TradeDirPTo2 p) = TradeDir2ToP p -- give . party p . give +flipTradeDir (TradeDir1ToP p) = TradeDirPTo1 p -- party p . give . give = party p +flipTradeDir (TradeDir2ToP p) = TradeDirPTo2 p -- give . party p . give . give = give . party p +flipTradeDir (TradeDirPToQ p q) = TradeDirQToP p q -- party q . give . party p . give +flipTradeDir (TradeDirQToP p q) = TradeDirPToQ p q -- party q . give . party p . give . give = party q . give . party p + +-- | Return the two parties in a TradeDir in the order @(recieving party, giving party)@. +-- +tradeDirParties :: TradeDir -> (Party, Party) +tradeDirParties TradeDir2To1 = (FirstParty, Counterparty) +tradeDirParties TradeDir1To2 = (Counterparty, FirstParty) +tradeDirParties (TradeDirPTo1 p) = (FirstParty, ThirdParty p) +tradeDirParties (TradeDirPTo2 p) = (Counterparty, ThirdParty p) +tradeDirParties (TradeDir1ToP p) = (ThirdParty p, FirstParty) +tradeDirParties (TradeDir2ToP p) = (ThirdParty p, Counterparty) +tradeDirParties (TradeDirPToQ p q) = (ThirdParty q, ThirdParty p) +tradeDirParties (TradeDirQToP p q) = (ThirdParty p, ThirdParty q) + + +-- --------------------------------------------------------------------------- +-- * Display tree instance +-- --------------------------------------------------------------------------- + +instance Show (DecisionStep x) where + show Done = "Done" + show (Trade dir n t _) = case dir of + TradeDir2To1 -> "Receive " ++ quantityOfStuff + TradeDir1To2 -> "Provide " ++ quantityOfStuff + + TradeDirPTo1 p -> "Receive from " ++ partyQuantityOfStuff p + TradeDirPTo2 p -> "Counterparty receives from " ++ partyQuantityOfStuff p + + TradeDir1ToP p -> "Provide to " ++ partyQuantityOfStuff p + TradeDir2ToP p -> "Counterparty provides to " ++ partyQuantityOfStuff p + + TradeDirPToQ p q -> p ++ " provides to " ++ q ++ " " ++ quantityOfStuff + TradeDirQToP p q -> q ++ " provides to " ++ p ++ " " ++ quantityOfStuff + where + quantityOfStuff = show n ++ " " ++ show t + partyQuantityOfStuff p = p ++ " " ++ quantityOfStuff + + show (Choose p cid _ _) = "Choose " ++ show p ++ " " ++ cid + show (ObserveCond o _ _) = "ObserveCond " ++ show o + show (ObserveValue o _) = "ObserveValue " ++ show o + show (Wait conds opts) = "Wait for one to become true...\n" + ++ unlines (map (show . fst) conds) + ++ "Or pick an available option\n" + ++ unlines (map (show . fst) opts) + +instance Display DecisionTree where + toTree (DecisionTree time st) = case st of + Done -> Node "done" [] + Trade dir n t st1 -> Node descr [toTree st1] + where + descr = dirDescr ++ " " ++ show n ++ " " ++ show t + ++ "\n" ++ show time + dirDescr = case dir of + TradeDir2To1 -> "receive" + TradeDir1To2 -> "provide" + + TradeDirPTo1 p -> "receive from " ++ p + TradeDirPTo2 p -> "counterparty receives from " ++ p + + TradeDir1ToP p -> "provide to " ++ p + TradeDir2ToP p -> "counterparty provides to " ++ p + + TradeDirPToQ p q -> p ++ " provides to " ++ q + TradeDirQToP p q -> q ++ " provides to " ++ p + + Choose p cid st1 st2 -> Node (partyDescr ++ cid ++ "\n" ++ show time) + [toTree st1, toTree st2] + where + partyDescr = case p of + FirstParty -> "choose " + Counterparty -> "counterparty choice " + ThirdParty p -> "3rd party " ++ p ++ " choice " + ObserveCond obs st1 st2 -> Node "observe cond" [toTree obs + ,toTree st1 + ,toTree st2] + ObserveValue obs st1 -> Node "observe val" [ toTree obs + , case Obs.eval time obs of + Result v -> toTree (st1 v) + _ -> toTree (st1 0) ] + Wait conds opts -> Node ("wait\n" ++ show time) + $ [ Node (show obs) + [ case Obs.timeHorizon time obs of + Nothing -> toTree (cont time) + Just time' -> toTree (cont time') ] + | (obs, cont) <- conds ] + ++ [ Node "option" [toTree (cont time)] + | (_c, cont) <- opts ] + +-- XML instances +instance HTypeable Party where + toHType _ = Defined "Party" [] [] + +instance XmlContent Party where + parseContents = do + e@(Elem t _ _) <- element ["Party", "Counterparty", "ThirdParty"] + commit $ interior e $ case localName t of + "Party" -> return FirstParty + "Counterparty" -> return Counterparty + "ThirdParty" -> liftM ThirdParty text + + toContents FirstParty = [mkElemC "Party" []] + toContents Counterparty = [mkElemC "Counterparty" []] + toContents (ThirdParty p) = [mkElemC "ThirdParty" (toText p)] + +instance HTypeable TradeDir where + toHType _ = Defined "TradeDir" [] [] + +instance XmlContent TradeDir where + parseContents = do + e@(Elem t _ _) <- element ["TradeDir2To1","TradeDir1To2" + ,"TradeDirPTo1","TradeDirPTo2" + ,"TradeDir1ToP","TradeDir2ToP" + ,"TradeDirPToQ","TradeDirQToP"] + commit $ interior e $ case localName t of + "TradeDir2To1" -> return TradeDir2To1 + "TradeDir1To2" -> return TradeDir1To2 + "TradeDirPTo1" -> liftM TradeDirPTo1 text + "TradeDirPTo2" -> liftM TradeDirPTo2 text + "TradeDir1ToP" -> liftM TradeDir1ToP text + "TradeDir2ToP" -> liftM TradeDir2ToP text + "TradeDirPToQ" -> liftM2 TradeDirPToQ text text + "TradeDirQToP" -> liftM2 TradeDirQToP text text + + toContents TradeDir2To1 = [mkElemC "TradeDir2To1" []] + toContents TradeDir1To2 = [mkElemC "TradeDir1To2" []] + toContents (TradeDirPTo1 p) = [mkElemC "TradeDirPTo1" (toText p)] + toContents (TradeDirPTo2 p) = [mkElemC "TradeDirPTo2" (toText p)] + toContents (TradeDir1ToP p) = [mkElemC "TradeDir1ToP" (toText p)] + toContents (TradeDir2ToP p) = [mkElemC "TradeDir2ToP" (toText p)] + toContents (TradeDirPToQ p q) = [mkElemC "TradeDirPToQ" (toText p ++ toText q)] + toContents (TradeDirQToP p q) = [mkElemC "TradeDirQToP" (toText p ++ toText q)] + +instance HTypeable (Blocked c) where + toHType _ = Defined "Blocked" [] [] + +instance XmlContent c => XmlContent (Blocked c) where + parseContents = do + e@(Elem t _ _) <- element ["BlockedOnWhen", "BlockedOnAnytime"] + commit $ interior e $ case localName t of + "BlockedOnWhen" -> liftM2 BlockedOnWhen (fmap unObsCondition parseContents) + parseContents + "BlockedOnAnytime" -> liftM4 BlockedOnAnytime parseContents + (inElement "ChoiceId" text) + (fmap unObsCondition parseContents) + parseContents + + toContents (BlockedOnWhen obs c) = + [mkElemC "BlockedOnWhen" (toContents (ObsCondition obs) ++ toContents c)] + toContents (BlockedOnAnytime val cid obs c) = + [mkElemC "BlockedOnAnytime" (toContents val ++ [mkElemC "ChoiceId" (toText cid)] ++ + toContents (ObsCondition obs) ++ toContents c)] + +newtype ObsCondition = ObsCondition { unObsCondition :: (Obs Bool) } + +instance HTypeable ObsCondition where + toHType _ = Defined "ObsCondition" [] [] + +instance XmlContent ObsCondition where + parseContents = inElement "ObsCondition" $ + liftM ObsCondition Obs.parseObsCond + toContents (ObsCondition obs) = [mkElemC "ObsCondition" [Obs.printObs obs]] + +instance HTypeable ThreadState where + toHType _ = Defined "ThreadState" [] [] + +instance XmlContent ThreadState where + parseContents = + inElement "ThreadState" $ + liftM4 TSt parseContents + (inElement "UntilConditions" (fmap (map unObsCondition) parseContents)) + parseContents parseContents + toContents (TSt c obss sf dir) = + [mkElemC "ThreadState" (toContents c ++ + mkElemC "UntilConditions" (toContents (map ObsCondition obss)) : + toContents sf ++ toContents dir)] + +instance HTypeable ProcessState where + toHType _ = Defined "ProcessState" [] [] + +instance XmlContent ProcessState where + parseContents = + inElement "ProcessState" $ + liftM3 PSt parseContents + (inElement "BlockedThreads" parseContents) + (inElement "RunnableThreads" parseContents) + toContents (PSt t blocked runnable) = + [mkElemC "ProcessState" (toContents t ++ + [ mkElemC "BlockedThreads" (toContents blocked) + , mkElemC "RunnableThreads" (toContents runnable) ])] diff --git a/src/DecisionTreeSimplify.hs b/src/DecisionTreeSimplify.hs new file mode 100644 --- /dev/null +++ b/src/DecisionTreeSimplify.hs @@ -0,0 +1,125 @@ +-- |Netrium is Copyright Anthony Waite, Dave Hetwett, Shaun Laurens 2009-2015, and files herein are licensed +-- |under the MIT license, the text of which can be found in license.txt +-- +{-# LANGUAGE DeriveFunctor, GADTs, PatternGuards #-} + +module DecisionTreeSimplify ( + decisionTreeSimple, + decisionStepWithTime, + simplifyWait + ) where + +import Contract +import Observable (Steps(..)) +import qualified Observable as Obs +import DecisionTree +import Display + +import Prelude hiding (product, until, and) +import Data.List hiding (and) +import Data.Ord + + +-- --------------------------------------------------------------------------- +-- * Apply our knowledge of time +-- --------------------------------------------------------------------------- + +decisionTreeSimple :: Time -> Contract -> DecisionTree +decisionTreeSimple t c = unfoldDecisionTree + decisionStepWithTime + (initialProcessState t c) + +decisionStepWithTime :: ProcessState -> (DecisionStep ProcessState, Time) +decisionStepWithTime st@(PSt time _ _) = case decisionStep st of + Done -> (Done, time) + + Trade d sf t st1 -> (Trade d sf t st1, time) + + Choose p id st1 st2 -> (Choose p id st1 st2, time) + + ObserveCond o st1 st2 -> case Obs.eval time o of + Result True -> decisionStepWithTime st1 + Result False -> decisionStepWithTime st2 + _ -> (ObserveCond o st1 st2, time) + + ObserveValue o k -> case Obs.eval time o of + Result v -> decisionStepWithTime (k v) + _ -> (ObserveValue o k, time) + + Wait conds opts -> case simplifyWait time conds (not (null opts)) of + Left st' -> decisionStepWithTime st' + Right [] -> (Done, time) + Right conds' -> (Wait conds' opts, time) + +-- The Wait action is the complicated one +-- +simplifyWait :: Time + -> [(Obs Bool, Time -> ProcessState)] + -> Bool + -> Either ProcessState + [(Obs Bool, Time -> ProcessState)] +simplifyWait time conds opts = + + -- Check if any conditions are currently true, + case checkCondTrue time conds of + + -- if so we can run one rather than waiting. + Left k -> Left (k time) + + -- If all the conditions are evermore false... + Right [] | opts -> Right [(konst False, \time' -> PSt time' [] [])] + | otherwise -> Right [] + + -- Otherwise, all conditions are either false or are unknown. + Right otherConds -> + + -- We look at the remaining conditions and check if there is + -- a time at which one of the conditions will become true. + case Obs.earliestTimeHorizon time otherConds of + + -- Of course, there may be no such time, in which case we + -- simply return a new Wait using the remaining conditions + Nothing -> Right otherConds + + -- but if this time does exists (call it the time horizon) + -- then we can use it to simplify or eliminate the + -- remaining conditions. + -- Note that we also get the continuation step associated + -- with the condition that becomes true at the horizon. + Just (horizon, k) -> + + -- For each remaining condition we try to simplify it + -- based on the knowledge that the time falls in the + -- range between now and the time horizon (exclusive). + -- If a condition will be false for the whole of this + -- time range then it can be eliminated. + let simplifiedConds = [ (obs', k') + | (obs, k') <- otherConds + , let obs' = Obs.simplifyWithinHorizon + time horizon obs + , not (Obs.isFalse time obs') ] + + -- It is possible that all the conditions are false + -- in the time period from now up to (but not + -- including) the horizon. + in if null simplifiedConds + + -- In that case the condition associated with the + -- time horizon will become true first, and we + -- can advance time to the horizon and follow its + -- associated continuation. + then if opts then Right [(at horizon, k)] + else Left (k horizon) + + -- Otherwise, we return a new Wait, using the + -- simplified conditions + else Right ((at horizon, k) : simplifiedConds) + + where + checkCondTrue :: Time -> [(Obs Bool, a)] -> Either a [(Obs Bool, a)] + checkCondTrue time conds + | ((_,k) :_) <- trueConds = Left k + | otherwise = Right otherConds' + where + (trueConds, otherConds) = partition (Obs.isTrue time . fst) conds + otherConds' = filter (not . Obs.evermoreFalse time . fst) otherConds diff --git a/src/Display.hs b/src/Display.hs new file mode 100644 --- /dev/null +++ b/src/Display.hs @@ -0,0 +1,39 @@ +-- |Netrium is Copyright Anthony Waite, Dave Hetwett, Shaun Laurens 2009-2015, and files herein are licensed +-- |under the MIT license, the text of which can be found in license.txt +-- +{-# OPTIONS_HADDOCK hide #-} +module Display ( + + module Data.Tree, + Display(..), + trimDepth, + module WriteDotGraph, + + disp, disp', + + ) where + +import Data.Tree +import System.Cmd + +import WriteDotGraph + + +class Display a where + toTree :: a -> Tree String + +trimDepth :: Int -> Tree String -> Tree String +trimDepth 0 (Node _ _) = Node "..." [] +trimDepth n (Node l ts) = Node l (map (trimDepth (n-1)) ts) + +-- Utils for use in ghci: + +disp :: Display a => a -> IO () +disp = disp' 8 + +disp' :: Display a => Int -> a -> IO () +disp' depth x = do + writeDotFile "out.dot" (trimDepth depth $ toTree x) + rawSystem "dot" ["-Tsvg", "-o", "out.svg", "out.dot"] + rawSystem "eog" ["out.svg"] + return () diff --git a/src/Interpreter.hs b/src/Interpreter.hs new file mode 100644 --- /dev/null +++ b/src/Interpreter.hs @@ -0,0 +1,481 @@ +-- |Netrium is Copyright Anthony Waite, Dave Hetwett, Shaun Laurens 2009-2015, and files herein are licensed +-- |under the MIT license, the text of which can be found in license.txt +-- +{-# LANGUAGE DeriveFunctor #-} + +module Interpreter where + +import Contract +import Observable (Steps(..), VarName) +import qualified Observable as Obs +import DecisionTree hiding (Trade) +import qualified DecisionTree as TD (DecisionStep(Trade)) +import DecisionTreeSimplify +import Observations + +import Prelude hiding (product, until, and) +import Data.List hiding (and) +import Data.Monoid +import qualified Data.Map as Map +import Data.Map (Map) +import Control.Monad +import Text.XML.HaXml.Namespaces (localName) +import Text.XML.HaXml.Types (QName(..)) +import Text.XML.HaXml.XmlContent hiding (next) +import XmlUtils +import Control.Exception (assert) + + +-- --------------------------------------------------------------------------- +-- * Main interpreter, using observables and choice data +-- --------------------------------------------------------------------------- + +data Output = Trade Party Party Double Tradeable + | OptionUntil ChoiceId Time + | OptionForever ChoiceId + deriving (Eq, Show) + +data StopReason = Finished -- ^ contract reduced to 'zero' + | StoppedTime -- ^ stop time reached (in timeout mode) + | StoppedWait -- ^ stopped at first wait point (in wait mode) + | WaitForever -- ^ a non-terminating wait + | ChoiceRequired Party ChoiceId + | ObservationExhausted VarName + | ObservationMissing VarName -- ^ really an error + deriving (Eq, Show) + +data SimEnv + = SimEnv { + valueObservations :: Observations Double, -- ^ primitive real-valued obs + condObservations :: Observations Bool, -- ^ primitive bool-valued obs + optionsTaken :: Choices (), -- ^ 'anytime' options taken + choicesMade :: Choices Bool -- ^ 'or' choices made + } + +data SimOutputs + = SimOutputs { + simTrace :: TimedEvents String, + simOutputs :: TimedEvents Output, + simStopReason :: StopReason, + simStopTime :: Time, + simStopContract :: Contract, + simStopState :: ProcessState, + simStopWaitInfo :: Maybe WaitInfo + } + deriving (Show, Eq) + +data StopWait = NoStop | StopFirstWait | StopNextWait + deriving (Show, Eq) + +data WaitInfo + = WaitInfo { + waitObs :: [Obs Bool], + waitHorizon :: Maybe Time, + waitOptions :: [ChoiceId] + } + deriving (Show, Eq) + +runContract :: SimEnv + -> Time -- ^ start time + -> Maybe Time -- ^ optional stop time + -> StopWait -- ^ stop at first waitpoint + -> Either Contract ProcessState + -> SimOutputs +runContract _ startTime (Just stopTime) _ _ + | not (stopTime > startTime) + = error "runContract: stop time must be after start time" + +runContract simenv startTime mStopTime mStopWait0 startState = + let st0 = case startState of + Left contract -> initialProcessState startTime contract + Right st@(PSt time' _ _) + | startTime == time' -> st + | otherwise -> error $ "runContract: resuming from the wrong time " + ++ show time' ++ " vs " ++ show startTime + + in go [] [] mStopWait0 st0 + + where + go :: [(Time, String)] -> [(Time, Output)] -> StopWait + -> ProcessState -> SimOutputs + go trace output mStopWait st@(PSt time _ _) = + -- if we go past the stop time, we've done something wrong... + assert (maybe True (time <) mStopTime) $ + + let obsenv = currentObsEnv (valueObservations simenv) + (condObservations simenv) time + result = result' output + result' out reason time' st' = + SimOutputs { + simTrace = TEs (reverse trace), + simOutputs = TEs (reverse out), + simStopReason = reason, + simStopTime = time', + simStopContract = currentContract st', + simStopState = st', + simStopWaitInfo = Nothing + } + step = decisionStep st + trace' = (time, show step) : trace + in + case decisionStep st of + Done -> + result Finished time st + + TD.Trade dir sf t next -> + go trace' ((time, Trade p p' sf t) : output) mStopWait next + where + (p, p') = tradeDirParties dir + + Choose p cid next1 next2 -> + case lookupChoice (choicesMade simenv) cid time of + Nothing -> result (ChoiceRequired p cid) time st + Just v | v -> go trace' output mStopWait next1 + | otherwise -> go trace' output mStopWait next2 + + ObserveCond obs next1 next2 -> + case evalObs obsenv time obs of + ObsExhausted varname -> result (ObservationExhausted varname) time st + ObsMissing varname -> result (ObservationMissing varname) time st + ObsResult v | v -> go trace' output mStopWait next1 + | otherwise -> go trace' output mStopWait next2 + + ObserveValue obs next -> + case evalObs obsenv time obs of + ObsExhausted varname -> result (ObservationExhausted varname) time st + ObsMissing varname -> result (ObservationMissing varname) time st + ObsResult v -> go trace' output mStopWait (next v) + + Wait obsExprs optionsAvail | mStopWait == StopFirstWait -> + case simplifyWait time obsExprs (not (null optionsAvail)) of + Left next -> go trace' output mStopWait next + Right [] -> result Finished time st + Right conds' -> (result StoppedWait time st) { + simStopWaitInfo = Just WaitInfo { + waitObs = fmap fst conds', + waitHorizon = fmap fst (Obs.earliestTimeHorizon time conds'), + waitOptions = fmap fst optionsAvail + } + } + + Wait obsExprs optionsAvail -> + + let (time', waitResult) = runWait simenv obsenv + mStopTime time + obsExprs optionsAvail + in case waitResult of + ObsResult waitreason -> + case waitreason of + WaitContinue next -> go trace' outputU' mStopWait' (next time') + WaitStopped -> result' outputU' StoppedTime time' st + WaitFinished -> result' outputF' Finished time' st + WaitNonTerm -> result' outputF' WaitForever time' st + where + outputU' = [ (time, OptionUntil choiceid time') + | (choiceid, _k) <- optionsAvail ] ++ output + outputF' = [ (time, OptionForever choiceid) + | (choiceid, _k) <- optionsAvail ] ++ output + mStopWait' | mStopWait == StopNextWait = StopFirstWait + | otherwise = mStopWait + + ObsExhausted varname -> result (ObservationExhausted varname) time' st + ObsMissing varname -> result (ObservationMissing varname) time' st + +data WaitResult k = WaitContinue k + | WaitStopped + | WaitFinished + | WaitNonTerm + +runWait :: SimEnv + -> ObsEnv + -> Maybe Time + -> Time + -> [(Obs Bool, k)] + -> [(ChoiceId, k)] + -> (Time, ObsResult (WaitResult k)) +runWait simenv obsenv mStopTime time obsExprs optionsAvail = + checkEvents time (unTEs events) + + where + timeouts = (case Obs.earliestTimeHorizon time obsExprs of + Nothing -> [] + Just (time', k) -> [(time', Just k)]) + ++ (case mStopTime of + Nothing -> [] + Just stopTime -> [(stopTime, Nothing)]) + --events :: TimedEvents (WaitEvent k) + events = mergeWaitEvents + (valueObservations simenv) (condObservations simenv) + (optionsTaken simenv) + timeouts time obsenv + + -- Did we reach the time horizon? + checkEvents time' [] = (time', ObsResult WaitNonTerm) + checkEvents _ ((time', Timeout (Just k)):_remaining) = + (time', ObsResult (WaitContinue k)) + + checkEvents _ ((time', Timeout Nothing):_remaining) = + (time', ObsResult WaitStopped) + + -- Check if we took an available option + checkEvents _ ((time', TakeOption cid):remaining) = + case lookup cid optionsAvail of + Just k -> (time', ObsResult (WaitContinue k)) + Nothing -> checkEvents time' remaining + + -- Check if any observable is true at this time + checkEvents _ ((time', ObsChanged obsEnv): remaining) = + case foldr accum (ObsResult Nothing) obsExprs of + ObsResult (Just k) -> (time', ObsResult (WaitContinue k)) + ObsResult Nothing + | all (Obs.evermoreFalse time' . fst) obsExprs + -> (time', ObsResult WaitFinished) + | otherwise -> checkEvents time' remaining + ObsExhausted varname -> (time', ObsExhausted varname) + ObsMissing varname -> (time', ObsExhausted varname) + + where + accum (obs, k) rest = + case evalObs obsEnv time' obs of + ObsResult True -> ObsResult (Just k) + ObsResult False -> rest + ObsExhausted varname -> ObsExhausted varname + ObsMissing varname -> ObsMissing varname + + +-- | When in a wait state there are three different things that can happen +-- one of the observables can become true, we can choose to take an 'anytime' +-- option that is available to us. +-- +-- There are two ways an observable can become true, one is due to a change in +-- a primitive/external ovservable, and the other is via the passage of time. +-- +-- Hence, overall, there are three events we are interested in while waiting. +-- +data WaitEvent k = TakeOption ChoiceId + | ObsChanged ObsEnv + | Timeout k + deriving Show + +-- | Take all three sources of events we are interested in and produce a +-- unified event list +-- +mergeWaitEvents :: Observations Double -- ^ time series for real primitive obs + -> Observations Bool -- ^ time series for bool primitive obs + -> Choices () -- ^ 'anytime' options taken + -> [(Time, k)] -- ^ optional timeouts + -> Time -- ^ initial time + -> ObsEnv -- ^ initial values of all primitive obs + -> TimedEvents (WaitEvent k) +mergeWaitEvents valObss condObss options timeouts time0 obsenv0 = + events' + where + + -- Firstly, combine all the observations into a unified event list + obsTS :: TimedEvents [(VarName, Either (Maybe Double) (Maybe Bool))] + obsTS = mconcat (valTSs ++ condTSs) + + valTSs, condTSs :: [TimedEvents [(VarName, Either (Maybe Double) (Maybe Bool))]] + + valTSs = [ fmap (\e -> [(varname, Left e)]) + (pruneTimedEvents time0 (timeSeriesEvents ts)) + | (varname, ts) <- Map.toList valObss ] + + condTSs = [ fmap (\v -> [(varname, Right v)]) + (pruneTimedEvents time0 (timeSeriesEvents ts)) + | (varname, ts) <- Map.toList condObss ] + + -- similarly for the options, a unified event list + optionsTS :: TimedEvents ChoiceId + optionsTS = mconcat + [ fmap (const cid) (pruneTimedEvents time0 ts) + | (cid, ts) <- Map.toList options ] + + -- for the observations, convert the list of changes in observations + -- into a list of ObsEnv values at each time + obsEnvTS :: TimedEvents ObsEnv + obsEnvTS = insertEventBefore time0 obsenv0 + $ snd (mapAccumTS accumObsEnv obsenv0 obsTS) + + accumObsEnv :: ObsEnv + -> [(VarName, Either (Maybe Double) (Maybe Bool))] + -> (ObsEnv, ObsEnv) + accumObsEnv obsenv obschanges = (obsenv', obsenv') + where + obsenv' = foldl' update obsenv obschanges + + update (ObsEnv realObsvns boolObsvns) (varname, Left v) = + ObsEnv realObsvns' boolObsvns + where + realObsvns' = Map.insert varname v realObsvns + + update (ObsEnv realObsvns boolObsvns) (varname, Right v) = + ObsEnv realObsvns boolObsvns' + where + boolObsvns' = Map.insert varname v boolObsvns + + -- Now combine the different events into one event list + -- firstly the observations and the options + events = mergeEventsBiased (fmap ObsChanged obsEnvTS) + (fmap TakeOption optionsTS) + + -- and lastly any timeouts + events' = foldr (\(time, k) -> insertEventAfter time (Timeout k)) + events timeouts + + +-- --------------------------------------------------------------------------- +-- * Evaluating observables in the presense of observables data +-- --------------------------------------------------------------------------- + +data ObsEnv = ObsEnv (Map VarName (Maybe Double)) + (Map VarName (Maybe Bool)) + deriving Show + +currentObsEnv :: Observations Double + -> Observations Bool + -> Time + -> ObsEnv +currentObsEnv realObsvns boolObsvns time = + ObsEnv (fmap (flip lookupTimeSeries time) realObsvns) + (fmap (flip lookupTimeSeries time) boolObsvns) + + +data ObsResult a = ObsResult a + | ObsExhausted VarName + | ObsMissing VarName + deriving (Functor, Show) + +evalObs :: ObsEnv + -> Time + -> Obs a + -> ObsResult a +evalObs (ObsEnv realObsvns boolObsvns) time = + go . Obs.eval time + where + go :: Steps a -> ObsResult a + go (Result v) = ObsResult v + + go (NeedNamedVal _ varname k) = + case Map.lookup varname realObsvns of + Nothing -> ObsMissing varname + Just Nothing -> ObsExhausted varname + Just (Just v) -> go (k v) + + go (NeedNamedCond _ varname k) = + case Map.lookup varname boolObsvns of + Nothing -> ObsMissing varname + Just Nothing -> ObsExhausted varname + Just (Just v) -> go (k v) + + +-- --------------------------------------------------------------------------- +-- * XML instances +-- --------------------------------------------------------------------------- + +instance HTypeable Output where + toHType _ = Defined "Output" [] [] + +instance XmlContent Output where + parseContents = do + e@(Elem t _ _) <- element ["Trade","OptionUntil","OptionForever"] + commit $ interior e $ case localName t of + "Trade" -> liftM4 Trade parseContents parseContents + parseContents parseContents + "OptionUntil" -> liftM2 OptionUntil (attrStr (N "choiceid") e) parseContents + "OptionForever" -> liftM OptionForever (attrStr (N "choiceid") e) + + toContents (Trade p p' sf t) = [mkElemC "Trade" (toContents p + ++ toContents p' + ++ toContents sf + ++ toContents t)] + toContents (OptionUntil cid time') = [mkElemAC (N "OptionUntil") + [(N "choiceid", str2attr cid)] + (toContents time')] + toContents (OptionForever cid) = [mkElemAC (N "OptionForever") + [(N "choiceid", str2attr cid)] []] + + +instance HTypeable StopReason where + toHType _ = Defined "StopReason" [] [] + +instance XmlContent StopReason where + parseContents = do + e@(Elem t _ _) <- element ["Finished", "StoppedTime", "StoppedWait","WaitForever" + ,"ChoiceRequired" + ,"ObservationMissing","ObservationExhausted"] + commit $ interior e $ case localName t of + "Finished" -> return Finished + "StoppedTime" -> return StoppedTime + "StoppedWait" -> return StoppedWait + "WaitForever" -> return WaitForever + "ChoiceRequired" -> liftM2 ChoiceRequired parseContents + (attrStr (N "choiceid") e) + "ObservationMissing" -> liftM ObservationMissing (attrStr (N "var") e) + "ObservationExhausted" -> liftM ObservationExhausted (attrStr (N "var") e) + + toContents Finished = [mkElemC "Finished" []] + toContents StoppedTime = [mkElemC "StoppedTime" []] + toContents StoppedWait = [mkElemC "StoppedWait" []] + toContents WaitForever = [mkElemC "WaitForever" []] + + toContents (ChoiceRequired party choiceid) = + [mkElemAC (N "ChoiceRequired") [(N "choiceid", str2attr choiceid)] + (toContents party)] + toContents (ObservationExhausted varname) = + [mkElemAC (N "ObservationExhausted") [(N "var", str2attr varname)] []] + toContents (ObservationMissing varname) = + [mkElemAC (N "ObservationMissing") [(N "var", str2attr varname)] []] + + +instance HTypeable StopWait where + toHType _ = Defined "StopWait" [] [] + +instance XmlContent StopWait where + parseContents = (do + e@(Elem t _ _) <- element ["StopFirstWait", "StopNextWait"] + commit $ interior e $ case localName t of + "StopFirstWait" -> return StopFirstWait + "StopNextWait" -> return StopNextWait) + `onFail` return NoStop + + toContents NoStop = [] + toContents StopFirstWait = [mkElemC "StopFirstWait" []] + toContents StopNextWait = [mkElemC "StopNextWait" []] + + +instance HTypeable WaitInfo where + toHType _ = Defined "WaitInfo" [] [] + +instance XmlContent WaitInfo where + parseContents = inElement "WaitInfo" $ do + obss <- parseContents + t <- parseContents + opts <- parseContents + return $ WaitInfo ((map (\(WaitCondition obs) -> obs)) obss) + t + (map (\(WaitOption cid) -> cid) opts) + toContents (WaitInfo obss t opts) = [mkElemC "WaitInfo" (toContents (map WaitCondition obss) + ++ toContents t + ++ toContents (map WaitOption opts))] + +newtype WaitCondition = WaitCondition (Obs Bool) + +instance HTypeable WaitCondition where + toHType _ = Defined "WaitCondition" [] [] + +instance XmlContent WaitCondition where + parseContents = inElement "WaitCondition" $ + liftM WaitCondition Obs.parseObsCond + toContents (WaitCondition obs) = [mkElemC "WaitCondition" [Obs.printObs obs]] + + +newtype WaitOption = WaitOption ChoiceId + +instance HTypeable WaitOption where + toHType _ = Defined "WaitOption" [] [] + +instance XmlContent WaitOption where + parseContents = inElement "WaitOption" $ + liftM WaitOption text + toContents (WaitOption cid) = [mkElemC "WaitOption" (toText cid)] diff --git a/src/Observable.hs b/src/Observable.hs new file mode 100644 --- /dev/null +++ b/src/Observable.hs @@ -0,0 +1,829 @@ +-- |Netrium is Copyright Anthony Waite, Dave Hetwett, Shaun Laurens 2009-2015, and files herein are licensed +-- |under the MIT license, the text of which can be found in license.txt +-- +{-# LANGUAGE GADTs, MultiParamTypeClasses, FlexibleInstances #-} +-- +-- The definition of observable expressions +module Observable ( + + -- * Creating observables + Obs(..), + konst, + -- ** Named observables + VarName, primVar, primCond, var, + -- ** Time-based observables + Time, mkdate, + at, before, after, between, + -- ** Operators + -- | Comparison, logical and numeric operators + (%==), (%>), (%>=), (%<), (%<=), + (%&&), (%||), (%+), (%-), (%*), (%/), + -- ** Other observable functions + ifthen, negate, not, max, min, abs, + + -- * Other utilities on observables + -- ** Parsing + parseObsCond, parseObsReal, printObs, + + -- ** Evaluating + eval, Steps(..), + subst, + + -- ** Analysing + isTrue, isFalse, + nextTrue, nextFalse, + evermoreTrue, evermoreFalse, + timeHorizon, earliestTimeHorizon, simplifyWithinHorizon, + + ) where + +import Display +import XmlUtils + +import Prelude hiding (product, not, min, max) +import qualified Prelude +import Data.Time hiding (Day) +import Data.List (minimumBy) +import Data.Ord (comparing) +import Control.Monad +import Text.Show.Functions () +import Text.XML.HaXml.Namespaces (localName) +import Text.XML.HaXml.XmlContent + (XMLParser(), Element(..), Content(), element, interior, text, toText, mkElemC) + +-- * Observable type definition +-- | We use a continuous model of time. +type Time = UTCTime + +-- | Convenience function to create a time from a date. +-- +mkdate :: Integer -> Int -> Int -> Time +mkdate year month day = UTCTime (fromGregorian year month day) 0 + +-- | A variable name +type VarName = String + +-- | A simple expression language of \"observable values\". +-- An observable represents is a time-varying value (a function from +-- 'Time' to a value). +-- +-- Currently there are two types of observables: +-- +-- * condition observables, type @Obs Bool@ +-- +-- * real-valued observables, type @Obs Double@ +-- +data Obs a where + Const :: (Show a, Eq a) => a -> Obs a -- constant value + Var :: VarName -> Obs Double -- from local environment + NamedVal :: VarName -> Obs Double -- from external environment + NamedCond :: VarName -> Obs Bool -- from external environment + + At :: Time -> Obs Bool -- time == t + After :: Time -> Obs Bool -- time >= t + Before :: Time -> Obs Bool -- time < t + + UnOp :: UnOp a b -> Obs a -> Obs b + BinOp :: BinOp a a b -> Obs a -> Obs a -> Obs b + IfThen :: Obs Bool -> Obs a -> Obs a -> Obs a + +-- Time operations are sufficiently important, and restricted that we treat +-- them specially. In particular it is important that the only time ranges +-- that we can construct are inclusive below and exclusive above. + +-- Note that 'Not (At _)' is a semantic error. Remember that we work with a +-- continuous model of time. At what time would it become false? + +-- | Unary operators +data UnOp a b where + Not :: UnOp Bool Bool + Neg :: UnOp Double Double + Abs :: UnOp Double Double + Sqrt :: UnOp Double Double + Exp :: UnOp Double Double + Log :: UnOp Double Double + Sin :: UnOp Double Double + Cos :: UnOp Double Double + Asin :: UnOp Double Double + Atan :: UnOp Double Double + Acos :: UnOp Double Double + Sinh :: UnOp Double Double + Cosh :: UnOp Double Double + Asinh :: UnOp Double Double + Acosh :: UnOp Double Double + Atanh :: UnOp Double Double + +-- |Binary operators +data BinOp a b c where + And :: BinOp Bool Bool Bool + Or :: BinOp Bool Bool Bool + + Eq :: BinOp Double Double Bool + + Gt :: BinOp Double Double Bool + Gte :: BinOp Double Double Bool + Lt :: BinOp Double Double Bool + Lte :: BinOp Double Double Bool + + Add :: BinOp Double Double Double + Sub :: BinOp Double Double Double + Mul :: BinOp Double Double Double + Div :: BinOp Double Double Double + + Min :: BinOp Double Double Double + Max :: BinOp Double Double Double + +-- Notice that Obs Bool have this structure: +-- +-- The top level expression is logical combination of Obs Bool "atoms" +-- +-- bexp ::= atom +-- | Not bexp +-- | And bexp bexp +-- | Or bexp bexp +-- +-- There are various Obs Bool "atoms" +-- +-- atom ::= Const Bool +-- | NamedCond String +-- | Before/After/At Time +-- | Eq/Gt/Gte/Lt/Lte a a + + +-- * The basics +-- ** Variables +-- | A constant observable. +konst :: (Show a, Eq a) => a -> Obs a +konst a = Const a + +-- | A named interal contract program variable. +-- +-- Usually you should use 'letin' rather than this directly. +var :: VarName -> Obs Double + +-- | A named external real-valued observable +-- +-- Example: +-- +-- > primVar "gas-price" +primVar :: VarName -> Obs Double + +-- | A named external condition observable +primCond :: VarName -> Obs Bool + +var = Var +primVar = NamedVal +primCond = NamedCond + +-- ** Time + +-- | An observable that becomes true at a single given point in time +-- and is false at all other times. +at :: Time -> Obs Bool +at = At +-- | An observable that becomes true after a given point in time and is +-- false prior to that time. +after :: Time -> Obs Bool +after = After +-- | An observable that is true up to a given point in time and is false +-- thereafter. +before :: Time -> Obs Bool +before = Before + + +-- | An observable that is true between two given points in time +-- and is false at all other times. +-- +-- @between t1 t2 = time >= t1 && time < t2@ +between :: Time -> Time -> Obs Bool +between t1 t2 = after t1 %&& before t2 + +-- ** Other syntax and functions +-- | if..then..else for observables (returns an observable) +ifthen :: Obs Bool -> Obs a -> Obs a -> Obs a +ifthen = IfThen + +-- | Negate a boolean observable +not :: Obs Bool -> Obs Bool +not = UnOp Not + +min = BinOp Min +max = BinOp Max + +-- * Operators +isInfix :: BinOp a b c -> Bool +isInfix Eq = True +isInfix Gt = True +isInfix Gte = True +isInfix Lt = True +isInfix Lte = True +isInfix And = True +isInfix Or = True +isInfix Add = True +isInfix Sub = True +isInfix Mul = True +isInfix Div = True +isInfix _ = False + +infixl 7 %*, %/ +infixl 6 %+, %- +infix 4 %==, %>, %>=, %<, %<= +infixr 3 %&& +infixr 2 %|| + +(%==) :: Obs Double -> Obs Double -> Obs Bool +(%==) = BinOp Eq + +(%>), (%>=), (%<), (%<=) :: Obs Double -> Obs Double -> Obs Bool +(%>) = BinOp Gt +(%>=) = BinOp Gte +(%<) = BinOp Lt +(%<=) = BinOp Lte + +(%&&), (%||) :: Obs Bool -> Obs Bool -> Obs Bool +(%&&) = BinOp And +(%||) = BinOp Or + +(%+), (%-), (%*), (%/) :: Obs Double -> Obs Double -> Obs Double +(%+) = BinOp Add +(%-) = BinOp Sub +(%*) = BinOp Mul +(%/) = BinOp Div + +-- | Equality +instance Eq (Obs a) where + Const v1 == Const v2 = v1 == v2 + Var n1 == Var n2 = n1 == n2 + NamedVal n1 == NamedVal n2 = n1 == n2 + NamedCond n1 == NamedCond n2 = n1 == n2 + At t1 == At t2 = t1 == t2 + After t1 == After t2 = t1 == t2 + Before t1 == Before t2 = t1 == t2 + UnOp op1 x1 == UnOp op2 x2 = case deq op1 op2 of + Just Refl -> x1 == x2 + Nothing -> False + + BinOp op1 x1 y1 == BinOp op2 x2 y2 = case deq op1 op2 of + Just Refl -> x1 == x2 && y1 == y2 + Nothing -> False + + IfThen c1 x1 y1 == IfThen c2 x2 y2 = c1 == c2 && x1 == x2 && y1 == y2 + + _ == _ = False + +-- | Note that you can use ordinary Num operators like '+', '-', '*' etc +-- in observable expressions. +instance Num (Obs Double) where + (+) = BinOp Add + (*) = BinOp Mul + (-) = BinOp Sub + negate = UnOp Neg + abs = UnOp Abs + signum = error "Obs: signum not yet implemented" + fromInteger = konst . fromInteger + +-- | Double operations +instance Fractional (Obs Double) where + (/) = BinOp Div + fromRational = konst . fromRational + +-- | Floating operations +instance Floating (Obs Double) where + pi = Const pi + sqrt = UnOp Sqrt + exp = UnOp Exp + log = UnOp Log + sin = UnOp Sin + cos = UnOp Cos + asin = UnOp Asin + atan = UnOp Atan + acos = UnOp Acos + sinh = UnOp Sinh + cosh = UnOp Cosh + asinh = UnOp Asinh + acosh = UnOp Acosh + atanh = UnOp Atanh + +-- * Observable operations +data Steps a = NeedNamedVal Time VarName (Double -> Steps a) + | NeedNamedCond Time VarName (Bool -> Steps a) + | Result a + deriving Show + +-- | Evaluate an observable at a given time +eval :: Time -> Obs a -> Steps a +eval time = flip eval' Result + where + eval' :: Obs b -> (b -> Steps a) -> Steps a + eval' (Const v) k = k v + eval' (Var name) _ = error ("unbound var " ++ name) + eval' (NamedVal name) k = NeedNamedVal time name k + eval' (NamedCond name) k = NeedNamedCond time name k + + eval' (At t) k = k (time == t) + eval' (After t) k = k (time >= t) + eval' (Before t) k = k (time < t) + + eval' (UnOp op obs1) k = eval' obs1 $ \v -> k (evalUnOp op v) + eval' (BinOp op obs1 obs2) k = eval' obs1 $ \v1 -> + eval' obs2 $ \v2 -> k (evalBinOp op v1 v2) + eval' (IfThen obsc obs1 obs2) k = eval' obsc $ \vc -> if vc + then eval' obs1 k + else eval' obs2 k + +evalUnOp :: UnOp a b -> a -> b +evalUnOp Not = Prelude.not +evalUnOp Neg = Prelude.negate +evalUnOp Abs = Prelude.abs +evalUnOp Sqrt = sqrt +evalUnOp Exp = exp +evalUnOp Log = log +evalUnOp Sin = sin +evalUnOp Cos = cos +evalUnOp Asin = asin +evalUnOp Atan = atan +evalUnOp Acos = acos +evalUnOp Sinh = sinh +evalUnOp Cosh = cosh +evalUnOp Asinh = asinh +evalUnOp Acosh = acosh +evalUnOp Atanh = atanh + +evalBinOp :: BinOp a a b -> a -> a -> b +evalBinOp Eq = (==) +evalBinOp Gt = (>) +evalBinOp Gte = (>=) +evalBinOp Lt = (<) +evalBinOp Lte = (<=) + +evalBinOp And = (&&) +evalBinOp Or = (||) + +evalBinOp Add = (+) +evalBinOp Sub = (-) +evalBinOp Mul = (*) +evalBinOp Div = (/) +evalBinOp Min = (Prelude.min) +evalBinOp Max = (Prelude.max) + +-- | The time horizon of an condition observable is earliest time that it +-- guaranteed to become true (or @Nothing@ if there is no such time) +timeHorizon :: Time -> Obs Bool -> Maybe Time +timeHorizon = nextTrue + +-- | Return the earliest time horizon of a set of observables and the associate +-- tag of the observable that has the earliest time horizon (or @Nothing@ if +-- none of the observables have a time horizon) +earliestTimeHorizon :: Time -> [(Obs Bool, a)] -> Maybe (Time, a) +earliestTimeHorizon time os = + maybeMinimumBy (comparing fst) + [ (t, x)| (o, x) <- os, Just t <- [timeHorizon time o] ] + where + maybeMinimumBy _ [] = Nothing + maybeMinimumBy cmp xs = Just (minimumBy cmp xs) + +-- | Check if an observable is known to be true at a given point in time, +-- independent of knowledge of any external observables +isTrue :: Time -> Obs Bool -> Bool +isTrue time obs = case eval time obs of + Result True -> True + _ -> False + +-- | Check if an observable is known to be false at a given point in time, +-- independent of knowledge of any external observables +isFalse :: Time -> Obs Bool -> Bool +isFalse time obs = case eval time obs of + Result False -> True + _ -> False + +-- | The next time that an observable is guaranteed to become true +nextTrue :: Time -> Obs Bool -> Maybe Time +nextTrue time obs = case obs of + Const True -> Just time + Const False -> Nothing + NamedCond _ -> Nothing + + -- theTime == t + -- -----------|-------------- + -- ^ ^ ^ + -- time time time + At t + | time <= t -> Just t + | otherwise -> Nothing + + -- t <= theTime + -- -----------[++++++++++++++ + -- ^ ^ ^ + -- time time time + After t + | time <= t -> Just t + | otherwise -> Just time + + -- theTime < t + -- +++++++++++)-------------- + -- ^ ^ ^ + -- time time time + Before t + | time < t -> Just time + | otherwise -> Nothing + + UnOp Not obs1 -> nextFalse time obs1 + + BinOp And obs1 obs2 -> + case (nextTrue time obs1, nextTrue time obs2) of + (Just t1, _ ) | isTrue t1 obs2 -> Just t1 + (_ , Just t2) | isTrue t2 obs1 -> Just t2 + (_ , _ ) -> Nothing + + BinOp Or obs1 obs2 -> + case (nextTrue time obs1, nextTrue time obs2) of + (v1, Nothing) -> v1 + (Nothing, v2) -> v2 + (Just t1, Just t2) -> Just (Prelude.min t1 t2) + + BinOp Eq _ _ -> Nothing + BinOp Gt _ _ -> Nothing + BinOp Gte _ _ -> Nothing + BinOp Lt _ _ -> Nothing + BinOp Lte _ _ -> Nothing + IfThen _ _ _ -> Nothing + +-- | The next time that an observable is guaranteed to become false +nextFalse :: Time -> Obs Bool -> Maybe Time +nextFalse time obs = case obs of + Const True -> Nothing + Const False -> Just time + NamedCond _ -> Nothing + + At _ -> error "The observable 'not (at t)' is not valid" + + -- t <= theTime + -- -----------[++++++++++++++ + -- ^ ^ ^ + -- time time time + After t + | time < t -> Just time + | otherwise -> Nothing + + -- theTime < t + -- +++++++++++)-------------- + -- ^ ^ ^ + -- time time time + Before t + | time <= t -> Just t + | otherwise -> Just time + + UnOp Not obs1 -> nextTrue time obs1 + + BinOp And obs1 obs2 -> + case (nextFalse time obs1, nextFalse time obs2) of + (v1, Nothing) -> v1 + (Nothing, v2) -> v2 + (Just t1, Just t2) -> Just (Prelude.min t1 t2) + + BinOp Or obs1 obs2 -> + case (nextFalse time obs1, nextFalse time obs2) of + (Just t1, _ ) | isFalse t1 obs2 -> Just t1 + (_ , Just t2) | isFalse t2 obs1 -> Just t2 + (_ , _ ) -> Nothing + + BinOp Eq _ _ -> Nothing + BinOp Gt _ _ -> Nothing + BinOp Gte _ _ -> Nothing + BinOp Lt _ _ -> Nothing + BinOp Lte _ _ -> Nothing + IfThen _ _ _ -> Nothing + + +simplifyWithinHorizon :: Time -> Time -> Obs Bool -> Obs Bool +simplifyWithinHorizon time horizon = simplify + where + simplify :: Obs a -> Obs a + simplify obs = case obs of + + -- t <= theTime + -- -----------[++++++++++++++ + -- ^ ^ ^ + -- time time time + After t + | horizon < t -> Const False + | t <= time -> Const True + + -- theTime < t + -- +++++++++++)-------------- + -- ^ ^ ^ + -- time time time + Before t + | horizon < t -> Const True + | t <= time -> Const False + + BinOp And obs1 obs2 -> + case (simplify obs1, simplify obs2) of + (Const True, obs2' ) -> obs2' + (obs1' , Const True) -> obs1' + (obs1' , obs2' ) -> BinOp And obs1' obs2' + + BinOp Or obs1 obs2 -> + case (simplify obs1, simplify obs2) of + (Const True, _ ) -> Const True + (_ , Const True) -> Const True + (obs1' , obs2' ) -> BinOp Or obs1' obs2' + + BinOp op obs1 obs2 -> BinOp op (simplify obs1) (simplify obs2) + UnOp op obs1 -> UnOp op (simplify obs1) + + _ -> obs + +evermoreTrue, evermoreFalse :: Time -> Obs Bool -> Bool + +evermoreTrue time obs = case obs of + Const True -> True + Const False -> False + NamedCond _ -> False + At _ -> False + After t -> time >= t + Before _ -> False + UnOp Not obs1 -> evermoreFalse time obs1 + BinOp And obs1 obs2 -> evermoreTrue time obs1 && evermoreTrue time obs2 + BinOp Or obs1 obs2 -> evermoreTrue time obs1 || evermoreTrue time obs2 + + -- these cannot depend on the time, so we can reuse isTrue + BinOp Eq _ _ -> isTrue time obs + BinOp Gt _ _ -> isTrue time obs + BinOp Gte _ _ -> isTrue time obs + BinOp Lt _ _ -> isTrue time obs + BinOp Lte _ _ -> isTrue time obs + IfThen _ _ _ -> isTrue time obs + +evermoreFalse time obs = case obs of + Const True -> False + Const False -> True + NamedCond _ -> False + At t -> time > t + After _ -> False + Before t -> time >= t + UnOp Not obs1 -> evermoreTrue time obs1 + BinOp And obs1 obs2 -> evermoreFalse time obs1 || evermoreFalse time obs2 + BinOp Or obs1 obs2 -> evermoreFalse time obs1 && evermoreFalse time obs2 + + -- these cannot depend on the time, so we can reuse isTrue + BinOp Eq _ _ -> isFalse time obs + BinOp Gt _ _ -> isFalse time obs + BinOp Gte _ _ -> isFalse time obs + BinOp Lt _ _ -> isFalse time obs + BinOp Lte _ _ -> isFalse time obs + IfThen _ _ _ -> isFalse time obs + +subst :: VarName -> Double -> Obs a -> Obs a +subst n v = subst' + where + subst' :: Obs a -> Obs a + subst' (Var n') | n == n' = Const v + + subst' (UnOp op obs1) = UnOp op (subst' obs1) + subst' (BinOp op obs1 obs2) = BinOp op (subst' obs1) (subst' obs2) + subst' (IfThen obsc obs1 obs2) = IfThen (subst' obsc) (subst' obs1) (subst' obs2) + + subst' o = o + + +{- +-- | Construct a decision procedure for this set of high level Obs +-- expressions (and their associated continuation info) +-- +mkDecisionProcedure :: [(Obs Bool, a)] -> ObsDecisionProcedure a + +-- | In the current state, if no new events arrive, does there exist a +-- time horizon where one one observable will become true anyway +-- (simply due to time passing) +-- +timeHorizon :: ObsDecisionProcedure -> Maybe (Time, a) + +-- | An event has arrived before the time horizon, update the decision +-- procedure state machine with this event. Either an observable will +-- become true, or we just get a new decision procedure state. +-- +nextEvent :: Time + -> ObsAtomEvent + -> ObsDecisionProcedure a + -> Either (Time, a) + (ObsDecisionProcedure a) +-} + +-- * Eq instance helpers +-- GADT fun + +data Rep a where + Double :: Rep Double + Bool :: Rep Bool + +data TEq a b where + Refl :: TEq a a + +class DEq a b where + deq :: a -> b -> Maybe (TEq a b) + +instance DEq (Rep a1) (Rep a2) where + deq Double Double = Just Refl + deq Bool Bool = Just Refl + deq _ _ = Nothing + +instance DEq (UnOp a1 b1) (UnOp a2 b2) where + deq Not Not = Just Refl + deq Neg Neg = Just Refl + deq Abs Abs = Just Refl + deq Sqrt Sqrt = Just Refl + deq Exp Exp = Just Refl + deq Log Log = Just Refl + deq Cos Cos = Just Refl + deq Sin Sin = Just Refl + deq Asin Asin = Just Refl + deq Acos Acos = Just Refl + deq Atan Atan = Just Refl + deq Sinh Sinh = Just Refl + deq Cosh Cosh = Just Refl + deq Asinh Asinh = Just Refl + deq Acosh Acosh = Just Refl + deq Atanh Atanh = Just Refl + deq _ _ = Nothing + +instance DEq (BinOp a1 b1 c1) (BinOp a2 b2 c2) where + deq And And = Just Refl + deq Or Or = Just Refl + deq Eq Eq = Just Refl + deq Gt Gt = Just Refl + deq Gte Gte = Just Refl + deq Lt Lt = Just Refl + deq Lte Lte = Just Refl + deq Add Add = Just Refl + deq Sub Sub = Just Refl + deq Mul Mul = Just Refl + deq Div Div = Just Refl + deq Min Min = Just Refl + deq Max Max = Just Refl + deq _ _ = Nothing + + +-- | Display tree instances +instance Show (Obs a) where + show (Const v) = show v + show (Var n) = n + show (NamedVal n) = n + show (NamedCond n) = n + show (At t) = "(time == " ++ show t ++ ")" + show (After t) = "(time >= " ++ show t ++ ")" + show (Before t) = "(time < " ++ show t ++ ")" + show (UnOp op obs1) = "(" ++ show op ++ " " ++ show obs1 ++ ")" + + show (BinOp op obs1 obs2) + | isInfix op = "(" ++ show obs1 ++ " " ++ show op + ++ " " ++ show obs2 ++ ")" + | otherwise = "(" ++ show op ++ " " ++ show obs1 + ++ " " ++ show obs2 ++ ")" + show (IfThen obsc obs1 obs2) = "if " ++ show obsc + ++ "\nthen " ++ show obs1 + ++ "\nelse " ++ show obs2 + +instance Show (UnOp a b) where + show Not = "not" + show Neg = "-" + show Abs = "abs" + show Sqrt = "sqrt" + show Exp = "exp" + show Log = "log" + show Sin = "sin" + show Cos = "cos" + show Asin = "asin" + show Acos = "acos" + show Atan = "atan" + show Sinh = "sinh" + show Cosh = "cosh" + show Asinh = "asinh" + show Atanh = "atanh" + show Acosh = "acosh" + +instance Show (BinOp a b c) where + show Eq = "==" + show Gt = ">" + show Gte = ">=" + show Lt = "<" + show Lte = "<=" + show And = "&&" + show Or = "||" + show Add = "+" + show Sub = "-" + show Mul = "*" + show Div = "/" + show Min = "min" + show Max = "max" + + +instance Show a => Display (Obs a) where + toTree obs = Node (show obs) [] + + +-- * XML instances +-- | XML parser for real-valued observables +parseObsReal :: XMLParser (Obs Double) +parseObsReal = do + e@(Elem t _ _) <- element ["Const","Var","NamedVal","IfThen" + ,"Neg","Abs","Sqrt","Exp","Log","Sin","Cos","Asin","Acos","Atan","Sinh","Cosh","Asinh","Acosh","Atanh","Add","Sub","Mul","Div","Min","Max"] + + case localName t of + "Const" -> interior e $ liftM Const readText + "Var" -> interior e $ liftM Var text + "NamedVal" -> interior e $ liftM NamedVal text + + "Neg" -> interior e $ liftM (UnOp Neg) parseObsReal + "Abs" -> interior e $ liftM (UnOp Abs) parseObsReal + "Sqrt" -> interior e $ liftM (UnOp Sqrt) parseObsReal + "Exp" -> interior e $ liftM (UnOp Exp) parseObsReal + "Log" -> interior e $ liftM (UnOp Log) parseObsReal + "Sin" -> interior e $ liftM (UnOp Sin) parseObsReal + "Cos" -> interior e $ liftM (UnOp Cos) parseObsReal + "Asin" -> interior e $ liftM (UnOp Asin) parseObsReal + "Acos" -> interior e $ liftM (UnOp Acos) parseObsReal + "Atan" -> interior e $ liftM (UnOp Atan) parseObsReal + "Sinh" -> interior e $ liftM (UnOp Sinh) parseObsReal + "Cosh" -> interior e $ liftM (UnOp Cosh) parseObsReal + "Asinh" -> interior e $ liftM (UnOp Asinh) parseObsReal + "Acosh" -> interior e $ liftM (UnOp Acosh) parseObsReal + "Atanh" -> interior e $ liftM (UnOp Atanh) parseObsReal + + "Add" -> interior e $ liftM2 (BinOp Add) parseObsReal parseObsReal + "Sub" -> interior e $ liftM2 (BinOp Sub) parseObsReal parseObsReal + "Mul" -> interior e $ liftM2 (BinOp Mul) parseObsReal parseObsReal + "Div" -> interior e $ liftM2 (BinOp Div) parseObsReal parseObsReal + "Min" -> interior e $ liftM2 (BinOp Min) parseObsReal parseObsReal + "Max" -> interior e $ liftM2 (BinOp Max) parseObsReal parseObsReal + + "IfThen" -> interior e $ liftM3 IfThen parseObsCond parseObsReal parseObsReal + +-- | XML parser for condition observables +parseObsCond :: XMLParser (Obs Bool) +parseObsCond = do + e@(Elem t _ _) <- element ["Const","NamedCond","At", "After","Before","IfThen" + ,"Not","And","Or","Eq","Gt","Gte","Lt","Lte"] + + case localName t of + "Const" -> interior e $ liftM Const readText + "NamedCond" -> interior e $ liftM NamedCond text + + "At" -> interior e $ liftM At readText + "After" -> interior e $ liftM After readText + "Before" -> interior e $ liftM Before readText + + "Not" -> interior e $ liftM (UnOp Not) parseObsCond + "And" -> interior e $ liftM2 (BinOp And) parseObsCond parseObsCond + "Or" -> interior e $ liftM2 (BinOp Or) parseObsCond parseObsCond + + "Gt" -> interior e $ liftM2 (BinOp Gt) parseObsReal parseObsReal + "Gte" -> interior e $ liftM2 (BinOp Gte) parseObsReal parseObsReal + "Lt" -> interior e $ liftM2 (BinOp Lt) parseObsReal parseObsReal + "Lte" -> interior e $ liftM2 (BinOp Lte) parseObsReal parseObsReal + + "IfThen" -> interior e $ liftM3 IfThen parseObsCond parseObsCond parseObsCond + +-- | Create XML tags +printObs :: Obs a -> Content () +printObs (Const v) = mkElemC "Const" (toText (show v)) +printObs (Var n) = mkElemC "Var" (toText n) +printObs (NamedVal n) = mkElemC "NamedVal" (toText n) +printObs (NamedCond n) = mkElemC "NamedCond" (toText n) + +printObs (At t) = mkElemC "At" (toText (show t)) +printObs (After t) = mkElemC "After" (toText (show t)) +printObs (Before t) = mkElemC "Before" (toText (show t)) + +printObs (IfThen oc o1 o2) = mkElemC "IfThen" [printObs oc, printObs o1, printObs o2] + +printObs (UnOp Not o1) = mkElemC "Not" [printObs o1] +printObs (UnOp Neg o1) = mkElemC "Neg" [printObs o1] +printObs (UnOp Abs o1) = mkElemC "Abs" [printObs o1] +printObs (UnOp Sqrt o1) = mkElemC "Sqrt" [printObs o1] +printObs (UnOp Exp o1) = mkElemC "Exp" [printObs o1] +printObs (UnOp Log o1) = mkElemC "Log" [printObs o1] +printObs (UnOp Sin o1) = mkElemC "Sin" [printObs o1] +printObs (UnOp Cos o1) = mkElemC "Cos" [printObs o1] +printObs (UnOp Asin o1) = mkElemC "Asin" [printObs o1] +printObs (UnOp Atan o1) = mkElemC "Atan" [printObs o1] +printObs (UnOp Acos o1) = mkElemC "Acos" [printObs o1] +printObs (UnOp Sinh o1) = mkElemC "Asinh" [printObs o1] +printObs (UnOp Cosh o1) = mkElemC "Cosh" [printObs o1] +printObs (UnOp Asinh o1) = mkElemC "Asinh" [printObs o1] +printObs (UnOp Acosh o1) = mkElemC "Acosh" [printObs o1] +printObs (UnOp Atanh o1) = mkElemC "Atanh" [printObs o1] + +printObs (BinOp And o1 o2) = mkElemC "And" [printObs o1, printObs o2] +printObs (BinOp Or o1 o2) = mkElemC "Or" [printObs o1, printObs o2] +printObs (BinOp Eq o1 o2) = mkElemC "Eq" [printObs o1, printObs o2] +printObs (BinOp Gt o1 o2) = mkElemC "Gt" [printObs o1, printObs o2] +printObs (BinOp Gte o1 o2) = mkElemC "Gte" [printObs o1, printObs o2] +printObs (BinOp Lt o1 o2) = mkElemC "Lt" [printObs o1, printObs o2] +printObs (BinOp Lte o1 o2) = mkElemC "Lte" [printObs o1, printObs o2] +printObs (BinOp Add o1 o2) = mkElemC "Add" [printObs o1, printObs o2] +printObs (BinOp Sub o1 o2) = mkElemC "Sub" [printObs o1, printObs o2] +printObs (BinOp Mul o1 o2) = mkElemC "Mul" [printObs o1, printObs o2] +printObs (BinOp Div o1 o2) = mkElemC "Div" [printObs o1, printObs o2] +printObs (BinOp Min o1 o2) = mkElemC "Min" [printObs o1, printObs o2] +printObs (BinOp Max o1 o2) = mkElemC "Max" [printObs o1, printObs o2] diff --git a/src/ObservableDB.hs b/src/ObservableDB.hs new file mode 100644 --- /dev/null +++ b/src/ObservableDB.hs @@ -0,0 +1,67 @@ +-- |Netrium is Copyright Anthony Waite, Dave Hetwett, Shaun Laurens 2009-2015, and files herein are licensed +-- |under the MIT license, the text of which can be found in license.txt +-- +module ObservableDB where + +import Control.Monad (liftM, liftM2) +import Text.XML.HaXml.Namespaces (localName) +import Text.XML.HaXml.Types (QName(..)) +import Text.XML.HaXml.XmlContent + +import XmlUtils + +newtype ObservableDB = ObservableDB { unObservableDB :: [ObservableDecl] } + deriving (Show, Read) +data ObservableDecl = ObservableDecl String ObservableType + deriving (Show, Read) +data ObservableType = Double | Bool + deriving (Show, Read) + +instance HTypeable ObservableDB where + toHType _ = Defined "ObservableDB" [] [] + +instance XmlContent ObservableDB where + parseContents = inElement "ObservableDB" $ + liftM ObservableDB parseContents + + toContents (ObservableDB ds) = + [mkElemC "ObservableDB" (toContents ds)] + +instance HTypeable ObservableDecl where + toHType _ = Defined "ObservableDecl" [] [] + +instance XmlContent ObservableDecl where + parseContents = do + e@(Elem t _ _) <- element ["ObservableDecl"] + commit $ interior e $ case localName t of + "ObservableDecl" -> liftM2 ObservableDecl (attrStr (N "name") e) parseContents + + toContents (ObservableDecl n t) = + [mkElemAC (N "ObservableDecl") [(N "name", str2attr n)] (toContents t)] + +instance HTypeable ObservableType where + toHType _ = Defined "ObservableType" [] [] + +instance XmlContent ObservableType where + parseContents = do + e@(Elem t _ _) <- element ["Double", "Bool"] + commit $ interior e $ case localName t of + "Double" -> return Double + "Bool" -> return Bool + + toContents Double = [mkElemC "Double" []] + toContents Bool = [mkElemC "Bool" []] + +compileObservableDB :: ObservableDB -> String +compileObservableDB = unlines . map compileObservable . unObservableDB + where + compileObservable (ObservableDecl n t) = + n ++ " :: Obs " ++ ct ++ "\n" ++ + n ++ " = " ++ ce ++ " " ++ show n + where + ct = case t of + Double -> "Double" + Bool -> "Bool" + ce = case t of + Double -> "primVar" + Bool -> "primCond" diff --git a/src/Observations.hs b/src/Observations.hs new file mode 100644 --- /dev/null +++ b/src/Observations.hs @@ -0,0 +1,281 @@ +-- |Netrium is Copyright Anthony Waite, Dave Hetwett, Shaun Laurens 2009-2015, and files herein are licensed +-- |under the MIT license, the text of which can be found in license.txt +-- +{-# LANGUAGE TypeSynonymInstances #-} +module Observations where + +import Contract +import DecisionTree +import Observable (VarName) +import ObservableDB (ObservableType(..)) +import XmlUtils + +import Control.Monad +import Data.List +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Monoid +import Data.Function +import Text.XML.HaXml.Namespaces (localName) +import Text.XML.HaXml.Types (QName(..)) +import Text.XML.HaXml.XmlContent + + +type Observations a = Map VarName (TimeSeries a) +type Choices a = Map ChoiceId (TimedEvents a) + + +-- --------------------------------------------------------------------------- +-- * Time series +-- --------------------------------------------------------------------------- + +data TimeSeries a = SeriesEntry Time a (TimeSeries a) + | SeriesEnds Time + | SeriesUnbounded + deriving (Show, Read) + +lookupTimeSeries :: TimeSeries a -> Time -> Maybe a +lookupTimeSeries ts0 time = case ts0 of + SeriesEntry t v ts + | time >= t -> go v ts + _ -> Nothing + where + go v (SeriesEntry t' v' ts') | time < t' = Just v + | otherwise = go v' ts' + go v (SeriesEnds t') | time < t' = Just v + | otherwise = Nothing + go v SeriesUnbounded = Just v + +pruneTimeSeries :: Time -> TimeSeries a -> TimeSeries a +pruneTimeSeries time (SeriesEntry _t _v (SeriesEntry t' v' ts')) + | time >= t' = pruneTimeSeries time (SeriesEntry t' v' ts') +pruneTimeSeries _time ts = ts + +lookupChoice :: Map ChoiceId (TimedEvents a) -> ChoiceId -> Time -> Maybe a +lookupChoice choices cid time = do + tvs <- Map.lookup cid choices + lookupTimedEvent tvs time + +timeSeriesEvents :: TimeSeries a -> TimedEvents (Maybe a) +timeSeriesEvents = TEs . go + where + go (SeriesEntry t v ts) = (t, Just v) : go ts + go (SeriesEnds t) = (t, Nothing) : [] + go SeriesUnbounded = [] + +-- --------------------------------------------------------------------------- +-- * Timed events +-- --------------------------------------------------------------------------- + +newtype TimedEvents a = TEs [(Time, a)] + deriving (Show, Read, Eq) + +unTEs (TEs x) = x + +instance Functor TimedEvents where + fmap f (TEs tes) = TEs [ (t,f e) | (t,e) <- tes ] + +instance Monoid a => Monoid (TimedEvents a) where + mempty = TEs [] + mappend as bs = + fmap mappendMergeResult (mergeEvents as bs) + where + mappendMergeResult (OnlyInLeft a) = a + mappendMergeResult (InBoth a b) = a `mappend` b + mappendMergeResult (OnlyInRight b) = b + + -- mconcat = --TODO: optimise mconcat to do more balanced merges + +mapAccumTS :: (acc -> x -> (acc, y)) + -> acc -> TimedEvents x + -> (acc, TimedEvents y) +mapAccumTS f a0 (TEs tes) = let (a', tes') = mapAccumL f' a0 tes + in (a', TEs tes') + where + f' a (t,x) = let (a', y) = f a x in (a', (t,y)) + + +lookupTimedEvent :: TimedEvents a -> Time -> Maybe a +lookupTimedEvent (TEs tes) = go tes + where + go [] _ = Nothing + go ((t,e):tes') time | time > t = go tes' time + | time == t = Just e + | otherwise = Nothing + +-- | Insert an event into a TimedEvents series. +-- +-- This event is placed before the other simultaneous events in the sequence. +-- +insertEventBefore :: Time -> a -> TimedEvents a -> TimedEvents a +insertEventBefore time e = TEs . insertBy (compare `on` fst) (time, e) . unTEs + +-- | Insert an event into a TimedEvents series. +-- +-- This event is placed after the other simultaneous events in the sequence. +-- +insertEventAfter :: Time -> a -> TimedEvents a -> TimedEvents a +insertEventAfter time e = + TEs . insertAfterBy (compare `on` fst) (time, e) . unTEs + where + insertAfterBy :: (a -> a -> Ordering) -> a -> [a] -> [a] + insertAfterBy _ x [] = [x] + insertAfterBy cmp x ys@(y:ys') = + case cmp x y of + LT -> x : ys + _ -> y : insertAfterBy cmp x ys' + +pruneTimedEvents :: Time -> TimedEvents a -> TimedEvents a +pruneTimedEvents time = TEs . dropWhile (\(t,_) -> t < time) . unTEs + +mergeEvents :: TimedEvents a -> TimedEvents b -> TimedEvents (MergeResult a b) +mergeEvents (TEs as) (TEs bs) = + TEs (map combine (mergeBy (\(t,_) (t',_) -> compare t t') as bs)) + where + combine (OnlyInLeft (t,a) ) = (t, OnlyInLeft a) + combine (InBoth (t,a) (_,b)) = (t, InBoth a b) + combine (OnlyInRight (t,b)) = (t, OnlyInRight b) + +-- For simultaneous events, ones from the second stream are placed second. +-- +mergeEventsBiased :: TimedEvents a -> TimedEvents a -> TimedEvents a +mergeEventsBiased as bs = + TEs . foldr shuffle [] . unTEs $ mergeEvents as bs + where + shuffle (t, OnlyInLeft a ) rest = (t, a) : rest + shuffle (t, InBoth a b) rest = (t, a) : (t, b) : rest + shuffle (t, OnlyInRight b) rest = (t, b) : rest + + +-- --------------------------------------------------------------------------- +-- * Merging +-- --------------------------------------------------------------------------- + + +-- | Generic merging utility. For sorted input lists this is a full outer join. +-- +mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b] +mergeBy cmp = merge + where + merge [] ys = [ OnlyInRight y | y <- ys] + merge xs [] = [ OnlyInLeft x | x <- xs] + merge (x:xs) (y:ys) = + case x `cmp` y of + GT -> OnlyInRight y : merge (x:xs) ys + EQ -> InBoth x y : merge xs ys + LT -> OnlyInLeft x : merge xs (y:ys) + +data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b + +-- --------------------------------------------------------------------------- +-- * XML instances +-- --------------------------------------------------------------------------- + +data ObservationSeries = ObservationsSeriesBool String (XMLTimeSeries Bool) + | ObservationsSeriesDouble String (XMLTimeSeries Double) + +instance HTypeable ObservationSeries where + toHType _ = Defined "ObservationSeries" [] [] + +instance XmlContent ObservationSeries where + parseContents = do + e@(Elem t _ _) <- element ["ObservationSeries"] + commit $ interior e $ case localName t of + "ObservationSeries" -> do + seriesType <- attrRead (N "type") e + seriesVar <- attrStr (N "var") e + case seriesType of + Double -> liftM (ObservationsSeriesDouble seriesVar) parseContents + Bool -> liftM (ObservationsSeriesBool seriesVar) parseContents + + toContents (ObservationsSeriesBool var ts) = + [mkElemAC (N "ObservationSeries") [(N "type", str2attr "Bool") + ,(N "var", str2attr var)] + (toContents ts)] + toContents (ObservationsSeriesDouble var ts) = + [mkElemAC (N "ObservationSeries") [(N "type", str2attr "Double") + ,(N "var", str2attr var)] + (toContents ts)] + + +data ChoiceSeries = ChoiceSeries (XMLTimedEvents Choice) +data Choice = OrChoice ChoiceId Bool + | AnytimeChoice ChoiceId + +instance HTypeable ChoiceSeries where + toHType _ = Defined "ChoiceSeries" [] [] + +instance HTypeable Choice where + toHType _ = Defined "Choice" [] [] + +instance XmlContent ChoiceSeries where + parseContents = do + e@(Elem t _ _) <- element ["Choices"] + commit $ interior e $ case localName t of + "Choices" -> liftM ChoiceSeries parseContents + + toContents (ChoiceSeries cs) = [mkElemC "Choices" (toContents cs)] + +instance XmlContent Choice where + parseContents = do + e@(Elem t _ _) <- element ["Choice"] + commit $ interior e $ case localName t of + "Choice" -> do + cid <- attrStr (N "choiceid") e + content <- parseContents + case content of + Nothing -> return (AnytimeChoice cid) + Just m -> return (OrChoice cid m) + + toContents (OrChoice cid m) = + [mkElemAC (N "Choice") [(N "choiceid", str2attr cid)] (toContents m)] + toContents (AnytimeChoice cid) = + [mkElemAC (N "Choice") [(N "choiceid", str2attr cid)] []] + + +data Timed a = Timed Time a +data SeriesEnd = Unbounded | Bounded Time + +instance HTypeable SeriesEnd where + toHType _ = Defined "SeriesEnd" [] [] + +instance XmlContent SeriesEnd where + parseContents = do + e@(Elem t _ _) <- element ["SeriesUnbounded", "SeriesEnds"] + commit $ interior e $ case localName t of + "SeriesUnbounded" -> return Unbounded + "SeriesEnds" -> liftM Bounded parseContents + + toContents Unbounded = [mkElemC "SeriesUnbounded" []] + toContents (Bounded t) = [mkElemC "Bounded" (toContents t)] + + +instance HTypeable (Timed a) where + toHType _ = Defined "SeriesEntry" [] [] + +instance XmlContent a => XmlContent (Timed a) where + parseContents = inElement "SeriesEntry" $ + liftM2 Timed parseContents parseContents + toContents (Timed t a) = [mkElemC "SeriesEntry" (toContents t ++ toContents a)] + +type XMLTimeSeries a = ([Timed a], SeriesEnd) +type XMLTimedEvents a = [Timed a] + +toTimedEvents :: XMLTimedEvents a -> TimedEvents a +toTimedEvents xs = TEs $ map (\ (Timed t a) -> (t, a)) xs + +fromTimedEvents :: TimedEvents a -> XMLTimedEvents a +fromTimedEvents (TEs xs) = map (\ (t, a) -> Timed t a) xs + +toTimeSeries :: XMLTimeSeries a -> TimeSeries a +toTimeSeries (xs, mt) = foldr cons (nil mt) xs + where + cons (Timed t a) r = SeriesEntry t a r + nil Unbounded = SeriesUnbounded + nil (Bounded t) = SeriesEnds t + +fromTimeSeries :: TimeSeries a -> XMLTimeSeries a +fromTimeSeries (SeriesUnbounded) = ([], Unbounded) +fromTimeSeries (SeriesEnds t) = ([], Bounded t) +fromTimeSeries (SeriesEntry t a r) = case fromTimeSeries r of + (xs, e) -> (Timed t a : xs, e) diff --git a/src/UnitsDB.hs b/src/UnitsDB.hs new file mode 100644 --- /dev/null +++ b/src/UnitsDB.hs @@ -0,0 +1,76 @@ +-- |Netrium is Copyright Anthony Waite, Dave Hetwett, Shaun Laurens 2009-2015, and files herein are licensed +-- |under the MIT license, the text of which can be found in license.txt +-- +module UnitsDB where + +import Control.Monad (liftM, liftM2) +import Text.XML.HaXml.Namespaces (localName) +import Text.XML.HaXml.Types (QName(..)) +import Text.XML.HaXml.XmlContent + +import XmlUtils + +newtype UnitsDB = UnitsDB { unUnitsDB :: [UnitDecl] } + deriving (Show, Read) + +data UnitDecl = CommodityDecl String + | UnitDecl String + | LocationDecl String + | CurrencyDecl String + | CashFlowTypeDecl String + deriving (Show, Read) + + +instance HTypeable UnitsDB where + toHType _ = Defined "UnitsDB" [] [] + +instance XmlContent UnitsDB where + parseContents = inElement "UnitsDB" (liftM UnitsDB parseContents) + toContents (UnitsDB ds) = [mkElemC "UnitsDB" (toContents ds)] + + +instance HTypeable UnitDecl where + toHType _ = Defined "UnitDecl" [] [] + +instance XmlContent UnitDecl where + parseContents = do + e@(Elem t _ _) <- element ["CommodityDecl", "CashFlowTypeDecl", + "UnitDecl", + "LocationDecl", "CurrencyDecl"] + commit $ interior e $ case localName t of + "CashFlowTypeDecl" -> liftM CashFlowTypeDecl (attrStr (N "name") e) + "CommodityDecl" -> liftM CommodityDecl (attrStr (N "name") e) + "UnitDecl" -> liftM UnitDecl (attrStr (N "name") e) + "LocationDecl" -> liftM LocationDecl (attrStr (N "name") e) + "CurrencyDecl" -> liftM CurrencyDecl (attrStr (N "name") e) + + toContents (CommodityDecl n) = + [mkElemAC (N "CommodityDecl") [(N "name", str2attr n)] []] + toContents (CashFlowTypeDecl n) = + [mkElemAC (N "CashFlowTypeDecl") [(N "name", str2attr n)] []] + toContents (UnitDecl n) = + [mkElemAC (N "UnitDecl") [(N "name", str2attr n)] []] + toContents (LocationDecl n) = + [mkElemAC (N "LocationDecl") [(N "name", str2attr n)] []] + toContents (CurrencyDecl n) = + [mkElemAC (N "CurrencyDecl") [(N "name", str2attr n)] []] + + +compileUnitsDB :: UnitsDB -> String +compileUnitsDB = unlines . map compileUnit . unUnitsDB + where + compileUnit (CashFlowTypeDecl n) = + n ++ " :: CashFlowType\n" ++ + n ++ " = CashFlowType " ++ show n + compileUnit (CommodityDecl n) = + n ++ " :: Commodity\n" ++ + n ++ " = Commodity " ++ show n + compileUnit (UnitDecl n) = + n ++ " :: Unit\n" ++ + n ++ " = Unit " ++ show n + compileUnit (LocationDecl n) = + n ++ " :: Location\n" ++ + n ++ " = Location " ++ show n + compileUnit (CurrencyDecl n) = + n ++ " :: Currency\n" ++ + n ++ " = Currency " ++ show n diff --git a/src/Valuation.hs b/src/Valuation.hs new file mode 100644 --- /dev/null +++ b/src/Valuation.hs @@ -0,0 +1,304 @@ +-- |Netrium is Copyright Anthony Waite, Dave Hetwett, Shaun Laurens 2009-2015, and files herein are licensed +-- |under the MIT license, the text of which can be found in license.txt +-- +-- Module for valuation semantics +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 + +-- *Value Processes +-- **The basics +-- |Type for value processes +newtype PR a = PR { unPr :: [RV a] } deriving Show + +-- |Random variables +type RV a = [a] + +-- **Value process helpers +-- |Truncates a (possibly infinite) value process +takePr :: Int -> PR a -> PR a +takePr n (PR rvs) = PR $ take n rvs + +-- |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 + +-- |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) + +-- **Value process lifting +-- |Lift functions wih a single argument +liftPr :: (a -> b) -> PR a -> PR b +liftPr f (PR a) = PR $ map (map f) a + +-- |Lift functions with 2 arguments +lift2Pr :: (a -> b -> c) -> PR a -> PR b -> PR c +lift2Pr f (PR a) (PR b) = PR $ zipWith (zipWith f) a b + +-- |Lift functions for binary operations +lift2PrAll :: (a -> a -> a) -> PR a -> PR a -> PR a +lift2PrAll f (PR a) (PR b) = PR $ zipWithAll (zipWith f) a b + +-- |Lift functions with 3 arguments +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 + +-- |A 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 (x:xs) (y:ys) = f x y : zipWithAll f xs ys +zipWithAll f xs@(_:_) [] = xs +zipWithAll f [] ys@(_:_) = ys +zipWithAll _ _ _ = [] + +-- |To use Num operations on PR +instance Num a => Num (PR a) where + fromInteger i = bigK (fromInteger i) + (+) = lift2PrAll (+) + (-) = lift2PrAll (-) + (*) = lift2PrAll (*) + abs = liftPr abs + signum = liftPr signum + +-- |To use Ord operations on PR +instance Ord a => Ord (PR a) where + max = lift2Pr (Prelude.max) + +-- |To use Equality operations on PR +instance Eq a => Eq (PR a) where + (PR a) == (PR b) = a == b + +-- *Models +-- |A model has a start date/time and an exchange rate model +data Model = Model { + modelStart :: Time, -- ^Start date and time for the model + exch :: Currency -> Currency -> PR Double -- ^Exchange rate model + } + +-- |A simple model with a constant exchange rate model +simpleModel :: Time -> Model +simpleModel modelDate = Model { + modelStart = modelDate, + exch = exch + } + where + +-- Exchange rate model + exch :: Currency -> Currency -> PR Double + exch k1 k2 = PR (konstSlices 1) + +-- |Each currency has different parameters for the interest rate model. Since the model is not realistic, these parameters are currently entirely arbitrary. +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)] + +-- |Function to pick an exchange rate model from the above list +rateModel k = + case lookup k rateModels of + Just x -> x + Nothing -> error $ "rateModel: currency not found " ++ (show k) + +-- *Process primitives +-- |Constant process +bigK :: a -> PR a +bigK x = PR (konstSlices x) + +-- |Generate an infinite list +konstSlices x = nextSlice [x] + where nextSlice sl = sl : (nextSlice (x:sl)) + +-- This needs to be changed as we are dealing with proper dates +--datePr :: PR DateTime +--datePr = PR $ timeSlices [time0] + +--timeSlices sl@((s,t):_) = sl : timeSlices [(s,t+1) | _ <- [0..t+1]] + +-- |Evaluate a condition at date T +condPr :: PR Bool -> PR a -> PR a -> PR a +condPr = lift3Pr (\b tru fal -> if b then tru else fal) + +-- |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. +-- +-- 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 + +-- |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 + +-- |Not currently implemented. The paper describes the following as a possible algorithm: +-- +-- - take the final column of the tree (horizon), +-- +-- - discount it back one time step, +-- +-- - take the maximum of that column with the corresponding column of the original tree, +-- +-- - then repeat that process all the way back to the root. +-- +-- 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) +-- @ +snell :: Currency -> (PR Bool, PR Double) -> PR Double +snell k (PR bs, prd) = prd -- stub, doesn't do anything + +-- *Lattices +-- **Simple calculation +-- |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 + +-- |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) ..] + +-- **Probability calculation +-- |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))) + +-- **Expected value +-- |The code for 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 + +-- *Valuation semantics +-- **Valuation semantics for contracts +-- |Evaluate a contract at a given time +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) + +-- **Valuation semantics for observables +-- |Evaluate a constant observable +evalO :: Obs a -> PR a +evalO (Const v) = bigK v + +-- *Functions for Graphviz output +-- |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 ++ ";" diff --git a/src/WriteDotGraph.hs b/src/WriteDotGraph.hs new file mode 100644 --- /dev/null +++ b/src/WriteDotGraph.hs @@ -0,0 +1,56 @@ +-- |Netrium is Copyright Anthony Waite, Dave Hetwett, Shaun Laurens 2009-2015, and files herein are licensed +-- |under the MIT license, the text of which can be found in license.txt +-- +{-# OPTIONS_HADDOCK hide #-} +module WriteDotGraph (renderDotGraph, writeDotFile) where + +import Data.Tree + +labelTree :: Tree a -> Int -> (Tree (Int,a), Int) +labelTree (Node l ts) n = (Node (n,l) ts', n') + where + (ts', n') = labelForest ts [] (n+1) + labelForest [] nts n = (reverse nts, n) + labelForest (t:ts) nts n = let (nt, n') = labelTree t n + in labelForest ts (nt:nts) n' + +treeToGraph :: Tree (Int, String) -> ([(Int, String)], [(Int, Int)]) +treeToGraph (Node (n, label) ts) = + let node = (n, label) + edges = [ (n, n') | Node (n', _) _ <- ts ] + (nodes', edges') = unzip (map treeToGraph ts) + in (node:concat nodes', edges++concat edges') + +writeDotFile :: FilePath -> Tree String -> IO () +writeDotFile file tree = writeFile file (renderDotGraph tree) + +renderDotGraph :: Tree String -> String +renderDotGraph tree = + unlines ( + [header + ,graphDefaultAtribs + ,nodeDefaultAtribs + ,edgeDefaultAtribs] + ++ map makeNode nodes + ++ map makeEdge edges + ++ [footer] + ) + where + (nodes, edges) = treeToGraph (fst $ labelTree tree 0) + + makeNode (n,l) = "\t" ++ show n ++ " [label=\"" ++ escape l ++ "\"];" + + makeEdge (n, n') = "\t" ++ show n ++ " -> " ++ show n' ++ "[];" + + escape [] = [] + escape ('\n':cs) = "\\n" ++ escape cs + escape ('"' :cs) = "\\\"" ++ escape cs + escape (c :cs) = c : escape cs + + +header = "digraph contract {" +footer = "}" + +graphDefaultAtribs = "\tgraph [fontsize=14, fontcolor=black, color=black];" +nodeDefaultAtribs = "\tnode [label=\"\\N\", width=\"0.75\", shape=ellipse];" +edgeDefaultAtribs = "\tedge [fontsize=10];" diff --git a/src/XmlUtils.hs b/src/XmlUtils.hs new file mode 100644 --- /dev/null +++ b/src/XmlUtils.hs @@ -0,0 +1,51 @@ +-- |Netrium is Copyright Anthony Waite, Dave Hetwett, Shaun Laurens 2009-2015, and files herein are licensed +-- |under the MIT license, the text of which can be found in license.txt +-- +{-# OPTIONS_HADDOCK hide #-} +module XmlUtils where + +import Text.XML.HaXml.Namespaces (localName) +import Text.XML.HaXml.XmlContent +import Data.Time + +attrStr n (Elem _ as _) = + case lookup n as of + Nothing -> fail ("expected attribute " ++ localName n) + Just av -> return (attr2str av) + +attrRead n e = do + str <- attrStr n e + case reads str of + [(v,_)] -> return v + _ -> fail $ "cannot parse attribute " ++ localName n ++ ": " ++ str + +mkElemAC x as cs = CElem (Elem x as cs) () + +readText :: Read a => XMLParser a +readText = do + t <- text + case reads t of + [(v,_)] -> return v + _ -> fail $ "cannot parse " ++ t + + +instance XmlContent Bool where + parseContents = do + e@(Elem t _ _) <- element ["True", "False"] + commit $ interior e $ case localName t of + "True" -> return True + "False" -> return False + + toContents True = [mkElemC "True" []] + toContents False = [mkElemC "False" []] + +instance XmlContent Double where + parseContents = inElement "Double" readText + toContents t = [mkElemC "Double" (toText (show t))] + +instance HTypeable UTCTime where + toHType _ = Defined "Time" [] [] + +instance XmlContent UTCTime where + parseContents = inElement "Time" readText + toContents t = [mkElemC "Time" (toText (show t))] diff --git a/tool/Normalise.hs b/tool/Normalise.hs new file mode 100644 --- /dev/null +++ b/tool/Normalise.hs @@ -0,0 +1,162 @@ +-- |Netrium is Copyright Anthony Waite, Dave Hetwett, Shaun Laurens 2009-2015, and files herein are licensed +-- |under the MIT license, the text of which can be found in license.txt +-- +module Main where + +import ObservableDB +import UnitsDB +import Paths_netrium_demo + +import Control.Monad (liftM, liftM2, when) +import Data.Version +import System.Environment (getArgs, getProgName) +import System.Exit (exitFailure, exitWith, ExitCode(..)) +import System.Directory (getTemporaryDirectory, canonicalizePath, removeFile) +import System.IO (openTempFile, hPutStr, hClose) +import System.Process (runProcess, waitForProcess) +import System.FilePath ((), dropExtension, addExtension, takeDirectory) +import System.Console.GetOpt +import Text.XML.HaXml.XmlContent + + +data Options = + Options + { optObsDBs :: [FilePath] + , optUnitDBs :: [FilePath] + , optImportDirs :: [FilePath] + , optFast :: Bool + , optVersion :: Bool + } + +defaultOptions = + Options + { optObsDBs = [] + , optUnitDBs = [] + , optImportDirs = [] + , optFast = False + , optVersion = False + } + +options :: [OptDescr (Options -> Options)] +options = [Option [] ["obs-db"] + (ReqArg (\ db opts -> opts { optObsDBs = db : optObsDBs opts }) "") + "use the observable database " + ,Option [] ["units-db"] + (ReqArg (\ db opts -> opts { optUnitDBs = db : optUnitDBs opts }) "") + "use the units (products, currencies etc) database " + ,Option [] ["import-dir"] + (ReqArg (\ db opts -> opts { optImportDirs = db : optImportDirs opts }) "DIR") + "Allow contracts to import modules from this directory" + ,Option [] ["fast"] + (NoArg (\ opts -> opts { optFast = True })) + "Generate the output XML quickly but without any nice formatting" + ,Option [] ["version"] + (NoArg (\ opts -> opts { optVersion = True })) + "Print version information" + ] + +main :: IO () +main = + do + plainArgs <- getArgs + let (optMods, args, errs) = getOpt Permute options plainArgs + let opts = foldl (flip ($)) defaultOptions optMods + case args of + _ | optVersion opts -> printVersion + [input] | null errs -> normalise opts input output + where output = addExtension input "xml" + [input, output] | null errs -> normalise opts input output + _ -> exit + +exit :: IO () +exit = + do + p <- getProgName + let txt = "Usage: " ++ p ++ " [options] []\n\n" ++ + "Flags:" + putStrLn $ usageInfo txt options + exitFailure + +printVersion :: IO () +printVersion = + do + p <- getProgName + putStrLn $ "netrium-demo " ++ p ++ " version " ++ showVersion version + + +getObservableDBs :: Options -> IO [ObservableDB] +getObservableDBs = mapM fReadXml . optObsDBs + +getUnitsDBs :: Options -> IO [UnitsDB] +getUnitsDBs = mapM fReadXml . optUnitDBs + + +normalise :: Options -> FilePath -> FilePath -> IO () +normalise opts input output = + do + tdir <- getTemporaryDirectory + let cdir = case takeDirectory input of "" -> "."; dir -> dir + + -- read and process the various input files + obsDBs <- getObservableDBs opts + unitsDBs <- getUnitsDBs opts + wrapper <- readFile =<< getDataFileName "normalise-wrapper.hs" + contract <- readFile input + absOutput <- canonicalizePath output + + -- write the temporary source file + (fp, h) <- openTempFile tdir "norm.hs" + hPutStr h $ generateContractProgram (optFast opts) + obsDBs unitsDBs + wrapper "normalise-wrapper.hs" + contract input + absOutput + hClose h + + -- compile and run it + ddir <- getDataDir + let ghcargs = [ "-package", "netrium-demo-" ++ showVersion version ] + ++ [ "-i" ++ dir | dir <- ddir : optImportDirs opts ++ [cdir] ] + args = map ("--ghc-arg="++) ghcargs ++ [fp] + ph <- runProcess "runghc" args Nothing Nothing Nothing Nothing Nothing + exit <- waitForProcess ph + removeFile fp + when (exit /= ExitSuccess) exitFailure + + +generateContractProgram :: Bool + -> [ObservableDB] -> [UnitsDB] + -> String -> FilePath + -> String -> FilePath + -> FilePath + -> String +generateContractProgram fast obsDBs unitsDBs + wrapper wrapperFile + contract contractFile outputFile = + unlines + [ "-- This is a generated file; do not edit.\n" + , "{-# LINE 1 " ++ show wrapperFile ++ " #-}" + , wrapper + + , "{-# LINE 1 " ++ show contractFile ++ " #-}" + , contract + + , "{-# LINE 1 \"observables database\" #-}" + , unlines (map compileObservableDB obsDBs) + + , "{-# LINE 1 \"units database\" #-}" + , unlines (map compileUnitsDB unitsDBs) + + , "{-# LINE 1 \"generated contract program\" #-}" + , "entrypoint :: Contract" + , "entrypoint = contract" + , "main = writeFile " ++ show outputFile ++ " $ " ++ outputCode + ] + where + outputCode + | fast + = "PP.renderStyle PP.style { PP.mode = PP.OneLineMode } $ " + ++ "XML.PP.document $ XML.toXml False entrypoint" + + | otherwise + = "XML.showXml False entrypoint" diff --git a/tool/Simulate.hs b/tool/Simulate.hs new file mode 100644 --- /dev/null +++ b/tool/Simulate.hs @@ -0,0 +1,290 @@ +-- |Netrium is Copyright Anthony Waite, Dave Hetwett, Shaun Laurens 2009-2015, and files herein are licensed +-- |under the MIT license, the text of which can be found in license.txt +-- +module Main where + +import Contract (Contract, Time) +import Interpreter +import DecisionTree +import Observations +import Paths_netrium_demo + +import Data.Maybe +import Data.Monoid +import Control.Monad +import qualified Data.Map as Map +import Data.Version +import System.Environment +import System.Exit +import System.Console.GetOpt +import System.FilePath + +import Text.XML.HaXml.Namespaces (localName) +import Text.XML.HaXml.Types +import Text.XML.HaXml.Pretty (document) +import Text.XML.HaXml.XmlContent +import Text.PrettyPrint.HughesPJ (render) + + +data OutputMode = XmlOutput | TextOutput + +data Options = + Options + { optMode :: OutputMode + , optTrace :: Bool + , optTest :: Bool + , optVersion :: Bool + } + +defaultOptions = + Options + { optMode = XmlOutput + , optTrace = False + , optTest = False + , optVersion = False + } + +options :: [OptDescr (Options -> Options)] +options = [Option [] ["xml"] + (NoArg (\ opts -> opts { optMode = XmlOutput })) + "Output in xml format (this is the default)" + ,Option [] ["text"] + (NoArg (\ opts -> opts { optMode = TextOutput })) + "Output as readable text" + ,Option [] ["trace"] + (NoArg (\ opts -> opts { optTrace = True })) + "Output a trace of contract steps (--text mode only)" + ,Option [] ["tests"] + (NoArg (\ opts -> opts { optTest = True })) + "Run internal tests as well" + ,Option [] ["version"] + (NoArg (\ opts -> opts { optVersion = True })) + "Print version information" + ] + +main :: IO () +main = + do + plainArgs <- getArgs + let (optMods, args, errs) = getOpt Permute options plainArgs + let opts = foldl (flip ($)) defaultOptions optMods + case args of + _ | optVersion opts -> printVersion + [contract, observations] | null errs + -> simulate opts contract observations output + where output = addExtension contract "xml" + [contract, observations, output] | null errs + -> simulate opts contract observations output + _ -> exit + + +exit :: IO () +exit = + do + p <- getProgName + let txt = "Usage: " ++ p ++ " []\n\n" + ++ "Flags:" + putStrLn (usageInfo txt options) + exitFailure + + +printVersion :: IO () +printVersion = do + p <- getProgName + putStrLn $ "netrium-demo " ++ p ++ " version " ++ showVersion version + + +simulate :: Options -> FilePath -> FilePath -> FilePath -> IO () +simulate opts contractFile observationsFile outputFile = do + + contract <- fReadXml contractFile + + (SimulationInputs startTime mStopTime mStopWait + valObsvns condObsvns + optionsTaken choicesMade + simState) <- fReadXml observationsFile + + let initialState = case simState of + Nothing -> Left contract + Just st -> Right st + simenv = SimEnv valObsvns condObsvns optionsTaken choicesMade + simout = runContract simenv startTime mStopTime mStopWait initialState + + when (optTest opts) $ + case testRunContract simenv startTime contract of + Nothing -> return () + Just err -> fail ("internal tests failed: " ++ err) + + case optMode opts of + XmlOutput -> writeFile outputFile (renderContractRunXml simout) + TextOutput -> putStr (renderContractRun simout') + where + simout' | optTrace opts = simout + | otherwise = simout { simTrace = TEs [] } + + +renderContractRun :: SimOutputs -> String +renderContractRun (SimOutputs (TEs trace) (TEs outs) + stopReason stopTime residualContract _ mWaitInfo) = + unlines $ + [ "============ Contract trace: ============" | not (null trace) ] + ++ [ show time' ++ ": " ++ msg | (time', msg) <- trace ] + ++ [ "\n============ Contract output: ============" ] + ++ [ show out | out <- outs ] + ++ [ "\n============ Contract result: ============" + , show stopReason + , show stopTime ] + ++ case mWaitInfo of + Nothing -> [] + Just (WaitInfo obss mHorizon opts) -> + [ "\n============ Horizon: ============" | isJust mHorizon ] + ++ [ show horizon | horizon <- maybeToList mHorizon ] + ++ [ "\n============ Wait conditions: ============" | not (null obss) ] + ++ [ show obs | obs <- obss ] + ++ [ "\n============ Available options: ============" | not (null opts) ] + ++ [ show opt | opt <- opts ] + +renderContractRunXml :: SimOutputs -> String +renderContractRunXml (SimOutputs _ outs stopReason stopTime residualContract simState mWaitInfo) = + render (document (Document prolog emptyST body [])) + + where + prolog = Prolog (Just (XMLDecl "1.0" Nothing Nothing)) [] Nothing [] + body = Elem (N "SimulationResult") [] $ + toContents (fromTimedEvents outs) + ++ toContents stopReason + ++ toContents stopTime + ++ toContents residualContract + ++ toContents simState + ++ toContents mWaitInfo + +data SimulationInputs = SimulationInputs + Time (Maybe Time) StopWait + (Observations Double) (Observations Bool) + (Choices ()) (Choices Bool) + (Maybe ProcessState) + +instance HTypeable SimulationInputs where + toHType _ = Defined "ChoiceSeries" [] [] + +instance XmlContent SimulationInputs where + parseContents = do + e@(Elem t _ _) <- element ["SimulationInputs"] + commit $ interior e $ case localName t of + "SimulationInputs" -> do + startTime <- parseContents + mStopTime <- parseContents + mStopWait <- parseContents + obsSeriess <- parseContents + choiceSeries <- parseContents + simState <- parseContents + let (valObsvns, condObsvns) = convertObservationSeries obsSeriess + (optionsTaken, choicesMade) = convertChoiceSeries choiceSeries + + return (SimulationInputs startTime mStopTime mStopWait + valObsvns condObsvns + optionsTaken choicesMade + simState) + + where + convertObservationSeries :: [ObservationSeries] + -> (Observations Double, Observations Bool) + convertObservationSeries obsSeriess = (valObsvns, condObsvns) + where + valObsvns = Map.fromList + [ (var, toTimeSeries ts) + | ObservationsSeriesDouble var ts <- obsSeriess ] + condObsvns = Map.fromList + [ (var, toTimeSeries ts) + | ObservationsSeriesBool var ts <- obsSeriess ] + + convertChoiceSeries :: ChoiceSeries -> (Choices (), Choices Bool) + convertChoiceSeries (ChoiceSeries choiceSeriesXml) = (optionsTaken, choicesMade) + where + optionsTaken = Map.fromListWith mergeEventsBiased + [ (cid, TEs [(t,())]) + | (t, AnytimeChoice cid) <- choiceSeries ] + choicesMade = Map.fromListWith mergeEventsBiased + [ (cid, TEs [(t,v)]) + | (t, OrChoice cid v) <- choiceSeries ] + TEs choiceSeries = toTimedEvents choiceSeriesXml + + toContents (SimulationInputs startTime mStopTime mStopWait + valObsvns condObsvns + optionsTaken choicesMade simState) = + [mkElemC "SimulationInputs" $ + toContents startTime ++ toContents mStopTime + ++ toContents mStopWait + ++ toContents obsSeriess ++ toContents choiceSeries + ++ toContents simState] + where + obsSeriess = [ ObservationsSeriesDouble var (fromTimeSeries ts) + | (var, ts) <- Map.toList valObsvns ] + ++ [ ObservationsSeriesBool var (fromTimeSeries ts) + | (var, ts) <- Map.toList condObsvns ] + choiceSeries = ChoiceSeries $ fromTimedEvents $ TEs $ + [ (t, AnytimeChoice cid) + | (cid, TEs tes) <- Map.toList optionsTaken + , (t, ()) <- tes ] + ++ [ (t, OrChoice cid v) + | (cid, TEs tes) <- Map.toList choicesMade + , (t, v) <- tes ] + +------------------------------------------------------------------------------- +-- testing +-- + +-- Check: +-- * contract and process state can round trip via xml ok +-- * trace from single stepping is the same as running from scratch + +testRunContract :: SimEnv -> Time -> Contract -> Maybe String +testRunContract simenv startTime contract + | simStopReason overallOut /= simStopReason finalStep + = Just $ show (simStopReason overallOut, simStopReason finalStep) + + | simStopTime overallOut /= simStopTime finalStep + = Just $ show (simStopTime overallOut, simStopTime finalStep) + + | simOutputs overallOut /= foldr1 mergeEventsBiased (map simOutputs steps) + = Just $ "outputs do not match:\n" + ++ show (simOutputs overallOut) + ++ "\nvs:\n" + ++ show (foldr1 mergeEventsBiased (map simOutputs steps)) + + | simTrace overallOut /= foldr1 mergeEventsBiased (map simTrace steps) + = Just $ "trace does not match:\n" + ++ show (simTrace overallOut) + ++ "\nvs:\n" + ++ show (foldr1 mergeEventsBiased (map simTrace steps)) + + | not (all checkXmlRoundTrip steps) + = Just "xml round trip failure" + + | otherwise = Nothing + where + steps = contractWaitSteps simenv startTime contract + finalStep = last steps + + overallOut = runContract simenv startTime Nothing NoStop (Left contract) + + checkXmlRoundTrip simOut = roundTripProperty (simStopContract simOut) + && roundTripProperty (simStopState simOut) + + roundTripProperty :: (XmlContent a, Eq a) => a -> Bool + roundTripProperty x = readXml (showXml False x) == Right x + +contractWaitSteps :: SimEnv -> Time -> Contract -> [SimOutputs] +contractWaitSteps simenv startTime contract = + remainingSteps step0 + where + step0 = runContract simenv startTime Nothing StopFirstWait (Left contract) + + remainingSteps out + | simStopReason out == StoppedWait = out : remainingSteps out' + | otherwise = out : [] + where + resumeState@(PSt resumeTime _ _) = simStopState out + out' = runContract simenv resumeTime + Nothing StopNextWait + (Right resumeState) diff --git a/tool/Visualise.hs b/tool/Visualise.hs new file mode 100644 --- /dev/null +++ b/tool/Visualise.hs @@ -0,0 +1,156 @@ +-- |Netrium is Copyright Anthony Waite, Dave Hetwett, Shaun Laurens 2009-2015, and files herein are licensed +-- |under the MIT license, the text of which can be found in license.txt +-- +{-# LANGUAGE PatternGuards #-} + +module Main where + +import Contract +import DecisionTreeSimplify +import Display +import Paths_netrium_demo + +import Data.Maybe +import Data.Version +import System.Environment +import System.Exit +import System.Console.GetOpt +import System.IO +import System.Directory +import System.Process +import System.FilePath + +import Text.XML.HaXml.XmlContent + + +data OutputMode = OutputSvg | OutputPng | OutputDot + +outputExtension OutputSvg = "svg" +outputExtension OutputPng = "png" +outputExtension OutputDot = "dot" + +data Options = + Options + { optMode :: OutputMode + , optDecisionTree :: Bool + , optStartTime :: Maybe Time + , optDepth :: Maybe Int + , optVersion :: Bool + } + +defaultOptions :: Options +defaultOptions = + Options + { optMode = OutputSvg + , optDecisionTree = False + , optStartTime = Nothing + , optDepth = Nothing + , optVersion = False + } + +optDepthDefault :: Int +optDepthDefault = 8 + +options :: [OptDescr (Options -> Options)] +options = + [ Option [] ["syntax-tree"] + (NoArg (\ opts -> opts { optDecisionTree = False })) + "Generate the contract syntax tree (default mode)" + , Option [] ["decision-tree"] + (NoArg (\ opts -> opts { optDecisionTree = True })) + "Generate the contract decision tree" + , Option [] ["start-time"] + (ReqArg (\ arg opts -> opts { + optStartTime = Just (readArg "start-time" arg) + }) "TIME") + "Contract start time (required in decision tree mode)" + , Option [] ["tree-depth"] + (ReqArg (\ arg opts -> opts { + optDepth = Just (readArg "tree-depth" arg) + }) "NUM") + ("Limit the tree depth (decision tree mode default is " + ++ show optDepthDefault ++ ")") + , Option [] ["svg"] + (NoArg (\ opts -> opts { optMode = OutputSvg })) + "Output in SVG image format (default format)" + , Option [] ["png"] + (NoArg (\ opts -> opts { optMode = OutputPng })) + "Output in PNG image format" + , Option [] ["dot"] + (NoArg (\ opts -> opts { optMode = OutputDot })) + "Output in DOT graph format" + , Option [] ["version"] + (NoArg (\ opts -> opts { optVersion = True })) + "Print version information" + ] + +readArg :: Read a => String -> String -> a +readArg optname arg = + case reads arg of + [(v,"")] -> v + _ -> error $ "unrecognised value '" ++ arg + ++ "' for option --" ++ optname + +main :: IO () +main = + do + plainArgs <- getArgs + let (optMods, args, errs) = getOpt Permute options plainArgs + let opts = foldl (flip ($)) defaultOptions optMods + case (args, errs) of + _ | optVersion opts -> printVersion + | optDecisionTree opts + , Nothing <- optStartTime opts + -> exit ["In --decision-tree mode, --start-time= is required"] + + ([contract], []) -> visualise opts contract output + where output = replaceExtension contract + (outputExtension (optMode opts)) + ([contract, output], []) -> visualise opts contract output + _ -> exit errs + + +exit :: [String] -> IO () +exit errs = do + p <- getProgName + let output | null errs = usageInfo usage options + | otherwise = p ++ ": " ++ unlines errs + ++ usageInfo usage options + usage = "Usage: " ++ p ++ " []\n\nFlags:" + putStrLn output + exitFailure + + +printVersion :: IO () +printVersion = do + p <- getProgName + putStrLn $ "netrium-demo " ++ p ++ " version " ++ showVersion version + + +visualise :: Options -> FilePath -> FilePath -> IO () +visualise opts contractFile outputFile = do + + contract <- fReadXml contractFile + + let tree | optDecisionTree opts + , Just startTime <- optStartTime opts + = trimDepth (fromMaybe optDepthDefault (optDepth opts)) + $ toTree (decisionTreeSimple startTime contract) + + | otherwise + = maybe id trimDepth (optDepth opts) + $ toTree contract + + case optMode opts of + OutputDot -> writeFile outputFile (renderDotGraph tree) + _ -> do + tmpdir <- getTemporaryDirectory + (tmpfile, htmp) <- openTempFile tmpdir "contract.dot" + hPutStr htmp (renderDotGraph tree) + hClose htmp + let format = case optMode opts of + OutputSvg -> "-Tsvg" + OutputPng -> "-Tpng" + exitcode <- rawSystem "dot" [format, "-o", outputFile, tmpfile] + removeFile tmpfile + exitWith exitcode