OCaml for Financial Modeling

1(* Option types with phantom types *)
2type european
3type american
4type asian
5
6type _ option_style =
7  | European : european option_style
8  | American : american option_style
9  | Asian : asian option_style
10
11type call
12type put
13
14type _ option_type =
15  | Call : call option_type
16  | Put : put option_type
17
18(* Option contract *)
19type ('style, 'otype) option_contract = {
20  style : 'style option_style;
21  otype : 'otype option_type;
22  strike : float;
23  expiry : float;  (* years *)
24  underlying : string;
25}
26
27(* Black-Scholes for European options only *)
28let black_scholes_price
29    (type t)
30    (contract : (european, t) option_contract)
31    ~spot
32    ~vol
33    ~rate
34  : float =
35  
36  let open Float in
37  let d1 =
38    (log (spot / contract.strike) +. (rate +. 0.5 *. vol *. vol) *. contract.expiry)
39    /. (vol *. sqrt contract.expiry)
40  in
41  let d2 = d1 -. vol *. sqrt contract.expiry in
42  
43  (* Standard normal CDF *)
44  let norm_cdf x =
45    0.5 *. (1.0 +. erf (x /. sqrt 2.0))
46  in
47  
48  match contract.otype with
49  | Call ->
50      spot *. norm_cdf d1 -. contract.strike *. exp (~-.rate *. contract.expiry) *. norm_cdf d2
51  | Put ->
52      contract.strike *. exp (~-.rate *. contract.expiry) *. norm_cdf (~-.d2) -. spot *. norm_cdf (~-.d1)
53
54(* Binomial tree for American options *)
55let binomial_tree_price
56    (type t)
57    (contract : (american, t) option_contract)
58    ~spot
59    ~vol
60    ~rate
61    ~steps
62  : float =
63  
64  let dt = contract.expiry /. float_of_int steps in
65  let u = exp (vol *. sqrt dt) in
66  let d = 1.0 /. u in
67  let p = (exp (rate *. dt) -. d) /. (u -. d) in
68  
69  (* Terminal payoffs *)
70  let payoffs = Array.init (steps + 1) (fun i ->
71    let spot_t = spot *. (u ** float_of_int i) *. (d ** float_of_int (steps - i)) in
72    let intrinsic = match contract.otype with
73      | Call -> max 0.0 (spot_t -. contract.strike)
74      | Put -> max 0.0 (contract.strike -. spot_t)
75    in
76    intrinsic
77  ) in
78  
79  (* Backward induction *)
80  for step = steps - 1 downto 0 do
81    for i = 0 to step do
82      let spot_t = spot *. (u ** float_of_int i) *. (d ** float_of_int (step - i)) in
83      
84      (* Continuation value *)
85      let continuation =
86        exp (~-.rate *. dt) *. (p *. payoffs.(i + 1) +. (1.0 -. p) *. payoffs.(i))
87      in
88      
89      (* Exercise value (American option) *)
90      let exercise = match contract.otype with
91        | Call -> max 0.0 (spot_t -. contract.strike)
92        | Put -> max 0.0 (contract.strike -. spot_t)
93      in
94      
95      payoffs.(i) <- max continuation exercise
96    done
97  done;
98  
99  payoffs.(0)
100
101(* Usage enforces correct pricing method at compile time *)
102let () =
103  let eur_call = {
104    style = European;
105    otype = Call;
106    strike = 100.0;
107    expiry = 1.0;
108    underlying = "AAPL";
109  } in
110  
111  let price = black_scholes_price eur_call ~spot:105.0 ~vol:0.25 ~rate:0.02 in
112  Printf.printf "European call price: %.2f\n" price;
113  
114  let amer_put = {
115    style = American;
116    otype = Put;
117    strike = 100.0;
118    expiry = 1.0;
119    underlying = "AAPL";
120  } in
121  
122  let price = binomial_tree_price amer_put ~spot:95.0 ~vol:0.25 ~rate:0.02 ~steps:100 in
123  Printf.printf "American put price: %.2f\n" price
124  
125  (* This won't compile: *)
126  (* let wrong = black_scholes_price amer_put ~spot:95.0 ~vol:0.25 ~rate:0.02 *)
127  (* Error: This expression has type (american, put) option_contract
128            but an expression was expected of type (european, 'a) option_contract *)
129

1(* Market data *)
2type tick = {
3  symbol : string;
4  price : float;
5  size : int;
6  timestamp : float;
7}
8
9type bar = {
10  symbol : string;
11  open_ : float;
12  high : float;
13  low : float;
14  close : float;
15  volume : int;
16  timestamp : float;
17}
18
19(* Signals *)
20type signal =
21  | Buy of { symbol : string; confidence : float }
22  | Sell of { symbol : string; confidence : float }
23  | Hold
24
25(* Strategy interface *)
26module type STRATEGY = sig
27  type state
28  
29  val init : unit -> state
30  val on_tick : state -> tick -> state * signal
31  val on_bar : state -> bar -> state * signal
32end
33
34(* Moving average crossover *)
35module MA_Crossover : STRATEGY = struct
36  type state = {
37    fast_window : float list;
38    slow_window : float list;
39    fast_period : int;
40    slow_period : int;
41    last_signal : signal;
42  }
43  
44  let init () = {
45    fast_window = [];
46    slow_window = [];
47    fast_period = 10;
48    slow_period = 30;
49    last_signal = Hold;
50  }
51  
52  let moving_average prices =
53    let sum = List.fold_left (+.) 0.0 prices in
54    sum /. float_of_int (List.length prices)
55  
56  let on_tick state tick = (state, Hold)  (* Ignore ticks *)
57  
58  let on_bar state bar =
59    (* Update windows *)
60    let fast_window = bar.close :: state.fast_window |> List.take state.fast_period in
61    let slow_window = bar.close :: state.slow_window |> List.take state.slow_period in
62    
63    let state = { state with fast_window; slow_window } in
64    
65    (* Check if we have enough data *)
66    if List.length fast_window < state.fast_period ||
67       List.length slow_window < state.slow_period then
68      (state, Hold)
69    else
70      let fast_ma = moving_average fast_window in
71      let slow_ma = moving_average slow_window in
72      
73      (* Crossover logic *)
74      let signal =
75        if fast_ma > slow_ma then
76          match state.last_signal with
77          | Sell _ | Hold -> Buy { symbol = bar.symbol; confidence = 0.7 }
78          | Buy _ -> Hold
79        else if fast_ma < slow_ma then
80          match state.last_signal with
81          | Buy _ | Hold -> Sell { symbol = bar.symbol; confidence = 0.7 }
82          | Sell _ -> Hold
83        else
84          Hold
85      in
86      
87      ({ state with last_signal = signal }, signal)
88end
89
90(* Strategy combinator: only trade when both strategies agree *)
91module Combine (S1 : STRATEGY) (S2 : STRATEGY) : STRATEGY = struct
92  type state = {
93    s1_state : S1.state;
94    s2_state : S2.state;
95  }
96  
97  let init () = {
98    s1_state = S1.init ();
99    s2_state = S2.init ();
100  }
101  
102  let combine_signals sig1 sig2 =
103    match sig1, sig2 with
104    | Buy b1, Buy b2 ->
105        Buy { b1 with confidence = min b1.confidence b2.confidence }
106    | Sell s1, Sell s2 ->
107        Sell { s1 with confidence = min s1.confidence s2.confidence }
108    | _, _ -> Hold
109  
110  let on_tick state tick =
111    let s1_state, sig1 = S1.on_tick state.s1_state tick in
112    let s2_state, sig2 = S2.on_tick state.s2_state tick in
113    ({ s1_state; s2_state }, combine_signals sig1 sig2)
114  
115  let on_bar state bar =
116    let s1_state, sig1 = S1.on_bar state.s1_state bar in
117    let s2_state, sig2 = S2.on_bar state.s2_state bar in
118    ({ s1_state; s2_state }, combine_signals sig1 sig2)
119end
120

1open Core
2open Incremental.Let_syntax
3
4(* Incremental portfolio risk calculation *)
5module Risk = struct
6  type position = {
7    symbol : string;
8    quantity : int;
9    entry_price : float;
10  }
11  
12  type portfolio = position list
13  
14  (* Incremental variable for positions *)
15  let positions_var = Incremental.Var.create []
16  
17  (* Current prices (incremental) *)
18  let prices_var = Incremental.Var.create String.Map.empty
19  
20  (* Portfolio value (auto-updates when positions or prices change) *)
21  let portfolio_value =
22    let%bind positions = Incremental.Var.watch positions_var in
23    let%bind prices = Incremental.Var.watch prices_var in
24    
25    Incremental.map positions ~f:(fun positions ->
26      List.fold positions ~init:0.0 ~f:(fun acc pos ->
27        match Map.find prices pos.symbol with
28        | Some price -> acc +. float_of_int pos.quantity *. price
29        | None -> acc +. float_of_int pos.quantity *. pos.entry_price
30      )
31    )
32  
33  (* P&L (incremental) *)
34  let pnl =
35    let%bind positions = Incremental.Var.watch positions_var in
36    let%bind prices = Incremental.Var.watch prices_var in
37    
38    Incremental.map2 positions prices ~f:(fun positions prices ->
39      List.fold positions ~init:0.0 ~f:(fun acc pos ->
40        match Map.find prices pos.symbol with
41        | Some price ->
42            let current_value = float_of_int pos.quantity *. price in
43            let cost_basis = float_of_int pos.quantity *. pos.entry_price in
44            acc +. (current_value -. cost_basis)
45        | None -> acc
46      )
47    )
48  
49  (* VaR (95%) using historical simulation *)
50  let var_95 returns_history =
51    let sorted = List.sort ~compare:Float.compare returns_history in
52    let idx = int_of_float (0.05 *. float_of_int (List.length sorted)) in
53    List.nth sorted idx |> Option.value ~default:0.0 |> Float.abs
54  
55  let () =
56    Incremental.stabilize ();
57    
58    (* Update positions *)
59    Incremental.Var.set positions_var [
60      { symbol = "AAPL"; quantity = 100; entry_price = 150.0 };
61      { symbol = "GOOGL"; quantity = 50; entry_price = 2800.0 };
62    ];
63    
64    (* Update prices *)
65    Incremental.Var.set prices_var (
66      String.Map.of_alist_exn [
67        ("AAPL", 155.0);
68        ("GOOGL", 2850.0);
69      ]
70    );
71    
72    Incremental.stabilize ();
73    
74    Printf.printf "Portfolio value: $%.2f\n" (Incremental.observe portfolio_value);
75    Printf.printf "P&L: $%.2f\n" (Incremental.observe pnl)
76end
77

1type order_event =
2  | New of { order_id : string; symbol : string; side : [`Buy | `Sell]; qty : int; price : float }
3  | Modify of { order_id : string; new_qty : int option; new_price : float option }
4  | Cancel of { order_id : string }
5  | Fill of { order_id : string; filled_qty : int; fill_price : float }
6  | PartialFill of { order_id : string; filled_qty : int; remaining_qty : int; fill_price : float }
7  | Reject of { order_id : string; reason : string }
8
9type order_state = {
10  order_id : string;
11  symbol : string;
12  side : [`Buy | `Sell];
13  original_qty : int;
14  remaining_qty : int;
15  price : float;
16  fills : (int * float) list;  (* (quantity, price) *)
17  status : [`Open | `PartiallyFilled | `Filled | `Canceled | `Rejected];
18}
19
20let handle_event state event =
21  match event with
22  | New { order_id; symbol; side; qty; price } ->
23      { order_id; symbol; side;
24        original_qty = qty;
25        remaining_qty = qty;
26        price;
27        fills = [];
28        status = `Open }
29  
30  | Modify { order_id; new_qty; new_price } ->
31      { state with
32        remaining_qty = Option.value new_qty ~default:state.remaining_qty;
33        price = Option.value new_price ~default:state.price }
34  
35  | Cancel { order_id } when state.status = `Open || state.status = `PartiallyFilled ->
36      { state with status = `Canceled }
37  
38  | Fill { order_id; filled_qty; fill_price } ->
39      { state with
40        remaining_qty = 0;
41        fills = (filled_qty, fill_price) :: state.fills;
42        status = `Filled }
43  
44  | PartialFill { order_id; filled_qty; remaining_qty; fill_price } ->
45      { state with
46        remaining_qty;
47        fills = (filled_qty, fill_price) :: state.fills;
48        status = `PartiallyFilled }
49  
50  | Reject { order_id; reason } ->
51      { state with status = `Rejected }
52  
53  | _ -> state  (* Ignore invalid transitions *)
54
55let average_fill_price state =
56  match state.fills with
57  | [] -> None
58  | fills ->
59      let total_qty, total_value =
60        List.fold_left fills ~init:(0, 0.0) ~f:(fun (qty_acc, val_acc) (qty, price) ->
61          (qty_acc + qty, val_acc +. float_of_int qty *. price)
62        )
63      in
64      Some (total_value /. float_of_int total_qty)
65

1Component                Lines    Performance         Uptime
2────────────────────────────────────────────────────────────────────
3Derivatives pricer       3,200    2.3μs/option        99.99%
4Risk aggregator          1,800    500μs/portfolio     99.98%
5Strategy backtester      4,500    1M bars/sec         N/A
6Market data normalizer   2,100    150k msgs/sec       99.995%
7