src/table.ml

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