Produce LustreV6 from dot topology

dot2lus.ml

+#use "topfind";;
+#require "sasacore";; (* simplified DOT parsing *)
+
+open Sasacore
+
+
+let state_type = "state"
+let action_type = "action"
+let action_number = "actions_number"
+let action_of_int = "action_of_int"
+
+
+let algo_name (node : Topology.node) = Filename.chop_suffix node.file ".ml"
+
+
+let output_prelude output (graph : Topology.t) =
+	graph.nodes
+	|> List.map algo_name
+	|> List.sort_uniq String.compare
+	|> List.iter (Printf.fprintf output "include \"%s.lus\"\n");
+
+	output_string output "\n";
+	let dmin, dmax = Topology.get_degree graph in
+	Printf.fprintf output "const max_degree=%d;\n" dmax;
+	Printf.fprintf output "const min_degree=%d;\n" dmin;
+	Printf.fprintf output "const mean_degree=%f;\n" (Topology.get_mean_degree graph);
+	Printf.fprintf output "const card=%d;\n" (List.length graph.nodes);
+	Printf.fprintf output "const links_number=%d;\n" (Topology.get_nb_link graph);
+	let connected, cyclic = Topology.is_connected_and_cyclic graph in
+	Printf.fprintf output "const is_cyclic=%b;\n" cyclic;
+	Printf.fprintf output "const is_connected=%b;\n" connected;
+	Printf.fprintf output "const is_directed = %b;\n" graph.directed;
+	List.iter
+		(fun (name, value) -> Printf.fprintf output "const %s = %s;\n" name value)
+		graph.attributes;
+
+	output_string output "
+function _first_set<<const N:int>>(s : bool^N) returns (x : int);
+var
+	found : int;
+let
+	found = with (N = 1) then (if s[0] then 0 else -1)
+	        else _first_set<<N-1>>(s[1 .. N-1]);
+	x = if s[0] then 0
+	    else if found < 0 then -1
+	    else found + 1;
+tel;\n";
+
+	Printf.fprintf output "
+function _action_of_activation(activation : bool^%s) returns (action : %s);
+let
+	assert(boolred<<1,%s,%s>>(activation));
+	action = %s(_first_set<<%s>>(activation));
+tel;\n" action_number action_type action_number action_number action_of_int action_number
+
+
+let output_topology output (graph : Topology.t) name =
+	let make_index (graph : Topology.t) : (Topology.node_id -> int) =
+		let index_map = Hashtbl.create (List.length graph.nodes) in
+		graph.nodes
+		|> List.map (fun (n : Topology.node) -> n.id)
+		|> List.iteri (fun index node_id -> Hashtbl.add index_map node_id index);
+		Hashtbl.find index_map (* returns the partially applied find *) in
+
+	let sprint_neighbor_list neighbor_ids : string =
+		match neighbor_ids with
+		| [] -> "[]"
+		| n :: ns ->
+			let prefix, sufix = Printf.sprintf "[ nodes[%d]" n, " ]" in
+			let concat acc n = acc ^ (Printf.sprintf ", nodes[%d]" n) in
+			(List.fold_left concat prefix ns) ^ sufix in
+
+	let index_of_id = make_index graph in
+
+	Printf.fprintf output
+		"\nnode %s(activations : bool^%s^card; initials : %s^card)\n"
+		name action_number state_type;
+
+	Printf.fprintf output
+		"returns (nodes : %s^card; enables : bool^%s^card);\n"
+		state_type action_number;
+
+	output_string output "var\n";
+
+	graph.nodes
+	|> List.iteri (fun i _ -> Printf.fprintf output "\tsel_%d : bool;\n" i);
+
+	output_string output "let\n";
+
+	graph.nodes
+	|> List.iteri (fun i _ ->
+			Printf.fprintf output
+				"\tsel_%d = false -> boolred<<1,%s,%s>>(activations[%d]);\n"
+				i action_number action_number i);
+
+	graph.nodes
+	|> List.iteri (fun i n ->
+		let algo = algo_name n in
+		let neighbors = graph.succ n.id |> List.map (fun (_, id) -> index_of_id id) in
+		let deg = List.length neighbors in
+		let nl = sprint_neighbor_list neighbors in
+		Printf.fprintf output "
+	nodes[%d] = initials[%d] ->
+		if sel_%d
+		then %s_step<<%d>>(pre(nodes[%d]), pre(%s), _action_of_activation(activations[%d]))
+		else pre(nodes[%d]);
+	enables[%d] = %s_enable<<%d>>(nodes[%d], %s);\n"
+			i i i algo deg i nl i i i algo deg i nl);
+
+	output_string output "tel;\n"
+
+
+let graph2lus graph name =
+	let output = open_out (name ^ ".lus") in
+	output_prelude output graph;
+	output_topology output graph name;
+	close_out output
+
+
+let dot2lus dotfile =
+	let graph = Topology.read dotfile in
+	let name = dotfile |> Filename.basename |> Filename.chop_extension in
+	graph2lus graph name
+
+
+let _ =
+	match Array.length Sys.argv with
+	| 2 -> dot2lus Sys.argv.(1)
+	| _ -> print_string "usage: dot2lus <dotfile>\n"; exit 1