New: add a gtk3 UI over rdbg named rdbgui4sasa

sasa.opam

@@ -23,6 +23,7 @@ depends: [
   "dune" { >= "1.11" }
   "ocamlgraph"
   "lutils"
+  "lablgtk3"
   "lustre-v6"
   "lutin"
   "rdbg" { >= "1.184" }

test/Makefile.inc

-# 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

tools/rdbgui/dune

+
+
+(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))
+)

tools/rdbgui/rdbgui.ml

+
+
+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 *)