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
  24
  25
  26
  27
  28 (*28/01/2014
  29   parametres : tree  l'arbre xml
  30                n     un noeud
  31                m     move
  32   retour :un noeud qui correspond ॆ la relation r
  33 *)
  34
  35 let print_node_list tree l =
  36   List.iter (fun node ->
  37     Naive_tree.print_xml stdout tree node;
  38     print_newline()
  39   ) l
  40
  41 let rec print_query_tree fmt q =
  42   match q.desc with
  43       Dom -> Format.fprintf fmt "Dom"
  44     | Start -> Format.fprintf fmt "Start"
  45     | Tag (t,k) -> Format.fprintf fmt "Tag(%a, %a)" QNameSet.print t Tree.NodeKind.print k
  46     | Axis (a,q) ->
  47       Format.fprintf fmt "%a(%a)" Xpath.Ast.print_axis a print_query_tree q
  48     | Binop (op,q1,q2) ->
  49       Format.fprintf fmt "%a(%a, %a)"
  50       print_binop  op
  51       print_query_tree  q1
  52       print_query_tree  q2
  53
  54 and print_binop fmt o =
  55   match o with
  56     | Union -> Format.fprintf fmt "Union"
  57     | Inter -> Format.fprintf fmt "Inter"
  58     | Diff -> Format.fprintf fmt "Diff"
  59
  60 let rec eval_relation tree m n =
  61   match m with
  62       Self -> n
  63     | Firstchild ->  Naive_tree.first_child tree n
  64     | Nextsibling -> Naive_tree.next_sibling tree n
  65     | Revfirstchild -> Naive_tree.parent_of_first tree n
  66     | Prevsibling -> Naive_tree.prev_sibling tree n
  67
  68 (*28/01/2014
  69   parametres : tree  l'arbre xml
  70                ls    l'ensemble de noeuds
  71                m     move
  72   retour : l'ensemble de noeuds qui correspondent ॆ la relation r
  73 *)
  74
  75
  76 let compare_node tree a b =
  77   compare (Naive_tree.preorder tree a ) (Naive_tree.preorder tree b )
  78
  79 let rec eval_move tree ls m =
  80   match m with
  81       Self -> ls
  82     | r -> List.filter (fun n -> n != Naive_tree.nil)
  83            (List.map (eval_relation tree r) ls)
  84
  85
  86 (*28/01/2014
  87   parametres : tree  l'arbre xml
  88                ls    l'ensemble de noeuds
  89                m     move
  90   retour : l'ensemble de noeuds qui correspondent ॆ des relations lr
  91 *)
  92
  93 and eval_star tree ls lr =
  94   let h = Hashtbl.create 17 in
  95   let q = Queue.create () in
  96   List.iter ( fun e -> Queue.add e q ) ls;
  97   while not (Queue.is_empty q ) do
  98     let n = Queue.pop q in
  99     if not (Hashtbl.mem h n) then begin
 100       Hashtbl.add h n ();
 101       List.iter ( fun r -> let m = eval_relation tree r n in
 102                            if m != Naive_tree.nil && not (Hashtbl.mem h m ) then begin
 103
 104                              Queue.add m q; end
 105       ) lr
 106     end
 107   done;
 108   let l = Hashtbl.fold (fun k _ acc -> k::acc) h [] in
 109   List.sort (compare_node tree) l
 110
 111 (*28/01/2014
 112   parametres : tree  l'arbre xml
 113                ls    l'ensemble de noeuds
 114                a     axis
 115   retour : l'ensemble de noeuds qui correspondent ॆ l'axe
 116 *)
 117
 118 let keep_elements t l = (*
 119    List.filter (fun n -> match Naive_tree.kind t n with
 120      | Element | Text | Document | Attribute -> true | _ -> false) l
 121                         *) l
 122
 123 let keep_attributs t l = (*
 124   List.filter (fun n -> match Naive_tree.kind t n with
 125     | Attribute ->true | _ -> false) *) l
 126
 127 let rec eval_axis tree ls a =
 128   let open Xpath.Ast in
 129         match a with
 130             Self -> ls
 131
 132           | Attribute -> let lfc = eval_move tree ls Firstchild in
 133                          let lc = eval_star tree lfc [Nextsibling] in
 134                          keep_attributs tree lc
 135
 136           | Child -> let lfc = eval_move tree ls Firstchild in
 137                      let lc = eval_star tree lfc [Nextsibling] in
 138                      keep_elements tree lc
 139
 140           | Descendant c -> let lfc = eval_move tree ls Firstchild in
 141                             let ls2 = eval_star tree lfc [Firstchild;Nextsibling] in
 142                             let ldes =
 143                             if not c then ls2
 144                             else List.merge (compare_node tree) ls2 ls
 145                             in
 146                             keep_elements tree ldes
 147
 148           | FollowingSibling -> let lnexts = eval_move tree ls Nextsibling in
 149                                 let lfs = eval_star tree lnexts [Nextsibling] in
 150                                 keep_elements tree lfs
 151
 152           | Parent -> let lprevs = eval_star tree ls [Prevsibling] in
 153                       let lp = eval_move tree lprevs Revfirstchild in
 154                       keep_elements tree lp
 155
 156           | Ancestor b -> let ls2 = eval_star tree ls [Revfirstchild;Prevsibling] in
 157                           let ls3 = eval_move tree ls2 Revfirstchild in
 158                           let lac =
 159                           if not b then ls3
 160                           else List.merge (compare_node tree ) ls3 ls
 161                           in
 162                           keep_elements tree lac
 163
 164           | PrecedingSibling -> let ls2 = eval_star tree ls [Prevsibling] in
 165                                 let lps = eval_move tree ls2 Prevsibling in
 166                                 keep_elements tree lps
 167
 168           | Preceding -> let ls2 = eval_axis tree ls (Ancestor true) in
 169                          let ls3 = eval_axis tree ls2 PrecedingSibling in
 170                          let lp = eval_axis tree ls3 (Descendant true) in
 171                          keep_elements tree lp
 172
 173           | Following -> let ls2 = eval_axis tree ls (Ancestor true) in
 174                          let ls3 = eval_axis tree ls2 FollowingSibling in
 175                          let lf = eval_axis tree ls3 (Descendant true) in
 176                          keep_elements tree lf
 177
 178
 179
 180
 181
 182
 183
 184
 185