(* 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 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 -> List.assoc svar c.svars | MathQL.RVar rvar -> [List.assoc rvar c.rvars] | 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) = List.assoc uri c.rvars 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 -> let rec sub_prod attl = match attl with (*per ogni el. di attl *) [] -> () (*devo andare in ric. su tail1*) | 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) -> List.assoc path (List.assoc rvar c.groups) | MathQL.VVar s -> List.assoc s c.vvars | 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