From ce09a30489dce8ac9e389c8c1525a34d1e02354e Mon Sep 17 00:00:00 2001
From: =?utf8?q?Kim=20Nguy=E1=BB=85n?= <kn@lri.fr>
Date: Thu, 14 Mar 2013 21:29:39 +0100
Subject: [PATCH 1/1] Add a 'trace' mode (must be enabled at build time) that
 saves the tree and all information to a browsable svg.

---
 .gitignore            |  4 +-
 build                 | 10 +++--
 myocamlbuild.ml       |  4 +-
 src/auto.mlpack       |  1 +
 src/auto/ata.ml       | 14 ++++++-
 src/auto/eval.ml      | 31 +++++++++++++--
 src/auto/html.ml      | 93 +++++++++++++++++++++++++++++++++++++++++++
 src/auto/html.mli     |  2 +
 tests/trace/trace.css | 16 ++++++++
 tools/add_onclick.sh  |  3 ++
 10 files changed, 167 insertions(+), 11 deletions(-)
 create mode 100644 src/auto/html.ml
 create mode 100644 src/auto/html.mli
 create mode 100644 tests/trace/trace.css
 create mode 100755 tools/add_onclick.sh

diff --git a/.gitignore b/.gitignore
index d035efa..b2e50f4 100644
--- a/.gitignore
+++ b/.gitignore
@@ -3,4 +3,6 @@ _build
 *.byte
 tests/*.results/*
 *.class
-
+tests/trace/*.html
+tests/trace/*.dot
+tests/trace/*.svg
\ No newline at end of file
diff --git a/build b/build
index 2b29bba..f381c94 100755
--- a/build
+++ b/build
@@ -20,6 +20,7 @@ let target = ref [ ]
 let debug = ref false
 let profile = ref false
 let verbose = ref false
+let trace = ref false
 
 let dir = Sys.getcwd ()
 let project_root = Filename.dirname Sys.argv.(0)
@@ -30,11 +31,12 @@ let () =
     | "-d" -> debug := true
     | "-p" -> profile := true
     | "-v" -> verbose := true
+    | "-t" -> trace := true
     | x -> target := x :: !target
   done
-
+let otrace = if !trace then " -tag htmltrace " else ""
 let oprofile = if !profile then " -tag profile " else ""
-let odebug = if !profile then " -tag debug " else ""
+let odebug = if !debug then " -tag debug " else ""
 let clean_first = ref false
 let () =
   Sys.chdir project_root;
@@ -52,8 +54,8 @@ let otarget = List.fold_left (fun acc t ->
 let overbose = if !verbose then " -classic-display " else ""
 let clean_cmd = if !clean_first then "ocamlbuild -clean;" else ""
 let build_cmd = if otarget = "" then "" else
-    Printf.sprintf "ocamlbuild -use-ocamlfind %s %s %s %s"
-      overbose  oprofile  odebug otarget
+    Printf.sprintf "ocamlbuild -use-ocamlfind %s %s %s %s %s"
+      overbose otrace oprofile  odebug otarget
 let i = Sys.command  (clean_cmd ^ build_cmd)
 let () = Sys.chdir dir;
   Printf.printf "Leaving directory `%s'\n%!" project_root
diff --git a/myocamlbuild.ml b/myocamlbuild.ml
index 0ea5ff0..5ce02af 100644
--- a/myocamlbuild.ml
+++ b/myocamlbuild.ml
@@ -28,9 +28,11 @@ let () = dispatch begin
   function
     | Before_rules -> ()
     | After_rules ->
-        set_flags [["ocaml";"compile"]; ["ocaml";"ocamldep"] ] macro_flags;
+        set_flags [["ocaml";"compile"]; ["ocaml"; "ocamldep"] ] macro_flags;
         pflag [ "ocaml"; "compile" ] "warning"   (fun s -> (S[ A"-w"; A s]));
         flag [ "ocaml"; "compile"; "debug" ] (S[ A"-g"; A"-ppopt"; A"-DDEBUG"]);
+        flag [ "ocaml"; "compile"; "htmltrace" ] (S[ A"-ppopt"; A"-DHTMLTRACE"]);
+        flag [ "ocaml"; "ocamldep"; "htmltrace" ] (S[ A"-ppopt"; A"-DHTMLTRACE"]);
         flag [ "ocaml"; "link"; "debug" ] (A"-g");
         flag [ "ocaml"; "compile"; "profile"] (S[A"-ppopt"; A"-DPROFILE"]);
         flag [ "ocaml"; "compile"; "profile"; "native"] (A"-p");
diff --git a/src/auto.mlpack b/src/auto.mlpack
index 5c493b4..3ec7d78 100644
--- a/src/auto.mlpack
+++ b/src/auto.mlpack
@@ -3,3 +3,4 @@ auto/Formula
 auto/Eval
 auto/State
 auto/StateSet
+auto/Html
diff --git a/src/auto/ata.ml b/src/auto/ata.ml
index 9e5e57f..1015513 100644
--- a/src/auto/ata.ml
+++ b/src/auto/ata.ml
@@ -14,7 +14,7 @@
 (***********************************************************************)
 
 (*
-  Time-stamp: <Last modified on 2013-03-13 18:31:19 CET by Kim Nguyen>
+  Time-stamp: <Last modified on 2013-03-14 19:14:03 CET by Kim Nguyen>
 *)
 
 INCLUDE "utils.ml"
@@ -161,7 +161,17 @@ module Transition = Hcons.Make (struct
     HASHINT4 (PRIME1, a, ((QNameSet.uid b) :> int), ((SFormula.uid c) :> int))
 end)
 
-module TransList : Hlist.S with type elt = Transition.t = Hlist.Make(Transition)
+module TransList : sig
+  include Hlist.S with type elt = Transition.t
+  val print : Format.formatter -> t -> unit
+end =
+  struct
+    include Hlist.Make(Transition)
+    let print ppf l =
+      iter (fun t ->
+        let q, lab, f = Transition.node t in
+        fprintf ppf "%a, %a -> %a<br/>" State.print q QNameSet.print lab SFormula.print f) l
+  end
 
 let get_trans a states tag =
   StateSet.fold (fun q acc0 ->
diff --git a/src/auto/eval.ml b/src/auto/eval.ml
index a5b30f1..3192773 100644
--- a/src/auto/eval.ml
+++ b/src/auto/eval.ml
@@ -14,7 +14,7 @@
 (***********************************************************************)
 
 (*
-  Time-stamp: <Last modified on 2013-03-14 13:52:04 CET by Kim Nguyen>
+  Time-stamp: <Last modified on 2013-03-14 19:13:55 CET by Kim Nguyen>
 *)
 
 INCLUDE "utils.ml"
@@ -27,6 +27,16 @@ module Make (T : Tree.Sig.S) :
   end
  = struct
 
+
+IFDEF HTMLTRACE
+  THEN
+DEFINE TRACE(e) = (e)
+  ELSE
+DEFINE TRACE(e) = ()
+END
+
+
+
   type cache = StateSet.t Cache.N1.t
   let get c t n = Cache.N1.find c (T.preorder t n)
 
@@ -128,6 +138,10 @@ module Make (T : Tree.Sig.S) :
               (auto.Ata.states.StateSet.id :> int) trs; trs)
           else trs
         in
+        let () =
+          TRACE(Html.trace (T.preorder tree node) _i "Pre States: %a<br/>Pre Trans: %a<br/>"
+                  StateSet.print states0 Ata.TransList.print trans0)
+        in
         let ps = get cache tree parent in
         let fcs = get cache tree fc in
         let nss = get cache tree ns in
@@ -141,17 +155,26 @@ module Make (T : Tree.Sig.S) :
         let trans1, states1 =
           eval_trans trans_cache6 trans0 node_info fcs nss ps states0
         in
+        let () =
+          TRACE(Html.trace (T.preorder tree node) _i "TD States: %a<br/>TD Trans: %a<br/>" StateSet.print states1 Ata.TransList.print trans1)
+        in
         if states1 != states0 then set cache tree node states1;
         let () = loop fc in
         let fcs1 = get cache tree fc in
         let trans2, states2 =
           eval_trans trans_cache6 trans1 node_info fcs1 nss ps states1
         in
+        let () =
+          TRACE(Html.trace (T.preorder tree node) _i "Left BU States: %a<br/>Left BU Trans: %a<br/>" StateSet.print states2 Ata.TransList.print trans2)
+        in
         if states2 != states1 then set cache tree node states2;
         let () = loop ns in
-        let _, states3 =
+        let _trans3, states3 =
           eval_trans trans_cache6 trans2 node_info fcs1 (get cache tree ns) ps states2
         in
+        let () =
+          TRACE(Html.trace (T.preorder tree node) _i "Right BU States: %a<br/>Right BU Trans: %a<br/>" StateSet.print states3 Ata.TransList.print _trans3)
+        in
         if states3 != states2 then set cache tree node states3;
         if states0 != states3 && (not !redo) then redo := true
       end
@@ -196,6 +219,8 @@ module Make (T : Tree.Sig.S) :
       redo := top_down_run auto tree node cache trans_cache2 trans_cache6 !iter;
       incr iter;
     done;
-    get_results auto tree node cache
+    let r = get_results auto tree node cache in
+    TRACE(Html.gen_trace (module T : Tree.Sig.S with type t = T.t) (tree));
+    r
 
 end
diff --git a/src/auto/html.ml b/src/auto/html.ml
new file mode 100644
index 0000000..06f04a5
--- /dev/null
+++ b/src/auto/html.ml
@@ -0,0 +1,93 @@
+open Format
+module M = Map.Make(struct type t = int let compare = compare end)
+
+let info = Hashtbl.create 2017
+
+
+let add_info (nodeid:int) (i:int) s =
+  let m = try Hashtbl.find info nodeid with Not_found -> M.empty in
+  let old_s = try M.find i m with Not_found -> "" in
+  let s' = old_s ^ s in
+  let m' = M.add i s' m in
+  Hashtbl.replace info nodeid m'
+
+let buff = Buffer.create 20
+let fmt = formatter_of_buffer buff
+
+let trace nodeid i =
+  let () = pp_print_flush fmt ();
+    Buffer.clear buff
+  in
+  kfprintf (fun fmt ->
+    pp_print_flush fmt ();
+    let s = Buffer.contents buff in
+    add_info nodeid i s) fmt
+
+
+let gen_trace (type s)  = (); fun t tree ->
+  let module T = (val (t) : Tree.Sig.S with type t = s) in
+  let rec loop odot ohtml node parent =
+    if node == T.nil then () else begin
+      let s_node = "node" ^ (string_of_int (T.preorder tree node)) in
+      fprintf odot "%s[ id=\"%s\" label=\"%s\"];\n"
+        s_node s_node (Utils.QName.to_string (T.tag tree node));
+      let m =
+        try
+          Hashtbl.find info (T.preorder tree node)
+        with Not_found -> M.empty
+      in
+      fprintf ohtml "data['%s'] = new Array();\n" s_node;
+      M.iter
+        (fun i s -> fprintf ohtml "data['%s'][%i] = '%s';\n" s_node i s)
+        m;
+      if parent != T.nil then
+        fprintf odot "node%i -> %s;\n"
+          (T.preorder tree parent) s_node;
+      loop odot ohtml (T.first_child tree node) node;
+      loop odot ohtml (T.next_sibling tree node) parent
+    end
+  in
+  ignore (Sys.command "mkdir -p tests/trace");
+  let odot_ = open_out "tests/trace/trace.dot" in
+  let ohtml_ = open_out "tests/trace/trace.html" in
+  let odot = formatter_of_out_channel odot_ in
+  let ohtml = formatter_of_out_channel ohtml_ in
+  fprintf odot "digraph G {\n";
+  fprintf ohtml "<html>\
+<head><title></title>
+<link rel='stylesheet' type='text/css' href='trace.css' />\
+<meta http-equiv='content-type' content='text/html;charset=utf-8'/>\
+</head>\
+<body>\
+<div id='data' > </div>\
+<script type='text/javascript'>";
+  loop odot ohtml (T.root tree) (T.nil);
+  fprintf odot "\n}\n%!";
+  pp_print_flush odot ();
+  close_out odot_;
+  
+  ignore (Sys.command "dot -o tests/trace/trace.svg -Tsvg tests/trace/trace.dot");
+  ignore (Sys.command "./tools/add_onclick.sh tests/trace/trace.svg > tests/trace/trace2.svg");
+  fprintf ohtml "var activate = function (id) {\
+  var d = document.getElementById('data');
+  var msg = '';
+  for (i=0; i < data[id].length; i++)
+     msg += ('<p>' + i + ':') + data[id][i] + '</p>\\n';
+  d.innerHTML = msg;
+  return;
+  };\n";
+
+  fprintf ohtml "</script>\n<div id='svg'>\n";
+  let fi = open_in "tests/trace/trace2.svg" in
+  try
+    while true do
+      let s = input_line fi in
+      fprintf ohtml "%s\n" s;
+    done
+  with
+    End_of_file ->
+      fprintf ohtml "</div></body></html>\n%!";
+      pp_print_flush ohtml ();
+      close_out ohtml_;
+      close_in fi
+
diff --git a/src/auto/html.mli b/src/auto/html.mli
new file mode 100644
index 0000000..0a7d8dd
--- /dev/null
+++ b/src/auto/html.mli
@@ -0,0 +1,2 @@
+val trace : int -> int -> ('a, Format.formatter, unit, unit) format4 -> 'a
+val gen_trace : (module Tree.Sig.S with type t = 'a) -> 'a -> unit
diff --git a/tests/trace/trace.css b/tests/trace/trace.css
new file mode 100644
index 0000000..1cd40ab
--- /dev/null
+++ b/tests/trace/trace.css
@@ -0,0 +1,16 @@
+div#data {
+    position: absolute;
+    top: 0%;
+    left: 0%;
+    width: 30%;
+    height: 100%;
+    overflow: auto;
+}
+div#svg {
+    position: absolute;
+    top: 0%;
+    left: 30%;
+    width: 70%;
+    height: 100%;
+    overflow: auto;
+}
diff --git a/tools/add_onclick.sh b/tools/add_onclick.sh
new file mode 100755
index 0000000..89ba0f7
--- /dev/null
+++ b/tools/add_onclick.sh
@@ -0,0 +1,3 @@
+#!/bin/sh
+
+cat "$1" | sed -e "s/id=\\(\"node[0-9]*\"\\)/id=\\1 onclick='activate(\\1);' /"
-- 
2.17.1