diff --git a/test/rdbg-utils/chut.svg b/test/rdbg-utils/chut.svg new file mode 100644 index 0000000000000000000000000000000000000000..d56d2adcc86adff9736b667b530df0da614ef46d --- /dev/null +++ b/test/rdbg-utils/chut.svg @@ -0,0 +1,20 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!-- Created with Inkscape (http://www.inkscape.org/) --> +<svg id="svg4874" width="96" height="96" version="1.1" viewBox="0 0 96 96" xmlns="http://www.w3.org/2000/svg" xmlns:cc="http://creativecommons.org/ns#" xmlns:dc="http://purl.org/dc/elements/1.1/" xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"> + <metadata id="metadata4879"> + <rdf:RDF> + <cc:Work rdf:about=""> + <dc:format>image/svg+xml</dc:format> + <dc:type rdf:resource="http://purl.org/dc/dcmitype/StillImage"/> + <dc:title/> + </cc:Work> + </rdf:RDF> + </metadata> + <g id="layer1" transform="translate(67.857 -78.505)"> + <rect id="rect4782" transform="rotate(90)" x="78.505" y="-28.143" width="96" height="96" style="color:#000000;fill:none"/> + <path id="path4205" d="m18.729 85.092-80 80 2.8281 2.8281 80-80-2.8281-2.8281z" style="block-progression:tb;color-rendering:auto;color:#000000;fill:#808080;font-feature-settings:normal;font-variant-alternates:normal;font-variant-caps:normal;font-variant-ligatures:normal;font-variant-numeric:normal;font-variant-position:normal;image-rendering:auto;isolation:auto;mix-blend-mode:normal;shape-padding:0;shape-rendering:auto;solid-color:#000000;text-decoration-color:#000000;text-decoration-line:none;text-decoration-style:solid;text-indent:0;text-transform:none;white-space:normal"/> + <path id="path4160" d="m7.8772 95.935-3.5352 3.5352c6.9061 7.2961 10.777 16.961 10.777 27.035 0 10.435-4.1431 20.438-11.521 27.816l3.5352 3.5371c8.3148-8.3148 12.986-19.595 12.986-31.354 0-11.398-4.4005-22.337-12.242-30.57z" style="fill:#808080"/> + <path id="path4158" d="m-2.0056 105.82-3.5352 3.5352c4.2886 4.6701 6.6836 10.785 6.6836 17.152 0 6.7278-2.6704 13.176-7.4277 17.934l3.5352 3.5352c5.6936-5.6936 8.8926-13.417 8.8926-21.469 0-7.6913-2.9247-15.078-8.1484-20.688z" style="fill:#808080"/> + <path id="path4180" transform="translate(-67.857 78.505)" d="m48 8-19.777 19.777h-15.777s-4.4453 7.5806-4.4453 20.23c0 12.65 4.4453 20.215 4.4453 20.215h6.8477l4.002-4.002h-8.2188c-1.0205-2.1051-3.0762-6.9593-3.0762-16.213 0-9.256 2.0577-14.122 3.0781-16.23h14.801l14.121-14.121v25.859l4-4v-31.516zm0 37.172-4 4v29.17l-14.121-14.121h-0.92773l-4.002 4.002h3.2734l19.777 19.777v-42.828z" style="fill:#808080"/> + </g> +</svg> diff --git a/test/rdbg-utils/chut_small.svg b/test/rdbg-utils/chut_small.svg new file mode 100644 index 0000000000000000000000000000000000000000..c21b31e4a5335560d309b7242483b2d538f1d816 --- /dev/null +++ b/test/rdbg-utils/chut_small.svg @@ -0,0 +1,29 @@ +<?xml version="1.0" encoding="UTF-8" standalone="no"?> +<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN" "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd"> +<svg version="1.1" id="Layer_1" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" x="0px" y="0px" width="50px" height="50px" viewBox="0 0 50 50" enable-background="new 0 0 50 50" xml:space="preserve"> <image id="image0" width="50" height="50" x="0" y="0" + xlink:href="data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAADIAAAAyCAQAAAC0NkA6AAAABGdBTUEAALGPC/xhBQAAACBjSFJN +AAB6JgAAgIQAAPoAAACA6AAAdTAAAOpgAAA6mAAAF3CculE8AAAAAmJLR0QA/4ePzL8AAAAJcEhZ +cwAADfsAAA37AQt3NZsAAAAHdElNRQfkAxEIKw8G2AheAAAEXUlEQVRYw+3Y229UVRTH8c+ZzvRG +oa1AoUgLthI1cokGoiYYqSZG4cH4lxpNOiDlgQcToqAIiUSilE5bmGnLTS7t9DJnfOjp4cx9SvTB +xPXS7kv2d6+19l6/PScol/3rlvr3Ef91yKJZW5nYJqRk2rM25uV95xuzrwIJ3XDZahuIrDm9uqN2 +enuIS3oELeYVZM0acda+7XqyiXjRBmJSzoizDsR9bXoS+rUtxH3n5Yw6ZzjR25Ynm16selOPZnf3 +rm/N1iDagoRumFJ0ysdNHc85r2CXz6oQbUBCN11SdMqEnibzCi5aEChaqPG2BSR005QVp0zoahKq +gknzhvRbc8X8diCbgVpx0kR85hshckZ87YwuT/xorWI8nVzylnzF+Sm6FQWqGWLGRfeidO8x7aY/ +3PFOfcgTly0RByVQlm6JyJm0YMhZw+h0yoynbhrXWQ8y7ZE93qrwZZfjTRF5Fy1KCXVEPa970y9y +7nmjFrLmjtB7TmvfCrLu6bfikWu+0IEO77pl2XQCEif+mbxeY9tCTMo56CuHlf2uEPUPGxKa8aIW +8sALew20XLpcgRh1zrj3dHnmdjS2w0EpD/1VC1mybrDpddtE9OlEPkYM47AhoWnFaNZBHdZizxKQ +v5QNtiyA+0zYKS9bUaN6HBJ44mE0a7cuGx5VQ0qWddjZAtHnc28k9GKrRgUO6FCMl+3WJ/QsDm10 +ujasSelqCekz74K5Kr2gT5dlz6NWRjdWbcgkIaGSID7rjW1GVsFoFYJOGeW4mKRksKFUCWnP5p23 +UEcvWllq609aWanp1LwLCvpM1EGsWRfEhSS0jnQcmdRWajLC+AjWR2TNC/TUvUvPrcroi1rriuiq +hnToVYoTV2sFWXMGZOpqStl9Jd1ei9pFz6XsjO9HfE/6BR43kKUtvfikQbFckVM2YHfUfmhVOkYm +Er9XxmMrehsgRp1reFVnLAqMxVuYV9Jrfzwee7LHDkse18nFFmJ/Az+XXbdqVywSL8wL7dZfC9lp +2LK7cZS3ENm6j5xkPm64K/B2vPO8RSmHEzGJw9Vp3G3XLQuU7XVURs737htpei/+cMW6PU5GZ6nk +N0U7jCWCm7iMY16z5IGyIeMykbD21XlHvbSSaU91Ox2/e+/5E6NeT8xKQAackRdIOWJE3gULAqtu +G24owR0+smzQsai95qqnup1IKHwFJOWoo9H/m8J6yJif/ST0aUNMvy+l42V+cxtHjFfMqVu7XqZ7 +n0FTrtEE81Lo5v1g1YAPKvyoC8lHenHOfhzHlGsCn7aQtAcueSjjQwerRmog1ZKUclzZlKsCbzeF +/G5W4Jj3azaTrkZMRoiXepFyAlOuWrJRFYikHVOw7kwd6UtXI3J1f1+cwCV/CuxoCOn3pbCuhCcg +edm6iCSmcZ1Gww3EkFYFJOWEwEWv8pUkgiyaNNeigKQcF/r1FTARpGi5BWLLm8GWb5paCza/EpXN +6Yrrzz9twf+forZjfwN/YnagMZnv5AAAACV0RVh0ZGF0ZTpjcmVhdGUAMjAyMC0wMy0xN1QwODo0 +MzoxNSswMTowMPJWgN0AAAAldEVYdGRhdGU6bW9kaWZ5ADIwMjAtMDMtMTdUMDg6NDM6MTUrMDE6 +MDCDCzhhAAAAGXRFWHRTb2Z0d2FyZQB3d3cuaW5rc2NhcGUub3Jnm+48GgAAAABJRU5ErkJggg==" /> +</svg> diff --git a/test/rdbg-utils/graph.png b/test/rdbg-utils/graph.png new file mode 100644 index 0000000000000000000000000000000000000000..c715327e8d2141fde84a535493b37d11bc1dfe64 Binary files /dev/null and b/test/rdbg-utils/graph.png differ diff --git a/test/rdbg-utils/graph_small.png b/test/rdbg-utils/graph_small.png new file mode 100644 index 0000000000000000000000000000000000000000..fe734a819ed9d70d3e2e3dd4296ef72f50c8b2d4 Binary files /dev/null and b/test/rdbg-utils/graph_small.png differ diff --git a/test/rdbg-utils/oracle.jpg b/test/rdbg-utils/oracle.jpg new file mode 100644 index 0000000000000000000000000000000000000000..5ba9ecbd148b07cc1dfe21220f92e1df4e0dea84 Binary files /dev/null and b/test/rdbg-utils/oracle.jpg differ diff --git a/test/rdbg-utils/oracle_small.jpg b/test/rdbg-utils/oracle_small.jpg new file mode 100644 index 0000000000000000000000000000000000000000..a14cd8aa27c45cbea623e65b58325c3753c83a16 Binary files /dev/null and b/test/rdbg-utils/oracle_small.jpg differ diff --git a/test/rdbg-utils/rdbgui.ml b/test/rdbg-utils/rdbgui.ml new file mode 100644 index 0000000000000000000000000000000000000000..795b882582aaca557e14e0d6033635725981c46a --- /dev/null +++ b/test/rdbg-utils/rdbgui.ml @@ -0,0 +1,202 @@ +#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 ()