X-Git-Url: http://matita.cs.unibo.it/gitweb/?p=helm.git;a=blobdiff_plain;f=helm%2Focaml%2Fmathql_interpreter%2Fmqint.ml;fp=helm%2Focaml%2Fmathql_interpreter%2Fmqint.ml;h=0000000000000000000000000000000000000000;hp=b275de355372b898404fe49d85f668acb5fff179;hb=869549224eef6278a48c16ae27dd786376082b38;hpb=89262281b6e83bd2321150f81f1a0583645eb0c8 diff --git a/helm/ocaml/mathql_interpreter/mqint.ml b/helm/ocaml/mathql_interpreter/mqint.ml deleted file mode 100644 index b275de355..000000000 --- a/helm/ocaml/mathql_interpreter/mqint.ml +++ /dev/null @@ -1,254 +0,0 @@ -(* 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/. - *) - - - - -(* - * implementazione del'interprete MathQL - *) - - - - -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 BooleExpTrue - -let init connection_param = Dbconn.init connection_param - -let close () = Dbconn.close () - -let check () = - let status = Dbconn.pgc () - in () - -let stat = ref true - -let set_stat b = stat := b - -let get_stat () = ! stat - -let postgres_db = "postgres" - -let galax_db = "galax" - -let dbname = ref galax_db - -let set_database s = - if s = postgres_db || s = galax_db then dbname := s - else raise (Invalid_argument s) - -let get_database () = ! dbname - -(* valuta una MathQL.set_exp e ritorna un MathQL.resource_set *) - -let rec exec_set_exp c = function - MathQL.SVar svar -> - (try - List.assoc svar c.svars - with Not_found -> - raise (SVarUnbound svar)) - | MathQL.RVar rvar -> - (try - [List.assoc rvar c.rvars] - with Not_found -> - raise (RVarUnbound rvar)) - | MathQL.Ref vexp -> List.map (fun s -> (s,[])) (exec_val_exp c vexp) - | MathQL.Pattern vexp -> pattern_ex (exec_val_exp c vexp) - | MathQL.Intersect (sexp1, sexp2) -> - let before = Sys.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 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 - if !stat then - (print_endline("INTERSECT(" ^ ll1 ^ "," ^ ll2 ^ ") = " ^ string_of_int (List.length res) ^ - ": " ^ diff ^ "s"); - flush stdout); - res - | MathQL.Union (sexp1, sexp2) -> - let before = Sys.time () in - let res = union_ex (exec_set_exp c sexp1) (exec_set_exp c sexp2) in - let after = Sys.time() in - let diff = string_of_float (after -. before) in - if !stat then - (print_endline ("UNION: " ^ diff ^ "s"); - flush stdout); - res - | MathQL.LetSVar (svar, sexp1, sexp2) -> - let before = Sys.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 ! stat then - (print_string ("LETIN " ^ svar ^ " = " ^ string_of_int (List.length res) ^ ": "); - print_endline (string_of_float (Sys.time() -. before) ^ "s"); - flush stdout); - res - | MathQL.LetVVar (vvar, vexp, sexp) -> - let before = Sys.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 ! stat then - (print_string ("LETIN " ^ vvar ^ " = " ^ string_of_int (List.length res) ^ ": "); - print_endline (string_of_float (Sys.time() -. before) ^ "s"); - flush stdout); - res - | MathQL.Relation (inv, rop, path, sexp, assl) -> - let before = Sys.time() in - if ! dbname = postgres_db then - (let res = relation_ex inv rop path (exec_set_exp c sexp) assl in - if ! stat then - (print_string ("RELATION " ^ (fst path) ^ " = " ^ string_of_int(List.length res) ^ ": "); - print_endline (string_of_float (Sys.time() -. before) ^ "s"); - flush stdout); - res) - - else - (let res = relation_galax_ex inv rop path (exec_set_exp c sexp) assl in - if !stat then - (print_string ("RELATION-GALAX " ^ (fst path) ^ " = " ^ string_of_int(List.length res) ^ ": "); - print_endline (string_of_float (Sys.time() -. before) ^ "s"); - flush stdout); - res) - - - | MathQL.Select (rvar, sexp, bexp) -> - let before = Sys.time() in - let rset = (exec_set_exp c sexp) in - let rec select_ex rset = - match rset with - [] -> [] - | 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 ! stat then - (print_string ("SELECT " ^ rvar ^ " = " ^ string_of_int (List.length res) ^ ": "); - print_endline (string_of_float (Sys.time() -. before) ^ "s"); - flush stdout); - res - | MathQL.Diff (sexp1, sexp2) -> diff_ex (exec_set_exp c sexp1) (exec_set_exp c sexp2) - -(* valuta una MathQL.boole_exp e ritorna un boole *) - -and exec_boole_exp c = - function - MathQL.False -> false - | MathQL.True -> true - | MathQL.Not x -> not (exec_boole_exp c x) - | MathQL.And (x, y) -> (exec_boole_exp c x) && (exec_boole_exp c y) - | MathQL.Or (x, y) -> (exec_boole_exp c x) || (exec_boole_exp c y) - | MathQL.Sub (vexp1, vexp2) -> - sub_ex (exec_val_exp c vexp1) (exec_val_exp c vexp2) - | MathQL.Meet (vexp1, vexp2) -> - meet_ex (exec_val_exp c vexp1) (exec_val_exp c vexp2) - | MathQL.Eq (vexp1, vexp2) -> (exec_val_exp c vexp1) = (exec_val_exp c vexp2) - | MathQL.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*) - 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 - MathQL.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 - | MathQL.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)) - | MathQL.VVar s -> - (try - List.assoc s c.vvars - with Not_found -> - raise (VVarUnbound s)) - | MathQL.RefOf sexp -> List.map (fun (s,_) -> s) (exec_set_exp c sexp) - | MathQL.Fun (s, vexp) -> fun_ex s (exec_val_exp c vexp) - | MathQL.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 *) -and execute x = - exec_set_exp {svars = []; rvars = []; groups = []; vvars = []} x