From 7f510b2df638258669d6539861a3f06ed5fab773 Mon Sep 17 00:00:00 2001 From: Claudio Sacerdoti Coen Date: Tue, 28 May 2002 15:55:36 +0000 Subject: [PATCH] * New operators (Subset, SetEqual and RVarOccurrence) added to MathQL * New implementation of all the operations. We will have to choose if this new implementation is better or worst than the previous one. * Diff and SortBy not implemented yet. --- helm/ocaml/mathql_interpreter/.depend | 39 +-- helm/ocaml/mathql_interpreter/Makefile | 6 +- helm/ocaml/mathql_interpreter/dbconn.ml | 4 +- helm/ocaml/mathql_interpreter/intersect.ml | 152 ++++------- helm/ocaml/mathql_interpreter/intersect.mli | 3 +- helm/ocaml/mathql_interpreter/mathql.ml | 16 +- .../mathql_interpreter/mathql_semantics.ml | 33 +++ helm/ocaml/mathql_interpreter/mqint.ml | 41 +-- helm/ocaml/mathql_interpreter/pattern.ml | 5 +- helm/ocaml/mathql_interpreter/pattern.mli | 5 +- helm/ocaml/mathql_interpreter/select.ml | 248 +++++++----------- helm/ocaml/mathql_interpreter/select.mli | 10 +- helm/ocaml/mathql_interpreter/union.ml | 29 ++ helm/ocaml/mathql_interpreter/union.mli | 3 +- helm/ocaml/mathql_interpreter/use.ml | 45 ++-- helm/ocaml/mathql_interpreter/use.mli | 3 +- 16 files changed, 302 insertions(+), 340 deletions(-) create mode 100644 helm/ocaml/mathql_interpreter/mathql_semantics.ml diff --git a/helm/ocaml/mathql_interpreter/.depend b/helm/ocaml/mathql_interpreter/.depend index b2ce01bf6..75754ac27 100644 --- a/helm/ocaml/mathql_interpreter/.depend +++ b/helm/ocaml/mathql_interpreter/.depend @@ -1,9 +1,14 @@ eval.cmi: mathql.cmo func.cmi: mathql.cmo sortedby.cmi: mathql.cmo -select.cmi: mathql.cmo -pattern.cmi: mathql.cmo +select.cmi: mathql.cmo mathql_semantics.cmo +intersect.cmi: mathql_semantics.cmo +union.cmi: mathql_semantics.cmo +pattern.cmi: mathql.cmo mathql_semantics.cmo +use.cmi: mathql.cmo mathql_semantics.cmo mqint.cmi: mathql.cmo +mathql_semantics.cmo: mathql.cmo +mathql_semantics.cmx: mathql.cmx dbconn.cmo: mathql.cmo dbconn.cmi dbconn.cmx: mathql.cmx dbconn.cmi eval.cmo: mathql.cmo eval.cmi @@ -16,17 +21,19 @@ diff.cmo: diff.cmi diff.cmx: diff.cmi sortedby.cmo: func.cmi mathql.cmo utility.cmi sortedby.cmi sortedby.cmx: func.cmx mathql.cmx utility.cmx sortedby.cmi -select.cmo: func.cmi mathql.cmo utility.cmi select.cmi -select.cmx: func.cmx mathql.cmx utility.cmx select.cmi -intersect.cmo: intersect.cmi -intersect.cmx: intersect.cmi -union.cmo: union.cmi -union.cmx: union.cmi -pattern.cmo: dbconn.cmi eval.cmi utility.cmi pattern.cmi -pattern.cmx: dbconn.cmx eval.cmx utility.cmx pattern.cmi -use.cmo: dbconn.cmi utility.cmi use.cmi -use.cmx: dbconn.cmx utility.cmx use.cmi -mqint.cmo: dbconn.cmi diff.cmi eval.cmi intersect.cmi mathql.cmo pattern.cmi \ - select.cmi sortedby.cmi union.cmi use.cmi utility.cmi mqint.cmi -mqint.cmx: dbconn.cmx diff.cmx eval.cmx intersect.cmx mathql.cmx pattern.cmx \ - select.cmx sortedby.cmx union.cmx use.cmx utility.cmx mqint.cmi +select.cmo: func.cmi mathql.cmo mathql_semantics.cmo utility.cmi select.cmi +select.cmx: func.cmx mathql.cmx mathql_semantics.cmx utility.cmx select.cmi +intersect.cmo: mathql_semantics.cmo intersect.cmi +intersect.cmx: mathql_semantics.cmx intersect.cmi +union.cmo: mathql_semantics.cmo union.cmi +union.cmx: mathql_semantics.cmx union.cmi +pattern.cmo: dbconn.cmi eval.cmi mathql_semantics.cmo utility.cmi pattern.cmi +pattern.cmx: dbconn.cmx eval.cmx mathql_semantics.cmx utility.cmx pattern.cmi +use.cmo: dbconn.cmi mathql_semantics.cmo utility.cmi use.cmi +use.cmx: dbconn.cmx mathql_semantics.cmx utility.cmx use.cmi +mqint.cmo: dbconn.cmi diff.cmi eval.cmi intersect.cmi mathql.cmo \ + mathql_semantics.cmo pattern.cmi select.cmi sortedby.cmi union.cmi \ + use.cmi utility.cmi mqint.cmi +mqint.cmx: dbconn.cmx diff.cmx eval.cmx intersect.cmx mathql.cmx \ + mathql_semantics.cmx pattern.cmx select.cmx sortedby.cmx union.cmx \ + use.cmx utility.cmx mqint.cmi diff --git a/helm/ocaml/mathql_interpreter/Makefile b/helm/ocaml/mathql_interpreter/Makefile index 5769f6cde..ccd485a59 100644 --- a/helm/ocaml/mathql_interpreter/Makefile +++ b/helm/ocaml/mathql_interpreter/Makefile @@ -6,9 +6,11 @@ INTERFACE_FILES = dbconn.mli eval.mli utility.mli func.mli diff.mli \ sortedby.mli select.mli intersect.mli union.mli \ pattern.mli use.mli mqint.mli -IMPLEMENTATION_FILES = mathql.ml $(INTERFACE_FILES:%.mli=%.ml) +IMPLEMENTATION_FILES = mathql.ml mathql_semantics.ml \ + $(INTERFACE_FILES:%.mli=%.ml) -EXTRA_OBJECTS_TO_INSTALL = mathql.ml mathql.cmi +EXTRA_OBJECTS_TO_INSTALL = mathql.ml mathql.cmi mathql_semantics.ml \ + mathql_semantics.cmi EXTRA_OBJECTS_TO_CLEAN = diff --git a/helm/ocaml/mathql_interpreter/dbconn.ml b/helm/ocaml/mathql_interpreter/dbconn.ml index fd207ba03..185ea011d 100644 --- a/helm/ocaml/mathql_interpreter/dbconn.ml +++ b/helm/ocaml/mathql_interpreter/dbconn.ml @@ -39,8 +39,8 @@ open Mathql;; * TODO: bisogna scegliere se questi parametri vengono * passati come argomento *) -(*let connection_param = "dbname=helm";;*) -let connection_param = "host=dotto.cs.unibo.it dbname=helm user=helm";; +let connection_param = "dbname=helm";; +(*let connection_param = "host=dotto.cs.unibo.it dbname=helm user=helm";;*) (* * connessione al db diff --git a/helm/ocaml/mathql_interpreter/intersect.ml b/helm/ocaml/mathql_interpreter/intersect.ml index e346101cf..6bd620a10 100644 --- 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 ;; - diff --git a/helm/ocaml/mathql_interpreter/intersect.mli b/helm/ocaml/mathql_interpreter/intersect.mli index aee42c09c..3b721b4f7 100644 --- a/helm/ocaml/mathql_interpreter/intersect.mli +++ b/helm/ocaml/mathql_interpreter/intersect.mli @@ -23,4 +23,5 @@ * http://cs.unibo.it/helm/. *) -val intersect_ex : string list list -> string list list -> string list list +val intersect_ex : + Mathql_semantics.result -> Mathql_semantics.result -> Mathql_semantics.result diff --git a/helm/ocaml/mathql_interpreter/mathql.ml b/helm/ocaml/mathql_interpreter/mathql.ml index 01cbf431a..e78029036 100644 --- a/helm/ocaml/mathql_interpreter/mathql.ml +++ b/helm/ocaml/mathql_interpreter/mathql.ml @@ -93,6 +93,10 @@ type mqstring = | MQMConclusion (* main conclusion *) | MQConclusion (* inner conclusion *) +type mqorder = + | MQAsc + | MQDesc + type mqbool = | MQTrue | MQFalse @@ -100,12 +104,13 @@ type mqbool = | MQOr of mqbool * mqbool | MQNot of mqbool | MQIs of mqstring * mqstring (* operands *) + | MQSetEqual of mqlist * mqlist (* the two lists denote the *) + (* same set *) + | MQSubset of mqlist * mqlist (* the two lists denote two *) + (* sets, the first one *) + (* subsect of the second one. *) -type mqorder = - | MQAsc - | MQDesc - -type mqlist = +and mqlist = | MQSelect of mqrvar * mqlist * mqbool (* rvar, list, boolean *) | MQUse of mqlist * mqsvar (* list, Position attribute *) | MQUsedBy of mqlist * mqsvar (* list, Position attribute *) @@ -114,6 +119,7 @@ type mqlist = | MQDiff of mqlist * mqlist (* *) | MQIntersect of mqlist * mqlist (* *) | MQSortedBy of mqlist * mqorder * mqfunc (* *) + | MQRVarOccur of mqrvar type mquery = | MQList of mqlist diff --git a/helm/ocaml/mathql_interpreter/mathql_semantics.ml b/helm/ocaml/mathql_interpreter/mathql_semantics.ml new file mode 100644 index 000000000..e7e5ee5e5 --- /dev/null +++ b/helm/ocaml/mathql_interpreter/mathql_semantics.ml @@ -0,0 +1,33 @@ +(* Copyright (C) 2000, HELM Team. + * + * This file is part of HELM, an Hypertextual, Electronic + * Library of Mathematics, developed at the Computer Science + * Department, University of Bologna, Italy. + * + * HELM is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * HELM is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with HELM; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, + * MA 02111-1307, USA. + * + * For details, see the HELM World-Wide-Web page, + * http://cs.unibo.it/helm/. + *) + +(* attributes are sorted w.r.t. their name in increasing order *) +type attributed_uri = + { uri: string ; attributes : (Mathql.mqsvar * string) list } + +type attributed_uri_env = + (Mathql.mqrvar * attributed_uri) list + +type result = attributed_uri list diff --git a/helm/ocaml/mathql_interpreter/mqint.ml b/helm/ocaml/mathql_interpreter/mqint.ml index c78465aa7..2bf4d144e 100644 --- a/helm/ocaml/mathql_interpreter/mqint.ml +++ b/helm/ocaml/mathql_interpreter/mqint.ml @@ -60,34 +60,37 @@ let fi_to_string fi = *) let init () = Dbconn.init ();; -(* - * esecuzione di una query - * - * parametri: - * q - * - * output: string list list; risultato internto formato da uri + contesto. - *) -let rec execute_ex q = - match q with +(* execute_ex env q *) +(* [env] is the attributed uri environment in which the query [q] *) +(* must be evaluated *) +(* [q] is the query to evaluate *) +(* It returns a [Mathql_semantics.result] *) +let rec execute_ex env = + function MQSelect (apvar, alist, abool) -> - select_ex apvar (execute_ex alist) abool + select_ex env apvar (execute_ex env alist) abool | MQUsedBy (alist, asvar) -> - use_ex (execute_ex alist) asvar "F" (*"refObj"*) + use_ex (execute_ex env alist) asvar "F" (*"refObj"*) | MQUse (alist, asvar) -> - use_ex (execute_ex alist) asvar "B" (*"backPointer"*) + use_ex (execute_ex env alist) asvar "B" (*"backPointer"*) | MQPattern (apreamble, apattern, afragid) -> pattern_ex apreamble apattern afragid | MQUnion (l1, l2) -> - union_ex (execute_ex l1) (execute_ex l2) + union_ex (execute_ex env l1) (execute_ex env l2) +(* | MQDiff (l1, l2) -> - diff_ex (execute_ex l1) (execute_ex l2) + diff_ex (execute_ex env l1) (execute_ex env l2) | MQSortedBy (l, o, f) -> - sortedby_ex (execute_ex l) o f + sortedby_ex (execute_ex env l) o f +*) | MQIntersect (l1, l2) -> - intersect_ex (execute_ex l1) (execute_ex l2) + intersect_ex (execute_ex env l1) (execute_ex env l2) + | MQRVarOccur rvar -> [List.assoc rvar env] ;; +(* Let's initialize the execute in Select, creating a cyclical recursion *) +Select.execute := execute_ex;; + (* * converte il risultato interno di una query (uri + contesto) * in un risultato di sole uri @@ -119,7 +122,7 @@ let rec execute_ex q = * la uri puo' far parte del risultato. *) let xres_to_res l = - let tmp = List.map List.hd (List.tl l) in + let tmp = List.map (function {Mathql_semantics.uri = uri} -> uri) l in MQRefs (List.map (function l -> @@ -178,7 +181,7 @@ let xres_to_res l = *) let execute q = match q with - MQList qq -> xres_to_res (execute_ex qq) + MQList qq -> xres_to_res (execute_ex [] qq) ;; (* diff --git a/helm/ocaml/mathql_interpreter/pattern.ml b/helm/ocaml/mathql_interpreter/pattern.ml index b68baa9a4..fa28f6cc5 100644 --- a/helm/ocaml/mathql_interpreter/pattern.ml +++ b/helm/ocaml/mathql_interpreter/pattern.ml @@ -30,6 +30,7 @@ open Dbconn;; open Utility;; open Eval;; +open Mathql_semantics;; let pattern_ex apreamble apattern afragid = let c = pgc () in @@ -40,5 +41,7 @@ let pattern_ex apreamble apattern afragid = let res = c#exec (qq) in - [["retVal"]] @ List.map (fun l -> [l]) (pgresult_to_string_list res) + List.map + (function uri -> {uri = uri ; attributes = []}) + (pgresult_to_string_list res) ;; diff --git a/helm/ocaml/mathql_interpreter/pattern.mli b/helm/ocaml/mathql_interpreter/pattern.mli index 051ffe9f2..72d44dc41 100644 --- a/helm/ocaml/mathql_interpreter/pattern.mli +++ b/helm/ocaml/mathql_interpreter/pattern.mli @@ -24,6 +24,5 @@ *) val pattern_ex : - string -> - Mathql.mquptoken list -> - int option * int option -> string list list + string -> Mathql.mquptoken list -> int option * int option -> + Mathql_semantics.result diff --git a/helm/ocaml/mathql_interpreter/select.ml b/helm/ocaml/mathql_interpreter/select.ml index f408b8bfe..4b2c26402 100644 --- a/helm/ocaml/mathql_interpreter/select.ml +++ b/helm/ocaml/mathql_interpreter/select.ml @@ -31,180 +31,110 @@ open Mathql;; open Func;; open Utility;; -(* - * valutazione di una stringa - *) -let stringeval s l = - match s with - MQCons s -> - s - | MQFunc (f, rvar) -> - apply_func f (List.assoc rvar l) - | MQRVar rvar -> - List.assoc rvar l - | MQSVar svar -> - List.assoc svar l - | MQMConclusion -> - "MainConclusion" - | MQConclusion -> - "InConclusion" +exception ExecuteFunctionNotInitialized;; +let execute = + ref + (function _ -> raise ExecuteFunctionNotInitialized) ;; (* - * + * valutazione di una stringa *) -let rec is_good l abool = - match abool with - MQAnd (b1, b2) -> - (is_good l b1) && (is_good l b2) - | MQOr (b1, b2) -> - (is_good l b1) || (is_good l b2) - | MQNot b1 -> - not (is_good l b1) - | MQTrue -> - true - | MQFalse -> - false - | MQIs (s1, s2) -> - (stringeval s1 l) = (stringeval s2 l) +let stringeval env = + let module S = Mathql_semantics in + function + MQCons s -> + s + | MQFunc (f, rvar) -> + let {S.uri = uri} = List.assoc rvar env in + apply_func f uri + | MQRVar rvar -> + let {S.uri = uri} = List.assoc rvar env in + uri + | MQSVar svar -> + let (_,{S.attributes = attributes}) = List.hd env in + List.assoc svar attributes + | MQMConclusion -> + "MainConclusion" + | MQConclusion -> + "InConclusion" ;; (* * *) -let rec replace avar newval l = - match l with - MQAnd (b1, b2) -> MQAnd (replace avar newval b1, replace avar newval b2) - | MQOr (b1, b2) -> MQOr (replace avar newval b1, replace avar newval b2) - | MQNot b1 -> MQNot (replace avar newval b1) - | MQIs (s1, s2) -> - let ns1 = ( - match s1 with - MQRVar v when v = avar -> MQRVar newval - | MQFunc (f, v) when v = avar -> MQFunc (f, newval) - | _ -> s1 - ) - and ns2 = ( - match s2 with - MQRVar v when v = avar -> MQRVar newval - | MQFunc (f, v) when v = avar -> MQFunc (f, newval) - | _ -> s2 - ) - in - MQIs (ns1, ns2) - | _ -> l (* i casi non compresi sono MQTrue e MQFalse *) +let rec is_good env = + let module S = Mathql_semantics in + function + MQAnd (b1, b2) -> + (is_good env b1) && (is_good env b2) + | MQOr (b1, b2) -> + (is_good env b1) || (is_good env b2) + | MQNot b1 -> + not (is_good env b1) + | MQTrue -> + true + | MQFalse -> + false + | MQIs (s1, s2) -> + (stringeval env s1) = (stringeval env s2) +(*CSC: magari le prossime funzioni dovrebbero andare in un file a parte, *) +(*CSC: insieme alla [execute] che utilizzano *) + | MQSetEqual (q1,q2) -> + (* set_of_result returns an ordered list of uris without duplicates *) + let rec set_of_result = + function + _,[] -> [] + | (Some olduri as v),{S.uri = uri}::tl when uri = olduri -> + set_of_result (v,tl) + | _,{S.uri = uri}::tl -> + uri::(set_of_result (Some uri, tl)) + in + let ul1 = set_of_result (None,!execute env q1) in + let ul2 = set_of_result (None,!execute env q2) in +prerr_endline ("MQSETEQUAL(" ^ string_of_int (List.length (!execute env q1)) ^ ">" ^ string_of_int (List.length ul1) ^ "," ^ string_of_int (List.length (!execute env q2)) ^ ">" ^ string_of_int (List.length ul2) ^ ")") ; flush stderr ; + (try + List.fold_left2 (fun b uri1 uri2 -> b && uri1=uri2) true ul1 ul2 + with + _ -> false) + | MQSubset (q1,q2) -> +(*CSC: codice cut&paste da sopra: ridurlo facendo un'unica funzione h.o. *) + (* set_of_result returns an ordered list of uris without duplicates *) + let rec set_of_result = + function + _,[] -> [] + | (Some olduri as v),{S.uri = uri}::tl when uri = olduri -> + set_of_result (v,tl) + | _,{S.uri = uri}::tl -> + uri::(set_of_result (Some uri, tl)) + in + let ul1 = set_of_result (None,!execute env q1) in + let ul2 = set_of_result (None,!execute env q2) in +prerr_endline ("MQSUBSET(" ^ string_of_int (List.length (!execute env q1)) ^ ">" ^ string_of_int (List.length ul1) ^ "," ^ string_of_int (List.length (!execute env q2)) ^ ">" ^ string_of_int (List.length ul2) ^ ")") ; flush stderr ; + let rec is_subset s1 s2 = + match s1,s2 with + [],_ -> true + | _,[] -> false + | uri1::tl1,uri2::tl2 when uri1 = uri2 -> + is_subset tl1 tl2 + | uri1::_,uri2::tl2 when uri1 > uri2 -> + is_subset s1 tl2 + | _,_ -> false + in + is_subset ul1 ul2 ;; -(*let rec print_booltree b = - match b with - MQAnd (b1, b2) -> - let i = print_booltree b1 in - let j = print_string " AND " in - print_booltree b2 - | MQOr (b1, b2) -> - let i = print_booltree b1 in - let j = print_string " OR " in - print_booltree b2 - | MQNot b1 -> - let j = print_string " NOT " in - print_booltree b1 - | MQTrue -> - print_string " TRUE " - | MQFalse -> - print_string " FALSE " - | MQIs (s1, s2) -> - let s1v = match s1 with - MQCons s -> - "'" ^ s ^ "'" - | MQFunc (f, rvar) -> - ( - match f with - MQName -> "NAME " ^ rvar - | MQTheory -> "THEORY" ^ rvar - | MQTitle -> "TITLE" ^ rvar - | MQContributor -> "contributor" ^ rvar - | MQCreator -> "creator" ^ rvar - | MQPublisher -> "publisher" ^ rvar - | MQSubject -> "subject" ^ rvar - | MQDescription -> "description" ^ rvar - | MQDate -> "date" ^ rvar - | MQType -> "type" ^ rvar - | MQFormat -> "format" ^ rvar - | MQIdentifier -> "identifier" ^ rvar - | MQLanguage -> "language" ^ rvar - | MQRelation -> "relation" ^ rvar - | MQSource -> "source" ^ rvar - | MQCoverage -> "coverage" ^ rvar - | MQRights -> "rights" ^ rvar - | MQInstitution -> "institution" ^ rvar - | MQContact -> "contact" ^ rvar - | MQFirstVersion -> "firstversion" ^ rvar - | MQModified -> "modified" ^ rvar - ) - | MQRVar rvar -> - rvar - | MQSVar svar -> - svar - | MQMConclusion -> - "MainConclusion" - | MQConclusion -> - "InConclusion" - and s2v = match s2 with - MQCons s -> - s - | MQFunc (f, rvar) -> - ( - match f with - MQName -> "NAME " ^ rvar - | MQTheory -> "THEORY" ^ rvar - | MQTitle -> "TITLE" ^ rvar - | MQContributor -> "contributor" ^ rvar - | MQCreator -> "creator" ^ rvar - | MQPublisher -> "publisher" ^ rvar - | MQSubject -> "subject" ^ rvar - | MQDescription -> "description" ^ rvar - | MQDate -> "date" ^ rvar - | MQType -> "type" ^ rvar - | MQFormat -> "format" ^ rvar - | MQIdentifier -> "identifier" ^ rvar - | MQLanguage -> "language" ^ rvar - | MQRelation -> "relation" ^ rvar - | MQSource -> "source" ^ rvar - | MQCoverage -> "coverage" ^ rvar - | MQRights -> "rights" ^ rvar - | MQInstitution -> "institution" ^ rvar - | MQContact -> "contact" ^ rvar - | MQFirstVersion -> "firstversion" ^ rvar - | MQModified -> "modified" ^ rvar - ) - | MQRVar rvar -> - rvar - | MQSVar svar -> - svar - | MQMConclusion -> - "MainConclusion" - | MQConclusion -> - "InConclusion" - in - print_string (s1v ^ " = " ^ s2v) -;; -*) (* * implementazione del comando SELECT *) -let select_ex avar alist abool = - let _ = print_string ("SELECT ") +let select_ex env avar alist abool = + let _ = print_string ("SELECT = ") and t = Unix.time () in let result = - let wrt = replace avar "retVal" abool in - (*let j = print_booltree wrt in*) - [List.hd alist] - @ - List.find_all - (fun l -> is_good (List.combine (List.hd alist) l) wrt) - (List.tl alist) + List.filter (function entry -> is_good ((avar,entry)::env) abool) alist in - let _ = print_endline (string_of_float (Unix.time () -. t)); flush stdout in - result + print_string (string_of_int (List.length result) ^ ": ") ; + print_endline (string_of_float (Unix.time () -. t) ^ "s") ; + flush stdout ; + result ;; - diff --git a/helm/ocaml/mathql_interpreter/select.mli b/helm/ocaml/mathql_interpreter/select.mli index 7d627b00b..582fc0030 100644 --- a/helm/ocaml/mathql_interpreter/select.mli +++ b/helm/ocaml/mathql_interpreter/select.mli @@ -23,6 +23,12 @@ * http://cs.unibo.it/helm/. *) +exception ExecuteFunctionNotInitialized;; +val execute: + (Mathql_semantics.attributed_uri_env -> + Mathql.mqlist -> Mathql_semantics.result) ref + val select_ex : - Mathql.mqrvar -> - Mathql.mqsvar list list -> Mathql.mqbool -> Mathql.mqsvar list list + Mathql_semantics.attributed_uri_env -> + Mathql.mqrvar -> Mathql_semantics.result -> Mathql.mqbool -> + Mathql_semantics.result diff --git a/helm/ocaml/mathql_interpreter/union.ml b/helm/ocaml/mathql_interpreter/union.ml index 5573c192e..65f73503b 100644 --- a/helm/ocaml/mathql_interpreter/union.ml +++ b/helm/ocaml/mathql_interpreter/union.ml @@ -27,6 +27,7 @@ * implementazione del comando UNION *) +(* (* * *) @@ -104,4 +105,32 @@ let union_ex alist1 alist2 = ) (* match *) ) ;; +*) +(* preserves order and gets rid of duplicates *) +let rec union_ex l1 l2 = + let module S = Mathql_semantics in + match (l1, l2) with + [],l + | l,[] -> l + | ({S.uri = uri1} as entry1)::tl1, + ({S.uri = uri2} as entry2)::_ when uri1 < uri2 || entry1 < entry2 -> + entry1::(union_ex tl1 l2) + | ({S.uri = uri1} as entry1)::_, + ({S.uri = uri2} as entry2)::tl2 when uri2 < uri1 || entry2 < entry1 -> + entry2::(union_ex l1 tl2) + | entry1::tl1,entry2::tl2 -> (* same entry *) + entry1::(union_ex tl1 tl2) +;; + +let union_ex l1 l2 = + let before = Unix.time () in + let res = union_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 ("UNION(" ^ ll1 ^ "," ^ ll2 ^ "): " ^ diff ^ "s") ; + flush stderr ; + res +;; diff --git a/helm/ocaml/mathql_interpreter/union.mli b/helm/ocaml/mathql_interpreter/union.mli index 967915d84..6b6ba6d27 100644 --- a/helm/ocaml/mathql_interpreter/union.mli +++ b/helm/ocaml/mathql_interpreter/union.mli @@ -23,4 +23,5 @@ * http://cs.unibo.it/helm/. *) -val union_ex : string list list -> string list list -> string list list +val union_ex : + Mathql_semantics.result -> Mathql_semantics.result -> Mathql_semantics.result diff --git a/helm/ocaml/mathql_interpreter/use.ml b/helm/ocaml/mathql_interpreter/use.ml index 7755ff20a..ecc12f01d 100644 --- a/helm/ocaml/mathql_interpreter/use.ml +++ b/helm/ocaml/mathql_interpreter/use.ml @@ -45,17 +45,16 @@ open Dbconn;; * comando USE/USED BY *) let use_ex alist asvar usek = - let _ = print_string ("USE ") - and t = Unix.time () in - let result = - let c = pgc () - in - [ (List.hd alist) @ [asvar] ] - @ +let module S = Mathql_semantics in +let _ = print_string ("USE ") +and t = Unix.time () in +let result = + let c = pgc () in Sort.list - (fun l m -> List.hd l < List.hd m) + (fun {S.uri = uri1} {S.uri = uri2} -> uri1 < uri2) (List.fold_left - (fun parziale xres -> + (fun parziale {S.uri = uri ; S.attributes = attributes} -> + print_string uri ; (*let r1 = helm_property_id usek and r2 = helm_property_id "position" and r3 = helm_property_id "occurrence" @@ -65,22 +64,28 @@ let use_ex alist asvar usek = "where " ^ "t" ^ r1 ^ ".att0 = '" ^ (List.hd xres) ^ "' and t" ^ r1 ^ ".att1 = t" ^ r2 ^ ".att0 and t" ^ r1 ^ ".att1 = t" ^ r3 ^ ".att0 order by t" ^ r3 ^ ".att1 asc"*) - let tv = pgresult_to_string (c#exec ("select id from registry where uri='" ^ (List.hd xres) ^ "'")) in - let qq = "select uri, context from t" ^ tv ^ " where back_for='" ^ usek ^ "'" + let tv = + pgresult_to_string + (c#exec ("select id from registry where uri='" ^ uri ^ "'")) + in + let qq = + "select uri, context from t" ^ tv ^ " where back_for='" ^ usek ^ + "' order by uri asc" in let res = c#exec qq in (List.map - (fun l -> [List.hd l] @ List.tl xres @ List.tl l) - res#get_list - ) - @ + (function + [uri;context] -> {S.uri = uri ; S.attributes = [asvar, context]} + | _ -> assert false + ) res#get_list + ) @ parziale - ) - [] - (List.tl alist) + ) [] alist ) - in - let _ = print_endline (string_of_float (Unix.time () -. t)); flush stdout in +in +print_string (" = " ^ string_of_int (List.length result) ^ ": ") ; +print_endline (string_of_float (Unix.time () -. t) ^ "s") ; +flush stdout ; result ;; diff --git a/helm/ocaml/mathql_interpreter/use.mli b/helm/ocaml/mathql_interpreter/use.mli index 708c134c9..a8186b40a 100644 --- a/helm/ocaml/mathql_interpreter/use.mli +++ b/helm/ocaml/mathql_interpreter/use.mli @@ -23,4 +23,5 @@ * http://cs.unibo.it/helm/. *) -val use_ex : string list list -> string -> string -> string list list +val use_ex : + Mathql_semantics.result -> Mathql.mqsvar -> string -> Mathql_semantics.result -- 2.39.2