-DEFINE TRACE(e) = ()
-END
-
- 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/>unsat: %a<br/>todo: %around: %i<br/>"
- (T.preorder tree node)
- msg
- StateSet.print config.sat
- StateSet.print config.unsat
- (Ata.TransList.print ~sep:"<br/>") config.todo i
-
-
- let debug msg tree node i config =
- let config = config.NodeStatus.node in
- eprintf
- "DEBUG:%s node: %i\nsat: %a\nunsat: %a\ntodo: %around: %i\n"
- msg
- (T.preorder tree node)
- StateSet.print config.sat
- StateSet.print config.unsat
- (Ata.TransList.print ~sep:"\n") config.todo i
-
-
- let get_trans cache2 auto tag states =
- let trs =
- Cache.N2.find cache2
- (tag.QName.id :> int) (states.StateSet.id :> int)
- in
- if trs == dummy_trl then
- let trs = Ata.get_trans auto tag states in
- (Cache.N2.add
- cache2
- (tag.QName.id :> int)
- (states.StateSet.id :> int) trs; trs)
- else trs
-
-
-
- let simplify_atom atom pos q { NodeStatus.node = status; _ } =
- if (pos && StateSet.mem q status.sat)
- || ((not pos) && StateSet.mem q status.unsat) then Ata.Formula.true_
- else if (pos && StateSet.mem q status.unsat)
- || ((not pos) && StateSet.mem q status.sat) then Ata.Formula.false_
- else atom
-
-
- let eval_form phi fcs nss ps ss summary =
- let open Ata in
- let rec loop phi =
- begin match Formula.expr phi with
- Boolean.True | Boolean.False -> phi
- | Boolean.Atom (a, b) ->
- begin
- let open NodeSummary in
- match a.Atom.node with
- | Move (m, q) ->
- let states = match m with
- `First_child -> fcs
- | `Next_sibling -> nss
- | `Parent | `Previous_sibling -> ps
- | `Stay -> ss
- in simplify_atom phi b q states
- | Is_first_child -> Formula.of_bool (b == is_left summary)
- | Is_next_sibling -> Formula.of_bool (b == is_right summary)
- | Is k -> Formula.of_bool (b == (k == kind summary))
- | Has_first_child -> Formula.of_bool (b == has_left summary)
- | Has_next_sibling -> Formula.of_bool (b == has_right summary)
- end
- | Boolean.And(phi1, phi2) -> Formula.and_ (loop phi1) (loop phi2)
- | Boolean.Or (phi1, phi2) -> Formula.or_ (loop phi1) (loop phi2)
- end
- in
- loop phi
-
-
- let eval_trans_aux cache4 fcs nss ps ss old_config =
- 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
- new_config
-
-
- 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 new_config =
- eval_trans_aux cache4 fcs nss ps ss old_config
- 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