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