* 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 bd582a3b2ae8c1dbb9e6d56ede86ca1bea274a56..6bd620a108596575477b8c44cdf12cb426ed10d0 100644 (file)
--- a/helm/ocaml/mathql_interpreter/intersect.ml
+++ b/helm/ocaml/mathql_interpreter/intersect.ml
@@ -23,85 +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
-      try 
-       (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
-       ) with
-        Join_must_be_empty -> []
+(* 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 *)
 ;;
 
-(*
- * implementazione del comando INTERSECT
- *)
-let intersect_ex alist1 alist2 =
- let head1 = List.hd alist1
- and tail1 = List.tl alist1
- and head2 = List.hd alist2
- and tail2 = List.tl alist2 (* e fin qui ... *)
- in
-  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 *)
-          @
-          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
-             )
-             )
-           []
-           tail1 (* per ogni elemento di tail1 applica la List.fold_left *)
-      ) (* match *)
+(* 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
 ;;
 
+let intersect_ex l1 l2 =
+ 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
+;;