type move = Self
	    | Firstchild
	    | Nextsibling
	    | Revfirstchild
	    | Prevsibling

type query_tree_desc = Binop of op * query_tree * query_tree
		       | Axis of Xpath.Ast.axis * query_tree
		       | Start 
		       | Dom
		       | Tag of QNameSet.t * Tree.NodeKind.t

and op = Union | Inter | Diff

and query_tree = {
  mutable desc  : query_tree_desc;
  mutable id : int;
  mutable hash : int;
}


module QTree = struct
  type t = query_tree
  let rec equal q1 q2 =
    q1 == q2 ||
      (q1.id == q2.id && q1.id != -1) ||
      match q1.desc, q2.desc with
	| Binop(op1,qt1,qt2),Binop(op2,qt3,qt4)-> op1==op2&& (equal qt1 qt3 && equal qt2 qt4) 
							   
	| Axis(a1,qt1),Axis(a2,qt2) -> compare_axis a1 a2 && equal qt1 qt2
	| Tag(t1,k1),Tag(t2,k2) -> t1==t2&& k1==k2
	| Dom,Dom | Start,Start -> true
	| _,_ ->false
  and compare_axis a1 a2 =
    match a1,a2 with
	Self ,Self | Attribute, Attribute | Child , Child | Parent , Parent
      | FollowingSibling , FollowingSibling 	   
      | PrecedingSibling , PrecedingSibling
      | Preceding , Preceding | Following , Following -> true
      | Descendant b1, Descendant b2 -> b1==b2 
      | Ancestor b1, Ancestor b2 -> b1==b2
      | _,_ -> false

  let rec hash q = 
    if q.hash != -1 then q.hash
    else match q.desc with
	Dom -> 1
      | Start -> 3
      | Tag(s,_) -> 5 + 17*QNameSet.hash s
      | Axis(a,q) -> 7 + 17 * Hashtbl.hash a + 23* hash q
      | Binop(op,q1,q2) -> 11 + 17* Hashtbl.hash op + 23* hash q1 + 27* hash q2

end


module QTreeHash = Hashtbl.Make(QTree)



(*28/01/2014  
  parametres : tree  l'arbre xml
               n     un noeud
               m     move   
  retour :un noeud qui correspond ॆ la relation r
*)

let print_node_list tree l =
  List.iter (fun node ->
    Naive_tree.print_xml stdout tree node;
    print_newline() 
  ) l

let rec print_query_tree fmt q =
  match q.desc with
      Dom -> Format.fprintf fmt "Dom"
    | Start -> Format.fprintf fmt "Start"
    | Tag (t,k) -> Format.fprintf fmt "Tag(%a, %a)" QNameSet.print t Tree.NodeKind.print k
    | Axis (a,q) ->
      Format.fprintf fmt "%a(%a)" Xpath.Ast.print_axis a print_query_tree q
    | Binop (op,q1,q2) -> 
      Format.fprintf fmt "%a(%a, %a)"
      print_binop  op
      print_query_tree  q1 
      print_query_tree  q2 
 
and print_binop fmt o =
  match o with
    | Union -> Format.fprintf fmt "Union"
    | Inter -> Format.fprintf fmt "Inter"
    | Diff -> Format.fprintf fmt "Diff"

let rec eval_relation tree m n =
  match m with
      Self -> n
    | Firstchild ->  Naive_tree.first_child tree n
    | Nextsibling -> Naive_tree.next_sibling tree n
    | Revfirstchild -> Naive_tree.parent_of_first tree n
    | Prevsibling -> Naive_tree.prev_sibling tree n

(*28/01/2014  
  parametres : tree  l'arbre xml
               ls    l'ensemble de noeuds
               m     move   
  retour : l'ensemble de noeuds qui correspondent ॆ la relation r
*)


let compare_node tree a b =
  compare (Naive_tree.preorder tree a ) (Naive_tree.preorder tree b ) 

let rec eval_move tree ls m =
  match m with
      Self -> ls
    | r -> List.filter (fun n -> n != Naive_tree.nil)
           (List.map (eval_relation tree r) ls) 
	   

(*28/01/2014  
  parametres : tree  l'arbre xml
               ls    l'ensemble de noeuds
               m     move   
  retour : l'ensemble de noeuds qui correspondent ॆ des relations lr
*)

and eval_star tree ls lr =
  let h = Hashtbl.create 17 in
  let q = Queue.create () in
  List.iter ( fun e -> Queue.add e q ) ls;
  while not (Queue.is_empty q ) do
    let n = Queue.pop q in
    if not (Hashtbl.mem h n) then begin
      Hashtbl.add h n ();
      List.iter ( fun r -> let m = eval_relation tree r n in
			   if m != Naive_tree.nil && not (Hashtbl.mem h m ) then begin
			     
			     Queue.add m q; end
      ) lr
    end
  done;
  let l = Hashtbl.fold (fun k _ acc -> k::acc) h [] in
  List.sort (compare_node tree) l
    
(*28/01/2014  
  parametres : tree  l'arbre xml
               ls    l'ensemble de noeuds
               a     axis   
  retour : l'ensemble de noeuds qui correspondent ॆ l'axe
*)

let keep_elements t l = (*
   List.filter (fun n -> match Naive_tree.kind t n with
     | Element | Text | Document | Attribute -> true | _ -> false) l
			*) l

let keep_attributs t l = (*
  List.filter (fun n -> match Naive_tree.kind t n with
    | Attribute ->true | _ -> false) *) l

let rec eval_axis tree ls a =
  let open Xpath.Ast in
	match a with
	    Self -> ls
	      
	  | Attribute -> let lfc = eval_move tree ls Firstchild in
			 let lc = eval_star tree lfc [Nextsibling] in
			 keep_attributs tree lc
	    
	  | Child -> let lfc = eval_move tree ls Firstchild in
		     let lc = eval_star tree lfc [Nextsibling] in
		     keep_elements tree lc
		       
	  | Descendant c -> let lfc = eval_move tree ls Firstchild in		     
			    let ls2 = eval_star tree lfc [Firstchild;Nextsibling] in
			    let ldes =
			    if not c then ls2
			    else List.merge (compare_node tree) ls2 ls
			    in
			    keep_elements tree ldes
			      
	  | FollowingSibling -> let lnexts = eval_move tree ls Nextsibling in
				let lfs = eval_star tree lnexts [Nextsibling] in
				keep_elements tree lfs
				  
	  | Parent -> let lprevs = eval_star tree ls [Prevsibling] in
		      let lp = eval_move tree lprevs Revfirstchild in
		      keep_elements tree lp
			
	  | Ancestor b -> let ls2 = eval_star tree ls [Revfirstchild;Prevsibling] in
			  let ls3 = eval_move tree ls2 Revfirstchild in
			  let lac =
			  if not b then ls3
			  else List.merge (compare_node tree ) ls3 ls
			  in
			  keep_elements tree lac
			    
	  | PrecedingSibling -> let ls2 = eval_star tree ls [Prevsibling] in
				let lps = eval_move tree ls2 Prevsibling in
				keep_elements tree lps
				  
	  | Preceding -> let ls2 = eval_axis tree ls (Ancestor true) in
			 let ls3 = eval_axis tree ls2 PrecedingSibling in
			 let lp = eval_axis tree ls3 (Descendant true) in
			 keep_elements tree lp
			 
	  | Following -> let ls2 = eval_axis tree ls (Ancestor true) in
			 let ls3 = eval_axis tree ls2 FollowingSibling in
			 let lf = eval_axis tree ls3 (Descendant true) in
			 keep_elements tree lf