diff --git a/test/rdbg-utils/dot.ml b/test/rdbg-utils/dot.ml
new file mode 100644
index 0000000000000000000000000000000000000000..eb95fa006052a81d46b4ccbcb1c9829aa31a3b36
--- /dev/null
+++ b/test/rdbg-utils/dot.ml
@@ -0,0 +1,313 @@
+
+#require "ocamlgraph";;
+
+open Graph
+open Graph.Dot_ast
+open Data
+open Event
+
+(* XXX duplicated from lib/sasacore/topology.ml:
+ make a user lib out of it.
+ *)
+type node_id = string
+type node = {
+ id: node_id;
+ file: string;
+ init: (string * string) list;
+}
+
+type edge = node_id * node_id list
+
+type t = node list * string
+
+type node_info_t = (string, node) Hashtbl.t
+let node_info:node_info_t = Hashtbl.create 100
+
+type node_succ_t = (string, string list) Hashtbl.t
+let node_succ:node_succ_t = Hashtbl.create 100
+
+let (of_id:Dot_ast.id -> string) =
+ function Ident str | Html str | Number str | String str -> str
+
+let (of_node_id:Dot_ast.node_id -> string) = fun id -> of_id (fst id)
+let (of_node:Dot_ast.node -> string) = function
+ | NodeId node_id -> of_node_id node_id
+ | NodeSub _subgraph -> assert false
+
+let (get_file: Dot_ast.node_id -> Dot_ast.attr list -> string) =
+ fun node_id attrs ->
+ let attrs = List.flatten attrs in
+ try (
+ match List.assoc (Ident "algo") attrs with
+ None -> assert false
+ | Some id -> of_id id
+ )
+ with Not_found -> failwith ((of_node_id node_id)^" should have an algo attribute")
+
+let (get_init: Dot_ast.attr list -> (string * string) list ) =
+ fun attrs ->
+ let attrs = List.flatten attrs in (* XXX why a list of list ? *)
+ let init_list =
+ List.fold_left
+ (fun acc (id,idopt) ->
+ if id <> Ident "init" then acc else
+ match idopt with
+ | Some (String id) -> (
+ try
+ let i = String.index id '=' in
+ let l = String.length id in
+ (String.sub id 0 i, String.sub id (i+1) (l-i-1))::acc
+ with
+ Not_found -> acc
+ )
+ | _ -> acc
+ )
+ []
+ attrs
+ in
+ init_list
+
+let (do_stmt: bool -> node list -> Dot_ast.stmt -> node list) =
+ fun directed n stmt ->
+ match stmt with
+ | Node_stmt (node_id, attrs) ->
+ let id = of_node_id node_id in
+ let inits = get_init attrs in
+ let node = { id=id ; file = get_file node_id attrs ; init = inits } in
+ if Hashtbl.mem node_info id then
+ failwith (id ^ " defined twice")
+ else
+ Hashtbl.add node_info id node;
+ node::n
+ | Edge_stmt (node, nodes, _attrs) ->
+ let node = of_node node in
+ let nodes = List.map of_node nodes in
+ (* for egdes written "a -- b -- c -- d", which
+ is a shortcut for "
+ a -- b
+ b -- c
+ c -- d
+ "
+ Graph.Dot.parse_dot_ast returns the pair a,[b,c,d]
+ which is weird IMHO.
+ The code below add the missing edges:
+ *)
+ let add_edge n1 n2 =
+ if n1 = n2 then failwith
+ (Printf.sprintf "Bad topology: %s can not ne a neighbor of itself!" n1);
+ let pn1 = try Hashtbl.find node_succ n1 with Not_found -> [] in
+ let pn2 = try Hashtbl.find node_succ n2 with Not_found -> [] in
+ Hashtbl.replace node_succ n1 (n2::pn1);
+ if not directed then Hashtbl.replace node_succ n2 (n1::pn2);
+ n2
+ in
+ ignore (List.fold_left add_edge node nodes);
+ n
+ | Attr_graph _attrs -> n
+ | Attr_node _attrs -> n
+ | Attr_edge _attrs -> n
+ | Equal (_id1, _id2) -> assert false
+ | Subgraph _subgraph -> assert false
+
+
+let (read: string -> t) = fun f ->
+ let dot_file = Graph.Dot.parse_dot_ast f in
+ assert (not dot_file.strict);
+ let res = List.fold_left (do_stmt dot_file.digraph) [] dot_file.stmts in
+ List.rev res,f
+;;
+
+
+let succ str = try Hashtbl.find node_succ str with Not_found -> []
+
+(* XXX bad name: process? *)
+type pid = {
+ name: string;
+ actions: (string * bool * bool) list; (* (action name, enabled, active) *)
+ vars: (string * Data.v) list (* pid local vars*)
+}
+
+let (is_parent: string -> int -> Event.t -> bool) =
+ fun a i e ->
+ (* XXX marche ssi une variable s'appelle par!
+ je devrais au moins generaliser avec l'existence
+ d'une variable de type parent (et encore)
+ *)
+ match List.assoc_opt (a^"_par") e.data with
+ | None -> false
+ | Some (I j) -> i = j
+ | _ -> false
+
+let (get_pidl : node list -> string -> Event.t -> pid list) =
+ fun nodes f e ->
+ if e.kind <> Ltop then (
+ print_string "print_dot should be called from Ltop event\n";
+ failwith "exit print_dot"
+ );
+ let l = List.map (fun (x,v) -> Str.split (Str.regexp "_") x, v) e.data in
+ let rec sortv (enab, other) (x,v) =
+ match x with
+ | ["Enab";pid;a] -> (pid,a,v)::enab, other
+ | [pid; str] -> enab, (pid,str,v)::other
+ | _ -> assert false
+ in
+ let enab, other = List.fold_left sortv ([],[]) l in
+ let rec (build_pidl: pid list -> (string * string * Data.v) list ->
+ (string * string * Data.v) list -> pid list) =
+ fun pidl enab other ->
+ match enab with
+ | [] -> pidl
+ | (pid, _, _)::_ ->
+ let enab_pid_list, enab = List.partition (fun (pid0,_,_) -> pid=pid0) enab in
+ let other_pid, other = List.partition (fun (pid0,_,_) -> pid=pid0) other in
+ let acti_pid, vars_pid =
+ List.partition
+ (fun (_,n,_) -> List.exists (fun (_,n2,_) -> n2=n) enab_pid_list)
+ other_pid
+ in
+ let get_actions (_, n, enabv) =
+ let (_,_,activ) = List.find (fun (_,n0, _) -> n=n0) acti_pid in
+ (n, enabv = Data.B true, activ = B true)
+ in
+ let pid = {
+ name = pid;
+ actions = List.map get_actions enab_pid_list;
+ vars = List.map (fun (_,n,v) -> n,v) vars_pid;
+ }
+ in
+ build_pidl (pid::pidl) enab other
+ in
+ let pidl = build_pidl [] enab other in
+ List.rev pidl
+
+
+(* Compute a dot from the content of e.data *)
+let print_dot (nodes,f) e =
+ let (pidl : pid list) = get_pidl nodes f e in
+ let oc = open_out ("sasa-"^f) in
+ let nodes_decl =
+ String.concat "\n"
+ (List.map
+ (fun pid ->
+ let color =
+ if List.exists (fun (_,_,a) -> a) pid.actions then
+ "fillcolor=gold,style=filled,"
+ else
+ if List.exists (fun (_,e,_) -> e) pid.actions then
+ "fillcolor=green,style=filled,"
+ else ""
+ in
+ let enabled = String.concat ","
+ (List.map
+ (fun (n,_,_) -> n)
+ (List.filter (fun (_,e,_) -> e) pid.actions))
+ in
+ let enabled = if enabled = "" then "" else (enabled^"|") in
+ let loc = String.concat "|"
+ (List.map (fun (n,v) ->
+ Printf.sprintf "%s=%s" n (Data.val_to_string string_of_float v))
+ pid.vars
+ )
+ in
+ Printf.sprintf " %s [%slabel=\"%s|{%s%s}\"] "
+ pid.name color pid.name enabled loc
+ )
+ pidl
+ )
+ in
+ let trans =
+ List.flatten
+ (List.map
+ (fun n ->
+ let l = succ n.id in
+ List.mapi (fun i t ->
+ if is_parent n.id i e then
+ Printf.sprintf "%s -> %s" n.id t
+ else if n.id < t then
+ Printf.sprintf "%s -- %s" n.id t
+ else
+ Printf.sprintf "%s -- %s" t n.id
+ )
+ l
+ )
+ nodes
+ )
+ in
+ let trans = List.sort_uniq compare trans in
+ let is_directed str =
+ try
+ ignore (Str.search_forward (Str.regexp "->") str 0);
+ true
+ with Not_found -> false
+ in
+ let trans_dir,trans_undir = List.partition is_directed trans in
+ let trans_dir_str = String.concat "\n" trans_dir in
+ let trans_undir_str = String.concat "\n" trans_undir in
+ let trans_undir_str = Str.global_replace (Str.regexp "--") "->" trans_undir_str in
+ let trans_str =
+ (* if trans_dir_str = "" then trans_undir_str else *)
+ Printf.sprintf "subgraph dir {\n\t%s}
+subgraph undir {\n\t edge [dir=none]\n%s} " trans_dir_str trans_undir_str
+ in
+ Printf.fprintf oc
+ "digraph %s {\nlabel=\"%s step %d\"\nnode [shape=record];\n%s\n%s\n}\n"
+ "g" f e.step
+ nodes_decl trans_str;
+ flush oc;
+ close_out oc;
+ Sys.command (Printf.sprintf "dot -Tpdf sasa-%s -o sasa-%s.pdf" f f)
+;;
+
+(***********************************************************************)
+
+let get_removable pl =
+ let pl = List.filter
+ (fun p ->
+ (List.exists (fun (_,_,acti) -> acti) p.actions) ||
+ (List.for_all (fun (_,enab,_) -> (not enab)) p.actions)
+ )
+ pl
+ in
+ List.map (fun p -> p.name) pl
+
+let next_round nodes f e =
+ let (pl : pid list) = get_pidl nodes f e in
+ let p_with_enable_action =
+ List.filter
+ (fun p -> List.exists (fun (_,enab,acti) -> enab&¬(acti)) p.actions)
+ pl
+ in
+ let pidl = List.map (fun p -> p.name) p_with_enable_action in
+ Printf.printf "The processes to check : %s\n" (String.concat "," pidl);
+ flush stdout;
+ let rec go cpidl e =
+ let e = step e in
+ let pl = get_pidl nodes f e in
+ let removable = get_removable pl in
+ Printf.printf "Current process: %s\n" (String.concat "," cpidl);
+ Printf.printf "Removable process: %s\n" (String.concat "," removable);
+ flush stdout;
+ let cpidl = List.filter (fun pid -> not (List.mem pid removable)) cpidl in
+ if cpidl = [] then e else go cpidl e
+ in
+ go pidl e
+
+(***********************************************************************)
+
+let _ = print_string "
+===> Use the read fonction to load the dot file
+===> Use the print_dot function at Ltop event to generated dot files
+
+You migth want to add something along those lines at the end of your rdbg-session.ml file
+(the name of the dot file and the path to the dot.ml file migth need to be adapted
+to your context tough):
+;;
+#use \"../rdbg-utils/dot.ml\";;
+let nodes,dotfile = read \"g.dot\";;
+let d () = print_dot (nodes, dotfile) !e;;
+let sd () = s();d();;
+let nr () = e:=next_round nodes dotfile !e; d();;
+
+let _ = n (); d (); Sys.command (\"zathura sasa-g.dot.pdf&\")
+
+"