- let eval_trans cache4 fcs nss ps ss =
- let fcsid = (fcs.NodeStatus.id :> int) in
- let nssid = (nss.NodeStatus.id :> int) in
- let psid = (ps.NodeStatus.id :> int) in
- let rec loop old_config =
- let oid = (old_config.NodeStatus.id :> int) in
- let res =
- let res = Cache.N4.find cache4 oid fcsid nssid psid in
- if res != dummy_status then res
- else
- let { sat = old_sat;
- unsat = old_unsat;
- todo = old_todo;
- summary = old_summary } = old_config.NodeStatus.node
- in
- let sat, unsat, removed, kept, todo =
- Ata.TransList.fold
- (fun trs acc ->
- let q, lab, phi = Ata.Transition.node trs in
- let a_sat, a_unsat, a_rem, a_kept, a_todo = acc in
- if StateSet.mem q a_sat || StateSet.mem q a_unsat then acc else
- let new_phi =
- eval_form phi fcs nss ps old_config old_summary
- in
- if Ata.Formula.is_true new_phi then
- StateSet.add q a_sat, a_unsat, StateSet.add q a_rem, a_kept, a_todo
- else if Ata.Formula.is_false new_phi then
- a_sat, StateSet.add q a_unsat, StateSet.add q a_rem, a_kept, a_todo
- else
- let new_tr = Ata.Transition.make (q, lab, new_phi) in
- (a_sat, a_unsat, a_rem, StateSet.add q a_kept, (Ata.TransList.cons new_tr a_todo))
- ) old_todo (old_sat, old_unsat, StateSet.empty, StateSet.empty, Ata.TransList.nil)
- in
- (* States that have been removed from the todo list and not kept are now
- unsatisfiable *)
- let unsat = StateSet.union unsat (StateSet.diff removed kept) in
- (* States that were found once to be satisfiable remain so *)
- let unsat = StateSet.diff unsat sat in
- let new_config = NodeStatus.make { old_config.NodeStatus.node with sat; unsat; todo; } in
- Cache.N4.add cache4 oid fcsid nssid psid new_config;
- new_config
- in
- if res == old_config then res else loop res
- in
- loop ss
-
-
-
-
- let top_down node run =
- let tree = run.tree in
- let auto = run.auto in
- let status = run.status in
- let cache2 = run.cache2 in
- let cache4 = run.cache4 in
- let unstable = run.unstable in
- let rec loop node =
- let node_id = T.preorder tree node in
- if node == T.nil || not (Bitvector.get unstable node_id) then false else begin
- let parent = T.parent tree node in
- let fc = T.first_child tree node in
- let fc_id = T.preorder tree fc in
- let ns = T.next_sibling tree node in
- let ns_id = T.preorder tree ns in
- let tag = T.tag tree node in
- (* We enter the node from its parent *)
-
- let status0 =
- let c = unsafe_get_status status node_id in
- if c == dummy_status then
- (* first time we visit the node *)
- NodeStatus.make
- { c.NodeStatus.node with
- todo = get_trans cache2 auto tag (Ata.get_states auto);
- summary = NodeSummary.make
- (node == T.first_child tree parent) (* is_left *)
- (node == T.next_sibling tree parent) (* is_right *)
- (fc != T.nil) (* has_left *)
- (ns != T.nil) (* has_right *)
- (T.kind tree node) (* kind *)
- }
- else c
- in
-
- TRACE(html tree node _i config0 "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 fcs = unsafe_get_status status fc_id in
- let nss = unsafe_get_status status ns_id in
- (* evaluate the transitions with all this statuses *)
- let status1 = eval_trans cache4 fcs nss ps status0 in
-
- TRACE(html tree node _i config1 "Updating transitions");
-
- (* update the cache if the status of the node changed *)
-
- if status1 != status0 then status.(node_id) <- status1;
- (* recursively traverse the first child *)
- let unstable_left = loop fc in
- (* here we re-enter the node from its first child,
- get the new status of the first child *)
- let fcs1 = unsafe_get_status status fc_id in
- (* update the status *)
- let status2 = eval_trans cache4 fcs1 nss ps status1 in
-
- TRACE(html tree node _i config2 "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 cache4 fcs1 nss1 ps status2 in
-
- TRACE(html tree node _i config3 "Updating transitions (after next-sibling)");
-
- if status3 != status2 then status.(node_id) <- status3;