Hashtbl.replace final n (b,r)
-let gen_trace (type s) = (); fun t tree ->
+let gen_trace (type s) = fun auto t tree ->
let module T = (val (t) : Tree.S with type t = s) in
- let rec loop odot ohtml node parent =
- if node == T.nil then () else begin
+ 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)
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 odot "%s[ id=\"%s\" label=\"%s\" style=filled fillcolor=\"%f,1.0,1.0\"\
-shape=\"%s\" ];\n"
- s_node
- s_node
- (QName.to_string (T.tag tree node))
- (1.0 -. (float (last_round+1) /. float (!max_round+1)))
- (if marked then "oval" else "box") ;
+ fprintf osvg "<rect id=\"%s\" onclick=\"activate(\'%s\');\" x=\"%i\" y=\"%i\" width=\"%i\" height=\"20\" style=\"fill:rgba(255,%i,%i,255);stroke-width:2;stroke:rgb(0,0,0)%s\"/>\n%!"
+ s_node s_node x y lbox color color (if marked then "" else ";stroke-dasharray:2,2");
+ 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;
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
+ 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 "<line x1=\"%i\" y1=\"%i\" x2=\"%i\" y2=\"%i\" style=\"stroke:rgb(0,0,0);stroke-width:2\"/>\n"
+ (x + lbox / 2) (y-20) (x + lbox / 2) (y);
+ if next != T.nil then
+ fprintf osvg "<line x1=\"%i\" y1=\"%i\" x2=\"%i\" y2=\"%i\" style=\"stroke:rgb(0,0,0);stroke-width:2\"/>\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 odot_ = open_out "tests/trace/trace.dot" in
+ let osvg_ = open_out "tests/trace/trace.svg" in
let ohtml_ = open_out "tests/trace/trace.html" in
- let odot = formatter_of_out_channel odot_ in
+ let osvg = formatter_of_out_channel osvg_ in
let ohtml = formatter_of_out_channel ohtml_ in
- fprintf odot "digraph G {\n node[shape=box, style=filled, fillcolor=white];splines=false;";
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='automata' >%a
+</div>
<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");
+<script type='text/javascript'>"
+Ata.print auto;
+ let maxw, maxh = loop osvg ohtml (T.root tree) T.nil 50 50 in
+ pp_print_flush osvg ();
+ close_out osvg_;
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';
+ msg += ('<p>round: ' + i + ':<br/>') + 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
+ fprintf ohtml "</script>\n<div id='svg'><svg width=\"%i\" height=\"%i\" xmlns=\"http://www.w3.org/2000/svg\" version=\"1.1\">\n"
+ maxw maxh;
+ let fi = open_in "tests/trace/trace.svg" in
try
while true do
let s = input_line fi in
done
with
End_of_file ->
- fprintf ohtml "</div></body></html>\n%!";
+ fprintf ohtml "</svg>\n</div></body></html>\n%!";
pp_print_flush ohtml ();
close_out ohtml_;
close_in fi
+
let html tree node i config msg =
let config = config.NodeStatus.node in
Html.trace (T.preorder tree node) i
- "node: %i<br/>%s<br/>sat: %a<br/>todo: %a<br/>round: %i<br/>"
+ "node: %i<br/>%s<br/>sat: %a<br/>todo: %a<br/>_______________________<br/>"
(T.preorder tree node)
msg
StateSet.print config.sat
StateSet.print config.todo
- i
let debug msg tree node i config =
let top_down run =
+ let _i = run.pass in
let tree = run.tree in
let auto = run.auto in
let status = run.status in
}
else c
in
- TRACE(html tree node _i config0 "Entering node");
+ TRACE(html tree node _i status0 "Entering node");
(* get the node_statuses for the first child, next sibling and parent *)
let ps = unsafe_get_status status (T.preorder tree parent) in
let nss = unsafe_get_status status ns_id in
(* evaluate the transitions with all this statuses *)
let status1 = eval_trans auto cache2 cache5 tag fcs nss ps status0 in
- TRACE(html tree node _i config1 "Updating transitions");
+ TRACE(html tree node _i status1 "Updating transitions");
(* update the cache if the status of the node changed *)
(* update the status *)
let status2 = eval_trans auto cache2 cache5 tag fcs1 nss ps status1 in
- TRACE(html tree node _i config2 "Updating transitions (after first-child)");
+ TRACE(html tree node _i status2 "Updating transitions (after first-child)");
if status2 != status1 then status.(node_id) <- status2;
let unstable_right = loop ns in
let nss1 = unsafe_get_status status ns_id in
let status3 = eval_trans auto cache2 cache5 tag fcs1 nss1 ps status2 in
- TRACE(html tree node _i config3 "Updating transitions (after next-sibling)");
+ TRACE(html tree node _i status3 "Updating transitions (after next-sibling)");
if status3 != status2 then status.(node_id) <- status3;
Html.finalize_node
node_id
_i
- Ata.(StateSet.intersect config3.Config.node.sat auto.selection_states)));
+ Ata.(StateSet.intersect status3.NodeStatus.node.sat (get_selecting_states auto))));
unstable_self
end
in
run.redo <- loop (T.root tree);
run.pass <- run.pass + 1
-(*
- let stats run =
- let count = ref 0 in
- let len = Bitvector.length run.unstable in
- for i = 0 to len - 1 do
- if not (Bitvector.unsafe_get run.unstable i) then
- incr count
- done;
- Logger.msg `STATS
- "%i nodes over %i were skipped in iteration %i (%.2f %%), redo is: %b"
- !count len run.pass (100. *. (float !count /. float len))
- run.redo
-
-
- let eval auto tree node =
- let len = T.size tree in
- let run = { config = Array.create len Ata.dummy_config;
- unstable = Bitvector.create ~init:true len;
- redo = true;
- pass = 0
- }
- in
- while run.redo do
- run.redo <- false;
- Ata.reset auto; (* prevents the .cache2 and .cache4 memoization tables from growing too much *)
- run.redo <- top_down_run auto tree node run;
- stats run;
- run.pass <- run.pass + 1;
- done;
- at_exit (fun () -> Logger.msg `STATS "%i iterations" run.pass);
- at_exit (fun () -> stats run);
- let r = get_results auto tree node run.config in
-
- TRACE(Html.gen_trace (module T : Tree.S with type t = T.t) (tree));
-
- r
-*)
let get_results run =
let cache = run.status in
(fun q acc -> (q, Cache.N1.find res_mapper (q :> int))::acc)
(Ata.get_selecting_states auto) [])
+
let prepare_run run list =
let tree = run.tree in
let auto = run.auto in
status.(node_id) <- status0) list
- let eval full auto tree nodes =
+ let compute_run auto tree nodes =
let run = make auto tree in
prepare_run run nodes;
while run.redo do
top_down run
done;
- if full then `Full (get_full_results run)
- else `Normal (get_results run)
+ TRACE(Html.gen_trace auto (module T : Tree.S with type t = T.t) tree);
+ run
let full_eval auto tree nodes =
- match eval true auto tree nodes with
- `Full l -> l
- | _ -> assert false
+ let r = compute_run auto tree nodes in
+ get_full_results r
let eval auto tree nodes =
- match eval false auto tree nodes with
- `Normal l -> l
- | _ -> assert false
+ let r = compute_run auto tree nodes in
+ get_results r
end
projects / tatoo.git / commitdiff