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

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

tools/rdbg4sasa/dune

 
 (install
- (files sasa-rdbg-cmds.ml dot4sasa.ml)
+ (files sasa-rdbg-cmds.ml dot4sasa.ml daemongui.ml)
  (section lib)
  (package sasa)
 )