New: add a --generate-rdbg-load (hidden) option used by rdbg to generate sessions

This is necessary because I cannot Dynlink .cmxs files from a ocaml
toplevel. Hence, one way to load the algos from rdbg is to
#load .cma files. This option generates an ocaml file that
can be #used by automatically generated rdbg-session.ml files.

lib/sasacore/sasArg.ml

-(* Time-stamp: <modified the 02/04/2019 (at 08:25) by Erwan Jahier> *)
+(* Time-stamp: <modified the 06/05/2019 (at 14:47) by Erwan Jahier> *)
 
 
 type t = {
@@ -11,6 +11,7 @@ type t = {
   mutable ifi: bool;
   mutable gen_lutin: bool;
   mutable dummy_input: bool;
+  mutable generate_rdbg_load_files: bool;
   
   mutable _args : (string * Arg.spec * string) list;
   mutable _user_man  : (string * string list) list; 
@@ -38,6 +39,7 @@ let (make_args : unit -> t) =
       ifi = false;
       gen_lutin = false;
       dummy_input = false;
+      generate_rdbg_load_files = false;
       _args = [];        
       _user_man  = [];   
       _hidden_man  = []; 
@@ -119,6 +121,11 @@ let (mkoptab : string array -> t -> unit) =
       (Arg.Unit(fun () -> args.gen_lutin <- true))
       ["Generate Lutin demons and exit"];
 
+   mkopt args ~hide:true ["--generate-rdbg-load"]
+     (Arg.Unit(fun () -> args.generate_rdbg_load_files <- true))
+      ["Generate a file meant to be included by rdbg, and exit. ";
+      "This file allows one to load the node algo cma files "];
+    
    mkopt args ~hide:true ["--dummy-input"]
       (Arg.Unit(fun () -> args.dummy_input <- true))
       ["Add a dummy input to sasa so that built-in demon can be used from rdbg"];
@@ -131,7 +138,7 @@ let (mkoptab : string array -> t -> unit) =
       (Arg.Int (fun i -> args.length <- i))
       ["Maximum number of steps to be done (" ^ (string_of_int args.length) ^ " by default).\n"];
 
-    mkopt args ~hide:true ["--version";"-version";"-v"]
+    mkopt args ["--version";"-version";"-v"]
       (Arg.Unit (fun _ ->
            (print_string (SasaVersion.str^"-"^SasaVersion.sha^"\n");flush stdout;exit 0)))
       ["Display the sasa version and exit."];
@@ -198,7 +205,7 @@ let parse argv = (
           exit 2; 
         | x::_ -> x
       );
-      args
+    args
   )
   with
   | Arg.Bad msg ->

lib/sasacore/sasArg.mli

-(* Time-stamp: <modified the 02/04/2019 (at 14:43) by Erwan Jahier> *)
+(* Time-stamp: <modified the 06/05/2019 (at 14:24) by Erwan Jahier> *)
 
 type t = {
   mutable topo: string;
@@ -10,6 +10,7 @@ type t = {
   mutable ifi: bool;
   mutable gen_lutin: bool;
   mutable dummy_input: bool;
+  mutable generate_rdbg_load_files: bool;
   
   mutable _args : (string * Arg.spec * string) list;
   mutable _user_man  : (string * string list) list; 

lib/sasacore/sasa.ml

-(* Time-stamp: <modified the 09/05/2019 (at 21:58) by Erwan Jahier> *)
+(* Time-stamp: <modified the 09/05/2019 (at 21:59) by Erwan Jahier> *)
 
 open Algo
 open Sasacore
@@ -175,6 +175,26 @@ let (make : bool -> string array -> t) =
       let e = update_env_with_init e pl algo_neighors in
       let pl_n = List.combine pl algo_neighors in
       if !Algo.verbose_level > 0 then List.iter dump_process pl_n;
+      if args.generate_rdbg_load_files then (
+        let fn = Printf.sprintf "load-%s.ml" args.topo in
+        if Sys.file_exists fn then (
+          Printf.eprintf "%s already exists: rename it to update.\n" fn;
+          flush stderr; exit 0
+        ) else 
+          let oc = open_out fn in
+          let files = List.fold_left
+              (fun acc n ->
+                 let f = (Filename.chop_extension n.Topology.file) ^ ".cma" in
+                 
+                 if List.mem f acc then acc else f::acc)
+              [] nl
+          in
+          let loadl = List.map (fun s -> Printf.sprintf "#load \"%s\"" s) files in
+          Printf.fprintf oc "%s" (String.concat "\n" loadl);
+          flush oc;
+          close_out oc;
+          exit 0
+      );
       if args.gen_lutin then (
         let fn = (Filename.remove_extension args.topo) ^ ".lut" in
         if Sys.file_exists fn then (

test/dfs/rdbg-session.ml

@@ -53,5 +53,4 @@ let dotfile = "g.dot";;
 #use "../my-rdbg-tuning.ml";;
 
 
-let _ = n (); d (); ignore (Sys.command ("zathura sasa-g.dot.pdf&"))
 

test/my-rdbg-tuning.ml

 (*  Some useful short-cuts for rdbg interactive sessions *)
 
+
 let _ = time_travel true;;
 
 
@@ -36,6 +37,7 @@ let pa () = patchwork p dotfile !e;;
 let os () = osage p dotfile !e;;
 
 
+
 (* Convergence is reached when data does not change *)
 let rec go () =
   let data = !e.data in
@@ -90,13 +92,17 @@ let (round : Event.t -> bool) =
       );
     res
 
-
+(* go to next and previous rounds  *)
 let nr () = e:=next_round !e; circo p dotfile !e;;
-let pr () = e:=goto_last_ckpt !e.nb;;
-(**********************************************************************)
+let pr () = e:=goto_last_ckpt !e.nb; circo p dotfile !e;;
 
+(* checkpoint at rounds! *)
 let _ = check_ref := round;;
 
+
+
+let _ =  d (); Sys.command (Printf.sprintf "zathura sasa-%s.pdf&" dotfile)
+
 let _ = print_string "
  --> type 'man' for online help
 " 

test/rdbg-utils/dot.ml

@@ -23,8 +23,8 @@ let (is_parent: string -> string -> int -> Event.t -> bool) =
       | Some (I j) -> j > -1 && i = j
       | _ -> false
 
-let (get_processes : string -> Event.t -> process list) =
-  fun f e -> 
+let (get_processes : Event.t -> process list) =
+  fun e -> 
 (*    if e.kind <> Ltop then (
       print_string "dot should be called from Ltop event\n";
       failwith "exit dot"
@@ -94,7 +94,7 @@ let (get_parent_var_name: nodes list -> string) =
 (* Compute a dot from the content of e.data  *)
 let to_pdf engine par_var g f e =
   let nodes = g.nodes in
-  let (pidl : process list) = get_processes f e in
+  let (pidl : process list) = get_processes e in
   let oc = open_out ("sasa-"^f) in
   let nodes_decl =
     String.concat "\n"
@@ -166,7 +166,12 @@ subgraph undir {\n\t edge [dir=none]\n%s} " trans_dir_str trans_undir_str
     nodes_decl trans_str;
   flush oc;
   close_out oc;
-  Sys.command (Printf.sprintf "%s -Tpdf sasa-%s -o sasa-%s.pdf" engine f f)
+  if Sys.command (Printf.sprintf "%s -Tpdf sasa-%s -o sasa-%s.pdf" engine f f) > 0
+  then (
+    Printf.printf "'%s -Tpdf sasa-%s -o sasa-%s.pdf' Failed\n" engine f f;
+    flush stdout
+  )
+    
 ;;
 
 let dot = to_pdf "dot" "_par" ;;
@@ -200,10 +205,13 @@ let get_removable pl =
       pl
   in
   List.map (fun p -> p.name) pl
+(***********************************************************************)
+
+
 
 (*   *)
-let next_round nodes f e = 
-  let (pl : process list) = get_processes f e in
+let next_round e = 
+  let (pl : process list) = get_processes e in
   let p_with_enable_action =
     List.filter
       (fun p -> List.exists (fun (_,enab,acti) -> enab&&not(acti)) p.actions)
@@ -215,7 +223,7 @@ let next_round nodes f e =
   flush stdout;
   let rec go cpidl e =
     let e = step e in
-    let pl = get_processes f e in
+    let pl = get_processes 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);
@@ -224,7 +232,10 @@ let next_round nodes f e =
     if cpidl = [] then e else go cpidl e
   in
   go pidl e
-    
+
+
+
+
 (***********************************************************************)
 
 let _ = print_string "
@@ -243,7 +254,7 @@ let dotfile = \"g.dot\";;
 let p = Topology.read dotfile;;
 let d () = dot (p.nodes, dotfile) !e;;
 let sd () = s();d();;
-let nr () = e:=next_round p.nodes dotfile !e; d();;
+let nr () = e:=next_round dotfile !e; d();;
 
 let _ = n (); d (); Sys.command (\"zathura sasa-g.dot.pdf&\")