From e47b23f9d239e22171aca74a910db75a87e7734d Mon Sep 17 00:00:00 2001
From: Erwan Jahier <erwan.jahier@univ-grenoble-alpes.fr>
Date: Fri, 7 May 2021 11:57:49 +0200
Subject: [PATCH] Refactoring
---
tools/rdbg4sasa/gtkgui.ml | 336 ++++++++++++++------------------------
1 file changed, 125 insertions(+), 211 deletions(-)
diff --git a/tools/rdbg4sasa/gtkgui.ml b/tools/rdbg4sasa/gtkgui.ml
index de60147c..afc53cf5 100644
--- a/tools/rdbg4sasa/gtkgui.ml
+++ b/tools/rdbg4sasa/gtkgui.ml
@@ -1,3 +1,4 @@
+(* Time-stamp: <modified the 07/05/2021 (at 09:27) by Erwan Jahier> *)
#thread
#require "lablgtk3"
@@ -82,28 +83,20 @@ let custom_daemon gtext vbox step_button round_button =
init_rdbg_hook ();
let daemon_box = GPack.hbox ~packing:vbox#add () ~homogeneous:true ~height:15 in
- let daemon_box_manual = GPack.hbox ~packing:vbox#add () in
let dk_dd = GButton.radio_button ~active:(!daemon_kind=Distributed)
~label:"Distributed" ~packing:daemon_box#add ()
in
- let dk_cd = GButton.radio_button ~active:(!daemon_kind=Central)
- ~label:"Central" ~group:dk_dd#group ~packing:daemon_box#add ()
- in
- let dk_lcd = GButton.radio_button ~active:(!daemon_kind=LocCentral)
- ~label:"Locally Central" ~group:dk_dd#group ~packing:daemon_box#add ()
- in
- let dk_sd = GButton.radio_button ~active:(!daemon_kind=Synchronous)
- ~label:"Synchronous" ~group:dk_dd#group ~packing:daemon_box#add ()
- in
- let dk_manual = GButton.radio_button ~active:(!daemon_kind=Manual)
- ~label:"Manual" ~group:dk_dd#group ~packing:daemon_box_manual#add ()
- in
- let dk_manual_central = GButton.radio_button ~active:(!daemon_kind=ManualCentral)
- ~label:"Manual Central" ~group:dk_dd#group ~packing:daemon_box_manual#add ()
- in
- let scrolled = GBin.scrolled_window ~border_width:10
- ~shadow_type:`OUT ~height:150 ~packing:vbox#add ()
- in
+ let make_but act lbl = GButton.radio_button ~active:act ~label:lbl
+ ~group:dk_dd#group ~packing:daemon_box#add ()
+ in
+ let dk_cd = make_but (!daemon_kind=Central) "Central" in
+ let dk_lcd = make_but (!daemon_kind=LocCentral) "Locally Central" in
+ let dk_sd = make_but (!daemon_kind=Synchronous) "Synchronous" in
+ let dk_manual = make_but (!daemon_kind=Manual) "Manual" in
+ let dk_manual_central = make_but (!daemon_kind=ManualCentral) "Manual Central" in
+ (* let _scrolled = GBin.scrolled_window ~border_width:10 *)
+ (* ~shadow_type:`OUT ~height:150 ~packing:vbox#add () *)
+ (* in *)
dk_dd#misc#set_tooltip_text (Printf.sprintf "Set the automatic distributed mode");
dk_sd#misc#set_tooltip_text (Printf.sprintf "Set the automatic synchronous mode");
dk_cd#misc#set_tooltip_text (Printf.sprintf "Set the automatic central mode");
@@ -185,7 +178,7 @@ let custom_daemon gtext vbox step_button round_button =
~height:300
~shadow_type:`OUT ~packing:pushbox_grid#add ()
in
- let pushbox_scrolled_grid_box = GPack.vbox ~homogeneous:true ~packing:pushbox_scrolled_grid#add () in
+ let pushbox_scrolled_grid_box = GPack.vbox ~homogeneous:true ~packing:pushbox_scrolled_grid#add () in
let pushbox_line = GPack.hbox ~packing:pushbox_scrolled_grid_box#add () in
let pushbox_line_ref = ref pushbox_line in
let pushbox_map = Hashtbl.create n in
@@ -369,7 +362,8 @@ let libui_prefix = prefix ^ "/lib/rdbgui4sasa"
let oc_stdin = stdout
let ic_stdout = stdin
-
+
+open GButton
(* GTK3 *)
let main () =
let _locale = GtkMain.Main.init () in
@@ -383,17 +377,10 @@ let main () =
let box = GPack.vbox ~packing: w#add () in
let gbox = GPack.hbox ~packing: box#add () in
let gbox2 = GPack.hbox ~packing: box#add () in
- let sw1 = GBin.scrolled_window ~border_width:10 ~shadow_type:`IN ~height:30 ~width:50
- ~packing:box#add ()
- in
let sw2 = GBin.scrolled_window ~border_width:10 ~shadow_type:`OUT ~height:250
~packing:box#add ()
in
- sw1#misc#set_tooltip_text "This window displays the commands sent to the rdbg cli";
sw2#misc#set_tooltip_text "This window displays commands outputs";
- let text_in = GText.view ~wrap_mode:`CHAR ~height:250 ~editable:true ~width:50
- ~packing: sw1#add () ~cursor_visible:true
- in
let text_out = GText.view ~wrap_mode:`CHAR ~height:250 ~editable:false
~packing: sw2#add () ~cursor_visible:true
in
@@ -402,10 +389,33 @@ let main () =
Printf.fprintf oc_stdin "%s\n%!" str;
Printf.printf "%s\n%!" str;
in
+ (* It should be better to rely on the gtk event handler
- Printf.fprintf oc_stdin "#require \"sasa\";;\n%!" ;
- (* Printf.fprintf oc_stdin "#use \"sasa-rdbg-cmds.ml\";;\n%!"; *)
- Printf.fprintf oc_stdin "print_sasa_event false !e;;\n%!"; (* print the first event *)
+ let sw1 = GBin.scrolled_window ~border_width:10 ~shadow_type:`IN ~height:30 ~width:50
+ ~packing:box#add ()
+ in
+ sw1#misc#set_tooltip_text "This window displays the commands sent to the rdbg cli";
+ let text_in = GText.view ~wrap_mode:`CHAR ~height:250 ~editable:true ~width:50
+ ~packing: sw1#add () ~cursor_visible:true
+ in
+ let rec read_text_in () =
+ let buff = text_in#buffer#get_text () in
+ let size = String.length buff in
+ if size >0 then (
+ let last = String.get buff (size - 1) in
+ if last = '\n' then (
+ Printf.fprintf oc_stdin "%s\n%!" buff;
+ Printf.printf "%s\n%!" buff;
+ text_in#set_buffer (GText.buffer ~text:"(rdbg) " ())
+ ) else ()
+ );
+ Unix.sleepf 0.1;
+ read_text_in ()
+ in
+ let _ = Thread.create read_text_in () in
+ *)
+ (* Printf.fprintf oc_stdin "#use \"sasa-rdbg-cmds.ml\";;\n%!"; *)
+ (* Printf.fprintf oc_stdin "print_sasa_event false !e;;\n%!"; (* print the first event *) *)
let bbox = GPack.hbox ~packing: box#add () in
let change_label button str =
@@ -425,23 +435,17 @@ let main () =
text_out#buffer#set_text txt
in
- let back_step_button =
- GButton.button ~use_mnemonic:true ~stock:`GO_BACK ~packing:bbox#add ()
- in
+ let back_step_button = button ~use_mnemonic:true ~stock:`GO_BACK ~packing:bbox#add () in
back_step_button#misc#set_tooltip_text "Move BACKWARD to the previous STEP";
change_label back_step_button "Ste_p";
ignore (back_step_button#connect#clicked ~callback:(button_cb bd));
- let step_button =
- GButton.button ~use_mnemonic:true ~packing:bbox#add ~stock:`GO_FORWARD ()
- in
+ let step_button = button ~use_mnemonic:true ~packing:bbox#add ~stock:`GO_FORWARD () in
let back_round_button =
- GButton.button ~packing:bbox#add ~stock:`MEDIA_PREVIOUS ~use_mnemonic:true
- ~label:"back round" ()
+ button ~packing:bbox#add ~stock:`MEDIA_PREVIOUS ~use_mnemonic:true ~label:"back round" ()
in
let round_button =
- GButton.button ~use_mnemonic:true ~stock:`MEDIA_FORWARD
- ~packing:bbox#add ~label:"round" ()
+ button ~use_mnemonic:true ~stock:`MEDIA_FORWARD ~packing:bbox#add ~label:"round" ()
in
let ze_step =
if custom_mode then
@@ -464,10 +468,8 @@ let main () =
change_label back_round_button "Roun_d";
ignore (back_round_button#connect#clicked ~callback:(button_cb pr));
-
let legitimate () =
- let legitimate_button = GButton.button ~use_mnemonic:true
- ~packing:bbox#add () in
+ let legitimate_button = button ~use_mnemonic:true ~packing:bbox#add () in
legitimate_button#misc#set_tooltip_text
"Move FORWARD until a legitimate configuration is reached (silence by default)";
let image = GMisc.image ~file:(libui_prefix^"/chut_small.svg") () in
@@ -479,7 +481,7 @@ let main () =
legitimate ();
let graph () =
- let graph_button = GButton.button ~use_mnemonic:true ~packing:bbox#add () in
+ let graph_button = button ~use_mnemonic:true ~packing:bbox#add () in
graph_button#misc#set_tooltip_text
"Visualize the Topology states: Green=Enabled ; Gold=Active";
let image = GMisc.image ~file:(libui_prefix^"/graph_small.png") () in
@@ -489,142 +491,76 @@ let main () =
in
graph ();
- let viol_oracle () =
- let viol_button = GButton.button ~use_mnemonic:true ~stock:`OK
- ~packing:bbox#add () in
- viol_button#misc#set_tooltip_text
- "Move FORWARD until an oracle is violated";
- (* let image = GMisc.image ~file:"../rdbg-utils/oracle_small.jpg" () in *)
- (* viol_button#set_image image#coerce; *)
- change_label viol_button "_Oracle";
- ignore (viol_button#connect#clicked ~callback:(button_cb_string viol_string))
- in
- (* if args.oracles <> [] then *)
- viol_oracle ();
-
- let undo_button = GButton.button ~use_mnemonic:true ~stock:`UNDO
- ~packing:bbox#add ~label:"undo" ()
- in
- undo_button#misc#set_tooltip_text "Undo the last move";
- ignore (undo_button#connect#clicked ~callback:(button_cb (fun () -> u();d())));
-
- let restart_button = GButton.button ~use_mnemonic:true ~stock:`REFRESH
- ~packing:bbox#add ~label:"restart" ()
- in
- restart_button#misc#set_tooltip_text "Restart from the beginning";
- change_label restart_button "Restar_t";
- ignore (restart_button#connect#clicked ~callback:(button_cb (fun ()-> r();d())));
-
- let info_button =
- GButton.button ~use_mnemonic:true ~stock:`INFO ~packing:bbox#add ~label:"_Info" ()
- in
- change_label info_button "_Info";
- info_button#misc#set_tooltip_text "Get information about the current session";
- ignore (info_button#connect#clicked ~callback:(button_cb_string info_string));
-
- let quit_button =
- GButton.button ~use_mnemonic:true ~stock:`QUIT ~packing:bbox#add ~label:"_Quit" ()
- in
- quit_button#misc#set_tooltip_text "Quit RDBGUI";
- ignore (quit_button#connect#clicked ~callback: (fun() -> Stdlib.exit 0));
-
-
- let dot_button = GButton.radio_button ~packing:gbox#add ~label:"dot" () in
- let fd_button = GButton.radio_button ~packing:gbox#add
- ~group:dot_button#group ~label:"fdp" ()
- in
- let sf_button = GButton.radio_button ~packing:gbox#add
- ~group:dot_button#group ~label:"sfdp" ()
- in
- let ne_button = GButton.radio_button ~packing:gbox#add
- ~active:true ~group:dot_button#group ~label:"neato" ()
- in
- let tw_button = GButton.radio_button ~packing:gbox#add
- ~group:dot_button#group ~label:"twopi" ()
- in
- let ci_button = GButton.radio_button ~packing:gbox#add
- ~group:dot_button#group ~label:"circo" ()
- in
- let pa_button = GButton.radio_button ~packing:gbox#add
- ~group:dot_button#group ~label:"patchwork" ()
- in
- let os_button = GButton.radio_button ~packing:gbox#add
- ~group:dot_button#group ~label:"osage" ()
- in
-
- let par_dot () =
- let par_dot_button = GButton.radio_button ~packing:gbox2#add
- ~group:dot_button#group ~label:"dot*" () in
- let par_fd_button = GButton.radio_button ~packing:gbox2#add
- ~group:dot_button#group ~label:"fdp*" () in
- let par_sf_button = GButton.radio_button ~packing:gbox2#add
- ~group:dot_button#group ~label:"sfdp*" () in
- let par_ne_button = GButton.radio_button ~packing:gbox2#add
- ~group:dot_button#group ~label:"neato*" () in
- let par_tw_button = GButton.radio_button ~packing:gbox2#add
- ~group:dot_button#group ~label:"twopi*" () in
- let par_ci_button = GButton.radio_button ~packing:gbox2#add
- ~group:dot_button#group ~label:"circo*" () in
- let par_pa_button = GButton.radio_button ~packing:gbox2#add
- ~group:dot_button#group ~label:"patchwork*" () in
- let par_os_button = GButton.radio_button ~packing:gbox2#add
- ~group:dot_button#group ~label:"osage*" ()
- in
- par_dot_button#misc#set_tooltip_text
- "Use dot, but show only links to the parent (works if State.t contains a 'par:int' field)";
- par_fd_button#misc#set_tooltip_text
- "Use fdp, but show only links to the parent (works if State.t contains a 'par:int' field)";
- par_sf_button#misc#set_tooltip_text
- "Use sfdp, but show only links to the parent (works if State.t contains a 'par:int' field)";
- par_ne_button#misc#set_tooltip_text
- "Use neato, but show only links to the parent (works if State.t contains a 'par:int' field)";
- par_tw_button#misc#set_tooltip_text
- "Use twopi, but show only links to the parent (works if State.t contains a 'par:int' field)";
- par_ci_button#misc#set_tooltip_text
- "Use circo, but show only links to the parent (works if State.t contains a 'par:int' field)";
- par_pa_button#misc#set_tooltip_text
- "Use patchwork, but show only links to the parent (works if State.t contains a 'par:int' field)";
- par_os_button#misc#set_tooltip_text
- "Use osage, but show only links to the parent (works if State.t contains a 'par:int' field)";
- ignore (par_dot_button#connect#clicked
- ~callback:(fun () ->
- p ((par_dot_button#misc#tooltip_text)^"\n"^(help_string "d_par"));
- dot_view := d_par; !dot_view()));
- ignore (par_fd_button#connect#clicked
- ~callback:(fun () ->
- p ((par_fd_button#misc#tooltip_text)^"\n"^(help_string "fd_par"));
- dot_view := fd_par; !dot_view()));
- ignore (par_sf_button#connect#clicked
- ~callback:(fun () ->
- p ((par_sf_button#misc#tooltip_text)^"\n"^(help_string "sf_par"));
- dot_view := sf_par; !dot_view()));
- ignore (par_ne_button#connect#clicked
- ~callback:(fun () ->
- p ((par_ne_button#misc#tooltip_text)^"\n"^(help_string "ne_par"));
- dot_view := ne_par; !dot_view()));
- ignore (par_tw_button#connect#clicked
- ~callback:(fun () ->
- p ((par_tw_button#misc#tooltip_text)^"\n"^(help_string "tw_par"));
- dot_view := tw_par; !dot_view()));
- ignore (par_ci_button#connect#clicked
- ~callback:(fun () ->
- p ((par_ci_button#misc#tooltip_text)^"\n"^(help_string "ci_par"));
- dot_view := ci_par; !dot_view()));
- ignore (par_pa_button#connect#clicked
- ~callback:(fun () ->
- p ((par_pa_button#misc#tooltip_text)^"\n"^(help_string "pa_par"));
- dot_view := pa_par; !dot_view()));
- ignore (par_os_button#connect#clicked
- ~callback:(fun () ->
- p ((par_os_button#misc#tooltip_text)^"\n"^(help_string "os_par"));
- dot_view := os_par; !dot_view()))
+ let make_button stock lbl msg cmd =
+ let butt = button ~use_mnemonic:true ~stock:stock ~packing:bbox#add ~label:lbl () in
+ butt#misc#set_tooltip_text msg;
+ change_label butt lbl;
+ ignore (butt#connect#clicked ~callback:cmd);
+ butt
+ in
+ if args.oracles <> [] then (
+ ignore (make_button `OK "_Oracle" "Move FORWARD until an oracle is violated"
+ (* let image = GMisc.image ~file:"../rdbg-utils/oracle_small.jpg" () in *)
+ (* viol_button#set_image image#coerce; *)
+ (button_cb_string viol_string))
+ );
+ let _ = make_button `UNDO "_Undo" "Undo the last move" (button_cb (fun ()->u();d())) in
+ let _ = make_button `REFRESH "Restar_t" "Restart from the beginning"
+ (button_cb (fun ()-> r();d()))
+ in
+ let _ = make_button `INFO "_Info" "Get information about the current session"
+ (button_cb_string info_string)
+ in
+ let _ = make_button `QUIT "_Quit" "Quit RDBGUI" (fun() -> p "bye"; Stdlib.exit 0) in
+ let dot_button = radio_button ~packing:gbox#add ~label:"dot" () in
+ let make_but active lbl = radio_button ~packing:gbox#add
+ ~active:active ~group:dot_button#group ~label:lbl ()
+ in
+ let fd_button = make_but false "fdp" in
+ let sf_button = make_but false "sfdp" in
+ let ne_button = make_but true "neato" in
+ let tw_button = make_but false "twopi" in
+ let ci_button = make_but false "circo" in
+ let pa_button = make_but false "patchwork" in
+ let os_button = make_but false "osage" in
+
+ let connect button str cmd =
+ ignore (button#connect#clicked
+ ~callback:(fun () -> p ((button#misc#tooltip_text)^"\n"^(help_string str));
+ dot_view := cmd; !dot_view()))
in
-
let have_parent () = (* is there a parent field in the state ? *)
- (* List.exists (fun (v,_) -> Str.string_match (Str.regexp ".*_par.*") v 0) !e.data *)
- true
+ List.exists (fun (v,_) -> Str.string_match (Str.regexp ".*_par.*") v 0) !e.data
in
- if have_parent () then par_dot ();
+ if have_parent () then (
+ let make_but lbl = GButton.radio_button ~packing:gbox2#add
+ ~group:dot_button#group ~label:lbl ()
+ in
+ let par_dot_button = make_but "dot*" in
+ let par_fd_button = make_but "fdp*" in
+ let par_sf_button = make_but "sfdp*" in
+ let par_ne_button = make_but "neato*" in
+ let par_tw_button = make_but "twopi*" in
+ let par_ci_button = make_but "circo*" in
+ let par_pa_button = make_but "patchwork*" in
+ let par_os_button = make_but "osage*" in
+ par_dot_button#misc#set_tooltip_text "Use dot, but show only links to the parent";
+ par_fd_button#misc#set_tooltip_text "Use fdp, but show only links to the parent";
+ par_sf_button#misc#set_tooltip_text "Use sfdp, but show only links to the parent";
+ par_ne_button#misc#set_tooltip_text "Use neato, but show only links to the parent";
+ par_tw_button#misc#set_tooltip_text "Use twopi, but show only links to the parent";
+ par_ci_button#misc#set_tooltip_text "Use circo, but show only links to the parent";
+ par_pa_button#misc#set_tooltip_text "Use patchwork, but show only links to the parent";
+ par_os_button#misc#set_tooltip_text "Use osage, but show only links to the parent";
+ connect par_dot_button "d_par" d_par;
+ connect par_fd_button "fd_par" fd_par;
+ connect par_sf_button "sf_par" sf_par;
+ connect par_ne_button "ne_par" ne_par;
+ connect par_tw_button "tw_par" tw_par;
+ connect par_ci_button "ci_par" ci_par;
+ connect par_pa_button "pa_par" pa_par;
+ connect par_os_button "os_par" os_par;
+ );
dot_button#misc#set_tooltip_text "Use the dot engine to display the graph";
fd_button#misc#set_tooltip_text "Use the fdp engine to display the graph";
sf_button#misc#set_tooltip_text "Use the sfdp engine to display the graph";
@@ -634,38 +570,15 @@ let main () =
pa_button#misc#set_tooltip_text "Use the patchwork engine to display the graph";
os_button#misc#set_tooltip_text "Use the osage engine to display the graph";
- ignore (dot_button#connect#clicked
- ~callback:(fun () ->
- p ((dot_button#misc#tooltip_text)^"\n"^(help_string "d"));
- dot_view:=dot; !dot_view()));
- ignore (fd_button#connect#clicked
- ~callback:(fun () ->
- p ((fd_button#misc#tooltip_text)^"\n"^(help_string "fd"));
- dot_view:=fd; !dot_view()));
- ignore (sf_button#connect#clicked
- ~callback:(fun () ->
- p ((sf_button#misc#tooltip_text)^"\n"^(help_string "sf"));
- dot_view:=sf; !dot_view()));
- ignore (ne_button#connect#clicked
- ~callback:(fun () ->
- p ((ne_button#misc#tooltip_text)^"\n"^(help_string "ne"));
- dot_view:=ne; !dot_view()));
- ignore (tw_button#connect#clicked
- ~callback:(fun () ->
- p ((tw_button#misc#tooltip_text)^"\n"^(help_string "tw"));
- dot_view:=tw; !dot_view()));
- ignore (ci_button#connect#clicked
- ~callback:(fun () ->
- p ((ci_button#misc#tooltip_text)^"\n"^(help_string "ci"));
- dot_view:=ci; !dot_view()));
- ignore (pa_button#connect#clicked
- ~callback:(fun () ->
- p ((pa_button#misc#tooltip_text)^"\n"^(help_string "pa"));
- dot_view:=pa; !dot_view()));
- ignore (os_button#connect#clicked
- ~callback:(fun () ->
- p ((os_button#misc#tooltip_text)^"\n"^(help_string "os"));
- dot_view:=os; !dot_view()));
+ connect dot_button "d" dot;
+ connect fd_button "fd" fd;
+ connect sf_button "sf" sf;
+ connect ne_button "ne" ne;
+ connect tw_button "tw" tw;
+ connect ci_button "ci" ci;
+ connect pa_button "pa" pa;
+ connect os_button "os" os;
+
ignore (window#connect#destroy ~callback: (
fun () ->
quit (); (* quit rdbg, this will stop the readloop below *)
@@ -679,9 +592,10 @@ let main () =
let gui = main
(* todo
+- boutons gnuplot-rif et sim2chro
- couper les grosses fonctions en morceaux
- cacher les messages issus du #use
-- lire les commandes dans text_in
+- lire les commandes dans text_in (comment ? c'est rdbgtop qui lance gtk maintenant...)
- faire les modes automatiques
- reglage de la taille des boites
- utiliser les GEdit.spin_button ?
--
GitLab