- 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,TS.empty else
- if Tree.is_node t
- then
- 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 etl = Ptset.is_empty tl
- and etll = Ptset.is_empty tll
- in
- 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 etr && etrr
- then Tree.mk_nil t
- else
- 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 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 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
-