- let rec aux t num =
- if Tree.is_node t
- then
- match (try Hashtbl.find traces (Tree.id t) with Not_found -> TNil(Ptset.empty,Ptset.empty)) with
- | TNode(r,s,mark,trs) ->
- let numl = aux (Tree.left t) num in
- let numr = aux (Tree.right t) (numl+1) in
- let mynum = numr + 1 in
- Format.fprintf outf "n%i [ label=\"<%s>\\nr=" mynum (Tag.to_string (Tree.tag t));
- pr_st outf (Ptset.elements r);
- Format.fprintf outf "\\ns=";
- pr_st outf (Ptset.elements s);
- List.iter (fun (q,m,f) ->
- Format.fprintf outf "\\n%i %s" q (if m then "⇨" else "→");
- pr_frm outf f ) trs;
- Format.fprintf outf "\", %s shape=box ];\n"
- (if mark then "color=cyan1, style=filled," else "");
- let _ = Format.fprintf outf "n%i -> n%i;\n" mynum numl in
- let _ = Format.fprintf outf "n%i -> n%i;\n" mynum numr in
- mynum
- | TNil(r,s) -> Format.fprintf outf "n%i [ shape=box, label=\"Nil\\nr=" num;
- pr_st outf (Ptset.elements r);
- Format.fprintf outf "\\ns=";
- pr_st outf (Ptset.elements s);
- Format.fprintf outf "\"];\n";num
- else
- match Hashtbl.find traces (-10) with
- | TNil(r,s) ->
- Format.fprintf outf "n%i [ shape=box, label=\"Nil\\nr=" num;
- pr_st outf (Ptset.elements r);
- Format.fprintf outf "\\ns=";
- pr_st outf (Ptset.elements s);
- Format.fprintf outf "\"];\n";
- num
+ let choose_jump tagset qtags1 qtagsn a f_nil f_text f_t1 f_s1 f_tn f_sn f_notext =
+ let tags1,hastext1,fin1 = inter_text tagset (tags a qtags1) in
+ let tagsn,hastextn,finn = inter_text tagset (tags a qtagsn) in
+ if (hastext1||hastextn) then f_text (* jumping to text nodes doesn't work really well *)
+ else if (Ptset.Int.is_empty tags1) && (Ptset.Int.is_empty tagsn) then f_nil
+ else if (Ptset.Int.is_empty tagsn) then
+ if (Ptset.Int.is_singleton tags1)
+ then (* TaggedChild/Sibling *)
+ let tag = (Ptset.Int.choose tags1) in mk_app_fun f_t1 tag (Tag.to_string tag)
+ else (* SelectChild/Sibling *)
+ mk_app_fun f_s1 tags1 (string_of_ts tags1)
+ else if (Ptset.Int.is_empty tags1) then
+ if (Ptset.Int.is_singleton tagsn)
+ then (* TaggedDesc/Following *)
+ let tag = (Ptset.Int.choose tagsn) in mk_app_fun f_tn tag (Tag.to_string tag)
+ else (* SelectDesc/Following *)
+ mk_app_fun f_sn tagsn (string_of_ts tagsn)
+ else f_notext
+
+ let choose_jump_down a b c d =
+ choose_jump a b c d
+ (mk_fun (Tree.mk_nil) "Tree.mk_nil")
+ (mk_fun (Tree.text_below) "Tree.text_below")
+ (mk_fun (fun _ -> Tree.node_child) "[TaggedChild]Tree.node_child") (* !! no tagged_child in Tree.ml *)
+ (mk_fun (fun _ -> Tree.node_child) "[SelectChild]Tree.node_child") (* !! no select_child in Tree.ml *)
+ (mk_fun (Tree.tagged_desc) "Tree.tagged_desc")
+ (mk_fun (fun _ -> Tree.node_child ) "[SelectDesc]Tree.node_child") (* !! no select_desc *)
+ (mk_fun (Tree.node_child) "Tree.node_child")
+
+ let choose_jump_next a b c d =
+ choose_jump a b c d
+ (mk_fun (fun t _ -> Tree.mk_nil t) "Tree.mk_nil2")
+ (mk_fun (Tree.text_next) "Tree.text_next")
+ (mk_fun (fun _ -> Tree.node_sibling_ctx) "[TaggedSibling]Tree.node_sibling_ctx")(* !! no tagged_sibling in Tree.ml *)
+ (mk_fun (fun _ -> Tree.node_sibling_ctx) "[SelectSibling]Tree.node_sibling_ctx")(* !! no select_sibling in Tree.ml *)
+ (mk_fun (Tree.tagged_foll_below) "Tree.tagged_foll_below")
+ (mk_fun (fun _ -> Tree.node_sibling_ctx) "[SelectFoll]Tree.node_sibling_ctx")(* !! no select_foll *)
+ (mk_fun (Tree.node_sibling_ctx) "Tree.node_sibling_ctx")
+
+ let get_trans slist tag a t =
+ try
+ Hashtbl.find td_trans (tag,hpl slist)
+ with
+ | Not_found ->
+ let fl_list,llist,rlist,ca,da,sa,fa =
+ fold_pl
+ (fun set _ (fll_acc,lllacc,rllacc,ca,da,sa,fa) -> (* For each set *)
+ let fl,ll,rr,ca,da,sa,fa =
+ StateSet.fold
+ (fun q acc ->
+ List.fold_left
+ (fun ((fl_acc,ll_acc,rl_acc,c_acc,d_acc,s_acc,f_acc) as acc)
+ (ts,t) ->
+ if (TagSet.mem tag ts)
+ then
+ let _,_,f,_ = Transition.node t in
+ let (child,desc,below),(sibl,foll,after) = Formula.st f in
+ (Formlist.add t fl_acc,
+ StateSet.union ll_acc below,
+ StateSet.union rl_acc after,
+ StateSet.union child c_acc,
+ StateSet.union desc d_acc,
+ StateSet.union sibl s_acc,
+ StateSet.union foll f_acc)
+ else acc ) acc (
+ try Hashtbl.find a.trans q
+ with
+ Not_found -> Printf.eprintf "Looking for state %i, doesn't exist!!!\n%!"
+ q;[]
+ )
+
+ ) set (Formlist.empty,StateSet.empty,StateSet.empty,ca,da,sa,fa)
+ in fl::fll_acc, cons ll lllacc, cons rr rllacc,ca,da,sa,fa)
+ slist ([],Nil,Nil,StateSet.empty,StateSet.empty,StateSet.empty,StateSet.empty)
+ in
+ (* Logic to chose the first and next function *)
+ let tags_below,tags_after = Tree.tags t tag in
+ let first = choose_jump_down tags_below ca da a
+ and next = choose_jump_next tags_after sa fa a in
+ let v = (fl_list,llist,rlist,first,next) in
+ Hashtbl.add td_trans (tag, hpl slist) v; v
+
+ let merge rb rb1 rb2 mark t res1 res2 =
+ if rb
+ then
+ let res1 = if rb1 then res1 else RS.empty
+ and res2 = if rb2 then res2 else RS.empty
+ in
+ if mark then RS.cons t (RS.concat res1 res2)
+ else RS.concat res1 res2
+ else RS.empty
+
+ let top_down ?(noright=false) a t slist ctx slot_size =
+ let pempty = empty_size slot_size in
+ let eval_fold2_slist fll sl1 sl2 res1 res2 t =
+ let res = Array.copy res1 in
+ let rec fold l1 l2 fll i aq = match l1,l2,fll with
+ | Cons(s1,_,ll1), Cons(s2, _ ,ll2),fl::fll ->
+ let r',rb,rb1,rb2,mark = eval_formlist s1 s2 fl in
+ let _ = res.(i) <- merge rb rb1 rb2 mark t res1.(i) res2.(i)
+ in
+ fold ll1 ll2 fll (i+1) (cons r' aq)
+ | Nil, Nil,[] -> aq,res