- let tself = (s ==> ts @@ (q',d2)) in
- (Transition.cap t' tself)::acc ) (acc) l
-
- let from_list = List.fold_left (fun acc e -> SSet.add e acc) SSet.empty
-
- let dir = function (FollowingSibling,_,_) -> Right
- | _ -> Left
-
- let rev_map_dir p =
- let rec map_dir (d,acc) = function
- | [] -> acc
- | s::r -> map_dir ((dir s),(s,d)::acc) r
- in let l = match p with
- | Absolute p | Relative p -> map_dir (Final,[]) p
- | AbsoluteDoS p ->
- let l = (map_dir (Final,[]) p)
- in ((DescendantOrSelf,TagSet.Xml.node,Expr True),dir (fst(List.hd l)))::l
- in ((Child,TagSet.Xml.node,Expr True),dir (fst(List.hd l)))::l
-
-
- let rec compile_step q dir trs final initial ignore (axis,test,pred) =
- let q' = State.mk() in
- let trs,final,initial = match axis,test with
- | Self,ts ->
- let tchange,tkeep = split_dest q trs in
- let trs' = mk_self_trs ts tkeep tchange in
- (trs',q::final,initial)
-
- | Child,ts ->
- (mk_tag_t dir q ts q' ignore) ::( q==> any @@ (ignore,q))::trs, q'::final,initial
-
- | Descendant,ts ->
- (mk_tag_t dir q ts q' ignore) ::
- (q==> star @@ (q,q))::(q==> notstar @@ (ignore,q))::trs,q'::final,initial
-
- | DescendantOrSelf,ts ->
- let tchange,tkeep = split_dest q trs in
- let trs' = mk_dself_trs q' ts trs tchange in
- (mk_tag_t dir q ts q' ignore) ::
- (q==> star @@ (q,q))::(q==> notstar @@ (ignore,q))::trs',q'::final,initial
-
- | FollowingSibling,ts ->
- (mk_tag_t dir q ts q' ignore) :: (q ==> any @@ (ignore,q))::trs,q'::final,initial
-
- (* q' is not returned and thus not added to the set of final states.
- It's ok since we should never be in a final state on a node
- <@> *)
-
- | Attribute,ts -> let q'' = State.mk() in
- (mk_tag_t Left q (TagSet.Xml.attribute) q' ignore)::
- (mk_tag_t Left q' (ts) q'' ignore)::( q==> any @@ (ignore,q))::trs, q''::q'::final,initial
-
- | Parent,ts -> let q'' = List.hd initial in
- (mk_tag_t Left q' (star) q q')::
- ( q'' ==> ts @@ (q',q''))::
- ( q'' ==> star @@ (q'',q''))::
- ( q'' ==> notstar @@ (ignore,q''))::trs,q'::q''::final,q''::initial
-
- in
- let q_out = List.hd final in
- let tchange,tkeep = split_dest q_out trs in
- let trs' = compile_pred q_out tkeep tchange pred in
- (trs',final,initial)
-
- and compile_pred q_out tkeep tchange p =
- let rec pred_rec = function
-
- | Or(p1,p2) -> cup (pred_rec p1) (pred_rec p2)
- | And(p1,p2) -> cap (pred_rec p1) (pred_rec p2)
- | Not(p) -> neg (pred_rec p)
- | Expr e -> match compile_expr e with
- | `True -> `Label (TagSet.Xml.any)
- | `False -> `Label (TagSet.Xml.empty)
- | e -> `Fun (fun t -> Functions.truth_value (Functions.eval_expr t e))
-
- in match pred_rec p with
- `Fun f -> mk_pred_trs f tkeep tchange
- | `Label ts -> mk_self_trs ts tkeep tchange
-
- and compile_expr = function
- True -> `True
- | False -> `False
- | Path p -> `Auto(compile p)
- | Int i -> `Int i
- | String s -> `String s
- | Function ("contains",elist) ->`Contains(List.map compile_expr elist)
- | Function (f,elist) -> `Call(f,List.map compile_expr elist)
-
- and cup a b = match a,b with
- | `Label l1 , `Label l2 -> `Label(TagSet.Xml.cup l1 l2)
- | `Fun f1 , `Fun f2 -> `Fun (fun x -> (f1 x)||(f2 x))
- | `Fun f , `Label l | `Label l, `Fun f ->
- `Fun (fun x ->
- (TagSet.Xml.mem (Tree.Binary.tag x) l)
- || (f x))
-
- and cap a b = match a,b with
- | `Label l1, `Label l2 -> `Label (TagSet.Xml.cap l1 l2)
- | `Fun f1,`Fun f2 -> `Fun (fun x -> (f1 x)&&(f2 x))
- | `Fun f,`Label l | `Label l,`Fun f ->
- `Fun (fun x ->
- (TagSet.Xml.mem (Tree.Binary.tag x) l)
- && f x)
- and neg = function
- `Label l -> `Label(TagSet.Xml.neg l)
- | `Fun f -> `Fun (fun x -> not (f x))
-
- and compile p =
- let p = rev_map_dir p in
- let ignore = State.mk()
- in
- let q0 = State.mk() in
- let transitions = Transition.empty () in
- let tlist,qlist,initacc = List.fold_left
- (fun (tlist,qlist,initacc) (s,dir) ->
- let q = List.hd qlist in
- compile_step q dir tlist qlist initacc ignore s ) ([],[q0;ignore],[q0]) p
- in
- List.iter (Transition.add transitions) tlist;
- let qmark = List.hd qlist in
- { Automaton.mk() with
- initial = from_list initacc;
- final = from_list qlist;
- transitions = transitions;
- marking = from_list [qmark];
- ignore = from_list [qmark;ignore];
- }
+ 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
+ in
+ new_states,new_dst,nanc_st,npar_st,npre_st,new_ctx, num+1,new_bw,(match a_isrec with [] -> [] | _::r -> r)
+ )
+ (states, q_src, Ata.StateSet.empty,Ata.StateSet.empty,Ata.StateSet.empty, ctx_path,idx, false,(List.tl annot_path) )
+ annot_path
+
+and binop_ conf q_src idx ctx_path dir pred p1 p2 f ddst =
+ let a_st1,anc_st1,par_st1,pre_st1,idx1,f1 =
+ compile_pred conf q_src idx ctx_path dir p1 ddst in
+ let a_st2,anc_st2,par_st2,pre_st2,idx2,f2 =
+ compile_pred conf q_src idx1 ctx_path dir p2 ddst
+ in
+ Ata.StateSet.union a_st1 a_st2,
+ Ata.StateSet.union anc_st1 anc_st2,
+ Ata.StateSet.union par_st1 par_st2,
+ Ata.StateSet.union pre_st1 pre_st2,
+ idx2, (f f1 f2)
+
+and compile_pred conf q_src idx ctx_path dir pred qdst =
+ match pred with
+ | Or(p1,p2) ->
+ binop_ conf q_src idx ctx_path dir pred p1 p2 (( +| )) qdst
+ | And(p1,p2) ->
+ binop_ conf q_src idx ctx_path dir pred p1 p2 (( *& )) qdst
+ | Expr e -> compile_expr conf Ata.StateSet.empty q_src idx ctx_path dir e qdst
+ | Not(p) ->
+ let a_st,anc_st,par_st,pre_st,idx,f =
+ compile_pred conf q_src idx ctx_path dir p qdst
+ in a_st,anc_st,par_st,pre_st,idx, Ata.Formula.not_ f
+
+and compile_expr conf states q_src idx ctx_path dir e qdst =
+ match e with
+ | Path (p) ->
+ let q = Ata.State.make () in
+ let annot_path = match p with Relative(r) -> dirannot (List.rev r) | _ -> assert false in
+ let a_st,a_dst,anc_st,par_st,pre_st,_,idx,has_backward,_ =
+ compile_path ~existential:true annot_path conf q states idx ctx_path
+ in
+ let ret_dir = match annot_path with
+ | ((FollowingSibling,_,_),_)::_ -> `Right
+ | _ -> `Left
+ in
+ let _ = match annot_path with
+ | (((Parent|Ancestor|AncestorOrSelf),_,_),_)::_ -> conf.final_state <- Ata.StateSet.add qdst conf.final_state
+ | _ -> ()
+ in let _ = conf.univ_states <- a_dst::conf.univ_states in
+ (a_st,anc_st,par_st,pre_st,idx, ((ret_dir) *+ q))
+ | True -> states,Ata.StateSet.empty,Ata.StateSet.empty,Ata.StateSet.empty,idx,Ata.Formula.true_
+ | False -> states,Ata.StateSet.empty,Ata.StateSet.empty,Ata.StateSet.empty,idx,Ata.Formula.false_
+ | _ -> assert false
+
+
+and dirannot = function
+ [] -> []
+ | [p] -> [p,`Last]
+ | p::(((FollowingSibling),_,_)::_ as l) -> (p,`Right)::(dirannot l)
+ | p::l -> (p,`Left) :: (dirannot l)
+
+let compile ?(querystring="") path =
+ let steps =
+ match path with
+ | Absolute(steps)
+ | Relative(steps) -> steps
+ | AbsoluteDoS(steps) -> steps@[(DescendantOrSelf,TagSet.node,Expr(True))]
+ in
+ let steps = List.rev steps in
+ let dirsteps = dirannot steps in
+ let config = { st_root = Ata.State.make();
+ st_univ = Ata.State.make();
+ final_state = Ata.StateSet.empty;
+ st_from_root = Ata.State.make();
+ has_backward = false;
+ tr_parent_loop = Hashtbl.create 5;
+ tr = Hashtbl.create 5;
+ tr_aux = Hashtbl.create 5;
+ entry_points = [];
+ contains = None;
+ univ_states = [];
+ starstate = None;
+ }
+ in
+ let q0 = Ata.State.make() in
+ let states = Ata.StateSet.from_list [config.st_univ;config.st_root]
+ in
+ let num = 0 in
+ (* add_trans num config.tr_aux (mk_star config.st_from_root `Left config.st_univ config.st_from_root);
+ add_trans num config.tr_aux (mk_star config.st_from_root `Left config.st_from_root config.st_univ);
+ add_trans num config.tr_aux (mk_step config.st_no_nil (TagSet.add Tag.pcdata TagSet.star) `Left config.st_univ config.st_univ);
+ *)
+ let a_st,a_dst,anc_st,par_st,pre_st,_,_,has_backward,_ =
+ compile_path dirsteps config q0 states 0 [(config.st_root,[]) ]
+ in
+ let fst_tr =
+ ?< (config.st_root) >< (TagSet.singleton (Tag.tag ""),false) >=>
+ ((if is_rec dirsteps then `LLeft else `Left)*+ q0) *& (if config.has_backward then `LLeft *+ config.st_from_root else Ata.Formula.true_)
+ in
+ add_trans num config.tr fst_tr;
+ if config.has_backward then begin
+ add_trans num config.tr_aux
+ (?< (config.st_from_root) >< (TagSet.star,false) >=> `LLeft *+ config.st_from_root);
+ add_trans num config.tr_aux
+ (?< (config.st_from_root) >< (TagSet.any,false) >=>
+ `RRight *+ config.st_from_root);
+
+ end;
+ let phi = Hashtbl.create 37 in
+ let fadd = fun _ (_,l) -> List.iter (fun (s,t,tr) ->
+ let lt = try
+ Hashtbl.find phi s
+ with Not_found -> []
+ in
+ Hashtbl.replace phi s ((t,tr)::lt)
+ ) l in
+ Hashtbl.iter (fadd) config.tr;
+ Hashtbl.iter (fadd) config.tr_aux;
+ Hashtbl.iter (fadd) config.tr_parent_loop;
+ let final =
+ let s = anc_st
+ in if has_backward then Ata.StateSet.add config.st_from_root s else s
+ in { Ata.id = Oo.id (object end);
+ Ata.states = Hashtbl.fold (fun q _ acc -> Ata.StateSet.add q acc) phi Ata.StateSet.empty;
+ Ata.init = Ata.StateSet.singleton config.st_root;
+ Ata.trans = phi;
+ Ata.starstate = config.starstate;
+ Ata.query_string = querystring;
+ },config.entry_points,!contains
+
+