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

Merge the 2 sasa/rdbg GUI

parent 8ac1bbad
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/daemongui.ml
+ 350
− 86
View file @ 272e76b3
......@@ -77,25 +77,7 @@ let init_rdbg_hook () =
in
rdbg_mv_hook := Some guidaemon
(* GTK3 *)
let main () =
let _locale = GtkMain.Main.init () in
let _thread = GtkThread.start () in
let window = GWindow.window
(* ~width:320 ~height:240 *)
~title:"Daemon GUI"
~show:true () in
let vbox = GPack.vbox ~packing:window#add () ~homogeneous:false in
ignore (window#connect#destroy ~callback: (
fun () ->
quit (); (* quit rdbg, this will stop the readloop below *)
Main.quit () (* terminate gtk *)
));
(* Affichage d'informations *)
let gtext_content = ref "" in
let custom_daemon gtext vbox =
(* création du rdbg_mv_hook et de tout ce qu'il faut autour *)
init_rdbg_hook ();
......@@ -122,9 +104,6 @@ let main () =
let scrolled = GBin.scrolled_window ~border_width:10
~shadow_type:`OUT ~height:150 ~packing:vbox#add ()
in
let gtext = GText.view ~wrap_mode:`CHAR ~height:50 ~editable:false ~width:50
~packing: scrolled#add () ~cursor_visible:true
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");
......@@ -325,75 +304,360 @@ let main () =
ignore(dk_manual#connect#clicked ~callback:set_manual_mode);
ignore(dk_manual_central#connect#clicked ~callback:set_manual_central_mode);
(* Affichage d'informations *)
gtext#buffer#set_text !gtext_content;
let _print_gui str =
let txt = Printf.sprintf "%s\n%s" str (str_of_sasa_event true !e) in
gtext#buffer#set_text txt;
gtext_content := txt;
in
(* Boutons de contrôle de la simulation *)
let hbox = GPack.hbox ~packing:vbox#add () in
let rdbg_btn label tip cmd =
let btn = GButton.button ~label:label ~packing:hbox#add () in
btn#misc#set_tooltip_text tip;
ignore (btn#connect#clicked ~callback: (
fun () ->
cmd ();
refresh ();
));
btn
in
let rec get_higher_prioriry nl =
let prio n =
let counter = Hashtbl.find counter_map n in
counter#get
(* gtext#buffer#set_text !gtext_content; *)
let rec get_higher_prioriry nl =
let prio n =
let counter = Hashtbl.find counter_map n in
counter#get
in
let rec aux p acc = function
| [] -> acc
| (n, false)::t -> aux p acc t
| (n, true)::t ->
let pn = prio n in
if p > pn then aux p acc t else
if p = pn then aux p (n::acc) t else
aux pn [n] t
in
aux 0 [] nl
in
let rec aux p acc = function
| [] -> acc
| (n, false)::t -> aux p acc t
| (n, true)::t ->
let pn = prio n in
if p > pn then aux p acc t else
if p = pn then aux p (n::acc) t else
aux pn [n] t
let step () =
match !daemon_kind with
| Distributed ->
gtext#buffer#set_text "finish me"
| Synchronous -> (
let nodes_enabled = rdbg_nodes_enabled !e in
let nodes = get_higher_prioriry nodes_enabled in
List.iter
(fun (n,_) ->
if List.mem n nodes
then Hashtbl.add daemongui_activate n true
else Hashtbl.add daemongui_activate n false
)
nodes_enabled;
sd ();
gtext#buffer#set_text ("Synchronous step : " ^ (String.concat "," nodes))
)
| Central ->
gtext#buffer#set_text "finish me"
| LocCentral ->
gtext#buffer#set_text "finish me"
| ManualCentral -> () (* SNO *)
| Manual -> sd ()
in
aux 0 [] nl
step
let prefix =
try
let opam_dir = Unix.getenv "OPAM_SWITCH_PREFIX" in
opam_dir
with Not_found -> "$HOME/sasa/"
let lib_prefix = prefix ^ "/lib/sasa"
let libui_prefix = prefix ^ "/lib/rdbgui4sasa"
let oc_stdin = stdout
let ic_stdout = stdin
(* GTK3 *)
let main () =
let _locale = GtkMain.Main.init () in
let _thread = GtkThread.start () in
let window = GWindow.window
(* ~width:320 ~height:240 *)
~title:"A rdbg GUI for sasa"
~show:true ()
in
let step () =
match !daemon_kind with
| Distributed ->
gtext#buffer#set_text "finish me"
| Synchronous -> (
let nodes_enabled = rdbg_nodes_enabled !e in
let nodes = get_higher_prioriry nodes_enabled in
List.iter
(fun (n,_) ->
if List.mem n nodes
then Hashtbl.add daemongui_activate n true
else Hashtbl.add daemongui_activate n false
)
nodes_enabled;
sd ();
gtext#buffer#set_text ("Synchronous step : " ^ (String.concat "," nodes))
)
| Central ->
gtext#buffer#set_text "finish me"
| LocCentral ->
gtext#buffer#set_text "finish me"
| ManualCentral -> () (* SNO *)
| Manual -> sd ()
in
let _ = rdbg_btn "<<" "previous round" pr in
let _ = rdbg_btn "<" "previous step" bd in
let _ = rdbg_btn "G" "display the network" graph_view in
let _ = rdbg_btn ">" "next step" step in
let _ = rdbg_btn ">>" "next round" nr in
let _ = rdbg_btn "q" "end the session" q in
let w = GPack.vbox ~packing:window#add () ~homogeneous:false 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 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
let p str =
text_out#set_buffer (GText.buffer ~text:str ());
Printf.fprintf oc_stdin "%s\n%!" str;
Printf.printf "%s\n%!" str;
in
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 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 button_cb cmd () =
cmd ();
let txt = Printf.sprintf "%s" (str_of_sasa_event false !e) in
text_out#buffer#set_text txt
in
let button_cb_string cmd () =
let txt = Printf.sprintf "%s" (cmd ()) in
text_out#buffer#set_text txt
in
let back_step_button =
GButton.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
step_button#misc#set_tooltip_text "Move FORWARD to the next STEP";
change_label step_button "_Step";
ignore (step_button#connect#clicked ~callback:(button_cb 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:(button_cb 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:(button_cb nr));
let legitimate () =
let legitimate_button = GButton.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
legitimate_button#set_image image#coerce;
(* change_label legitimate_button "Silen_t"; *)
ignore (legitimate_button#connect#clicked ~callback:(button_cb legitimate))
in
legitimate ();
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:(libui_prefix^"/graph_small.png") () in
graph_button#set_image image#coerce;
ignore (graph_button#connect#clicked ~callback:(button_cb 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 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()))
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_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()));
ignore (window#connect#destroy ~callback: (
fun () ->
quit (); (* quit rdbg, this will stop the readloop below *)
Main.quit () (* terminate gtk *)
));
(* Affichage d'informations *)
(* let gtext_content = ref "" in *)
let step = custom_daemon text_out w in
refresh ()
let m = main
let gui = main
(* todo
- cacher les boutons de rounds en mode manuel
- cacher le bouton step en mode manuel central
......
tools/rdbg4sasa/sasa-rdbg-cmds.ml
+ 18
− 5
View file @ 272e76b3
......@@ -223,13 +223,18 @@ let goto_next_false_oracle e =
List.mem ("ok", Bool) e.outputs &&
not (vb "ok" e))
let viol () =
let viol_string () =
if args.oracles <> [] then (
e:=goto_next_false_oracle !e; !dot_view ()
e:=goto_next_false_oracle !e; !dot_view (); "An oracle has been violated. Cf the .rif file"
) else (
Printf.printf "No oracle is set.\n%!"
"No oracle is set."
)
;;
let viol () = Printf.printf "%s\n%!" (viol_string ())
let _ = add_doc_entry
"viol" "unit -> unit" "Move forward until the oracle is violated"
"sasa" "sasa-rdbg-cmds.ml"
(**********************************************************************)
(* Move forward until silence *)
......@@ -283,8 +288,16 @@ let _ =
add_doc_entry "nd" "unit -> unit" "go to the next event and update the network" "sasa" "sasa-rdbg-cmds.ml";
add_doc_entry "bd" "unit -> unit" "go to the previous event and update the network" "sasa" "sasa-rdbg-cmds.ml";
add_doc_entry "nr" "unit -> unit" "go to the next round and update the network" "sasa" "sasa-rdbg-cmds.ml";
add_doc_entry "pr" "unit -> unit" "go to the previous round and update the network" "sasa" "sasa-rdbg-cmds.ml"
;;
add_doc_entry "pr" "unit -> unit" "go to the previous round and update the network" "sasa" "sasa-rdbg-cmds.ml";
add_doc_entry "d_par" "unit -> unit" "cf d (for topology with a parent field)" "sasa" "sasa-rdbg-cmds.ml";
add_doc_entry "ne_par" "unit -> unit" "cf ne (for topology with a parent field)" "sasa" "sasa-rdbg-cmds.ml";
add_doc_entry "tw_par" "unit -> unit" "cf tw (for topology with a parent field)" "sasa" "sasa-rdbg-cmds.ml";
add_doc_entry "ci_par" "unit -> unit" "cf ci (for topology with a parent field)" "sasa" "sasa-rdbg-cmds.ml";
add_doc_entry "fd_par" "unit -> unit" "cf fd (for topology with a parent field)" "sasa" "sasa-rdbg-cmds.ml";
add_doc_entry "sf_par" "unit -> unit" "cf sf (for topology with a parent field)" "sasa" "sasa-rdbg-cmds.ml";
add_doc_entry "pa_par" "unit -> unit" "cf pa (for topology with a parent field)" "sasa" "sasa-rdbg-cmds.ml";
add_doc_entry "os_par" "unit -> unit" "cf os (for topology with a parent field)" "sasa" "sasa-rdbg-cmds.ml";
()
let l () =
l();
......
tools/rdbgui4sasa/dune
+ 1
− 1
View file @ 272e76b3
......@@ -13,7 +13,7 @@
)
)
(install
(files chut_small.svg graph_small.png)
(files chut_small.svg graph_small.png gui2use.ml)
(section lib)
(package rdbgui4sasa)
)
......
tools/rdbgui4sasa/rdbgui.ml
+ 3
− 320
View file @ 272e76b3
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 prefix =
try
let opam_dir = Unix.getenv "OPAM_SWITCH_PREFIX" in
opam_dir
with Not_found -> "$HOME/sasa/"
let lib_prefix = prefix ^ "/lib/sasa"
let libui_prefix = prefix ^ "/lib/rdbgui4sasa"
let gui str =
Printf.fprintf oc_stdin "%s\n" str; (* sent the session choice *)
(* Printf.fprintf oc_stdin "#require \"sasa\";;\n%!" ; *)
(* Printf.fprintf oc_stdin "#use \"sasa-rdbg-cmds.ml\";;\n%!"; *)
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 "#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 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 legitimate () =
let legitimate_button = GButton.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
legitimate_button#set_image image#coerce;
(* change_label legitimate_button "Silen_t"; *)
ignore (legitimate_button#connect#clicked ~callback:(fun () -> p "legitimate"))
in
legitimate ();
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:(libui_prefix^"/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 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 "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 welcome () =
Printf.printf "rdbgui4sasa is a GUI wrapper around rdbg when used with sasa\n";
Printf.printf "you can thus replace rdbg by rdbgui4sasa, but sasa *must be* involved in the session\n";
Printf.printf "Example: \n";
Printf.printf "you can thus replace rdbg by rdbgui4sasa, but sasa *must be* ";
Printf.printf "involved in the session\nExample: \n";
Printf.printf " rdbgui4sasa -sut \"sasa g.dot\"\n";
Printf.printf " rdbgui4sasa -h\n\n";
flush stdout
......@@ -331,5 +15,4 @@ let _ =
let n = Array.length Sys.argv in
welcome ();
if n = 1 && Mypervasives.ls "rdbg-session" "ml" = [] then exit 0;
ignore (read_stdout ic_stdout);
gui (read_line ()) (* read the session choice *)
Sys.command rdbg_cmd
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