+
+ module Fold2Res3 = struct
+ include Hashtbl.Make(struct
+ type t = Tag.t*Formlistlist.t*SList.t*SList.t
+ let equal (a,b,c,d) (x,y,z,t) =
+ a == x && b == y && c == z && d == t
+ let hash (a,b,c,d) = HASHINT4 (a,
+ Uid.to_int b.Formlistlist.Node.id,
+ Uid.to_int c.SList.Node.id,
+ Uid.to_int d.SList.Node.id)
+ end)
+ let add h t f s1 s2 d =
+ add h (t,f,s1,s2) d
+ let find h t f s1 s2 =
+ find h (t,f,s1,s2)
+ end
+
+ module Fold2Res =
+ struct
+ type cell = { key : int;
+ obj : Obj.t }
+ type 'a t = cell array
+ let dummy = { key = 0; obj = Obj.repr () }
+ let create n = Array.create 25000 dummy
+ let hash a b c d = HASHINT4(Obj.magic a,
+ Uid.to_int b.Formlistlist.Node.id,
+ Uid.to_int c.SList.Node.id,
+ Uid.to_int d.SList.Node.id)
+
+ let find_slot t key =
+ let rec loop i =
+ if (t.(i) != dummy) && (t.(i).key != key)
+ then loop ((i+1 mod 25000))
+ else i
+ in loop (key mod 25000)
+ ;;
+
+ let find t k1 k2 k3 k4 =
+ let i = find_slot t (hash k1 k2 k3 k4) in
+ if t.(i) == dummy then raise Not_found
+ else Obj.magic (t.(i).obj)
+
+ let add t k1 k2 k3 k4 v =
+ let key = hash k1 k2 k3 k4 in
+ let i = find_slot t key in
+ t.(i)<- { key = key; obj = (Obj.repr v) }
+
+ end
+
+ let h_fold2 = Fold2Res.create 10000
+
+ let top_down ?(noright=false) a tree t slist ctx slot_size =
+ let pempty = empty_size slot_size in
+ let rempty = Array.make slot_size RS.empty in
+ (* evaluation starts from the right so we put sl1,res1 at the end *)
+ let eval_fold2_slist fll t tag (sl2,res2) (sl1,res1) =
+ let res = Array.copy rempty in
+ try
+ let r,b,btab = Fold2Res.find h_fold2 tag fll sl1 sl2 in
+ if b then for i=0 to slot_size - 1 do
+ res.(i) <- RS.merge btab.(i) t res1.(i) res2.(i);
+ done;
+ r,res
+ with
+ Not_found ->
+ begin
+ let btab = Array.make slot_size NO in
+ let rec fold l1 l2 fll i aq ab =
+ match fll.Formlistlist.Node.node,
+ l1.SList.Node.node,
+ l2.SList.Node.node
+ with
+ | Formlistlist.Cons(fl,fll),
+ SList.Cons(s1,ll1),
+ SList.Cons(s2,ll2) ->
+ let r',conf = eval_formlist tag s1 s2 fl in
+ let _ = btab.(i) <- conf
+ in
+ fold ll1 ll2 fll (i+1) (SList.cons r' aq) ((conf!=NO)||ab)
+ | _ -> aq,ab
+ in
+ let r,b = fold sl1 sl2 fll 0 SList.nil false in
+ Fold2Res.add h_fold2 tag fll sl1 sl2 (r,b,btab);
+ if b then for i=0 to slot_size - 1 do
+ res.(i) <- RS.merge btab.(i) t res1.(i) res2.(i);
+ done;
+ r,res;
+ end
+ in
+
+ let null_result = (pempty,Array.copy rempty) in
+ let rec loop t slist ctx =
+ if t == Tree.nil then null_result else get_trans t slist (Tree.tag tree t) ctx
+ and loop_tag tag t slist ctx =
+ if t == Tree.nil then null_result else get_trans t slist tag ctx
+ and loop_no_right t slist ctx =
+ if t == Tree.nil then null_result else get_trans ~noright:true t slist (Tree.tag tree t) ctx
+ and get_trans ?(noright=false) t slist tag ctx =
+ let cont =
+ try
+ TransCache.find td_trans tag slist
+ with
+ | Not_found ->
+ let fl_list,llist,rlist,ca,da,sa,fa =
+ SList.fold
+ (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,_ = t.Transition.node in
+ let (child,desc,below),(sibl,foll,after) = Formula.st f in
+ (Formlist.cons 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.nil,StateSet.empty,StateSet.empty,ca,da,sa,fa)
+ in (Formlistlist.cons fl fll_acc), (SList.cons ll lllacc), (SList.cons rr rllacc),ca,da,sa,fa)
+ slist (Formlistlist.nil,SList.nil,SList.nil,StateSet.empty,StateSet.empty,StateSet.empty,StateSet.empty)
+ in
+ (* Logic to chose the first and next function *)
+ let tags_child,tags_below,tags_siblings,tags_after = Tree.tags tree tag in
+ let d_f = Algebra.decide a tags_child tags_below (StateSet.union ca da) true in
+ let d_n = Algebra.decide a tags_siblings tags_after (StateSet.union sa fa) false in
+ let f_kind,first = choose_jump_down tree d_f
+ and n_kind,next = if noright then (`NIL, fun _ _ -> Tree.nil )
+ else choose_jump_next tree d_n in
+ (*let f_kind,first = `ANY, Tree.first_child tree
+ and n_kind,next = `ANY, Tree.next_sibling_below tree
+ in *)
+ let empty_res = null_result in
+ let cont =
+ match f_kind,n_kind with
+ | `NIL,`NIL ->
+ (fun t _ -> eval_fold2_slist fl_list t (Tree.tag tree t) empty_res empty_res)
+ | _,`NIL -> (
+ match f_kind with
+ (*|`TAG(tag') ->
+ let default = fun t _ -> eval_fold2_slist fl_list t (Tree.tag tree t) empty_res
+ (loop_tag tag' (first t) llist t )
+ in default (*
+ let cf = SList.hd llist in
+ if (slot_size == 1) && StateSet.is_singleton cf
+ then
+ let s = StateSet.choose cf in
+ if (Algebra.is_rec a s fst) && (Algebra.is_rec a s snd)
+ && (Algebra.is_final_marking a s)
+ then
+ RS.mk_quick_tag_loop default llist 1 tree tag'
+ else default
+ else default *) *)
+ | _ ->
+ (fun t _ -> eval_fold2_slist fl_list t (Tree.tag tree t) empty_res
+ (loop (first t) llist t ))
+ )
+ | `NIL,_ -> (
+ match n_kind with
+ |`TAG(tag') ->
+ if SList.equal rlist slist && tag == tag' then
+ let rec loop t ctx =
+ if t == Tree.nil then empty_res else
+ let res2 = loop (next t ctx) ctx in
+ eval_fold2_slist fl_list t tag res2 empty_res
+ in loop
+ else
+ (fun t ctx -> eval_fold2_slist fl_list t (Tree.tag tree t)
+ (loop_tag tag' (next t ctx) rlist ctx ) empty_res)
+
+ | _ ->
+ (fun t ctx -> eval_fold2_slist fl_list t (Tree.tag tree t)
+ (loop (next t ctx) rlist ctx ) empty_res)
+ )
+
+ | `TAG(tag1),`TAG(tag2) ->
+ (fun t ctx ->
+ eval_fold2_slist fl_list t (Tree.tag tree t)
+ (loop_tag tag2 (next t ctx) rlist ctx )
+ (loop_tag tag1 (first t) llist t ))