From 5bd9f59fb930fe5e585ee297cd2d9c23d7536ea3 Mon Sep 17 00:00:00 2001
From: Erwan Jahier <erwan.jahier@univ-grenoble-alpes.fr>
Date: Mon, 6 Apr 2020 10:58:39 +0200
Subject: [PATCH] New: add a gtk3 UI over rdbg named rdbgui4sasa
---
sasa.opam | 1 +
test/Makefile.inc | 9 +-
test/{my-rdbg-tuning.ml => sasa-rdbg-cmds.ml} | 0
tools/rdbgui/dune | 12 +
tools/rdbgui/rdbgui.ml | 309 ++++++++++++++++++
5 files changed, 328 insertions(+), 3 deletions(-)
rename test/{my-rdbg-tuning.ml => sasa-rdbg-cmds.ml} (100%)
create mode 100644 tools/rdbgui/dune
create mode 100644 tools/rdbgui/rdbgui.ml
diff --git a/sasa.opam b/sasa.opam
index 03f1d945..935c4507 100644
--- a/sasa.opam
+++ b/sasa.opam
@@ -23,6 +23,7 @@ depends: [
"dune" { >= "1.11" }
"ocamlgraph"
"lutils"
+ "lablgtk3"
"lustre-v6"
"lutin"
"rdbg" { >= "1.184" }
diff --git a/test/Makefile.inc b/test/Makefile.inc
index 111a45b4..b8c625da 100644
--- a/test/Makefile.inc
+++ b/test/Makefile.inc
@@ -1,4 +1,4 @@
-# Time-stamp: <modified the 11/03/2020 (at 13:59) by Erwan Jahier>
+# Time-stamp: <modified the 06/04/2020 (at 10:35) by Erwan Jahier>
DIR=../../_build/install/default
@@ -37,7 +37,10 @@ LIB=-package algo
sasa $<
%.rdbg: %.dot %.ml
- rdbg -sut "sasa $< -dd"
+ ledit -h rdbg-history -x rdbg -sut "sasa $< -dd"
+
+%.rdbgui: %.dot %.ml
+ ledit -h rdbg-history -x rdbgui4sasa -sut "sasa $< -dd"
@@ -47,7 +50,7 @@ s:sim2chrogtk
genclean:
rm -f *.cmxs sasa *.cm* *.o *.pdf *.rif *.gp *.log *.dro *.seed *.c *.h sasa-*.dot
rm -f rdbg-session*.ml luretteSession* *.lut a.out *.cov read_dot.ml
- rm -f *.exec *.sh grid*.ml read_dot.ml
+ rm -f *.exec *.sh grid*.ml read_dot.ml rdbg-history
##################################################################################
-include Makefile.untracked
diff --git a/test/my-rdbg-tuning.ml b/test/sasa-rdbg-cmds.ml
similarity index 100%
rename from test/my-rdbg-tuning.ml
rename to test/sasa-rdbg-cmds.ml
diff --git a/tools/rdbgui/dune b/tools/rdbgui/dune
new file mode 100644
index 00000000..77345078
--- /dev/null
+++ b/tools/rdbgui/dune
@@ -0,0 +1,12 @@
+
+
+(executables
+ (names rdbgui )
+ (flags :standard -w -3-6-7-10-24-26-27-33-35 -no-strict-sequence)
+ (libraries lablgtk3 str))
+
+(install
+ (section bin)
+ (package sasa)
+(files (rdbgui.exe as rdbgui4sasa))
+)
diff --git a/tools/rdbgui/rdbgui.ml b/tools/rdbgui/rdbgui.ml
new file mode 100644
index 00000000..8709ca66
--- /dev/null
+++ b/tools/rdbgui/rdbgui.ml
@@ -0,0 +1,309 @@
+
+
+let quote str = if String.contains str ' ' then ("\""^str^"\"") else str
+let rdbg_cmd =
+ String.concat " " ("rdbg"::(List.tl (List.map quote (Array.to_list Sys.argv))))
+
+(* let oc_stdin = Unix.open_process_out rdbg_cmd *)
+let ic_stdout, oc_stdin = Unix.open_process rdbg_cmd
+(* let ic_stdout, oc_stdin, ic_stderr =
+ Unix.open_process_full rdbg_cmd (Unix.environment()) *)
+
+let _ =
+ Unix.set_nonblock (Unix.descr_of_in_channel ic_stdout);
+(* Unix.set_nonblock (Unix.descr_of_in_channel ic_stderr) *)
+ ()
+(* let p str = Printf.printf "%s\n%!" str *)
+
+
+let read_stdout ic =
+ let buff = Bytes.create 256 in
+ let res = ref "" in
+ let cond = ref true in
+ Unix.sleepf 0.5;
+ while !cond do
+ try
+ let n = Stdlib.input ic buff 0 256 in
+ res := !res ^ (Bytes.sub_string buff 0 n);
+ if n < 256 then cond := false;
+ with Sys_blocked_io -> cond := false
+ done;
+ if !res <> "" then Printf.printf "%s%!" !res;
+ !res
+
+let gui str =
+ Printf.fprintf oc_stdin "%s\n" str; (* sent the session choice *)
+ Printf.fprintf oc_stdin
+ "del_hook \"print_event\"; add_hook \"print_event\" (print_sasa_event false);;\n%!";
+ (* Printf.fprintf oc_stdin "print_sasa_event false !e;;\n"; (* print the first event *) *)
+
+ let _locale = GMain.init () in
+ let _thread = GtkThread.start() in
+ let w = GWindow.window ~show:true ~title: "A rdbg GUI for sasa" () in
+ 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 text1 = GText.view ~wrap_mode:`CHAR ~height:50 ~editable:false ~width:50
+ ~packing: sw1#add () ~cursor_visible:true
+ in
+ let text2 = GText.view ~wrap_mode:`CHAR ~height:250 ~editable:false
+ ~packing: sw2#add () ~cursor_visible:true
+ in
+ (* text2#place_cursor_onscreen (); *)
+ (* let text3 = GText.view ~editable:false ~packing: box#add () in *)
+
+ (* let input_buff = Buffer.create 100 in *)
+ let p str =
+ (* Buffer.add_string input_buff (str^"\n"); *)
+ (* text1#set_buffer (GText.buffer ~text:(Buffer.contents input_buff) ()); *)
+ text1#set_buffer (GText.buffer ~text:str ());
+ Printf.fprintf oc_stdin "%s\n%!" str;
+ Printf.printf "%s\n%!" str;
+ in
+ (* p str; *)
+ Printf.fprintf oc_stdin "print_sasa_event false !e;;\n%!"; (* print the first event *)
+
+ let readloop () =
+ while true do
+ let str = read_line () in
+ p str;
+ if str="q" then exit 0;
+ done;
+ in
+ (* let str = input_line ic_stdout in *)
+ (* let n_buff = GText.buffer ~text:str () in *)
+ (* text#set_buffer n_buff; *)
+
+
+
+ let bbox = GPack.hbox ~packing: box#add () in
+
+ let change_label button str =
+ let icon = button#image in
+ button#set_label str;
+ button#set_image icon
+ in
+
+ let back_step_button =
+ GButton.button ~use_mnemonic:true ~stock:`GO_BACK ~packing:bbox#add
+ ~label:"back step" ()
+ 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:(fun () -> p "bd"));
+
+ let step_button =
+ GButton.button ~use_mnemonic:true ~packing:bbox#add ~stock:`GO_FORWARD
+ ~label:"step" ()
+ in
+ step_button#misc#set_tooltip_text "Move FORWARD to the next STEP";
+ change_label step_button "_Step";
+ ignore (step_button#connect#clicked ~callback:(fun () -> p "sd"));
+
+ let back_round_button =
+ GButton.button ~packing:bbox#add ~stock:`MEDIA_PREVIOUS ~use_mnemonic:true
+ ~label:"back round" ()
+ in
+ back_round_button#misc#set_tooltip_text "Move BACKWARD to the previous ROUND";
+ change_label back_round_button "Roun_d";
+ ignore (back_round_button#connect#clicked ~callback:(fun () -> p "pr" ));
+
+ let round_button =
+ GButton.button ~use_mnemonic:true ~stock:`MEDIA_FORWARD
+ ~packing:bbox#add ~label:"round" ()
+ in
+ round_button#misc#set_tooltip_text "Move FORWARD to the next ROUND";
+ change_label round_button "_Round";
+ ignore (round_button#connect#clicked ~callback:(fun () -> p "nr"));
+
+ let silence () =
+ let silence_button = GButton.button ~use_mnemonic:true
+ ~packing:bbox#add () in
+ silence_button#misc#set_tooltip_text
+ "Move FORWARD until the algorithm is SILENT (i.e., when no action is enabled)";
+ let image = GMisc.image ~file:"../rdbg-utils/chut_small.svg" () in
+ silence_button#set_image image#coerce;
+ (* change_label silence_button "Silen_t"; *)
+ ignore (silence_button#connect#clicked ~callback:(fun () -> p "silence"))
+
+ in
+ silence ();
+
+ let graph () =
+ let graph_button = GButton.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:"../rdbg-utils/graph_small.png" () in
+ graph_button#set_image image#coerce;
+ ignore (graph_button#connect#clicked ~callback: (fun () -> p "graph_view" ));
+
+ 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 states something wrong happened";
+ (* 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:(fun () -> p "viol"))
+ 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:(fun () -> p "u\nd"));
+
+ 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:(fun ()-> p "r\nd"));
+
+ 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: (fun() -> p "i"));
+
+ let quit_button =
+ GButton.button ~use_mnemonic:true ~stock:`QUIT ~packing:bbox#add ~label:"bye" ()
+ in
+ quit_button#misc#set_tooltip_text "Quit RDBGUI";
+ ignore (quit_button#connect#clicked ~callback: (fun() -> p "q"; 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 parents";
+ par_fd_button#misc#set_tooltip_text "Use fdp, but show only links to parents";
+ par_sf_button#misc#set_tooltip_text "Use sfdp, but show only links to parents";
+ par_ne_button#misc#set_tooltip_text "Use neato, but show only links to parents";
+ par_tw_button#misc#set_tooltip_text "Use twopi, but show only links to parents";
+ par_ci_button#misc#set_tooltip_text "Use circo, but show only links to parents";
+ par_pa_button#misc#set_tooltip_text "Use patchwork, but show only links to parents";
+ par_os_button#misc#set_tooltip_text "Use osage, but show only links to parents";
+ ignore (par_dot_button#connect#clicked
+ ~callback:(fun () -> p "dot_view := d_par; !dot_view();;"));
+ ignore (par_fd_button#connect#clicked
+ ~callback:(fun () -> p "dot_view := fd_par; !dot_view();;"));
+ ignore (par_sf_button#connect#clicked
+ ~callback:(fun () -> p "dot_view := sf_par; !dot_view();;"));
+ ignore (par_ne_button#connect#clicked
+ ~callback:(fun () -> p "dot_view := ne_par; !dot_view();;"));
+ ignore (par_tw_button#connect#clicked
+ ~callback:(fun () -> p "dot_view := tw_par; !dot_view();;"));
+ ignore (par_ci_button#connect#clicked
+ ~callback:(fun () -> p "dot_view := ci_par; !dot_view();;"));
+ ignore (par_pa_button#connect#clicked
+ ~callback:(fun () -> p "dot_view := pa_par; !dot_view();;"));
+ ignore (par_os_button#connect#clicked
+ ~callback:(fun () -> p "dot_view := os_par; !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
+ in
+ if have_parent () then par_dot ();
+ 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";
+ ne_button#misc#set_tooltip_text "Use the neato engine to display the graph";
+ tw_button#misc#set_tooltip_text "Use the twopi engine to display the graph";
+ ci_button#misc#set_tooltip_text "Use the circo engine to display the graph";
+ 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_view:=dot; !dot_view();;"));
+ ignore (fd_button#connect#clicked
+ ~callback:(fun () -> p "dot_view:=fd; !dot_view();;"));
+ ignore (sf_button#connect#clicked
+ ~callback:(fun () -> p "dot_view:=sf; !dot_view();;"));
+ ignore (ne_button#connect#clicked
+ ~callback:(fun () -> p "dot_view:=ne; !dot_view();;"));
+ ignore (tw_button#connect#clicked
+ ~callback:(fun () -> p "dot_view:=tw; !dot_view();;"));
+ ignore (ci_button#connect#clicked
+ ~callback:(fun () -> p "dot_view:=ci; !dot_view();;"));
+ ignore (pa_button#connect#clicked
+ ~callback:(fun () -> p "dot_view:=pa; !dot_view();;"));
+ ignore (os_button#connect#clicked
+ ~callback:(fun () -> p "dot_view:=os; !dot_view();;"));
+
+ ignore (read_stdout ic_stdout);
+ let rec read_stdout_loop () =
+ let res = read_stdout ic_stdout in
+ let res = Str.global_replace (Str.regexp_string "(rdbg) ") "" res in
+ if res <> "" then text2#set_buffer (GText.buffer ~text:res ());
+ (* let res = read_stdout ic_stderr in *)
+ (* if res <> "" then text3#set_buffer (GText.buffer ~text:res ()); *)
+ read_stdout_loop ()
+ in
+
+ let _ = Thread.create read_stdout_loop () in
+
+ (* ignore (Sys.command "rdbg"); *)
+ readloop ()
+ (* GMain.main () *)
+;;
+
+
+let _ =
+ ignore (read_stdout ic_stdout);
+ gui (read_line ()) (* read the session choice *)
--
GitLab