+ module SetTagKey =
+ struct
+ type t = Tag.t*SList.t
+ let equal (t1,s1) (t2,s2) = t1 == t2 && s1 == s2
+ let hash (t,s) = HASHINT2(t,s.SList.Node.id)
+ end
+
+ module CachedTransTable = Hashtbl.Make(SetTagKey)
+ let td_trans = CachedTransTable.create 4093
+
+
+ let empty_size n =
+ let rec loop acc = function 0 -> acc
+ | n -> loop (SList.cons StateSet.empty acc) (n-1)
+ in loop SList.nil n
+
+
+ module Fold2Res = Hashtbl.Make(struct
+ type t = Formlistlist.t*SList.t*SList.t
+ let hash (f,s,t) = HASHINT3(f.Formlistlist.Node.id,
+ s.SList.Node.id,
+ t.SList.Node.id)
+ let equal (a,b,c) (d,e,f) = a==d && b == e && c == f
+ end)
+
+ let h_fold2 = Fold2Res.create BIG_H_SIZE
+
+ 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 (sl2,res2) (sl1,res1) =
+ let res = Array.copy rempty in
+ try
+ let r,b,btab = Fold2Res.find h_fold2 (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 ->
+ let btab = Array.make slot_size (false,false,false,false) 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',((b,_,_,_) as flags) = eval_formlist s1 s2 fl in
+ let _ = btab.(i) <- flags
+ in
+ fold ll1 ll2 fll (i+1) (SList.cons r' aq) (b||ab)
+ | _ -> aq,ab
+ in
+ let r,b = fold sl1 sl2 fll 0 SList.nil false in
+ Fold2Res.add h_fold2 (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
+ 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
+ CachedTransTable.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,_ = Transition.node t 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 _ = Printf.eprintf "Tags below %s are : \n" (Tag.to_string tag) in
+ let _ = Ptset.Int.iter (fun i -> Printf.eprintf "%s " (Tag.to_string i)) tags_below in
+ let _ = Printf.eprintf "\n%!" in *)
+(* let tags_below = Ptset.Int.remove tag tags_below 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 empty_res = null_result in
+ let cont =
+ match f_kind,n_kind with
+ | `NIL,`NIL ->
+ (fun t _ -> eval_fold2_slist fl_list t empty_res empty_res )
+ | _,`NIL -> (
+ match f_kind with
+ |`TAG(tag) ->
+ (fun t _ -> eval_fold2_slist fl_list t empty_res
+ (loop_tag tag (first t) llist t))
+ | `ANY ->
+ (fun t _ -> eval_fold2_slist fl_list t empty_res
+ (loop (first t) llist t))
+ | _ -> assert false)
+
+ | `NIL,_ -> (
+ match n_kind with
+ |`TAG(tag) ->
+ (fun t ctx -> eval_fold2_slist fl_list t
+ (loop_tag tag (next t ctx) rlist ctx) empty_res)
+
+ | `ANY ->
+ (fun t ctx -> eval_fold2_slist fl_list t
+ (loop (next t ctx) rlist ctx) empty_res)
+
+ | _ -> assert false)
+
+ | `TAG(tag1),`TAG(tag2) ->
+ (fun t ctx -> eval_fold2_slist fl_list t
+ (loop_tag tag2 (next t ctx) rlist ctx)
+ (loop_tag tag1 (first t) llist t))
+
+ | `TAG(tag),`ANY ->
+ (fun t ctx -> eval_fold2_slist fl_list t
+ (loop (next t ctx) rlist ctx)
+ (loop_tag tag (first t) llist t))
+ | `ANY,`TAG(tag) ->
+ (fun t ctx ->
+ eval_fold2_slist fl_list t
+ (loop_tag tag (next t ctx) rlist ctx)
+ (loop (first t) llist t) )
+ | `ANY,`ANY ->
+ (fun t ctx ->
+ eval_fold2_slist fl_list t
+ (loop (next t ctx) rlist ctx)
+ (loop (first t) llist t) )
+ | _ -> assert false
+ in
+ let cont = D_IF_( (fun t ctx ->
+ let a,b = cont t ctx in
+ register_trace tree t (slist,a,fl_list,first,next,ctx);
+ (a,b)
+ ) ,cont)
+ in
+ (CachedTransTable.add td_trans (tag,slist) cont;cont)
+ in cont t ctx
+
+ in
+ (if noright then loop_no_right else loop) t slist ctx
+
+
+ let run_top_down a tree =
+ let init = SList.cons a.init SList.nil in
+ let _,res = top_down a tree Tree.root init Tree.root 1
+ in
+ D_IGNORE_(
+ output_trace a tree "trace.html"
+ (RS.fold (fun t a -> IntSet.add (Tree.id tree t) a) res.(0) IntSet.empty),
+ res.(0))
+ ;;
+
+ module Configuration =
+ struct
+ module Ptss = Set.Make(StateSet)
+ module IMap = Map.Make(StateSet)
+ type t = { hash : int;
+ sets : Ptss.t;
+ results : RS.t IMap.t }
+ let empty = { hash = 0;
+ sets = Ptss.empty;
+ results = IMap.empty;
+ }
+ let is_empty c = Ptss.is_empty c.sets
+ let add c s r =
+ if Ptss.mem s c.sets then
+ { c with results = IMap.add s (RS.concat r (IMap.find s c.results)) c.results}
+ else
+ { hash = HASHINT2(c.hash,Ptset.Int.uid s);
+ sets = Ptss.add s c.sets;
+ results = IMap.add s r c.results
+ }
+
+ let pr fmt c = Format.fprintf fmt "{";
+ Ptss.iter (fun s -> StateSet.print fmt s;
+ Format.fprintf fmt " ") c.sets;
+ Format.fprintf fmt "}\n%!";
+ IMap.iter (fun k d ->
+ StateSet.print fmt k;
+ Format.fprintf fmt "-> %i\n" (RS.length d)) c.results;
+ Format.fprintf fmt "\n%!"
+
+ let merge c1 c2 =
+ let acc1 =
+ IMap.fold
+ ( fun s r acc ->
+ IMap.add s
+ (try
+ RS.concat r (IMap.find s acc)
+ with
+ | Not_found -> r) acc) c1.results IMap.empty
+ in
+ let imap =
+ IMap.fold (fun s r acc ->
+ IMap.add s
+ (try
+ RS.concat r (IMap.find s acc)
+ with
+ | Not_found -> r) acc) c2.results acc1
+ in
+ let h,s =
+ Ptss.fold
+ (fun s (ah,ass) -> (HASHINT2(ah,Ptset.Int.uid s),
+ Ptss.add s ass))
+ (Ptss.union c1.sets c2.sets) (0,Ptss.empty)
+ in
+ { hash = h;
+ sets =s;
+ results = imap }
+
+ end
+
+ let h_fold = Hashtbl.create 511
+
+ let fold_f_conf t slist fl_list conf dir=
+ let rec loop sl fl acc =
+ match SList.node sl,fl with
+ |SList.Nil,[] -> acc
+ |SList.Cons(s,sll), formlist::fll ->
+ let r',(rb,rb1,rb2,mark) =
+ let key = SList.hash sl,Formlist.hash formlist,dir in
+ try
+ Hashtbl.find h_fold key
+ with
+ Not_found -> let res =
+ if dir then eval_formlist s Ptset.Int.empty formlist
+ else eval_formlist Ptset.Int.empty s formlist
+ in (Hashtbl.add h_fold key res;res)
+ in
+ if rb && ((dir&&rb1)|| ((not dir) && rb2))
+ then
+ let acc =
+ let old_r =
+ try Configuration.IMap.find s conf.Configuration.results
+ with Not_found -> RS.empty
+ in
+ Configuration.add acc r' (if mark then RS.cons t old_r else old_r)
+ in
+ loop sll fll acc
+ else loop sll fll acc
+ | _ -> assert false
+ in
+ loop slist fl_list Configuration.empty
+
+ let h_trans = Hashtbl.create 4096
+
+ let get_up_trans slist ptag a tree =
+ let key = (HASHINT2(SList.uid slist,ptag)) in
+ try
+ Hashtbl.find h_trans key
+ with
+ | Not_found ->
+ let f_list =
+ Hashtbl.fold (fun q l acc ->
+ List.fold_left (fun fl_acc (ts,t) ->
+ if TagSet.mem ptag ts then Formlist.cons t fl_acc
+ else fl_acc)
+
+ acc l)
+ a.trans Formlist.nil