src/table.ml

   1
   2 type move = Self
   3             | Firstchild
   4             | Nextsibling
   5             | Revfirstchild
   6             | Prevsibling
   7
   8 type query_tree_desc = Binop of op * query_tree * query_tree
   9                        | Axis of Xpath.Ast.axis * query_tree
  10                        | Start
  11                        | Dom
  12                        | Tag of QNameSet.t * Tree.NodeKind.t
  13
  14 and op = Union | Inter | Diff
  15
  16 and query_tree = {
  17   mutable desc  : query_tree_desc;
  18   mutable id : int;
  19   mutable hash : int;
  20 }
  21
  22
  23 module QTree = struct
  24   type t = query_tree
  25   let rec equal q1 q2 =
  26     q1 == q2 ||
  27       (q1.id == q2.id && q1.id != -1) ||
  28       match q1.desc, q2.desc with
  29         | Binop(op1,qt1,qt2),Binop(op2,qt3,qt4)-> op1==op2&& (equal qt1 qt3 && equal qt2 qt4)
  30
  31         | Axis(a1,qt1),Axis(a2,qt2) -> compare_axis a1 a2 && equal qt1 qt2
  32         | Tag(t1,k1),Tag(t2,k2) -> t1==t2&& k1==k2
  33         | Dom,Dom | Start,Start -> true
  34         | _,_ ->false
  35   and compare_axis a1 a2 =
  36     match a1,a2 with
  37         Self ,Self | Attribute, Attribute | Child , Child | Parent , Parent
  38       | FollowingSibling , FollowingSibling
  39       | PrecedingSibling , PrecedingSibling
  40       | Preceding , Preceding | Following , Following -> true
  41       | Descendant b1, Descendant b2 -> b1==b2
  42       | Ancestor b1, Ancestor b2 -> b1==b2
  43       | _,_ -> false
  44
  45   let rec hash q =
  46     if q.hash != -1 then q.hash
  47     else match q.desc with
  48         Dom -> 1
  49       | Start -> 3
  50       | Tag(s,_) -> 5 + 17*QNameSet.hash s
  51       | Axis(a,q) -> 7 + 17 * Hashtbl.hash a + 23* hash q
  52       | Binop(op,q1,q2) -> 11 + 17* Hashtbl.hash op + 23* hash q1 + 27* hash q2
  53
  54 end
  55
  56
  57 module QTreeHash = Hashtbl.Make(QTree)
  58
  59 let compare_node tree a b =
  60   compare (Naive_tree.preorder tree a ) (Naive_tree.preorder tree b )
  61
  62 module Tas = struct
  63 type 'a tas =
  64   | Vide
  65   | Noeud of 'a tas * 'a * 'a tas
  66
  67 let comp_node tree a b = (Naive_tree.preorder tree a )< (Naive_tree.preorder tree b )
  68
  69 let rec size t =
  70   match t with
  71       Vide -> 0
  72     | Noeud (t1,racine,t2) -> 1+ size t1 + size t2
  73
  74 let rec height t =
  75   match t with
  76       Vide -> 0
  77     | Noeud (t1,racine,t2) -> 1 + max (height t1) (height t2)
  78
  79 let equilibre t =
  80   let rec aux t =
  81     match t with
  82         Vide -> 0
  83       | Noeud (t1,racine,t2) -> 1 + min (aux t1) (aux t2)
  84   in
  85   let max_h = height t in
  86   let min_h = aux t in
  87   if max_h- min_h >1 then false
  88   else true
  89
  90 let  is_tas t =
  91   if not (equilibre t) then false
  92   else
  93     let rec aux n t =
  94       match t with
  95           Vide -> true
  96         | Noeud (Vide,racine,Vide)  -> racine >= n
  97         | Noeud (t1,racine, t2) -> (aux racine t1) && (aux racine t2)
  98     in
  99     aux 0 t
 100
 101 let rec pop tree t =
 102   match t with
 103       Vide -> failwith "Tas vide"
 104     | Noeud (t1, racine, t2) ->  begin
 105       match t1,t2 with
 106           Vide,t2 -> t2
 107         | t1,Vide -> t1
 108         | Noeud (t3,r1,t4),Noeud (t5,r2,t6) -> if comp_node tree r1 r2 then Noeud (pop tree t1, r1,t2)
 109           else Noeud (pop tree t2, r2, t1)
 110     end
 111
 112 let rec push tree t a =
 113   match t with
 114       Vide -> Noeud(Vide,a,Vide)
 115     | Noeud (t1,r,t2) ->  if comp_node tree a r then Noeud (t2,a,push tree t1 r)
 116       else Noeud(t2,r, push tree t1 a)
 117
 118 let tas_of_list tree l =
 119   List.fold_left (push tree) Vide l
 120
 121 let is_empty t = (size t )== 0
 122
 123 let rec list_of_tas tree t =
 124   match t with
 125       Vide -> []
 126     | Noeud(t1,r,t2) -> r::(list_of_tas tree  (pop tree t))
 127
 128 let sort_of_list tree l =
 129   let t = tas_of_list tree l in
 130   list_of_tas tree t
 131
 132 end
 133
 134 (*28/01/2014
 135   parametres : tree  l'arbre xml
 136                n     un noeud
 137                m     move
 138   retour :un noeud qui correspond ॆ la relation r
 139 *)
 140
 141 let print_node_list tree l =
 142   List.iter (fun node ->
 143     Naive_tree.print_xml stdout tree node;
 144     print_newline()
 145   ) l
 146
 147 let rec print_query_tree fmt q =
 148   match q.desc with
 149       Dom -> Format.fprintf fmt "Dom"
 150     | Start -> Format.fprintf fmt "Start"
 151     | Tag (t,k) -> Format.fprintf fmt "Tag(%a, %a)" QNameSet.print t Tree.NodeKind.print k
 152     | Axis (a,q) ->
 153       Format.fprintf fmt "%a(%a)" Xpath.Ast.print_axis a print_query_tree q
 154     | Binop (op,q1,q2) ->
 155       Format.fprintf fmt "%a(%a, %a)"
 156       print_binop  op
 157       print_query_tree  q1
 158       print_query_tree  q2
 159
 160 and print_binop fmt o =
 161   match o with
 162     | Union -> Format.fprintf fmt "Union"
 163     | Inter -> Format.fprintf fmt "Inter"
 164     | Diff -> Format.fprintf fmt "Diff"
 165
 166 let rec eval_relation tree m n =
 167   match m with
 168       Self -> n
 169     | Firstchild ->  Naive_tree.first_child tree n
 170     | Nextsibling -> Naive_tree.next_sibling tree n
 171     | Revfirstchild -> Naive_tree.parent_of_first tree n
 172     | Prevsibling -> Naive_tree.prev_sibling tree n
 173
 174 (*28/01/2014
 175   parametres : tree  l'arbre xml
 176                ls    l'ensemble de noeuds
 177                m     move
 178   retour : l'ensemble de noeuds qui correspondent ॆ la relation r
 179 *)
 180
 181
 182
 183
 184 let rec eval_move tree ls m =
 185   match m with
 186       Self -> ls
 187     | r -> List.filter (fun n -> n != Naive_tree.nil)
 188            (List.map (eval_relation tree r) ls)
 189
 190
 191 (*28/01/2014
 192   parametres : tree  l'arbre xml
 193                ls    l'ensemble de noeuds
 194                m     move
 195   retour : l'ensemble de noeuds qui correspondent ॆ des relations lr
 196 *)
 197
 198 and eval_star tree ls lr =
 199   let h = Hashtbl.create 17 in
 200   let q = Queue.create () in
 201   List.iter ( fun e -> Queue.add e q ) ls;
 202   while not (Queue.is_empty q ) do
 203     let n = Queue.pop q in
 204     if not (Hashtbl.mem h n) then begin
 205       Hashtbl.add h n ();
 206       List.iter ( fun r -> let m = eval_relation tree r n in
 207                            if m != Naive_tree.nil && not (Hashtbl.mem h m ) then begin
 208
 209                              Queue.add m q; end
 210       ) lr
 211     end
 212   done;
 213   let l = Hashtbl.fold (fun k _ acc -> k::acc) h [] in
 214   Tas.sort_of_list tree l
 215
 216 (*28/01/2014
 217   parametres : tree  l'arbre xml
 218                ls    l'ensemble de noeuds
 219                a     axis
 220   retour : l'ensemble de noeuds qui correspondent ॆ l'axe
 221 *)
 222
 223 let keep_elements t l = (*
 224    List.filter (fun n -> match Naive_tree.kind t n with
 225      | Element | Text | Document | Attribute -> true | _ -> false) l
 226                         *) l
 227
 228 let keep_attributs t l = (*
 229   List.filter (fun n -> match Naive_tree.kind t n with
 230     | Attribute ->true | _ -> false) *) l
 231
 232 let rec eval_axis tree ls a =
 233   let open Xpath.Ast in
 234         match a with
 235             Self -> ls
 236
 237           | Attribute -> let lfc = eval_move tree ls Firstchild in
 238                          let lc = eval_star tree lfc [Nextsibling] in
 239                          keep_attributs tree lc
 240
 241           | Child -> let lfc = eval_move tree ls Firstchild in
 242                      let lc = eval_star tree lfc [Nextsibling] in
 243                      keep_elements tree lc
 244
 245           | Descendant c -> let lfc = eval_move tree ls Firstchild in
 246                             let ls2 = eval_star tree lfc [Firstchild;Nextsibling] in
 247                             let ldes =
 248                             if not c then ls2
 249                             else List.merge (compare_node tree) ls2 ls
 250                             in
 251                             keep_elements tree ldes
 252
 253           | FollowingSibling -> let lnexts = eval_move tree ls Nextsibling in
 254                                 let lfs = eval_star tree lnexts [Nextsibling] in
 255                                 keep_elements tree lfs
 256
 257           | Parent -> let lprevs = eval_star tree ls [Prevsibling] in
 258                       let lp = eval_move tree lprevs Revfirstchild in
 259                       keep_elements tree lp
 260
 261           | Ancestor b -> let ls2 = eval_star tree ls [Revfirstchild;Prevsibling] in
 262                           let ls3 = eval_move tree ls2 Revfirstchild in
 263                           let lac =
 264                           if not b then ls3
 265                           else List.merge (compare_node tree ) ls3 ls
 266                           in
 267                           keep_elements tree lac
 268
 269           | PrecedingSibling -> let ls2 = eval_star tree ls [Prevsibling] in
 270                                 let lps = eval_move tree ls2 Prevsibling in
 271                                 keep_elements tree lps
 272
 273           | Preceding -> let ls2 = eval_axis tree ls (Ancestor true) in
 274                          let ls3 = eval_axis tree ls2 PrecedingSibling in
 275                          let lp = eval_axis tree ls3 (Descendant true) in
 276                          keep_elements tree lp
 277
 278           | Following -> let ls2 = eval_axis tree ls (Ancestor true) in
 279                          let ls3 = eval_axis tree ls2 FollowingSibling in
 280                          let lf = eval_axis tree ls3 (Descendant true) in
 281                          keep_elements tree lf
 282
 283
 284
 285
 286
 287
 288
 289
 290