src/table.ml

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