(* A Crude Priority Queue *)
type xx = ACK | INV | NP of int
type event = {what: xx; whn: float; where: int}
type 'a ml = MT | ML of ('a * 'a ml ref);;

open Printf
let newevent, nextevent, nmt = let elst = ref MT in
((fun e -> let rec nwe el = match !el with
     MT -> el := ML(e, ref MT)
   | ML(a, b) -> if e.whn < a.whn then el := ML(e, ref !el)
             else nwe b in nwe elst),
 (fun _ -> match !elst with ML(a, b) -> (elst := !b; a) | MT -> assert false),
 (fun _ -> match !elst with MT -> false | ML(_, _) -> true));;

(* vestegial unit test
newevent {what=INV; whn=3.2; where=2};
newevent {what=NP(7000); whn=3.1; where=1};; => ()
*)
type node = {bw: float; delay: float; quota: int;
  mutable clear: int; mutable coming: int; mutable waiting: int; mutable sent: int};;

(* sch is a service to schedule network snapshots *)
let sch = let times = [| 0.; 0.0005; 0.04; 1.; 10.5; 1e6 |] and j=ref 0 in
  fun t -> if t > times.(!j) then (j := !j + 1; true) else false
and nc = 20 and ps = 65536 in
let net = Array.init nc (fun j -> {bw = 1e10;
           delay = 0.;
           quota = 1;
           clear=1; coming=1; waiting=0; sent=0})
and newpacket = let pc = ref (3 * nc / 2) in (fun t ->
     pc := !pc - 1; if !pc > 0 then
       (printf "Input at t= %10.7f\n" t; newevent {what = NP(ps); whn = t; where=0}))
and pn n = printf "bw = %e, lat = %4.1f ms, clr = %d, come = %d, wait = %d, snt=%d\n"
     n.bw (1000. *. n.delay) n.clear n.coming n.waiting n.sent
and pe e = printf "e= %s, t=%e, where=%d\n" (match e with
    {what=ACK}->"ACK"|{what=INV}->"INV"|{what=NP _}->"NP") e.whn e.where in
let pnet _ = for j = 0 to nc-1 do pn net.(j) done in
newpacket 0.;
while nmt () do let evn = nextevent () in
 match evn with {whn=w; where=j} -> (if sch w then pnet ();
  if j=nc then (match evn with
       | {what=NP(sz)} -> (printf "Output %d at=%11.8f sec.\n" sz w;
         newevent {what=ACK; whn = w +. net.(nc-1).delay; where=nc-1};
         newevent {what=INV; whn = w +. net.(nc-1).delay +. 1e-7; where=nc-1})
       | {what=ACK} | {what=INV} -> assert false)
  else ((match evn with
   | {what=ACK} -> (assert(net.(j).sent>0); net.(j).sent <- net.(j).sent - 1)
   | {what=NP(sz)} -> (assert (net.(j).coming>0); net.(j).coming <- net.(j).coming-1;
       net.(j).waiting <- net.(j).waiting+1;
       if j>0 then newevent {what=ACK; whn=w +. net.(j-1).delay; where=j-1})
   | {what=INV} -> (net.(j).clear <- net.(j).clear+1));
 while net.(j).clear>0 & net.(j).waiting>0 do newevent {what=NP(ps);
         whn=w +. net.(j).delay +. ((float_of_int (ps*8)) /. net.(j).bw); where=j+1};
        net.(j).clear <- net.(j).clear - 1; net.(j).waiting <- net.(j).waiting - 1;
        net.(j).sent <- net.(j).sent + 1 done;
 while net.(j).coming + net.(j).waiting + net.(j).sent < net.(j).quota do
       if j>0 then newevent {what=INV; whn=w +. net.(j-1).delay; where=j-1}
        else newpacket w;
       net.(j).coming <- net.(j).coming + 1 done)) done;
 pnet();;