1: //Implements the theory from 'How to write a financial contract' by S.L Peyton Jones 
  2: //and J-M Eber
  3: 
  4: type RandomVariable<'a> = seq<'a>
  5: 
  6: type Process<'a> = Process of (seq<RandomVariable<'a>>)
  7:     
  8: let liftP f (Process(p)) =  Process(Seq.map (Seq.map f) p)
  9:     
 10: let liftP2 f (Process(p1)) (Process(p2)) = 
 11:     Process(Seq.map2 (Seq.map2 f) p1 p2) 
 12:     
 13: let seq_map3 f xs1 xs2 xs3 = 
 14:   Seq.zip3 xs1 xs2 xs3 |> Seq.map (fun (a,b,c) -> f a b c)    
 15:     
 16: let liftP3 f (Process(p1)) (Process(p2)) (Process(p3))= 
 17:     Process(seq_map3 (seq_map3 f) p1 p2 p3)     
 18: 
 19: type Obs<'a when 'a :comparison> = Obs of (float -> Process<'a>)
 20: 
 21: type Currency = 
 22:     |USD 
 23:     |EUR
 24:     |JPY 
 25:     |GBP 
 26: 
 27: type Contract = 
 28:     | Zero
 29:     | One of Currency
 30:     | Give of Contract
 31:     | And of Contract * Contract
 32:     | Or of Contract * Contract
 33:     | Scale of float Obs * Contract 
 34:     | Anytime of bool Obs * Contract 
 35:     | Cond of bool Obs * Contract * Contract 
 36:     | When of bool Obs * Contract //<--
 37:     | Until of bool Obs * Contract
 38: 
 39: let when' o c = When(o,c)
 40: let anytime o c = Anytime(o,c)
 41: 
 42: let rec always x = seq { yield x; yield! always x}
 43: 
 44: let K x = Process  (always (always x))
 45: let konst a = Obs (fun t -> K a) 
 46: let scaleK x c = Scale ((konst x), c)
 47: 
 48: let TempInParis = konst 9.7
 49: 
 50: let rec generate_time t = seq{ yield always t ; yield! generate_time (t + 1.) }
 51: 
 52: let date = Obs (fun t -> Process(generate_time 0.) )
 53: 
 54: let lift  f (Obs (o)) = Obs (fun t -> liftP f (o t))
 55: let lift2 f (Obs(o1)) (Obs(o2)) = Obs(fun t -> liftP2 f (o1 t) (o2 t) )
 56: 
 57: let eq_obs a b = a = b
 58: 
 59: let at (t:float) = lift2 (fun x y -> eq_obs x y) date (konst t)
 60: 
 61: let zcb t x k = when' (at t) (scaleK x (One k)) //Zero Coupon Bond
 62: 
 63: let european t u = when' (at t) (Or(u,Zero))
 64: 
 65: let (%>=) a b = lift2 (>=) a b
 66: let (%<=) a b = lift2 (<=) a b
 67: 
 68: let between t1 t2 = lift2 (&&) (date %>= t1) (date %<= t2)
 69: 
 70: let american (t1, t2) u = anytime (between t1 t2) u
 71: 
 72: let oneBuck = One USD;;
 73: let hundredBucks = Scale((konst 100.),oneBuck);;
 74: 
 75: let add_obs = liftP2 (+) 
 76: let (%+) = liftP2 (+) 
 77: let minus_obs = liftP2 (-)
 78: let (%-) = liftP2 (-) 
 79: let mult_obs = liftP2 (*) 
 80: let (%*) = liftP2 (*) 
 81: let div_obs = liftP2 (/) 
 82: let (%/) = liftP2 (/) 
 83: let (~-) = liftP (~-)
 84: let max = liftP2 max
 85: 
 86: let cond = liftP3 (fun b tru fal -> if b then tru else fal)
 87: 
 88: type Model  = 
 89:     abstract exch  : (Currency -> Currency -> Process<float>)
 90:     abstract disc  : (Currency -> Process<bool>*Process<float> -> Process<float>)
 91:     abstract snell : (Currency -> Process<bool>*Process<float> -> Process<float>)
 92:     abstract absorb: (Currency -> Process<bool>*Process<float> -> Process<float>)
 93: 
 94: let evalO (Obs(o)) = o 0.
 95: 
 96: let ff = evalO TempInParis
 97: 
 98: let rec evalC (m:Model) (cur:Currency) (c:Contract)    =
 99:     let evalC' = evalC m cur
100:     match c with 
101:     | Zero -> K 0.
102:     | One(cur2)  -> m.exch cur cur2 
103:     | Give(c1)   -> -(evalC' c1) 
104:     | Scale(o,c1) -> mult_obs (evalO o) (evalC' c1)
105:     | And(c2,c1) -> add_obs (evalC' c1) (evalC' c2)
106:     | Or(c2,c1) -> max (evalC' c1) (evalC' c2)
107:     | Cond(o,c1,c2) -> cond (evalO o) (evalC' c1) (evalC' c2)
108:     | When(o,c1) -> m.disc cur ((evalO o), (evalC' c1))
109:     | Anytime(o,c1) -> m.snell cur ((evalO o), (evalC' c1))
110:     | Until(o,c1) -> m.absorb cur ((evalO o), (evalC' c1))
111:     
112:     
113: let rates (rateNow:float) (delta:float) = 
114:     
115:     let rec generateSlice minRate n =  
116:         seq { yield minRate + 2.*delta*float(n); yield! generateSlice minRate (n+1) }
117:     
118:     let rateSlice minRate n = Seq.take n (generateSlice minRate 0)
119:     
120:     let rec makeRateSlices rateNow n = 
121:         seq { 
122:             yield (rateSlice rateNow n) ; 
123:             yield! (makeRateSlices (rateNow-delta) (n+1))}
124:     
125:     Process(makeRateSlices rateNow 1)
126:     
127: 
128: open System.Collections.Generic
129:     
130: let rateModels = new Dictionary<Currency,Process<float>>()
131: 
132: Seq.iter (fun x -> rateModels.Add x) [ 
133:     USD, rates 7. 1.; 
134:     EUR, rates 6. 1.; 
135:     JPY, rates 8. 1.; 
136:     GBP, rates 5. 1.; 
137:     ] 
138:     
139: let rateModel k = 
140:     match rateModels.TryGetValue(k) with
141:     | true, p -> p
142:     | _   , _ -> failwith "invalid currency"
143:     
144: let unProc (Process(s)) = s
145: 
146: let rec prevSlice (r:seq<float>) = 
147:   seq {
148:             if not (Seq.isEmpty r) then 
149:                 let rest = Seq.skip 1 r
150:                 if not (Seq.isEmpty rest) then 
151:                 
152:                     let a = Seq.head r
153:                     let b = Seq.head rest
154:                                                                     
155:                     yield ((a + b)/2.)
156:                 
157:                     yield! prevSlice rest
158:         
159:     }
160:     
161: let rec discCalc (pb:seq<RandomVariable<bool>>) (pf:seq<RandomVariable<float>>) 
162:         (rates:seq<RandomVariable<float>>) = 
163:     seq{
164:         if not(Seq.isEmpty pb || Seq.isEmpty pf || Seq.isEmpty rates) then
165:             
166:             let bRv = Seq.head pb
167:             let pRv = Seq.head pf
168:             
169:             //-- we need a termination condition or as much as it is needed to ensure a level of certainty                       
170:             if Seq.forall (fun x -> x) (Seq.truncate 10 bRv)   
171:             then 
172:                 yield pRv
173:             else
174:                 let rateRv = Seq.head rates
175:             
176:                 let bs = Seq.skip 1 pb
177:                 let ps = Seq.skip 1 pf
178:                 let rs = Seq.skip 1 rates
179:                 
180:                 let rest = discCalc bs ps rs; 
181:                 
182:                 if not(Seq.isEmpty rest) then
183:                 
184:                     let nextSlice = Seq.head rest
185:                     
186:                     let discSlice = 
187:                         Seq.map2 (fun x r -> x / (1. + (r/100.))) (prevSlice nextSlice) rateRv
188:                                         
189:                     let thisSlice = 
190:                         seq_map3 (fun b p q -> if b then p else q) bRv pRv discSlice
191:                     
192:                     yield thisSlice; yield! rest
193:     }
194: 
195: let disc k (Process(pb),Process(pf)) = 
196:     Process(discCalc pb pf (unProc(rateModel k)))
197: 
198: let model = {
199:     new Model with
200:         member m.exch   = fun cur1 cur2    -> K 1.
201:         member m.disc   = disc
202:         member m.snell  = fun cur1 (pb,pf) -> K 0.5//--
203:         member m.absorb = 
204:             fun k (Process(bO),Process(rvs)) -> 
205:                     Process(Seq.map2 (Seq.map2 (fun o p -> if o then 0. else p)) bO rvs)
206: }
207: 
208: let GiltStrip = zcb 3.0 10. GBP
209: 
210: let q = evalC model GBP GiltStrip
211: 
212: printf "%A\n" q
213: 
214: printf "%A\n" (evalO (at 3.0))
215: printf "%A\n" (evalO (date))
216: printf "%A\n" (rateModel GBP)
217: