module TransTable = Hashtbl
module Formlist = struct
- include Hlist.Make(Transition)
- type data = t node
- let make _ = failwith "make"
+ include Hlist.Make(Transition)
let print ppf fl =
iter (fun t -> Transition.print ppf t; Format.pp_print_newline ppf ()) fl
end
-
type 'a t = {
id : int;
module Run (RS : ResultSet) =
struct
- module SList = struct
- include Hlist.Make (StateSet)
- type data = t node
- let make _ = failwith "make"
- end
+ module SList = Hlist.Make (StateSet)
else RS.concat res1 res2
else RS.empty
-
let top_down ?(noright=false) a tree t slist ctx slot_size =
let pempty = empty_size slot_size in
- (* evaluation starts from the right so we put sl1,res1 at the end *)
+ (* 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 res1 in
let rec fold l1 l2 fll i aq =
- match SList.node l1,SList.node l2, fll with
- | SList.Cons(s1,ll1),
- SList.Cons(s2,ll2),
- fl::fll ->
- let r',flags = eval_formlist s1 s2 fl in
- let _ = res.(i) <- RS.merge flags t res1.(i) res2.(i)
- in
+ match fll with
+ [fl] -> (* inline for speed *)
+ let s1 = SList.hd l1
+ and s2 = SList.hd l2 in
+ let r',flags = eval_formlist s1 s2 fl in
+ let _ = res.(i) <- RS.merge flags t res1.(i) res2.(i) in
+ (SList.cons r' aq),res
+ | fl::fll ->
+ let SList.Cons(s1,ll1) = l1.SList.Node.node
+ and SList.Cons(s2,ll2) = l2.SList.Node.node in
+ let r',flags = eval_formlist s1 s2 fl in
+ let _ = res.(i) <- RS.merge flags t res1.(i) res2.(i)
+ in
fold ll1 ll2 fll (i+1) (SList.cons r' aq)
-
- | SList.Nil, SList.Nil,[] -> aq,res
- | _ -> assert false
+ | _ -> aq,res
in
- fold sl1 sl2 fll 0 SList.nil
+ fold sl1 sl2 fll 0 SList.nil
in
let null_result() = (pempty,Array.make slot_size RS.empty) 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 =
in
(* Logic to chose the first and next function *)
let _,tags_below,_,tags_after = Tree.tags tree tag 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 f_kind,first = choose_jump_down tree tags_below ca da a
and n_kind,next = if noright then (`NIL, fun _ _ -> Tree.nil )
else choose_jump_next tree tags_after sa fa a in
in
let cont = D_IF_( (fun t ctx ->
let a,b = cont t ctx in
- register_trace t (slist,a,fl_list,first,next,ctx);
+ register_trace tree t (slist,a,fl_list,first,next,ctx);
(a,b)
) ,cont)
in
let _,res = top_down a tree Tree.root init Tree.root 1
in
D_IGNORE_(
- output_trace a tree root "trace.html"
- (RS.fold (fun t a -> IntSet.add (Tree.id t) a) res.(0) IntSet.empty),
+ output_trace a tree "trace.html"
+ (RS.fold (fun t a -> IntSet.add (Tree.id tree t) a) res.(0) IntSet.empty),
res.(0))
;;
end
let top_down_count a t = let module RI = Run(Integer) in Integer.length (RI.run_top_down a t)
- let top_down a t = let module RI = Run(GResult) in (RI.run_top_down a t)
+ let top_down a t = let module RI = Run(IdSet) in (RI.run_top_down a t)
let bottom_up_count a t k = let module RI = Run(Integer) in Integer.length (RI.run_bottom_up a t k)