Skip to content

Commit b1eb732

Browse files
jbertholdjberthold
committed
split triggers.sml into module and test script
1 parent b629953 commit b1eb732

File tree

2 files changed

+178
-128
lines changed

2 files changed

+178
-128
lines changed

‎ContractTriggers.sml

Lines changed: 140 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,140 @@
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

‎triggers.sml

Lines changed: 38 additions & 128 deletions
Original file line numberDiff line numberDiff line change
@@ -1,131 +1,8 @@
1-
app load ["Real", "Int", "ContractBase", "Contract" ];
2-
open ContractBase Contract;
3-
4-
(*
5-
more JB notes about "trigger value extraction":
6-
7-
collecting triggers:
8-
9-
simpleTriggers : contr -> boolE list
10-
11-
triggers : contr -> (realE (obs, actually)* real list) list
12-
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
13-
it could be
14-
(realE * real list) list ; grouped by the actual obs
15-
(string * int * real list) list ; grouped by the actual obs, decomposed
16-
(X)
17-
(string * (int * real list) list ) list ; grouped by observable, then by day
18-
(int * (string * real list) list ) list ; grouped by day, then observable
19-
20-
Better: use a "time window" rather than single days.
21-
(merge becomes more complicated, well-understood)
22-
23-
Similar to (X) above:
24-
(string * ((int,int) * real list) list
25-
start,end
26-
27-
*)
28-
29-
fun mergeUniq xs [] = xs
30-
| mergeUniq [] ys = ys
31-
| mergeUniq (x::xs) (y::ys)
32-
= case Real.compare (x,y) of
33-
LESS => x :: mergeUniq xs (y::ys)
34-
| GREATER => y :: mergeUniq (x::xs) ys
35-
| EQUAL => x :: mergeUniq xs ys
36-
37-
fun trMerge' (tr as (s,(d1,d2),vs), []) = [tr]
38-
| trMerge' (tr as (s,(d1,d2),vs), ((tr' as (s',(d1',d2'),vs')) :: trs))
39-
= if s = s' then
40-
(* compares intervals and splits into several (2 or 3) resulting ones:
41-
--------------------- (3 resulting, overlap)
42-
----------------------
43-
44-
-------------
45-
---------------------- (3 resulting, inclusion)
46-
47-
------- ------- (2 resulting, disjoint)
48-
49-
----------- (2 results, simple inclusion)
50-
------------------
51-
52-
------|----- and vs = vs' (merge opportunity)
53-
*)
54-
(* merge opportunity. However, might be desirable to keep apart
55-
if vs = vs' andalso (d2 = d1'+1 orelse d1 = d2'+1)
56-
then trMerge' ((s, (Int.min (d1,d1'), Int.max (d2,d2')), vs), trs)
57-
else *)
58-
if d2 < d1' orelse d2' < d1 (* disjoint, continue merging *)
59-
then tr' :: trMerge' (tr, trs)
60-
else
61-
if d1 = d1'
62-
then if d2 = d2' (* identical ranges: *)
63-
then (s,(d1,d2), mergeUniq vs vs') :: trs
64-
else (* simple inclusion, and we know d2 <> d2' *)
65-
let val vs'' = if d2 < d2' then vs' else vs
66-
val lo = Int.min (d2, d2')
67-
in trMerge ((s,(d1,lo), mergeUniq vs vs') ::
68-
(s,(lo+1,Int.max (d2,d2')), vs'') :: trs)
69-
end
70-
else if d2 = d2' (* simple inclusion, d1 <> d1' *)
71-
then let val vs'' = if d1 < d1' then vs else vs'
72-
val hi = Int.max (d1, d1')
73-
in trMerge ((s,(Int.min (d1,d1'),hi), vs'') ::
74-
(s,(hi+1,d2), mergeUniq vs vs') :: trs)
75-
end
76-
else (* d1 <> d1', d2 <> d2' *)
77-
if d1 < d1' andalso d2' < d2 (* inclusion of tr' *)
78-
then trMerge ((s,(d1,d1'-1), vs) ::
79-
(s,(d1',d2'), mergeUniq vs vs') ::
80-
(s,(d2'+1,d2), vs) :: trs)
81-
else if d1' < d1 andalso d2 < d2' (* inclusion of tr *)
82-
then trMerge ((s,(d1',d1-1), vs') ::
83-
(s,(d1,d2), mergeUniq vs vs') ::
84-
(s,(d2+1,d2'), vs) :: trs)
85-
else (* real overlap *)
86-
let val v1s = if d1 < d1' then vs else vs'
87-
val v2s = if d2 < d2' then vs' else vs
88-
val (mid1,mid2) = (Int.max (d1,d1'),Int.min (d2,d2'))
89-
in trMerge ((s,(Int.min (d1,d1'),mid1-1), v1s) ::
90-
(s,(mid1,mid2), mergeUniq vs vs') ::
91-
(s,(mid2+1,Int.max (d2,d2')), v2s) :: trs )
92-
end
93-
else tr' :: trMerge' (tr, trs) (* different observables *)
94-
and trMerge ts = foldl trMerge' [] ts
95-
96-
(* triggersExp is where new triggers are added: *)
97-
98-
(* returns a list of triggers (s,(t1,t2),vs) *)
99-
fun triggersExp (t1,t2) (BinOp ("<", e1, Obs(s,d)))
100-
= ([(s,(t1+d,t2+d), [evalR emptyEnv e1])] handle Fail _ => [])
101-
| triggersExp (t1,t2) (BinOp ("<", Obs(s,d), e1))
102-
= ([(s,(t1+d,t2+d), [evalR emptyEnv e1])] handle Fail _ => [])
103-
| triggersExp (t1,t2) (BinOp ("|", e1, e2))
104-
= trMerge ((triggersExp (t1,t2) e1) @ (triggersExp (t1,t2) e2))
105-
| triggersExp (t1,t2) (UnOp ("not", e1)) = triggersExp (t1,t2) e1
106-
(* *)
107-
| triggersExp ts exp = []
108-
109-
110-
(* triggers : (int,int) -> contr -> trigger list (see above)
111-
where (int,int) is start+end relative date, starting at (0,0),
112-
expanded any time a construct introduces a "duration"
113-
*)
114-
fun triggers _ (Zero) = []
115-
| triggers _ (TransfOne _) = []
116-
| triggers ts (Scale (_,c)) = triggers ts c
117-
| triggers ts (Both (c1,c2)) = trMerge ((triggers ts c1) @ (triggers ts c2))
118-
| triggers (t1,t2) (Transl (i,c)) = triggers (t1+i, t2+i) c
119-
| triggers ts (Let (v,e,c))
120-
= raise Fail "clunky: need to consider v=e everywhere. How? Issue with translate, need an environment..."
121-
| triggers (t1,t2) (If(e,c1,c2))
122-
= trMerge ((triggersExp (t1,t2) e) @
123-
(triggers (t1,t2) c1) @
124-
(triggers (t1,t2) c2))
125-
| triggers (t1,t2) (CheckWithin (e,d,c1,c2))
126-
= trMerge ((triggersExp (t1,t2+d) e) @
127-
(triggers (t1,t2+d) c1) @
128-
(triggers (t1+d, t2+d) c2))
1+
(* this is a mosml script for development *)
2+
3+
app load ["Real", "Int", "ContractBase", "Contract", "ContractTriggers" ];
4+
5+
open ContractBase Contract ContractTriggers;
1296

1307
(* copied *)
1318
infix !+! !-! !*! !<! !=! !|! ;
@@ -166,6 +43,39 @@ fun ppTriggers [] = ""
16643
": " ^ (String.concatWith ", " (map Real.toString vs)) ^
16744
"\n" ^ ppTriggers rest
16845

46+
(* some test data *)
47+
infix !+! !-! !*! !<! !=! !|! ;
48+
49+
load "Currency"; open Currency;
50+
51+
fun M n = n*30
52+
fun Y n = n*360
53+
54+
(* Barrier option on "Carlsberg" stock *)
55+
val equity = "Carlsberg"
56+
val maturity = M 3
57+
val ex4if =
58+
let val strike = 50.0
59+
val obs = obs(equity,0)
60+
in checkWithin (R strike !<! obs, maturity,
61+
scale(obs !-! R strike,
62+
transfOne(EUR,"you","me")),
63+
zero)
64+
end
65+
66+
fun mkOpt i s =
67+
let val strike = s
68+
val obs = obs(equity,0)
69+
in checkWithin (R strike !<! obs, M i,
70+
scale(obs !-! R strike,
71+
transfOne(EUR,"you","me")),
72+
zero)
73+
end
74+
75+
val test1 = all (List.tabulate (3, fn di => 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+
16979
val () = (print ("Carlsberg barrier options (settled):\n" ^ ppContr test3);
17080
print "\nTrigger values:\n";
17181
print (ppTriggers (triggers (0,10) test3)))

0 commit comments

Comments
 (0)