X-Git-Url: http://git.nguyen.vg/gitweb/?a=blobdiff_plain;f=ata.ml;h=fc29e98fc96c916a05a8710a675a6d08a34a0231;hb=52101d20031fd52639753282519b8a45e26ecb5d;hp=a9dbf2279e0b1b2c1600af7a08885ecf01755aa1;hpb=4a66518948bf6356b5cb72ba30b4d48a8c9e833a;p=SXSI%2Fxpathcomp.git diff --git a/ata.ml b/ata.ml index a9dbf22..fc29e98 100644 --- a/ata.ml +++ b/ata.ml @@ -30,46 +30,52 @@ type formula_expr = | False | True | Or of formula * formula | And of formula * formula - | Atom of ([ `Left | `Right ]*bool*state) + | Atom of ([ `Left | `Right | `LLeft | `RRight ]*bool*state) and formula = { fid: int; + fkey : int; pos : formula_expr; neg : formula; - st : Ptset.t*Ptset.t; + st : (Ptset.t*Ptset.t)*(Ptset.t*Ptset.t); size: int; } +external hash_const_variant : [> ] -> int = "%identity" +external int_bool : bool -> int = "%identity" + +let hash_node_form t = match t with + | False -> 0 + | True -> 1 + | And(f1,f2) -> (2+17*f1.fkey + 37*f2.fkey) land max_int + | Or(f1,f2) -> (3+101*f1.fkey + 253*f2.fkey) land max_int + | Atom(v,b,s) -> ((hash_const_variant v) + (3846*(int_bool b) +257) + (s lsl 13 - s)) land max_int + module FormNode = struct type t = formula - let hash t = match t.pos with - | False -> 0 - | True -> 1 - | And(f1,f2) -> (2+17*f1.fid + 37*f2.fid) land max_int - | Or(f1,f2) -> (3+101*f1.fid + 253*f2.fid) land max_int - | Atom(`Left,true,s) -> (5 + 11 * 23 * s) land max_int - | Atom(`Right,true,s) -> (5 + 19 * 23 * s) land max_int - | Atom(`Left,false,s) -> (5 + 11 * 39 * s) land max_int - | Atom(`Right,false,s) -> (5 + 19 * 39 * s) land max_int - - + + let hash t = t.fkey let equal f1 f2 = - if f1.fid == f2.fid || f1.pos == f2.pos then true + if f1.fid == f2.fid || f1.fkey == f2.fkey || f1.pos == f2.pos then true else match f1.pos,f2.pos with | False,False | True,True -> true - | Atom(d1,b1,s1), Atom(d2,b2,s2) when (b1==b2) && (s1=s2) && (d1 = d2) -> true + | Atom(d1,b1,s1), Atom(d2,b2,s2) when (b1==b2) && (s1==s2) && (d1 = d2) -> true | Or(g1,g2),Or(h1,h2) | And(g1,g2),And(h1,h2) -> g1.fid == h1.fid && g2.fid == h2.fid | _ -> false + end module WH = Weak.Make(FormNode) let f_pool = WH.create 107 +let empty_pair = Ptset.empty,Ptset.empty +let empty_quad = empty_pair,empty_pair + let true_,false_ = - let rec t = { fid = 1; pos = True; neg = f ; st = Ptset.empty,Ptset.empty; size =1; } - and f = { fid = 0; pos = False; neg = t; st = Ptset.empty,Ptset.empty; size = 1; } + let rec t = { fid = 1; pos = True; fkey=1; neg = f ; st = empty_quad; size =1; } + and f = { fid = 0; pos = False; fkey=0; neg = t; st = empty_quad; size = 1; } in WH.add f_pool f; WH.add f_pool t; @@ -82,6 +88,7 @@ let is_false f = f.fid == 0 let cons pos neg s1 s2 size1 size2 = let rec pnode = { fid = gen_id (); + fkey = hash_node_form pos; pos = pos; neg = nnode; st = s1; @@ -89,6 +96,7 @@ let cons pos neg s1 s2 size1 size2 = and nnode = { fid = gen_id (); pos = neg; + fkey = hash_node_form neg; neg = pnode; st = s2; size = size2; @@ -99,20 +107,24 @@ let cons pos neg s1 s2 size1 size2 = let atom_ d p s = let si = Ptset.singleton s in let ss = match d with - | `Left -> si,Ptset.empty - | `Right -> Ptset.empty,si + | `Left -> (si,Ptset.empty),empty_pair + | `Right -> empty_pair,(si,Ptset.empty) + | `LLeft -> (Ptset.empty,si),empty_pair + | `RRight -> empty_pair,(Ptset.empty,si) in fst (cons (Atom(d,p,s)) (Atom(d,not p,s)) ss ss 1 1) + +let union_quad ((l1,ll1),(r1,rr1)) ((l2,ll2),(r2,rr2)) = + (Ptset.union l1 l2 ,Ptset.union ll1 ll2), + (Ptset.union r1 r2 ,Ptset.union rr1 rr2) let merge_states f1 f2 = let sp = - Ptset.union (fst f1.st) (fst f2.st), - Ptset.union (snd f1.st) (snd f2.st) + union_quad f1.st f2.st and sn = - Ptset.union (fst f1.neg.st) (fst f2.neg.st), - Ptset.union (snd f1.neg.st) (snd f2.neg.st) + union_quad f1.neg.st f2.neg.st in sp,sn - + let full_or_ f1 f2 = let f1,f2 = if f1.fid < f2.fid then f2,f1 else f1,f2 in let sp,sn = merge_states f1 f2 in @@ -208,48 +220,52 @@ type t = { (pr_frm ppf f2); | Atom(dir,b,s) -> Format.fprintf ppf "%s%s[%i]" (if b then "" else "¬") - (if dir = `Left then "↓₁" else "↓₂") s + (match dir with + | `Left -> "↓₁" + | `Right -> "↓₂" + | `LLeft -> "⇓₁" + | `RRight -> "⇓₂") s let dnf_hash = Hashtbl.create 17 let rec dnf_aux f = match f.pos with | False -> PL.empty | True -> PL.singleton (Ptset.empty,Ptset.empty) - | Atom(`Left,_,s) -> PL.singleton (Ptset.singleton s,Ptset.empty) - | Atom(`Right,_,s) -> PL.singleton (Ptset.empty,Ptset.singleton s) + | Atom((`Left|`LLeft),_,s) -> PL.singleton (Ptset.singleton s,Ptset.empty) + | Atom((`Right|`RRight),_,s) -> PL.singleton (Ptset.empty,Ptset.singleton s) | Or(f1,f2) -> PL.union (dnf f1) (dnf f2) | And(f1,f2) -> - let pl1 = dnf f1 - and pl2 = dnf f2 - in - PL.fold (fun (s1,s2) acc -> - PL.fold ( fun (s1', s2') acc' -> - (PL.add - ((Ptset.union s1 s1'), - (Ptset.union s2 s2')) acc') ) - pl2 acc ) - pl1 PL.empty - - - and dnf f = - try + let pl1 = dnf f1 + and pl2 = dnf f2 + in + PL.fold (fun (s1,s2) acc -> + PL.fold ( fun (s1', s2') acc' -> + (PL.add + ((Ptset.union s1 s1'), + (Ptset.union s2 s2')) acc') ) + pl2 acc ) + pl1 PL.empty + + + and dnf f = + try Hashtbl.find dnf_hash f.fid with - Not_found -> - let d = dnf_aux f in - Hashtbl.add dnf_hash f.fid d;d + Not_found -> + let d = dnf_aux f in + Hashtbl.add dnf_hash f.fid d;d - let can_top_down f = + let can_top_down f = let nf = dnf f in if (PL.cardinal nf > 3)then None else match PL.elements nf with - | [(s1,s2); (t1,t2); (u1,u2)] when - Ptset.is_empty s1 && Ptset.is_empty s2 && Ptset.is_empty t1 && Ptset.is_empty u2 - -> Some(true,t2,u1) - | [(t1,t2); (u1,u2)] when Ptset.is_empty t1 && Ptset.is_empty u2 - -> Some(false,t2,u1) - | _ -> None + | [(s1,s2); (t1,t2); (u1,u2)] when + Ptset.is_empty s1 && Ptset.is_empty s2 && Ptset.is_empty t1 && Ptset.is_empty u2 + -> Some(true,t2,u1) + | [(t1,t2); (u1,u2)] when Ptset.is_empty t1 && Ptset.is_empty u2 + -> Some(false,t2,u1) + | _ -> None let equal_form f1 f2 = @@ -269,7 +285,7 @@ type t = { let s = if TagSet.is_finite ts - then "{" ^ (TagSet.fold (fun t a -> a ^ " " ^ (Tag.to_string t)) ts "") ^"}" + then "{" ^ (TagSet.fold (fun t a -> a ^ " '" ^ (Tag.to_string t)^"'") ts "") ^" }" else let cts = TagSet.neg ts in if TagSet.is_empty cts then "*" else (TagSet.fold (fun t a -> a ^ " " ^ (Tag.to_string t)) cts "*\\{" @@ -285,9 +301,14 @@ type t = { Format.fprintf ppf ",%s %s " (Tag.to_string t) (if b then "=>" else "->"); pr_frm ppf f; Format.fprintf ppf "(fid=%i) left=" f.fid; - let l,r = f.st in pr_st ppf (Ptset.elements l); + let (l,ll),(r,rr) = f.st in + pr_st ppf (Ptset.elements l); + Format.fprintf ppf ", "; + pr_st ppf (Ptset.elements ll); Format.fprintf ppf ", right="; pr_st ppf (Ptset.elements r); + Format.fprintf ppf ", "; + pr_st ppf (Ptset.elements rr); Format.fprintf ppf "\n"; ) a.sigma; Format.fprintf ppf "=======================================\n" @@ -308,7 +329,7 @@ type t = { let equal_trans (q1,t1,m1,f1,_) (q2,t2,m2,f2,_) = (q1 == q2) && (TagSet.equal t1 t2) && (m1 == m2) && (equal_form f1 f2) - + module TS = struct type node = Nil | Cons of Tree.t * node | Concat of node*node @@ -319,7 +340,8 @@ type t = { let cons e t = node (Cons(e,t.node)) (t.size+1) let concat t1 t2 = node (Concat (t1.node,t2.node)) (t1.size+t2.size) - let append e t = concat t (cons e empty) + let append = cons +(* let append e t = node (Concat(t.node,Cons(e,Nil))) (t.size+1) *) let to_list_rev t = let rec aux acc l rest = @@ -344,86 +366,30 @@ type t = { | Concat(n1,n2) -> let _ = loop n1 in loop n2 in loop n - end - module TS2 = - struct - type t = string - let empty = String.make 10_000_000 '0' - let cons e t = t.[Tree.id e] <- '1';t - let append = cons - let concat s1 s2 = failwith "not implemented" - - let length t = - let res = ref 0 in - for i = 0 to 9_999_999 do - if t.[i] == '1' then - incr res - done; !res - - let iter f t = failwith "not implemented" - let to_list_rev t = failwith "not implemented" - end + let rev_iter f { node = n } = + let rec loop = function + | Nil -> () + | Cons(e,n) -> let _ = loop n in f e + | Concat(n1,n2) -> let _ = loop n2 in loop n1 + in loop n - module BottomUpNew = struct - -IFDEF DEBUG -THEN - type trace = - | TNil of Ptset.t*Ptset.t - | TNode of Ptset.t*Ptset.t*bool* (int*bool*formula) list - - let traces = Hashtbl.create 17 - let dump_trace t = - let out = open_out "debug_trace.dot" - in - let outf = Format.formatter_of_out_channel out in - - 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 - | _ -> assert false + let find f { node = n } = + let rec loop = function + | Nil -> raise Not_found + | Cons(e,n) -> if f e then e else loop n + | Concat(n1,n2) -> try + loop n1 + with + | Not_found -> loop n2 in - Format.fprintf outf "digraph G {\n"; - ignore(aux t 0); - Format.fprintf outf "}\n%!"; - close_out out; - ignore(Sys.command "dot -Tsvg debug_trace.dot > debug_trace.svg") -END - + loop n + end +(* + module BottomUpJumpNew = struct +*) module HFEval = Hashtbl.Make( struct type t = int*Ptset.t*Ptset.t @@ -432,36 +398,14 @@ END let hash (a,b,c) = a+17*(Ptset.hash b) + 31*(Ptset.hash c) end) - + let hfeval = HFEval.create 4097 -(* let miss = ref 0 - let call = ref 0 - let timeref = ref 0.0 - let timerefall = ref 0.0 - let time f x = - incr call; - let t1 = Unix.gettimeofday () - in let r = f x - in - timeref := !timeref +. ((Unix.gettimeofday()) -. t1); - r - - let timeall f x = - let t1 = Unix.gettimeofday () - in let r = f x - in - timerefall := !timerefall +. ((Unix.gettimeofday()) -. t1); - r - -*) - - let eval_form_bool f s1 s2 = let rec eval f = match f.pos with - | Atom(`Left,b,q) -> if b == (Ptset.mem q s1) then (true,true,false) else false,false,false - | Atom(`Right,b,q) -> if b == (Ptset.mem q s2) then (true,false,true) else false,false,false + | Atom((`Left|`LLeft),b,q) -> if b == (Ptset.mem q s1) then (true,true,false) else false,false,false + | Atom((`Right|`RRight),b,q) -> if b == (Ptset.mem q s2) then (true,false,true) else false,false,false (* test some inlining *) | True -> true,true,true | False -> false,false,false @@ -496,55 +440,6 @@ END in eval f - module HFEvalDir = Hashtbl.Make( - struct - type t = int*Ptset.t*[`Left | `Right ] - let equal (a,b,c) (d,e,f) = - a==d && (Ptset.equal b e) && (c = f) - let hash_dir = function `Left -> 7919 - | `Right -> 3517 - - let hash (a,b,c) = - a+17*(Ptset.hash b) + 31*(hash_dir c) - end) - - let hfeval_dir = HFEvalDir.create 4097 - - - let eval_dir dir f s = - let rec eval f = match f.pos with - | Atom(d,b,q) when d = dir -> if b == (Ptset.mem q s) then true_ else false_ - | Atom(_,b,q) -> f - (* test some inlining *) - | True -> true_ - | False -> false_ - | _ -> - try - HFEvalDir.find hfeval_dir (f.fid,s,dir) - with - | Not_found -> - let r = - match f.pos with - | Or(f1,f2) -> - let f1 = eval f1 - in - if is_true f1 then true_ - else if is_false f1 then eval f2 - else or_ f1 f2 - | And(f1,f2) -> - let f1 = eval f1 in - if is_false f1 then false_ - else if is_true f1 then eval f2 - else and_ f1 f2 - | _ -> assert false - in - HFEvalDir.add hfeval_dir (f.fid,s,dir) r; - r - - in eval f - - - let fstate_pool = Hashtbl.create 11 let merge_pred a b = match a,b with @@ -576,8 +471,7 @@ END else f,false in (or_ tmpf accf,accm||m,acchtrue||hastrue) else (accf,accm,acchtrue) - ) acc (Hashtbl.find a.phi q) - + ) acc (try Hashtbl.find a.phi q with Not_found -> []) let get_trans t a tag r = try @@ -599,173 +493,291 @@ END HTagSet.add a.sigma (accq,tag) (mark,f,([],[]),has_true); f.st,f,mark,has_true,accq + let h_union = Hashtbl.create 4097 + + let pt_cup s1 s2 = + let h = (Ptset.hash s1,Ptset.hash s2) in + try + Hashtbl.find h_union h + with + | Not_found -> let s = Ptset.union s1 s2 + in + Hashtbl.add h_union h s;s - let check_pred l t = true (*l = [] || - List.exists (function p -> - match p with - `Left f | `Right f -> f t - | _ -> assert false) l - *) + + + let tags_of_state a q = Hashtbl.fold + (fun p l acc -> + if p == q then + List.fold_left + (fun acc (ts,_) -> + pt_cup (TagSet.positive ts) acc) acc l + else acc) a.phi Ptset.empty + + let h_tags_states = Hashtbl.create 4096 + + + + + let tags a qs = + try + Hashtbl.find h_tags_states (Ptset.hash qs) + with + | Not_found -> + let l = Ptset.fold (fun q acc -> pt_cup acc (tags_of_state a q)) qs Ptset.empty + in + Hashtbl.add h_tags_states (Ptset.hash qs) l;l + + let time cpt acc f x = + let t1 = Unix.gettimeofday () in + let r = f x in + let t2 = Unix.gettimeofday () in + let t = (1000. *.(t2 -. t1)) in + acc:=!acc+.t; + incr cpt; + r + + let h_time = Hashtbl.create 4096 + let calls = ref 0 - let rec accepting_among2 a t r acc = + let rtime s f x = + + let cpt,atime = + try + Hashtbl.find h_time s + with + | _ -> (ref 0, ref 0.) + in + let r = time cpt atime f x + in + Hashtbl.replace h_time s (cpt,atime); + r + + let rec accepting_among_time a t r ctx = + incr calls; let orig = r in let rest = Ptset.inter r a.final in let r = Ptset.diff r rest in - if Ptset.is_empty r then rest,acc else - if (not (Tree.is_node t)) + if Ptset.is_empty r then rest,TS.empty else + if Tree.is_node t then - orig,acc - else - let t1 = Tree.first_child t - and t2 = Tree.next_sibling t in - let (r1,r2),formula,mark,has_true,r = get_trans t a (Tree.tag t) r - in - let s1,res1 = accepting_among2 a t1 r1 acc - in - let formula = eval_dir `Left formula s1 in - if is_false formula then rest,acc - else - if is_true formula then (* tail call equivalent to a top down *) - accepting_among2 a t2 orig (if mark then TS.append t res1 else res1) + let among,result,form = + let ((ls,lls),(rs,rrs)),formula,mark,has_true,r' = + let tag = rtime "Tree.tag" Tree.tag t in + rtime "get_trans" (get_trans t a tag) r + in + let tl = rtime "tags" (tags a) ls + and tr = rtime "tags" (tags a) rs + and tll = rtime "tags" (tags a) lls + and trr = rtime "tags" (tags a) rrs + in + let first = + if Ptset.mem Tag.pcdata (pt_cup tl tll) + then + rtime "Tree.text_below" (Tree.text_below) t else - let s2,res2 = accepting_among2 a t2 r2 res1 + let etl = Ptset.is_empty tl + and etll = Ptset.is_empty tll in - let formula = eval_dir `Right formula s2 + if etl && etll + then Tree.mk_nil t + else + if etl then rtime "Tree.tagged_desc_only" (Tree.tagged_desc_only t) tll + else if etll then rtime "Tree.first_child" (Tree.first_child) t + else (* add child only *) + rtime "Tree.tagged_below" (Tree.tagged_below t tl) tll + and next = + if Ptset.mem Tag.pcdata (pt_cup tr trr) + then + rtime "Tree.text_next" (Tree.text_next t) ctx + else + let etr = Ptset.is_empty tr + and etrr = Ptset.is_empty trr in - if is_false formula then rest,res1 + if etr && etrr + then Tree.mk_nil t else - orig,(if mark then TS.append t (res2) - else res2) + if etr then rtime "Tree.tagged_foll_only" (Tree.tagged_foll_only t trr) ctx + else if etrr then rtime "Tree.next_sibling" (Tree.next_sibling) t + else (* add ns only *) + rtime "Tree.tagged_next" (Tree.tagged_next t tr trr) ctx + + in + let s1,res1 = accepting_among_time a first (pt_cup ls lls) t + and s2,res2 = accepting_among_time a next (pt_cup rs rrs) ctx + in + let rb,rb1,rb2 = rtime "eval_form_bool" (eval_form_bool formula s1) s2 in + if rb + then + let res1 = if rb1 then res1 else TS.empty + and res2 = if rb2 then res2 else TS.empty + in r', rtime "TS.concat" (TS.concat res2) (if mark then rtime "TS.append" (TS.append t) res1 else res1),formula + else Ptset.empty,TS.empty,formula + + in + + among,result + + else orig,TS.empty + + + let run_time a t = + let st,res = accepting_among_time a t a.init t in + let _ = Printf.eprintf "\n Timings\n"; + let total_time = Hashtbl.fold (fun fname ({ contents=cpt }, {contents=atime}) (total_time) -> + Printf.eprintf "%s\t %i calls, %f ms accumulated time, %f ms mean time\n" + fname cpt atime (atime /. (float_of_int cpt)); + total_time +. atime ) h_time 0. + in + Printf.eprintf "total calls %i, total monitored time %f ms\n%!" !calls total_time + in + if Ptset.is_empty (st) then TS.empty else res + - let rec accepting_among a t r = + let rec accepting_among a t r ctx = let orig = r in let rest = Ptset.inter r a.final in let r = Ptset.diff r rest in if Ptset.is_empty r then rest,TS.empty else if Tree.is_node t then - let (r1,r2),formula,mark,has_true,r = get_trans t a (Tree.tag t) r - in - let s1,res1 = accepting_among a (Tree.first_child t) r1 - and s2,res2 = accepting_among a (Tree.next_sibling t) r2 - in - let rb,rb1,rb2 = eval_form_bool formula s1 s2 in - if rb - then - let res1 = if rb1 then res1 else TS.empty - and res2 = if rb2 then res2 else TS.empty - in r, TS.concat res2 (if mark then TS.cons t res1 else res1) - else orig,TS.empty + let among,result,form = + let ((ls,lls),(rs,rrs)),formula,mark,has_true,r' = + let tag = Tree.tag t in + get_trans t a tag r + in + let tl = tags a ls + and tr = tags a rs + and tll = tags a lls + and trr = tags a rrs + in + let first = + if Ptset.mem Tag.pcdata (pt_cup tl tll) + then + Tree.text_below t + else + let etl = Ptset.is_empty tl + and etll = Ptset.is_empty tll + in + if etl && etll + then Tree.mk_nil t + else + if etl then Tree.tagged_desc_only t tll + else if etll then Tree.first_child t + else (* add child only *) + Tree.tagged_below t tl tll + and next = + if Ptset.mem Tag.pcdata (pt_cup tr trr) + then + Tree.text_next t ctx + else + let etr = Ptset.is_empty tr + and etrr = Ptset.is_empty trr + in + if etr && etrr + then Tree.mk_nil t + else + if etr then Tree.tagged_foll_only t trr ctx + else if etrr then Tree.next_sibling t + else (* add ns only *) + Tree.tagged_next t tr trr ctx + + in + let s1,res1 = accepting_among a first (pt_cup ls lls) t + and s2,res2 = accepting_among a next (pt_cup rs rrs) ctx + in + let rb,rb1,rb2 = eval_form_bool formula s1 s2 in + if rb + then + let res1 = if rb1 then res1 else TS.empty + and res2 = if rb2 then res2 else TS.empty + in r', TS.concat res2 (if mark then TS.append t res1 else res1),formula + else Ptset.empty,TS.empty,formula + + in + among,result + else orig,TS.empty + + let run a t = + let st,res = accepting_among a t a.init t in + if Ptset.is_empty (st) then TS.empty else res - - - let rec accepting_count a t r = + let rec accepting_among_count a t r ctx = let orig = r in let rest = Ptset.inter r a.final in let r = Ptset.diff r rest in if Ptset.is_empty r then rest,0 else if Tree.is_node t then - let (r1,r2),formula,mark,has_true,r = get_trans t a (Tree.tag t) r + let ((ls,lls),(rs,rrs)),formula,mark,has_true,r' = + let tag = Tree.tag t in + get_trans t a tag r in - let s1,res1 = accepting_count a (Tree.first_child t) r1 - and s2,res2 = accepting_count a (Tree.next_sibling t) r2 + let tl = tags a ls + and tr = tags a rs + and tll = tags a lls + and trr = tags a rrs + in + let first = + if Ptset.mem Tag.pcdata (pt_cup tl tll) + then + Tree.text_below t + else + let etl = Ptset.is_empty tl + and etll = Ptset.is_empty tll + in + if etl && etll + then Tree.mk_nil t + else + if etl then Tree.tagged_desc_only t tll + else if etll then Tree.first_child t + else (* add child only *) + Tree.tagged_below t tl tll + and next = + if Ptset.mem Tag.pcdata (pt_cup tr trr) + then + Tree.text_next t ctx + else + let etr = Ptset.is_empty tr + and etrr = Ptset.is_empty trr + in + if etr && etrr + then Tree.mk_nil t + else + if etr then Tree.tagged_foll_only t trr ctx + else if etrr then Tree.next_sibling t + else (* add ns only *) + Tree.tagged_next t tr trr ctx + + in + let s1,res1 = accepting_among_count a first (pt_cup ls lls) t + and s2,res2 = accepting_among_count a next (pt_cup rs rrs) ctx in let rb,rb1,rb2 = eval_form_bool formula s1 s2 in - if rb - then - let res1 = if rb1 then res1 else 0 - and res2 = if rb2 then res2 else 0 - in r, res1+res2+(if mark then 1 else 0) - else orig,0 + if rb + then + let res1 = if rb1 then res1 else 0 + and res2 = if rb2 then res2 else 0 + in r', res2 + (if mark then 1 + res1 else res1) + else Ptset.empty,0 + + + else orig,0 + + let run_count a t = + let st,res = accepting_among_count a t a.init t in + if Ptset.is_empty (st) then 0 else res - let run a t = -(* let _ = - call := 0; miss:=0; - timeref := 0.0; - HFEval.clear hfeval; - Hashtbl.clear dnf_hash; - Hashtbl.clear fstate_pool; - in *) - let st,res = accepting_among a t a.init in - let b = Ptset.is_empty (st) in - if b then TS.empty - else - res - let run_count a t = -(* let _ = - call := 0; miss:=0; - timeref := 0.0; - timerefall := 0.0; - HFEval.clear hfeval; - Hashtbl.clear dnf_hash; - Hashtbl.clear fstate_pool; - in *) - let st,res = accepting_count a t a.init in - let b = Ptset.is_empty (st) in - if b then 0 - else - res - end - - module Jump = struct - let eval_dir = BottomUpNew.eval_dir - let xi1 = HTagSet.create 10 - let xi2 = HTagSet.create 10 - - let rec accept_from orig a t r acc = - if (Tree.is_root t) || - (Ptset.subset orig r) - then - acc - else - let is_left = Tree.is_left t in - let tag = Tree.tag t in - let nr,f, mark = - try - HTagSet.find (if is_left then xi1 else xi2) - (r,tag) - with - | Not_found -> - let trans = - Hashtbl.fold - (fun q l acc -> - List.fold_left (fun ((racc,facc,macc) as acc) (ts,(m,f,_)) -> - let rl,rr = f.st in - if (TagSet.mem tag ts) && - (Ptset.intersect (if is_left then rl else rr) r) - then (Ptset.add q racc,or_ f facc, macc||m) - else acc) acc l) - a.phi (Ptset.empty,false_,false) - in - HTagSet.add (if is_left then xi1 else xi2) (r,tag) trans; - trans - in - let form = eval_dir (if is_left then `Left else `Right) f r - in - if is_true form then accept_from orig a (Tree.parent t) nr - (if mark then TS.cons t acc else acc) - else if is_false form then TS.empty - else assert false - - let run a t r = - HTagSet.clear xi1; - HTagSet.clear xi2; - let orig = - List.fold_left (fun s (_,(_,f,_)) -> - Ptset.union s (fst f.st)) - Ptset.empty (Hashtbl.find a.phi (Ptset.choose a.init)) - in - accept_from orig a t r TS.empty - +(* end +*)