+++ /dev/null
-(* 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
projects / helm.git / blobdiff