X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Focaml%2Fmathql_interpreter%2FmQueryInterpreter.ml;h=57e1207bcbef3c6187fb1ce5cfe9691c99d2ac9d;hb=ad4c175433641f3b6668971bb7b3498c31390e0e;hp=f320ebba667ce8f3b2492fb97189a1a121d56b26;hpb=03dee221bd1f2c9a6e7f74d9abf88be14aac7763;p=helm.git

diff --git a/helm/ocaml/mathql_interpreter/mQueryInterpreter.ml b/helm/ocaml/mathql_interpreter/mQueryInterpreter.ml
index f320ebba6..57e1207bc 100644
--- a/helm/ocaml/mathql_interpreter/mQueryInterpreter.ml
+++ b/helm/ocaml/mathql_interpreter/mQueryInterpreter.ml
@@ -23,242 +23,174 @@
  * http://cs.unibo.it/helm/.
  *)
 
-open Dbconn;;
-open Union;;
-open Intersect;;
-open Meet;;
-open Property;;
-open Sub;;
-open Context;;
-open Diff;;
-open Relation;;
-open Func;;
-open Pattern;;
-
-exception SVarUnbound of string;;
-exception RVarUnbound of string;;
-exception VVarUnbound of string;;
-exception PathUnbound of (string * string list);;
-
-exception InvalidConnection
-exception ConnectionFailed of string
-
-exception BooleExpTrue
-  
-(* valuta una MathQL.set_exp e ritorna un MathQL.resource_set *)
-
-let galax_char = 'G'
-let stat_char = 'S'
-
-let execute_aux log m x =
-   let module M = MathQL in
-   let module X = MQueryMisc in
-let rec exec_set_exp c = function
-     M.SVar svar ->
-      (try
-        List.assoc svar c.svars
-       with Not_found ->
-        raise (SVarUnbound svar))
-   | M.RVar rvar ->
-      (try
-        [List.assoc rvar c.rvars]  
-       with Not_found ->
-        raise (RVarUnbound rvar))
-   | M.Ref vexp -> List.map (fun s -> (s,[])) (exec_val_exp c vexp)
-   | M.Pattern vexp -> pattern_ex (exec_val_exp c vexp)
-   | M.Intersect (sexp1, sexp2) ->    
-        let before = X.start_time() in
-	let rs1 = exec_set_exp c sexp1 in
-	let rs2 = exec_set_exp c sexp2 in
-        let res = intersect_ex rs1 rs2 in
-        let diff = X.stop_time before in
-        let ll1 = string_of_int (List.length rs1) in
-        let ll2 = string_of_int (List.length rs2) in
-	if String.contains m stat_char then
-        log ("INTERSECT(" ^ ll1 ^ "," ^ ll2 ^ ") = " ^ string_of_int (List.length res) ^
-         ": " ^ diff ^ "\n");
-        res
-   | M.Union (sexp1, sexp2) -> 
-        let before = X.start_time () in
-	let res = union_ex (exec_set_exp c sexp1) (exec_set_exp c sexp2) in
-	let diff = X.stop_time before in
-        if String.contains m stat_char then log ("UNION: " ^ diff ^ "\n");
-        res		      	
-   | M.LetSVar (svar, sexp1, sexp2) ->
-        let before = X.start_time() in
-        let c1 = upd_svars c ((svar, exec_set_exp c sexp1) :: c.svars) in 
-	let res = exec_set_exp c1 sexp2 in
-	if String.contains m stat_char then begin
-	   log ("LETIN " ^ svar ^ " = " ^ string_of_int (List.length res) ^ ": ");
-	   log (X.stop_time before ^ "\n");
-        end;
-	res			
-   | M.LetVVar (vvar, vexp, sexp) ->
-        let before = X.start_time() in
-	let c1 = upd_vvars c ((vvar, exec_val_exp c vexp) :: c.vvars) in
-	let res = exec_set_exp c1 sexp in
-	if String.contains m stat_char then begin
-	   log ("LETIN " ^ vvar ^ " = " ^ string_of_int (List.length res) ^ ": ");
-           log (X.stop_time before ^ "\n");
-        end;
-	res
-   | M.Relation (inv, rop, path, sexp, assl) -> 
-        let before = X.start_time() in
-	if String.contains m galax_char then begin
-           let res = relation_galax_ex inv rop path (exec_set_exp c sexp) assl in
-           if String.contains m stat_char then begin
-              log  ("RELATION-GALAX " ^ (fst path) ^ " = " ^ string_of_int(List.length res) ^ ": ");
-              log (X.stop_time before ^ "\n")
-          end;
-          res
-        end else begin 
-           let res = relation_ex inv rop path (exec_set_exp c sexp) assl in
-	   if String.contains m stat_char then begin 
-	      log ("RELATION " ^ (fst path) ^ " = " ^ string_of_int(List.length res) ^ ": ");
-              log (X.stop_time before ^ "\n")
-           end;
-           res
-	end
-   | M.Select (rvar, sexp, bexp) ->
-        let before = X.start_time() in
-        let rset = (exec_set_exp c sexp) in
-        let rec select_ex =
-         function
-	    [] -> []
-	  | r::tl -> 
-             let c1 = upd_rvars c ((rvar,r)::c.rvars) in                      
-              if (exec_boole_exp c1 bexp) then
-               r::(select_ex tl)
-              else
-               select_ex tl
-        in 
-	let res = select_ex rset in
-	if String.contains m stat_char then begin
-	   log ("SELECT " ^ rvar ^ " = " ^ string_of_int (List.length res) ^ ": ");
-	   log (X.stop_time before ^ "\n");
-        end;
-	res
-   | M.Diff (sexp1, sexp2) -> diff_ex (exec_set_exp c sexp1) (exec_set_exp c sexp2)
-   
-(* valuta una MathQL.boole_exp e ritorna un boole *)
+(*  AUTOR: Ferruccio Guidi <fguidi@cs.unibo.it>
+ *)
 
-and exec_boole_exp c =
- function
-    M.False      -> false
-  | M.True       -> true
-  | M.Not x      -> not (exec_boole_exp c x)
-  | M.And (x, y) -> (exec_boole_exp c x) && (exec_boole_exp c y)
-  | M.Or (x, y)  -> (exec_boole_exp c x) || (exec_boole_exp c y)
-  | M.Sub (vexp1, vexp2) ->
-     sub_ex (exec_val_exp c vexp1) (exec_val_exp c vexp2)
-  | M.Meet (vexp1, vexp2) ->
-     meet_ex (exec_val_exp c vexp1) (exec_val_exp c vexp2)
-  | M.Eq (vexp1, vexp2) -> (exec_val_exp c vexp1) = (exec_val_exp c vexp2)
-  | M.Ex l bexp -> 
-     if l = [] then
-      (exec_boole_exp c bexp)
-     else
-   	 let latt =
-          List.map
-           (fun uri -> 
-             let (r,attl) =
-              (try
-                List.assoc uri c.rvars
-               with Not_found -> assert false)
-             in
-              (uri,attl)
-           ) l (*latt = l + attributi*)
+exception Found
+
+module U = AvsUtil
+module M = MathQL
+module I = M.I
+module P = MQueryUtil 
+module C = MQIConn
+module L = MQILib
+module F = MQueryIO
+
+(* contexts *****************************************************************)
+
+type svar_context = (M.svar * M.result) list
+
+type avar_context = (M.avar * (string * M.group list)) list
+
+type group_context = (M.avar * M.group) list
+
+type context = {svars: svar_context;   
+                avars: avar_context;   
+                groups: group_context (* auxiliary context *)  
+               }
+	       
+(* execute ******************************************************************)
+
+let execute h x =
+   let warn q = 
+     if C.set h C.Warn then 
+     begin
+        C.log h "MQIExecute: waring: reference to undefined variables: ";
+	F.text_of_query (C.log h) "\n" q
+     end
+   in
+   let rec eval_query c = function
+      | M.Const r -> 
+         let aux2 s g = I.make s (eval_list c g) in
+         let aux (s, gl) = 
+	    if gl = [] then U.avs_of_string s else U.iter (aux2 s) gl
+	 in 
+         c, U.iter aux r
+      | M.Dot (i, p) -> 
+         begin
+            try c, I.grp_read (List.assoc i c.groups) p 
+	    with Not_found -> warn (M.Dot (i, p)); c, I.empty 
+	 end
+      | M.Ex (l, y) -> 
+         let rec ex_aux h = function
+	    | []        -> 
+	       let d = {c with groups = h} in
+               if snd (eval_query d y) = U.val_false then () else raise Found 
+	    | i :: tail -> 
+               begin
+	          try 
+		     let (_, a) = List.assoc i c.avars in 
+		     let rec add_group = function
+		        | []     -> ()
+	                | g :: t -> ex_aux ((i, g) :: h) tail; add_group t 
+		     in
+		     add_group a
+	          with Not_found -> ()
+	       end
+         in
+	 begin try ex_aux [] l; c, U.val_false with Found -> c, U.val_true end
+      | M.SVar i -> 
+         begin
+            try c, List.assoc i c.svars 
+	    with Not_found -> warn (M.SVar i); c, I.empty
+	 end  
+      | M.AVar i -> 
+         begin
+            try 
+	       let s, gl = List.assoc i c.avars in
+	       c, U.make_x s gl  
+	    with Not_found -> warn (M.AVar i); c, I.empty
+	 end
+      | M.Let (Some i, x1, x2) ->
+	 let d, r = eval_query c x1 in
+	 let d = {d with svars = P.add_assoc (i, r) d.svars} in
+         eval_query d x2
+      | M.Let (None, x1, x2) ->
+	 let d, r = eval_query c x1 in eval_query d x2
+      | M.For (k, i, x1, x2) ->
+         let f = match k with
+	    | M.GenFJoin -> I.union
+	    | M.GenFMeet -> I.intersect
 	 in
-	  try
-	   let rec prod c =
-            function
-	       [] -> if (exec_boole_exp c bexp) then raise BooleExpTrue 
-	     | (uri,attl)::tail1 ->
-                 (*per ogni el. di attl devo andare in ric. su tail1*)
-                 let rec sub_prod attl =
-                  match attl with
-                     [] -> () 
-                   | att::tail2 ->
-                      let c1 = upd_groups c ((uri,att)::c.groups) in
-                       prod c1 tail1; sub_prod tail2 
-                 in	      
-                  sub_prod attl 
-   	   in
-	    prod c latt;
-            false
-	  with BooleExpTrue -> true
-
-(* valuta una MathQL.val_exp e ritorna un MathQL.value *)
-
-and exec_val_exp c = function
-     M.Const x -> let
-        ol = List.sort compare x in 
-   			let rec edup = function
-			
-			   [] -> [] 
-			 | s::tl -> if tl <> [] then  
-			                         if s = (List.hd tl) then edup tl
-			                         else s::(edup tl)
-				    else s::[]
-	                in
-			 edup ol
-   | M.Record (rvar, path) ->
-      (try
-        List.assoc path
-         (try
-           List.assoc rvar c.groups
-          with Not_found ->
-           raise (RVarUnbound rvar))
-       with Not_found ->
-        raise (PathUnbound path))
-   | M.VVar s ->
-      (try
-        List.assoc s c.vvars
-       with Not_found ->
-        raise (VVarUnbound s))
-   | M.RefOf sexp -> List.map (fun (s,_) -> s) (exec_set_exp c sexp)
-   | M.Fun (s, vexp) -> fun_ex s (exec_val_exp c vexp)
-   | M.Property (inv, rop, path, vexp) -> property_ex rop path inv (exec_val_exp c vexp) 
-
-(* valuta una MathQL.set_exp nel contesto vuoto e ritorna un MathQL.resource_set *)
-in
-   exec_set_exp {svars = []; rvars = []; groups = []; vvars = []} x 
-
-(* new interface  ***********************************************************)
-
-module type Callbacks = 
-   sig
-      val log : string -> unit (* logging function *)
-   end
-
-module Make (C: Callbacks) =
-   struct
-      
-      let postgres = "P"
-      let galax = "G"
-      let stat = "S"
-      let quiet = "Q"
-      let warn = "W"
-
-      let execute m x = execute_aux C.log m x
-
-      let init m =
-        let default_connection_string =
-            "host=mowgli.cs.unibo.it dbname=helm_mowgli_new_schema user=helm"
-	in
-	let connection_string =
-            try Sys.getenv "POSTGRESQL_CONNECTION_STRING"
-            with Not_found -> default_connection_string 
-        in
-	if String.contains m galax_char then true else
-	   try Dbconn.init connection_string; true
-	   with ConnectionFailed s -> false
-
-      let close m =
-         if String.contains m galax_char then () else Dbconn.close ()
-   
-      let check m =
-         if String.contains m galax_char then false else
-	 try ignore (Dbconn.pgc ()); true with InvalidConnection -> false 
-	 
-   end
+         let for_aux (d, r) s gl _ =
+	    let d = {d with avars = P.add_assoc (i, (s, gl)) d.avars} in
+	    let d, s = eval_query d x2 in
+	    d, f r s
+	 in 
+	 let d, r = eval_query c x1 in
+	 I.x_iter for_aux (d, I.empty) (I.optimize r)
+      | M.While (k, x1, x2) ->
+         let f = match k with
+	    | M.GenFJoin -> I.union
+	    | M.GenFMeet -> I.intersect
+	 in
+         let rec while_aux (d, r) = 
+	    let d, b = eval_query d x1 in
+	    if b = U.val_false then d, r else 
+	    let d, s = eval_query d x2 in
+	    while_aux (d, f r s)
+	 in
+	 while_aux (c, U.val_false)
+      | M.Add (b, z, x) ->
+         let f = if b then I.d_union else I.union in
+	 let agl = eval_grp c z in	 
+	 let aux r sj gl _ = 
+	    I.union r (f (U.make_x sj gl) (U.make_x sj agl))
+	 in
+	 let _, r = eval_query c x in
+	 c, I.x_iter aux I.empty (I.optimize r)
+      | M.Property (q0, q1, q2, mc, ct, cfl, el, pat, y) ->
+	 let _, r = eval_query c y in
+	 let subj, mct = 
+	    if q0 then [], (pat, q2 @ mc, r) else (q2 @ mc), (pat, [], r)  
+	 in
+         let eval_cons (pat, p, y) = 
+	    let _, r = eval_query c y in (pat, q2 @ p, r)
+	 in
+	 let cons_true = mct :: List.map eval_cons ct in
+	 let cons_false = List.map (List.map eval_cons) cfl in
+	 let eval_exp (p, po) = (q2 @ p, po) in
+	 let exp = List.map eval_exp el in
+	 let t = P.start_time () in
+	 let r = MQIProperty.exec h q1 subj cons_true cons_false exp in 
+	 let s = P.stop_time t in
+         if C.set h C.Stat then 
+	    C.log h (Printf.sprintf "Property: %s,%i\n" s (U.count r));
+	 c, r 
+      | M.Select (i, x, y) ->
+         let aux (d, r) sj gl _ =
+	    let d = {d with avars = P.add_assoc (i, (sj, gl)) d.avars} in
+	    let d, s = eval_query d y in
+	    if s = U.val_false then d, r else d, (I.union r (U.make_x sj gl))
+	 in
+	 let d, r = eval_query c x in
+         I.x_iter aux (d, I.empty) (I.optimize r) 
+      | M.Fun (p, pl, xl) ->        
+	 let e = {L.eval = (fun x -> snd (eval_query c x)); L.conn = h} in
+         c, L.fun_eval e (F.text_out_spec (C.log h) "\n") F.text_in_spec 
+            p pl xl
+      | M.Gen (p, xl) -> 
+         let e = {L.eval = (fun x -> snd (eval_query c x)); L.conn = h} in
+	 eval_query c (L.gen_eval e p xl)
+   and eval_list c l =
+      let aux (p, y) = 
+         let _, r = eval_query c y in
+         U.x_grp_make_x p r
+      in
+      U.grp_iter aux l
+   and eval_grp c = function
+      | M.Attr gs ->
+	 let attr_auxs s l = I.grps_make s (eval_list c l) in
+	 List.fold_left attr_auxs [] gs
+      | M.From i ->
+         try snd (List.assoc i c.avars) 
+	 with Not_found -> warn (M.AVar i); []
+   in
+   let c = {svars = []; avars = []; groups = []} in
+   let t = P.start_time () in
+   let _, r = eval_query c x in
+   let s = P.stop_time t in
+   if C.set h C.Stat then 
+      C.log h (Printf.sprintf "MQIExecute: %s,%s\n" s 
+         (C.string_of_flags (C.flags h)));
+   r