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 let comp_node t n1 n2 = (Naive_tree.preorder t n1) < (Naive_tree.preorder t n2)
  63
  64
  65 let rec union_list t l1 l2 =
  66   match l1,l2 with
  67     | [],l2 -> l2
  68     | l1, [] -> l1
  69     | h1::ll1, h2::ll2 -> if (comp_node t h2 h1) then h2 :: (union_list t l1 ll2)
  70       else if (comp_node t h1 h2) then h1::(union_list t ll1 l2)
  71       else h1 ::(union_list t ll1 ll2)
  72
  73 let rec inter_list t l1 l2 =
  74   match l1,l2 with
  75     | [],l2 -> []
  76     | l1, [] -> []
  77     | h1::ll1, h2::ll2 -> if (comp_node t h1 h2) then inter_list t ll1 l2
  78       else if (comp_node t h2 h1) then inter_list t l1 ll2
  79       else h1 :: (inter_list t ll1 ll2)
  80
  81 let rec diff_list t l1 l2 =
  82   match l1,l2 with
  83     | [],l2 -> []
  84     | l1, [] -> l1
  85     | h1::ll1, h2::ll2 -> if (comp_node t h1 h2) then h1::(diff_list t ll1 l2)
  86       else if (comp_node t h2 h1)  then h2 :: (diff_list t l1 ll2)
  87       else diff_list t ll1 ll2
  88
  89 let print_node_list tree l =
  90   List.iter (fun node ->
  91     Naive_tree.print_xml stdout tree node;
  92     print_newline()
  93   ) l
  94
  95 let rec print_query_tree fmt q =
  96   match q.desc with
  97       Dom -> Format.fprintf fmt "Dom"
  98     | Start -> Format.fprintf fmt "Start"
  99     | Tag (t,k) -> Format.fprintf fmt "Tag(%a, %a)" QNameSet.print t Tree.NodeKind.print k
 100     | Axis (a,q) ->
 101       Format.fprintf fmt "%a(%a)" Xpath.Ast.print_axis a print_query_tree q
 102     | Binop (op,q1,q2) ->
 103       Format.fprintf fmt "%a(%a, %a)"
 104       print_binop  op
 105       print_query_tree  q1
 106       print_query_tree  q2
 107
 108 and print_binop fmt o =
 109   match o with
 110     | Union -> Format.fprintf fmt "Union"
 111     | Inter -> Format.fprintf fmt "Inter"
 112     | Diff -> Format.fprintf fmt "Diff"
 113
 114 let rec eval_relation tree m n =
 115   match m with
 116       Self -> n
 117     | Firstchild ->  Naive_tree.first_child tree n
 118     | Nextsibling -> Naive_tree.next_sibling tree n
 119     | Revfirstchild -> Naive_tree.parent_of_first tree n
 120     | Prevsibling -> Naive_tree.prev_sibling tree n
 121
 122 (*28/01/2014
 123   parametres : tree  l'arbre xml
 124                ls    l'ensemble de noeuds
 125                m     move
 126   retour : l'ensemble de noeuds qui correspondent ॆ la relation r
 127 *)
 128
 129
 130
 131
 132 let rec eval_move tree ls m =
 133   match m with
 134       Self -> ls
 135     | r -> List.filter (fun n -> n != Naive_tree.nil)
 136            (List.map (eval_relation tree r) ls)
 137
 138
 139 (*28/01/2014
 140   parametres : tree  l'arbre xml
 141                ls    l'ensemble de noeuds
 142                m     move
 143   retour : l'ensemble de noeuds qui correspondent ॆ des relations lr
 144 *)
 145
 146 and eval_star tree ls lr =
 147   let h = Hashtbl.create 17 in
 148   let q = Queue.create () in
 149   List.iter ( fun e -> Queue.add e q ) ls;
 150   while not (Queue.is_empty q ) do
 151     let n = Queue.pop q in
 152     if not (Hashtbl.mem h n) then begin
 153       Hashtbl.add h n ();
 154       List.iter ( fun r -> let m = eval_relation tree r n in
 155                            if m != Naive_tree.nil && not (Hashtbl.mem h m ) then begin
 156
 157                              Queue.add m q; end
 158       ) lr
 159     end
 160   done;
 161   let l = Hashtbl.fold (fun k _ acc -> k::acc) h [] in
 162   l
 163  (*
 164  Tas.sort_of_list tree l
 165   List.sort (compare_node tree) l*)
 166
 167 let rec compare_node_list tree l1 l2 =
 168   match l1,l2 with
 169       [],[] -> 0
 170     | _,[] -> 1
 171     | [],_ -> -1
 172     | n1::ll1,n2::ll2 -> let b = compare_node tree n1 n2 in
 173                          if b=0 then compare_node_list tree ll1 ll2
 174                          else b
 175
 176 let get_descendant tree ln =
 177   let rec aux n acc =
 178     if n == Naive_tree.nil then  acc
 179     else let n1 = Naive_tree.first_child tree n in
 180          let acc1 = aux n1 (n::acc) in
 181          let n2 = Naive_tree.next_sibling tree n in
 182          let acc2 = aux n2 acc1 in
 183          acc2
 184   in
 185   let l = List.fold_left (fun acc n -> if List.mem n acc then acc
 186     else let n1 = Naive_tree.first_child tree n in
 187          aux n1 acc) [] ln
 188   in
 189   List.rev l
 190
 191 let get_child tree ln =
 192   let rec aux n acc =
 193     if n == Naive_tree.nil then acc
 194     else
 195       let n1 = Naive_tree.next_sibling tree n in
 196       aux n1 (n::acc)
 197   in
 198   let ll = List.map (fun  n->
 199     let n1 = Naive_tree.first_child tree n in
 200     let res = aux n1 [] in
 201     List.rev res
 202   )  ln in
 203   List.fold_left (fun acc l -> union_list tree acc l) [] ll
 204
 205
 206 let get_followingSibling tree ln =
 207   let rec aux n acc =
 208     let n1 = Naive_tree.next_sibling tree n in
 209     if n1 == Naive_tree.nil then acc
 210     else aux n1 (n1::acc)
 211   in
 212   let ll = List.map (fun n -> let res = aux n [] in
 213                               List.rev res ) ln in
 214   List.fold_left (fun acc l1 -> union_list tree acc l1) [] ll
 215
 216
 217 let rec get_firstBling tree n pred =
 218   if n== Naive_tree.nil then pred
 219   else get_firstBling tree (Naive_tree.prev_sibling tree n) n
 220
 221 let get_parent tree ln =
 222   let l = List.fold_left (fun acc n ->
 223     let n1 = get_firstBling tree n Naive_tree.nil in
 224     let n2 = Naive_tree.parent_of_first tree n1 in
 225     if n2 == Naive_tree.nil or List.mem n2 acc then acc
 226     else union_list tree [n2] acc
 227   ) [] ln
 228   in
 229   l
 230
 231
 232
 233 let get_ancestor tree ln =
 234   let rec aux tree l1 acc =
 235     match l1 with
 236         [] -> acc
 237       | _ -> let ll1 = get_parent tree l1 in
 238              let acc1 = union_list tree acc ll1 in
 239              aux tree ll1  acc1
 240   in
 241   let l = aux tree ln [] in
 242   l
 243
 244 let get_preSibling tree ln =
 245   let rec aux n acc =
 246     let n1 = Naive_tree.prev_sibling tree n in
 247     if n1 == Naive_tree.nil then acc
 248     else aux n1 (n1::acc)
 249   in
 250   let ll = List.map (fun n -> aux n [] ) ln in
 251   List.fold_left (fun acc l1 -> union_list tree acc l1) [] ll
 252
 253
 254
 255 let rec eval_axis tree ls a =
 256   let open Xpath.Ast in
 257         match a with
 258             Self -> ls
 259
 260           | Attribute -> get_child tree ls
 261
 262           | Child -> get_child tree ls
 263
 264           | Descendant c -> let ls2 = get_descendant tree ls in
 265                             let ldes =
 266                               if not c then ls2
 267                               else union_list tree ls2 ls
 268                             in
 269                             ldes
 270
 271           | FollowingSibling -> get_followingSibling tree ls
 272
 273           | Parent -> get_parent tree ls
 274
 275           | Ancestor b ->
 276                           let ls3 = get_ancestor tree ls in
 277                           let lac =
 278                           if not b then ls3
 279                           else union_list tree ls3 ls
 280                           in
 281                           lac
 282
 283           | PrecedingSibling -> get_preSibling tree ls
 284
 285           | Preceding -> let ls2 = eval_axis tree ls (Ancestor true) in
 286                          let ls3 = eval_axis tree ls2 PrecedingSibling in
 287                          let lp = eval_axis tree ls3 (Descendant true) in
 288                          lp
 289
 290           | Following -> let ls2 = eval_axis tree ls (Ancestor true) in
 291                          let ls3 = eval_axis tree ls2 FollowingSibling in
 292                          let lf = eval_axis tree ls3 (Descendant true) in
 293                          lf
 294
 295
 296
 297
 298
 299
 300