Sketch

dsl/lib/control.ml

@@ -5,4 +5,49 @@ type t = {
   z_out : State.t -> Packet.t -> State.t;
 }
 
-let of_policy _ = failwith "TBD"
+type addr = Eps | Cons of int * addr
+
+let rec addr_to_string = function
+  | Eps -> "ε"
+  | Cons (i, addr) -> Printf.sprintf "%d ∙ %s" i (addr_to_string addr)
+
+let rec init_state_of_policy (p : Policy.t) s addr =
+  let join plst addr s =
+    let f (i, s) p = (i + 1, init_state_of_policy p s (Cons (i, addr))) in
+    match List.fold_left f (0, s) plst with _, s' -> s'
+  in
+
+  let prefix = addr_to_string addr in
+
+  match p with
+  | Class _ -> s
+  | Fifo plst | Strict plst -> join plst addr s
+  | RoundRobin plst ->
+      let init_rank_ptrs =
+        List.mapi
+          (fun i _ -> (Printf.sprintf "%s_r_%d" prefix i, float_of_int i))
+          plst
+      in
+      s
+      |> State.rebind (Printf.sprintf "%s_turn" prefix) 0.0
+      |> State.rebind_all init_rank_ptrs
+      |> join plst addr
+  | WeightedFair wplst ->
+      let weights =
+        List.mapi
+          (fun i (_, w) -> (Printf.sprintf "%s_w_%d" prefix i, float_of_int w))
+          wplst
+      in
+      s |> State.rebind_all weights |> join (List.map fst wplst) addr
+  | _ -> failwith "TBD"
+
+let z_in_of_policy _ = failwith "TBD"
+let z_out_of_policy _ = failwith "TBD"
+
+let of_policy p =
+  {
+    q = p |> Topo.of_policy |> Pieotree.create;
+    s = init_state_of_policy p (State.create 10) Eps;
+    z_in = z_in_of_policy p;
+    z_out = z_out_of_policy p;
+  }

dsl/lib/packet.ml

@@ -1 +1,3 @@
 type t = unit
+
+let flow = failwith "TBD"

dsl/lib/packet.mli

@@ -1 +1,3 @@
 type t
+
+val flow : t -> Ast.clss

dsl/lib/pieotree.ml

@@ -39,3 +39,6 @@ let rec create (topo : Topo.t) =
       let qs = List.map create topos in
       let p = Pieo.create (fun (_, a, _) (_, b, _) -> Rank.cmp a b) in
       Internal (qs, p)
+
+let rec to_topo t : Topo.t =
+  match t with Leaf _ -> Star | Internal (qs, _) -> Node (List.map to_topo qs)

dsl/lib/pieotree.mli

@@ -4,3 +4,4 @@ val pop : t -> Time.t -> (Packet.t * t) option
 val push : t -> Time.t -> Packet.t -> Path.t -> t
 val size : t -> Time.t -> int
 val create : Topo.t -> t
+val to_topo : t -> Topo.t

dsl/lib/state.ml

@@ -11,4 +11,5 @@ let rebind k v t =
   Hashtbl.add t k v;
   t
 
+let rebind_all lst t = List.fold_left (fun t (k, v) -> rebind k v t) t lst
 let isdefined mem t = Hashtbl.mem t mem

dsl/lib/state.mli

@@ -3,4 +3,5 @@ type t
 val create : int -> t
 val lookup : string -> t -> float
 val rebind : string -> float -> t -> t
+val rebind_all : (string * float) list -> t -> t
 val isdefined : string -> t -> bool

dsl/lib/topo.ml

@@ -12,6 +12,10 @@ let rec of_policy p =
       Node (List.map of_policy plst)
   | WeightedFair wplst -> Node (List.map (fun (p, _) -> of_policy p) wplst)
 
+let rec size = function
+  | Star -> 1
+  | Node ts -> List.fold_left (fun acc x -> acc + size x) 0 ts
+
 (* A few topologies to play with. *)
 let one_level_quaternary = Node [ Star; Star; Star; Star ]
 let one_level_ternary = Node [ Star; Star; Star ]

dsl/lib/topo.mli

@@ -1,6 +1,7 @@
 type t = Star | Node of t list
 
 val of_policy : Policy.t -> t
+val size : t -> int
 
 (* A few topologies to play with. *)
 val one_level_quaternary : t