rdbgui.ml 8.51 KiB
#thread;;
#require "lablgtk3";;
(*
- comment rafraichir
-
*)
let gui () =
let _locale = GMain.init () in
let _thread = GtkThread.start() in
let w = GWindow.window ~show:true ~title: "rdbgui" () 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 text = GText.view ~packing: box#add () in
let bbox = GPack.hbox ~packing: box#add () in
let up () =
text#buffer#set_text
(Printf.sprintf "step %d; round %d " !e.step !roundnb )
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 ~stock:`GO_BACK ~packing:bbox#add ~label:"back step" ()
in
back_step_button#misc#set_tooltip_text "Go Back to Previous Step";
change_label back_step_button "Step";
ignore (back_step_button#connect#clicked ~callback:(fun () -> bd(); up()));
let step_button =
GButton.button ~packing:bbox#add ~stock:`GO_FORWARD ~label:"step" ()
in
step_button#misc#set_tooltip_text "Go Forward to Next Step";
change_label step_button "Step";
ignore (step_button#connect#clicked ~callback:(fun () -> sd(); up()));
let back_round_button =
GButton.button ~packing:bbox#add ~stock:`MEDIA_PREVIOUS
~label:"back round" ()
in
back_round_button#misc#set_tooltip_text "Go Backward to Previous Round";
change_label back_round_button "Round";
ignore (back_round_button#connect#clicked ~callback:(fun () -> pr();up() ));
let round_button =
GButton.button ~stock:`MEDIA_FORWARD ~packing:bbox#add ~label:"round" ()
in
round_button#misc#set_tooltip_text "Go Forward to Next Round";
change_label round_button "Round";
ignore (round_button#connect#clicked ~callback:(fun () -> nr (); up()));
let silence () =
let silence_button = GButton.button ~packing:bbox#add () in
silence_button#misc#set_tooltip_text "Move Forward Until No Action is Enabled";
let image = GMisc.image ~file:"../rdbg-utils/chut_small.svg" () in
silence_button#set_image image#coerce;
ignore (silence_button#connect#clicked ~callback:(fun () -> silence(); up()))
in
silence ();
let graph () = let graph_button = GButton.button ~packing:bbox#add () in
graph_button#misc#set_tooltip_text "View the Topology";
let image = GMisc.image ~file:"../rdbg-utils/graph_small.png" () in
graph_button#set_image image#coerce;
ignore (graph_button#connect#clicked ~callback:graph_view);
in
graph ();
let viol_oracle () =
let viol_button = GButton.button ~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;
ignore (viol_button#connect#clicked ~callback:(fun () -> viol(); up()))
in
if args.oracles <> [] then viol_oracle ();
let undo_button = GButton.button ~stock:`UNDO
~packing:bbox#add ~label:"undo" ()
in
undo_button#misc#set_tooltip_text "Undo Last Move";
ignore (undo_button#connect#clicked ~callback:(fun () -> u();up();!dot_view ()));
let restart_button = GButton.button ~stock:`REFRESH
~packing:bbox#add ~label:"restart" ()
in
restart_button#misc#set_tooltip_text "Restart from the beginning";
change_label restart_button "Restart";
ignore (restart_button#connect#clicked ~callback:(fun ()-> r();up()));
let quit_button =
GButton.button ~stock:`QUIT ~packing:bbox#add ~label:"bye" ()
in
quit_button#misc#set_tooltip_text "Quit RDBGUI";
ignore (quit_button#connect#clicked ~callback:quit);
let dot_button = GButton.radio_button ~packing:gbox#add ~label:"dot" () in
let fd_button = GButton.radio_button ~packing:gbox#add
~active:true ~group:dot_button#group ~label:"fdp" ()
in
dot_view := fd;
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
~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 () -> dot_view := d_par; !dot_view ()));
ignore (par_fd_button#connect#clicked
~callback:(fun () -> dot_view := fd_par; !dot_view ()));
ignore (par_sf_button#connect#clicked
~callback:(fun () -> dot_view := sf_par; !dot_view ()));
ignore (par_ne_button#connect#clicked
~callback:(fun () -> dot_view := ne_par; !dot_view ()));
ignore (par_tw_button#connect#clicked
~callback:(fun () -> dot_view := tw_par; !dot_view ()));
ignore (par_ci_button#connect#clicked
~callback:(fun () -> dot_view := ci_par; !dot_view ()));
ignore (par_pa_button#connect#clicked
~callback:(fun () -> dot_view := pa_par; !dot_view ()));
ignore (par_os_button#connect#clicked
~callback:(fun () -> 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
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 () -> dot_view := dot; !dot_view ()));
ignore (fd_button#connect#clicked ~callback:(fun () -> dot_view := fd; !dot_view ()));
ignore (sf_button#connect#clicked ~callback:(fun () -> dot_view := sf; !dot_view ()));
ignore (ne_button#connect#clicked ~callback:(fun () -> dot_view := ne; !dot_view ()));
ignore (tw_button#connect#clicked ~callback:(fun () -> dot_view := tw; !dot_view ()));
ignore (ci_button#connect#clicked ~callback:(fun () -> dot_view := ci; !dot_view ()));
ignore (pa_button#connect#clicked ~callback:(fun () -> dot_view := pa; !dot_view ()));
ignore (os_button#connect#clicked ~callback:(fun () -> dot_view := os; !dot_view ()));
up()
;;
let _ = gui ()