-IFDEF HTMLTRACE
- THEN
-DEFINE IFTRACE(e) = (e)
- ELSE
-DEFINE IFTRACE(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/>todo: %a<br/>_______________________<br/>"
- (T.preorder tree node)
- msg
- StateSet.print config.sat
- StateSet.print config.todo
-
-
- let debug msg tree node i config =
- let config = config.NodeStatus.node in
- eprintf
- "DEBUG:%s node: %i\nsat: %a\ntodo: %a\nround: %i\n"
- msg
- (T.preorder tree node)
- StateSet.print config.sat
- StateSet.print config.todo
- i
-
- let get_form cache2 auto tag q =
- let phi =
- Cache.N2.find cache2 (tag.QName.id :> int) (q :> int)
- in
- if phi == dummy_form then
- let phi = Ata.get_form auto tag q in
- let () =
- Cache.N2.add
- cache2
- (tag.QName.id :> int)
- (q :> int) phi
- in phi
- else phi
-
- type trivalent = False | True | Unknown
- let of_bool = function false -> False | true -> True
- let or_ t1 t2 =
- match t1 with
- False -> t2
- | True -> True
- | Unknown -> if t2 == True then True else Unknown
-
- let and_ t1 t2 =
- match t1 with
- False -> False
- | True -> t2
- | Unknown -> if t2 == False then False else Unknown
-
- (* Define as macros to get lazyness *)
-DEFINE OR_(t1,t2) =
- let __t1 = (t1) in
- match t1 with
- False -> (t2)
- | True -> True
- | Unknown -> if (t2) == True then True else Unknown
-
-DEFINE AND_(t1,t2) =
- let __t1 = (t1) in
- match t1 with
- False -> False
- | True -> (t2)
- | Unknown -> if (t2) == False then False else Unknown
-
-
- let eval_form phi fcs nss ps ss summary =
- let open Ata in
- let rec loop phi =
- begin match Formula.expr phi with
- | Boolean.False -> False
- | Boolean.True -> True
- | Boolean.Atom (a, b) ->
- begin
- let open NodeSummary in
- match a.Atom.node with
- | Move (m, q) ->
- let { NodeStatus.node = n_sum; _ } as sum =
- match m with
- `First_child -> fcs
- | `Next_sibling -> nss
- | `Parent | `Previous_sibling -> ps
- | `Stay -> ss
- in
- if sum == dummy_status || StateSet.mem q n_sum.todo then
- Unknown
- else
- of_bool (b == StateSet.mem q n_sum.sat)
- | Is_first_child -> of_bool (b == is_left summary)
- | Is_next_sibling -> of_bool (b == is_right summary)
- | Is k -> of_bool (b == (k == kind summary))
- | Has_first_child -> of_bool (b == has_left summary)
- | Has_next_sibling -> of_bool (b == has_right summary)
- end
- | Boolean.And(phi1, phi2) -> AND_ (loop phi1, loop phi2)
- | Boolean.Or (phi1, phi2) -> OR_ (loop phi1, loop phi2)
- end
- in
- loop phi
-
-
- let eval_trans_aux auto cache2 tag fcs nss ps old_status =
- let { sat = old_sat;
- todo = old_todo;
- summary = old_summary } as os_node = old_status.NodeStatus.node
- in
- let sat, todo =
- StateSet.fold (fun q ((a_sat, a_todo) as acc) ->
- let phi =
- get_form cache2 auto tag q
- in
- let v = eval_form phi fcs nss ps old_status old_summary in
- match v with
- True -> StateSet.add q a_sat, a_todo
- | False -> acc
- | Unknown -> a_sat, StateSet.add q a_todo
- ) old_todo (old_sat, StateSet.empty)
- in
- if old_sat != sat || old_todo != todo then
- NodeStatus.make { os_node with sat; todo }
- else old_status
-
-
- let eval_trans auto cache2 cache5 tag fcs nss ps ss =
- let rec loop old_status =
- let new_status =
- eval_trans_aux auto cache2 tag fcs nss ps old_status
- in
- if new_status == old_status then old_status else loop new_status
- in
- let fcsid = (fcs.NodeStatus.id :> int) in
- let nssid = (nss.NodeStatus.id :> int) in
- let psid = (ps.NodeStatus.id :> int) in
- let ssid = (ss.NodeStatus.id :> int) in
- let tagid = (tag.QName.id :> int) in
- let res = Cache.N5.find cache5 tagid ssid fcsid nssid psid in
- if res != dummy_status then res
- else let new_status = loop ss in
- Cache.N5.add cache5 tagid ssid fcsid nssid psid new_status;
- new_status
-
-
-
- let top_down run =
- let _i = run.pass in
+let eval_trans_aux run tag summary fcs nss ps sat todo =
+ StateSet.fold (fun q (a_sat) ->
+ let phi =
+ get_form run tag q
+ in
+ if eval_form phi fcs nss ps a_sat summary then
+ StateSet.add q a_sat
+ else a_sat
+ ) todo sat
+
+
+let rec eval_trans_fix run tag summary fcs nss ps sat todo =
+ let new_sat =
+ eval_trans_aux run tag summary fcs nss ps sat todo
+ in
+ if new_sat == sat then sat else
+ eval_trans_fix run tag summary fcs nss ps new_sat todo
+
+
+let eval_trans run trans_cache tag summary fcs nss ps ss todo =
+ let stats = run.stats in
+ let fcsid = (fcs.StateSet.id :> int) in
+ let nssid = (nss.StateSet.id :> int) in
+ let psid = (ps.StateSet.id :> int) in
+ let ssid = (ss.StateSet.id :> int) in
+ let tagid = (tag.QName.id :> int) in
+
+ let res = Cache.N6.find trans_cache tagid summary ssid fcsid nssid psid in
+ stats.eval_trans_cache_access <- 1 + stats.eval_trans_cache_access;
+ if res != dummy_set then
+ res
+ else let new_sat = if todo == StateSet.empty then ss else
+ eval_trans_fix run tag summary fcs nss ps ss todo
+ in
+ stats.eval_trans_cache_miss <- 1 + stats.eval_trans_cache_miss;
+ Cache.N6.add trans_cache tagid summary ssid fcsid nssid psid new_sat;
+ new_sat
+
+
+module Make (T : Tree.S) =
+struct
+ module Tree : Tree.S with type node = T.node = T
+ module ResultSet : Deque.S with type elem = Tree.node =
+ Deque.Make (struct type t = Tree.node end)
+
+
+ let make auto tree =
+ let len = Tree.size tree in
+ (* let ba = Array1.create int16_unsigned c_layout len in
+ Array1.fill ba 0; *)
+ let ba = Bytes.make len '\000' in
+ {
+ tree = tree;
+ auto = auto;
+ sat = (let a = Array.make len StateSet.empty in
+ IFHTML([a], a));
+ pass = 0;
+ fetch_trans_cache = Cache.N2.create dummy_form;
+ td_cache = Cache.N6.create dummy_set;
+ bu_cache = Cache.N6.create dummy_set;
+ node_summaries = ba;
+ stats = {
+ pass = 0;
+ tree_size = len;
+ fetch_trans_cache_access = 0;
+ fetch_trans_cache_miss = 0;
+ eval_trans_cache_access = 0;
+ eval_trans_cache_miss = 0;
+ nodes_per_run = [];
+ }
+ }
+
+
+ let top_down2 run update_res =
+ let num_visited = ref 0 in
+ let i = run.pass in