1 (* Copyright (C) 2000, HELM Team.
3 * This file is part of HELM, an Hypertextual, Electronic
4 * Library of Mathematics, developed at the Computer Science
5 * Department, University of Bologna, Italy.
7 * HELM is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU General Public License
9 * as published by the Free Software Foundation; either version 2
10 * of the License, or (at your option) any later version.
12 * HELM is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 * GNU General Public License for more details.
17 * You should have received a copy of the GNU General Public License
18 * along with HELM; if not, write to the Free Software
19 * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
22 * For details, see the HELM World-Wide-Web page,
23 * http://cs.unibo.it/helm/.
30 * implementazione del'interprete MathQL
48 exception SVarUnbound of string;;
49 exception RVarUnbound of string;;
50 exception VVarUnbound of string;;
51 exception PathUnbound of (string * string list);;
53 exception BooleExpTrue
55 let init connection_param = Dbconn.init connection_param
57 let close () = Dbconn.close ()
60 let status = Dbconn.pgc ()
65 let set_stat b = stat := b
67 let get_stat () = ! stat
69 let postgres_db = "postgres"
71 let galax_db = "galax"
73 let dbname = ref galax_db
76 if s = postgres_db || s = galax_db then dbname := s
77 else raise (Invalid_argument s)
79 let get_database () = ! dbname
81 (* valuta una MathQL.set_exp e ritorna un MathQL.resource_set *)
83 let rec exec_set_exp c = function
86 List.assoc svar c.svars
88 raise (SVarUnbound svar))
91 [List.assoc rvar c.rvars]
93 raise (RVarUnbound rvar))
94 | MathQL.Ref vexp -> List.map (fun s -> (s,[])) (exec_val_exp c vexp)
95 | MathQL.Pattern vexp -> pattern_ex (exec_val_exp c vexp)
96 | MathQL.Intersect (sexp1, sexp2) ->
97 let before = Sys.time() in
98 let rs1 = exec_set_exp c sexp1 in
99 let rs2 = exec_set_exp c sexp2 in
100 let res = intersect_ex rs1 rs2 in
101 let after = Sys.time() in
102 let ll1 = string_of_int (List.length rs1) in
103 let ll2 = string_of_int (List.length rs2) in
104 let diff = string_of_float (after -. before) in
106 (prerr_endline("INTERSECT(" ^ ll1 ^ "," ^ ll2 ^ ") = " ^ string_of_int (List.length res) ^
110 | MathQL.Union (sexp1, sexp2) ->
111 let before = Sys.time () in
112 let res = union_ex (exec_set_exp c sexp1) (exec_set_exp c sexp2) in
113 let after = Sys.time() in
114 let diff = string_of_float (after -. before) in
116 (prerr_endline ("UNION: " ^ diff ^ "s");
119 | MathQL.LetSVar (svar, sexp1, sexp2) ->
120 let before = Sys.time() in
121 let c1 = upd_svars c ((svar, exec_set_exp c sexp1) :: c.svars) in
122 let res = exec_set_exp c1 sexp2 in
124 (prerr_string ("LETIN " ^ svar ^ " = " ^ string_of_int (List.length res) ^ ": ");
125 prerr_endline (string_of_float (Sys.time() -. before) ^ "s");
128 | MathQL.LetVVar (vvar, vexp, sexp) ->
129 let before = Sys.time() in
130 let c1 = upd_vvars c ((vvar, exec_val_exp c vexp) :: c.vvars) in
131 let res = exec_set_exp c1 sexp in
133 (prerr_string ("LETIN " ^ vvar ^ " = " ^ string_of_int (List.length res) ^ ": ");
134 prerr_endline (string_of_float (Sys.time() -. before) ^ "s");
137 | MathQL.Relation (inv, rop, path, sexp, assl) ->
138 let before = Sys.time() in
139 if ! dbname = postgres_db then
140 (let res = relation_ex inv rop path (exec_set_exp c sexp) assl in
142 (prerr_string ("RELATION " ^ (fst path) ^ " = " ^ string_of_int(List.length res) ^ ": ");
143 prerr_endline (string_of_float (Sys.time() -. before) ^ "s");
148 (let res = relation_galax_ex inv rop path (exec_set_exp c sexp) assl in
150 (prerr_string ("RELATION-GALAX " ^ (fst path) ^ " = " ^ string_of_int(List.length res) ^ ": ");
151 prerr_endline (string_of_float (Sys.time() -. before) ^ "s");
156 | MathQL.Select (rvar, sexp, bexp) ->
157 let before = Sys.time() in
158 let rset = (exec_set_exp c sexp) in
163 let c1 = upd_rvars c ((rvar,r)::c.rvars) in
164 if (exec_boole_exp c1 bexp) then
169 let res = select_ex rset in
171 (prerr_string ("SELECT " ^ rvar ^ " = " ^ string_of_int (List.length res) ^ ": ");
172 prerr_endline (string_of_float (Sys.time() -. before) ^ "s");
175 | MathQL.Diff (sexp1, sexp2) -> diff_ex (exec_set_exp c sexp1) (exec_set_exp c sexp2)
177 (* valuta una MathQL.boole_exp e ritorna un boole *)
179 and exec_boole_exp c =
181 MathQL.False -> false
182 | MathQL.True -> true
183 | MathQL.Not x -> not (exec_boole_exp c x)
184 | MathQL.And (x, y) -> (exec_boole_exp c x) && (exec_boole_exp c y)
185 | MathQL.Or (x, y) -> (exec_boole_exp c x) || (exec_boole_exp c y)
186 | MathQL.Sub (vexp1, vexp2) ->
187 sub_ex (exec_val_exp c vexp1) (exec_val_exp c vexp2)
188 | MathQL.Meet (vexp1, vexp2) ->
189 meet_ex (exec_val_exp c vexp1) (exec_val_exp c vexp2)
190 | MathQL.Eq (vexp1, vexp2) -> (exec_val_exp c vexp1) = (exec_val_exp c vexp2)
191 | MathQL.Ex l bexp ->
193 (exec_boole_exp c bexp)
200 List.assoc uri c.rvars
201 with Not_found -> assert false)
204 ) l (*latt = l + attributi*)
209 [] -> if (exec_boole_exp c bexp) then raise BooleExpTrue
210 | (uri,attl)::tail1 ->
211 (*per ogni el. di attl devo andare in ric. su tail1*)
212 let rec sub_prod attl =
216 let c1 = upd_groups c ((uri,att)::c.groups) in
217 prod c1 tail1; sub_prod tail2
223 with BooleExpTrue -> true
225 (* valuta una MathQL.val_exp e ritorna un MathQL.value *)
227 and exec_val_exp c = function
228 MathQL.Const x -> let
229 ol = List.sort compare x in
230 let rec edup = function
233 | s::tl -> if tl <> [] then
234 if s = (List.hd tl) then edup tl
239 | MathQL.Record (rvar, path) ->
243 List.assoc rvar c.groups
245 raise (RVarUnbound rvar))
247 raise (PathUnbound path))
252 raise (VVarUnbound s))
253 | MathQL.RefOf sexp -> List.map (fun (s,_) -> s) (exec_set_exp c sexp)
254 | MathQL.Fun (s, vexp) -> fun_ex s (exec_val_exp c vexp)
255 | MathQL.Property (inv, rop, path, vexp) -> property_ex rop path inv (exec_val_exp c vexp)
257 (* valuta una MathQL.set_exp nel contesto vuoto e ritorna un MathQL.resource_set *)
259 exec_set_exp {svars = []; rvars = []; groups = []; vvars = []} x