├── .gitignore ├── Haskell ├── .gitignore ├── Test.hs ├── Makefile ├── modules.txt ├── fxExamples.hs ├── Contract │ ├── Hash.hs │ ├── ExprIO.hs │ ├── Environment.hs │ ├── FXInstrument.hs │ ├── Type.hs │ ├── Date.hs │ └── Transform.hs ├── TTest.hs ├── DTest.hs ├── Contract.hs ├── CTest.hs ├── LexifiContracts.hs ├── ETest.hs └── Architecture.lhs ├── SML ├── LargeInt.sml ├── ContractSafe.sml ├── test │ ├── utest.mlb │ ├── date.mlb │ ├── expr.mlb │ ├── contract.mlb │ ├── contract.ok │ ├── tests.mlb │ ├── Makefile │ ├── Utest.sml │ ├── expr.ok │ ├── date.sml │ ├── date.ok │ ├── contract.sml │ ├── expr.sml │ └── basiccontracts.sml ├── Contract.sig ├── multicontracts.mlb ├── ListSort.sig ├── CURRENCY.sig ├── Currency.sml ├── contract.mlb ├── Instruments_test.sml ├── DateUtil.sig ├── loadscript ├── README.md ├── pftest.sml ├── ListSort.sml ├── ContractBase.sml ├── SimpleDate.sml ├── ContractMonad.sml ├── portfolio.sml ├── Makefile ├── DateUtilOld.sml ├── triggers.sml ├── CONTRACTSIG.sig ├── DateUtil.sml ├── ContractTriggers.sml ├── multicontracts.sml └── Instruments.sml ├── doc ├── DSLvision.pdf └── .gitignore ├── Coq ├── .gitignore ├── Extraction │ ├── Examples │ │ ├── Examples.hs │ │ ├── ChooserOption.hs │ │ ├── RebindableSyntaxExamples.hs │ │ ├── KnockoutOption.hs │ │ ├── AsianOption.hs │ │ ├── Bond.hs │ │ ├── DualBarrier.hs │ │ ├── CDSSimple.hs │ │ └── CreditDefaultSwap.hs │ ├── BaseTypes.hs │ ├── Makefile │ ├── Header.hs │ ├── EDSL.hs │ ├── PrettyPrinting.hs │ ├── RebindableEDSL.hs │ ├── Extraction.v │ └── HOAS.hs ├── DerivedSyntax.v ├── Causality.v ├── Tactics.v ├── Equivalence.v ├── Environments.v ├── TranslateExp.v ├── Syntax.v ├── Antisymmetry.v ├── Horizon.v ├── Typing.v ├── README.md ├── DenotationalTyped.v ├── Makefile ├── SimpleCausality.v └── Denotational.v ├── .travis.yml ├── README.md └── LICENSE /.gitignore: -------------------------------------------------------------------------------- 1 | *.ui 2 | *.uo 3 | *~ 4 | -------------------------------------------------------------------------------- /Haskell/.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.hi 3 | -------------------------------------------------------------------------------- /SML/LargeInt.sml: -------------------------------------------------------------------------------- 1 | structure LargeInt = Int 2 | -------------------------------------------------------------------------------- /SML/ContractSafe.sml: -------------------------------------------------------------------------------- 1 | structure ContractSafe = Contract :> CONTRACTSIG 2 | -------------------------------------------------------------------------------- /SML/test/utest.mlb: -------------------------------------------------------------------------------- 1 | local $(SML_LIB)/basis/basis.mlb 2 | in Utest.sml 3 | end -------------------------------------------------------------------------------- /doc/DSLvision.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/HIPERFIT/contracts/HEAD/doc/DSLvision.pdf -------------------------------------------------------------------------------- /Coq/.gitignore: -------------------------------------------------------------------------------- 1 | *.glob 2 | *.v.d 3 | *.vo 4 | Extraction/Contract.hs 5 | Extraction/ContractExtracted.hs 6 | -------------------------------------------------------------------------------- /SML/test/date.mlb: -------------------------------------------------------------------------------- 1 | local 2 | $(SML_LIB)/basis/basis.mlb 3 | ../contract.mlb 4 | utest.mlb 5 | in date.sml 6 | end -------------------------------------------------------------------------------- /SML/test/expr.mlb: -------------------------------------------------------------------------------- 1 | local 2 | $(SML_LIB)/basis/basis.mlb 3 | ../contract.mlb 4 | utest.mlb 5 | in expr.sml 6 | end -------------------------------------------------------------------------------- /SML/test/contract.mlb: -------------------------------------------------------------------------------- 1 | local 2 | $(SML_LIB)/basis/basis.mlb 3 | ../contract.mlb 4 | utest.mlb 5 | in contract.sml 6 | end -------------------------------------------------------------------------------- /doc/.gitignore: -------------------------------------------------------------------------------- 1 | *.aux 2 | *.log 3 | *.nav 4 | *.out 5 | *.pdf 6 | *.snm 7 | *.synctex.gz 8 | *.toc 9 | *.vrb 10 | *.blg 11 | *.bbl 12 | -------------------------------------------------------------------------------- /SML/Contract.sig: -------------------------------------------------------------------------------- 1 | signature Contract = 2 | CONTRACTSIG where type 'a exp = ContractBase.exp0 3 | and type contr = ContractBase.contr 4 | -------------------------------------------------------------------------------- /SML/test/contract.ok: -------------------------------------------------------------------------------- 1 | zero scale: OK 2 | zero both: OK 3 | barrier - no hit: OK 4 | barrier - hit: OK 5 | translE: OK 6 | translE': OK 7 | horizon: OK 8 | -------------------------------------------------------------------------------- /SML/multicontracts.mlb: -------------------------------------------------------------------------------- 1 | local 2 | $(SML_LIB)/basis/basis.mlb 3 | DateUtil.sml 4 | ListSort.sig 5 | ListSort.sml 6 | in 7 | multicontracts.sml 8 | end -------------------------------------------------------------------------------- /SML/test/tests.mlb: -------------------------------------------------------------------------------- 1 | local 2 | $(SML_LIB)/basis/basis.mlb 3 | ../contract.mlb 4 | utest.mlb 5 | in basiccontracts.sml 6 | ../portfolio.sml 7 | ../pftest.sml 8 | ../Instruments_test.sml 9 | end -------------------------------------------------------------------------------- /SML/ListSort.sig: -------------------------------------------------------------------------------- 1 | (** List sort operations. *) 2 | signature ListSort = 3 | sig 4 | val sort : ('a * 'a -> order) -> 'a list -> 'a list 5 | val sorted : ('a * 'a -> order) -> 'a list -> bool 6 | end 7 | -------------------------------------------------------------------------------- /SML/CURRENCY.sig: -------------------------------------------------------------------------------- 1 | signature CURRENCY = sig 2 | eqtype cur 3 | val EUR : cur 4 | val DKK : cur 5 | val SEK : cur 6 | val USD : cur 7 | val GBP : cur 8 | val JPY : cur 9 | val ppCur : cur -> string 10 | end 11 | -------------------------------------------------------------------------------- /SML/Currency.sml: -------------------------------------------------------------------------------- 1 | structure Currency = struct 2 | datatype cur = EUR | DKK | SEK | USD | GBP | JPY 3 | fun ppCur EUR = "EUR" 4 | | ppCur DKK = "DKK" 5 | | ppCur SEK = "SEK" 6 | | ppCur USD = "USD" 7 | | ppCur GBP = "GBP" 8 | | ppCur JPY = "JPY" 9 | end 10 | -------------------------------------------------------------------------------- /Haskell/Test.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified ETest as E 4 | import qualified DTest as D 5 | import qualified CTest as C 6 | import qualified TTest as T 7 | 8 | main = do putStrLn "running all tests" 9 | E.runtests 10 | D.runtests 11 | C.runtests 12 | T.runtests 13 | -------------------------------------------------------------------------------- /Coq/Extraction/Examples/Examples.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RebindableSyntax #-} 2 | 3 | module Examples where 4 | 5 | import RebindableEDSL 6 | 7 | -- Silly example to test the interaction of binders on contract and 8 | -- expression level. 9 | 10 | ex1 :: Contr 11 | ex1 = letc 0 (\ b -> scale (acc (\r -> r + (acc (\r' -> b) 0 0)) 0 0) zero) 12 | -------------------------------------------------------------------------------- /SML/test/Makefile: -------------------------------------------------------------------------------- 1 | 2 | ifeq ($(strip $(MLCOMP)),) 3 | MLCOMP=mlkit 4 | endif 5 | 6 | FILES=Makefile $(shell ls -1 *.mlb *.sml) 7 | 8 | all: tests.out expr.out contract.out date.out 9 | 10 | %.out: %.exe 11 | ./$< > $@ 12 | diff -q $@ $*.ok 13 | 14 | %.exe: $(FILES) 15 | $(MLCOMP) -output $@ $*.mlb 16 | 17 | clean: 18 | rm -rf MLB *~ *.exe *.ui *.uo run *.res *.out 19 | -------------------------------------------------------------------------------- /SML/contract.mlb: -------------------------------------------------------------------------------- 1 | local 2 | $(SML_LIB)/basis/basis.mlb 3 | in 4 | DateUtil.sig 5 | DateUtil.sml 6 | ListSort.sig 7 | ListSort.sml 8 | CURRENCY.sig 9 | Currency.sml 10 | CONTRACTSIG.sig 11 | ContractBase.sml 12 | Contract.sig 13 | Contract.sml 14 | ContractSafe.sml 15 | Instruments.sml 16 | ContractTransform.sml 17 | ContractMonad.sml 18 | end -------------------------------------------------------------------------------- /SML/Instruments_test.sml: -------------------------------------------------------------------------------- 1 | structure Instruments_test = struct 2 | open Currency Contract Instruments 3 | fun pr s c = print (s ^ ":\n " ^ ppContr c ^ "\n") 4 | 5 | val fxput = vanillaFx Put "F" "us" (USD, SEK) 30E6 6.3 365 6 | val () = pr "fxput" fxput 7 | 8 | val touch = fxBarrierTouch "me" "you" EUR 1000.0 (EUR,USD) 1.0 Up (12*30) 9 | 10 | val () = pr "touch" touch 11 | end 12 | -------------------------------------------------------------------------------- /Haskell/Makefile: -------------------------------------------------------------------------------- 1 | 2 | GHC=`which ghc` 3 | 4 | MODULES = Contract.hs Contract/*.hs 5 | TESTS = ETest.hs DTest.hs CTest.hs TTest.hs Test.hs 6 | 7 | all : Test 8 | 9 | Test: $(MODULES) $(TESTS) 10 | $(GHC) -O2 --make Test.hs 11 | 12 | qc: ${MODULES} QCHash.hs 13 | ${GHC} -O2 --make QCHash.hs -o qc && ./qc 14 | 15 | 16 | 17 | .PHONY: clean 18 | clean: 19 | rm *.hi *.o Contract/*.hi Contract/*.o Test qc 20 | -------------------------------------------------------------------------------- /Coq/Extraction/BaseTypes.hs: -------------------------------------------------------------------------------- 1 | module BaseTypes where 2 | 3 | data Asset = EUR | DKK | USD | JPY | CHF 4 | deriving (Show, Ord, Eq) 5 | 6 | data BoolObs = Decision Party String 7 | | Default Party 8 | deriving (Show, Ord, Eq) 9 | 10 | data RealObs = FX Asset Asset 11 | | Clock 12 | deriving (Show, Ord, Eq) 13 | 14 | data Party = X | Y | Z | P1 | P2 | P3 deriving (Show, Ord, Eq) 15 | -------------------------------------------------------------------------------- /SML/test/Utest.sml: -------------------------------------------------------------------------------- 1 | structure Utest = struct 2 | 3 | fun testPP pp s e f = 4 | let fun pr res = print (s ^ ": " ^ res ^ "\n") 5 | in let val e1 = f() 6 | val s1 = pp e1 7 | val s = pp e 8 | in if s1 = s then pr "OK" 9 | else pr("ERR -\n expected: " ^ s ^ "\n got: " ^ s1) 10 | end handle Fail s => pr ("EXN Fail(" ^ s ^ ")") 11 | | ? => pr ("EXN: " ^ General.exnMessage ?) 12 | end 13 | 14 | end 15 | -------------------------------------------------------------------------------- /Coq/Extraction/Examples/ChooserOption.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE RebindableSyntax #-} 3 | 4 | module ChooserOption where 5 | 6 | import RebindableEDSL 7 | 8 | strike :: Exp R 9 | strike = 6.5 10 | 11 | contract :: Contr 12 | contract = do price <- rObs (FX DKK USD) 60 13 | payout <- ife (bObs (Decision X "call option") 30) 14 | (max (price - strike) 0) 15 | (max (strike - price) 0) 16 | 60 ! (payout # transfer Y X DKK) 17 | -------------------------------------------------------------------------------- /Coq/Extraction/Examples/RebindableSyntaxExamples.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RebindableSyntax #-} 2 | 3 | module RebindableSyntaxExamples where 4 | 5 | import RebindableEDSL 6 | 7 | ex1 :: Contr 8 | ex1 = do b <- rObs (FX DKK USD) 0 > 5 && bObs (Decision X "foo") 0 9 | wait 4 10 | if b `within` 10 then zero else 11 | acc (\r -> r + (acc (\r' -> if not b then r else r') 0 0)) 1 10 # transfer X Y USD 12 | 13 | env = mkExtEnvP [][(Decision X "foo",0,True)] 14 | 15 | spec1 :: Contr 16 | spec1 = specialise ex1 env 17 | -------------------------------------------------------------------------------- /Coq/Extraction/Makefile: -------------------------------------------------------------------------------- 1 | TARGET = Contract.hs 2 | EXTRACTED = ContractExtracted.hs 3 | HEADER = Header.hs 4 | COQ_FILE = Extraction.v 5 | SED_SCRIPT = '/^data Var =/,$$'p 6 | 7 | default: $(TARGET) 8 | 9 | Contract.hs: $(EXTRACTED) $(HEADER) 10 | cp $(HEADER) $(TARGET) 11 | sed -n $(SED_SCRIPT) $(EXTRACTED) >> $(TARGET) 12 | 13 | $(EXTRACTED): $(COQ_FILE) 14 | coqc $(COQ_FILE) 15 | 16 | clean: 17 | rm -rf *~ 18 | rm -f $(TARGET) $(EXTRACTED) 19 | rm -rf $(COQ_FILE:.v=.vo) $(COQ_FILE:.v=.glob) 20 | 21 | test: default 22 | ghc -fno-code -no-hs-main Examples/*.hs 23 | -------------------------------------------------------------------------------- /Coq/Extraction/Examples/KnockoutOption.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE RebindableSyntax #-} 3 | 4 | module KnockoutOption where 5 | 6 | import RebindableEDSL 7 | 8 | -- knock-out barrier option 9 | -- 10 | 11 | knockout :: Exp R -> Exp R -> Exp R -> Int -> Contr 12 | knockout barrier strike notional maturity = 13 | if rObs (FX EUR DKK) 0 <= barrier `within` maturity 14 | then zero 15 | else if bObs (Decision X "exercise") 0 16 | then notional # (transfer Y X EUR & 17 | (strike # transfer X Y DKK)) 18 | else zero 19 | -------------------------------------------------------------------------------- /SML/DateUtil.sig: -------------------------------------------------------------------------------- 1 | signature DateUtil = sig 2 | type date (* abstract representation of a date *) 3 | exception DateError of string 4 | val ? : string -> date (* [?s] reads a date on the form YYYY-MM-DD from the string s; raises 5 | * DateError(msg) if s does not conform to the format. *) 6 | val addDays : int -> date -> date 7 | val ppDate : date -> string (* [ppDate d] prints the date d on the form YYYY-MM-DD *) 8 | val dateDiff : date -> date -> int 9 | val compare : date * date -> order 10 | end 11 | -------------------------------------------------------------------------------- /Coq/Extraction/Header.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-matches #-} 2 | 3 | module Contract (module Contract, module BaseTypes) where 4 | 5 | import Control.Monad (liftM,liftM2,liftM3) 6 | import Data.Map (Map) 7 | import Data.Maybe 8 | import qualified Data.Map as Map 9 | 10 | import Prelude hiding (map) 11 | import qualified Prelude as P 12 | import BaseTypes 13 | 14 | type List a = [a] 15 | type FMap = Map ((Party,Party),Asset) Double 16 | 17 | unionWith :: Ord k => (a -> a -> Maybe a) -> Map k a -> Map k a -> Map k a 18 | unionWith f = Map.mergeWithKey (const f) id id 19 | 20 | -------------------------------------------------------------------------------- /Haskell/modules.txt: -------------------------------------------------------------------------------- 1 | Module structure 2 | ---------------- 3 | 4 | Contract.hs -- with smart constructors (also for Expr module) 5 | 6 | Contract.Expr -- expression types, p.printer, evaluation 7 | 8 | Contract.Type -- contract type and p.printer 9 | -- exporting constructors, for internal use 10 | 11 | Contract.Date -- date library 12 | 13 | Contract.Instrument -- canned FX product functions 14 | 15 | Contract.Transform -- simplification/evaluation, normal form 16 | 17 | Contract.Analysis -- trigger extraction etc (?) 18 | 19 | -------------------------------------------------------------------------------- /Coq/Extraction/Examples/AsianOption.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RebindableSyntax #-} 2 | 3 | module AsianOption where 4 | 5 | import RebindableEDSL 6 | 7 | option :: Contr 8 | option = 90 ! if bObs (Decision X "exercise") 0 9 | then 100 # (transfer Y X USD & 10 | (rate # transfer X Y DKK)) 11 | else zero 12 | where rate = (acc (\r -> r + rObs (FX USD DKK) 0) 30 0) / 30 13 | 14 | american :: Contr 15 | american = if bObs (Decision X "exercise") 0 `within` 90 16 | then 100 # (transfer Y X USD & 17 | (6.23 # transfer X Y DKK)) 18 | else zero 19 | -------------------------------------------------------------------------------- /SML/loadscript: -------------------------------------------------------------------------------- 1 | 2 | (* load required modules *) 3 | app load ["Math", "Date", "Bool", "ListPair", "IntInf", "CharVector"]; 4 | structure LargeInt = Int; 5 | 6 | app use ["DateUtil.sig", "DateUtil.sml", "ListSort.sig", "ListSort.sml", "CURRENCY.sig", "Currency.sml", "ContractBase.sml", "CONTRACTSIG.sig", "Contract.sig", "Contract.sml", "ContractSafe.sml", "Instruments.sml", "ContractTransform.sml", "ContractMonad.sml"]; 7 | 8 | (* bring contract "constructors" in direct scope *) 9 | open Currency ContractSafe Instruments; 10 | 11 | print "vanillaFx Put \"F\" \"us\" (USD,SEK) 30E6 6.3 365:\n"; 12 | 13 | val fxput = vanillaFx Put "F" "us" (USD,SEK) 30E6 6.3 365; 14 | 15 | 16 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | env: GHCVER=7.8.4 2 | 3 | before_install: 4 | - travis_retry sudo add-apt-repository -y ppa:hvr/ghc 5 | - travis_retry sudo add-apt-repository -y ppa:avsm/ocaml41+opam12 6 | - travis_retry sudo apt-get update 7 | - travis_retry sudo apt-get install ghc-$GHCVER ocaml ocaml-native-compilers camlp4-extra 8 | - export PATH=/opt/ghc/$GHCVER/bin:$PATH 9 | - ghc --version 10 | - wget https://coq.inria.fr/distrib/V8.4pl6/files/coq-8.4pl6.tar.gz 11 | - tar xf coq-8.4pl6.tar.gz 12 | - cd coq-8.4pl6 13 | - ./configure -prefix /usr 14 | - make 15 | - sudo make install 16 | - cd .. 17 | script: 18 | - cd Coq 19 | - make 20 | - cd Extraction 21 | - make clean 22 | - make test 23 | -------------------------------------------------------------------------------- /SML/README.md: -------------------------------------------------------------------------------- 1 | Contracts 2 | ========= 3 | 4 | A simple algebraic financial contract language 5 | 6 | Introduction 7 | ============ 8 | This is an implementation of a simple financial contract language. The 9 | implementation is written in Standard ML and will easily run in most 10 | SML implementations. 11 | 12 | How to run it 13 | ============= 14 | 15 | Simply write 16 | 17 | $ make contracts.exe 18 | $ ./contracts.exe 19 | 20 | You need eiter Mlkit or MLton to get it to run with only changes to the Makefile. 21 | 22 | See also 23 | 24 | Martin Elsman. [Functional Programming for Trade Management and 25 | Valuation](http://www.elsman.com/FPforTradeManagement.pdf?attredirects=0). Seminar 26 | on Functional High Performance Computing in Finance. December 14, 27 | 2010. 28 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Certified Symbolic Management of Financial Multi-Party Contracts [![Build Status](https://travis-ci.org/HIPERFIT/contracts.svg?branch=master)](https://travis-ci.org/HIPERFIT/contracts) 2 | 3 | This is a certified implementation of a financial multi-party contract 4 | language. The Coq-based certified implementation of the language is 5 | found in the [Coq](Coq) subdirectory. The contract language and its 6 | verified Coq implementation are documented in the accompanying 7 | [ICFP 2015 paper](doc/icfp2015.pdf); 8 | the [README file](Coq/README.md) provides an overview of the Coq 9 | proofs. Moreover, this repository also includes earlier prototype 10 | implementations of the contract language in Haskell (see 11 | [Haskell](Haskell) subdirectory) and Standard ML (see [SML](SML) 12 | subdirectory). 13 | -------------------------------------------------------------------------------- /Coq/Extraction/Examples/Bond.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE RebindableSyntax #-} 3 | 4 | module Bond where 5 | 6 | import RebindableEDSL 7 | 8 | -- bond 9 | 10 | -- A bond contract parametrised by the maturity (in months), the 11 | -- currency, the interest and the nominal as well as the holder and 12 | -- the issuer of the bond. 13 | 14 | bond :: Int -> Asset -> Exp R -> Exp R -> Party -> Party -> Contr 15 | bond months cur inter nom holder issuer = payment months 16 | where payment :: Int -> Contr 17 | payment i | i < 1 = nom # transfer issuer holder cur 18 | | otherwise = (inter # transfer issuer holder cur) & 19 | (30 ! payment (i-1)) 20 | 21 | 22 | exampleBond :: Contr 23 | exampleBond = bond 12 DKK 10 1000 X Y 24 | -------------------------------------------------------------------------------- /Coq/Extraction/Examples/DualBarrier.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE RebindableSyntax #-} 3 | 4 | module DualBarrier where 5 | 6 | import RebindableEDSL 7 | 8 | -- dual barrier knock-out FX option 9 | -- 10 | -- If either of the two barriers is hit within the maturity, the 11 | -- contract is cancelled otherwise party X may exercise the FX option 12 | -- at maturity with the given strike. 13 | 14 | dualBarrier :: Exp R -> Exp R -> Exp R -> Exp R -> Int -> Contr 15 | dualBarrier lower upper strike notional maturity = 16 | if rObs (FX EUR DKK) 0 <= lower || rObs (FX CHF DKK) 0 >= upper `within` maturity 17 | then zero 18 | else if bObs (Decision X "exercise") 0 19 | then notional # (transfer Y X USD & 20 | (strike # transfer X Y DKK)) 21 | else zero 22 | 23 | 24 | ex :: Contr 25 | ex = dualBarrier 1 2 3 4 10 26 | -------------------------------------------------------------------------------- /SML/test/expr.ok: -------------------------------------------------------------------------------- 1 | test !+! - i: OK 2 | test !+! - r: OK 3 | test !-! - i: OK 4 | test !-! - r: OK 5 | test !*! - i: OK 6 | test !*! - r: OK 7 | test ! (forall t', TiTyC (REAL @ Time 0 :: t' :: ts) t c1) 21 | -> (forall t', TiTyC (map (sub_time d) (t' :: ts)) (tsub' d t) c2) 22 | -> TiTyC ts t (IfBind e d c1 c2). 23 | Proof. 24 | intros. unfold IfBind. 25 | apply causal_let with (t':= REAL @ Time 0). 26 | econstructor;eauto. econstructor. 27 | apply causal_if;eauto. 28 | eapply causal_let;eauto. apply causal_op with (ts':=[REAL @ Time 0;REAL @ Time 0]). 29 | econstructor; eauto. eauto. econstructor. econstructor; eauto. econstructor. 30 | eauto. 31 | Qed. -------------------------------------------------------------------------------- /Haskell/fxExamples.hs: -------------------------------------------------------------------------------- 1 | 2 | import Contract 3 | import Contract.FXInstrument 4 | import Contract.Transform 5 | import Contract.Analysis 6 | 7 | today = at "2014-09-02" 8 | 9 | halfY = oneY `div` 2 10 | oneY = 365 11 | 12 | -- 13 | touchOptions 14 | = (today, 15 | allCs [ fxTouch "C" "us" USD 40000 (USD,SEK) 6.90 Up halfY 16 | , fxTouch "D" "us" USD 60000 (USD,SEK) 6.15 Down oneY 17 | , fxNoTouch "A" "us" USD 140000 (USD,SEK) 6.70 Up halfY 18 | , fxNoTouch "B" "us" USD 160000 (USD,SEK) 6.25 Down oneY 19 | ]) 20 | 21 | -- One touch option will be triggered (barrier up 6.9). 22 | -- Two no-touch options will be canceled (barriers up 6.7, down 6.25). 23 | env = fixings "FX USD/SEK" today 24 | [6.6, 6.7, 6.8, 6.9, 6.8, 6.7, 6.6, 6.5, 6.4, 6.3, 6.2, 6.1] 25 | 26 | allTouch' = simplify env touchOptions 27 | 28 | run = (putStrLn . ppCashflows . cashflows) allTouch' 29 | 30 | {- 31 | *Main> run 32 | 2014-09-05 Certain [C->us] USD 40000.0000 33 | 2014-09-13 Certain [D->us] USD 60000.0000 34 | 35 | -} 36 | 37 | trs = (putStrLn . ppTriggers . branchBounds) touchOptions 38 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2013 Martin Elsman 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 9 | the Software, and to permit persons to whom the Software is furnished to do so, 10 | subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 17 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 18 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 19 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /SML/pftest.sml: -------------------------------------------------------------------------------- 1 | local 2 | open portfolio ContractSafe 3 | in 4 | 5 | (* compact function for computing and printing all cashflows 6 | startdate is the start date of the contract. 7 | *) 8 | fun ppCs mcontract = 9 | print (ppCashflows (cashflows mcontract) ^ "\n") 10 | 11 | val today = DateUtil.?"2014-01-01" 12 | 13 | (* simple test for addFixings *) 14 | 15 | val env = addFixings ("FX USD/SEK",today) 16 | [6.6,6.7,6.8,6.91,6.8,6.7,6.6,6.5,6.4,6.3,6.2,6.1] 17 | (emptyFrom today) 18 | (* two touchOptions will be triggered (barriers up 6.9, down 6.15) 19 | two noTouchOptions will be canceled (barriers up 6.7, down 6.25) *) 20 | val allTouch = (today,all touchOptions) : mcontr 21 | val allTouch' = simplify env allTouch : mcontr 22 | 23 | fun contr (_,c) = c 24 | 25 | val () = (ppCs allTouch; 26 | print "------------------\n and with fixings:\n"; 27 | ppCs allTouch'; 28 | print ("Contract was: \n" ^ ppContr (contr allTouch) ^ "\n"); 29 | print ("Simplified contract is:\n" ^ ppContr (contr allTouch') ^ "\n")) 30 | 31 | (* 32 | val () = ppCs today fxPortfolio 33 | *) 34 | 35 | (* this file should be extended to showcase advancing, fixings, normalisation *) 36 | 37 | end 38 | 39 | -------------------------------------------------------------------------------- /SML/ListSort.sml: -------------------------------------------------------------------------------- 1 | structure ListSort :> ListSort = 2 | struct 3 | fun sort ordr xs = 4 | let 5 | fun merge [] ys = ys 6 | | merge xs [] = xs 7 | | merge (x::xs) (y::ys) = 8 | if ordr(x, y) <> GREATER then x :: merge xs (y::ys) 9 | else y :: merge (x::xs) ys 10 | fun mergepairs l1 [] k = [l1] 11 | | mergepairs l1 (ls as (l2::lr)) k = 12 | if k mod 2 = 1 then l1::ls 13 | else mergepairs (merge l1 l2) lr (k div 2) 14 | fun nextrun run [] = (run, []) 15 | | nextrun run (xs as (x::xr)) = 16 | if ordr(x, List.hd run) = LESS then (run, xs) 17 | else nextrun (x::run) xr 18 | fun sorting [] ls r = List.hd(mergepairs [] ls 0) 19 | | sorting (x::xs) ls r = 20 | let val (revrun, tail) = nextrun [x] xs 21 | in sorting tail (mergepairs (List.rev revrun) ls (r+1)) (r+1) 22 | end 23 | in sorting xs [] 0 24 | end 25 | 26 | fun sorted ordr [] = true 27 | | sorted ordr (y1 :: yr) = 28 | let fun h x0 [] = true 29 | | h x0 (x1::xr) = ordr(x0, x1) <> GREATER andalso h x1 xr 30 | in h y1 yr 31 | end 32 | 33 | end (* structure ListSort *) 34 | -------------------------------------------------------------------------------- /SML/ContractBase.sml: -------------------------------------------------------------------------------- 1 | structure ContractBase = struct 2 | 3 | type var0 = string 4 | datatype exp0 = I of int 5 | | R of real 6 | | B of bool 7 | | V of var0 8 | | BinOp of string * exp0 * exp0 9 | | UnOp of string * exp0 10 | | Obs of string * int (* Obs(s,i): the value of s in i days; negative 11 | * values refer to the past... *) 12 | | ChosenBy of string * int (* label(incl party) and time *) 13 | | Iff of exp0 * exp0 * exp0 14 | | Pair of exp0 * exp0 15 | | Fst of exp0 16 | | Snd of exp0 17 | | Acc of (var0*exp0) * int * exp0 (* Acc(f,i,a) = f/i(...(f/2(f/1(a)))) *) 18 | 19 | local open Currency 20 | in 21 | type party = string 22 | datatype contr = 23 | Zero 24 | | TransfOne of cur * party * party 25 | | Scale of exp0 * contr 26 | | Transl of int * contr 27 | | Both of contr * contr 28 | | If of exp0 * contr * contr 29 | | CheckWithin of exp0 * int * contr * contr 30 | (* if cond : boolE becomes true within time: intE then contract 1 in effect. 31 | otherwise (time expired, always false) contract 2 in effect 32 | *) 33 | | Let of var0 * exp0 * contr 34 | end 35 | 36 | end 37 | -------------------------------------------------------------------------------- /SML/SimpleDate.sml: -------------------------------------------------------------------------------- 1 | (* Date *) 2 | structure SimpleDate (* : sig 3 | type date 4 | exception Date 5 | val fromString : string -> date 6 | val toString : date -> string 7 | val diff : date -> date -> int 8 | val compare : date * date -> order 9 | end *) = 10 | struct 11 | type date = {year: int, month:int, day:int} 12 | exception Date 13 | fun fromString s = 14 | {year = valOf (Int.fromString(String.substring (s,0,4))), 15 | month = valOf (Int.fromString(String.substring (s,5,2))), 16 | day = valOf (Int.fromString(String.substring (s,8,2)))} 17 | handle _ => raise Date 18 | fun padl n s = 19 | if n <= String.size s then s 20 | else padl n ("0" ^ s) 21 | fun toString {year,month,day} = 22 | padl 4 (Int.toString year) ^ "-" ^ 23 | padl 2 (Int.toString month) ^ "-" ^ 24 | padl 2 (Int.toString day) 25 | fun days {year,month,day} = 26 | 360 * (year - 1) + 30 * (month - 1) + day - 1 27 | fun diff d1 d2 = 28 | days d1 - days d2 29 | fun compare ({year=y1,month=m1,day=d1}, 30 | {year=y2,month=m2,day=d2}) = 31 | if y1 < y2 then LESS 32 | else 33 | if y1 = y2 then 34 | if m1 < m2 then LESS 35 | else 36 | if m1 = m2 then 37 | if d1 < d2 then LESS 38 | else 39 | if d1 = d2 then EQUAL 40 | else GREATER 41 | else GREATER 42 | else GREATER 43 | end 44 | -------------------------------------------------------------------------------- /Haskell/Contract/Hash.hs: -------------------------------------------------------------------------------- 1 | -- | Utility module for hashing expressions and contracts 2 | module Contract.Hash 3 | ( Hash 4 | , hash, hashStr, hashPrimes, index, hashSigned 5 | ) where 6 | 7 | import Data.Char 8 | import Data.List 9 | 10 | -- | the Hash value is an Integer 11 | type Hash = Integer 12 | 13 | -- | list of prime numbers to use as seeds in the hash 14 | hashPrimes :: [Hash] 15 | hashPrimes = [2,3,5,7,11,13,17,19,23,29,31,37,41,43,47, 16 | 53,59,61,67,71,73,79,83,89,97,101,103,107,109,113] 17 | -- let sieve (p:ps) = p : [x | x <- ps , rem x p /= 0 ] 18 | -- in sieve [2..] 19 | alpha, beta :: Hash 20 | alpha = 65599 -- but it is not used... 21 | beta = 19 -- next prime number after the hashPrimes 22 | 23 | -- | hashing an integral number 24 | hash :: Integral a => a -> Hash -> Hash 25 | hash 0 a = a 26 | hash p a = fromIntegral p * (a + 1) 27 | 28 | -- | hashing an integral number to non-negative hash 29 | hashSigned :: Integral a => a -> Hash -> Hash 30 | hashSigned p | p < 0 = hash 2 . hash (negate p) 31 | | otherwise = hash 3 . hash p 32 | 33 | 34 | -- | 35 | hashAdd :: Integral a => a -> Hash -> Hash 36 | hashAdd w acc = fromIntegral w + acc * beta 37 | 38 | 39 | hashStr :: String -> Hash -> Hash 40 | hashStr s a = go 0 a 41 | where sz = length s 42 | go n a = if n >= sz then a 43 | else go (n+1) (hashAdd (ord (s!!n)) a) 44 | 45 | index v vs = findIndex (==v) vs 46 | -------------------------------------------------------------------------------- /Coq/Extraction/Examples/CDSSimple.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE RebindableSyntax #-} 3 | 4 | module CDSSimple where 5 | 6 | -- Simple credit default swap for a zero coupon bond. 7 | 8 | import RebindableEDSL 9 | 10 | -- Credit default swap parametrised by the maturity (in days), the 11 | -- currency, the premium and the settlement as well as the buyer and 12 | -- the seller of the CDS and the reference entity. 13 | 14 | cds :: Int -> Asset -> Exp R -> Exp R -> Party -> Party -> Party -> Contr 15 | cds maturity cur premium settle buyer seller ref = 16 | payment & settlement 17 | where payment = premium # transfer buyer seller cur 18 | settlement = if bObs (Default ref) 0 `within` maturity 19 | then settle # transfer seller buyer cur 20 | else zero 21 | 22 | -- zero coupon bond 23 | 24 | bond :: Int -> Asset -> Exp R -> Party -> Party -> Contr 25 | bond maturity cur nom holder issuer = if bObs (Default issuer) 0 `within` maturity 26 | then zero 27 | else nom # transfer issuer holder cur 28 | 29 | 30 | 31 | bondCDSExample :: Contr 32 | bondCDSExample = bond 30 DKK 1000 Y X & cds 30 DKK 10 900 Y Z X 33 | 34 | env1 = mkExtEnvP [] [(Default X,n,False) | n <- [0..30]] 35 | env2 = mkExtEnvP [] [(Default X,n,n==15) | n <- [0..30]] 36 | 37 | spec1 :: Contr 38 | spec1 = specialise bondCDSExample env1 39 | 40 | spec2 :: Contr 41 | spec2 = specialise bondCDSExample env2 42 | -------------------------------------------------------------------------------- /SML/test/date.sml: -------------------------------------------------------------------------------- 1 | open DateUtil 2 | 3 | val ppDate = DateUtil.ppDate 4 | 5 | (* 6 | val fullDate = Date.toString 7 | *) 8 | 9 | fun dtest (s,d1,d2f) = Utest.testPP ppDate s d1 d2f 10 | 11 | (* 12 | fun dtestfull (s,d1,d2) = Utest.testPP fullDate s d1 (fn () => d2) 13 | *) 14 | 15 | (* Known bug: ignore week days or make sure you always pick Monday! ;-) *) 16 | val today = ?"2013-01-01" 17 | 18 | val tests1 = [ ("add nothing", (?"2013-01-01"), (fn () => addDays 0 today)) 19 | , ("add one day", (?"2013-01-02"), (fn () => addDays 1 today)) 20 | , ("add one (non-leap) year", (?"2014-01-01"), 21 | (fn () => addDays 365 today)) 22 | , ("add January", (?"2013-02-01"), (fn () => addDays 31 today)) 23 | , ("add first 6 months of the year", 24 | (?"2013-07-01"), (fn () => addDays (31+28+31+30+31+30) today)) 25 | ] 26 | 27 | fun testDiff i = Utest.testPP Int.toString 28 | ("dateDiff test with difference " ^ 29 | (Int.toString i)) 30 | i (fn () => dateDiff today (addDays i today)) 31 | fun testDiff2 dt i = dt ("dateDiff back and forth", 32 | today, fn () => addDays (~i) (addDays i today)) 33 | 34 | val () = app testDiff (List.tabulate ( 36, fn i => 10*i-31 )) 35 | val () = app (testDiff2 dtest) (List.tabulate ( 10, fn i => 25+10*i )) 36 | 37 | val () = app dtest tests1 38 | 39 | (* 40 | val () = app dtestfull tests1 41 | *) 42 | 43 | -------------------------------------------------------------------------------- /Coq/Causality.v: -------------------------------------------------------------------------------- 1 | (********** Causality **********) 2 | 3 | (* This module defines the semantic notion of causality and gives some 4 | lemmas helpful for proving causality. *) 5 | 6 | 7 | Require Export Denotational. 8 | Require Export TranslateExp. 9 | 10 | Open Scope Z. 11 | 12 | 13 | (** [ext_until d r1 r2] iff [r1] and [r2] coincide at [d] and earlier. *) 14 | 15 | Definition ext_until {A} (d : Z) (r1 r2 : ExtEnv' A) : Prop := 16 | forall l z, Z.le z d -> r1 l z = r2 l z. 17 | 18 | (* Semantic causality of (closed) contracts *) 19 | 20 | Definition causal (c : Contr) : Prop := 21 | forall d r1 r2 t1 t2, ext_until (Z.of_nat d) r1 r2 -> C[|c|]nil r1 = Some t1 -> C[|c|]nil r2 = Some t2 22 | -> t1 d = t2 d. 23 | 24 | 25 | Lemma ext_until_adv {A} d t (r1 r2 : ExtEnv' A): 26 | ext_until d (adv_ext t r1) (adv_ext t r2) <-> ext_until (t + d) r1 r2. 27 | Proof. 28 | unfold ext_until,adv_ext. split; intros. 29 | - pose (H l (z - t)%Z). 30 | assert (t + (z - t) = z)%Z as E. omega. rewrite E in *. 31 | apply e. omega. 32 | - apply H. omega. 33 | Qed. 34 | 35 | 36 | Lemma ext_until_adv_1 {A} d (r1 r2 : ExtEnv' A) : (1 <= d -> ext_until d r1 r2 -> 37 | ext_until (d - 1) (adv_ext 1 r1) (adv_ext 1 r2))%Z. 38 | Proof. 39 | intros. 40 | assert (1 + (d - 1) = d)%Z by omega. 41 | rewrite ext_until_adv. rewrite H1. assumption. 42 | Qed. 43 | 44 | Lemma ext_until_le {A} d1 d2 (r1 r2 : ExtEnv' A) : ext_until d1 r1 r2 -> d2 <= d1 -> ext_until d2 r1 r2. 45 | Proof. 46 | unfold ext_until. intros. apply H. omega. 47 | Qed. -------------------------------------------------------------------------------- /Haskell/TTest.hs: -------------------------------------------------------------------------------- 1 | module TTest where 2 | 3 | import Contract 4 | import Contract.Analysis 5 | import Contract.ExprIO 6 | 7 | import Contract.Transform -- for branch elimination 8 | 9 | import Contract.Date(Date, addDays) -- should be exported from Contract.hs... 10 | 11 | -- simple tests for trigger analysis 12 | 13 | ms n = n*30 14 | ys n = n*360 15 | 16 | -- Barrier option on "Carlsberg" stock 17 | equity = "Carlsberg" 18 | maturity = ms 3 19 | ex4if = checkWithin (strike ! String) -> String -> a -> a -> IO () 8 | testPP pp s e1 e2 = let pr msg = putStrLn (s ++ ": " ++ msg) 9 | pp1 = pp e1 10 | pp2 = pp e2 11 | in E.catch (if pp1 == pp2 then pr ": OK" 12 | else pr (": ERROR, expected " ++ pp1 13 | ++ ", got " ++ pp2)) 14 | (\e -> pr ("EXN, " ++ show (e::E.SomeException))) 15 | 16 | dtest :: (String, Date, Date) -> IO () 17 | dtest (s,d1,d2) = testPP ppDate s d1 d2 18 | 19 | today = read "2013-01-01" 20 | 21 | tests1 = [ ("add nothing", read "2013-01-01", addDays 0 today) 22 | , ("add one day", read "2013-01-02", addDays 1 today) 23 | , ("add one (non-leap) year", read "2014-01-01", addDays 365 today) 24 | , ("add January", read "2013-02-01", addDays 31 today) 25 | , ("add first 6 months of the year", 26 | read "2013-07-01", addDays (31+28+31+30+31+30) today) 27 | ] 28 | 29 | testDiff i = testPP show ("dateDiff test with difference " ++ show i) 30 | i (dateDiff today (addDays i today)) 31 | testDiff2 dt i = dt ("dateDiff back and forth", 32 | today, addDays (-i) (addDays i today)) 33 | 34 | runtests = do mapM_ testDiff [ 10*i-31 | i <- [0..35]] 35 | mapM_ (testDiff2 dtest) [ 25+10*i | i <- [0..9]] 36 | mapM_ dtest tests1 37 | -------------------------------------------------------------------------------- /SML/ContractMonad.sml: -------------------------------------------------------------------------------- 1 | 2 | structure Contract = ContractSafe 3 | 4 | signature CONTRACT_MONAD = sig 5 | type 'a m 6 | val ret : 'a -> 'a m 7 | val >>= : 'a m * ('a -> 'b m) -> 'b m 8 | val >> : unit m * 'b m -> 'b m 9 | val observe : string -> Contract.realE m 10 | val transf : Contract.realE * Contract.cur * Contract.party * Contract.party -> unit m 11 | val ifm : Contract.boolE * 'a m * 'a m -> 'a m 12 | val wait : int -> unit m 13 | val terminate : unit -> 'a m 14 | val skip : unit m 15 | val toContr : unit m -> ContractSafe.contr 16 | end 17 | 18 | structure ContractMonad :> CONTRACT_MONAD = 19 | struct 20 | open Contract 21 | type 'a m = ('a -> int -> contr) -> int -> contr 22 | fun ret a k i = k a i 23 | infix >>= >> 24 | fun f >>= g = fn k => fn i => 25 | f (fn a => fn i' => g a k i') i 26 | fun f >> m = f >>= (fn _ => m) 27 | fun observe s k i = k (obs(s,i)) i 28 | fun transf (e, c, p1, p2) k i = 29 | both(scale(e,transfOne(c,p1,p2)), k () i) 30 | fun ifm (b,m1,m2) k i = iff (b,m1 k i, m2 k i) 31 | fun wait i' k i = transl(i', k () i) 32 | fun terminate () k i = zero 33 | val skip : unit m = ret () 34 | fun toContr m = m (fn _ => fn _ => zero) 0 35 | end 36 | 37 | open ContractMonad Contract Currency 38 | infix >>= >> !> 41 | wait 5 >> 42 | transf (R 1000.0, EUR, "me", "you") >> 43 | wait 10 >> 44 | transf (R 1005.0, EUR, "you", "me")) 45 | 46 | val c2 = toContr 47 | (observe "Carlsberg" >>= (fn strike => 48 | wait 30 >> 49 | observe "Carlsberg" >>= (fn c => 50 | ifm(strike ! Asset -> Exp R -> Exp R -> Party -> Party -> Party -> Contr 13 | cds months cur premium comp buyer seller ref = 14 | step months 15 | where step i = if (i <= 0) then zero else 16 | (premium # transfer buyer seller cur) & 17 | if bObs (Default ref) 0 `within` 30 18 | then comp # transfer seller buyer cur 19 | else step (i-1) 20 | 21 | 22 | -- A bond contract parametrised by the maturity (in months), the 23 | -- currency, the interest and the nominal as well as the holder and 24 | -- the issuer of the bond. 25 | 26 | bond :: Int -> Asset -> Exp R -> Exp R -> Party -> Party -> Contr 27 | bond months cur inter nom holder issuer = step months 28 | where step i = if i <= 0 then nom # transfer issuer holder cur 29 | else inter # transfer issuer holder cur & 30 | if bObs (Default issuer) 0 `within` 30 31 | then zero 32 | else step (i-1) 33 | 34 | 35 | bondCDSExample :: Contr 36 | bondCDSExample = bond 12 DKK 10 1000 Y X & cds 12 DKK 9 1000 Y Z X 37 | 38 | env1 = mkExtEnvP [] [(Default X,n,False) | n <- [0..6*30]] 39 | env2 = mkExtEnvP [] [(Default X,n,n==50) | n <- [0..6*30]] 40 | 41 | spec1 :: Contr 42 | spec1 = specialise bondCDSExample env1 43 | 44 | spec2 :: Contr 45 | spec2 = specialise bondCDSExample env2 46 | -------------------------------------------------------------------------------- /SML/test/date.ok: -------------------------------------------------------------------------------- 1 | dateDiff test with difference ~31: OK 2 | dateDiff test with difference ~21: OK 3 | dateDiff test with difference ~11: OK 4 | dateDiff test with difference ~1: OK 5 | dateDiff test with difference 9: OK 6 | dateDiff test with difference 19: OK 7 | dateDiff test with difference 29: OK 8 | dateDiff test with difference 39: OK 9 | dateDiff test with difference 49: OK 10 | dateDiff test with difference 59: OK 11 | dateDiff test with difference 69: OK 12 | dateDiff test with difference 79: OK 13 | dateDiff test with difference 89: OK 14 | dateDiff test with difference 99: OK 15 | dateDiff test with difference 109: OK 16 | dateDiff test with difference 119: OK 17 | dateDiff test with difference 129: OK 18 | dateDiff test with difference 139: OK 19 | dateDiff test with difference 149: OK 20 | dateDiff test with difference 159: OK 21 | dateDiff test with difference 169: OK 22 | dateDiff test with difference 179: OK 23 | dateDiff test with difference 189: OK 24 | dateDiff test with difference 199: OK 25 | dateDiff test with difference 209: OK 26 | dateDiff test with difference 219: OK 27 | dateDiff test with difference 229: OK 28 | dateDiff test with difference 239: OK 29 | dateDiff test with difference 249: OK 30 | dateDiff test with difference 259: OK 31 | dateDiff test with difference 269: OK 32 | dateDiff test with difference 279: OK 33 | dateDiff test with difference 289: OK 34 | dateDiff test with difference 299: OK 35 | dateDiff test with difference 309: OK 36 | dateDiff test with difference 319: OK 37 | dateDiff back and forth: OK 38 | dateDiff back and forth: OK 39 | dateDiff back and forth: OK 40 | dateDiff back and forth: OK 41 | dateDiff back and forth: OK 42 | dateDiff back and forth: OK 43 | dateDiff back and forth: OK 44 | dateDiff back and forth: OK 45 | dateDiff back and forth: OK 46 | dateDiff back and forth: OK 47 | add nothing: OK 48 | add one day: OK 49 | add one (non-leap) year: OK 50 | add January: OK 51 | add first 6 months of the year: OK 52 | -------------------------------------------------------------------------------- /SML/test/contract.sml: -------------------------------------------------------------------------------- 1 | infix 7 !*! 2 | infix 6 !+! !-! 3 | infix 5 !|! 4 | infix 4 !=! ! 11 | let val c = f() 12 | in #2(simplify E (today,c)) 13 | end) 14 | 15 | val E0 = emptyFrom today 16 | fun ctest s c f = ctestE s c f E0 17 | 18 | val () = ctest "zero scale" zero (fn () => scale(R 3.0,zero)) 19 | val () = ctest "zero both" zero (fn () => both(zero,scale(R 3.0,zero))) 20 | 21 | fun iter n f a = if n < 0 then a else iter (n-1) f (f(n,a)) 22 | val pay1EUR = transfOne(EUR,"me","you") 23 | val equity = "Carlsberg" 24 | infix ++ 25 | fun d ++ i = DateUtil.addDays i d 26 | 27 | val () = 28 | let val y1 = 360 29 | val hit = transl(y1,pay1EUR) 30 | fun f x = x !|! (R 50.0 ! addFixing((equity,today++i,20.0),e)) E0 36 | val E_hit = iter 1000 (fn (i,e) => addFixing((equity,today++i,real (i div 7)),e)) E0 37 | in ctestE "barrier - no hit" zero barrier E_no 38 | ; ctestE "barrier - hit" hit barrier E_hit 39 | end 40 | 41 | val () = 42 | let val maxInt = 100000 43 | fun translE(e: intE,c) = 44 | letc(e !+! obs("Time",0), fn x => checkWithin(obs("Time",0) !=! x, maxInt, c, zero)) 45 | val E = iter 1000 (fn (i,e) => addFixing((equity,today++i,2.0),e)) E0 46 | val E' = iter 1000 (fn (i,e) => addFixing((equity,today++i,3.0+real i),e)) E0 47 | val c = transl(5,translE(obs(equity,2), pay1EUR)) 48 | in ctestE "translE" (transl(7,pay1EUR)) (fn () => c) E; 49 | ctestE "translE'" (transl(15,pay1EUR)) (fn () => c) E'; 50 | Utest.testPP Int.toString "horizon" 100005 (fn () => horizon c) 51 | end 52 | -------------------------------------------------------------------------------- /Coq/Tactics.v: -------------------------------------------------------------------------------- 1 | (** [false_goal] replaces any goal by the goal [False]. 2 | Contrary to the tactic [false] (below), it does not try to do 3 | anything else *) 4 | 5 | Tactic Notation "false_goal" := 6 | elimtype False. 7 | 8 | (** [false_post] is the underlying tactic used to prove goals 9 | of the form [False]. In the default implementation, it proves 10 | the goal if the context contains [False] or an hypothesis of the 11 | form [C x1 .. xN = D y1 .. yM], or if the [congruence] tactic 12 | finds a proof of [x <> x] for some [x]. *) 13 | 14 | Ltac false_post := 15 | solve [ assumption | discriminate | congruence ]. 16 | 17 | (** [false] replaces any goal by the goal [False], and calls [false_post] *) 18 | 19 | Tactic Notation "false" := 20 | false_goal; try false_post. 21 | 22 | (** [tryfalse] tries to solve a goal by contradiction, and leaves 23 | the goal unchanged if it cannot solve it. 24 | It is equivalent to [try solve \[ false \]]. *) 25 | 26 | Tactic Notation "tryfalse" := 27 | try solve [ false ]. 28 | 29 | (** [tryfalse by tac /] is that same as [tryfalse] except that 30 | it tries to solve the goal using tactic [tac] if [assumption] 31 | and [discriminate] do not apply. 32 | It is equivalent to [try solve \[ false; tac \]]. 33 | Example: [tryfalse by congruence/] *) 34 | 35 | Tactic Notation "tryfalse" "by" tactic(tac) "/" := 36 | try solve [ false; instantiate; tac ]. 37 | 38 | 39 | Ltac rewr_assumption := idtac; match goal with 40 | | [R: _ = _ |- _ ] => first [rewrite R| rewrite <- R] 41 | end. 42 | 43 | Tactic Notation "rewr_assumption" "in" ident(H) := 44 | idtac; match goal with 45 | | [R: _ = _ |- _ ] => first [rewrite R in H| rewrite <- R in H] 46 | end. 47 | 48 | 49 | Ltac def_to_eq_sym X HX E := 50 | assert (HX : E = X) by reflexivity; clearbody X. 51 | 52 | Tactic Notation "cases" constr(E) "as" ident(H) := 53 | let X := fresh "TEMP" in 54 | set (X := E) in *; def_to_eq_sym X H E; 55 | destruct X. 56 | 57 | Tactic Notation "cases" constr(E) := 58 | let H := fresh "Eq" in cases E as H. 59 | -------------------------------------------------------------------------------- /Coq/Extraction/EDSL.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ImpredicativeTypes #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | 7 | module EDSL ( 8 | -- * Data types used in contracts 9 | Asset (..), 10 | Party (..), 11 | 12 | Exp, 13 | acc, 14 | ife, 15 | -- * Real expression combinators 16 | RExp, 17 | rLit, 18 | rObs, 19 | 20 | 21 | -- * Boolean expression combinators 22 | BExp, 23 | false, true, 24 | (!!), (!>=!), (!&!), (!|!), 25 | bNot, 26 | bObs, 27 | 28 | -- * Contract combinators 29 | ContrHoas, 30 | Contr, 31 | zero, 32 | transfer, 33 | scale, 34 | (#), 35 | both, 36 | (&), 37 | translate, 38 | (!), 39 | ifWithin, 40 | iff, 41 | letc, 42 | 43 | -- * Operations on contracts 44 | ObsLabel (..), 45 | RealObs (..), 46 | BoolObs (..), 47 | ExtEnvP, 48 | FMap, 49 | horizon, 50 | advance, 51 | specialise, 52 | hasType, 53 | printContr, 54 | showContr, 55 | 56 | mkExtEnvP, 57 | 58 | ExpHoas, 59 | R, B, 60 | 61 | ) where 62 | 63 | import Contract hiding (Exp,Contr,specialise,horizon,map) 64 | import qualified Contract as C 65 | import HOAS 66 | import qualified Data.Map as Map 67 | import Data.Maybe 68 | 69 | 70 | horizon :: Contr -> Int 71 | horizon c = C.horizon (fromHoas c) 72 | 73 | advance :: Contr -> ExtEnvP -> (Contr, FMap) 74 | advance c env = let (c',t) = fromJust (redfun (fromHoas c) [] env) 75 | in (toHoas c', t) 76 | 77 | specialise :: Contr -> ExtEnvP -> Contr 78 | specialise c = toHoas . C.specialise (fromHoas c) [] 79 | 80 | mkExtEnvP :: [(RealObs, Int,Double)] -> [(BoolObs, Int,Bool)] -> ExtEnvP 81 | mkExtEnvP rs bs = env 82 | where real (l,i,r) = ((l,i),RVal r) 83 | bool (l,i,r) = ((l,i),BVal r) 84 | tabR = Map.fromList (map real rs) 85 | tabB = Map.fromList (map bool bs) 86 | env (LabR l) i = Map.lookup (l,i) tabR 87 | env (LabB l) i = Map.lookup (l,i) tabB 88 | 89 | 90 | hasType :: Contr -> Bool 91 | hasType = C.has_type . fromHoas 92 | 93 | printContr :: Contr -> IO () 94 | printContr = putStrLn . showContr 95 | 96 | showContr :: Contr -> String 97 | showContr = show . fromHoas 98 | -------------------------------------------------------------------------------- /SML/portfolio.sml: -------------------------------------------------------------------------------- 1 | structure portfolio = struct 2 | 3 | local open Currency Instruments 4 | in 5 | 6 | (* single barrier options: directly taken from table *) 7 | 8 | val singleBarriers = 9 | [ fxSingleBarrierOut "us" "A" (USD,SEK) Call Down 10E6 6.60 6.25 180 (* 6 months *) 10 | , fxSingleBarrierOut "A" "us" (USD,SEK) Call Down 15E6 6.40 6.25 180 (* 6 months *) 11 | , fxSingleBarrierIn "B" "us" (USD,SEK) Put Up 50E6 6.40 6.80 360 (* 1 year *) 12 | , fxSingleBarrierOut "C" "us" (USD,SEK) Call Down 5E6 6.30 6.70 360 (* 1 year *) 13 | , fxSingleBarrierIn "D" "us" (USD,SEK) Put Down 50E6 6.70 6.20 360 (* 1 year *) 14 | ] 15 | 16 | val doubleBarriers = 17 | [ fxDoubleBarrierIn "A" "us" (USD,SEK) Call 5E6 6.60 (6.20,6.80) 90 (* 3 months *) 18 | , fxDoubleBarrierOut "B" "us" (USD,SEK) Call 10E6 6.40 (6.20,6.80) 90 19 | , fxDoubleBarrierOut "B" "us" (USD,SEK) Put 8E6 6.50 (6.20,6.80) 90 20 | , fxDoubleBarrierIn "D" "us" (USD,SEK) Put 40E6 6.30 (6.10,6.70) 360 (* 1 year *) 21 | ] 22 | 23 | (* Asian options: not yet handled (needs observable average computation) *) 24 | 25 | val touchOptions = 26 | [ fxBarrierTouch "C" "us" USD (0.04 * 10E6) (USD,SEK) 6.90 Up 180 (* 6 months *) 27 | , fxBarrierTouch "D" "us" USD (0.03 * 20E6) (USD,SEK) 6.15 Down 360 (* 12 months*) 28 | , fxBarrierNoTouch "A" "us" USD (0.07 * 20E6) (USD,SEK) 6.70 Up 180 (* 6 months*) 29 | , fxBarrierNoTouch "B" "us" USD (0.08 * 20E6) (USD,SEK) 6.25 Down 360 (* 12 months*) 30 | ] 31 | 32 | val vanillas = 33 | [ vanillaFx Call "us" "F" (USD,SEK) 10E6 6.60 90 (* 3 months *) 34 | , vanillaFx Put "us" "F" (USD,SEK) 10E6 6.30 180 (* 6 months *) 35 | , vanillaFx Put "F" "us" (USD,SEK) 10E6 6.30 360 (* 12 months *) 36 | , vanillaFx Put "us" "F" (USD,SEK) 10E6 6.30 720 (* 24 months *) 37 | ] 38 | 39 | val forwards = 40 | [ fxForward "us" "G" (USD,SEK) 60E6 6.55 180 (* 6 months *) 41 | ] 42 | 43 | (* everything together (using "all" constructor) is the portfolio *) 44 | val fxPortfolio = ContractSafe.all (singleBarriers @ doubleBarriers @ 45 | touchOptions @ vanillas @ forwards) 46 | 47 | end 48 | 49 | end 50 | -------------------------------------------------------------------------------- /Coq/Equivalence.v: -------------------------------------------------------------------------------- 1 | Require Export Denotational. 2 | Require Import TranslateExp. 3 | Require Import FunctionalExtensionality. 4 | Require Import Tactics. 5 | 6 | Require Import DenotationalTyped. 7 | 8 | (********** Equivalence of contracts **********) 9 | 10 | (* Full equivalence. *) 11 | 12 | Definition equiv (g : TyEnv) (c1 c2 : Contr) : Prop 13 | := g |-C c1 /\ g |-C c2 /\ 14 | (forall (env : Env) (ext : ExtEnv), 15 | TypeExt ext -> TypeEnv g env -> C[|c1|]env ext = C[|c2|]env ext). 16 | Notation "c1 '≡[' g ']' c2" := (equiv g c1 c2) (at level 50). 17 | 18 | 19 | Lemma equiv_typed g c1 c2 : g |-C c1 -> g |-C c2 -> (forall t1 t2 env ext, TypeExt ext -> TypeEnv g env -> C[|c1|]env ext = Some t1 -> C[|c2|]env ext = Some t2 -> t1 = t2) -> c1 ≡[g] c2. 20 | Proof. 21 | intros T1 T2 E. unfold equiv. repeat split;auto. intros. 22 | eapply Csem_typed_total in T1;eauto. destruct T1 as [t1 T1]. 23 | eapply Csem_typed_total in T2;eauto. destruct T2 as [t2 T2]. 24 | rewrite T1. rewrite T2. f_equal. eauto. 25 | Qed. 26 | 27 | Lemma delay_trace_at d t : delay_trace d t d = t O. 28 | Proof. 29 | unfold delay_trace. 30 | assert (leb d d = true) as E by (apply leb_correct; auto). 31 | rewrite E. rewrite minus_diag. reflexivity. 32 | Qed. 33 | 34 | Hint Resolve translateExp_type. 35 | 36 | Theorem transl_ifwithin g e d t c1 c2 : g |-C c1 -> g |-C c2 -> g |-E e ∶ BOOL -> 37 | If (translateExp (Z.of_nat d) e) t (Translate d c1) (Translate d c2) ≡[g] 38 | Translate d (If e t c1 c2). 39 | Proof. 40 | unfold equiv. intros. repeat split; eauto. intros env ext R V. 41 | generalize dependent ext. induction t; intros. 42 | - eapply Esem_typed_total with (ext:=(adv_ext (Z.of_nat d) ext)) in H1;eauto. 43 | decompose [ex and] H1. simpl in *. rewrite translateExp_ext, H3 in *. 44 | destruct x; try destruct b; reflexivity. 45 | - pose H1 as H1'. eapply Esem_typed_total with (ext:=(adv_ext (Z.of_nat d) ext)) in H1';eauto. 46 | decompose [ex and] H1'. simpl in *. rewrite translateExp_ext, H3. destruct x; try reflexivity. destruct b. reflexivity. 47 | rewrite IHt;eauto. rewrite adv_ext_swap. repeat rewrite liftM_liftM. apply liftM_ext. 48 | intros. unfold compose. apply delay_trace_swap. 49 | Qed. -------------------------------------------------------------------------------- /Haskell/Contract/ExprIO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, StandaloneDeriving #-} 2 | module Contract.ExprIO where 3 | 4 | import Contract.Expr 5 | -- Show/Read instances and other pretty-printing related stuff 6 | 7 | deriving instance Show (Expr a) 8 | 9 | {- 10 | -- | Operators can be read in 11 | instance Read AOp where 12 | readsPrec _ ('+':rest) = [(Plus,rest)] 13 | readsPrec _ ('-':rest) = [(Minus,rest)] 14 | readsPrec _ ('*':rest) = [(Times,rest)] 15 | readsPrec _ ('/':rest) = [(Div,rest)] 16 | readsPrec _ ('m':'a':'x':rest) = [(Max,rest)] 17 | readsPrec _ ('m':'i':'n':rest) = [(Min,rest)] 18 | readsPrec _ _ = [] 19 | -} 20 | 21 | ----------------------------------------------------------------- 22 | -- Pretty-print an expression (not the same as the Show instance) 23 | 24 | -- | internal: print an expression, using an int printing function 25 | ppExp0 :: (Int -> String) -> Expr a -> String 26 | ppExp0 ppInt e = 27 | case e of 28 | V s -> s 29 | I i -> ppInt i 30 | R r -> ppReal r 31 | B b -> show b 32 | Pair e1 e2 -> par (ppExp0 ppInt e1 ++ "," ++ ppExp0 ppInt e2) 33 | Fst e -> "first" ++ par (ppExp0 ppInt e) 34 | Snd e -> "second" ++ par (ppExp0 ppInt e) 35 | Acc f i e -> "acc" ++ par(ppFun f ++ "," ++ show i ++ "," ++ ppExp e) 36 | Obs (s,off) -> "Obs" ++ par (s ++ "@" ++ ppInt off) 37 | ChosenBy (p,i) -> "Chosen by " ++ p ++ " @ " ++ ppInt i 38 | Not e1 -> "not" ++ par (ppExp e1) 39 | Arith op e1 e2 -> let (c,infx) = ppOp op 40 | in if infx then par(ppExp e1 ++ c ++ ppExp e2) 41 | else c ++ par (ppExp e1) ++ ' ':par(ppExp e2) 42 | Less e1 e2 -> par(ppExp0 ppInt e1 ++ " < " ++ ppExp0 ppInt e2) 43 | Equal e1 e2 -> par(ppExp0 ppInt e1 ++ "==" ++ ppExp0 ppInt e2) 44 | Or e1 e2 -> par(ppExp e1 ++ "||" ++ ppExp e2) 45 | where ppExp e = ppExp0 ppInt e 46 | ppFun (v,e) = "\\" ++ v ++ " -> " ++ ppExp e 47 | 48 | -- | pretty-printing an expression, using normal printer for Int 49 | ppExp = ppExp0 show 50 | 51 | -- parenthesis around a string 52 | par s = "(" ++ s ++ ")" 53 | -------------------------------------------------------------------------------- /SML/Makefile: -------------------------------------------------------------------------------- 1 | MLCOMP=mlkit 2 | #MLCOMP=mlton 3 | 4 | MOSMLC=mosmlc 5 | MOSML=mosml 6 | 7 | # All infrastructure modules (not tests). Order matters here: 8 | 9 | COREFILES=DateUtil.sig DateUtil.sml ListSort.sig ListSort.sml CURRENCY.sig Currency.sml ContractBase.sml CONTRACTSIG.sig Contract.sig Contract.sml ContractSafe.sml ContractTransform.sml Instruments.sml 10 | MOSMLFILES=LargeInt.sml $(COREFILES) 11 | 12 | SMLFILES=$(COREFILES) ContractMonad.sml 13 | 14 | all: contract.exe 15 | 16 | .PHONY: help clean 17 | help: 18 | @echo " Target Purpose remarks" 19 | @echo "-------------------------------------------------------------------" 20 | @echo "contractmos runs loadscript in interpreter mosml" 21 | @echo " (loading some essential modules)" 22 | @echo "mosmodules compiles all basic modules with data mosml" 23 | @echo " types and manipulation functions)" 24 | @echo "portfolio compiles portfolio module mosml" 25 | @echo " (depends on above modules)" 26 | @echo "pftest BROKEN! portfolio test program mosml" 27 | @echo "contract.exe compiles contracts mlb mlkit" 28 | @echo " (Instruments_test.sml)" 29 | @echo "" 30 | @echo "multicontracts.exe multiparty contracts mlb old" 31 | 32 | contract.exe: contract.mlb $(SMLFILES) 33 | $(MLCOMP) -output $@ contract.mlb 34 | 35 | multicontracts.exe: multicontracts.mlb multicontracts.sml $(SMLFILES) 36 | $(MLCOMP) -output $@ multicontracts.mlb 37 | 38 | #multimos: $(MOSMLFILES) test.sml 39 | # $(MOSMLC) -o multimos $^ 40 | 41 | contractmos: $(MOSMLFILES) 42 | $(MOSML) loadscript 43 | 44 | clean: 45 | rm -rf MLB *~ *.exe *.ui *.uo multimos run doc/*~ 46 | make -C test clean 47 | 48 | mosmodules: $(MOSMLFILES) 49 | for F in $(MOSMLFILES); do $(MOSMLC) -c $${F}; done 50 | 51 | portfolio.uo: mosmodules portfolio.sml 52 | $(MOSMLC) -c portfolio.sml 53 | 54 | pftest: portfolio.uo pftest.sml 55 | @echo ----------------------------------------------------------- 56 | @echo pftest in MosML is broken since ContractSafe was introduced 57 | @echo ----------------------------------------------------------- 58 | # doznwok: $(MOSMLC) -o pftest pftest.sml 59 | 60 | .PHONY: test 61 | test: 62 | $(MAKE) -C test all 63 | -------------------------------------------------------------------------------- /SML/DateUtilOld.sml: -------------------------------------------------------------------------------- 1 | structure DateUtil :> DateUtil = struct 2 | 3 | type date = Date.date 4 | exception DateError of string 5 | 6 | (* module functions operate on the Date.date type, ignoring time *) 7 | 8 | (* The expected format of our converter is yyyy-mm-dd. Suffix is ignored *) 9 | fun ? s = let val y = String.substring (s,0,4) 10 | val m = case String.substring(s,5,2) of 11 | "01" => "Jan " 12 | | "02" => "Feb " 13 | | "03" => "Mar " 14 | | "04" => "Apr " 15 | | "05" => "May " 16 | | "06" => "Jun " 17 | | "07" => "Jul " 18 | | "08" => "Aug " 19 | | "09" => "Sep " 20 | | "10" => "Oct " 21 | | "11" => "Nov " 22 | | "12" => "Dec " 23 | | other => raise DateError "garbled date" 24 | val d = String.substring (s,8,2) 25 | val bogus = case Date.fromString ("Mon " ^ m ^ d ^ " 00:00:00 " ^ y) of 26 | SOME x => x 27 | | NONE => raise DateError ("date conversion failed for " ^ 28 | "Mon " ^ m ^ d ^ " 00:00:00 " ^ y) 29 | in (* correcting the weekday: *) 30 | Date.fromTimeLocal (Date.toTime bogus) 31 | end 32 | 33 | fun addDays i d = 34 | let val t = Date.toTime d (* uses local time! see below *) 35 | val seconds = real i * 24.0*60.0*60.0 36 | (* Mosml's Time.fromSeconds function has a wrong type, thus it is 37 | * necessary to use the real representation for portability *) 38 | val off = Time.fromReal seconds 39 | val t' = Time.+(t,off) 40 | in Date.fromTimeLocal t' (* local time is used... 41 | TODO problem with daylight saving *) 42 | end 43 | 44 | (* computes day difference to go from d1 to d2 *) 45 | fun dateDiff d1 d2 = 46 | let val t1 = Date.toTime d1 47 | val t2 = Date.toTime d2 48 | val t = Time.-(t2,t1) 49 | val s = Time.toSeconds t 50 | in LargeInt.toInt(((s div 24) div 60) div 60) 51 | end 52 | 53 | val ppDate = Date.fmt "%Y-%m-%d" 54 | val compare = Date.compare 55 | end 56 | 57 | -------------------------------------------------------------------------------- /SML/triggers.sml: -------------------------------------------------------------------------------- 1 | (* this is a mosml script for development *) 2 | 3 | app load ["Real", "Int", "ContractBase", "Contract", "ContractTriggers" ]; 4 | 5 | open ContractBase Contract ContractTriggers; 6 | 7 | (* copied *) 8 | infix !+! !-! !*! ! mkOpt 3 (40.0 + real di))) 37 | val test2 = all (List.tabulate (6, fn i => mkOpt i (real i + 42.0))) 38 | val test3 = all [test1,test2] 39 | 40 | fun ppTriggers [] = "" 41 | | ppTriggers ((s,(i,j),vs)::rest) 42 | = s ^ " from day " ^ Int.toString i ^ " to " ^ Int.toString j ^ 43 | ": " ^ (String.concatWith ", " (map Real.toString vs)) ^ 44 | "\n" ^ ppTriggers rest 45 | 46 | (* some test data *) 47 | infix !+! !-! !*! ! mkOpt 3 (40.0 + real di))) 76 | val test2 = all (List.tabulate (6, fn i => mkOpt i (real i + 42.0))) 77 | val test3 = all [test1,test2] 78 | 79 | val () = (print ("Carlsberg barrier options (settled):\n" ^ ppContr test3); 80 | print "\nTrigger values:\n"; 81 | print (ppTriggers (triggers (0,10) test3))) 82 | 83 | -------------------------------------------------------------------------------- /Coq/Environments.v: -------------------------------------------------------------------------------- 1 | Require Export ZArith. 2 | Require Export Syntax. 3 | Require Import FunctionalExtensionality. 4 | Require Import Tactics. 5 | 6 | (* External environments map observables to values. [ExtEnv'] is 7 | parametrised over the type of values so that we can instantiate it 8 | later to partial environments. *) 9 | 10 | Definition ExtEnv' A := ObsLabel -> Z -> A. 11 | 12 | 13 | 14 | Open Scope Z. 15 | 16 | (* Move external environments into the future. *) 17 | 18 | Definition adv_ext {A} (d : Z) (e : ExtEnv' A) : ExtEnv' A 19 | := fun l x => e l (d + x)%Z. 20 | 21 | Lemma adv_ext_0 {A} (e : ExtEnv' A) : adv_ext 0 e = e. 22 | Proof. 23 | apply functional_extensionality. 24 | unfold adv_ext. reflexivity. 25 | Qed. 26 | 27 | Lemma adv_ext_iter {A} d d' (e : ExtEnv' A) : adv_ext d (adv_ext d' e) = adv_ext (d' + d) e. 28 | Proof. 29 | apply functional_extensionality. intro. apply functional_extensionality. induction d'; intros. 30 | - simpl. rewrite adv_ext_0. reflexivity. 31 | - simpl. unfold adv_ext in *. rewrite Z.add_assoc. reflexivity. 32 | - unfold adv_ext. rewrite Z.add_assoc. reflexivity. 33 | Qed. 34 | 35 | Lemma adv_ext_iter' {A} d d' (e : ExtEnv' A) : adv_ext d (adv_ext d' e) = adv_ext (d + d') e. 36 | Proof. 37 | apply functional_extensionality. intro. apply functional_extensionality. destruct d; intros; 38 | unfold adv_ext; f_equal; omega. 39 | Qed. 40 | 41 | Lemma adv_ext_opp {A} d d' (e : ExtEnv' A) : d' + d = 0 -> adv_ext d (adv_ext d' e) = e. 42 | Proof. 43 | intros. rewrite adv_ext_iter. rewrite H. apply adv_ext_0. 44 | Qed. 45 | 46 | 47 | Lemma adv_ext_swap {A} d d' (e : ExtEnv' A) : 48 | adv_ext d (adv_ext d' e) = adv_ext d' (adv_ext d e). 49 | Proof. 50 | repeat rewrite adv_ext_iter. rewrite Z.add_comm. reflexivity. 51 | Qed. 52 | 53 | Lemma adv_ext_step {A} n (ext : ExtEnv' A) : 54 | ((adv_ext (- Z.of_nat (S n)) ext) = (adv_ext (- Z.of_nat n) (adv_ext (-1) ext))). 55 | Proof. 56 | rewrite adv_ext_iter. f_equal. rewrite Nat2Z.inj_succ. omega. 57 | Qed. 58 | 59 | Lemma Zneg_of_succ_nat : forall n, Z.neg (Pos.of_succ_nat n) = (- Z.of_nat (S n))%Z. 60 | Proof. 61 | intros. rewrite <- Pos2Z.opp_pos. rewrite Zpos_P_of_succ_nat. rewrite Nat2Z.inj_succ. reflexivity. 62 | Qed. 63 | 64 | Lemma adv_ext_step' {A} n (ext : ExtEnv' A) : ((adv_ext (Z.neg (Pos.of_succ_nat n)) ext) 65 | = (adv_ext (- Z.of_nat n) (adv_ext (-1) ext))). 66 | Proof. 67 | rewrite Zneg_of_succ_nat. apply adv_ext_step. 68 | Qed. 69 | 70 | 71 | Definition Env' A := list A. 72 | 73 | 74 | Fixpoint lookupEnv {A} (v : Var) (env : Env' A) : option A := 75 | match v, env with 76 | | V1, x::_ => Some x 77 | | VS v, _::xs => lookupEnv v xs 78 | | _,_ => None 79 | end. 80 | -------------------------------------------------------------------------------- /Coq/TranslateExp.v: -------------------------------------------------------------------------------- 1 | (********** Translating Expressions in Time **********) 2 | 3 | (* This module defines the operation [translateExp] on expressions, 4 | which corresponds to the [Translate] constructs on contracts. In 5 | contrast to [Translate], however, [translateExp] works on [Z] instead of 6 | only on [nat]. *) 7 | 8 | Require Import Denotational. 9 | Require Import Tactics. 10 | Require Import Typing. 11 | Require Import FunctionalExtensionality. 12 | 13 | Fixpoint translateExp (d : Z) (e : Exp) : Exp := 14 | match e with 15 | | OpE op args => OpE op (map (translateExp d) args) 16 | | Obs l i => Obs l (d + i) 17 | | VarE a => VarE a 18 | | Acc f n z => Acc (translateExp d f) n (translateExp d z) 19 | end. 20 | 21 | 22 | 23 | Lemma translateExp_ope d op args : translateExp d (OpE op args) = OpE op (map (translateExp d) args). 24 | reflexivity. Qed. 25 | 26 | Ltac rewr_assumption := idtac; match goal with 27 | | [R: _ |- _ ] => rewrite R 28 | end. 29 | 30 | 31 | Lemma translateExp_ext (env : Env) d (e : Exp) ext : 32 | E[|translateExp d e|] env ext = E[|e|] env (adv_ext d ext). 33 | Proof. 34 | generalize dependent ext. generalize dependent env. 35 | induction e using Exp_ind';intros; 36 | try solve [simpl; repeat rewr_assumption; reflexivity]. 37 | rewrite translateExp_ope. simpl. rewrite map_map. 38 | eapply all_apply with (p:= env) in H. 39 | eapply all_apply with (p:= ext) in H. 40 | apply map_rewrite in H. rewrite H. reflexivity. 41 | 42 | generalize dependent ext. generalize dependent env. 43 | simpl. unfold Fsem in *. induction d0; intros. 44 | - simpl. apply IHe2. 45 | - repeat rewrite adv_ext_step. simpl. rewrite IHd0. 46 | repeat rewrite adv_ext_iter. apply bind_equals. 47 | f_equal; try (f_equal; omega). f_equal. 48 | f_equal; try (f_equal;f_equal; omega). do 2 (apply functional_extensionality; intro). 49 | do 3 f_equal. apply functional_extensionality. intros. do 3 f_equal. omega. do 2 f_equal. omega. 50 | intros. rewrite IHe1. 51 | repeat rewrite Zpos_P_of_succ_nat. do 2 f_equal. omega. rewrite <- adv_ext_0. f_equal. 52 | omega. 53 | Qed. 54 | 55 | Open Scope Z. 56 | 57 | Lemma translateExp_ext_opp (env : Env) (d d' : Z) (e : Exp) (ext : ExtEnv): 58 | d' + d = 0 -> E[|translateExp d e|] env (adv_ext d' ext) = E[|e|] env ext. 59 | Proof. 60 | intro H. rewrite translateExp_ext. rewrite adv_ext_opp; auto. 61 | Qed. 62 | 63 | 64 | Lemma translateExp_type g d e t : g |-E e ∶ t -> g |-E translateExp d e ∶ t. 65 | Proof. 66 | intro T. generalize dependent g. generalize dependent t. 67 | induction e using Exp_ind'; intros; simpl; inversion T; subst; auto. 68 | - econstructor. eassumption. eapply all_apply' in H. apply all_zip; eauto. 69 | Qed. 70 | -------------------------------------------------------------------------------- /Haskell/Contract/Environment.hs: -------------------------------------------------------------------------------- 1 | module Contract.Environment 2 | ( MEnv(..), Env -- MEnv constructor for internal use only! 3 | -- operations only on managed environments 4 | , emptyEnv, emptyFrom 5 | , addFix, addFixing, addFixings, fixings 6 | , promote, promoteEnv 7 | ) 8 | where 9 | 10 | import Contract.Date 11 | 12 | -- | An environment is a partial mapping from (String, Int) to Double. The keys carry an identifying string and an offset value (days), yielding a Double value. 13 | type Env = (String,Int) -> Maybe Double -- Hack: should use Bool for choice 14 | 15 | -- not using Data.Map here, infinite domain might be useful (see "Time") 16 | 17 | -- | construct an empty environment. "Time" is always defined 18 | emptyEnv :: Env 19 | emptyEnv ("Time",i) = Just (fromIntegral i) 20 | emptyEnv other = Nothing 21 | 22 | -- ideas: 23 | -- unify :: Env -> Env -> Env 24 | 25 | -- | A managed environment is an environment together with a start date. 26 | data MEnv = Env Date Env 27 | 28 | -- | an empty managed environment, from a given start date 29 | emptyFrom :: Date -> MEnv 30 | emptyFrom d = Env d emptyEnv 31 | 32 | -- | promoting an environment by a given date offset into the future 33 | -- (or past, if negative) 34 | promote :: Env -> Int -> Env 35 | promote e i = e . (\(s,x) -> (s,x+i)) 36 | 37 | -- | promoting a managed environment by a given date offset. See 'promote' 38 | promoteEnv :: MEnv -> Int -> MEnv 39 | promoteEnv (Env d e) i = Env d (promote e i) 40 | 41 | -- | adding a fixing to an environment. 42 | -- New values take precedence with this definition 43 | addFix :: (String, Int, Double) -> Env -> Env 44 | addFix (s,d,r) e = \x -> if x == (s,d) then Just r else e x 45 | 46 | -- | adding a fixing to a managed environment 47 | addFixing :: (String, Date, Double) -> MEnv -> MEnv 48 | addFixing (s,d,r) (Env e_d e_f) = 49 | let off = dateDiff e_d d 50 | in Env e_d (\x -> if x == (s,off) then Just r else e_f x) 51 | 52 | 53 | addFixings :: (String, Date) -> [Double] -> MEnv -> MEnv 54 | addFixings (s,d) [] e = e 55 | addFixings (s,d) vs (Env e_d e_f) = 56 | let l = length vs 57 | o = dateDiff e_d d 58 | f (s',n) = if s == s' && n >= o && n < l + o 59 | then Just (vs!!(n-o)) else e_f (s',n) 60 | in Env e_d f 61 | 62 | fixings :: String -> Date -> [Double] -> MEnv 63 | fixings s d vs = addFixings (s,d) vs (emptyFrom d) 64 | 65 | -- | join two environments (first one takes precedence) 66 | union :: Env -> Env -> Env 67 | union e1 e2 = \obs -> case e1 obs of 68 | Just x -> Just x 69 | Nothing -> e2 obs 70 | 71 | -- | join two managed environments (first one takes precedence) 72 | unionEnv :: MEnv -> MEnv -> MEnv 73 | unionEnv (Env d1 e1) (Env d2 e2) = Env d1 (union e1 e2') 74 | where e2' = promote e2 (dateDiff d2 d1) 75 | -------------------------------------------------------------------------------- /Coq/Extraction/PrettyPrinting.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | Implementation of pretty printing for contracts. 3 | 4 | 5 | module PrettyPrinting where 6 | 7 | import Contract hiding (map) 8 | import Data.Maybe 9 | 10 | instance Show ObsLabel where 11 | show (LabR l) = show l 12 | show (LabB l) = show l 13 | 14 | varName :: Int -> String 15 | varName i = "x"++show i 16 | 17 | ppBool :: Bool -> String 18 | ppBool True = "true" 19 | ppBool False = "false" 20 | 21 | parentheses str = "(" ++ str ++ ")" 22 | 23 | ppBinOp :: String -> String -> String -> String 24 | ppBinOp op e1 e2 = parentheses (e1 ++ " " ++ op ++ " " ++ e2) 25 | 26 | ppUnOp :: String -> String -> String 27 | ppUnOp op e = op ++ " " ++ e 28 | 29 | ppOp :: Op -> [String] -> String 30 | ppOp (BLit b) [] = ppBool b 31 | ppOp (RLit r) [] = show r 32 | ppOp Add [x,y] = ppBinOp "+" x y 33 | ppOp Mult [x,y] = ppBinOp "*" x y 34 | ppOp Sub [x,y] = ppBinOp "-" x y 35 | ppOp Div [x,y] = ppBinOp "/" x y 36 | ppOp And [x,y] = ppBinOp "&&" x y 37 | ppOp Or [x,y] = ppBinOp "||" x y 38 | ppOp Less [x,y] = ppBinOp "<" x y 39 | ppOp Leq [x,y] = ppBinOp "<=" x y 40 | ppOp Equal [x,y] = ppBinOp "==" x y 41 | ppOp Not [x] = ppUnOp "not" x 42 | ppOp Neg [x] = ppUnOp "-" x 43 | ppOp Cond [b,x,y] = "if " ++ b ++ " then " ++ x ++ " else " ++ y 44 | ppOp _ _ = error "pretty printing: expression is illformed" 45 | 46 | ppExp :: Int -> Env' Int -> Exp -> String 47 | ppExp c names e = 48 | case e of 49 | VarE v -> varName (fromJust (lookupEnv v names)) 50 | OpE op args -> ppOp op (map (ppExp c names) args) 51 | Obs l n -> "obs(" ++ show l ++ ", " ++ show n ++ ")" 52 | Acc f l z -> "acc(\\ " ++ varName c ++ " -> " ++ ppExp c' names' f 53 | ++ ", " ++ show l ++ ", " ++ ppExp c names z ++")" 54 | where c' = c + 1 55 | names' = c : names 56 | 57 | 58 | ppContr :: Int -> Env' Int -> Contr -> String 59 | ppContr cur names c = case c of 60 | Zero -> "zero" 61 | Translate l c -> parentheses (show l ++ " ! " ++ ppContr cur names c) 62 | Scale e c -> parentheses (ppExp cur names e ++ " # " ++ ppContr cur names c) 63 | Transfer p1 p2 a -> show a ++ "(" ++ show p1 ++ " -> " ++ show p2 ++ ")" 64 | Both c1 c2 -> parentheses (ppContr cur names c1 ++ " & " ++ ppContr cur names c2) 65 | If b l c1 c2 -> "if " ++ ppExp cur names b ++ within ++ " then " ++ 66 | ppContr cur names c1 ++ " else " ++ ppContr cur names c2 67 | where within = if l == 0 then "" else " within " ++ show l 68 | Let e c -> "let " ++ varName cur ++ " = " ++ ppExp cur names e 69 | ++ " in " ++ ppContr cur' names' c 70 | where cur' = cur + 1 71 | names' = cur : names 72 | -------------------------------------------------------------------------------- /Haskell/Contract.hs: -------------------------------------------------------------------------------- 1 | module Contract 2 | ( Contract -- without constructors 3 | , MContract 4 | , Party 5 | -- smart constructors and convenience functions, defined in Contract.Type 6 | , zero, transfOne, transl, iff, checkWithin, both, allCs, scale, flow, foreach 7 | , ppContr 8 | -- dates: 9 | , Date, DateError, dateDiff, at, addDays, ppDate, ppDays 10 | -- expressions: 11 | , Var, Currency(..) -- all constructors exported 12 | , BoolE, IntE, RealE -- Expr itself is not exported 13 | -- constructors 14 | , i, r, b, v, pair, first, second, acc, obs, chosenBy 15 | -- operators, unless in Num instance 16 | , (! Cashflow -> String 44 | ppCashflow w (d,cur,p1,p2,certain,e) = 45 | unwords [ ppDate d, ppCertain certain, pad w (sq (p1 ++ "->" ++ p2)), 46 | show cur, ppExp (simplifyExp emptyEnv e)] 47 | where sq s = "[" ++ s ++ "]" 48 | pad w s = s ++ replicate (w - length s) ' ' 49 | ppCertain b = if b then "Certain" else "Uncertain" 50 | 51 | -- | print a series of cashflows (no sorting applied here) 52 | ppCashflows :: [Cashflow] -> String 53 | ppCashflows [] = "no cashflows" 54 | ppCashflows l = unlines (map (ppCashflow sz) l) 55 | where sz = maximum $ 56 | map (\(_,_,p1,p2,_,_) -> length p1 + length p2 + 4) l 57 | 58 | -- | extract all (certain and uncertain) cashflows of a contract, sorted by date 59 | cashflows :: (Date, Contract) -> [ Cashflow ] 60 | cashflows (d,c) = sortBy (comparing cfDate) (cf (d, c, 1, True)) 61 | where cfDate (d,_,_,_,_,_) = d 62 | cf (d,c,s,certain) = 63 | case c of 64 | Zero -> [] 65 | TransfOne c p1 p2 -> [(d,c,p1,p2,certain,s)] 66 | Both c1 c2 -> cf (d,c1,s,certain) ++ cf (d,c2,s,certain) 67 | Scale s' c -> cf (d,c,s * s',certain) 68 | Transl i c2 -> cf (addDays i d, c2, s, certain) 69 | If b c1 c2 -> cf (d,c1,s,False) ++ cf (d,c2,s,False) 70 | CheckWithin e i c1 c2 -> 71 | if i < 0 then cf (d,c1,s,False) ++ cf (d,c2,s,False) 72 | else cf (d,c1,s,False) ++ 73 | cf(addDays 1 d, 74 | checkWithin (translExp e 1) (i-1) c1 c2, 75 | s, certain) 76 | -- Let(v,e,c) -> cf (d,c,s,certain) (* MEMO: check this *) 77 | 78 | -- more here? 79 | -------------------------------------------------------------------------------- /SML/CONTRACTSIG.sig: -------------------------------------------------------------------------------- 1 | signature CONTRACTSIG = sig 2 | 3 | (* Expressions *) 4 | type 'a num 5 | type 'a exp 6 | type boolE = bool exp 7 | type intE = int num exp 8 | type realE = real num exp 9 | 10 | val I : int -> intE 11 | val R : real -> realE 12 | val B : bool -> boolE 13 | val !+! : 'a num exp * 'a num exp -> 'a num exp 14 | val !-! : 'a num exp * 'a num exp -> 'a num exp 15 | val !*! : 'a num exp * 'a num exp -> 'a num exp 16 | val max : 'a num exp * 'a num exp -> 'a num exp 17 | val min : 'a num exp * 'a num exp -> 'a num exp 18 | val ! boolE 19 | val !=! : 'a exp * 'a exp -> boolE 20 | val !|! : boolE * boolE -> boolE 21 | val not : boolE -> boolE 22 | val obs : string*int -> 'a exp 23 | val chosenBy : string*int -> boolE 24 | val ifExpr : boolE * 'a exp * 'a exp -> 'a exp 25 | val pair : 'a exp * 'b exp -> ('a*'b) exp 26 | val fst : ('a*'b)exp -> 'a exp 27 | val snd : ('a*'b)exp -> 'b exp 28 | 29 | (* Functions *) 30 | val acc : ('a exp -> 'a exp) * int * 'a exp -> 'a exp 31 | 32 | (* Environments *) 33 | type date = DateUtil.date 34 | type env 35 | type menv 36 | val emptyEnv : env 37 | val addFix : (string * int * real) * env -> env 38 | val emptyFrom : date -> menv 39 | val addFixing : (string * date * real) * menv -> menv 40 | val addFixings : (string * date) -> real list -> menv -> menv 41 | val promoteEnv : menv -> int -> menv 42 | 43 | (* Evaluation *) 44 | val evalR : env -> realE -> real 45 | val evalI : env -> intE -> int 46 | val evalB : env -> boolE -> bool 47 | 48 | (* Expression utilities *) 49 | val certainExp : 'a exp -> bool 50 | val simplifyExp : env -> 'a exp -> 'a exp 51 | val ppExp : 'a exp -> string 52 | val eqExp : 'a exp * 'a exp -> bool 53 | val translExp : 'a exp * int -> 'a exp 54 | val hashExp : string list * 'a exp * IntInf.int -> IntInf.int 55 | 56 | (* Contracts *) 57 | type party = string 58 | type cur = Currency.cur 59 | type contr 60 | val zero : contr 61 | val transfOne : cur * party * party -> contr 62 | val scale : realE * contr -> contr 63 | val transl : int * contr -> contr 64 | val both : contr * contr -> contr 65 | val iff : boolE * contr * contr -> contr 66 | val checkWithin : boolE * int * contr * contr -> contr 67 | val letc : 'a exp * ('a exp -> contr) -> contr 68 | 69 | (* Some derived forms *) 70 | val all : contr list -> contr 71 | val flow : int * realE * cur * party * party -> contr 72 | val dual : contr -> contr 73 | 74 | (* Contract utilities *) 75 | val ppContr : contr -> string 76 | val eqContr : contr * contr -> bool 77 | val horizon : contr -> int 78 | 79 | (* Managed contracts *) 80 | type mcontr = date * contr 81 | val advance : int -> mcontr -> mcontr 82 | val simplify : menv -> mcontr -> mcontr 83 | 84 | type cashflow = date * cur * party * party * bool * realE 85 | val ppCashflows : cashflow list -> string 86 | val cashflows : mcontr -> cashflow list 87 | end 88 | -------------------------------------------------------------------------------- /Coq/Extraction/RebindableEDSL.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE RebindableSyntax #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE IncoherentInstances #-} 8 | 9 | module RebindableEDSL 10 | ( 11 | -- * comparison operators 12 | (<), (<=), (==), (/=), (>), (>=), 13 | -- * Boolean operators 14 | (&&), (||), not, 15 | 16 | -- * do notation 17 | (>>=), 18 | (>>), 19 | wait , 20 | max, 21 | min, 22 | 23 | module P, 24 | ifThenElse, 25 | within, 26 | module EDSL, 27 | ) where 28 | 29 | 30 | import EDSL 31 | import Prelude as P (Int,Integer,error, Num(..), Fractional(..), fail, return, Bool(..), otherwise, Show(..)) 32 | import qualified Prelude 33 | 34 | 35 | infix 4 ==, /=, <, <=, >=, > 36 | infixr 3 && 37 | infixr 2 || 38 | infix 1 `within` 39 | 40 | class Eq a b | a -> b where 41 | (==) :: a -> a -> b 42 | (/=) :: a -> a -> b 43 | 44 | instance ExpHoas exp => Eq (exp R) (exp B) where 45 | (==) = (!=!) 46 | (/=) = (!/=!) 47 | 48 | instance Eq Int Bool where 49 | (==) = (Prelude.==) 50 | (/=) = (Prelude./=) 51 | 52 | class Eq a b => Ord a b | a -> b where 53 | (<),(>=), (>), (<=) :: a -> a -> b 54 | 55 | class Max a where 56 | max,min :: a -> a -> a 57 | 58 | instance ExpHoas exp => Ord (exp R) (exp B) where 59 | (<) = (!) = (!>!) 62 | (>=) = (!>=!) 63 | 64 | instance ExpHoas exp => Max (exp R) where 65 | max x y = if x !) = (Prelude.>) 72 | (>=) = (Prelude.>=) 73 | 74 | instance Prelude.Ord a => Max a where 75 | max = Prelude.max 76 | min = Prelude.min 77 | 78 | class Boolean b where 79 | (&&) :: b -> b -> b 80 | (||) :: b -> b -> b 81 | not :: b -> b 82 | 83 | instance ExpHoas exp => Boolean (exp B) where 84 | (&&) = (!&!) 85 | (||) = (!|!) 86 | not = bNot 87 | 88 | 89 | instance Boolean Bool where 90 | (&&) = (Prelude.&&) 91 | (||) = (Prelude.||) 92 | not = Prelude.not 93 | 94 | 95 | (>>=) :: ContrHoas exp contr => exp t -> (exp t -> contr) -> contr 96 | (>>=) = letc 97 | 98 | newtype Wait = Wait Int 99 | 100 | wait :: Int -> Wait 101 | wait = Wait 102 | 103 | data Within exp = Within (exp B) Int 104 | 105 | within :: ExpHoas exp => exp B -> Int -> Within exp 106 | within = Within 107 | 108 | class IfThenElse b c where 109 | ifThenElse :: b -> c -> c -> c 110 | 111 | instance IfThenElse Bool a where 112 | ifThenElse True x _ = x 113 | ifThenElse False _ y = y 114 | 115 | 116 | instance ExpHoas exp => IfThenElse (exp B) (exp t) where 117 | ifThenElse = ife 118 | 119 | instance ContrHoas exp contr => IfThenElse (exp B) contr where 120 | ifThenElse = iff 121 | 122 | 123 | instance ContrHoas exp contr => IfThenElse (Within exp) contr where 124 | ifThenElse (Within b l) = ifWithin b l 125 | 126 | 127 | (>>) :: ContrHoas exp contr => Wait -> contr -> contr 128 | Wait n >> c = translate n c 129 | -------------------------------------------------------------------------------- /Haskell/CTest.hs: -------------------------------------------------------------------------------- 1 | module CTest where 2 | 3 | import Contract 4 | import Contract.Date 5 | import Contract.Expr(ppReal) 6 | import Contract.Transform(advance, simplify, dual) 7 | 8 | -- simple tests for contracts (was "basiccontracts.sml") 9 | 10 | you2me (d,v,c) = flow d (r v) c "you" "me" 11 | me2you = dual . you2me 12 | 13 | now = 0 14 | today = read "2013-01-01" :: Date 15 | 16 | todayIs = putStrLn ("Today is " ++ ppDate today ++ "\n") 17 | 18 | months n = n*30 19 | years n = n*360 20 | 21 | 22 | report s (d,c) = 23 | do putStrLn "\n---REPORT BEGIN---" 24 | putStrLn ("Today is " ++ ppDate d) 25 | putStrLn (s ++ " - Contract:\n" ++ ppContr c) 26 | putStrLn "Cashflows:" 27 | putStrLn (ppCashflows (cashflows (d,c))) 28 | putStrLn "---REPORT END---" 29 | 30 | -- (* Simple amortized loan *) 31 | ex1 = 32 | let coupon = 11000.0 33 | principal = 30000.0 34 | in allCs [you2me(now,principal,EUR), 35 | me2you(months 1,coupon,EUR), 36 | me2you(months 2,coupon,EUR), 37 | me2you(months 3,coupon,EUR)] 38 | 39 | 40 | -- (* Cross currency swap *) 41 | ex2 = 42 | let coupon_eur = 1000.0 43 | coupon_dkk = 7000.0 44 | in allCs [allCs [me2you(months 0,coupon_dkk,DKK), 45 | me2you(months 1,coupon_dkk,DKK), 46 | me2you(months 2,coupon_dkk,DKK)], 47 | me2you(months 0,coupon_eur,EUR), 48 | me2you(months 1,coupon_eur,EUR), 49 | me2you(months 2,coupon_eur,EUR)] 50 | 51 | ex2m = (today,ex2) 52 | 53 | ex3 = advance 15 ex2m 54 | 55 | -- (* Call option on "Carlsberg" stock *) 56 | equity = "Carlsberg" 57 | maturity = years 1 58 | ex4 = 59 | let strike = 50.0 60 | nominal = 1000.0 61 | theobs = maxx (r 0.0) (obs (equity,0) - r strike) 62 | in scale (r nominal) 63 | (transl maturity 64 | (scale theobs (transfOne EUR "you" "me"))) 65 | 66 | mature s c p = 67 | let m = (today, c) 68 | -- () = report (s ++ " - initial") m 69 | menv0 = emptyFrom today 70 | menv = addFixing (equity, addDays maturity today,p) menv0 71 | m' = simplify menv m 72 | m'' = advance maturity m' 73 | in report (s ++ " - at maturity; price(maturity)=" ++ ppReal p) m'' 74 | 75 | -- (* same call option, expressed with If *) 76 | ex4if = 77 | let strike = 50.0 78 | nominal = 1000.0 79 | theobs = obs (equity,0) 80 | in scale (r nominal) 81 | (transl maturity 82 | (iff (r strike ! Currency -> String 9 | fxRate c1 c2 = "FX " ++ show c1 ++ '/':show c2 10 | 11 | fxForward :: Party -> Party -- ^ buyer, seller 12 | -> (Currency, Currency) -- ^ FX currency pair 13 | -> RealE -> RealE -- ^ amount, strike 14 | -> Int -> Contract -- ^ days to maturity 15 | fxForward buyer seller (buyCur, otherCur) amount strike 0 16 | = scale amount (allCs [ transfOne buyCur seller buyer 17 | , scale strike (transfOne otherCur buyer seller)]) 18 | fxForward buyer seller (buyCur, otherCur) amount strike days 19 | = if days > 0 then 20 | transl days (fxForward buyer seller (buyCur,otherCur) amount strike 0) 21 | else error "fxForward into the past" 22 | 23 | -- some tags for recurring alternatives 24 | data OptionKind = Call | Put 25 | data BarrierKind = Up | Down 26 | 27 | 28 | -- vanilla options (explicit choice, not readily settled) 29 | vanillaFx :: OptionKind -> Party -> Party 30 | -> (Currency, Currency) 31 | -> RealE -> RealE 32 | -> Int -> Contract 33 | vanillaFx Call buyer seller (buyCur, otherCur) amount strike expiry 34 | = transl expiry 35 | (iff cond 36 | (fxForward buyer seller (buyCur, otherCur) amount strike 0) 37 | zero) 38 | where cond = chosenBy (buyer ++ ":Call",0) 39 | -- strike ! Party -> Currency -- ^ parties, settling currency 52 | -> RealE -> (Currency,Currency) -- ^ amount, FX cross 53 | -> RealE -> BarrierKind -> Int -- ^ barrier, direction, expiry 54 | -> Contract 55 | fxTouch buyer seller curSettle amount (cur1,cur2) barrier kind expiry 56 | = checkWithin cond expiry 57 | (scale amount (transfOne curSettle buyer seller)) 58 | zero 59 | where cond = case kind of 60 | -- including == case: 61 | Up -> nott (obs (rate,0) ! nott (barrier ! Party -> Currency -- ^ parties, settling currency 67 | -> RealE -> (Currency,Currency) -- ^ amount, FX cross 68 | -> RealE -> BarrierKind -> Int -- ^ barrier, direction, expiry 69 | -> Contract 70 | fxNoTouch buyer seller curSettle amount (cur1,cur2) barrier kind expiry 71 | = checkWithin cond expiry 72 | zero 73 | (scale amount (transfOne curSettle buyer seller)) 74 | where rate = fxRate cur1 cur2 75 | cond = case kind of 76 | -- including == case: 77 | Up -> nott (obs (rate,0) ! nott (barrier ! Asset -> bool. 16 | Axiom eqb_eq : forall x y, eqb x y = true <-> x = y. 17 | 18 | Lemma eqb_refl p: eqb p p = true. 19 | Proof. 20 | assert (p = p) as E by reflexivity. rewrite <- eqb_eq in E. auto. 21 | Qed. 22 | 23 | End Asset. 24 | 25 | Module Party. 26 | Parameter eqb : Party -> Party -> bool. 27 | Axiom eqb_eq : forall x y, eqb x y = true <-> x = y. 28 | Lemma eqb_refl p: eqb p p = true. 29 | Proof. 30 | assert (p = p) as E by reflexivity. rewrite <- eqb_eq in E. auto. 31 | Qed. 32 | 33 | End Party. 34 | 35 | (* We also keep the types for Boolean and real observable labels 36 | abstract. *) 37 | 38 | Parameter BoolObs : Set. 39 | Parameter RealObs : Set. 40 | 41 | 42 | (* The type of variables. *) 43 | 44 | Inductive Var : Set := V1 | VS (v:Var). 45 | 46 | (* The type of labels that describe external observables. *) 47 | 48 | Inductive ObsLabel : Set := LabR (l:RealObs) | LabB (l:BoolObs). 49 | 50 | (* The type of operations that may be used in expressions. *) 51 | 52 | Inductive Op : Set := Add | Sub | Mult | Div | And | Or | Less | Leq | Equal | 53 | Not | Neg | 54 | BLit (b : bool) | RLit (r:R) | 55 | Cond. 56 | 57 | (* The type of expressions. *) 58 | 59 | Inductive Exp : Set := OpE (op : Op) (args : list Exp) 60 | | Obs (l:ObsLabel) (i: Z) 61 | | VarE (v:Var) 62 | | Acc (f : Exp) (d : nat) (e : Exp). 63 | 64 | 65 | (* We need to define a custom induction principle for expressions. The 66 | automatically generated induction principle is too weak. *) 67 | 68 | Definition Exp_ind' : forall P : Exp -> Prop, 69 | (forall (op : Op) (args : list Exp), all P args -> P (OpE op args)) -> 70 | (forall (l : ObsLabel) (i : Z), P (Obs l i)) -> 71 | (forall v : Var, P (VarE v)) -> 72 | (forall f2 : Exp, 73 | P f2 -> forall (d : nat) (e : Exp), P e -> P (Acc f2 d e)) -> 74 | forall e : Exp, P e := 75 | fun (P : Exp -> Prop) 76 | (f : forall (op : Op) (args : list Exp), all P args -> P (OpE op args)) 77 | (f0 : forall (l : ObsLabel) (i : Z), P (Obs l i)) 78 | (f1 : forall v : Var, P (VarE v)) 79 | (f2 : forall f2 : Exp, 80 | P f2 -> forall (d : nat) (e : Exp), P e -> P (Acc f2 d e)) => 81 | fix F (e : Exp) : P e := 82 | match e as e0 return (P e0) with 83 | | OpE op args => let fix step es : all P es := 84 | match es with 85 | | nil => forall_nil P 86 | | e' :: es' => forall_cons P (F e') (step es') 87 | end 88 | in f op args (step args) 89 | | Obs l i => f0 l i 90 | | VarE v => f1 v 91 | | Acc f3 d e0 => f2 f3 (F f3) d e0 (F e0) 92 | end. 93 | 94 | (* This type defines the syntax of the contract language *) 95 | 96 | Inductive Contr : Type := 97 | | Zero : Contr 98 | | Let : Exp -> Contr -> Contr 99 | | Transfer : Party -> Party -> Asset -> Contr 100 | | Scale : Exp -> Contr -> Contr 101 | | Translate : nat -> Contr -> Contr 102 | | Both : Contr -> Contr -> Contr 103 | | If : Exp -> nat -> Contr -> Contr -> Contr. 104 | -------------------------------------------------------------------------------- /SML/test/expr.sml: -------------------------------------------------------------------------------- 1 | 2 | infix 7 !*! 3 | infix 6 !+! !-! 4 | infix 5 !|! 5 | infix 4 !=! ! 11 | let val e = f() 12 | in simplifyExp E e 13 | end) 14 | 15 | fun etest s e f = etestE s e f emptyEnv 16 | 17 | val () = etest "test !+! - i" (I 4) (fn () => I 3 !+! I 1) 18 | val () = etest "test !+! - r" (R 4.0) (fn () => R 3.0 !+! R 1.0) 19 | 20 | val () = etest "test !-! - i" (I 4) (fn () => I 5 !-! I 1) 21 | val () = etest "test !-! - r" (R 4.0) (fn () => R 5.0 !-! R 1.0) 22 | 23 | val () = etest "test !*! - i" (I 6) (fn () => I 3 !*! I 2) 24 | val () = etest "test !*! - r" (R 6.0) (fn () => R 3.0 !*! R 2.0) 25 | 26 | val () = etest "test ! R 2.0 ! I 2 ! R 4.0 ! R 3.0 ! I 4 ! I 3 ! I 4 !=! I 4) 34 | val () = etest "test !=! - if" (B false) (fn () => I 4 !=! I 3) 35 | val () = etest "test !=! - rt" (B true) (fn () => R 4.0 !=! R 4.0) 36 | val () = etest "test !=! - rf" (B false) (fn () => R 4.0 !=! R 3.0) 37 | val () = etest "test !=! - bt" (B true) (fn () => B true !=! B true) 38 | val () = etest "test !=! - bf" (B false) (fn () => B true !=! B false) 39 | 40 | val () = etest "test max - rfst" (R 45.0) (fn () => max(R 45.0, R 34.0)) 41 | val () = etest "test max - rsnd" (R 45.0) (fn () => max(R 21.0, R 45.0)) 42 | val () = etest "test min - rfst" (R 34.0) (fn () => min(R 45.0, R 34.0)) 43 | val () = etest "test min - rsnd" (R 21.0) (fn () => min(R 21.0, R 45.0)) 44 | val () = etest "test max - ifst" (I 45) (fn () => max(I 45, I 34)) 45 | val () = etest "test max - isnd" (I 45) (fn () => max(I 21, I 45)) 46 | val () = etest "test min - ifst" (I 34) (fn () => min(I 45, I 34)) 47 | val () = etest "test min - isnd" (I 21) (fn () => min(I 21, I 45)) 48 | 49 | val () = etest "test !|! - t" (B true) (fn () => B true !|! B true) 50 | val () = etest "test !|! - tfst" (B true) (fn () => B true !|! B false) 51 | val () = etest "test !|! - tsnd" (B true) (fn () => B false !|! B true) 52 | val () = etest "test !|! - f" (B false) (fn () => B false !|! B false) 53 | 54 | val () = etest "test not - t" (B true) (fn () => not(B false)) 55 | val () = etest "test not - f" (B false) (fn () => not(B true)) 56 | 57 | val () = etest "test iff - t" (I 34) (fn () => ifExpr(B true,I 33 !+! I 1, I 22)) 58 | val () = etest "test iff - f" (I 22) (fn () => ifExpr(not(B true),I 33 !+! I 1, I 22)) 59 | 60 | val () = etest "test pair" (I 34) (fn () => snd(fst(pair(pair(I 23,I 34),R 32.0)))) 61 | 62 | fun f v = v !+! I 1 63 | 64 | val () = etest "test acc - i0" (I 44) (fn () => acc(f,0,I 44)) 65 | val () = etest "test acc - i3" (I 4) (fn () => acc(f,3,I 1)) 66 | 67 | fun f x = pair(fst x !+! obs("C",0), 68 | snd x !+! I 1) 69 | 70 | val E = foldl(fn ((i,r),e) => addFix(("C",i,r),e)) emptyEnv [(0,1.0),(1,2.0),(2,3.0),(3,4.0),(4,5.0)] 71 | val () = etestE "test acc - avg" (pair(R 15.0,I 5)) (fn () => acc(f,5,pair(R 0.0,I 0))) E 72 | 73 | val E' = foldl(fn ((i,r),e) => addFix(("C",i,r),e)) emptyEnv [(0,1.0),(1,2.0),(2,3.0),(3,4.0)] 74 | val () = etestE "test acc - avg2" (pair(R 10.0 !+! obs("C",4),I 5)) (fn () => acc(f,5,pair(R 0.0,I 0))) E' 75 | 76 | fun carl n = (obs ("Carlsberg",0) ! h (I 3)) 81 | val () = Utest.testPP IntInf.toString "hashExp2" 8 (fn () => h (carl 1.0)) 82 | val () = Utest.testPP IntInf.toString "hashExp2" 8 (fn () => h (carl 0.0)) 83 | 84 | -------------------------------------------------------------------------------- /Coq/Antisymmetry.v: -------------------------------------------------------------------------------- 1 | (********** Antisymmetry of the denotational semantics **********) 2 | 3 | Require Import Denotational. 4 | Require Import Tactics. 5 | 6 | Definition antisym (t : Trans) : Prop := forall p1 p2 c, t p1 p2 c = - t p2 p1 c. 7 | Definition antisym_trace (t : Trace) : Prop := forall i, antisym (t i). 8 | Definition antisym_trace' (t : Env -> ExtEnv -> option Trace) : Prop := 9 | forall env ext t', t env ext = Some t' -> antisym_trace t'. 10 | 11 | 12 | Hint Resolve Ropp_0 Ropp_involutive. 13 | 14 | Lemma empty_trans_antisym : antisym empty_trans. 15 | Proof. 16 | unfold antisym, empty_trans. auto. 17 | Qed. 18 | 19 | 20 | Lemma const_trace_antisym t : antisym t -> antisym_trace (const_trace t). 21 | Proof. 22 | unfold antisym_trace. auto. 23 | Qed. 24 | 25 | 26 | Lemma singleton_trans_antisym p1 p2 c r : antisym (singleton_trans p1 p2 c r). 27 | Proof. 28 | unfold antisym, singleton_trans. 29 | intros. remember (Party.eqb p1 p2) as E0. 30 | destruct E0. auto. 31 | remember (Party.eqb p1 p0 && Party.eqb p2 p3 && Asset.eqb c c0) as E1. destruct E1. 32 | symmetry in HeqE1. repeat rewrite Bool.andb_true_iff in *. repeat rewrite Party.eqb_eq in *. 33 | rewrite Asset.eqb_eq in *. 34 | decompose [and] HeqE1. remember (Party.eqb p1 p3 && Party.eqb p2 p0 && Asset.eqb c c0) as E2. destruct E2. 35 | symmetry in HeqE2. repeat rewrite Bool.andb_true_iff in *. repeat rewrite Party.eqb_eq in *. 36 | rewrite Asset.eqb_eq in *. 37 | decompose [and] HeqE2. assert (p1 = p2) by (subst; auto). 38 | rewrite <- Party.eqb_eq in H4. tryfalse. 39 | simpl. auto. destruct (Party.eqb p1 p3 && Party.eqb p2 p0 && Asset.eqb c c0); auto. 40 | Qed. 41 | 42 | Lemma singleton_trace_antisym p1 p2 c r : antisym_trace (singleton_trace (singleton_trans p1 p2 c r)). 43 | Proof. 44 | unfold antisym_trace, singleton_trace. intros. destruct i. 45 | apply singleton_trans_antisym. apply empty_trans_antisym. 46 | Qed. 47 | 48 | 49 | Lemma scale_trans_antisym r t : antisym t -> antisym (scale_trans r t). 50 | Proof. 51 | unfold antisym, scale_trans. intros. rewrite H. apply Ropp_mult_distr_l_reverse. 52 | Qed. 53 | 54 | 55 | Lemma scale_trace_antisym r t : antisym_trace t -> antisym_trace (scale_trace r t). 56 | Proof. 57 | unfold antisym_trace, scale_trace, compose. intros. apply scale_trans_antisym. apply H. 58 | Qed. 59 | 60 | 61 | Lemma add_trans_antisym t1 t2: antisym t1 -> antisym t2 -> antisym (add_trans t1 t2). 62 | Proof. 63 | unfold antisym, add_trans. intros. rewrite H. rewrite H0. rewrite Ropp_plus_distr. reflexivity. 64 | Qed. 65 | 66 | 67 | Lemma add_trace_antisym t1 t2: antisym_trace t1 -> antisym_trace t2 -> antisym_trace (add_trace t1 t2). 68 | Proof. 69 | unfold antisym_trace, add_trace. intros. apply add_trans_antisym; auto. 70 | Qed. 71 | 72 | Lemma delay_trace_antisym d t : antisym_trace t -> antisym_trace (delay_trace d t). 73 | Proof. 74 | unfold antisym_trace, delay_trace. intros. destruct (leb d i). 75 | apply H. apply empty_trans_antisym. 76 | Qed. 77 | 78 | 79 | 80 | Hint Resolve const_trace_antisym add_trace_antisym delay_trace_antisym 81 | scale_trace_antisym singleton_trace_antisym empty_trans_antisym. 82 | 83 | Lemma within_trace_antisym t1 t2 b n : antisym_trace' t1 -> antisym_trace' t2 -> 84 | antisym_trace' (within_sem t1 t2 b n). 85 | Proof. 86 | intros T1 T2. intros. induction n; unfold antisym_trace'; intros; simpl in *; 87 | destruct (E[|b|]env ext); try destruct v; try destruct b0; eauto;tryfalse. 88 | apply liftM_some in H. decompose [ex and] H. subst. apply delay_trace_antisym. 89 | eauto. 90 | Qed. 91 | 92 | Hint Resolve within_trace_antisym. 93 | 94 | 95 | Theorem sem_antisym c : antisym_trace' (C[| c |]). 96 | Proof. 97 | 98 | induction c; try solve[unfold antisym_trace'; intros; simpl in *; 99 | first[progress option_inv_auto| inversion H]; subst; unfold empty_trace; eauto]. 100 | 101 | simpl. apply within_trace_antisym; auto. 102 | Qed. -------------------------------------------------------------------------------- /Coq/Horizon.v: -------------------------------------------------------------------------------- 1 | Require Import Denotational. 2 | Require Import Tactics. 3 | Require Import DenotationalTyped. 4 | 5 | (* Definition of contract horizon and proof of its correctness. *) 6 | 7 | (* Behaves as addition unless second argument is 0, in which case 0 is 8 | returned. *) 9 | 10 | Definition plus0 (n m : nat) : nat := 11 | match m with 12 | | 0 => 0 13 | | _ => n + m 14 | end. 15 | 16 | Lemma plus0_max_l n m p i : plus0 p (max n m) <= i -> n <= i. 17 | Proof. 18 | remember (max n m) as h. destruct h. destruct n. simpl. auto. 19 | simpl in *. destruct m;tryfalse. 20 | simpl. rewrite Heqh. intros. assert (max n m <= i) by omega. eapply Max.max_lub_l. eauto. 21 | Qed. 22 | 23 | Lemma plus0_max_r n m p i : plus0 p (max n m) <= i -> m <= i. 24 | Proof. 25 | rewrite Max.max_comm. apply plus0_max_l. 26 | Qed. 27 | 28 | Lemma plus0_le n m i : plus0 (S n) m <= i -> plus0 n m <= i - 1. 29 | Proof. 30 | destruct m. simpl. intros. omega. 31 | simpl. intros. omega. 32 | Qed. 33 | 34 | 35 | Fixpoint horizon (c : Contr) : nat := 36 | match c with 37 | | Zero => 0 38 | | Let _ c' => horizon c' 39 | | Transfer _ _ _ => 1 40 | | Scale _ c' => horizon c' 41 | | Translate l c' => plus0 l (horizon c') 42 | | Both c1 c2 => max (horizon c1) (horizon c2) 43 | | If _ l c1 c2 => plus0 l (max (horizon c1) (horizon c2)) 44 | end. 45 | 46 | 47 | Lemma max0 n m : max n m = 0 -> n = 0 /\ m = 0. 48 | Proof. 49 | intros. split. 50 | - destruct n. reflexivity. destruct m; simpl in H; inversion H. 51 | - destruct m. reflexivity. destruct n; simpl in H; inversion H. 52 | Qed. 53 | 54 | 55 | Theorem horizon_sound c env ext i t : horizon c <= i -> 56 | C[|c|] env ext = Some t -> t i = empty_trans. 57 | 58 | Proof. 59 | intros HO T. generalize dependent env. generalize dependent ext. generalize dependent t. 60 | generalize dependent i. 61 | induction c; simpl in *;intros. 62 | - inversion T. reflexivity. 63 | - destruct (E[|e|] env ext);tryfalse. simpl in T. eapply IHc. assumption. eapply T. 64 | - destruct i. inversion HO. inversion T. reflexivity. 65 | - remember (E[|e|] env ext >>= toReal) as r. remember (C[|c|] env ext) as C. 66 | destruct r;destruct C; tryfalse. simpl in T. unfold pure, compose in *. inversion T. 67 | symmetry in HeqC. eapply IHc with (i:=i) in HeqC ; auto. unfold scale_trace, compose. 68 | rewrite HeqC. apply scale_empty_trans. 69 | - remember (C[|c|] env (adv_ext (Z.of_nat n) ext)) as C. destruct C;tryfalse. 70 | simpl in T. unfold pure,compose in T. inversion T. clear T. unfold delay_trace. 71 | remember (horizon c) as h. destruct h. 72 | destruct (leb n i). eapply IHc. omega. eauto. reflexivity. 73 | simpl in HO. assert (horizon c <= i - n) as H' by omega. 74 | rewrite Heqh in *. eapply IHc in H'. 75 | unfold delay_trace. assert (leb n i = true) as L. apply leb_correct. omega. rewrite L. 76 | destruct H'; eauto. eauto. 77 | - rewrite NPeano.Nat.max_lub_iff in HO. destruct HO as [H1 H2]. 78 | remember (C[|c1|] env ext) as C1. remember (C[|c2|] env ext) as C2. 79 | destruct C1; destruct C2; tryfalse. 80 | simpl in T. unfold pure, compose in T. inversion T. 81 | unfold add_trace. erewrite IHc1;eauto. erewrite IHc2;eauto. 82 | - generalize dependent ext. generalize dependent i. generalize dependent t. induction n;intros. 83 | + simpl in HO. simpl in T. destruct (E[|e|] env ext);tryfalse. destruct v;tryfalse. 84 | destruct b. eapply IHc1; eauto. eapply plus0_max_l; eauto. 85 | eapply IHc2; eauto. eapply plus0_max_r; eauto. 86 | + simpl in HO. simpl in T. destruct (E[|e|] env ext);tryfalse. destruct v;tryfalse. 87 | destruct b. eapply IHc1; eauto. eapply plus0_max_l; eauto. 88 | remember (within_sem C[|c1|] C[|c2|] e n env (adv_ext 1 ext)) as C. destruct C;tryfalse. 89 | simpl in T. unfold pure, compose in T. inversion T. clear T. 90 | symmetry in HeqC. eapply IHn in HeqC. unfold delay_trace. destruct (leb 1 i). 91 | apply HeqC. reflexivity. apply plus0_le. assumption. 92 | Qed. 93 | -------------------------------------------------------------------------------- /Haskell/LexifiContracts.hs: -------------------------------------------------------------------------------- 1 | -- contracts from Lexifi, used with the generic pricing engine 2 | 3 | module LexifiContracts 4 | where 5 | 6 | -- MEMO: clean up imports and exports of umbrella file "Contract.hs" 7 | import Contract 8 | import Contract.Expr 9 | 10 | -- European option on DJ_Eurostoxx_50, starting 11 | european :: MContract 12 | european = (start, -- 2011-12-09 13 | transl duration -- on 2012-11-30 14 | (scale (maxx 0 (obs (idx,0) - strike)) 15 | (transfOne EUR "them" "us"))) 16 | where start = at "2011-12-09" :: Date 17 | duration = dateDiff start (at "2012-11-30") 18 | -- MEMO this fct. should be called "daysBetween" 19 | idx = "DJ_Eurostoxx_50" 20 | strike = 4000 21 | 22 | -- worst-off contract on five fixed dates (chain of iff) 23 | worstOff :: MContract 24 | worstOff = (start, foldr mkDateCheck endCase (zip dDiffs premiums)) 25 | where start = at "2012-01-27" 26 | dates = map (\s -> at (show s ++ "-01-27")) [2013..2017] 27 | dDiffs = zipWith dateDiff (start:dates) dates 28 | premiums = [1150.0, 1300.0, 1450.0, 1600.0, 1750] 29 | -- on the five dates (offset): one below initial spot => pay premium 30 | mkDateCheck (offset, premium) cont 31 | = transl offset $ iff barrier (collectEUR premium) cont 32 | barrier = nott (foldl1 minn (zipWith mkDiff idxs spots) ! and >= as smart constructors 34 | mkDiff idx spot = obs (idx, 0) - spot 35 | -- MEMO we should have RealE division. 36 | idxs = [ "DJ_Eurostoxx_50", "Nikkei_225", "SP_500" ] 37 | spots = [ 3758.05, 11840, 1200 ] 38 | -- if end (date 5) reached: pay 1000 if all above 0.75, 39 | -- otherwise pay the fraction of the worst (HOW? no division) 40 | endCase = iff (allAbove 0.75) (collectEUR 1000) 41 | (collectEUR (1000 * minRatio)) 42 | minRatio = foldl1 minn 43 | (zipWith (\id sp -> obs(id,0) / sp) idxs spots) 44 | allAbove d = nott (foldl1 (!|!) 45 | (zipWith (fractionSmaller d) idxs spots)) 46 | {- 0.75 < minimum [ obs(id,0) / sp | (id, sp) <- zip idxs spots ] 47 | <==> 48 | and [ 0.75 * sp ! 50 | not (or [obs(id, 0) ! obs(id,0) / sp) idxs spots) 71 | -- barrier check is accumulated (MEMO: does !|! shortcut evaluation?) 72 | breached = acc (\x -> x !|! oneBelow 0.7) 366 (oneBelow 0.7) 73 | -- now till day 367 74 | collectEUR amount = scale amount (transfOne EUR "them" "us") 75 | -- same indexes, spot prices, helpers as in contract above 76 | 77 | -------------------------------------------------------------------------------- /Haskell/ETest.hs: -------------------------------------------------------------------------------- 1 | module ETest 2 | where 3 | 4 | import Contract.Expr 5 | import Contract.ExprIO 6 | import Contract.Environment 7 | 8 | import qualified Control.Exception as E 9 | 10 | file :: String 11 | file = "ETest.hs" 12 | 13 | testPP :: (a -> String) -> String -> a -> a -> IO () 14 | testPP pp s e1 e2 = let pr msg = putStrLn (file ++ " - " ++ s ++ ": " ++ msg) 15 | pp1 = pp e1 16 | pp2 = pp e2 17 | in E.catch (if pp1 == pp2 then pr ": OK" 18 | else pr (": ERROR, expected " ++ pp1 19 | ++ ", got " ++ pp2)) 20 | (\e -> pr ("EXN, " ++ show (e::E.SomeException))) 21 | 22 | etestE :: String -> Expr a -> Expr a -> Env -> IO () 23 | etestE s e1 e2 env = testPP ppExp s e1 (simplifyExp env e2) 24 | 25 | etest s e1 e2 = etestE s e1 e2 emptyEnv 26 | 27 | 28 | runtests = do etest "test + - i" (i 4) (i 3 + 1) 29 | etest "test + - r" (r 4.0) (r 3.0 + 1) 30 | 31 | etest "test - - i" (i 4) (5 - 1) 32 | etest "test - - r" (r 4.0) (5 - 1) 33 | 34 | etest "test * - i" (i 6) (3 * 2) 35 | etest "test * - r" (r 6.0) (3 * r 2.0) 36 | 37 | etest "test ! ifExpr(B true,I 33 !+! I 1, I 22)) 74 | etest "test iff - f" (I 22) (fn () => ifExpr(not(B true),I 33 !+! I 1, I 22)) 75 | -} 76 | 77 | testPP show "test hash1 - should fail" (hashExp [] (carl 1) 1) (hashExp [] (carl 1) 0) 78 | 79 | carl n = (Obs ("Carlsberg",0) ! addFix ("C",i,r) e) emptyEnv 89 | [(0,1.0),(1,2.0),(2,3.0),(3,4.0),(4,5.0)] 90 | -- cnt :: Expr (Double,Int) -> Expr (Double,Int) 91 | cnt x = pair (first x + obs("C",0)) (second x + 1) 92 | 93 | main = runtests 94 | -------------------------------------------------------------------------------- /Coq/Extraction/Extraction.v: -------------------------------------------------------------------------------- 1 | Add LoadPath "..". 2 | 3 | Require Import Denotational. 4 | Require Import Reduction. 5 | Require Import Horizon. 6 | Require Import Specialise. 7 | Require Import TimedTyping. 8 | 9 | 10 | 11 | Extraction Language Haskell. 12 | 13 | Extract Inductive unit => "()" [ "()" ]. 14 | Extract Inductive bool => "Bool" [ "True" "False" ]. 15 | Extract Inductive sumbool => "Bool" [ "True" "False" ]. 16 | Extract Inlined Constant orb => "(||)". 17 | Extract Inlined Constant andb => "(&&)". 18 | 19 | Extract Inlined Constant compose => "(.)". 20 | Extract Inductive list => "List" [ "[]" "(:)" ]. 21 | Extract Inlined Constant map => "P.map". 22 | Extract Inlined Constant fold_right => "foldr". 23 | 24 | Extract Inductive nat => "Int" ["0" "succ"] "(\fO fS n -> if n==0 then fO () else fS (n-1))". 25 | Extract Inductive Z => "Int" ["0" "id" "negate"]. 26 | Extract Inductive positive => "Int" ["unused" "unused" "1"]. 27 | 28 | Extract Inlined Constant Z.leb => "(<=)". 29 | Extract Inlined Constant Z.ltb => "(<)". 30 | Extract Inlined Constant Z.add => "(+)". 31 | Extract Inlined Constant Z.sub => "(-)". 32 | Extract Inlined Constant Z.mul => "(*)". 33 | Extract Inlined Constant Z.opp => "negate". 34 | Extract Inlined Constant Z.max => "max". 35 | Extract Inlined Constant Z.min => "min". 36 | 37 | Extract Inlined Constant R => "Double". 38 | Extract Inlined Constant Rleb => "(<=)". 39 | Extract Inlined Constant Reqb => "(==)". 40 | Extract Inlined Constant Req_dec => "(==)". 41 | Extract Inlined Constant Rltb => "(<)". 42 | Extract Inlined Constant Rplus => "(+)". 43 | Extract Inlined Constant Rminus => "(-)". 44 | Extract Inlined Constant Rmult => "(*)". 45 | Extract Inlined Constant Rdiv => "(/)". 46 | Extract Inlined Constant Ropp => "negate". 47 | Extract Inlined Constant R1 => "1". 48 | Extract Inlined Constant R0 => "0". 49 | 50 | 51 | Extract Inlined Constant negb => "not". 52 | Extract Inlined Constant Z.eqb => "(==)". 53 | 54 | 55 | Extract Inductive prod => "(,)" [ "(,)" ]. 56 | Extract Inlined Constant fst => "fst". 57 | Extract Inlined Constant snd => "snd". 58 | 59 | Extract Inlined Constant plus => "(+)". 60 | Extract Inlined Constant minus => "(-)". 61 | Extract Inlined Constant max => "max". 62 | Extract Inlined Constant Z.of_nat => "id". 63 | Extract Inlined Constant Z.to_nat => "id". 64 | 65 | Extract Inductive option => "Maybe" [ "Just" "Nothing" ]. 66 | Extract Constant option_rect => "flip maybe". 67 | Extraction Inline option_rect option_rec. 68 | Extract Inlined Constant bind => "(>>=)". 69 | Extract Inlined Constant liftM => "liftM". 70 | Extract Inlined Constant liftM2 => "liftM2". 71 | Extract Inlined Constant liftM3 => "liftM3". 72 | Extract Inlined Constant pure => "return". 73 | Extract Inlined Constant sequence => "sequence". 74 | Extract Inlined Constant mapM => "mapM". 75 | Extract Inlined Constant default => "fromMaybe". 76 | 77 | 78 | 79 | Extract Inductive sum => "Either" ["Left" "Right"]. 80 | 81 | Extract Inlined Constant Asset => "Asset". 82 | Extract Inlined Constant Party => "Party". 83 | Extract Inlined Constant BoolObs => "BoolObs". 84 | Extract Inlined Constant RealObs => "RealObs". 85 | 86 | Extract Inlined Constant Asset.eqb => "(==)". 87 | Extract Inlined Constant Party.eqb => "(==)". 88 | 89 | Extract Inlined Constant FMap.FMap => "FMap". 90 | Extract Inlined Constant FMap.empty => "Map.empty". 91 | Extract Inlined Constant FMap.add => "Map.insert". 92 | Extract Inlined Constant FMap.find => "Map.lookup". 93 | Extract Inlined Constant FMap.is_empty => "Map.null". 94 | Extract Inlined Constant FMap.map => "Map.map". 95 | Extract Inlined Constant FMap.union_with => "unionWith". 96 | 97 | (* Coq extracts [SMap_rec] and [SMap.SMap_rect], even though they are 98 | not used. The inlining commands below prevent that. *) 99 | 100 | Extract Inlined Constant SMap.SMap_rec => "unused". 101 | Extract Inlined Constant SMap.SMap_rect => "unused". 102 | 103 | 104 | Extract Inlined Constant compare => "compare". 105 | 106 | Extract Inductive comparison => "Ordering" [ "EQ" "LT" "GT"]. 107 | 108 | Extraction "ContractExtracted.hs" 109 | lookupEnv 110 | Contr 111 | horizon 112 | redfun 113 | specialise 114 | has_type. -------------------------------------------------------------------------------- /SML/test/basiccontracts.sml: -------------------------------------------------------------------------------- 1 | structure test = struct 2 | 3 | open Currency ContractSafe 4 | infix !+! !-! !*! ! real) 114 | (FX: currency * real -> real) t = 115 | let val flows = cashflows0 noE t 116 | in List.foldl (fn ((d,cur,_,_,v,_),acc) => 117 | acc + FX(cur,discount d0 d v (R cur))) 118 | 0.0 flows 119 | end 120 | end 121 | 122 | fun FX(EUR,v) = 7.0 * v 123 | | FX(DKK,v) = v 124 | fun R EUR = 0.04 125 | | R DKK = 0.05 126 | 127 | val p1 = FlatRate.price (?"2011-01-01") R FX ex1 128 | val p2 = FlatRate.price (?"2011-01-01") R FX ex2 129 | 130 | val _ = println("\nPrice(ex1) : DKK " ^ ppReal p1) 131 | val _ = println("\nPrice(ex2) : DKK " ^ ppReal p2) 132 | *) 133 | end 134 | -------------------------------------------------------------------------------- /Coq/Extraction/HOAS.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FunctionalDependencies #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | 6 | -- | This module exports the internal expression and contract 7 | -- representation for constructing de Bruijn index encodings using a 8 | -- HOAS interface. 9 | 10 | module HOAS where 11 | 12 | 13 | import Contract hiding (Exp,Contr,map) 14 | import qualified Contract as C 15 | import PrettyPrinting 16 | 17 | instance Show C.Contr where 18 | show = ppContr 0 [] 19 | 20 | instance Show C.Exp where 21 | show = ppExp 0 [] 22 | 23 | toVar :: Int -> Var 24 | toVar 0 = V1 25 | toVar n = VS (toVar (n-1)) 26 | 27 | data R 28 | data B 29 | 30 | class ExpHoas' exp where 31 | ife :: exp B -> exp t -> exp t -> exp t 32 | opE :: Op -> [exp t'] -> exp t 33 | obs :: ObsLabel -> Int -> exp t 34 | acc :: (exp t -> exp t) -> Int -> exp t -> exp t 35 | 36 | newtype DB t = DB {unDB :: Int -> C.Exp} 37 | 38 | instance ExpHoas' DB where 39 | ife b e1 e2 = DB (\ i -> OpE Cond [unDB b i, unDB e1 i, unDB e2 i]) 40 | opE op args = DB (\ i -> OpE op (map (($ i) . unDB) args)) 41 | obs l t = DB (\_ -> Obs l t) 42 | acc f t e = DB (\i -> let v = \ j -> VarE (toVar (j-(i+1))) 43 | in Acc (unDB (f (DB v)) (i+1)) t (unDB e i)) 44 | 45 | 46 | rLit :: Double -> RExp 47 | rLit r = opE (RLit r) [] 48 | 49 | instance Num (DB R) where 50 | x + y = opE Add [x,y] 51 | x * y = opE Mult [x,y] 52 | x - y = opE Sub [x,y] 53 | abs x = ife (x !! 0) 1 0) 55 | fromInteger i = rLit (fromInteger i) 56 | 57 | instance Fractional (DB R) where 58 | fromRational r = rLit (fromRational r) 59 | x / y = opE Div [x,y] 60 | 61 | 62 | 63 | class (Num (exp R), Fractional (exp R), ExpHoas' exp) => ExpHoas exp 64 | 65 | instance ExpHoas DB 66 | 67 | type Exp t = forall exp . ExpHoas exp => exp t 68 | 69 | 70 | rObs :: ExpHoas exp => RealObs -> Int -> exp R 71 | rObs l i = obs (LabR l) i 72 | 73 | type RExp = Exp R 74 | type BExp = Exp B 75 | 76 | (!=!) :: ExpHoas exp => exp R -> exp R -> exp B 77 | x !=! y = opE Equal [x, y] 78 | 79 | (!/=!) :: ExpHoas exp => exp R -> exp R -> exp B 80 | x !/=! y = bNot (x !=! y) 81 | 82 | 83 | (! exp R -> exp R -> exp B 84 | x ! exp R -> exp R -> exp B 87 | x !<=! y = opE Leq [x, y] 88 | 89 | 90 | (!>!) :: ExpHoas exp => exp R -> exp R -> exp B 91 | (!>!) = (!=!) :: ExpHoas exp => exp R -> exp R -> exp B 94 | (!>=!) = (!<=!) 95 | 96 | 97 | (!&!) :: ExpHoas exp => exp B -> exp B -> exp B 98 | x !&! y = opE And [x, y] 99 | 100 | (!|!) :: ExpHoas exp => exp B -> exp B -> exp B 101 | x !|! y = opE Or [x, y] 102 | 103 | bNot :: ExpHoas exp => exp B -> exp B 104 | bNot x = opE Not [x] 105 | 106 | bObs :: ExpHoas exp => BoolObs -> Int -> exp B 107 | bObs l i = obs (LabB l) i 108 | 109 | 110 | false :: BExp 111 | false = opE (BLit False) [] 112 | 113 | true :: BExp 114 | true = opE (BLit True) [] 115 | 116 | 117 | 118 | newtype CDB = CDB {unCDB :: Int -> C.Contr} 119 | 120 | class ExpHoas exp => ContrHoas exp contr | exp -> contr, contr -> exp where 121 | zero :: contr 122 | letc :: exp t -> (exp t -> contr) -> contr 123 | scale :: exp R -> contr -> contr 124 | both :: contr -> contr -> contr 125 | transfer :: Party -> Party -> Asset -> contr 126 | translate :: Int -> contr -> contr 127 | ifWithin :: exp B -> Int -> contr -> contr -> contr 128 | fromClosed :: C.Contr -> contr 129 | 130 | 131 | instance ContrHoas DB CDB where 132 | zero = CDB (\_-> Zero) 133 | letc e c = CDB (\i -> let v = \ j -> VarE (toVar (j-(i+1))) 134 | in Let (unDB e i) (unCDB (c (DB v)) (i+1))) 135 | transfer p1 p2 a = CDB (\_-> Transfer p1 p2 a) 136 | scale e c = CDB (\i -> Scale (unDB e i) (unCDB c i)) 137 | translate t c = CDB (\i -> Translate t (unCDB c i)) 138 | both c1 c2 = CDB (\i -> Both (unCDB c1 i) (unCDB c2 i)) 139 | ifWithin e t c1 c2 = CDB (\i -> If (unDB e i) t (unCDB c1 i) (unCDB c2 i)) 140 | 141 | fromClosed c = CDB (const c) 142 | 143 | 144 | type Contr = forall exp contr . ContrHoas exp contr => contr 145 | 146 | fromHoas :: Contr -> C.Contr 147 | fromHoas t = unCDB t 0 148 | 149 | toHoas :: C.Contr -> Contr 150 | toHoas c = fromClosed c 151 | 152 | (&) :: ContrHoas exp contr => contr -> contr -> contr 153 | (&) = both 154 | 155 | (!) :: ContrHoas exp contr => Int -> contr -> contr 156 | (!) = translate 157 | 158 | (#) :: ContrHoas exp contr => exp R -> contr -> contr 159 | (#) = scale 160 | 161 | 162 | iff :: ContrHoas exp contr => exp B -> contr -> contr -> contr 163 | iff e = ifWithin e 0 164 | -------------------------------------------------------------------------------- /SML/DateUtil.sml: -------------------------------------------------------------------------------- 1 | structure DateUtil :> DateUtil = struct 2 | 3 | type date = {year:int,month:int,day:int} 4 | 5 | fun isLeapYear year = 6 | year mod 400 = 0 orelse 7 | (not (year mod 100 = 0) andalso year mod 4 = 0) 8 | 9 | fun daysInYear year = 10 | if isLeapYear year then 366 else 365 11 | 12 | fun daysInMonth year m = 13 | let val m31 = [1,3,5,7,8,10,12] 14 | fun daysInFeb () = if isLeapYear year then 29 else 28 15 | in if List.exists (fn x => x = m) m31 then 31 16 | else if m = 2 then daysInFeb() 17 | else 30 18 | end 19 | 20 | fun check {year,month,day} = 21 | year >= 1 andalso year <= 9999 andalso (* there is no such thing as year 0! *) 22 | month >= 1 andalso month <= 12 andalso 23 | day >= 1 andalso day <= daysInMonth year month 24 | 25 | exception DateError of string 26 | 27 | (* module functions operate on the Date.date type, ignoring time *) 28 | 29 | (* The expected format of our converter is yyyy-mm-dd. Suffix is ignored *) 30 | fun dateError s = 31 | (print (s ^ "\n"); 32 | raise DateError ("Expecting date in the form YYYY-MM-DD - got " ^ s)) 33 | 34 | fun digits s = CharVector.all Char.isDigit s 35 | 36 | fun ? s = 37 | if size s <> 10 orelse String.sub(s,4) <> #"-" orelse String.sub(s,7) <> #"-" then dateError s 38 | else 39 | let val y = String.substring (s,0,4) 40 | val m = String.substring (s,5,2) 41 | val d = String.substring (s,8,2) 42 | in if digits y andalso digits m andalso digits d then 43 | case (Int.fromString y, Int.fromString m, Int.fromString d) of 44 | (SOME y, SOME m, SOME d) => {year=y,month=m,day=d} 45 | | _ => dateError s 46 | else dateError s 47 | end 48 | 49 | fun pad n s = if size s < n then pad n ("0" ^ s) 50 | else s 51 | 52 | fun ppDate {year,month,day} = 53 | pad 4 (Int.toString year) ^ "-" ^ pad 2 (Int.toString month) ^ 54 | "-" ^ pad 2 (Int.toString day) 55 | 56 | fun return d = if check d then d else dateError (ppDate d) 57 | 58 | fun addDays 0 d = return d 59 | | addDays i (d as {year,month,day}) = 60 | if i < 0 then subDays (~i) d 61 | else let val days = daysInMonth year month 62 | val n = days - day 63 | in if i <= n then return {year=year,month=month,day=day+i} 64 | else addDays (i-n-1) 65 | (if month = 12 then {year=year+1,month=1,day=1} 66 | else {year=year,month=month+1,day=1}) 67 | end 68 | and subDays 0 d = return d 69 | | subDays i (d as {year,month,day}) = 70 | if i < 0 then addDays (~i) d 71 | else if i < day then return {year=year,month=month,day=day-i} 72 | else let val (y,m) = if month = 1 then (year-1,12) 73 | else (year,month-1) 74 | val d = daysInMonth y m 75 | in subDays (i-day) {year=y,month=m,day=d} 76 | end 77 | 78 | fun compare ({year=y1,month=m1,day=d1}, {year=y2,month=m2,day=d2}) = 79 | if y1 < y2 then LESS 80 | else (if y1 = y2 then 81 | if m1 < m2 then LESS 82 | else if m1 = m2 then 83 | (if d1 < d2 then LESS 84 | else if d1 = d2 then EQUAL 85 | else GREATER) 86 | else GREATER 87 | else GREATER) 88 | 89 | (* computes day difference to go from d1 to d2 *) 90 | fun dateDiff d1 d2 = 91 | case compare (d1,d2) of 92 | EQUAL => 0 93 | | GREATER => ~ (dateDiff d2 d1) 94 | | LESS => (* d1 < d2 *) 95 | let val {year=y1,month=m1,day=n1} = d1 96 | val {year=y2,month=m2,day=n2} = d2 97 | in 98 | if y1 = y2 then 99 | if m1 = m2 then n2 - n1 100 | else (* m2 > m1 *) 101 | let val d = daysInMonth y1 m1 102 | in d - n1 + 1 + dateDiff {year=y1,month=m1+1,day=1} d2 103 | end 104 | else (* y2 > y1 *) 105 | if m1 = 12 then 106 | daysInMonth y1 m1 + dateDiff {year=y1+1,month=1,day=n1} d2 107 | else 108 | daysInMonth y1 m1 + dateDiff {year=y1,month=m1+1,day=n1} d2 109 | end 110 | (* 111 | if n1 = n2 then 112 | if m1 = m2 then 113 | daysInYear (y2-1) + dateDiff d1 {year=y2-1,month=m2,day=n2} 114 | else if m2 > 1 then 115 | daysInMonth y2 (m2-1) + dateDiff d1 {year=y2,month=m2-1,day=n2} 116 | else daysInMonth (y2-1) 12 + dateDiff d1 {year=y2-1,month=12,day=n2} 117 | else if n2 > n1 then 118 | n2 - n1 + dateDiff d1 {year=y2,month=m2,day=n1} 119 | else (* n1 > n2 *) 120 | dateDiff d1 {year=y2,month=m2,day=n1} - (n1 - n2) 121 | end 122 | *) 123 | 124 | 125 | end 126 | 127 | -------------------------------------------------------------------------------- /Coq/Typing.v: -------------------------------------------------------------------------------- 1 | (********** Typing Rules **********) 2 | 3 | Require Export Syntax. 4 | 5 | Import ListNotations. 6 | 7 | (* Types for the expression language *) 8 | Inductive Ty := REAL | BOOL. 9 | 10 | 11 | (* Typing of operations *) 12 | 13 | Reserved Notation "'|-Op' e '∶' t '=>' r" (at level 20). 14 | 15 | Inductive TypeOp : Op -> list Ty -> Ty -> Prop := 16 | | type_blit b : |-Op (BLit b) ∶ [] => BOOL 17 | | type_rlit r : |-Op (RLit r) ∶ [] => REAL 18 | | type_neg : |-Op Neg ∶ [REAL] => REAL 19 | | type_not : |-Op Not ∶ [BOOL] => BOOL 20 | | type_cond t : |-Op Cond ∶ [BOOL;t;t] => t 21 | | type_add : |-Op Add ∶ [REAL;REAL] => REAL 22 | | type_sub : |-Op Sub ∶ [REAL;REAL] => REAL 23 | | type_mult : |-Op Mult ∶ [REAL;REAL] => REAL 24 | | type_div : |-Op Div ∶ [REAL;REAL] => REAL 25 | | type_and : |-Op And ∶ [BOOL;BOOL] => BOOL 26 | | type_or : |-Op Or ∶ [BOOL;BOOL] => BOOL 27 | | type_less : |-Op Less ∶ [REAL;REAL] => BOOL 28 | | type_leq : |-Op Leq ∶ [REAL;REAL] => BOOL 29 | | type_equal : |-Op Equal ∶ [REAL;REAL] => BOOL 30 | where "'|-Op' v '∶' t '=>' r" := (TypeOp v t r). 31 | 32 | 33 | (* Typing of observalbes *) 34 | Reserved Notation "'|-O' e '∶' t" (at level 20). 35 | 36 | Inductive TypeObs : ObsLabel -> Ty -> Prop := 37 | | type_obs_bool b : |-O LabB b ∶ BOOL 38 | | type_obs_real b : |-O LabR b ∶ REAL 39 | where "'|-O' v '∶' t" := (TypeObs v t). 40 | 41 | 42 | (* Type environments map variables to their types. *) 43 | 44 | Definition TyEnv := list Ty. 45 | 46 | (* Typing of variables *) 47 | 48 | Reserved Notation "g '|-X' v '∶' t" (at level 20). 49 | 50 | Inductive TypeVar : TyEnv -> Var -> Ty -> Prop := 51 | | type_var_1 t g : (t :: g) |-X V1 ∶ t 52 | | type_var_S g v t t' : g |-X v ∶ t -> (t' :: g) |-X VS v ∶ t 53 | where "g '|-X' v '∶' t" := (TypeVar g v t). 54 | 55 | 56 | (* Typing of expressions *) 57 | 58 | Reserved Notation "g '|-E' e '∶' t" (at level 20). 59 | 60 | Inductive TypeExp : TyEnv -> Exp -> Ty -> Prop := 61 | | type_op g op es ts t : |-Op op ∶ ts => t -> all2 (TypeExp g) es ts -> g |-E OpE op es ∶ t 62 | | type_obs t g o z : |-O o ∶ t -> g |-E Obs o z ∶ t 63 | | type_var t g v : g |-X v ∶ t -> g |-E VarE v ∶ t 64 | | type_acc n t g e1 e2 : (t :: g) |-E e1 ∶ t -> g |-E e2 ∶ t -> g |-E Acc e1 n e2 ∶ t 65 | where "g '|-E' e '∶' t" := (TypeExp g e t). 66 | 67 | (* The induction principle generated by Coq is not strong enough. We 68 | need to roll our own. *) 69 | 70 | Definition TypeExp_ind' : forall P : TyEnv -> Exp -> Ty -> Prop, 71 | (forall (g : TyEnv) (op : Op) (es : list Exp) (ts : list Ty) (t : Ty), 72 | |-Op op ∶ ts => t -> 73 | all2 (TypeExp g) es ts -> all2 (P g) es ts -> P g (OpE op es) t) -> 74 | (forall (t : Ty) (g : TyEnv) (o : ObsLabel) (z : Z), 75 | |-O o ∶ t -> P g (Obs o z) t) -> 76 | (forall (t : Ty) (g : TyEnv) (v : Var), g |-X v ∶ t -> P g (VarE v) t) -> 77 | (forall (n : nat) (t : Ty) (g : list Ty) (e1 e2 : Exp), 78 | (t :: g) |-E e1 ∶ t -> 79 | P (t :: g) e1 t -> g |-E e2 ∶ t -> P g e2 t -> P g (Acc e1 n e2) t) -> 80 | forall (t : TyEnv) (e : Exp) (t0 : Ty), t |-E e ∶ t0 -> P t e t0 := 81 | fun (P : TyEnv -> Exp -> Ty -> Prop) 82 | (f : forall (g : TyEnv) (op : Op) (es : list Exp) (ts : list Ty) (t : Ty), 83 | |-Op op ∶ ts => t -> all2 (TypeExp g) es ts -> all2 (P g) es ts -> P g (OpE op es) t) 84 | (f0 : forall (t : Ty) (g : TyEnv) (o : ObsLabel) (z : Z), 85 | |-O o ∶ t -> P g (Obs o z) t) 86 | (f1 : forall (t : Ty) (g : TyEnv) (v : Var), g |-X v ∶ t -> P g (VarE v) t) 87 | (f2 : forall (n : nat) (t : Ty) (g : list Ty) (e1 e2 : Exp), 88 | (t :: g) |-E e1 ∶ t -> 89 | P (t :: g) e1 t -> g |-E e2 ∶ t -> P g e2 t -> P g (Acc e1 n e2) t) => 90 | fix F (t : TyEnv) (e : Exp) (t0 : Ty) (t1 : t |-E e ∶ t0) {struct t1} : 91 | P t e t0 := 92 | match t1 in (t2 |-E e0 ∶ t3) return (P t2 e0 t3) with 93 | | type_op g op es ts t2 t3 f3 => 94 | let fix step es ts (args: all2 (TypeExp g) es ts) := 95 | match args with 96 | | all2_nil => all2_nil (P g) 97 | | all2_cons e t0 es ts ty tys => all2_cons (P g) (F g e t0 ty) (step es ts tys) 98 | end 99 | in f g op es ts t2 t3 f3 (step es ts f3) 100 | | type_obs t2 g o z t3 => f0 t2 g o z t3 101 | | type_var t2 g v t3 => f1 t2 g v t3 102 | | type_acc n t2 g e1 e2 t3 t4 => 103 | f2 n t2 g e1 e2 t3 (F (t2 :: g) e1 t2 t3) t4 (F g e2 t2 t4) 104 | end. 105 | 106 | 107 | (* Typing of contracts. *) 108 | 109 | Reserved Notation "g '|-C' e" (at level 20). 110 | 111 | Inductive TypeContr : TyEnv -> Contr -> Prop := 112 | | type_zero g : g |-C Zero 113 | | type_let e c t g : g |-E e ∶ t -> (t :: g) |-C c -> g |-C Let e c 114 | | type_transfer p1 p2 c g : g |-C Transfer p1 p2 c 115 | | type_scale e c g : g |-E e ∶ REAL -> g |-C c -> g |-C Scale e c 116 | | type_translate d c g : g |-C c -> g |-C Translate d c 117 | | type_both c1 c2 g : g |-C c1 -> g |-C c2 -> g |-C Both c1 c2 118 | | type_if e d c1 c2 g : g |-E e ∶ BOOL -> g |-C c1 -> g |-C c2 -> g |-C If e d c1 c2 119 | where "g '|-C' c" := (TypeContr g c). 120 | 121 | 122 | Hint Constructors TypeOp TypeObs TypeExp TypeVar TypeContr. -------------------------------------------------------------------------------- /Coq/README.md: -------------------------------------------------------------------------------- 1 | # Certified Symbolic Management of Financial Multi-Party Contracts [![Build Status](https://travis-ci.org/HIPERFIT/contracts.svg?branch=master)](https://travis-ci.org/HIPERFIT/contracts) 2 | 3 | This directory contains the certified implementation of the financial 4 | multi-party contract language described in the paper 5 | ["Certified Symbolic Management of Financial Multi-Party Contracts"](../doc/icfp2015.pdf). It 6 | also includes the Haskell implementation that has been extracted from 7 | the Coq implementation along with examples that illustrate the use of 8 | the extracted Haskell library. 9 | 10 | ## File Structure 11 | 12 | - [Syntax.v](Syntax.v) defines the language's syntax. 13 | - [Typing.v](Typing.v) defines the type system. 14 | - [Denotational.v](Denotational.v) defines the denotational semantics; 15 | [DenotationalTyped.v](DenotationalTyped.v) proves that the 16 | denotational semantics is total on well-typed contracts. 17 | - [Equivalence.v](Equivalence.v) proves some contract equivalences. 18 | - [Antisymmetry.v](Antisymmetry.v) proves antisymmetry of the 19 | denotational semantics. 20 | - [SyntacticCausality.v](SyntacticCausality.v) and 21 | [ContextualCausality.v](ContextualCausality.v) implement syntactic 22 | causality checks and prove them sound. 23 | - [TimedTyping.v](TimedTyping.v) gives the time-indexed type system 24 | and proves that well-typed contracts are causal. In addition, it 25 | defines type inference procedure and proves it sound and complete. 26 | - [Reduction.v](Reduction.v) defines the reduction semantics and 27 | proves it adequate for the denotational semantics. 28 | - [Specialise.v](Specialise.v) defines specialisation of contracts 29 | (partial evaluation w.r.t. a partial external environment) and 30 | proves it correct. 31 | - [Horizon.v](Horizon.v) defines the (syntactic) horizon of a contract 32 | and proves that it is semantically correct. 33 | 34 | ## Theorems from the Paper 35 | 36 | 37 | The list below details where the theorems (and lemmas, corollaries 38 | etc.) from the paper 39 | ["Certified Symbolic Management of Financial Multi-Party Contracts"](http://www.diku.dk/~paba/pubs/files/bahr15icfp-preprint.pdf) 40 | can be found in the Coq formalisation: 41 | 42 | - Lemma 1: lemma `translateExp_ext` in [TranslateExp.v](TranslateExp.v) 43 | - Lemma 2: theorem `sem_antisym` in [Antisymmetry.v](Antisymmetry.v) 44 | - Proposition 3: theorem `Esem_typed_total` and `Csem_typed_total` in 45 | [DenotationalTyped.v](DenotationalTyped.v) 46 | - Proposition 4: theorem `horizon_sound` in [Horizon.v](Horizon.v) 47 | - Proposition 5: lemma `TiTyE_type` and theorem `TiTyC_type` in [TimedTyping.v](TimedTyping.v) 48 | - Theorem 6: corollary `TiTyC_causal` in [TimedTyping.v](TimedTyping.v) 49 | - Lemma 7: lemma `TiTyE_open` and `TiTyC_open` in [TimedTyping.v](TimedTyping.v) 50 | - Theorem 8: theorem `inferC_sound` and inferC_complete in [TimedTyping.v](TimedTyping.v) 51 | - Corollary 9: corollary `has_type_causal` in [TimedTyping.v](TimedTyping.v) 52 | - Theorem 10: theorem `specialiseExp_sound` and `specialise_sound` in [Specialise.v](Specialise.v) 53 | - Theorem 11: (i) theorem `red_sound1` and `red_sound2`, (ii) theorem 54 | `red_preservation`, and (iii) theorem `red_progress` in [Reduction.v](Reduction.v) 55 | 56 | 57 | ## Other Definitions and Properties from the Paper 58 | 59 | The function `adv` from the paper is defined as `redfun` in 60 | [Reduction.v](Reduction.v). The soundness and completeness of `redfun` 61 | is proved by Theorem `redfun_red` respectively Theorem `red_redfun` in 62 | [Reduction.v](Reduction.v). 63 | 64 | The functions `spE` and `spC` from the paper are defined in 65 | [Specialise.v](Specialise.v) as `specialiseExp` and 66 | `specialise`, respectively. 67 | 68 | ## Code Extraction & Examples 69 | 70 | 71 | The [Extraction](Extraction) subdirectory implements a simple 72 | extraction of the Coq definitions to Haskell code using Coq's built-in 73 | extraction facility. For convenience, the extracted Haskell code is 74 | included in this repository. To reproduce the code extraction from Coq 75 | to Haskell use the Makefile in [Extraction](Extraction): 76 | 77 | ```shell 78 | make 79 | cd Extraction 80 | make 81 | ``` 82 | 83 | The extracted Haskell code provides a library for writing and managing 84 | contracts embedded in Haskell. The 85 | [Extraction/Examples](Extraction/Examples) subdirectory contains a 86 | number of example contracts that are written using the extracted 87 | Haskell library. 88 | 89 | 90 | ## Logical Axioms 91 | 92 | 93 | The Coq formalisation uses logical axioms for three abstract data 94 | types: 95 | 96 | - We assume the types `Asset` and `Party` with decidable equality 97 | (cf. [Syntax.v](Syntax.v)). 98 | - We assume the type `FMap` of finite mappings given by a standard set 99 | of operations on finite mappings together with a set of axioms that 100 | specify their properties (cf. [FinMap.v](FinMap.v)). 101 | 102 | ## Technical Details 103 | 104 | ### Dependencies 105 | 106 | - To check the proofs: Coq 8.4pl5 107 | - To step through the proofs: GNU Emacs 24.3.1, Proof General 4.2 108 | - To use extracted Haskell library: GHC 7.8.4 109 | 110 | ### Proof Checking 111 | 112 | To check and compile the complete Coq development, you can use the 113 | `Makefile`: 114 | 115 | ```shell 116 | > make 117 | ``` 118 | -------------------------------------------------------------------------------- /Haskell/Contract/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE GADTs #-} 3 | 4 | module Contract.Type 5 | ( Contract(..) -- constructors exported 6 | , MContract -- managed contract, including a start date 7 | , Party 8 | -- smart constructors and convenience functions 9 | , zero, transfOne, transl, iff, checkWithin, both, allCs, scale, flow, foreach 10 | -- pretty-printer 11 | , ppContr 12 | ) where 13 | 14 | import Contract.Expr 15 | import Contract.ExprIO 16 | import Contract.Date 17 | import Contract.Hash 18 | 19 | -- | party of a contract. A simple string 20 | type Party = String 21 | 22 | -- | a managed contract is a contract with a start date 23 | type MContract = (Date, Contract) 24 | 25 | -- | the contract representation type 26 | data Contract = Zero 27 | | TransfOne Currency Party Party -- ^ Atom: Transfer money 28 | | Scale RealE Contract -- ^ Scaling a contract by a RealE 29 | | Transl Int Contract -- ^ Translating a contract into the future 30 | | Both Contract Contract -- ^ Combining two contracts 31 | | If BoolE Contract Contract -- ^ Conditional contract 32 | | CheckWithin BoolE Int Contract Contract 33 | -- ^ Repeatedly checks every day, until given end, whether condition is true. When it is true, the first contract argument comes into effect. Otherwise (never true until end) the second contract comes into effect. 34 | -- | forall a . Let (Expr a) (Expr a -> Contract) 35 | deriving (Show) 36 | 37 | -- | computes hash of a contract, considering symmetry of 'Both' constructor 38 | hashContr :: [Var] -> Contract -> Hash -> Hash 39 | hashContr vs c a = 40 | let ps = hashPrimes 41 | in case c of 42 | Zero -> hash (ps!!0) a 43 | -- symmetric 44 | Both c1 c2 -> hashContr vs c1 0 + hashContr vs c2 0 + a 45 | TransfOne cur p1 p2 -> 46 | hashStr (show cur) (hashStr p1 (hashStr p2 (hash (ps!!1) a))) 47 | If e c1 c2 -> 48 | hashContr vs c1 (hashContr vs c2 (hashExp vs e (hash (ps!!2) a))) 49 | Scale e c -> hashExp vs e (hashContr vs c (hash (ps!!3) a)) 50 | Transl i c -> hash i (hashContr vs c (hash (ps!!4) a)) 51 | CheckWithin e1 i c1 c2 -> 52 | hashContr vs c1 (hashContr vs c2 (hashExp vs e1 53 | (hash i (hash (ps!!5) a)))) 54 | -- Let e f -> hashContr(v::vs,c,hashExp(vs,e,H(17,a))) 55 | 56 | -- | hash-based equality, levelling out some symmetries 57 | instance Eq Contract where 58 | c1 == c2 = hashContr [] c1 0 == hashContr [] c2 0 59 | 60 | -- | pretty-prints a contract. 61 | ppContr :: Contract -> String 62 | ppContr c = 63 | case c of 64 | TransfOne c p1 p2 -> "TransfOne" ++ par (show c ++ "," ++ p1 ++ "," ++ p2) 65 | Scale e c -> "Scale" ++ par (ppExp e ++ "," ++ ppContr c) 66 | Transl i c -> "Transl" ++ par (ppDays i ++ "," ++ ppContr c) 67 | Zero -> "zero" 68 | Both c1 c2 -> "Both" ++ par (ppContrs[c1,c2]) 69 | If e c1 c2 -> "If" ++ par (ppExp e ++ ", " ++ ppContr c1 ++ ", " ++ ppContr c2) 70 | CheckWithin e i c1 c2 -> 71 | "CheckWithin" ++ par (ppExp e ++ ", " ++ ppDays i ++ ", " ++ ppContr c1 ++ ", " ++ ppContr c2) 72 | -- | Let(v,e,c) -> "Let" ++ par (v ++ "," ++ ppExp e ++ "," ++ ppContr c) 73 | where par s = "(" ++ s ++ ")" 74 | 75 | ppContrs [] = "" 76 | ppContrs [c] = ppContr c 77 | ppContrs (c:cs) = ppContr c ++ ", " ++ ppContrs cs 78 | 79 | -- smart constructors (for reexport) TODO make them smarter! 80 | 81 | -- | the empty contract 82 | zero = Zero 83 | 84 | -- | Transfer one unit. Rarely used... 85 | transfOne = TransfOne 86 | 87 | -- | translate a contract into the future by a number of days 88 | transl :: Int -> Contract -> Contract 89 | transl d c | d < 0 = error "transl: negative time" 90 | transl 0 c = c 91 | transl _ Zero = Zero 92 | transl d (Transl d' c) = Transl (d+d') c 93 | transl d c = Transl d c 94 | 95 | -- | conditional contract (two branches) 96 | iff (B True) c1 c2 = c1 97 | iff (B False) c1 c2 = c2 98 | iff e c1 c2 = If e c1 c2 99 | 100 | -- | repeatedly checking condition for the given number of days, branching into first contract when true, or else into second contract at the end 101 | checkWithin e n c1 c2 | n == 0 = iff e c1 c2 102 | | otherwise = CheckWithin e n c1 c2 103 | 104 | -- | two contracts 105 | both c1 Zero = c1 106 | both Zero c2 = c2 107 | both c1 c2 | c1 == c2 = scale (r 2) c1 108 | | otherwise = Both c1 c2 109 | 110 | -- | many contracts (a 'book') 111 | allCs :: [Contract] -> Contract 112 | allCs [] = Zero 113 | allCs [c] = c 114 | allCs (Zero:cs) = allCs cs 115 | allCs (c:cs) = both c (allCs cs) 116 | 117 | -- | scaling a contract by a 'RealE' expression 118 | scale _ Zero = Zero 119 | scale r (Scale r' c) = Scale (r*r') c 120 | scale r c | r == 0 = Zero 121 | | r == 1 = c 122 | | otherwise = Scale r c 123 | 124 | -- | straightforward money transfer (translate, scale, transfOne): after given number of days, transfer from one party to another the given amount in the given currency 125 | flow :: Int -> RealE -> Currency -> Party -> Party -> Contract 126 | flow d amount cur from to = transl d (scale amount (transfOne cur from to)) 127 | 128 | -- | repeat contract c for each day in ds 129 | foreach :: [Int] -> Contract -> Contract 130 | foreach ds c = allCs (map (\ d -> transl d c) ds) 131 | -------------------------------------------------------------------------------- /Haskell/Contract/Date.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | module Contract.Date 3 | ( Date -- incl. Ord instance providing compare function and (<) 4 | , DateError 5 | , at -- was "?" in SML. Use the Read instance instead 6 | , addDays, dateDiff, ppDate, ppDays 7 | ) where 8 | 9 | 10 | -- to define the exception 11 | import Control.Exception as E 12 | import Data.Typeable 13 | 14 | import Data.Char(isDigit) 15 | import Text.Printf 16 | 17 | -- everything implemented "on foot". Could use a library module 18 | 19 | type Year = Int 20 | type Month = Int 21 | type Day = Int 22 | 23 | -- | Dates are represented as year, month, and day. 24 | data Date = Date Year Month Day 25 | deriving (Eq,Ord, Show) 26 | 27 | isLeapYear :: Year -> Bool 28 | isLeapYear year = year `mod` 400 == 0 || 29 | (not (year `mod` 100 == 0) && year `mod` 4 == 0) 30 | 31 | daysInYear year = if isLeapYear year then 366 else 365 32 | 33 | daysInMonth :: Year -> Month -> Int 34 | daysInMonth year m = 35 | let m31 = [1,3,5,7,8,10,12] 36 | daysInFeb = if isLeapYear year then 29 else 28 37 | in if m `elem` m31 then 31 38 | else if m == 2 then daysInFeb else 30 39 | 40 | data DateError = DateError String deriving (Typeable,Show) 41 | instance Exception DateError 42 | 43 | check :: Date -> Date 44 | check d@(Date year month day) = if 45 | year >= 1 && year <= 9999 && -- there is no such thing as year 0! 46 | month >= 1 && month <= 12 && 47 | day >= 1 && day <= daysInMonth year month 48 | then d else dateError (ppDate d) 49 | 50 | dateError s = -- print (s ++ "\n") 51 | throw (DateError ("Expecting date in the form YYYY-MM-DD - got " ++ s)) 52 | 53 | -- | read a date from a string in format yyyy-mm-dd 54 | at :: String -> Date 55 | at s | length s /= 10 = dateError s 56 | | s!!4 /= '-' = dateError s 57 | | s!!7 /= '-' = dateError s 58 | | not allDigits = dateError s 59 | | otherwise = check result 60 | where substr a b = take b (drop a s) 61 | y = substr 0 4 62 | m = substr 5 2 63 | d = substr 8 2 64 | allDigits = all isDigit (y++m++d) 65 | result = Date (read y) (read m) (read d) 66 | -- (\e -> dateError (s ++ "\n" ++ show (e::ErrorCall))) 67 | 68 | -- | Dates can only be read in format yyyy-mm-dd 69 | instance Read Date where 70 | readsPrec _ d = [(at (take 10 d), drop 10 d)] 71 | 72 | -- | print a date in format yyyy-mm-dd (padding with zeros) 73 | ppDate :: Date -> String 74 | ppDate (Date year month day) = printf "%04d-%02d-%02d" year month day 75 | 76 | -- | add given number of days to a date (result date is checked) 77 | addDays :: Int -> Date -> Date 78 | addDays 0 d = check d 79 | addDays i (d@(Date year month day)) 80 | | i < 0 = subDays (-i) d 81 | | otherwise = let days = daysInMonth year month 82 | n = days - day 83 | next = if month == 12 then Date (year+1) 1 1 84 | else Date year (month+1) 1 85 | in if i <= n then check (Date year month (day+i)) 86 | else addDays (i-n-1) next 87 | 88 | -- | subtract days (used for adding negative amount of days to a date) 89 | subDays 0 d = check d 90 | subDays i (d@(Date year month day)) 91 | | i < 0 = addDays (-i) d -- should not occur, not directly callable 92 | | otherwise = if i < day then check (Date year month (day-i)) 93 | else let (y,m) = if month == 1 then (year-1,12) 94 | else (year,month-1) 95 | d = daysInMonth y m 96 | in subDays (i-day) (Date y m d) 97 | 98 | -- derived Ord, comparisons component-wise left-to-right, no big deal 99 | -- fun compare ({year=y1,month=m1,day=d1}, {year=y2,month=m2,day=d2}) = 100 | -- if y1 < y2 then LESS 101 | -- else (if y1 = y2 then 102 | -- if m1 < m2 then LESS 103 | -- else if m1 = m2 then 104 | -- (if d1 < d2 then LESS 105 | -- else if d1 = d2 then EQUAL 106 | -- else GREATER) 107 | -- else GREATER 108 | -- else GREATER) 109 | 110 | -- | compute day difference to go from d1 to d2 111 | dateDiff :: Date -> Date -> Int 112 | dateDiff d1@(Date y1 m1 n1) d2@(Date y2 m2 n2) 113 | = case compare d1 d2 of 114 | EQ -> 0 115 | GT -> - (dateDiff d2 d1) 116 | LT -> -- d1 < d2 117 | if y1 == y2 then 118 | if m1 == m2 then n2 - n1 119 | else -- m1 < m2, go to next month 120 | daysInMonth y1 m1 - n1 + 1 + 121 | dateDiff (Date y1 (m1+1) 1) d2 122 | else -- y1 < y2, but step fwd in months (leapyears!) 123 | let next = if m1 == 12 then Date (y1+1) 1 n1 124 | else Date y1 (m1+1) n1 125 | in daysInMonth y1 m1 + dateDiff next d2 126 | 127 | -- | print a number of days as years/months/days, using 30/360 convention 128 | ppDays :: Int -> String 129 | ppDays 0 = "0d" 130 | ppDays t = if null s then "0d" else s 131 | where years = t `div` 360 132 | months = (t `div` 30) `mod` 12 -- (t mod 360) div 30 133 | days = t `mod` 30 134 | str n c = if n == 0 then "" else show n ++ c:[] 135 | s = concat (zipWith str [years,months,days] "ymd") 136 | 137 | -------------------------------------------------------------------------------- /Coq/DenotationalTyped.v: -------------------------------------------------------------------------------- 1 | (********** Denotational semantics preserves types **********) 2 | (********** (and is total on typed contracts) **********) 3 | 4 | Require Import Equality. 5 | Require Import Denotational. 6 | 7 | 8 | (* Typing of values *) 9 | 10 | Reserved Notation "'|-V' e '∶' t" (at level 20). 11 | 12 | Inductive TypeVal : Val -> Ty -> Prop := 13 | | type_bool b : |-V BVal b ∶ BOOL 14 | | type_real b : |-V RVal b ∶ REAL 15 | where "'|-V' v '∶' t" := (TypeVal v t). 16 | 17 | (* Typing of partial values *) 18 | 19 | Reserved Notation "'|-V'' e '∶' t" (at level 20). 20 | 21 | Inductive TypeVal' : option Val -> Ty -> Prop := 22 | | type_some v t : |-V v ∶ t -> |-V' Some v ∶ t 23 | | type_none t : |-V' None ∶ t 24 | where "'|-V'' v '∶' t" := (TypeVal' v t). 25 | 26 | Hint Constructors TypeVal TypeVal'. 27 | 28 | (* Typing of external environments *) 29 | 30 | Definition TypeExt (ext : ExtEnv) := forall z l t, |-O l ∶ t -> |-V (ext l z) ∶ t. 31 | 32 | Lemma adv_ext_type e d : TypeExt e -> TypeExt (adv_ext d e). 33 | Proof. 34 | unfold TypeExt, adv_ext. intros. auto. 35 | Qed. 36 | 37 | Hint Resolve adv_ext_type. 38 | 39 | (* Typing of environments *) 40 | 41 | Definition TypeEnv (g : TyEnv) (env : Env) : Prop := all2 TypeVal env g. 42 | 43 | Hint Unfold TypeEnv. 44 | 45 | (* Typing of arguments (to an operation). *) 46 | 47 | Definition TypeArgs (ts : list Ty) (args : list Val) : Prop := all2 TypeVal args ts. 48 | 49 | 50 | Lemma OpSem_typed_total {A} op ts t (args : list A) (f : A -> option Val) : 51 | |-Op op ∶ ts => t -> all2 (fun x t => exists v, f x = Some v /\ |-V v ∶ t) args ts -> 52 | exists v, (mapM f args >>= OpSem op) = Some v /\ |-V v ∶ t. 53 | Proof. 54 | intros O T. induction O; 55 | repeat (match goal with 56 | | [ H : exists _, _ /\ _ |- _ ] => 57 | let H1 := fresh in let H2 := fresh in let H3 := fresh in 58 | let H4 := fresh in 59 | destruct H as [H1 H2]; destruct H2 as [H3 H4]; rewrite H3 in *; inversion H4 60 | | [H : all2 _ _ _ |- _] => inversion H; clear H 61 | end; subst; simpl; unfold liftM2, bind); eexists; auto. 62 | Qed. 63 | 64 | 65 | (* The denotational semantics of expressions is total and produces 66 | values of the correct type. *) 67 | 68 | Theorem Esem_typed_total g e t (env : Env) (ext : ExtEnv) : 69 | g |-E e ∶ t -> TypeEnv g env -> TypeExt ext -> (exists v, E[|e|] env ext = Some v /\ |-V v ∶ t). 70 | Proof. 71 | intros E R V'. generalize dependent env. generalize dependent ext. 72 | dependent induction E using TypeExp_ind'; intros. 73 | + simpl. rewrite sequence_map. eapply OpSem_typed_total. apply H. 74 | do 4 (eapply all2_apply in H1;eauto). 75 | + simpl. eauto. 76 | + simpl. generalize dependent env. 77 | generalize dependent g. induction v; intros. 78 | - inversion H. subst. inversion R. subst. simpl. eauto. 79 | - simpl. inversion H. subst. inversion R. subst. eapply IHv. 80 | apply H2. auto. 81 | + simpl. eapply Acc_sem_ind. intros. decompose [ex and] H. subst. 82 | simpl. apply IHE1; auto. apply IHE2; auto. 83 | Qed. 84 | 85 | Corollary Esem_typed g e t (env : Env) (ext : ExtEnv) v : 86 | g |-E e ∶ t -> TypeEnv g env -> TypeExt ext -> E[|e|] env ext = Some v -> |-V v ∶ t. 87 | Proof. 88 | intros T T1 T2 S. eapply Esem_typed_total in T; eauto. decompose [ex and] T. 89 | rewrite H0 in S. inversion S. subst. assumption. 90 | Qed. 91 | 92 | Definition total_trace (t : option Trace) := exists v, t = Some v. 93 | 94 | Hint Unfold empty_trace empty_trans const_trace empty_trans 95 | total_trace singleton_trace singleton_trans scale_trace scale_trans. 96 | 97 | 98 | (* The denotational semantics of contracts is total. *) 99 | 100 | 101 | Theorem Csem_typed_total c g (env: Env) (ext : ExtEnv) : 102 | g |-C c -> TypeEnv g env -> TypeExt ext -> total_trace (C[|c|] env ext). 103 | Proof. 104 | intros C T R. generalize dependent env. generalize dependent ext. generalize dependent g. 105 | unfold total_trace. induction c. 106 | + simpl. repeat autounfold. eauto. 107 | + simpl. repeat autounfold. intros. inversion C; subst. clear C. 108 | eapply Esem_typed_total in H2; eauto. decompose [ex and] H2. rewrite H0. 109 | assert (TypeEnv (t :: g) (x :: env)) as T'. constructor; auto. 110 | destruct (IHc (t :: g) H3 ext R (x :: env) T'). simpl. rewrite H. eauto. 111 | + simpl. repeat autounfold. intros. eauto. 112 | + simpl. repeat autounfold. intros. unfold liftM2, bind. 113 | inversion C. subst. destruct (IHc g H3 ext R env T). 114 | eapply Esem_typed_total in H2; eauto. decompose [and ex] H2. 115 | rewrite H1. inversion H4. simpl. rewrite H. 116 | unfold pure, compose. eauto. 117 | + intros. simpl. unfold delay_trace. inversion C; subst. 118 | assert (TypeExt (adv_ext (Z.of_nat n) ext)) as R' by auto. 119 | destruct (IHc g H1 (adv_ext (Z.of_nat n) ext) R' env T). 120 | rewrite H. simpl. autounfold; eauto. 121 | + intros. simpl. unfold add_trace, add_trans, liftM2, bind. inversion C; subst. 122 | destruct (IHc1 g H2 ext R env T). rewrite H. 123 | destruct (IHc2 g H3 ext R env T). rewrite H0. 124 | unfold pure, compose. eauto. 125 | + simpl. induction n; intros;inversion C; subst. 126 | - simpl. eapply Esem_typed_total in H3; eauto. decompose [and ex] H3. 127 | rewrite H0. inversion H1. destruct b; eauto. 128 | - simpl. eapply Esem_typed_total in H3; eauto. decompose [and ex] H3. 129 | rewrite H0. inversion H1. destruct b; eauto. 130 | assert (TypeExt (adv_ext 1 ext)) as R' by auto. 131 | assert (g |-C If e n c1 c2) as C' by (inversion C; constructor;auto). 132 | destruct (IHn g C' (adv_ext 1 ext) R' env T). 133 | rewrite H2. simpl. autounfold. eauto. 134 | Qed. -------------------------------------------------------------------------------- /Haskell/Architecture.lhs: -------------------------------------------------------------------------------- 1 | \documentclass{article} 2 | 3 | \usepackage[utf8]{inputenc} 4 | \usepackage[T1]{fontenc} 5 | 6 | \usepackage{color} 7 | \usepackage{graphicx} 8 | \usepackage{wrapfig} 9 | 10 | \usepackage{listings} 11 | \lstloadlanguages{Haskell} 12 | % auto-colorisation with listings, handy for known languages... 13 | \lstdefinestyle{hsstyle}{ 14 | basicstyle=\small,%\sffamily, 15 | language=haskell, 16 | emphstyle={\bf}, 17 | commentstyle=\it, 18 | stringstyle=\mdseries\rmfamily, 19 | keywordstyle=\bfseries\rmfamily, 20 | % 21 | escapeinside={*'}{'*}, 22 | showspaces=false, 23 | showstringspaces=false, 24 | morecomment=[l]\%, 25 | % 26 | stepnumber=1, 27 | numbers=left, 28 | numberstyle=\ttfamily\tiny\color[gray]{0.3}, 29 | numbersep=5pt, 30 | } 31 | \lstnewenvironment{code} 32 | {\lstset{basicstyle=\scriptsize,style=hsstyle,frame=tlrb}} 33 | {} 34 | \lstnewenvironment{mlcodesmall} 35 | {\lstset{basicstyle=\tiny,style=hsstyle,frame=tlrb}} 36 | {} 37 | \lstset{style=hsstyle,keepspaces=true,breaklines=false}\newcommand{\cd}[1]{\lstinline$#1$} 38 | 39 | 40 | %\author{Jost Berthold \and Martin Elsman} 41 | 42 | \begin{document} 43 | 44 | This is (tex-style) literate Haskell. 45 | Enclose code like this: 46 | \begin{code} 47 | {-# LANGUAGE RankNTypes #-} 48 | module Architecture 49 | where 50 | 51 | import Data.List 52 | import Data.Maybe 53 | import System.Random 54 | import Control.Monad.ST 55 | \end{code} 56 | and use suitable typesetting packages for code to enable latex. 57 | 58 | \bigskip 59 | \hrule 60 | \bigskip 61 | 62 | \paragraph*{The Big Picture:} to build software which enables a code-generation 63 | and parallelism approach to financial computations, 64 | using the \cd{Contracts.hs} module as a starting point. 65 | % 66 | While allowing for partial evaluation and parallelising compilation, 67 | everything should be modular in the architecture. 68 | 69 | \begin{center} 70 | \includegraphics[width=\textwidth]{../doc/TheBigPicture}\\ 71 | \end{center} 72 | 73 | \section*{Modules and key interface functions} 74 | 75 | \paragraph*{Contracts Module:} The core multiparty contract. 76 | 77 | \begin{code} 78 | -- dummy definitions 79 | type Contract = () 80 | type Date = Int 81 | 82 | -- | an environment with phantom type 't' to constrain its domain 83 | data Env t a = Env ((String, Date) -> a) 84 | 85 | -- | Dependency type indexed with domain constraint 86 | data Dep t = Dep [(String, Date)] 87 | 88 | -- | generates the payoff function and constraints for the env. 89 | genPayoff :: Fractional a => Contract -> forall t . ( Env t a -> a, Dep t) 90 | genPayoff c = (undefined, undefined) 91 | \end{code} 92 | 93 | \paragraph*{Instruments Module:} many functions which create standard contracts 94 | \begin{code} 95 | -- ... 96 | \end{code} 97 | 98 | \paragraph*{Model Module:} 99 | producing a (stochastic) model from given dependencies. 100 | 101 | \begin{code} 102 | -- | this all should probably rather be called a stochastic process... 103 | newtype Seed t = Seed Int 104 | newtype MkEnv t = MkEnv (Seed t -> Env t) 105 | 106 | -- | create a model from given dependencies, querying market data 107 | model :: Dep t -> IO (MkEnv t) 108 | model (Dep cs) 109 | = do let os = map fst cs 110 | ds = nub (sort (map snd cs)) 111 | cs' = [ (o,ds) | o <- os ] 112 | mds <- mapM getMarketData cs' 113 | let f s = Env $ \(x,d) -> fromJust (lookup x (zip os mds)) $ (s,d) 114 | return (MkEnv f) 115 | 116 | getMarketData :: (String, [Date]) -> IO ((Seed t, Date) -> Double) 117 | getMarketData _ = undefined 118 | \end{code} 119 | 120 | \paragraph*{Pricing Module:} 121 | where it all fits together 122 | 123 | \begin{code} 124 | -- | Monte-Carlo price of a contract, given certain market data 125 | 126 | price :: Int -> Contract -> IO Double 127 | price n c = do let (payoff, dep) = genPayoff c 128 | MkEnv m <- model dep 129 | let vs = map (\s -> payoff (m s)) seeds 130 | return (avg vs) 131 | where avg xs = sum xs / fromIntegral n 132 | seeds = map Seed [1..n] 133 | \end{code} 134 | 135 | This is somewhat primitive... and these are not in fact seeds... 136 | 137 | And: no discounting is included. Needs refinement. 138 | 139 | \newpage 140 | 141 | \section*{Another snippet of draft code\ldots} 142 | This might end up in the future HQL library. 143 | 144 | \paragraph*{Just some dummy definitions...}: 145 | \begin{code} 146 | type Cash = Double 147 | data Swap = Swap 148 | data SomeBond = SomeBond 149 | \end{code} 150 | 151 | \paragraph*{Instruments} are probably just derivatives. 152 | Bonds are instruments, but a bond is also a type class in itself, 153 | with different kinds of bond as its instances. A swap is an instrument. 154 | \begin{code} 155 | class Instrument i where 156 | someX :: Model m => m -> i -> Cash 157 | someX = undefined 158 | 159 | class (Instrument b) => Bond b where 160 | something :: b -> Int 161 | something = undefined 162 | 163 | instance Instrument SomeBond 164 | instance Bond SomeBond 165 | \end{code} 166 | 167 | \paragraph*{Models} are used to price instruments in a pricing engine. 168 | \begin{code} 169 | class Model m where 170 | someY :: Instrument i => i -> m -> Cash 171 | someY = undefined 172 | 173 | data TermStructure = TermStructure (Double -> Double) 174 | data OtherModel = Other (Int -> Double) 175 | 176 | instance Model TermStructure 177 | instance Model OtherModel 178 | \end{code} 179 | 180 | \paragraph*{Pricing engine} is where instruments and models are joined. 181 | \begin{code} 182 | class (Instrument i, Model p) => PricingEngine i p where 183 | pv :: i -> p -> Cash 184 | pv = undefined 185 | 186 | instance PricingEngine SomeBond TermStructure 187 | instance PricingEngine SomeBond OtherModel 188 | instance PricingEngine Swap OtherModel 189 | \end{code} 190 | 191 | \end{document} 192 | -------------------------------------------------------------------------------- /SML/ContractTriggers.sml: -------------------------------------------------------------------------------- 1 | structure ContractTriggers = struct 2 | 3 | open ContractBase Contract; 4 | 5 | (* 6 | more JB notes about "trigger value extraction": 7 | 8 | collecting triggers: 9 | 10 | simpleTriggers : contr -> boolE list 11 | 12 | triggers : contr -> (realE (obs, actually)* real list) list 13 | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ 14 | it could be 15 | (realE * real list) list ; grouped by the actual obs 16 | (string * int * real list) list ; grouped by the actual obs, decomposed 17 | (X) 18 | (string * (int * real list) list ) list ; grouped by observable, then by day 19 | (int * (string * real list) list ) list ; grouped by day, then observable 20 | 21 | Better: use a "time window" rather than single days. 22 | (merge becomes more complicated, well-understood) 23 | 24 | Similar to (X) above: 25 | (string * ((int,int) * real list) list 26 | start,end 27 | 28 | *) 29 | 30 | fun mergeUniq xs [] = xs 31 | | mergeUniq [] ys = ys 32 | | mergeUniq (x::xs) (y::ys) 33 | = case Real.compare (x,y) of 34 | LESS => x :: mergeUniq xs (y::ys) 35 | | GREATER => y :: mergeUniq (x::xs) ys 36 | | EQUAL => x :: mergeUniq xs ys 37 | 38 | fun trMerge' (tr as (s,(d1,d2),vs), []) = [tr] 39 | | trMerge' (tr as (s,(d1,d2),vs), ((tr' as (s',(d1',d2'),vs')) :: trs)) 40 | = if s = s' then 41 | (* compares intervals and splits into several (2 or 3) resulting ones: 42 | --------------------- (3 resulting, overlap) 43 | ---------------------- 44 | 45 | ------------- 46 | ---------------------- (3 resulting, inclusion) 47 | 48 | ------- ------- (2 resulting, disjoint) 49 | 50 | ----------- (2 results, simple inclusion) 51 | ------------------ 52 | 53 | ------|----- and vs = vs' (merge opportunity) 54 | *) 55 | (* merge opportunity. However, might be desirable to keep apart 56 | if vs = vs' andalso (d2 = d1'+1 orelse d1 = d2'+1) 57 | then trMerge' ((s, (Int.min (d1,d1'), Int.max (d2,d2')), vs), trs) 58 | else *) 59 | if d2 < d1' orelse d2' < d1 (* disjoint, continue merging *) 60 | then tr' :: trMerge' (tr, trs) 61 | else 62 | if d1 = d1' 63 | then if d2 = d2' (* identical ranges: *) 64 | then (s,(d1,d2), mergeUniq vs vs') :: trs 65 | else (* simple inclusion, and we know d2 <> d2' *) 66 | let val vs'' = if d2 < d2' then vs' else vs 67 | val lo = Int.min (d2, d2') 68 | in trMerge ((s,(d1,lo), mergeUniq vs vs') :: 69 | (s,(lo+1,Int.max (d2,d2')), vs'') :: trs) 70 | end 71 | else if d2 = d2' (* simple inclusion, d1 <> d1' *) 72 | then let val vs'' = if d1 < d1' then vs else vs' 73 | val hi = Int.max (d1, d1') 74 | in trMerge ((s,(Int.min (d1,d1'),hi), vs'') :: 75 | (s,(hi+1,d2), mergeUniq vs vs') :: trs) 76 | end 77 | else (* d1 <> d1', d2 <> d2' *) 78 | if d1 < d1' andalso d2' < d2 (* inclusion of tr' *) 79 | then trMerge ((s,(d1,d1'-1), vs) :: 80 | (s,(d1',d2'), mergeUniq vs vs') :: 81 | (s,(d2'+1,d2), vs) :: trs) 82 | else if d1' < d1 andalso d2 < d2' (* inclusion of tr *) 83 | then trMerge ((s,(d1',d1-1), vs') :: 84 | (s,(d1,d2), mergeUniq vs vs') :: 85 | (s,(d2+1,d2'), vs) :: trs) 86 | else (* real overlap *) 87 | let val v1s = if d1 < d1' then vs else vs' 88 | val v2s = if d2 < d2' then vs' else vs 89 | val (mid1,mid2) = (Int.max (d1,d1'),Int.min (d2,d2')) 90 | in trMerge ((s,(Int.min (d1,d1'),mid1-1), v1s) :: 91 | (s,(mid1,mid2), mergeUniq vs vs') :: 92 | (s,(mid2+1,Int.max (d2,d2')), v2s) :: trs ) 93 | end 94 | else tr' :: trMerge' (tr, trs) (* different observables *) 95 | and trMerge ts = foldl trMerge' [] ts 96 | 97 | (* triggersExp is where new triggers are added: *) 98 | 99 | (* returns a list of triggers (s,(t1,t2),vs) *) 100 | fun triggersExp (t1,t2) (BinOp ("<", e1, Obs(s,d))) 101 | = ([(s,(t1+d,t2+d), [evalR emptyEnv e1])] handle Fail _ => []) 102 | | triggersExp (t1,t2) (BinOp ("<", Obs(s,d), e1)) 103 | = ([(s,(t1+d,t2+d), [evalR emptyEnv e1])] handle Fail _ => []) 104 | | triggersExp (t1,t2) (BinOp ("|", e1, e2)) 105 | = trMerge ((triggersExp (t1,t2) e1) @ (triggersExp (t1,t2) e2)) 106 | | triggersExp (t1,t2) (UnOp ("not", e1)) = triggersExp (t1,t2) e1 107 | (* *) 108 | | triggersExp ts exp = [] 109 | 110 | 111 | (* triggers : (int,int) -> contr -> trigger list (see above) 112 | where (int,int) is start+end relative date, starting at (0,0), 113 | expanded any time a construct introduces a "duration" 114 | *) 115 | fun triggers _ (Zero) = [] 116 | | triggers _ (TransfOne _) = [] 117 | | triggers ts (Scale (_,c)) = triggers ts c 118 | | triggers ts (Both (c1,c2)) = trMerge ((triggers ts c1) @ (triggers ts c2)) 119 | | triggers (t1,t2) (Transl (i,c)) = triggers (t1+i, t2+i) c 120 | | triggers ts (Let (v,e,c)) 121 | = raise Fail "clunky: need to consider v=e everywhere. How? Issue with translate, need an environment..." 122 | | triggers (t1,t2) (If(e,c1,c2)) 123 | = trMerge ((triggersExp (t1,t2) e) @ 124 | (triggers (t1,t2) c1) @ 125 | (triggers (t1,t2) c2)) 126 | | triggers (t1,t2) (CheckWithin (e,d,c1,c2)) 127 | = trMerge ((triggersExp (t1,t2+d) e) @ 128 | (triggers (t1,t2+d) c1) @ 129 | (triggers (t1+d, t2+d) c2)) 130 | 131 | fun ppTriggers [] = "" 132 | | ppTriggers ((s,(i,j),vs)::rest) 133 | = s ^ " from day " ^ Int.toString i ^ " to " ^ Int.toString j ^ 134 | ": " ^ (String.concatWith ", " (map Real.toString vs)) ^ 135 | "\n" ^ ppTriggers rest 136 | 137 | (* *) 138 | 139 | 140 | end 141 | -------------------------------------------------------------------------------- /Haskell/Contract/Transform.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | module Contract.Transform 3 | ( dual 4 | , advance 5 | , simplify 6 | , elimBranches 7 | ) where 8 | 9 | import Contract.Type 10 | import Contract.Expr 11 | import Contract.Date 12 | import Contract.Environment 13 | 14 | import Data.List 15 | 16 | dual :: Contract -> Contract 17 | dual Zero = zero 18 | dual (TransfOne c p1 p2) = transfOne c p2 p1 19 | dual (Scale e c) = scale e (dual c) 20 | dual (Transl i c) = transl i (dual c) 21 | dual (Both c1 c2) = both (dual c1) (dual c2) 22 | dual (If e c1 c2) = iff e (dual c1) (dual c2) 23 | dual (CheckWithin e i c1 c2) = checkWithin e i (dual c1) (dual c2) 24 | 25 | -- | Remove the given number of days (assumed positive) from a contract 26 | advance :: Int -> MContract -> MContract 27 | advance i (d,c) | i < 0 = error "advance: expecting positive number of days" 28 | | i == 0 = (d,c) 29 | | otherwise = (addDays i d, adv i c) 30 | 31 | adv :: Int -> Contract -> Contract 32 | adv i c = case c of 33 | Zero -> zero 34 | Both c1 c2 -> both (adv i c1) (adv i c2) 35 | Transl i' c -> if i <= i' then transl (i'-i) c 36 | else adv (i-i') c 37 | Scale s c -> scale (translExp s (-i)) (adv i c) 38 | TransfOne _ _ _ -> zero 39 | If b c1 c2 -> iff (translExp b (-i)) (adv i c1) (adv i c2) 40 | CheckWithin e i' c1 c2 41 | -> error "cannot advance into a CheckWithin (simplify first)" 42 | -- Let(v,e,c) => Let(v,translExp(e,~i),adv i c) 43 | 44 | -- | simplify a contract, using fixings from a managed environment ('MEnv') 45 | simplify :: MEnv -> MContract -> MContract 46 | simplify (Env e_d e_f) (c_d, c) = (c_d, simplify0 env c) 47 | where off = dateDiff e_d c_d 48 | env = promote e_f off -- (* e_f o (fn (s,x) => (s,x+off)) *) 49 | 50 | -- | internal simplify, assumes c and env have same reference date 51 | simplify0 :: Env -> Contract -> Contract 52 | simplify0 env c = 53 | case c of 54 | Zero -> zero 55 | Both c1 c2 -> both (simplify0 env c1) (simplify0 env c2) 56 | Scale ob (Both c1 c2) -> 57 | simplify0 env (both (scale ob c1) (scale ob c2)) 58 | Scale r t -> scale (eval env r) (simplify0 env t) 59 | Transl i t' -> transl i (simplify0 (promote env i) t') 60 | TransfOne _ _ _ -> c 61 | If e c1 c2 -> let e' = eval env e 62 | c1' = simplify0 env c1 63 | c2' = simplify0 env c2 64 | in iff e' c1' c2' -- if e known, iff will shorten due to use of the smart constructor "iff" 65 | CheckWithin e i c1 c2 66 | -> let env' = emptyEnv -- (emp,#2 G) 67 | substE = eval env' 68 | substC = simplify0 env' 69 | in case eval env e of 70 | B True -> simplify0 env c1 71 | B False -> simplify0 env 72 | (transl 1 (checkWithin (substE e) (i-1) (substC c1) (substC c2))) 73 | _ -> checkWithin (substE e) i (substC c1) (substC c2) 74 | {- (* 75 | val () = print ("e = " ^ ppExp e ^ "\n") 76 | val () = print ("obs(Time,0) = " ^ ppExp (eval G (obs("Time",0))) ^ "\n") 77 | *) -} 78 | 79 | -- Let(v,e,c) => 80 | -- let val e' = eval G e 81 | -- in if certainExp e' then 82 | -- let val G' = (#1 G, addVE(#2 G,v,e')) 83 | -- in simplify0 G' c 84 | -- end 85 | -- else Let(v,e',simplify0 G c) 86 | 87 | -- | uses values from environment to take known decision alternatives (constructs 'if' and 'checkWithin'). Like 'simplify', but it does not use values for scaling contracts. 88 | elimBranches :: MEnv -> MContract -> MContract 89 | elimBranches (Env e_d e) (c_d,c) = (c_d, elimBrs env c) 90 | where off = dateDiff e_d c_d 91 | env = promote e off 92 | 93 | -- | internal function working on relative dates for env and contract 94 | elimBrs :: Env -> Contract -> Contract 95 | elimBrs env Zero = zero 96 | elimBrs env (Both c1 c2) = both (elimBrs env c1) (elimBrs env c2) 97 | elimBrs env (Scale ob (Both c1 c2)) 98 | = elimBrs env (both (scale ob c1) (scale ob c2)) 99 | elimBrs env (Scale r t) = scale r (elimBrs env t) 100 | elimBrs env (Transl i t') = transl i (elimBrs (promote env i) t') 101 | elimBrs env c@(TransfOne _ _ _) = c 102 | -- the interesting ones: 103 | elimBrs env (If e c1 c2) = 104 | let e' = eval env e 105 | c1' = elimBrs env c1 106 | c2' = elimBrs env c2 107 | in iff e' c1' c2' -- if e known, iff will shorten due to use of the smart constructor "iff" 108 | elimBrs env (CheckWithin e 0 c1 c2) = elimBrs env (If e c1 c2) 109 | -- elimBrs env (CheckWithin e i c1 c2) 110 | -- = let env' = emptyEnv -- (emp,#2 G) 111 | -- substE = eval emptyEnv 112 | -- substC = elimBrs emptyEnv 113 | -- -- MEMO: this was adopted from the simplify0 code in SML; but why are 114 | -- -- we emptying the env? (probably do with variable environment in ML) 115 | -- in case eval env e of 116 | -- B True -> elimBrs env c1 117 | -- B False -> elimBrs env 118 | -- (transl 1 (checkWithin (substE e) (i-1) 119 | -- (substC c1) (substC c2))) 120 | -- _ -> checkWithin (substE e) i (substC c1) (substC c2) 121 | -- -- For the particular application (scenario execution) the function 122 | -- -- should check whether there is a value _anywhere_ within the checked 123 | -- -- range, and use that, instead of leaving it untouched unless e 124 | -- -- evaluates to B False. 125 | elimBrs env (CheckWithin e n c1 c2) 126 | = let vs = map (\d -> eval (promote env d) e) [0..n] -- check all values 127 | firstHit = findIndex (== B True) vs 128 | in case firstHit of 129 | Nothing -> -- never true, but maybe undetermined, cannot just use c2 130 | -- OK to eliminate in c2, but not in c1 (unknown start) 131 | checkWithin e n c1 (elimBrs (promote env n) c2) 132 | Just i -> -- e is B True on day n. No matter what it might 133 | -- be before, use this value to simplify the contract 134 | transl i (elimBrs (promote env i) c1) 135 | -------------------------------------------------------------------------------- /Coq/Makefile: -------------------------------------------------------------------------------- 1 | ############################################################################# 2 | ## v # The Coq Proof Assistant ## 3 | ## "$@" || ( RV=$$?; rm -f "$@"; exit $${RV} ) 234 | 235 | %.v.beautified: 236 | $(COQC) $(COQDEBUG) $(COQFLAGS) -beautify $* 237 | 238 | # WARNING 239 | # 240 | # This Makefile has been automagically generated 241 | # Edit at your own risks ! 242 | # 243 | # END OF WARNING 244 | 245 | -------------------------------------------------------------------------------- /Coq/SimpleCausality.v: -------------------------------------------------------------------------------- 1 | Require Import Causality. 2 | Require Import TranslateExp. 3 | Require Import Tactics. 4 | 5 | (* Simple causality. We define a simple syntactic notion of 6 | causality that conservatively approximates the semantic notion. In 7 | short a contract is syntactically causal if observables and external 8 | choices are never queried at a positive offset. *) 9 | 10 | Open Scope Z. 11 | 12 | (* Causality predicate on expressions *) 13 | 14 | Inductive Epc : Exp -> Prop:= 15 | | epc_obs : forall o i, i <= 0 -> Epc (Obs o i) 16 | | epc_op : forall op es, all Epc es -> Epc (OpE op es) 17 | | epc_var : forall v, Epc (VarE v) 18 | | epc_acc : forall f l z, Epc f -> Epc z -> Epc (Acc f l z). 19 | 20 | 21 | (* Custom induction principle *) 22 | 23 | Definition Epc_ind' : forall P : Exp -> Prop, 24 | (forall (o : ObsLabel) (i : Z), i <= 0 -> P (Obs o i)) -> 25 | (forall (op : Op) (es : list Exp), all Epc es -> all P es -> P (OpE op es)) -> 26 | (forall v : Var, P (VarE v)) -> 27 | (forall (f2 : Exp) (l : nat) (z : Exp), 28 | Epc f2 -> P f2 -> Epc z -> P z -> P (Acc f2 l z)) -> 29 | forall e : Exp, Epc e -> P e 30 | := 31 | fun (P : Exp -> Prop) 32 | (f : forall (o : ObsLabel) (i : Z), i <= 0 -> P (Obs o i)) 33 | (f0 : forall (op : Op) (es : list Exp), all Epc es -> all P es -> P (OpE op es)) 34 | (f1 : forall v : Var, P (VarE v)) 35 | (f2 : forall (f2 : Exp) (l : nat) (z : Exp), 36 | Epc f2 -> P f2 -> Epc z -> P z -> P (Acc f2 l z)) => 37 | fix F (e : Exp) (e0 : Epc e) {struct e0} : P e := 38 | match e0 in (Epc e1) return (P e1) with 39 | | epc_obs o i l => f o i l 40 | | epc_op op es f3 => let fix step {es} (ps : all Epc es) : all P es := 41 | match ps in all _ es return all P es with 42 | | forall_nil => forall_nil P 43 | | forall_cons e es p ps' => forall_cons P (F e p) (step ps') 44 | end 45 | in f0 op es f3 (step f3) 46 | | epc_var v => f1 v 47 | | epc_acc f3 l z e1 e2 => f2 f3 l z e1 (F f3 e1) e2 (F z e2) 48 | end. 49 | 50 | (* Causality predicate on contracts. *) 51 | 52 | Inductive Pc : Contr -> Prop := 53 | | pc_transl : forall d c, Pc c -> Pc (Translate d c) 54 | | pc_let : forall e c, Epc e -> Pc c -> Pc (Let e c) 55 | | pc_transf : forall cur p1 p2, Pc (Transfer cur p1 p2) 56 | | pc_scale : forall e c, Epc e -> Pc c -> Pc (Scale e c) 57 | | pc_both : forall c1 c2, Pc c1 -> Pc c2 -> Pc (Both c1 c2) 58 | | pc_zero : Pc Zero 59 | | pc_if : forall c1 c2 b l, Epc b -> Pc c1 -> Pc c2 -> Pc (If b l c1 c2). 60 | 61 | 62 | Hint Constructors Epc Pc. 63 | 64 | (* Below follows the proof that simple causality is sound (i.e. it 65 | implies semantic causality). *) 66 | 67 | Lemma epc_ext_until (e : Exp) d r1 r2 env : 68 | Epc e -> 0 <= d -> ext_until d r1 r2 -> E[|e|]env r1 = E[|e|]env r2. 69 | Proof. 70 | intros R D O. generalize dependent env. generalize dependent r2. generalize dependent r1. 71 | induction R using Epc_ind'; intros; try solve [simpl; f_equal; auto]. 72 | - simpl; unfold ext_until in O. rewrite O. reflexivity. omega. 73 | - do 4 (eapply all_apply in H0;eauto). 74 | apply map_rewrite in H0. simpl. rewrite H0. reflexivity. 75 | - generalize dependent env. generalize dependent r2. generalize dependent r1. 76 | induction l; intros. 77 | + simpl. apply IHR2. assumption. 78 | + pose (adv_ext_step l (A:=Val)) as RE. simpl in *. do 2 rewrite RE. 79 | erewrite IHl. apply bind_equals. apply IHl. apply ext_until_adv. eapply ext_until_le. eauto. 80 | omega. intros. apply IHR1. apply ext_until_adv. do 2 rewrite adv_ext_iter. apply ext_until_adv. 81 | eapply ext_until_le. apply O. rewrite Nat2Z.inj_succ. 82 | omega. constructor. 83 | Qed. 84 | 85 | (* Causality of (open) contracts *) 86 | 87 | Definition causal' (c : Contr) : Prop := 88 | forall d env r1 r2 t1 t2, ext_until (Z.of_nat d) r1 r2 -> C[|c|]env r1 = Some t1 -> C[|c|] env r2 = Some t2 89 | -> t1 d = t2 d. 90 | 91 | (* The lemma below proves causality of open contracts. *) 92 | 93 | Lemma pc_causal' c : Pc c -> causal' c. 94 | Proof. 95 | intros. induction H; unfold causal' in *; intros; simpl. 96 | 97 | - simpl in *. option_inv_auto. unfold delay_trace. 98 | remember (leb d d0) as C. destruct C. 99 | symmetry in HeqC. apply leb_complete in HeqC. 100 | assert (Z.of_nat d + Z.of_nat(d0 - d) = Z.of_nat d0) as D. 101 | rewrite <- Nat2Z.inj_add. f_equal. omega. 102 | eapply IHPc; eauto. rewrite ext_until_adv with (t:=Z.of_nat d). 103 | rewrite D. eassumption. reflexivity. 104 | - simpl in *. option_inv_auto. erewrite epc_ext_until in H4; eauto. rewrite H4 in H5. 105 | inversion H5. subst. eauto. omega. 106 | - simpl in *. rewrite H0 in H1. inversion H1. reflexivity. 107 | - simpl in *. rewrite epc_ext_until with (r2:=r2) (d:=Z.of_nat d) in H2 by first[eassumption|omega]. 108 | option_inv_auto. rewrite H7 in H3. inversion H3. clear H3. subst. 109 | rewrite H9 in H8. inversion H8. clear H8. subst. 110 | unfold scale_trace, compose. erewrite IHPc by eassumption. reflexivity. 111 | - simpl in *. option_inv_auto. unfold add_trace. f_equal; eauto. 112 | - simpl in *. inversion H0. inversion H1. reflexivity. 113 | - generalize dependent d. generalize dependent r1. generalize dependent r2. 114 | generalize dependent t1. generalize dependent t2. 115 | induction l; intros; simpl in *. 116 | + rewrite epc_ext_until with (r2:=r2) (d:=Z.of_nat d) in * by (eauto;omega). 117 | remember (E[|b|] env r2) as bl. destruct bl;tryfalse. destruct v;tryfalse. 118 | destruct b0; [eapply IHPc1|eapply IHPc2]; eassumption. 119 | +rewrite epc_ext_until with (r2:=r2) (d:=Z.of_nat d) in * by (eauto;omega). 120 | remember (E[|b|] env r2) as bl. destruct bl;tryfalse. destruct v;tryfalse. 121 | destruct b0. eapply IHPc1; eassumption. 122 | option_inv_auto. pose (IHl _ _ _ H5 _ H6) as IH. 123 | unfold delay_trace in *. remember (leb 1 d) as L. destruct L;try reflexivity. eapply IH. 124 | symmetry in HeqL. apply leb_complete in HeqL. rewrite Nat2Z.inj_sub by assumption. 125 | apply ext_until_adv_1. apply inj_le in HeqL. assumption. assumption. 126 | Qed. 127 | 128 | (* Soundness of simple causality. *) 129 | 130 | Theorem pc_causal c : Pc c -> causal c. 131 | Proof. 132 | unfold causal. intros. eapply pc_causal';eauto. 133 | Qed. 134 | 135 | (* Below we give a decision procedure for simple causality and prove 136 | it sound and complete. *) 137 | 138 | Open Scope bool. 139 | 140 | Fixpoint epc_dec (e : Exp) : bool := 141 | match e with 142 | | Obs _ i => Z.leb i 0 143 | | OpE _ args => let fix run es := 144 | match es with 145 | | nil => true 146 | | e' :: es' => epc_dec e' && run es' 147 | end 148 | in run args 149 | | VarE _ => true 150 | | Acc f _ z => epc_dec f && epc_dec z 151 | end. 152 | 153 | Require Import Tactics. 154 | 155 | Lemma epc_dec_correct (e : Exp) : epc_dec e = true <-> Epc e. 156 | Proof. 157 | split. 158 | - intro D. induction e using Exp_ind'; simpl in *; try first [rewrite Z.leb_le in D| 159 | repeat rewrite Bool.andb_true_iff in D; decompose [and] D]; auto. 160 | constructor. induction H. 161 | + auto. 162 | + constructor. destruct (epc_dec x); tryfalse. auto. 163 | apply IHall. destruct ((fix run (es : list Exp) : bool := 164 | match es with 165 | | Datatypes.nil => true 166 | | e' :: es' => epc_dec e' && run es' 167 | end) xs). reflexivity. rewrite Bool.andb_false_r in *. tryfalse. 168 | 169 | - intros D. induction D using Epc_ind'; try first [simpl; rewrite IHD1, IHD2| apply Z.leb_le]; auto. 170 | induction H0. 171 | + auto. 172 | + simpl in *. rewrite IHall. rewrite H0. reflexivity. inversion H. auto. 173 | Qed. 174 | 175 | 176 | Fixpoint pc_dec (c : Contr) : bool := 177 | match c with 178 | | Zero => true 179 | | Let e c => epc_dec e && pc_dec c 180 | | Transfer _ _ _ => true 181 | | Scale e c => epc_dec e && pc_dec c 182 | | Translate _ c => pc_dec c 183 | | Both c1 c2 => pc_dec c1 && pc_dec c2 184 | | If e _ c1 c2 => epc_dec e && pc_dec c1 && pc_dec c2 185 | end. 186 | 187 | Theorem pc_dec_correct (c : Contr) : pc_dec c = true <-> Pc c. 188 | Proof. 189 | split. 190 | - intro D. induction c; simpl in *; 191 | try first [repeat rewrite Bool.andb_true_iff in D; decompose [and] D 192 | |rewrite Z.leb_le in D]; auto. 193 | + rewrite -> epc_dec_correct in H. auto. 194 | + rewrite -> epc_dec_correct in H. auto. 195 | + rewrite epc_dec_correct in H1. auto. 196 | - intros D. induction D; simpl; try first [rewrite IHD1, IHD2| apply Z.leb_le]; auto. 197 | + rewrite <- epc_dec_correct in H. rewrite H, IHD. auto. 198 | + rewrite <-epc_dec_correct in H. rewrite H. auto. 199 | + rewrite <-epc_dec_correct in H. rewrite H. auto. 200 | Qed. 201 | -------------------------------------------------------------------------------- /SML/multicontracts.sml: -------------------------------------------------------------------------------- 1 | structure multicontracts = struct 2 | 3 | (* our own date library, day-precision and support for arithmetic *) 4 | open DateUtil 5 | 6 | (* Contracts *) 7 | datatype currency = EUR | DKK | SEK | USD | GBP | JPY 8 | fun pp_cur EUR = "EUR" 9 | | pp_cur DKK = "DKK" 10 | | pp_cur SEK = "SEK" 11 | | pp_cur USD = "USD" 12 | | pp_cur GBP = "GBP" 13 | | pp_cur JPY = "JPY" 14 | 15 | datatype certainty = Certain | Uncertain 16 | fun pp_certainty Certain = "Certain " 17 | | pp_certainty Uncertain = "Uncertain" 18 | 19 | (* Observables *) 20 | structure Obs = struct 21 | datatype t = 22 | Const of real 23 | | Underlying of string * Date.date 24 | | Mul of t * t 25 | | Add of t * t 26 | | Sub of t * t 27 | | Max of t * t 28 | 29 | (* Evaluation utility function on observables *) 30 | exception Eval 31 | fun eval E obs = 32 | let fun max r1 r2 = if r1 > r2 then r1 else r2 33 | in case obs of 34 | Const r => r 35 | | Underlying arg => 36 | let val obs = E arg 37 | in case obs of 38 | Underlying arg1 => 39 | if #1 arg = #1 arg1 40 | andalso Date.compare (#2 arg, #2 arg1) = EQUAL 41 | then raise Eval 42 | else eval E obs 43 | | _ => eval E obs 44 | end 45 | | Mul(obs1,obs2) => eval E obs1 * eval E obs2 46 | | Add(obs1,obs2) => eval E obs1 + eval E obs2 47 | | Sub(obs1,obs2) => eval E obs1 - eval E obs2 48 | | Max(obs1,obs2) => max (eval E obs1) (eval E obs2) 49 | end 50 | 51 | fun evalOpt E obs = 52 | SOME (eval E obs) handle Eval => NONE 53 | 54 | fun pp obs = 55 | let fun par s = "(" ^ s ^ ")" 56 | in case obs of 57 | Const r => Real.toString r 58 | | Underlying(s,d) => "[" ^ s ^ ":" ^ DateUtil.ppDate d ^ "]" 59 | | Mul(o1,o2) => par(pp o1 ^ "*" ^ pp o2) 60 | | Add(o1,o2) => par(pp o1 ^ "+" ^ pp o2) 61 | | Sub(o1,o2) => par(pp o1 ^ "-" ^ pp o2) 62 | | Max(o1,o2) => "max(" ^ pp o1 ^ "," ^ pp o2 ^ ")" 63 | end 64 | 65 | fun certainty t = 66 | case t of 67 | Const _ => true 68 | | Underlying _ => false 69 | | Mul(o1,o2) => certainty o1 andalso certainty o2 70 | | Add(o1,o2) => certainty o1 andalso certainty o2 71 | | Sub(o1,o2) => certainty o1 andalso certainty o2 72 | | Max(o1,o2) => certainty o1 andalso certainty o2 73 | 74 | (* Try to simplify an observable by evaluating it *) 75 | fun simplify E obs = 76 | let fun simpl opr o1 o2 = 77 | opr(simplify E o1,simplify E o2) 78 | in (Const(eval E obs)) 79 | handle _ => 80 | case obs of 81 | Const _ => obs 82 | | Underlying _ => obs 83 | | Mul(o1,o2) => simpl Mul o1 o2 84 | | Add(o1,o2) => simpl Add o1 o2 85 | | Sub(o1,o2) => simpl Sub o1 o2 86 | | Max(o1,o2) => simpl Max o1 o2 87 | end 88 | end 89 | 90 | type party = string 91 | 92 | structure Contract = struct 93 | datatype t = 94 | TransfOne of (* Atom: cash flow *) 95 | Date.date * currency * party * party 96 | | Scale of Obs.t * t (* scaling by observable value *) 97 | | All of t list (* combining several contracts *) 98 | | Transl of int * t (* move into the future by some days. 99 | Days argument must be positive! *) 100 | | Dual of t (* invert transfers in a contract *) 101 | | If of (real -> bool) * Obs.t * t 102 | (* conditional (on observable) *) 103 | 104 | fun pp t = 105 | case t of 106 | TransfOne (when,c,from,to) => "TransfOne(" ^ DateUtil.ppDate when ^ "," 107 | ^ pp_cur c ^ "," ^ from ^ "->" ^ to ^ ")" 108 | | Scale (obs, t) => "Scale(" ^ Obs.pp obs ^ "," ^ pp t ^ ")" 109 | | All [] => "emp" 110 | | All ts => "All[" ^ String.concatWith "," (map pp ts) ^ "]" 111 | | Transl (days, t) => "Transl(" ^ Int.toString days ^ "," ^ pp t ^ ")" 112 | | Dual t => "Dual(" ^ pp t ^ ")" 113 | | If (pred, obs, t) => "Conditional on " ^ Obs.pp obs ^ ": " ^ pp t 114 | 115 | (* Shorthand notation *) 116 | fun flow(d,v,c,from,to) = Scale(Obs.Const v,TransfOne(d,c,from,to)) 117 | val emp = All [] 118 | 119 | (* Contract Management *) 120 | fun simplify E t = 121 | case t of 122 | All ts => 123 | let val ts = map (simplify E) ts 124 | in case List.filter (fn All[] => false | _ => true) ts of 125 | [t] => t 126 | | ts => All ts 127 | end 128 | | Dual(All[]) => All[] 129 | | Scale(obs,All[]) => All[] 130 | | Dual(All ts) => simplify E (All(map Dual ts)) 131 | | Scale(obs,All ts) => 132 | simplify E (All (map (fn t => Scale(obs,t)) ts)) 133 | | Scale(obs,t) => 134 | (case Scale(Obs.simplify E obs,simplify E t) of 135 | Scale(o1,Scale(o2,t)) => 136 | simplify E (Scale(Obs.Mul(o1,o2),t)) 137 | | Scale(obs,All[]) => All[] 138 | | t as Scale(Obs.Const r,_) => 139 | if Real.==(r,0.0) then emp else t 140 | | t => t) 141 | | Transl(d,t) => (* Transl should be eliminated, push it inside *) 142 | (case simplify E t of (* do we need this call to simplify? *) 143 | All [] => emp 144 | | TransfOne (date,c,from,to) => TransfOne(addDays d date,c,from,to) 145 | (* do the translate in the date *) 146 | | Scale (obs,t') => simplify E (Scale (obs,Transl(d,t'))) 147 | | All ts => All (List.map (fn t => simplify E (Transl(d,t))) ts) 148 | | Transl(d',t') => simplify E (Transl(d'+d,t')) (* collapse *) 149 | | Dual t' => simplify E (Dual (Transl(d,t'))) 150 | | If (pred,obs,t') => simplify E (If (pred,obs,Transl(d,t'))) 151 | (* XXX should transl this obs as well? ^^^ *) 152 | ) 153 | | Dual t => 154 | (case Dual(simplify E t) of 155 | Dual(Dual t) => simplify E t 156 | | Dual(TransfOne(d,c,from,to)) => TransfOne(d,c,to,from) 157 | | t => t) 158 | | TransfOne _ => t 159 | | If (pred, obs, t') => 160 | let val obs' = Obs.simplify E obs 161 | val t'' = simplify E t' 162 | in case Obs.evalOpt E obs' of 163 | SOME r => if pred r then t'' else emp 164 | | NONE => If (pred, obs', t'') 165 | end 166 | 167 | fun noE _ = raise Fail "noEnv" 168 | 169 | (* Apply a fixing to a contract *) 170 | fun fixing (name,date,value) t = 171 | let fun E arg = 172 | if #1 arg = name 173 | andalso Date.compare (#2 arg, date) = EQUAL 174 | then Obs.Const value 175 | else Obs.Underlying arg 176 | in simplify E t (* should also advance t to date *) 177 | end 178 | 179 | (* Remove the past from a contract *) 180 | fun advance d t = 181 | let val t = simplify noE t 182 | fun adv t = 183 | case t of 184 | TransfOne (dt,c,from,to) => if Date.compare (dt,d) = GREATER 185 | then t else emp (* remove past transfers *) 186 | | Scale(obs,t) => Scale(obs, adv t) 187 | | Transl _ => t 188 | | Dual t => Dual(adv t) 189 | | All ts => All(map adv ts) 190 | | If (p,obs,t') => If (p, obs, adv t') 191 | in simplify noE (adv t) 192 | end 193 | 194 | fun swap (x,y) = (y,x) 195 | 196 | fun today() = ? "2010-10-19" 197 | 198 | (* Future Cash Flows *) 199 | (* XXX can get rid of d parameter now *) 200 | fun cashflows0 E t = 201 | let fun flows sw s d c t = 202 | if Real.== (s, 0.0) then [] 203 | else 204 | case t of 205 | TransfOne (when,cur,from,to) => 206 | let val (from,to) = sw (from,to) 207 | in [(when,cur,from,to,s,if c then Certain else Uncertain)] 208 | end 209 | | Scale(obs,t) => 210 | let val s1 = (Obs.eval E obs) handle _ => 1.0 211 | in flows sw (s * s1) d 212 | (c andalso Obs.certainty obs) t 213 | end 214 | | All ts => List.concat (map (flows sw s d c) ts) 215 | | Transl(d,t) => raise Error "flows sw s d c t" 216 | (* XXX do the translate, quite like the simplify code *) 217 | | Dual t => flows (sw o swap) s d c t 218 | | If (pred, obs, t') => 219 | case Obs.evalOpt E obs of 220 | SOME r => if pred r then flows sw s d c t' (* obs is certain *) 221 | else [] 222 | | NONE => flows sw s d false t' (* obs is uncertain *) 223 | val res = flows (fn x => x) 1.0 (today()) true t 224 | in ListSort.sort 225 | (fn (r1,r2) => Date.compare(#1 r1,#1 r2)) 226 | res 227 | end 228 | 229 | fun cashflows E t : string = 230 | let fun pp (d,cur,from,to,r,c) = 231 | DateUtil.ppDate d ^ " " ^ pp_certainty c ^ " " ^ 232 | pp_cur cur ^ " " ^ Real.toString r ^ " [" ^ from ^ " -> " ^ to ^ "]" 233 | val res = cashflows0 E t 234 | in String.concatWith "\n" (List.map pp res) 235 | end 236 | end 237 | 238 | end 239 | -------------------------------------------------------------------------------- /SML/Instruments.sml: -------------------------------------------------------------------------------- 1 | structure Instruments = struct 2 | 3 | exception Error of string 4 | 5 | local open Currency ContractSafe in 6 | 7 | infix !+! !-! !*! ! (string,currency) 15 | -> real -> real -> days -> Contract.t 16 | *) 17 | fun fxForward buyer seller (buyCurr, otherCurr) amount strike 0 = 18 | scale (R amount, 19 | all [ transfOne (buyCurr, seller, buyer) 20 | , scale ((R strike), 21 | transfOne (otherCurr, buyer, seller))] 22 | ) 23 | | fxForward buyer seller (buyCurr, otherCurr) amount strike days = 24 | if days > 0 then 25 | transl (days, fxForward buyer seller (buyCurr, otherCurr) amount strike 0) 26 | else raise Error "fxForward into the past" 27 | 28 | 29 | (* all following split into put and call, so we use a tag type *) 30 | datatype OptionKind = Call | Put 31 | 32 | (* buyer and seller with the currencies they receive, 33 | notional amount, strike (sell/buy), expiry (days) 34 | OptionKind -> (string,currency) -> (string,currency) 35 | -> real -> real -> int -> days -> Contract.t 36 | *) 37 | fun vanillaFx Call 38 | buyer seller (buyCurr,otherCurr) amount strike expiry = 39 | let val rate = fxRate buyCurr otherCurr 40 | val cond = chosenBy (buyer ^ ":Call-option",0) 41 | (* R strike ! strike *) 43 | (* offset "0", Transl supposed to move obs date offset!*) 44 | in transl (expiry,iff (cond, fxForward buyer seller 45 | (buyCurr, otherCurr) 46 | amount strike 0 , zero)) 47 | end 48 | | vanillaFx Put 49 | seller buyer (sellCurr,otherCurr) amount strike expiry = 50 | let val rate = fxRate sellCurr otherCurr 51 | val cond = chosenBy (seller ^ ":Put-option",0) 52 | (* obs (rate, 0) ! R barrier ! obs (rate,0) ! not (obs (rate, 0) ! not (R barrier ! R barrier ! obs (rate,0) ! not (obs (rate, 0) ! not (R barrier ! obs (rate, 0) ! R barrier ! not (R barrier ! not (obs (rate, 0) ! R barrier ! obs (rate, 0) ! not (obs (rate, 0) ! not (R barrier ! R barr ! obs (rate,0) ! R barr ! obs (rate,0) ! Val | RVal : R -> Val. 15 | 16 | 17 | 18 | (* Semantics of real expressions. *) 19 | 20 | Fixpoint Acc_sem {A} (f : nat -> A -> A) (n : nat) (z : A) : A := 21 | match n with 22 | | O => z 23 | | S n' => f n (Acc_sem f n' z) 24 | end. 25 | 26 | (* Induction principle for Acc_sem *) 27 | Lemma Acc_sem_ind A (P : A -> Prop) f n z : (forall i (x : A), P x -> P (f i x)) -> 28 | P z -> P (Acc_sem f n z). 29 | Proof. 30 | intros F Z. induction n; simpl;auto. 31 | Qed. 32 | 33 | (* Semantics of operations *) 34 | 35 | Definition OpSem (op : Op) (vs : list Val) : option Val := 36 | match op with 37 | | Add => match vs with ([RVal x; RVal y ]) => Some (RVal (x + y)) | _ => None end 38 | | Sub => match vs with ([RVal x; RVal y ]) => Some (RVal (x - y)) | _ => None end 39 | | Mult => match vs with ([RVal x; RVal y ]) => Some (RVal (x * y)) | _ => None end 40 | | Div => match vs with ([RVal x; RVal y ]) => Some (RVal (x / y)) | _ => None end 41 | | And => match vs with ([BVal x; BVal y ]) => Some (BVal (x && y)) | _ => None end 42 | | Or => match vs with ([BVal x; BVal y ]) => Some (BVal (x || y)) | _ => None end 43 | | Less => match vs with ([RVal x; RVal y ]) => Some (BVal (Rltb x y)) | _ => None end 44 | | Leq => match vs with ([RVal x; RVal y ]) => Some (BVal (Rleb x y)) | _ => None end 45 | | Equal => match vs with ([RVal x; RVal y ]) => Some (BVal (Reqb x y)) | _ => None end 46 | | BLit b => match vs with ([]) => Some (BVal b) | _ => None end 47 | | RLit r => match vs with ([]) => Some (RVal r) | _ => None end 48 | | Cond => match vs with 49 | | ([BVal b; RVal x; RVal y ]) => Some (RVal (if b then x else y)) 50 | | ([BVal b; BVal x; BVal y ]) => Some (BVal (if b then x else y)) 51 | | _ => None end 52 | | Neg => match vs with ([RVal x]) => Some (RVal (0 - x) %R) | _ => None end 53 | | Not => match vs with ([BVal x]) => Some (BVal (negb x)) | _ => None end 54 | end. 55 | 56 | 57 | 58 | Definition ExtEnv := ExtEnv' Val. 59 | 60 | (* (Internal) environments map variables to values. *) 61 | 62 | Definition Env := Env' Val. 63 | 64 | 65 | (* Semantics of expressions. *) 66 | 67 | Reserved Notation "'E[|' e '|]'" (at level 9). 68 | 69 | Definition Fsem {A} (f : Env -> ExtEnv -> option A) (env : Env) (ext : ExtEnv) 70 | := (fun m x => x >>= fun x' => f (x' :: env) (adv_ext (Z.of_nat m) ext)). 71 | 72 | Fixpoint Esem (e : Exp) (env : Env) (ext : ExtEnv) : option Val := 73 | match e with 74 | | OpE op args => sequence (map (fun e => E[|e|] env ext) args) >>= OpSem op 75 | | Obs l i => Some (ext l i) 76 | | VarE v => lookupEnv v env 77 | | Acc f l z => let ext' := adv_ext (- Z.of_nat l) ext 78 | in Acc_sem (Fsem E[|f|] env ext') l (E[|z|] env ext') 79 | end 80 | where "'E[|' e '|]'" := (Esem e ). 81 | 82 | 83 | (* Semantic structures for contracts. *) 84 | 85 | (* An elemtn of type [trans] represents a set of Transfers that a 86 | contract specifies at a particular point in time. It can also be 87 | [None], which indicates that the set of Transfers is undefined (read: 88 | "bottom"). *) 89 | 90 | Definition Trans := Party -> Party -> Asset -> R. 91 | 92 | 93 | Open Scope R. 94 | Definition empty_trans : Trans := fun p1 p2 c => 0. 95 | Definition singleton_trans (p1 p2 : Party) (a : Asset) r : Trans 96 | := if Party.eqb p1 p2 then (fun p1' p2' a' => 0) else 97 | fun p1' p2' a' => if Party.eqb p1 p1' && Party.eqb p2 p2' && Asset.eqb a a' 98 | then r 99 | else if Party.eqb p1 p2' && Party.eqb p2 p1' && Asset.eqb a a' 100 | then -r 101 | else 0. 102 | Definition add_trans : Trans -> Trans -> Trans := fun t1 t2 p1 p2 c => (t1 p1 p2 c + t2 p1 p2 c). 103 | Definition scale_trans : R -> Trans -> Trans := fun s t p1 p2 c => (t p1 p2 c * s). 104 | 105 | 106 | Lemma scale_empty_trans r : scale_trans r empty_trans = empty_trans. 107 | Proof. 108 | unfold scale_trans, empty_trans. rewrite Rmult_0_l. reflexivity. 109 | Qed. 110 | 111 | Lemma scale_trans_0 t : scale_trans 0 t = empty_trans. 112 | Proof. 113 | unfold scale_trans, empty_trans. do 3 (apply functional_extensionality;intro). rewrite Rmult_0_r. reflexivity. 114 | Qed. 115 | 116 | 117 | 118 | Lemma add_empty_trans_l t : add_trans empty_trans t = t. 119 | Proof. 120 | unfold add_trans, empty_trans. do 3 (apply functional_extensionality;intro). rewrite Rplus_0_l. reflexivity. 121 | Qed. 122 | 123 | Lemma add_empty_trans_r t : add_trans t empty_trans = t. 124 | Proof. 125 | unfold add_trans, empty_trans. do 3 (apply functional_extensionality;intro). rewrite Rplus_0_r. reflexivity. 126 | Qed. 127 | 128 | 129 | Hint Resolve scale_empty_trans add_empty_trans_l add_empty_trans_r. 130 | 131 | (* Traces represent the sequence of obligations that a contract 132 | specifies. *) 133 | 134 | Definition Trace := nat -> Trans. 135 | 136 | 137 | 138 | (* The following are combinators to contruct traces. *) 139 | 140 | Definition const_trace (t : Trans) : Trace := fun x => t. 141 | Definition empty_trace : Trace := const_trace empty_trans. 142 | Definition singleton_trace (t : Trans) : Trace 143 | := fun x => match x with 144 | | O => t 145 | | _ => empty_trans 146 | end. 147 | Definition scale_trace (s : R) (t : Trace) : Trace 148 | := scale_trans s ∘ t. 149 | 150 | Lemma scale_trace_0 t : scale_trace 0 t = empty_trace. 151 | Proof. 152 | unfold scale_trace, empty_trace,compose. apply functional_extensionality. intros. 153 | simpl. apply scale_trans_0. 154 | Qed. 155 | 156 | Lemma scale_empty_trace r : scale_trace r empty_trace = empty_trace. 157 | Proof. 158 | unfold scale_trace, empty_trace,compose. apply functional_extensionality. intros. 159 | simpl. apply scale_empty_trans. 160 | Qed. 161 | 162 | 163 | Open Scope nat. 164 | 165 | Definition delay_trace (d : nat) (t : Trace) : Trace := 166 | fun x => if leb d x 167 | then t (x - d) 168 | else empty_trans. 169 | 170 | Definition add_trace (t1 t2 : Trace) : Trace 171 | := fun x => add_trans (t1 x) (t2 x). 172 | 173 | 174 | Lemma add_empty_trace_l t : add_trace empty_trace t = t. 175 | Proof. 176 | unfold add_trace, empty_trace. apply functional_extensionality;intro. apply add_empty_trans_l. 177 | Qed. 178 | 179 | Lemma add_empty_trace_r t : add_trace t empty_trace = t. 180 | Proof. 181 | unfold add_trace, empty_trace. apply functional_extensionality;intro. apply add_empty_trans_r. 182 | Qed. 183 | 184 | 185 | (* Some lemmas about [delay_trace]. *) 186 | 187 | Lemma delay_trace_0 t : delay_trace 0 t = t. 188 | Proof. 189 | apply functional_extensionality. 190 | unfold delay_trace. simpl. intros. f_equal. omega. 191 | Qed. 192 | 193 | Lemma delay_trace_S n i x: delay_trace (S n) x (S i) = delay_trace n x i. 194 | Proof. 195 | unfold delay_trace,compose. cases (leb (S n) (S i)); simpl in Eq; rewrite Eq; reflexivity. 196 | Qed. 197 | 198 | 199 | Lemma delay_empty_trace r : delay_trace r empty_trace = empty_trace. 200 | Proof. 201 | apply functional_extensionality. intros. 202 | unfold delay_trace, empty_trace,const_trace. destruct (leb r x);reflexivity. 203 | Qed. 204 | 205 | Lemma delay_trace_iter d d' t : delay_trace d (delay_trace d' t) = delay_trace (d' + d) t. 206 | Proof. 207 | apply functional_extensionality. induction d'; intros. 208 | simpl. rewrite delay_trace_0. reflexivity. 209 | simpl. unfold delay_trace in *. 210 | remember (leb d x) as L. destruct L; 211 | remember (leb (S d') (x - d)) as L1; destruct L1; 212 | remember (leb (S (d' + d)) x) as L2; destruct L2; 213 | symmetry in HeqL; symmetry in HeqL1; symmetry in HeqL2; 214 | 215 | try apply leb_complete in HeqL; try apply leb_complete in HeqL1; 216 | try apply leb_complete in HeqL2; 217 | try apply leb_complete_conv in HeqL; try apply leb_complete_conv in HeqL1; 218 | try apply leb_complete_conv in HeqL2; f_equal; try omega; try reflexivity. 219 | Qed. 220 | 221 | 222 | Lemma delay_trace_swap d d' e : 223 | delay_trace d (delay_trace d' e) = delay_trace d' (delay_trace d e). 224 | Proof. 225 | repeat rewrite delay_trace_iter. rewrite plus_comm. reflexivity. 226 | Qed. 227 | 228 | (* The following function is needed to define the semantics of [IfWithin]. *) 229 | 230 | Fixpoint within_sem (c1 c2 : Env -> ExtEnv -> option Trace) 231 | (e : Exp) (i : nat) (env : Env) (rc : ExtEnv) : option Trace 232 | := match E[|e|] env rc with 233 | | Some (BVal true) => c1 env rc 234 | | Some (BVal false) => match i with 235 | | O => c2 env rc 236 | | S j => liftM (delay_trace 1) (within_sem c1 c2 e j env (adv_ext 1 rc)) 237 | end 238 | | _ => None 239 | end. 240 | 241 | 242 | (* Semantics of contracts. *) 243 | 244 | Reserved Notation "'C[|' e '|]'" (at level 9). 245 | 246 | Definition toReal (v : Val) : option R := 247 | match v with 248 | | RVal r => Some r 249 | | BVal _ => None 250 | end. 251 | 252 | Fixpoint Csem (c : Contr) (env : Env) (ext : ExtEnv) : option Trace := 253 | match c with 254 | | Zero => Some empty_trace 255 | | Let e c => E[|e|] env ext >>= fun val => C[|c|] (val :: env) ext 256 | | Transfer p1 p2 c => Some (singleton_trace (singleton_trans p1 p2 c 1)) 257 | | Scale e c' => liftM2 scale_trace (E[|e|] env ext >>= toReal) (C[|c'|] env ext) 258 | | Translate d c' => liftM (delay_trace d) (C[|c'|]env (adv_ext (Z.of_nat d) ext)) 259 | | Both c1 c2 => liftM2 add_trace (C[|c1|]env ext) (C[|c2|]env ext) 260 | | If e d c1 c2 => within_sem C[|c1|] C[|c2|] e d env ext 261 | end 262 | where "'C[|' e '|]'" := (Csem e). --------------------------------------------------------------------------------