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 let comp_node t n1 n2 = (Naive_tree.preorder t n1) < (Naive_tree.preorder t n2)
 135
 136
 137 let rec union_list t l1 l2 =
 138   match l1,l2 with
 139     | [],l2 -> l2
 140     | l1, [] -> l1
 141     | h1::ll1, h2::ll2 -> if (comp_node t h2 h1) then h2 :: (union_list t l1 ll2)
 142       else if (comp_node t h1 h2) then h1::(union_list t ll1 l2)
 143       else h1 ::(union_list t ll1 ll2)
 144
 145 let rec inter_list t l1 l2 =
 146   match l1,l2 with
 147     | [],l2 -> []
 148     | l1, [] -> []
 149     | h1::ll1, h2::ll2 -> if (comp_node t h1 h2) then inter_list t ll1 l2
 150       else if (comp_node t h2 h1) then inter_list t l1 ll2
 151       else h1 :: (inter_list t ll1 ll2)
 152
 153 let rec diff_list t l1 l2 =
 154   match l1,l2 with
 155     | [],l2 -> []
 156     | l1, [] -> l1
 157     | h1::ll1, h2::ll2 -> if (comp_node t h1 h2) then h1::(diff_list t ll1 l2)
 158       else if (comp_node t h2 h1)  then h2 :: (diff_list t l1 ll2)
 159       else diff_list t ll1 ll2
 160
 161 let print_node_list tree l =
 162   List.iter (fun node ->
 163     Naive_tree.print_xml stdout tree node;
 164     print_newline()
 165   ) l
 166
 167 let rec print_query_tree fmt q =
 168   match q.desc with
 169       Dom -> Format.fprintf fmt "Dom"
 170     | Start -> Format.fprintf fmt "Start"
 171     | Tag (t,k) -> Format.fprintf fmt "Tag(%a, %a)" QNameSet.print t Tree.NodeKind.print k
 172     | Axis (a,q) ->
 173       Format.fprintf fmt "%a(%a)" Xpath.Ast.print_axis a print_query_tree q
 174     | Binop (op,q1,q2) ->
 175       Format.fprintf fmt "%a(%a, %a)"
 176       print_binop  op
 177       print_query_tree  q1
 178       print_query_tree  q2
 179
 180 and print_binop fmt o =
 181   match o with
 182     | Union -> Format.fprintf fmt "Union"
 183     | Inter -> Format.fprintf fmt "Inter"
 184     | Diff -> Format.fprintf fmt "Diff"
 185
 186 let rec eval_relation tree m n =
 187   match m with
 188       Self -> n
 189     | Firstchild ->  Naive_tree.first_child tree n
 190     | Nextsibling -> Naive_tree.next_sibling tree n
 191     | Revfirstchild -> Naive_tree.parent_of_first tree n
 192     | Prevsibling -> Naive_tree.prev_sibling tree n
 193
 194 (*28/01/2014
 195   parametres : tree  l'arbre xml
 196                ls    l'ensemble de noeuds
 197                m     move
 198   retour : l'ensemble de noeuds qui correspondent ॆ la relation r
 199 *)
 200
 201
 202
 203
 204 let rec eval_move tree ls m =
 205   match m with
 206       Self -> ls
 207     | r -> List.filter (fun n -> n != Naive_tree.nil)
 208            (List.map (eval_relation tree r) ls)
 209
 210
 211 (*28/01/2014
 212   parametres : tree  l'arbre xml
 213                ls    l'ensemble de noeuds
 214                m     move
 215   retour : l'ensemble de noeuds qui correspondent ॆ des relations lr
 216 *)
 217
 218 and eval_star tree ls lr =
 219   let h = Hashtbl.create 17 in
 220   let q = Queue.create () in
 221   List.iter ( fun e -> Queue.add e q ) ls;
 222   while not (Queue.is_empty q ) do
 223     let n = Queue.pop q in
 224     if not (Hashtbl.mem h n) then begin
 225       Hashtbl.add h n ();
 226       List.iter ( fun r -> let m = eval_relation tree r n in
 227                            if m != Naive_tree.nil && not (Hashtbl.mem h m ) then begin
 228
 229                              Queue.add m q; end
 230       ) lr
 231     end
 232   done;
 233   let l = Hashtbl.fold (fun k _ acc -> k::acc) h [] in
 234   l
 235  (*
 236  Tas.sort_of_list tree l
 237   List.sort (compare_node tree) l*)
 238
 239 let rec compare_node_list tree l1 l2 =
 240   match l1,l2 with
 241       [],[] -> 0
 242     | _,[] -> 1
 243     | [],_ -> -1
 244     | n1::ll1,n2::ll2 -> let b = compare_node tree n1 n2 in
 245                          if b=0 then compare_node_list tree ll1 ll2
 246                          else b
 247
 248 let get_descendant tree ln =
 249   let rec aux n acc =
 250     if n == Naive_tree.nil then  acc
 251     else let n1 = Naive_tree.first_child tree n in
 252          let acc1 = aux n1 (n::acc) in
 253          let n2 = Naive_tree.next_sibling tree n in
 254          let acc2 = aux n2 acc1 in
 255          acc2
 256   in
 257   let l = List.fold_left (fun acc n -> if List.mem n acc then acc
 258     else let n1 = Naive_tree.first_child tree n in
 259          aux n1 acc) [] ln
 260   in
 261   List.rev l
 262
 263 let get_child tree ln =
 264   let rec aux n acc =
 265     if n == Naive_tree.nil then acc
 266     else
 267       let n1 = Naive_tree.next_sibling tree n in
 268       aux n1 (n::acc)
 269   in
 270   let ll = List.map (fun  n->
 271     let n1 = Naive_tree.first_child tree n in
 272     let res = aux n1 [] in
 273     List.rev res
 274   )  ln in
 275   List.fold_left (fun acc l -> union_list tree acc l) [] ll
 276
 277
 278 let get_followingSibling tree ln =
 279   let rec aux n acc =
 280     let n1 = Naive_tree.next_sibling tree n in
 281     if n1 == Naive_tree.nil then acc
 282     else aux n1 (n1::acc)
 283   in
 284   let ll = List.map (fun n -> let res = aux n [] in
 285                               List.rev res ) ln in
 286   List.fold_left (fun acc l1 -> union_list tree acc l1) [] ll
 287
 288
 289 let rec get_firstBling tree n pred =
 290   if n== Naive_tree.nil then pred
 291   else get_firstBling tree (Naive_tree.prev_sibling tree n) n
 292
 293 let get_parent tree ln =
 294   let l = List.fold_left (fun acc n ->
 295     let n1 = get_firstBling tree n Naive_tree.nil in
 296     let n2 = Naive_tree.parent_of_first tree n1 in
 297     if n2 == Naive_tree.nil or List.mem n2 acc then acc
 298     else union_list tree [n2] acc
 299   ) [] ln
 300   in
 301   l
 302
 303
 304
 305 let get_ancestor tree ln =
 306   let rec aux tree l1 acc =
 307     match l1 with
 308         [] -> acc
 309       | _ -> let ll1 = get_parent tree l1 in
 310              let acc1 = union_list tree acc ll1 in
 311              aux tree ll1  acc1
 312   in
 313   let l = aux tree ln [] in
 314   l
 315
 316 let get_preSibling tree ln =
 317   let rec aux n acc =
 318     let n1 = Naive_tree.prev_sibling tree n in
 319     if n1 == Naive_tree.nil then acc
 320     else aux n1 (n1::acc)
 321   in
 322   let ll = List.map (fun n -> aux n [] ) ln in
 323   List.fold_left (fun acc l1 -> union_list tree acc l1) [] ll
 324
 325
 326
 327 let rec eval_axis tree ls a =
 328   let open Xpath.Ast in
 329         match a with
 330             Self -> ls
 331
 332           | Attribute -> get_child tree ls
 333
 334           | Child -> get_child tree ls
 335
 336           | Descendant c -> let ls2 = get_descendant tree ls in
 337                             let ldes =
 338                               if not c then ls2
 339                               else union_list tree ls2 ls
 340                             in
 341                             ldes
 342
 343           | FollowingSibling -> get_followingSibling tree ls
 344
 345           | Parent -> get_parent tree ls
 346
 347           | Ancestor b ->
 348                           let ls3 = get_ancestor tree ls in
 349                           let lac =
 350                           if not b then ls3
 351                           else union_list tree ls3 ls
 352                           in
 353                           lac
 354
 355           | PrecedingSibling -> get_preSibling tree ls
 356
 357           | Preceding -> let ls2 = eval_axis tree ls (Ancestor true) in
 358                          let ls3 = eval_axis tree ls2 PrecedingSibling in
 359                          let lp = eval_axis tree ls3 (Descendant true) in
 360                          lp
 361
 362           | Following -> let ls2 = eval_axis tree ls (Ancestor true) in
 363                          let ls3 = eval_axis tree ls2 FollowingSibling in
 364                          let lf = eval_axis tree ls3 (Descendant true) in
 365                          lf
 366
 367
 368
 369
 370
 371
 372