INCLUDE "debug.ml"
INCLUDE "utils.ml"
+
type jump_kind = [ `TAG of Tag.t | `CONTAINS of string | `NOTHING ]
let cpt_trans = ref 0
let miss_trans = ref 0
let r_ignore _ x = x
let set_get_tag r t = r := (fun _ -> t)
- (*
-
- let merge_trans t a tag q acc =
- List.fold_left (fun (accf,acchash,idx) (ts,(m,f,pred)) ->
- if TagSet.mem tag ts
- then
- let acchash = HASHINT3(acchash,f.fid,q) in
- (Cons(q,f,acchash,idx,m,accf),acchash,idx+1)
- else (accf,acchash,idx)
- ) acc (try Hashtbl.find a.phi q with Not_found -> [])
-
-
-
- let cast_cont :'b -> ('a t -> Tree.t -> Tree.t -> Ptset.t*'a) =
- Obj.magic
-
- let get_trans conti t a tag r =
- try
- Hashtbl.find a.sigma (HASHINT2(Ptset.hash r,Tag.hash tag))
- with
- Not_found ->
- let fl,_,accq,_ =
- Ptset.fold (fun q (accf,acchash,accq,aidx) ->
- let naccf,acchash,naidx =
- merge_trans t a tag q (accf,acchash,aidx )
- in
- (naccf,acchash,Ptset.add q accq,naidx)
- )
- r (Nil,17,Ptset.empty,0)
- in
- let (ls,lls,llls),(rs,rrs,rrrs) =
- form_list_fold_left (fun ((a1,b1,c1),(a2,b2,c2)) _ f _ _ _ ->
- let (x1,y1,z1),(x2,y2,z2) = f.st in
- ((Ptset.union x1 a1),(Ptset.union y1 b1),(Ptset.union c1 z1)),
- ((Ptset.union x2 a2),(Ptset.union y2 b2),(Ptset.union c2 z2)))
- ((Ptset.empty,Ptset.empty,Ptset.empty),
- (Ptset.empty,Ptset.empty,Ptset.empty))
- fl
- in
- let tb,ta =
- Tree.tags t tag
- in
- let tl,htlt,lfin = inter_text tb (tags a ls)
- and tll,htllt,llfin = inter_text tb (tags a lls)
- and tr,htrt,rfin = inter_text ta (tags a rs)
- and trr,htrrt,rrfin = inter_text ta (tags a rrs)
- in
- let get_tag = ref Tree.tag in
- let first,flabel =
- if (llfin && lfin) then (* no stars *)
- (if htlt || htllt then (Tree.text_below, "#text_below")
- else
- let etl = Ptset.is_empty tl
- and etll = Ptset.is_empty tll
- in
- if (etl && etll)
- then (Tree.mk_nil, "#mk_nil")
- else
- if etl then
- if Ptset.is_singleton tll
- then begin
- set_get_tag get_tag (Ptset.choose tll);
- (Tree.tagged_desc (Ptset.choose tll), "#tagged_desc")
- end
- else (Tree.select_desc_only tll, "#select_desc_only")
- else if etll then (Tree.node_child,"#node_child")
- else (Tree.select_below tl tll,"#select_below"))
- else (* stars or node() *)
- if htlt||htllt then (Tree.first_child,"#first_child")
- else (Tree.node_child,"#node_child")
- and next,nlabel =
- if (rrfin && rfin) then (* no stars *)
- ( if htrt || htrrt
- then (Tree.text_next, "#text_next")
- else
- let etr = Ptset.is_empty tr
- and etrr = Ptset.is_empty trr
- in
- if etr && etrr
- then (mk_nil_ctx, "#mk_nil_ctx")
- else
- if etr then
- if Ptset.is_singleton trr
- then begin
- set_get_tag get_tag (Ptset.choose trr);
- (Tree.tagged_foll_below (Ptset.choose trr),"#tagged_foll_below")
- end
- else (Tree.select_foll_only trr,"#select_foll_only")
- else if etrr then (Tree.node_sibling_ctx,"#node_sibling_ctx")
- else
- (Tree.select_next tr trr,"#select_next") )
-
- else if htrt || htrrt then (Tree.next_sibling_ctx,"#next_sibling_ctx")
- else (Tree.node_sibling_ctx,"#node_sibling_ctx")
- in
- let cont = let flist = fl in
- fun a t res ctx ->
- let s1,res1 = conti a (first t) llls res t
- and s2,res2 = conti a (next t ctx) rrrs res ctx in
- let r',rb,rb1,rb2,mark,idxl = eval_formlist s1 s2 flist
- in
- r',(vb rb)*((vb mark) + (vb rb1)*res1 + (vb rb2)*res2)
- in
- Hashtbl.add a.sigma (HASHINT2(Ptset.hash r,Tag.hash tag)) (cast_cont cont);
- (cast_cont cont)
-
-
-(*
- let rec accepting_among a t r ctx =
- if Tree.is_nil t || Ptset.is_empty r then Ptset.empty,0,TS.Nil else
- let dispatch,mark,flist,llls,rrrs =
- get_trans (fun _ _ _ _ -> failwith "toto") t a (Tree.tag t) r
- in
- let s1,n1,res1 = accepting_among a (dispatch.first t) llls t in
- let s2,n2,res2 = accepting_among a (dispatch.next t ctx) rrrs ctx in
- let r',rb,rb1,rb2 = eval_formlist s1 s2 flist in
- r',(vb rb)*((vb mark) + (vb rb1)* n1 + (vb rb2)*n2),if rb then
- dispatch.consres t res1 res2 rb1 rb2
- else TS.Nil *)
-
- let run a t = assert false (*
- let st,n,res = accepting_among a t a.init t in
- if Ptset.is_empty (st) then TS.empty,0 else res,n *)
-
- let rec accepting_among_count_no_star a t r ctx =
- if Tree.is_nil t then Ptset.empty,0 else
- (get_trans (accepting_among_count_no_star) t a (Tree.tag t) r)
- a t ctx
-
-(*
- let rec accepting_among_count_star a t n =
- if Tree.is_nil t then n else
- if (Tree.tag t == Tag.attribute)
- then accepting_among_count_star a (Tree.node_sibling t) n
- else accepting_among_count_star a (Tree.node_sibling t)
- (accepting_among_count_star a (Tree.node_child t) (1+n))
-
- let rec accepting_among_count_may_star starstate a t r ctx =
- if r == starstate then starstate,(accepting_among_count_star a t 0)
- else
- if Tree.is_nil t||Ptset.is_empty r then Ptset.empty,0 else
- let dispatch,mark,flist,llls,rrrs =
- get_trans (fun _ _ _ _ -> failwith "toto") t a (Tree.tag t) r
- in
- let s1,res1 = accepting_among_count_may_star starstate a (dispatch.first t) llls t
- and s2,res2 = accepting_among_count_may_star starstate a (dispatch.next t ctx) rrrs ctx
- in
- let r',rb,rb1,rb2 = eval_formlist s1 s2 flist
- in
- r',(vb rb)*((vb mark) + (vb rb1)*res1 + (vb rb2)*res2)
-
-*)
- let run_count a t =
-
- let st,res = match a.starstate with
- | None -> accepting_among_count_no_star a t a.init t
- | Some s -> assert false (*accepting_among_count_may_star s a t a.init t *)
- in
- if Ptset.is_empty (st) then 0 else res
-
-
- let run_time _ _ = failwith "blah"
-
-
- module RealBottomUp = struct
-
- (* decrease number of arguments *)
- let ton t = if Tree.is_nil t then "##"
- else Tag.to_string (Tree.tag t)
- ;;
- let ion t = Tree.dump_node t
- let memo = Hashtbl.create 4097
- let rlist = ref []
-
- let cpt = ref 0;;
- let rec run a t res r root rinit next targettag r0 first tomark =
- incr cpt;
- let res = (vb tomark) + res in
- let newr,newres = if first then
- accepting_among_count_no_star a t r t
- else r, res
- in
- let r,res = if Ptset.is_empty newr then r,0 else newr,newres in
- if Tree.equal t root then
- if Ptset.intersect r rinit then (r,res,next)
- else (Ptset.empty,0,next)
- else
- let tag = Tree.tag t in
- let parent = Tree.binary_parent t in
- let parent_tag = Tree.tag parent in
- let left = Tree.is_left t in
- let r',mark =
- try Hashtbl.find memo (r,parent_tag,left) with
- | Not_found ->
- let pair =
- Hashtbl.fold
- (fun q l acc ->
- List.fold_left
- (fun (aq,am) (ts,(mark,form,_)) ->
- if TagSet.mem parent_tag ts then
- let (value,_,_) = if left then
- eval_form_bool form r Ptset.empty
- else
- eval_form_bool form Ptset.empty r
- in
-(* let _ = if value then begin
- Format.fprintf Format.err_formatter "Can take transition (%i,%s)%s%!"
- q (Tag.to_string parent_tag)
- (if mark then "=>" else "->");
- pr_frm Format.err_formatter form;
- Format.fprintf Format.err_formatter "%! %s(" (if left then "left" else "right");
- pr_st Format.err_formatter (Ptset.elements r);
- Format.fprintf Format.err_formatter ")\n%!" end;
- in *)
- if value then (Ptset.add q aq, mark||am)
- else (aq,am)
- else (aq,am))
- acc l
- ) a.phi (Ptset.empty,false)
- in Hashtbl.add memo (r,parent_tag,left) pair;pair
- in
- if Ptset.is_empty r' then Ptset.empty,0,next
- else
- if Tree.is_below_right t next then
- let rn,resn,nextofnext = run a next 0 r0 t r (Tree.tagged_next next targettag) targettag r0 true false
- in
- let rn,resn = if Ptset.is_empty rn then Ptset.empty,0 else rn,resn in
- run a (parent) (resn+res) r' root rinit nextofnext targettag r0 false false
- else
- run a (parent) (res) r' root rinit next targettag r0 false (mark&&left)
-
-
-
- let accept_count a t tag initset =
- let tree1 = Tree.tagged_lowest t tag in
- let tree2 = Tree.tagged_next tree1 tag in
- let c,b,_ =run a tree1 0 initset t a.init tree2 tag initset true false
- in Printf.eprintf "%i\n%!" !cpt;
- if Ptset.is_empty c then 0 else b
-
- end *)
-(*
- module RealBottomUp2 = struct
- module Formlist =
- struct
- type t = formlist
- let nil : t = Nil
- let cons q f i m l = Cons(q,f,i,m,l)
- let hash = function Nil -> 0 | Cons(_,_,i,_,_) -> max_int land i
- let pr fmt l =
- let rec loop = function
- | Nil -> ()
- | Cons(q,f,_,m,l) ->
- Format.fprintf fmt "%i %s" q (if m then "=>" else "->");
- pr_frm fmt f;
- Format.fprintf fmt "\n%!";
- loop l
- in
- loop l
- end
-
- type ptset_list = Nil | Cons of Ptset.t*int*ptset_list
- let hpl l = match l with
- | Nil -> 0
- | Cons (_,i,_) -> i
-
- let cons s l = Cons (s,(Ptset.hash s) + 65599 * (hpl l), l)
-
- let rec empty_size n =
- if n == 0 then Nil
- else cons Ptset.empty (empty_size (n-1))
-
- let fold_pl f l acc =
- let rec loop l acc = match l with
- Nil -> acc
- | Cons(s,h,pl) -> loop pl (f s h acc)
- in
- loop l acc
- let map_pl f l =
- let rec loop =
- function Nil -> Nil
- | Cons(s,h,ll) -> cons (f s) (loop ll)
- in loop l
-
- let rev_pl l =
- let rec loop acc l = match l with
- | Nil -> acc
- | Cons(s,_,ll) -> loop (cons s acc) ll
- in
- loop Nil l
-
- let rev_map_pl f l =
- let rec loop acc l =
- match l with
- | Nil -> acc
- | Cons(s,_,ll) -> loop (cons (f s) acc) ll
- in
- loop Nil l
-
- let merge_int _ rb rb1 rb2 mark _ res1 res2 =
- if rb then (vb mark) + ((vb rb1)*res1) + ((vb rb2)*res2)
- else 0
-
- let td_trans = Hashtbl.create 4096
-
- let choose_jump tagset qtags1 qtagsn a f_nil f_text f_t1 f_s1 f_tn f_sn f_notext =
- let tags1,hastext1,fin1 = inter_text tagset (tags a qtags1) in
- let tagsn,hastextn,finn = inter_text tagset (tags a qtagsn) in
-(* Format.fprintf Format.err_formatter "Tags below states ";
- pr_st Format.err_formatter (Ptset.elements qtags1);
- Format.fprintf Format.err_formatter " are { ";
- Ptset.iter (fun t -> Format.fprintf Format.err_formatter "%s " (Tag.to_string t)) tags1;
- Format.fprintf Format.err_formatter "}, %b,%b\n%!" hastext1 fin1;
-
- Format.fprintf Format.err_formatter "Tags below states ";
- pr_st Format.err_formatter (Ptset.elements qtagsn);
- Format.fprintf Format.err_formatter " are { ";
- Ptset.iter (fun t -> Format.fprintf Format.err_formatter "%s " (Tag.to_string t)) tagsn;
- Format.fprintf Format.err_formatter "}, %b,%b\n%!" hastextn finn;
-*)
- if (hastext1||hastextn) then f_text (* jumping to text nodes doesn't work really well *)
- else if (Ptset.is_empty tags1) && (Ptset.is_empty tagsn) then f_nil
- else if (Ptset.is_empty tagsn) then
- if (Ptset.is_singleton tags1) then f_t1 (Ptset.choose tags1) (* TaggedChild/Sibling *)
- else f_s1 tags1 (* SelectChild/Sibling *)
- else if (Ptset.is_empty tags1) then
- if (Ptset.is_singleton tagsn) then f_tn (Ptset.choose tagsn) (* TaggedDesc/Following *)
- else f_sn tagsn (* SelectDesc/Following *)
- else f_notext
-
- let choose_jump_down a b c d =
- choose_jump a b c d
- (Tree.mk_nil)
- (Tree.text_below )
- (fun _ -> Tree.node_child ) (* !! no tagged_child in Tree.ml *)
- (fun _ -> Tree.node_child ) (* !! no select_child in Tree.ml *)
- (Tree.tagged_desc)
- (fun _ -> Tree.node_child ) (* !! no select_desc *)
- (Tree.node_child)
-
- let choose_jump_next a b c d =
- choose_jump a b c d
- (fun t _ -> Tree.mk_nil t)
- (Tree.text_next)
- (fun _ -> Tree.node_sibling_ctx) (* !! no tagged_sibling in Tree.ml *)
- (fun _ -> Tree.node_sibling_ctx) (* !! no select_child in Tree.ml *)
- (Tree.tagged_foll_below)
- (fun _ -> Tree.node_sibling_ctx) (* !! no select_foll *)
- (Tree.node_sibling_ctx)
-
- module type RS = sig
- type t
- type elt
- val empty : t
- val cons : elt -> t -> t
- val concat : t -> t -> t
- end
-
-
- let get_trans slist tag a t =
- try
- Hashtbl.find td_trans (tag,hpl slist)
- with
- | Not_found ->
- let fl_list,llist,rlist,ca,da,sa,fa =
- fold_pl
- (fun set _ (fll_acc,lllacc,rllacc,ca,da,sa,fa) -> (* For each set *)
- let fl,ll,rr,ca,da,sa,fa =
- Ptset.fold
- (fun q acc ->
- fst (
- List.fold_left
- (fun (((fl_acc,ll_acc,rl_acc,c_acc,d_acc,s_acc,f_acc),h_acc) as acc)
- (ts,(m,f,_)) ->
- if (TagSet.mem tag ts)
- then
- let (child,desc,below),(sibl,foll,after) = f.st in
- ((Formlist.cons q f h_acc m fl_acc,
- Ptset.union ll_acc below,
- Ptset.union rl_acc after,
- Ptset.union child c_acc,
- Ptset.union desc d_acc,
- Ptset.union sibl s_acc,
- Ptset.union foll f_acc),
- HASHINT3(h_acc,f.fid,HASHINT2(q,vb m)))
- else acc ) (acc,0) (
- try Hashtbl.find a.phi q
- with
- Not_found -> Printf.eprintf "Looking for state %i, doesn't exist!!!\n%!"
- q;[]
- ))
-
- ) set (Formlist.nil,Ptset.empty,Ptset.empty,ca,da,sa,fa)
- in fl::fll_acc, cons ll lllacc, cons rr rllacc,ca,da,sa,fa)
- slist ([],Nil,Nil,Ptset.empty,Ptset.empty,Ptset.empty,Ptset.empty)
- in
- (* Logic to chose the first and next function *)
- let tags_below,tags_after = Tree.tags t tag in
- let first = choose_jump_down tags_below ca da a
- and next = choose_jump_next tags_after sa fa a in
- let v = (fl_list,llist,rlist,first,next) in
- Hashtbl.add td_trans (tag, hpl slist) v; v
-
-
- let top_down ?(noright=false) a merge null t slist ctx slot_size =
- let pempty = empty_size slot_size in
-
- let eval_fold2_slist fll sl1 sl2 res1 res2 t =
- let res = Array.copy res1 in
- let rec fold l1 l2 fll i aq = match l1,l2,fll with
- | Cons(s1,_,ll1), Cons(s2, _ ,ll2),fl::fll ->
- let r',rb,rb1,rb2,mark = eval_formlist s1 s2 fl in
- let _ = res.(i) <- merge null rb rb1 rb2 mark t res1.(i) res2.(i)
- in
-(* let _ = Format.fprintf Format.err_formatter "(%b,%b,%b,%b) Result was %i %i, now %i\n%!"
- rb rb1 rb2 mark (Obj.magic res1.(i)) (Obj.magic res2.(i)) (Obj.magic res.(i));
- in *)
-
- fold ll1 ll2 fll (i+1) (cons r' aq)
- | Nil, Nil,[] -> aq,res
- | _ -> assert false
- in
- fold sl1 sl2 fll 0 Nil
- in
- let rec loop t slist ctx =
- if Tree.is_nil t then (pempty,Array.make slot_size null)
- else
- let tag = Tree.tag t in
- let fl_list,llist,rlist,first,next = get_trans slist tag a t in
- let sl1,res1 = loop (first t) llist t in
- let sl2,res2 = if noright then (pempty,Array.make slot_size null)
- else loop (next t ctx) rlist ctx in
- eval_fold2_slist fl_list sl1 sl2 res1 res2 t
- in
- loop t slist ctx
- let run_top_down_count a t =
- let init = cons a.init Nil in
- let _,res = top_down a (fun _ rb rb1 rb2 mark t res1 res2 ->
- (vb rb)*( (vb mark) + (vb rb1)*res1 + (vb rb2)*res2))
- 0 t init t 1
- in res.(0)
- ;;
-
- let run_top_down a t =
- let init = cons a.init Nil in
- let _,res =
- top_down a (fun null rb rb1 rb2 mark t res1 res2 ->
- if rb then
- TS.concat
- (TS.concat (if mark then TS.Sing(t) else null)
- (if rb1 then res1 else null))
- (if rb2 then res2 else null)
- else null)
- TS.Nil t init t 1
- in res.(0)
- ;;
-
-
- end
-*)
module type ResultSet =
sig
type t
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
projects / SXSI / xpathcomp.git / blobdiff