9 people like it.

How to write a financial contract

Implements the theory from 'How to write a financial contract' by S.L Peyton Jones and J-M Eber

  1: 
  2: 
  3: 
  4: 
  5: 
  6: 
  7: 
  8: 
  9: 
 10: 
 11: 
 12: 
 13: 
 14: 
 15: 
 16: 
 17: 
 18: 
 19: 
 20: 
 21: 
 22: 
 23: 
 24: 
 25: 
 26: 
 27: 
 28: 
 29: 
 30: 
 31: 
 32: 
 33: 
 34: 
 35: 
 36: 
 37: 
 38: 
 39: 
 40: 
 41: 
 42: 
 43: 
 44: 
 45: 
 46: 
 47: 
 48: 
 49: 
 50: 
 51: 
 52: 
 53: 
 54: 
 55: 
 56: 
 57: 
 58: 
 59: 
 60: 
 61: 
 62: 
 63: 
 64: 
 65: 
 66: 
 67: 
 68: 
 69: 
 70: 
 71: 
 72: 
 73: 
 74: 
 75: 
 76: 
 77: 
 78: 
 79: 
 80: 
 81: 
 82: 
 83: 
 84: 
 85: 
 86: 
 87: 
 88: 
 89: 
 90: 
 91: 
 92: 
 93: 
 94: 
 95: 
 96: 
 97: 
 98: 
 99: 
100: 
101: 
102: 
103: 
104: 
105: 
106: 
107: 
108: 
109: 
110: 
111: 
112: 
113: 
114: 
115: 
116: 
117: 
118: 
119: 
120: 
121: 
122: 
123: 
124: 
125: 
126: 
127: 
128: 
129: 
130: 
131: 
132: 
133: 
134: 
135: 
136: 
137: 
138: 
139: 
140: 
141: 
142: 
143: 
144: 
145: 
146: 
147: 
148: 
149: 
150: 
151: 
152: 
153: 
154: 
155: 
156: 
157: 
158: 
159: 
160: 
161: 
162: 
163: 
164: 
165: 
166: 
167: 
168: 
169: 
170: 
171: 
172: 
173: 
174: 
175: 
176: 
177: 
178: 
179: 
180: 
181: 
182: 
183: 
184: 
185: 
186: 
187: 
188: 
189: 
190: 
191: 
192: 
193: 
194: 
195: 
196: 
197: 
198: 
199: 
200: 
201: 
202: 
203: 
204: 
205: 
206: 
207: 
208: 
209: 
210: 
211: 
212: 
213: 
214: 
215: 
216: 
//Implements the theory from 'How to write a financial contract' by S.L Peyton Jones 
//and J-M Eber

type RandomVariable<'a> = seq<'a>

type Process<'a> = Process of (seq<RandomVariable<'a>>)
    
let liftP f (Process(p)) =  Process(Seq.map (Seq.map f) p)
    
let liftP2 f (Process(p1)) (Process(p2)) = 
    Process(Seq.map2 (Seq.map2 f) p1 p2) 
    
let seq_map3 f xs1 xs2 xs3 = 
  Seq.zip3 xs1 xs2 xs3 |> Seq.map (fun (a,b,c) -> f a b c)    
    
let liftP3 f (Process(p1)) (Process(p2)) (Process(p3))= 
    Process(seq_map3 (seq_map3 f) p1 p2 p3)     

type Obs<'a when 'a :comparison> = Obs of (float -> Process<'a>)

type Currency = 
    |USD 
    |EUR
    |JPY 
    |GBP 

type Contract = 
    | Zero
    | One of Currency
    | Give of Contract
    | And of Contract * Contract
    | Or of Contract * Contract
    | Scale of float Obs * Contract 
    | Anytime of bool Obs * Contract 
    | Cond of bool Obs * Contract * Contract 
    | When of bool Obs * Contract //<--
    | Until of bool Obs * Contract

let when' o c = When(o,c)
let anytime o c = Anytime(o,c)

let rec always x = seq { yield x; yield! always x}

let K x = Process  (always (always x))
let konst a = Obs (fun t -> K a) 
let scaleK x c = Scale ((konst x), c)

let TempInParis = konst 9.7

let rec generate_time t = seq{ yield always t ; yield! generate_time (t + 1.) }

let date = Obs (fun t -> Process(generate_time 0.) )

let lift  f (Obs (o)) = Obs (fun t -> liftP f (o t))
let lift2 f (Obs(o1)) (Obs(o2)) = Obs(fun t -> liftP2 f (o1 t) (o2 t) )

let eq_obs a b = a = b

let at (t:float) = lift2 (fun x y -> eq_obs x y) date (konst t)

let zcb t x k = when' (at t) (scaleK x (One k)) //Zero Coupon Bond

let european t u = when' (at t) (Or(u,Zero))

let (%>=) a b = lift2 (>=) a b
let (%<=) a b = lift2 (<=) a b

let between t1 t2 = lift2 (&&) (date %>= t1) (date %<= t2)

let american (t1, t2) u = anytime (between t1 t2) u

let oneBuck = One USD;;
let hundredBucks = Scale((konst 100.),oneBuck);;

let add_obs = liftP2 (+) 
let (%+) = liftP2 (+) 
let minus_obs = liftP2 (-)
let (%-) = liftP2 (-) 
let mult_obs = liftP2 (*) 
let (%*) = liftP2 (*) 
let div_obs = liftP2 (/) 
let (%/) = liftP2 (/) 
let (~-) = liftP (~-)
let max = liftP2 max

let cond = liftP3 (fun b tru fal -> if b then tru else fal)

type Model  = 
    abstract exch  : (Currency -> Currency -> Process<float>)
    abstract disc  : (Currency -> Process<bool>*Process<float> -> Process<float>)
    abstract snell : (Currency -> Process<bool>*Process<float> -> Process<float>)
    abstract absorb: (Currency -> Process<bool>*Process<float> -> Process<float>)

let evalO (Obs(o)) = o 0.

let ff = evalO TempInParis

let rec evalC (m:Model) (cur:Currency) (c:Contract)    =
    let evalC' = evalC m cur
    match c with 
    | Zero -> K 0.
    | One(cur2)  -> m.exch cur cur2 
    | Give(c1)   -> -(evalC' c1) 
    | Scale(o,c1) -> mult_obs (evalO o) (evalC' c1)
    | And(c2,c1) -> add_obs (evalC' c1) (evalC' c2)
    | Or(c2,c1) -> max (evalC' c1) (evalC' c2)
    | Cond(o,c1,c2) -> cond (evalO o) (evalC' c1) (evalC' c2)
    | When(o,c1) -> m.disc cur ((evalO o), (evalC' c1))
    | Anytime(o,c1) -> m.snell cur ((evalO o), (evalC' c1))
    | Until(o,c1) -> m.absorb cur ((evalO o), (evalC' c1))
    
    
let rates (rateNow:float) (delta:float) = 
    
    let rec generateSlice minRate n =  
        seq { yield minRate + 2.*delta*float(n); yield! generateSlice minRate (n+1) }
    
    let rateSlice minRate n = Seq.take n (generateSlice minRate 0)
    
    let rec makeRateSlices rateNow n = 
        seq { 
            yield (rateSlice rateNow n) ; 
            yield! (makeRateSlices (rateNow-delta) (n+1))}
    
    Process(makeRateSlices rateNow 1)
    

open System.Collections.Generic
    
let rateModels = new Dictionary<Currency,Process<float>>()

Seq.iter (fun x -> rateModels.Add x) [ 
    USD, rates 7. 1.; 
    EUR, rates 6. 1.; 
    JPY, rates 8. 1.; 
    GBP, rates 5. 1.; 
    ] 
    
let rateModel k = 
    match rateModels.TryGetValue(k) with
    | true, p -> p
    | _   , _ -> failwith "invalid currency"
    
let unProc (Process(s)) = s

let rec prevSlice (r:seq<float>) = 
  seq {
            if not (Seq.isEmpty r) then 
                let rest = Seq.skip 1 r
                if not (Seq.isEmpty rest) then 
                
                    let a = Seq.head r
                    let b = Seq.head rest
                                                                    
                    yield ((a + b)/2.)
                
                    yield! prevSlice rest
        
    }
    
let rec discCalc (pb:seq<RandomVariable<bool>>) (pf:seq<RandomVariable<float>>) 
        (rates:seq<RandomVariable<float>>) = 
    seq{
        if not(Seq.isEmpty pb || Seq.isEmpty pf || Seq.isEmpty rates) then
            
            let bRv = Seq.head pb
            let pRv = Seq.head pf
            
            //-- we need a termination condition or as much as it is needed to ensure a level of certainty                       
            if Seq.forall (fun x -> x) (Seq.truncate 10 bRv)   
            then 
                yield pRv
            else
                let rateRv = Seq.head rates
            
                let bs = Seq.skip 1 pb
                let ps = Seq.skip 1 pf
                let rs = Seq.skip 1 rates
                
                let rest = discCalc bs ps rs; 
                
                if not(Seq.isEmpty rest) then
                
                    let nextSlice = Seq.head rest
                    
                    let discSlice = 
                        Seq.map2 (fun x r -> x / (1. + (r/100.))) (prevSlice nextSlice) rateRv
                                        
                    let thisSlice = 
                        seq_map3 (fun b p q -> if b then p else q) bRv pRv discSlice
                    
                    yield thisSlice; yield! rest
    }

let disc k (Process(pb),Process(pf)) = 
    Process(discCalc pb pf (unProc(rateModel k)))

let model = {
    new Model with
        member m.exch   = fun cur1 cur2    -> K 1.
        member m.disc   = disc
        member m.snell  = fun cur1 (pb,pf) -> K 0.5//--
        member m.absorb = 
            fun k (Process(bO),Process(rvs)) -> 
                    Process(Seq.map2 (Seq.map2 (fun o p -> if o then 0. else p)) bO rvs)
}

let GiltStrip = zcb 3.0 10. GBP

let q = evalC model GBP GiltStrip

printf "%A\n" q

printf "%A\n" (evalO (at 3.0))
printf "%A\n" (evalO (date))
printf "%A\n" (rateModel GBP)
Multiple items
val seq : sequence:seq<'T> -> seq<'T>

Full name: Microsoft.FSharp.Core.Operators.seq

--------------------
type seq<'T> = System.Collections.Generic.IEnumerable<'T>

Full name: Microsoft.FSharp.Collections.seq<_>
Multiple items
union case Process.Process: seq<RandomVariable<'a>> -> Process<'a>

--------------------
type Process<'a> = | Process of seq<RandomVariable<'a>>

Full name: Script.Process<_>
type RandomVariable<'a> = seq<'a>

Full name: Script.RandomVariable<_>
val liftP : f:('a -> 'b) -> Process<'a> -> Process<'b>

Full name: Script.liftP
val f : ('a -> 'b)
val p : seq<RandomVariable<'a>>
module Seq

from Microsoft.FSharp.Collections
val map : mapping:('T -> 'U) -> source:seq<'T> -> seq<'U>

Full name: Microsoft.FSharp.Collections.Seq.map
val liftP2 : f:('a -> 'b -> 'c) -> Process<'a> -> Process<'b> -> Process<'c>

Full name: Script.liftP2
val f : ('a -> 'b -> 'c)
val p1 : seq<RandomVariable<'a>>
val p2 : seq<RandomVariable<'b>>
val map2 : mapping:('T1 -> 'T2 -> 'U) -> source1:seq<'T1> -> source2:seq<'T2> -> seq<'U>

Full name: Microsoft.FSharp.Collections.Seq.map2
val seq_map3 : f:('a -> 'b -> 'c -> 'd) -> xs1:seq<'a> -> xs2:seq<'b> -> xs3:seq<'c> -> seq<'d>

Full name: Script.seq_map3
val f : ('a -> 'b -> 'c -> 'd)
val xs1 : seq<'a>
val xs2 : seq<'b>
val xs3 : seq<'c>
val zip3 : source1:seq<'T1> -> source2:seq<'T2> -> source3:seq<'T3> -> seq<'T1 * 'T2 * 'T3>

Full name: Microsoft.FSharp.Collections.Seq.zip3
val a : 'a
val b : 'b
val c : 'c
val liftP3 : f:('a -> 'b -> 'c -> 'd) -> Process<'a> -> Process<'b> -> Process<'c> -> Process<'d>

Full name: Script.liftP3
val p3 : seq<RandomVariable<'c>>
Multiple items
union case Obs.Obs: (float -> Process<'a>) -> Obs<'a>

--------------------
type Obs<'a (requires comparison)> = | Obs of (float -> Process<'a>)

Full name: Script.Obs<_>
Multiple items
val float : value:'T -> float (requires member op_Explicit)

Full name: Microsoft.FSharp.Core.Operators.float

--------------------
type float = System.Double

Full name: Microsoft.FSharp.Core.float

--------------------
type float<'Measure> = float

Full name: Microsoft.FSharp.Core.float<_>
type Currency =
  | USD
  | EUR
  | JPY
  | GBP

Full name: Script.Currency
union case Currency.USD: Currency
union case Currency.EUR: Currency
union case Currency.JPY: Currency
union case Currency.GBP: Currency
type Contract =
  | Zero
  | One of Currency
  | Give of Contract
  | And of Contract * Contract
  | Or of Contract * Contract
  | Scale of Obs<float> * Contract
  | Anytime of Obs<bool> * Contract
  | Cond of Obs<bool> * Contract * Contract
  | When of Obs<bool> * Contract
  | Until of Obs<bool> * Contract

Full name: Script.Contract
union case Contract.Zero: Contract
union case Contract.One: Currency -> Contract
union case Contract.Give: Contract -> Contract
union case Contract.And: Contract * Contract -> Contract
union case Contract.Or: Contract * Contract -> Contract
union case Contract.Scale: Obs<float> * Contract -> Contract
union case Contract.Anytime: Obs<bool> * Contract -> Contract
type bool = System.Boolean

Full name: Microsoft.FSharp.Core.bool
union case Contract.Cond: Obs<bool> * Contract * Contract -> Contract
union case Contract.When: Obs<bool> * Contract -> Contract
union case Contract.Until: Obs<bool> * Contract -> Contract
val when' : o:Obs<bool> -> c:Contract -> Contract

Full name: Script.when'
val o : Obs<bool>
val c : Contract
val anytime : o:Obs<bool> -> c:Contract -> Contract

Full name: Script.anytime
val always : x:'a -> seq<'a>

Full name: Script.always
val x : 'a
val K : x:'a -> Process<'a>

Full name: Script.K
val konst : a:'a -> Obs<'a> (requires comparison)

Full name: Script.konst
val a : 'a (requires comparison)
val t : float
val scaleK : x:float -> c:Contract -> Contract

Full name: Script.scaleK
val x : float
val TempInParis : Obs<float>

Full name: Script.TempInParis
val generate_time : t:float -> seq<seq<float>>

Full name: Script.generate_time
val date : Obs<float>

Full name: Script.date
val lift : f:('a -> 'b) -> Obs<'a> -> Obs<'b> (requires comparison and comparison)

Full name: Script.lift
val f : ('a -> 'b) (requires comparison and comparison)
val o : (float -> Process<'a>) (requires comparison)
val lift2 : f:('a -> 'b -> 'c) -> Obs<'a> -> Obs<'b> -> Obs<'c> (requires comparison and comparison and comparison)

Full name: Script.lift2
val f : ('a -> 'b -> 'c) (requires comparison and comparison and comparison)
val o1 : (float -> Process<'a>) (requires comparison)
val o2 : (float -> Process<'b>) (requires comparison)
val eq_obs : a:'a -> b:'a -> bool (requires equality)

Full name: Script.eq_obs
val a : 'a (requires equality)
val b : 'a (requires equality)
val at : t:float -> Obs<bool>

Full name: Script.at
val y : float
val zcb : t:float -> x:float -> k:Currency -> Contract

Full name: Script.zcb
val k : Currency
val european : t:float -> u:Contract -> Contract

Full name: Script.european
val u : Contract
val a : Obs<'a> (requires comparison)
val b : Obs<'a> (requires comparison)
val between : t1:Obs<float> -> t2:Obs<float> -> Obs<bool>

Full name: Script.between
val t1 : Obs<float>
val t2 : Obs<float>
val american : t1:Obs<float> * t2:Obs<float> -> u:Contract -> Contract

Full name: Script.american
val oneBuck : Contract

Full name: Script.oneBuck
val hundredBucks : Contract

Full name: Script.hundredBucks
val add_obs : (Process<float> -> Process<float> -> Process<float>)

Full name: Script.add_obs
val minus_obs : (Process<int> -> Process<int> -> Process<int>)

Full name: Script.minus_obs
val mult_obs : (Process<float> -> Process<float> -> Process<float>)

Full name: Script.mult_obs
val div_obs : (Process<int> -> Process<int> -> Process<int>)

Full name: Script.div_obs
val max : (Process<float> -> Process<float> -> Process<float>)

Full name: Script.max
val cond : (Process<bool> -> Process<float> -> Process<float> -> Process<float>)

Full name: Script.cond
val b : bool
val tru : float
val fal : float
type Model =
  interface
    abstract member absorb : (Currency -> Process<bool> * Process<float> -> Process<float>)
    abstract member disc : (Currency -> Process<bool> * Process<float> -> Process<float>)
    abstract member exch : (Currency -> Currency -> Process<float>)
    abstract member snell : (Currency -> Process<bool> * Process<float> -> Process<float>)
  end

Full name: Script.Model
abstract member Model.exch : (Currency -> Currency -> Process<float>)

Full name: Script.Model.exch
abstract member Model.disc : (Currency -> Process<bool> * Process<float> -> Process<float>)

Full name: Script.Model.disc
abstract member Model.snell : (Currency -> Process<bool> * Process<float> -> Process<float>)

Full name: Script.Model.snell
abstract member Model.absorb : (Currency -> Process<bool> * Process<float> -> Process<float>)

Full name: Script.Model.absorb
val evalO : Obs<'a> -> Process<'a> (requires comparison)

Full name: Script.evalO
val ff : Process<float>

Full name: Script.ff
val evalC : m:Model -> cur:Currency -> c:Contract -> Process<float>

Full name: Script.evalC
val m : Model
val cur : Currency
val evalC' : (Contract -> Process<float>)
val cur2 : Currency
property Model.exch: Currency -> Currency -> Process<float>
val c1 : Contract
val o : Obs<float>
val c2 : Contract
property Model.disc: Currency -> Process<bool> * Process<float> -> Process<float>
property Model.snell: Currency -> Process<bool> * Process<float> -> Process<float>
property Model.absorb: Currency -> Process<bool> * Process<float> -> Process<float>
val rates : rateNow:float -> delta:float -> Process<float>

Full name: Script.rates
val rateNow : float
val delta : float
val generateSlice : (float -> int -> seq<float>)
val minRate : float
val n : int
val rateSlice : (float -> int -> seq<float>)
val take : count:int -> source:seq<'T> -> seq<'T>

Full name: Microsoft.FSharp.Collections.Seq.take
val makeRateSlices : (float -> int -> seq<seq<float>>)
namespace System
namespace System.Collections
namespace System.Collections.Generic
val rateModels : Dictionary<Currency,Process<float>>

Full name: Script.rateModels
Multiple items
type Dictionary<'TKey,'TValue> =
  new : unit -> Dictionary<'TKey, 'TValue> + 5 overloads
  member Add : key:'TKey * value:'TValue -> unit
  member Clear : unit -> unit
  member Comparer : IEqualityComparer<'TKey>
  member ContainsKey : key:'TKey -> bool
  member ContainsValue : value:'TValue -> bool
  member Count : int
  member GetEnumerator : unit -> Enumerator<'TKey, 'TValue>
  member GetObjectData : info:SerializationInfo * context:StreamingContext -> unit
  member Item : 'TKey -> 'TValue with get, set
  ...
  nested type Enumerator
  nested type KeyCollection
  nested type ValueCollection

Full name: System.Collections.Generic.Dictionary<_,_>

--------------------
Dictionary() : unit
Dictionary(capacity: int) : unit
Dictionary(comparer: IEqualityComparer<'TKey>) : unit
Dictionary(dictionary: IDictionary<'TKey,'TValue>) : unit
Dictionary(capacity: int, comparer: IEqualityComparer<'TKey>) : unit
Dictionary(dictionary: IDictionary<'TKey,'TValue>, comparer: IEqualityComparer<'TKey>) : unit
val iter : action:('T -> unit) -> source:seq<'T> -> unit

Full name: Microsoft.FSharp.Collections.Seq.iter
val x : Currency * Process<float>
Dictionary.Add(key: Currency, value: Process<float>) : unit
val rateModel : k:Currency -> Process<float>

Full name: Script.rateModel
Dictionary.TryGetValue(key: Currency, value: byref<Process<float>>) : bool
val p : Process<float>
val failwith : message:string -> 'T

Full name: Microsoft.FSharp.Core.Operators.failwith
val unProc : Process<'a> -> seq<RandomVariable<'a>>

Full name: Script.unProc
val s : seq<RandomVariable<'a>>
val prevSlice : r:seq<float> -> seq<float>

Full name: Script.prevSlice
val r : seq<float>
Multiple items
val seq : sequence:seq<'T> -> seq<'T>

Full name: Microsoft.FSharp.Core.Operators.seq

--------------------
type seq<'T> = IEnumerable<'T>

Full name: Microsoft.FSharp.Collections.seq<_>
val not : value:bool -> bool

Full name: Microsoft.FSharp.Core.Operators.not
val isEmpty : source:seq<'T> -> bool

Full name: Microsoft.FSharp.Collections.Seq.isEmpty
val rest : seq<float>
val skip : count:int -> source:seq<'T> -> seq<'T>

Full name: Microsoft.FSharp.Collections.Seq.skip
val a : float
val head : source:seq<'T> -> 'T

Full name: Microsoft.FSharp.Collections.Seq.head
val b : float
val discCalc : pb:seq<RandomVariable<bool>> -> pf:seq<RandomVariable<float>> -> rates:seq<RandomVariable<float>> -> seq<RandomVariable<float>>

Full name: Script.discCalc
val pb : seq<RandomVariable<bool>>
val pf : seq<RandomVariable<float>>
val rates : seq<RandomVariable<float>>
val bRv : RandomVariable<bool>
val pRv : RandomVariable<float>
val forall : predicate:('T -> bool) -> source:seq<'T> -> bool

Full name: Microsoft.FSharp.Collections.Seq.forall
val x : bool
val truncate : count:int -> source:seq<'T> -> seq<'T>

Full name: Microsoft.FSharp.Collections.Seq.truncate
val rateRv : RandomVariable<float>
val bs : seq<RandomVariable<bool>>
val ps : seq<RandomVariable<float>>
val rs : seq<RandomVariable<float>>
val rest : seq<RandomVariable<float>>
val nextSlice : RandomVariable<float>
val discSlice : seq<float>
val r : float
val thisSlice : seq<float>
val p : float
val q : float
val disc : k:Currency -> Process<bool> * Process<float> -> Process<float>

Full name: Script.disc
val model : Model

Full name: Script.model
val cur1 : Currency
val pb : Process<bool>
val pf : Process<float>
val bO : seq<RandomVariable<bool>>
val rvs : seq<RandomVariable<float>>
val o : bool
val GiltStrip : Contract

Full name: Script.GiltStrip
val q : Process<float>

Full name: Script.q
val printf : format:Printf.TextWriterFormat<'T> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.printf

More information

Link:http://fssnip.net/3Z
Posted:5 years ago
Author:Ademar Gonzalez
Tags: combinators , finance , contracts , math