* New operators (Subset, SetEqual and RVarOccurrence) added to MathQL

[helm.git] / helm / ocaml / mathql_interpreter / intersect.ml

diff --git a/helm/ocaml/mathql_interpreter/intersect.ml b/helm/ocaml/mathql_interpreter/intersect.ml
index e346101cf9152a19599ba0241b853801ebf67d8b..6bd620a108596575477b8c44cdf12cb426ed10d0 100644 (file)
--- a/helm/ocaml/mathql_interpreter/intersect.ml
+++ b/helm/ocaml/mathql_interpreter/intersect.ml
@@ -23,118 +23,54 @@
  * http://cs.unibo.it/helm/.
  *)
 
-(*
- * implementazione del comando INTERSECT
- *)
-
-(*
- * eccezione sollevata quando il join dei contesti
- * deve essere vuoto
- *)
-exception Join_must_be_empty;;
+exception NotCompatible;;
 
-(*
- * join fra due contesti
- *)
-let xres_join_context h1 l1 h2 l2 =
- match (l1, l2) with
-    ([], _) -> l2
- |  (_, []) -> l1
- |  (_,  _) ->
-     let hh = h2 @ (List.find_all (function t -> not (List.mem t h2)) h1)
-     and m1 = List.combine h1 l1
-     and m2 = List.combine h2 l2
-     in
-       List.map
-        (fun elem ->
-         let value1 = try (List.assoc elem m1) with Not_found -> List.assoc elem m2
-         and value2 = try (List.assoc elem m2) with Not_found -> List.assoc elem m1
-         in
-          if value1 = value2 then value1 else raise Join_must_be_empty
-        )
-        hh
+(* intersect_attributes is successful iff there is no attribute with *)
+(* two different values in the two lists. The returned list is the   *)
+(* union of the two lists.                                           *)
+let rec intersect_attributes (attr1, attr2) =
+ match attr1, attr2 with
+    [],_ -> attr2
+  | _,[] -> attr1
+  | (key1,value1)::tl1, (key2,_)::_ when key1 < key2 ->
+      (key1,value1)::(intersect_attributes (tl1,attr2))
+  | (key1,_)::_, (key2,value2)::tl2 when key2 < key1 ->
+      (key2,value2)::(intersect_attributes (attr1,tl2))
+  | entry1::tl1, entry2::tl2 when entry1 = entry2 ->
+     entry1::(intersect_attributes (tl1,tl2))
+  | _, _ -> raise NotCompatible  (* same keys, different values *)
 ;;
 
-(*
- *
- *)
-let intersect_tails h1 t1 h2 t2 =
- let rec aux t1 t2 =
-  match (t1, t2) with
-     ([], _)
-  |  (_, []) -> []
-  |  ((l1::tl1)::tll1, (l2::tl2)::tll2) ->
-       if l1 = l2 then
-        try
-         (*match xres_join_context h1 tl1 h2 tl2 with
-            [] -> aux tll1 tll2
-          | t  -> (l1::(xres_join_context h1 tl1 h2 tl2))::(aux tll1 tll2)*)
-         (l1::(tl1 @ tl2))::(aux tll1 tll2)
-       with
-        Join_must_be_empty -> aux tll1 tll2
-       else
-        if l1 < l2 then
-         aux tll1 t2
-        else
-         aux t1 tll2
-   | _ -> assert false
- in
-  aux t1 t2
+(* preserves order and gets rid of duplicates *)
+let rec intersect_ex l1 l2 =
+ let module S = Mathql_semantics in
+  match (l1, l2) with
+     [],_
+   | _,[] -> []
+   | {S.uri = uri1}::tl1,
+     {S.uri = uri2}::_ when uri1 < uri2 -> intersect_ex tl1 l2
+   | {S.uri = uri1}::_,
+     {S.uri = uri2}::tl2 when uri2 < uri1 -> intersect_ex l1 tl2
+   | {S.uri = uri1 ; S.attributes = attributes1}::tl1,
+     {S.uri = uri2 ; S.attributes = attributes2}::tl2 ->
+       try
+        let attributes' = intersect_attributes (attributes1,attributes2) in
+         {S.uri = uri1 ; S.attributes = attributes'}::(intersect_ex tl1 tl2)
+       with
+        NotCompatible ->
+         intersect_ex tl1 tl2
 ;;
 
-(*
- * implementazione del comando INTERSECT
- *)
 let intersect_ex l1 l2 =
- let _ = print_string ("INTERSECT ")
- and t = Unix.time () in
-  let result = 
- match (l1, l2) with
-    ((head1::tail1), (head2::tail2)) ->
-     (match (head1, head2) with
-         ([], _) -> assert false (* gli header non devono mai essere vuoti *)
-      |  (_, []) -> assert false (* devono contenere almeno [retVal] *)
-      |  (_,  _) ->
-          (match (tail1, tail2) with
-              ([], _) -> [["retVal"]] (* se una delle due code e' vuota... *)
-           |  (_, []) -> [["retVal"]] (* ... l'intersezione e' vuota *)
-           |  (_,  _) ->
-               [head2 @
-                (List.find_all
-                (function t -> not (List.mem t head2))
-                head1
-               )
-              ] (* header del risultato finale *)
-              @
-              intersect_tails (List.tl head1) tail1 (List.tl head2) tail2
-              (*
-              List.fold_left
-                (fun par1 elem1 -> par1 @
-                 List.map
-                 (fun elem2 ->
-                  [(List.hd elem1)] @
-                  (xres_join_context (List.tl head1) (List.tl elem1)
-                                     (List.tl head2) (List.tl elem2)
-                   )
-                 )
-                  (List.find_all (* *)
-                   (fun elem2 ->    (* trova tutti gli elementi della lista tail2 *)
-                   ((List.hd elem1) = (List.hd elem2)) && (* che stanno in tail1 *)
-                   not ((xres_join_context (List.tl head1) (List.tl elem1)
-                                           (List.tl head2) (List.tl elem2)) = [])
-                   (* e per i quali la xres_join_context non sia vuota *)
-                  )
-                   tail2 (* List.find_all *)
-                 )
-                 )
-               []
-               tail1 (* per ogni elemento di tail1 applica la List.fold_left *)
-              *)
-          ) (* match *)
-     )
- | _ -> []
-  in
-   let _ = print_endline (string_of_float (Unix.time () -. t)); flush stdout in
-    result
+ let before = Unix.time () in
+ let res = intersect_ex l1 l2 in
+ let after = Unix.time () in
+  let ll1 = string_of_int (List.length l1) in
+  let ll2 = string_of_int (List.length l2) in
+  let diff = string_of_float (after -. before) in
+  prerr_endline
+   ("INTERSECT(" ^ ll1 ^ "," ^ ll2 ^ ") = " ^ string_of_int (List.length res) ^
+    ": " ^ diff ^ "s") ;
+  flush stderr ;
+  res
 ;;
-