open Format module M = Map.Make(struct type t = int let compare = compare end) let info = Hashtbl.create 2017 let final = Hashtbl.create 2017 let max_round = ref 0 let add_info (nodeid:int) (i:int) s = if i > !max_round then max_round := i; 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 finalize_node n r b = Hashtbl.replace final n (b,r) let gen_trace (type s) = fun auto t tree -> let module T = (val (t) : Tree.S with type t = s) in let root = T.root tree in let rec loop osvg ohtml node parent x y = if node != T.nil then begin let m = try Hashtbl.find info (T.preorder tree node) with Not_found -> M.empty in let node_id = T.preorder tree node in let marked, last_round = try Hashtbl.find final node_id with Not_found -> Printf.eprintf ">>> %i\n%!" node_id; false, !max_round; in let pc = if !max_round == 0 then 1. else float_of_int last_round /. float_of_int !max_round in let color = int_of_float (255. *. (1. -. pc)) in let tag = QName.to_string (T.tag tree node) in let lbox = (String.length tag + 2) * 10 in let s_node = "node" ^ (string_of_int node_id) in fprintf osvg "\n%!" s_node s_node x y lbox color color (if marked then "" else ";stroke-dasharray:2,2"); fprintf osvg "%s\n" (x+10) (y+15) s_node tag; 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; let first = T.first_child tree node in let maxw1, maxy1 = loop osvg ohtml first node x (y + 40) in let next = T.next_sibling tree node in let x_next = max (x+lbox) (maxw1+10) in if node != root then begin if node == T.first_child tree parent then fprintf osvg "\n" (x + lbox / 2) (y-20) (x + lbox / 2) (y); if next != T.nil then fprintf osvg "\n" (x + lbox) (y+10) x_next (y+10); end; let maxw2, maxy2 = loop osvg ohtml next node x_next y in maxw2, max maxy1 maxy2 end else x, y in ignore (Sys.command "mkdir -p tests/trace"); let osvg_ = open_out "tests/trace/trace.svg" in let ohtml_ = open_out "tests/trace/trace.html" in let osvg = formatter_of_out_channel osvg_ in let ohtml = formatter_of_out_channel ohtml_ in fprintf ohtml "\ \ \ \ \

\ \n

\n%!"; pp_print_flush ohtml (); close_out ohtml_; close_in fi