- open Ast
- open Automaton
-
-
- type direction = Left | Right | Final
- let (==>) a (b,c,d) = Transition.Label(a,b,c,d)
- let (@@) b (c,d) = (b,c,d)
-
- let star = TagSet.Xml.star
- let any = TagSet.Xml.any
- let notstar = TagSet.Xml.add Tag.pcdata (TagSet.Xml.add Tag.attribute TagSet.Xml.empty)
- let swap dir a b = match dir with
- | Left | Final -> (a,b)
- | Right -> (b,a)
-
- let split_dest q l =
- let rec aux ((qacc,nqacc) as acc) = function
- | [] -> acc
- | t::r ->
- aux (if State.equal (Transition.dest1 t) q
- || State.equal (Transition.dest2 t) q
- then t::qacc , nqacc
- else qacc , (t::nqacc)) r
- in
- aux ([],[]) l
-
-
- let mk_tag_t dir s ts q1 q2 = (s==> ts @@ (swap dir q1 q2));;
- let mk_self_trs ts acc l =
- List.fold_left
- (fun acc t ->
- let s = Transition.source t in
- let d1 = Transition.dest1 t in
- let d2 = Transition.dest2 t in
- let tself = (s ==> ts @@ (d1,d2)) in
- (Transition.cap t tself)::acc ) (acc) l
-
- let mk_pred_trs f acc l =
- List.fold_left
- (fun acc t ->
- let s = Transition.source t in
- let d1 = Transition.dest1 t in
- let d2 = Transition.dest2 t in
- let tself = Transition.External(s,f,d1,d2) in
- (Transition.cap t tself)::acc ) (acc) l
-
- let mk_dself_trs q' ts acc l =
- List.fold_left
- (fun acc t ->
- let t',s,d2 = match t with
- | Transition.Label(s,ts,_,d2) -> Transition.Label(s,ts,q',d2),s,d2
- | Transition.External (s,f,_,d2) -> Transition.External(s,f,q',d2),s,d2
+open Ast
+type transition = Ata.State.t*TagSet.t*Ata.Transition.t
+
+type config = { st_root : Ata.State.t; (* state matching the root element (initial state) *)
+ st_univ : Ata.State.t; (* universal state accepting anything *)
+ st_from_root : Ata.State.t; (* state chaining the root and the current position *)
+ mutable final_state : Ata.StateSet.t;
+ mutable has_backward: bool;
+ (* To store transitions *)
+ (* Key is the from state, (i,l) -> i the number of the step and l the list of trs *)
+ tr_parent_loop : (Ata.State.t,int*(transition list)) Hashtbl.t;
+ tr : (Ata.State.t,int*(transition list)) Hashtbl.t;
+ tr_aux : (Ata.State.t,int*(transition list)) Hashtbl.t;
+ mutable entry_points : (Tag.t*Ata.StateSet.t) list;
+ mutable contains : string option;
+ mutable univ_states : Ata.State.t list;
+ mutable starstate : Ata.StateSet.t option;
+ }
+let dummy_conf = { st_root = -1;
+ st_univ = -1;
+ st_from_root = -1;
+ final_state = Ata.StateSet.empty;
+ has_backward = false;
+ tr_parent_loop = Hashtbl.create 0;
+ tr = Hashtbl.create 0;
+ tr_aux = Hashtbl.create 0;
+ entry_points = [];
+ contains = None;
+ univ_states = [];
+ starstate = None;
+ }
+
+
+let _r =
+ function (`Left|`Last) -> `Right
+ | `Right -> `Left
+ | `RRight -> `LLeft
+ | `LLeft -> `RRight
+
+
+let _l =
+ function (`Left|`Last) -> `Left
+ | `Right -> `Right
+ | `RRight -> `RRight
+ | `LLeft -> `LLeft
+
+
+open Ata.Transition.Infix
+open Ata.Formula.Infix
+
+
+(* Todo : fix *)
+let add_trans num htr ((q,ts,_)as tr) =
+ Hashtbl.add htr q (num,[tr])
+
+let vpush x y = (x,[]) :: y
+let hpush x y =
+ match y with
+ | (z,r)::l -> (z,x::r) ::l
+ | _ -> assert false
+
+let vpop = function
+ (x,_)::r -> x,r
+ | _ -> assert false
+
+let hpop = function
+ | (x,z::y) ::r -> z,(x,y)::r
+ | _-> assert false
+
+let rec compile_step ?(existential=false) conf q_src dir ctx_path nrec step num =
+ let ex = existential in
+ let axis,test,pred = step in
+ let is_last = dir = `Last in
+ let { st_root = q_root;
+ st_univ = q_univ;
+ st_from_root = q_frm_root } = conf
+ in
+ let q_dst = Ata.State.make() in
+ let p_st, p_anc, p_par, p_pre, p_num, p_f =
+ compile_pred conf q_src num ctx_path dir pred q_dst
+ in
+ let new_st,new_dst, new_ctx =
+ match axis with
+ | Child | Descendant ->
+ if (TagSet.is_finite test)
+ then conf.entry_points <- (TagSet.choose test,Ata.StateSet.singleton q_src)::conf.entry_points;
+ let left,right =
+ if nrec then `LLeft,`RRight
+ else `Left,`Right
+ in
+ let _ = if is_last && axis=Descendant && TagSet.equal test TagSet.star
+ then conf.starstate <- Some(Ata.StateSet.singleton q_src)
+ in
+ let t1,ldst = ?< q_src><(test, is_last && not(ex))>=>
+ p_f *& ( if is_last then Ata.Formula.true_ else (_l left) *+ q_dst),
+ ( if is_last then [] else [q_dst])
+ in
+
+ let _ = add_trans num conf.tr t1 in
+ let _ = if axis=Descendant then
+ add_trans num conf.tr_aux (
+ ?< q_src><@ ((if ex||nrec then TagSet.diff TagSet.star test
+ else TagSet.star),false)>=>
+ (if TagSet.equal test TagSet.star then
+ `Left else `LLeft) *+ q_src )
+ in
+ let t3 =
+ ?< q_src><@ ((if ex then TagSet.diff TagSet.any test
+ else TagSet.any), false)>=>
+ (if axis=Descendant && (not (TagSet.equal test TagSet.star)) then
+ `RRight else `Right) *+ q_src
+ in
+ let _ = add_trans num conf.tr_aux t3
+ in
+ ldst, q_dst,
+ (if axis = FollowingSibling then hpush q_src ctx_path else vpush q_src ctx_path)
+
+
+ | Attribute ->
+ let q_dstreal = Ata.State.make() in
+ (* attributes are always the first child *)
+ let t1 = ?< q_src><(TagSet.attribute,false)>=>
+ `Left *+ q_dst in
+ let t2 = ?< q_dst><(test, is_last && not(existential))>=>
+ if is_last then Ata.Formula.true_ else `Left *+ q_dstreal in
+ let tsa = ?< q_dst><(TagSet.star, false)>=> `Right *+ q_dst
+ in
+ add_trans num conf.tr t1;
+ add_trans num conf.tr_aux t2;
+ add_trans num conf.tr_aux tsa;
+ [q_dst;q_dstreal], q_dstreal,
+ ctx_path
+
+
+ | _ -> assert false
+ in
+ (* todo change everything to Ata.StateSet *)
+ (Ata.StateSet.elements (Ata.StateSet.union p_st (Ata.StateSet.from_list new_st)),
+ new_dst,
+ new_ctx)
+and is_rec = function
+ [] -> false
+ | ((axis,_,_),_)::_ ->
+ match axis with
+ Descendant | Ancestor -> true
+ | _ -> false
+
+and compile_path ?(existential=false) annot_path config q_src states idx ctx_path =
+ List.fold_left
+ (fun (a_st,a_dst,anc_st,par_st,pre_st,ctx_path,num,has_backward,a_isrec) (step,dir) ->
+ let add_states,new_dst,new_ctx =
+ compile_step ~existential:existential config a_dst dir ctx_path (is_rec a_isrec) step num
+ in
+ let new_states = Ata.StateSet.union (Ata.StateSet.from_list add_states) a_st in
+ let nanc_st,npar_st,npre_st,new_bw =
+ match step with
+ |PrecedingSibling,_,_ -> anc_st,par_st,Ata.StateSet.add a_dst pre_st,true
+ |(Parent|Ancestor|AncestorOrSelf),_,_ -> Ata.StateSet.add a_dst anc_st,par_st,pre_st,true
+ | _ -> anc_st,par_st,pre_st,has_backward