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 BooleExpTrue
50 let init connection_param = Dbconn.init connection_param
52 let close () = Dbconn.close ()
55 let status = Dbconn.pgc ()
60 let set_stat b = stat := b
62 let get_stat () = ! stat
64 let postgres_db = "postgres"
66 let galax_db = "galax"
68 let dbname = ref galax_db
71 if s = postgres_db || s = galax_db then dbname := s
72 else raise (Invalid_argument s)
74 let get_database () = ! dbname
76 (* valuta una MathQL.set_exp e ritorna un MathQL.resource_set *)
78 let rec exec_set_exp c = function
79 MathQL.SVar svar -> List.assoc svar c.svars
80 | MathQL.RVar rvar -> [List.assoc rvar c.rvars]
81 | MathQL.Ref vexp -> List.map (fun s -> (s,[])) (exec_val_exp c vexp)
82 | MathQL.Intersect (sexp1, sexp2) ->
83 let before = Sys.time() in
84 let rs1 = exec_set_exp c sexp1 in
85 let rs2 = exec_set_exp c sexp2 in
86 let res = intersect_ex rs1 rs2 in
87 let after = Sys.time() in
88 let ll1 = string_of_int (List.length rs1) in
89 let ll2 = string_of_int (List.length rs2) in
90 let diff = string_of_float (after -. before) in
92 (print_endline("INTERSECT(" ^ ll1 ^ "," ^ ll2 ^ ") = " ^ string_of_int (List.length res) ^
96 | MathQL.Union (sexp1, sexp2) ->
97 let before = Sys.time () in
98 let res = union_ex (exec_set_exp c sexp1) (exec_set_exp c sexp2) in
99 let after = Sys.time() in
100 let diff = string_of_float (after -. before) in
102 (print_endline ("UNION: " ^ diff ^ "s");
105 | MathQL.LetSVar (svar, sexp1, sexp2) ->
106 let before = Sys.time() in
107 let c1 = upd_svars c ((svar, exec_set_exp c sexp1) :: c.svars) in
108 let res = exec_set_exp c1 sexp2 in
110 (print_string ("LETIN " ^ svar ^ " = " ^ string_of_int (List.length res) ^ ": ");
111 print_endline (string_of_float (Sys.time() -. before) ^ "s");
114 | MathQL.LetVVar (vvar, vexp, sexp) ->
115 let before = Sys.time() in
116 let c1 = upd_vvars c ((vvar, exec_val_exp c vexp) :: c.vvars) in
117 let res = exec_set_exp c1 sexp in
119 (print_string ("LETIN " ^ vvar ^ " = " ^ string_of_int (List.length res) ^ ": ");
120 print_endline (string_of_float (Sys.time() -. before) ^ "s");
123 | MathQL.Relation (inv, rop, path, sexp, attl) ->
124 let before = Sys.time() in
125 if ! dbname = postgres_db then
126 (let res = relation_ex rop path (exec_set_exp c sexp) attl in
128 (print_string ("RELATION " ^ (List.hd path) ^ " = " ^ string_of_int(List.length res) ^ ": ");
129 print_endline (string_of_float (Sys.time() -. before) ^ "s");
133 (let res = relation_galax_ex rop path (exec_set_exp c sexp) attl in
135 (print_string ("RELATION-GALAX " ^ (List.hd path) ^ " = " ^ string_of_int(List.length res) ^ ": ");
136 print_endline (string_of_float (Sys.time() -. before) ^ "s");
141 | MathQL.Select (rvar, sexp, bexp) ->
142 let before = Sys.time() in
143 let rset = (exec_set_exp c sexp) in
144 let rec select_ex rset =
147 | r::tl -> let c1 = upd_rvars c ((rvar,r)::c.rvars) in
148 if (exec_boole_exp c1 bexp) then r::(select_ex tl)
151 let res = select_ex rset in
153 (print_string ("SELECT " ^ rvar ^ " = " ^ string_of_int (List.length res) ^ ": ");
154 print_endline (string_of_float (Sys.time() -. before) ^ "s");
157 | MathQL.Diff (sexp1, sexp2) -> diff_ex (exec_set_exp c sexp1) (exec_set_exp c sexp2)
160 (* valuta una MathQL.boole_exp e ritorna un boole *)
162 and exec_boole_exp c = function
163 MathQL.False -> false
164 | MathQL.True -> true
165 | MathQL.Not x -> not (exec_boole_exp c x)
166 | MathQL.And (x, y) -> (exec_boole_exp c x) && (exec_boole_exp c y)
167 | MathQL.Or (x, y) -> (exec_boole_exp c x) || (exec_boole_exp c y)
168 | MathQL.Sub (vexp1, vexp2) -> sub_ex (exec_val_exp c vexp1) (exec_val_exp c vexp2)
169 | MathQL.Meet (vexp1, vexp2) -> meet_ex (exec_val_exp c vexp1) (exec_val_exp c vexp2)
170 | MathQL.Eq (vexp1, vexp2) -> (exec_val_exp c vexp1) = (exec_val_exp c vexp2)
171 | MathQL.Ex l bexp ->
172 if l = [] then (exec_boole_exp c bexp)
174 let latt = List.map (fun uri ->
175 let (r,attl) = List.assoc uri c.rvars in (uri,attl)) l (*latt = l + attributi*)
178 let rec prod c = function
179 [] -> if (exec_boole_exp c bexp) then raise BooleExpTrue
180 | (uri,attl)::tail1 -> let rec sub_prod attl =
182 (*per ogni el. di attl *) [] -> ()
183 (*devo andare in ric. su tail1*) | att::tail2 -> let c1 = upd_groups c ((uri,att)::c.groups) in
184 prod c1 tail1; sub_prod tail2
189 with BooleExpTrue -> true
191 (* valuta una MathQL.val_exp e ritorna un MathQL.value *)
193 and exec_val_exp c = function
194 MathQL.Const x -> let
195 ol = List.sort compare x in
196 let rec edup = function
199 | s::tl -> if tl <> [] then
200 if s = (List.hd tl) then edup tl
205 | MathQL.Record (rvar, vvar) -> List.assoc vvar (List.assoc rvar c.groups)
207 | MathQL.VVar s -> List.assoc s c.vvars
208 | MathQL.RefOf sexp -> List.map (fun (s,_) -> s) (exec_set_exp c sexp)
209 | MathQL.Fun (s, vexp) -> fun_ex s (exec_val_exp c vexp)
210 | MathQL.Attribute (inv, rop, path, vexp) -> attribute_ex rop path inv (exec_val_exp c vexp)
212 (* valuta una MathQL.set_exp nel contesto vuoto e ritorna un MathQL.resource_set *)
214 exec_set_exp {svars = []; rvars = []; groups = []; vvars = []} x