src/html.ml

   1 open Format
   2 module M = Map.Make(struct type t = int let compare = compare end)
   3
   4 let info = Hashtbl.create 2017
   5 let final = Hashtbl.create 2017
   6
   7 let max_round = ref 0
   8
   9 let add_info (nodeid:int) (i:int) s =
  10   if i > !max_round then max_round := i;
  11   let m = try Hashtbl.find info nodeid with Not_found -> M.empty in
  12   let old_s = try M.find i m with Not_found -> "" in
  13   let s' = old_s ^ s in
  14   let m' = M.add i s' m in
  15   Hashtbl.replace info nodeid m'
  16
  17
  18 let buff = Buffer.create 20
  19 let fmt = formatter_of_buffer buff
  20
  21 let trace nodeid i =
  22   let () = pp_print_flush fmt ();
  23     Buffer.clear buff
  24   in
  25   kfprintf (fun fmt ->
  26     pp_print_flush fmt ();
  27     let s = Buffer.contents buff in
  28     add_info nodeid i s) fmt
  29
  30 let finalize_node n r b =
  31   Hashtbl.replace final n (b,r)
  32
  33
  34 let gen_trace (type s) = fun auto t tree ->
  35   let module T = (val (t) : Tree.S with type t = s) in
  36   let root = T.root tree in
  37   let rec loop osvg ohtml node parent x y =
  38     if node != T.nil then begin
  39       let m =
  40         try
  41           Hashtbl.find info (T.preorder tree node)
  42         with Not_found -> M.empty
  43       in
  44       let node_id = T.preorder tree node in
  45       let marked, last_round = try Hashtbl.find final node_id with Not_found ->
  46         Printf.eprintf ">>> %i\n%!" node_id; false, !max_round;
  47       in
  48       let pc = if !max_round == 0 then 1. else float_of_int last_round /. float_of_int !max_round in
  49       let color = int_of_float (255. *. (1. -.  pc)) in
  50       let tag = QName.to_string (T.tag tree node) in
  51       let lbox = (String.length tag + 2) * 10 in
  52       let s_node = "node" ^ (string_of_int node_id) in
  53       fprintf osvg "<rect id=\"%s\" onclick=\"activate(\'%s\');\" x=\"%i\" y=\"%i\" width=\"%i\" height=\"20\" style=\"fill:rgba(255,%i,%i,255);stroke:rgb(0,0,0)%s\"/>\n%!"
  54         s_node s_node x y lbox color color (if marked then ";stroke-width:4" else ";stroke-width:2;stroke-dasharray:2,2");
  55       fprintf osvg "<text x=\"%i\" y=\"%i\" style=\"font-size:17;font-family:typewriter;\" onclick=\"activate(\'%s\');\" >%s</text>\n" (x+10) (y+15) s_node tag;
  56       fprintf ohtml "data['%s'] = new Array();\n" s_node;
  57       M.iter
  58         (fun i s -> fprintf ohtml "data['%s'][%i] = '%s';\n" s_node i s)
  59         m;
  60       let first = T.first_child tree node in
  61       let maxw1, maxy1 = loop osvg ohtml first node x (y + 40) in
  62       let next = T.next_sibling tree node in
  63       let x_next = max (x+lbox) (maxw1+10) in
  64       if node != root then begin
  65         if node == T.first_child tree parent then
  66           fprintf osvg  "<line x1=\"%i\" y1=\"%i\" x2=\"%i\" y2=\"%i\" style=\"stroke:rgb(0,0,0);stroke-width:2\"/>\n"
  67             (x + lbox / 2) (y-20) (x + lbox / 2) (y);
  68         if next != T.nil then
  69           fprintf osvg "<line x1=\"%i\" y1=\"%i\" x2=\"%i\" y2=\"%i\" style=\"stroke:rgb(0,0,0);stroke-width:2\"/>\n"
  70             (x + lbox) (y+10) x_next (y+10);
  71       end;
  72       let maxw2, maxy2 = loop osvg ohtml next node x_next y in
  73       maxw2, max maxy1 maxy2
  74     end
  75     else x, y
  76   in
  77   ignore (Sys.command "mkdir -p tests/trace");
  78   let osvg_ = open_out "tests/trace/trace.svg" in
  79   let ohtml_ = open_out "tests/trace/trace.html" in
  80   let osvg = formatter_of_out_channel osvg_ in
  81   let ohtml = formatter_of_out_channel ohtml_ in
  82   fprintf ohtml "<html>\
  83 <head><title></title>
  84 <link rel='stylesheet' type='text/css' href='trace.css' />\
  85 <meta http-equiv='content-type' content='text/html;charset=utf-8'/>\
  86 </head>\
  87 <body>\
  88 <div id='automata' >%a
  89 </div>
  90 <div id='data' > </div>\
  91 <script type='text/javascript'>"
  92 Ata.print auto;
  93   let maxw, maxh = loop osvg ohtml (T.root tree) T.nil 50 50 in
  94   pp_print_flush osvg ();
  95   close_out osvg_;
  96   fprintf ohtml "var activate = function (id) {\
  97   var d = document.getElementById('data');
  98   var msg = '';
  99   for (i=0; i < data[id].length; i++)
 100      msg += ('<p>round: ' + i + ':<br/>') + data[id][i] + '</p>\\n';
 101   d.innerHTML = msg;
 102   return;
 103   };\n";
 104   fprintf ohtml "</script>\n<div id='svg'><svg width=\"%i\" height=\"%i\" xmlns=\"http://www.w3.org/2000/svg\" version=\"1.1\">\n"
 105     maxw maxh;
 106   let fi = open_in "tests/trace/trace.svg" in
 107   try
 108     while true do
 109       let s = input_line fi in
 110       fprintf ohtml "%s\n" s;
 111     done
 112   with
 113     End_of_file ->
 114       fprintf ohtml "</svg>\n</div></body></html>\n%!";
 115       pp_print_flush ohtml ();
 116       close_out ohtml_;
 117       close_in fi
 118
 119