From 12e571b0e473cce5b1847218a669714cdba7722b Mon Sep 17 00:00:00 2001 From: Erwan Jahier <erwan.jahier@univ-grenoble-alpes.fr> Date: Wed, 24 Mar 2021 11:56:17 +0100 Subject: [PATCH] Add a daemongui.ml similar to gui.ml except that to try it : cd test/coloring echo "(* Do not edit me ; edit mv_hook.ml instead! *)" > include.ml echo "#use \"../../tools/rdbg4sasa/daemongui.ml\";;" >> include.ml make grid4.ml ledit rdbg --missing-vars-last -env "sasa grid4.dot -custd" --- tools/rdbg4sasa/daemongui.ml | 161 +++++++++++++++++++++++++++++++++++ tools/rdbg4sasa/dune | 2 +- 2 files changed, 162 insertions(+), 1 deletion(-) create mode 100644 tools/rdbg4sasa/daemongui.ml diff --git a/tools/rdbg4sasa/daemongui.ml b/tools/rdbg4sasa/daemongui.ml new file mode 100644 index 00000000..aa1de506 --- /dev/null +++ b/tools/rdbg4sasa/daemongui.ml @@ -0,0 +1,161 @@ + +#thread +#require "lablgtk3" + +open GMain +open GdkKeysyms +open RdbgEvent +open Data + +(** Extrait le nom et l'état des noeuds +@return liste de tuples (nom, etat, activable) +*) +let rdbg_nodes_info e: (string * string * bool) list = + (* récupère une liste qui dit si chaque état de chaque noeud est activable/pas activable *) + let enabled = + List.filter (fun (n,v) -> String.length n > 5 && String.sub n 0 5 = "Enab_") e.data + in + let split_var (str, value) = + let v = match value with B v -> v | _ -> assert false in + let p, label = + match String.split_on_char '_' str with + | [] | _::[] | _::_::[] -> assert false + | _::x::y::_ -> x, y + in + p, label,v + in + List.map split_var enabled + +(** Hashtable qui dit pour chaque noeud s'il est activable (cà d s'il a un état activable) ou non. +On considère que les états sont mutuellement exclusifs. *) +let rdbg_nodes_enabled e = + let table = Hashtbl.create 8 in + List.iter (fun (node, state, enabled) -> + let prev_enab = + match Hashtbl.find_opt table node with + | None -> false + | Some e -> e + in + Hashtbl.replace table node (prev_enab || enabled) + ) + (rdbg_nodes_info e); + table + +let daemongui_activate = Hashtbl.create 1 + +(** Met en place le hook *) +let init_rdbg_hook () = + let daemongui sl = + let sl = List.filter (fun (n,v) -> String.length n > 5 && String.sub n 0 5 = "Enab_") sl in + let res = List.map (fun (n,enabled) -> + (* n est de la forme Enab_node_state, enabled est un Data.v *) + let str = String.sub n 5 ((String.length n)-5) in + let node_name = List.hd (String.split_on_char '_' str) in + let to_activate = match Hashtbl.find_opt daemongui_activate node_name with + | None -> false + | Some x -> x + in + let activate = match enabled with + | B true -> B to_activate + | _ -> B false + in + (str, activate) + ) sl + in + Some res + in + rdbg_mv_hook := Some daemongui + +(** Met à jour le hook pour un noeud *) +let update_rdbg_hook node activate = + Hashtbl.replace daemongui_activate node activate + +(* 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 () in + ignore (window#connect#destroy ~callback: ( + fun () -> + quit (); (* quit rdbg, this will stop the readloop below *) + Main.quit () (* terminate gtk *) + )); + + (* création du rdbg_mv_hook et de tout ce qu'il faut autour *) + init_rdbg_hook (); + + (* 1 case par noeud : activer/pas activer *) + (* NB : lablgtk3 ne propose pas le FlowBox (pourtant dispo dans GTK >= 3.12) *) + let container = GPack.hbox ~packing:vbox#add () in + let nodes_table = rdbg_nodes_enabled !e in + let nodes_enabled = Hashtbl.to_seq nodes_table in + let n = Hashtbl.length nodes_table in + + let checkboxes_map = Hashtbl.create n in + Seq.iter (fun (name, enabled) -> + (* cf. classe toggle_button de lablgtk3 *) + let checkbox = GButton.check_button ~label:name ~packing:container#add () in + (* Quand on coche/décoche, met à jour le rdbg_mv_hook *) + ignore(checkbox#connect#toggled ~callback: (fun () -> + update_rdbg_hook name checkbox#active + )); + checkbox#set_sensitive enabled; (* désactive la box si le noeud n'est pas activable *) + checkbox#set_active false; (* décoche la case *) + Hashtbl.add checkboxes_map name checkbox + ) nodes_enabled; + + let update_checkbox node enabled = + let checkbox = Hashtbl.find checkboxes_map node in + checkbox#set_sensitive enabled + in + + (* Affichage d'informations *) + let scrolled = GBin.scrolled_window ~border_width:10 + ~shadow_type:`OUT ~height:250 ~packing:vbox#add () + in + let gtext = GText.view ~wrap_mode:`CHAR ~height:50 ~editable:false ~width:50 + ~packing: scrolled#add () ~cursor_visible:true + in + let gtext_content = ref "Noeuds activables :" in + gtext#buffer#set_text !gtext_content; + let print_gui str = + let txt = Printf.sprintf "%s\n%s" !gtext_content str in + gtext#buffer#set_text txt; + gtext_content := txt; + in + Seq.iter (fun (name, enabled) -> + print_gui (Printf.sprintf "%s : %B" name enabled); + ) nodes_enabled; + + (* Boutons de contrôle de la simulation *) + let hbox = GPack.hbox ~packing:vbox#add () in + let update_all_checkboxes () = + print_gui "Nouveaux noeuds activables :"; + Seq.iter (fun (name, enabled) -> + update_checkbox name enabled; + print_gui (Printf.sprintf "%s : %B" name enabled); + ) + (Hashtbl.to_seq (rdbg_nodes_enabled !e)) + in + let rdbg_btn label cmd = + let btn = GButton.button ~label:label ~packing:hbox#add () in + btn#misc#set_tooltip_text "tooltip"; + ignore (btn#connect#clicked ~callback: ( + fun () -> + cmd (); + print_gui (Printf.sprintf "> %s" label); + update_all_checkboxes (); + )); + btn + in + let _ = rdbg_btn "<<" pr in + let _ = rdbg_btn "<" bd in + let _ = rdbg_btn "G" graph_view in + let _ = rdbg_btn ">" sd in + let _ = rdbg_btn ">>" nr in + let _ = rdbg_btn "q" q in + () diff --git a/tools/rdbg4sasa/dune b/tools/rdbg4sasa/dune index 2fcfde61..25cbaac4 100644 --- a/tools/rdbg4sasa/dune +++ b/tools/rdbg4sasa/dune @@ -1,6 +1,6 @@ (install - (files sasa-rdbg-cmds.ml dot4sasa.ml) + (files sasa-rdbg-cmds.ml dot4sasa.ml daemongui.ml) (section lib) (package sasa) ) -- GitLab