X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Focaml%2Fmathql_interpreter%2Fintersect.ml;h=8a2f55ff224cec02d1392560c171af73eca81e9d;hb=4ac188650f64fb947c5d87dcf3c932a4d013d842;hp=6bd620a108596575477b8c44cdf12cb426ed10d0;hpb=7f510b2df638258669d6539861a3f06ed5fab773;p=helm.git diff --git a/helm/ocaml/mathql_interpreter/intersect.ml b/helm/ocaml/mathql_interpreter/intersect.ml index 6bd620a10..8a2f55ff2 100644 --- a/helm/ocaml/mathql_interpreter/intersect.ml +++ b/helm/ocaml/mathql_interpreter/intersect.ml @@ -23,54 +23,137 @@ * http://cs.unibo.it/helm/. *) -exception NotCompatible;; -(* 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 *) +(* Catenates two lists preserving order and getting rid of duplicates *) +let rec append (l1,l2) = + match l1,l2 with + [],_ -> l2 + | _,[] -> l1 + | s1::tl1, s2::_ when s1 < s2 -> s1::append (tl1,l2) + | s1::_, s2::tl2 when s2 < s1 -> s2::append (l1,tl2) + | s1::tl1, s2::tl2 -> s1::append (tl1,tl2) + ;; -(* 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 + +(* Sums two attribute groups preserving order *) +let rec sum_groups(gr1, gr2) = + match gr1, gr2 with + [],_ -> gr2 + | _,[] -> gr1 + | (key1,l1)::tl1, (key2,l2)::_ when key1 < key2 -> (key1,l1)::(sum_groups (tl1,gr2)) + | (key1,l1)::_, (key2,l2)::tl2 when key2 < key1 -> (key2,l2)::(sum_groups (gr1,tl2)) + | (key1,l1)::tl1, (key2,l2)::tl2 -> (key1,(append (l1,l2)))::(sum_groups (tl1,tl2)) + +;; + +(* Product between an attribute set and a group of attributes *) +let rec sub_prod (aset, gr) = (*prende un aset e un gr e fa la somma tra tutti i gruppi di aset e gr *) + match aset with + [] -> [] + | gr1::tl1 -> sum_groups (gr1, gr)::(sub_prod(tl1, gr)) +;; + + +(* Cartesian product between two attribute sets*) +let rec prod (as1, as2) = + match as1, as2 with + [],_ -> as2 + | _,[] -> as1 + | gr1::tl1, _ -> (sub_prod (as2, gr1))@(prod (tl1, as2)) (* chiamo la sub_prod con un el. as1 e as2 *) ;; +(* Intersection between two resource sets, preserves order and gets rid of duplicates *) +let intersect_ex rs1 rs2 = + let rec intersect_aux rs1 rs2 = + match (rs1, rs2) with + [],_ + | _,[] -> [] + | (uri1,_)::tl1, + (uri2,_)::_ when uri1 < uri2 -> intersect_aux tl1 rs2 + | (uri1,_)::_, + (uri2,_)::tl2 when uri2 < uri1 -> intersect_aux rs1 tl2 + | (uri1,as1)::tl1, + (uri2,as2)::tl2 -> (uri1, prod(as1,as2))::intersect_aux tl1 tl2 + in + let before = Sys.time () in + let res = intersect_aux rs1 rs2 in + let after = Sys.time () in + let ll1 = string_of_int (List.length rs1) in + let ll2 = string_of_int (List.length rs2) in + let diff = string_of_float (after -. before) in + print_endline + ("INTERSECT(" ^ ll1 ^ "," ^ ll2 ^ ") = " ^ string_of_int (List.length res) ^ + ": " ^ diff ^ "s") ; + flush stdout ; + res +;; + +(* + let intersect_ex l1 l2 = - let before = Unix.time () in + (* PRE-CLAUDIO + (*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 = Sys.time () in let res = intersect_ex l1 l2 in - let after = Unix.time () in + let after = Sys.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 + print_endline ("INTERSECT(" ^ ll1 ^ "," ^ ll2 ^ ") = " ^ string_of_int (List.length res) ^ ": " ^ diff ^ "s") ; - flush stderr ; + flush stdout ; res ;; + +*)