- 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
+
+ module type ResultSet =
+ sig
+ type t
+ type elt = [` Tree] Tree.node
+ val empty : t
+ val cons : elt -> t -> t
+ val concat : t -> t -> t
+ val iter : ( elt -> unit) -> t -> unit
+ val fold : ( elt -> 'a -> 'a) -> t -> 'a -> 'a
+ val map : ( elt -> elt) -> t -> t
+ val length : t -> int
+ val merge : (bool*bool*bool*bool) -> elt -> t -> t -> t
+ end
+
+ module Integer : ResultSet =
+ struct
+ type t = int
+ type elt = [`Tree] Tree.node
+ let empty = 0
+ let cons _ x = x+1
+ let concat x y = x + y
+ let iter _ _ = failwith "iter not implemented"
+ let fold _ _ _ = failwith "fold not implemented"
+ let map _ _ = failwith "map not implemented"
+ let length x = x
+ let merge (rb,rb1,rb2,mark) t res1 res2 =
+ if rb then
+ let res1 = if rb1 then res1 else 0
+ and res2 = if rb2 then res2 else 0
+ in
+ if mark then 1+res1+res2
+ else res1+res2
+ else 0
+ end
+
+ module IdSet : ResultSet =
+ struct
+ type elt = [`Tree] Tree.node
+ type node = Nil
+ | Cons of elt * node
+ | Concat of node*node
+
+ and t = { node : node;
+ length : int }
+
+ let empty = { node = Nil; length = 0 }
+
+ let cons e t = { node = Cons(e,t.node); length = t.length+1 }
+ let concat t1 t2 = { node = Concat(t1.node,t2.node); length = t1.length+t2.length }
+ let append e t = { node = Concat(t.node,Cons(e,Nil)); length = t.length+1 }
+
+ let fold f l acc =
+ let rec loop acc t = match t with
+ | Nil -> acc
+ | Cons (e,t) -> loop (f e acc) t
+ | Concat (t1,t2) -> loop (loop acc t1) t2
+ in
+ loop acc l.node
+
+ let length l = l.length
+
+
+ let iter f l =
+ let rec loop = function
+ | Nil -> ()
+ | Cons (e,t) -> f e; loop t
+ | Concat(t1,t2) -> loop t1;loop t2
+ in loop l.node
+
+ let map f l =
+ let rec loop = function
+ | Nil -> Nil
+ | Cons(e,t) -> Cons(f e, loop t)
+ | Concat(t1,t2) -> Concat(loop t1,loop t2)
+ in
+ { l with node = loop l.node }
+
+ let merge (rb,rb1,rb2,mark) t res1 res2 =
+ if rb then
+ let res1 = if rb1 then res1 else empty
+ and res2 = if rb2 then res2 else empty
+ in
+ if mark then { node = Cons(t,(Concat(res1.node,res2.node)));
+ length = res1.length + res2.length + 1;}
+ else
+ { node = (Concat(res1.node,res2.node));
+ length = res1.length + res2.length ;}
+ else empty
+
+
+ end
+
+ module Run (RS : ResultSet) =
+ struct
+
+ module SList = struct
+ include Hlist.Make (StateSet)
+ type data = t node
+ let make _ = failwith "make"
+ end
+
+
+
+IFDEF DEBUG
+THEN
+ module IntSet = Set.Make(struct type t = int let compare = (-) end)
+INCLUDE "html_trace.ml"
+
+END
+ let mk_fun f s = D_IGNORE_(register_funname f s,f)
+ let mk_app_fun f arg s = let g = f arg in
+ D_IGNORE_(register_funname g ((get_funname f) ^ " " ^ s), g)
+
+ let string_of_ts tags = (Ptset.Int.fold (fun t a -> a ^ " " ^ (Tag.to_string t) ) tags "{")^ " }"
+
+
+ let choose_jump tagset qtags1 qtagsn a f_nil f_t1 f_s1 f_tn f_sn f_notext f_maytext =
+ let tags1,hastext1,fin1 = inter_text tagset (tags a qtags1) in
+ let tagsn,hastextn,finn = inter_text tagset (tags a qtagsn) in
+ (*if (hastext1||hastextn) then (`ANY,f_text) (* jumping to text nodes doesn't work really well *)
+ else*)
+ if (Ptset.Int.is_empty tags1) && (Ptset.Int.is_empty tagsn) then (`NIL,f_nil)
+ else if (Ptset.Int.is_empty tagsn) then
+ if (Ptset.Int.is_singleton tags1)
+ then (* TaggedChild/Sibling *)
+ let tag = (Ptset.Int.choose tags1) in (`TAG(tag),mk_app_fun f_t1 tag (Tag.to_string tag))
+ else (* SelectChild/Sibling *)
+ (`ANY,mk_app_fun f_s1 tags1 (string_of_ts tags1))
+ else if (Ptset.Int.is_empty tags1) then
+ if (Ptset.Int.is_singleton tagsn)
+ then (* TaggedDesc/Following *)
+ let tag = (Ptset.Int.choose tagsn) in (`TAG(tag),mk_app_fun f_tn tag (Tag.to_string tag))
+ else (* SelectDesc/Following *)
+ (`ANY,mk_app_fun f_sn tagsn (string_of_ts tagsn))
+ else if (hastext1||hastextn) then (`ANY,f_maytext)
+ else (`ANY,f_notext)
+
+ let choose_jump_down tree a b c d =
+ choose_jump a b c d
+ (mk_fun (fun _ -> Tree.nil) "Tree.mk_nil")
+ (mk_fun (Tree.tagged_child tree) "Tree.tagged_child")
+ (mk_fun (Tree.select_child tree) "Tree.select_child")
+ (mk_fun (Tree.tagged_desc tree) "Tree.tagged_desc")
+ (mk_fun (Tree.select_desc tree) "Tree.select_desc")
+ (mk_fun (Tree.first_element tree) "Tree.first_element")
+ (mk_fun (Tree.first_child tree) "Tree.first_child")
+
+ let choose_jump_next tree a b c d =
+ choose_jump a b c d
+ (mk_fun (fun _ _ -> Tree.nil) "Tree.mk_nil2")
+ (mk_fun (Tree.tagged_sibling_ctx tree) "Tree.tagged_sibling_ctx")
+ (mk_fun (Tree.select_sibling_ctx tree) "Tree.select_sibling_ctx")
+ (mk_fun (Tree.tagged_foll_ctx tree) "Tree.tagged_foll_ctx")
+ (mk_fun (Tree.select_foll_ctx tree) "Tree.select_foll_ctx")
+ (mk_fun (Tree.next_element_ctx tree) "Tree.node_element_ctx")
+ (mk_fun (Tree.next_sibling_ctx tree) "Tree.node_sibling_ctx")