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 -> true | _ -> false) l
 109
 110 let rec eval_axis tree ls a =
 111   let open Xpath.Ast in
 112       let res =
 113      (* let ls =  List.sort ( fun a b -> compare (Naive_tree.preorder tree a ) (Naive_tree.preorder tree b ) ) ls in ़crir  dans la log!!!!!*)
 114         match a with
 115             Self -> ls
 116
 117           | Attribute -> assert false
 118
 119           | Child -> let lfc = eval_move tree ls Firstchild in
 120                      eval_star tree lfc [Nextsibling]
 121
 122           | Descendant c -> let lfc = eval_move tree ls Firstchild in
 123                             let ls2 = eval_star tree lfc [Firstchild;Nextsibling] in
 124
 125                           (* List.merge (compare_node tree) (if c then ls else [])
 126                              (List.merge (compare_node tree) ls2 ls)*)
 127
 128                             if not c then ls2
 129                             else List.merge (compare_node tree) ls2 ls
 130
 131           | FollowingSibling -> let lnexts = eval_move tree ls Nextsibling in
 132                                 eval_star tree lnexts [Nextsibling]
 133
 134           | Parent -> let lprevs = eval_star tree ls [Prevsibling] in
 135                       eval_move tree lprevs Revfirstchild
 136
 137           | Ancestor b -> let ls2 = eval_star tree ls [Revfirstchild;Prevsibling] in
 138                           let ls3 = eval_move tree ls2 Revfirstchild in
 139                           if not b then ls3
 140                           else List.merge (compare_node tree ) ls3 ls
 141
 142           | PrecedingSibling -> let ls2 = eval_star tree ls [Prevsibling] in
 143                                 eval_move tree ls2 Prevsibling
 144
 145           | Preceding -> let ls2 = eval_axis tree ls (Ancestor true) in
 146                          let ls3 = eval_axis tree ls2 PrecedingSibling in
 147                          eval_axis tree ls3 (Descendant true)
 148
 149           | Following -> let ls2 = eval_axis tree ls (Ancestor true) in
 150                          let ls3 = eval_axis tree ls2 FollowingSibling in
 151                          eval_axis tree ls3 (Descendant true)
 152       in
 153       keep_elements tree res
 154
 155
 156
 157
 158
 159
 160
 161