From c5077bf034307da03742a25456edc85a8e0f37a3 Mon Sep 17 00:00:00 2001
From: Erwan Jahier <erwan.jahier@univ-grenoble-alpes.fr>
Date: Mon, 11 Jul 2022 14:34:33 +0200
Subject: [PATCH] fix: rdbgui4sasa "New Seed" button was wrong when a seed was
 set

---
 lib/sasa/sasaRun.ml               |  4 ++--
 tools/rdbg4sasa/gtkgui.ml         |  9 +++++----
 tools/rdbg4sasa/sasa-rdbg-cmds.ml | 29 +++++++++++++++++++++++++++++
 3 files changed, 36 insertions(+), 6 deletions(-)

diff --git a/lib/sasa/sasaRun.ml b/lib/sasa/sasaRun.ml
index 14d3917b..c57e6504 100644
--- a/lib/sasa/sasaRun.ml
+++ b/lib/sasa/sasaRun.ml
@@ -65,8 +65,8 @@ let (compute_legitimate: bool -> 'v SimuState.t -> bool) =
 let (make_do: string array -> 'v SimuState.t -> RdbgPlugin.t) =
   fun argv st ->
   let pl = st.network in
-  let prog_id = Printf.sprintf "%s (with sasa Version %s)"
-      (String.concat " " (Array.to_list argv)) SasaVersion.str
+  let prog_id = Printf.sprintf "%s"
+      (String.concat " " (Array.to_list argv))
   in
   let vntl_i =
     List.map (fun (vn,vt) -> vn, Data.type_of_string vt)
diff --git a/tools/rdbg4sasa/gtkgui.ml b/tools/rdbg4sasa/gtkgui.ml
index 509191fd..411bd7a0 100644
--- a/tools/rdbg4sasa/gtkgui.ml
+++ b/tools/rdbg4sasa/gtkgui.ml
@@ -1,4 +1,4 @@
-(* Time-stamp: <modified the 03/07/2022 (at 17:36) by Erwan Jahier> *)
+(* Time-stamp: <modified the 11/07/2022 (at 14:12) by Erwan Jahier> *)
 
 #thread
 #require "lablgtk3"
@@ -210,11 +210,11 @@ let start () =
   !e.save_state !e.nb
 
 let restart p _ =
+  !e.RdbgEvent.reset();
   Seed.replay_seed := true;
   let seed = Seed.get dotfile in
   Seed.set seed;
   p (Printf.sprintf "Restarting using the seed %d" seed);
-  !e.RdbgEvent.reset();
   Round.reinit();
   e:=RdbgStdLib.run ~call_hooks:true ();
   start ();
@@ -803,12 +803,13 @@ let main () =
   let _ = make_button `REFRESH "_New Seed" "Restart from the beginning using a New Seed"
             (button_cb true true
                (fun ()->
+                 !e.RdbgEvent.reset();
                  Seed.reset(); Seed.replay_seed := false;
                  let seed = Seed.get dotfile in
+                 change_sasa_seed seed;
                  Seed.set (seed);
                  p (Printf.sprintf "Restarting using the seed %d" seed);
                  
-                 !e.RdbgEvent.reset();
                  e:=RdbgStdLib.run ~call_hooks:true ();
                  Round.reinit();
                  redos := [1];
@@ -935,7 +936,7 @@ let main () =
 
 let gui = main 
 (* todo
-- les oracles sont violés en silence
+- les oracles sont violés en silence (lancer un pop-up ?)
 - couper les grosses fonctions en morceaux
 - cacher les messages issus du #use
 - lire les commandes dans text_in (comment ? c'est rdbgtop qui lance gtk maintenant...)
diff --git a/tools/rdbg4sasa/sasa-rdbg-cmds.ml b/tools/rdbg4sasa/sasa-rdbg-cmds.ml
index ba0e9278..1f356ba5 100644
--- a/tools/rdbg4sasa/sasa-rdbg-cmds.ml
+++ b/tools/rdbg4sasa/sasa-rdbg-cmds.ml
@@ -135,6 +135,35 @@ let pr () =
   
 (* I need to overrides those *)
 
+
+(**********************************************************************)
+(* change the sasa seed in the rdbgplugin
+
+I've suposed that all Ocaml plugins called from sasa have a --seed option. Is it true?
+It is the case for sasa and lutin at least.
+ *)
+
+let (string_to_string_list : string -> string list) =
+  fun str ->
+    Str.split (Str.regexp "[ \t]+") str
+
+let (change_ocaml_plugin_seed: int -> RdbgPlugin.t -> RdbgPlugin.t) =
+  fun seed rdbgplugin -> 
+  let new_sasa_call = Printf.sprintf "%s --seed %d" rdbgplugin.id seed in
+  Sasa.SasaRun.make(Array.of_list (string_to_string_list new_sasa_call))
+
+let (change_plugin_seed : int -> RdbgArg.reactive_program -> RdbgArg.reactive_program) =
+  fun seed plugin ->
+  match plugin with
+  | Ocaml rdbgplugin -> Ocaml (change_ocaml_plugin_seed seed rdbgplugin)
+  | o -> o
+
+let change_sasa_seed seed =
+  args.suts <- List.map (change_plugin_seed seed) args.suts;
+  args.envs <- List.map (change_plugin_seed seed) args.envs
+      
+(**********************************************************************)
+
 (* won't work in semi-auto modes, but the buttons are hided *)
 let u () = undo (); ignore (round !e);; 
 let r () =
-- 
GitLab