Skip to content
Snippets Groups Projects
Commit e47b23f9 authored by erwan's avatar erwan
Browse files

Refactoring

parent a8ec5783
No related branches found
No related tags found
1 merge request!14A new rdbgui4sasa with automatic daemons
Hide whitespace changes
Inline Side-by-side
tools/rdbg4sasa/gtkgui.ml
+ 125
− 211
View file @ e47b23f9
(* 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 ?
......
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment