- | `Positive s -> let r = Ptset.inter a s in (r,Ptset.mem Tag.pcdata r, true)
- | `Negative s -> let r = Ptset.diff a s in (r, Ptset.mem Tag.pcdata r, false)
-
- let mk_nil_ctx x _ = Tree.mk_nil x
- let next_sibling_ctx x _ = Tree.next_sibling x
- 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 =