]> matita.cs.unibo.it Git - helm.git/blob - helm/ocaml/mathql_interpreter/mqint.ml
Switching interpreter.
[helm.git] / helm / ocaml / mathql_interpreter / mqint.ml
1 (* Copyright (C) 2000, HELM Team.
2  * 
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.
6  * 
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.
11  * 
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.
16  *
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,
20  * MA  02111-1307, USA.
21  * 
22  * For details, see the HELM World-Wide-Web page,
23  * http://cs.unibo.it/helm/.
24  *)
25
26
27
28
29 (*
30  * implementazione del'interprete MathQL
31  *)
32
33
34
35
36 open Dbconn;;
37 open Union;;
38 open Intersect;;
39 open Meet;;
40 open Sub;;
41 open Context;;
42 open Diff;;
43 open Relation;;
44 open Func;;
45
46
47 exception BooleExpTrue
48
49 let init connection_param = Dbconn.init connection_param 
50
51 let close () = Dbconn.close ()
52
53 let check () = 
54    let status = Dbconn.pgc () 
55    in ()
56
57 let stat = ref false
58
59 let set_stat b = stat := b
60
61 let get_stat () = ! stat
62
63 let dbname = ref "db-postgres"
64
65 let set_database db = dbname := db  
66
67 (* valuta una MathQL.set_exp e ritorna un MathQL.resource_set *)
68
69 let rec exec_set_exp c = function
70      MathQL.SVar svar -> List.assoc svar c.svars
71    | MathQL.RVar rvar -> [List.assoc rvar c.rvars]  
72    | MathQL.Ref vexp -> List.map (fun s -> (s,[])) (exec_val_exp c vexp)
73    | MathQL.Intersect (sexp1, sexp2) ->    
74         let before = Sys.time() in
75         let rs1 = exec_set_exp c sexp1 in
76         let rs2 = exec_set_exp c sexp2 in
77         let res = intersect_ex rs1 rs2 in
78         let after = Sys.time() in
79         let ll1 = string_of_int (List.length rs1) in
80         let ll2 = string_of_int (List.length rs2) in
81         let diff = string_of_float (after -. before) in
82         if !stat then
83         (print_endline("INTERSECT(" ^ ll1 ^ "," ^ ll2 ^ ") = " ^ string_of_int (List.length res) ^
84          ": " ^ diff ^ "s");
85          flush stdout);
86         res
87    | MathQL.Union (sexp1, sexp2) -> 
88         let before = Sys.time () in
89         let res = union_ex (exec_set_exp c sexp1) (exec_set_exp c sexp2) in
90         let after = Sys.time() in
91         let diff = string_of_float (after -. before) in
92         if !stat then
93         (print_endline ("UNION: " ^ diff ^ "s");
94          flush stdout);
95         res                     
96    | MathQL.LetSVar (svar, sexp1, sexp2) ->
97         let before = Sys.time() in
98         let c1 = upd_svars c ((svar, exec_set_exp c sexp1) :: c.svars) in 
99         let res = exec_set_exp c1 sexp2 in
100         if !stat then
101         (print_string ("LETIN " ^ svar ^ " = " ^ string_of_int (List.length res) ^ ": ");
102          print_endline (string_of_float (Sys.time() -. before) ^ "s");
103          flush stdout); 
104         res                     
105    | MathQL.LetVVar (vvar, vexp, sexp) ->
106         let before = Sys.time() in
107         let c1 = upd_vvars c ((vvar, exec_val_exp c vexp) :: c.vvars) in
108         let res = exec_set_exp c1 sexp in
109         if !stat then
110         (print_string ("LETIN " ^ vvar ^ " = " ^ string_of_int (List.length res) ^ ": ");
111          print_endline (string_of_float (Sys.time() -. before) ^ "s");
112          flush stdout); 
113         res
114    | MathQL.Relation (rop, path, sexp, attl) -> 
115         let before = Sys.time() in
116         if !dbname = "db-postgres" then
117         (let res = relation_ex rop path (exec_set_exp c sexp) attl in
118          if !stat then 
119          (print_string ("RELATION " ^ (List.hd path) ^ " = " ^ string_of_int(List.length res) ^ ": ");
120           print_endline (string_of_float (Sys.time() -. before) ^ "s");
121           flush stdout);
122          res)
123         else
124         (let res = relation_galax_ex rop path (exec_set_exp c sexp) attl in
125          if !stat then
126          (print_string ("RELATION-GALAX " ^ (List.hd path) ^ " = " ^ string_of_int(List.length res) ^ ": ");
127           print_endline (string_of_float (Sys.time() -. before) ^ "s");
128           flush stdout);
129          res) 
130         
131         
132    | MathQL.Select (rvar, sexp, bexp) ->
133         let before = Sys.time() in
134         let rset = (exec_set_exp c sexp) in
135         let rec select_ex rset =
136         match rset with 
137           [] -> []
138         | r::tl -> let c1 = upd_rvars c ((rvar,r)::c.rvars) in                      
139                    if (exec_boole_exp c1 bexp) then r::(select_ex tl)
140                    else select_ex tl
141         in 
142         let res = select_ex rset in
143         if !stat then
144         (print_string ("SELECT " ^ rvar ^ " = " ^ string_of_int (List.length res) ^ ": ");
145          print_endline (string_of_float (Sys.time() -. before) ^ "s");
146          flush stdout); 
147         res
148    | MathQL.Diff (sexp1, sexp2) -> diff_ex (exec_set_exp c sexp1) (exec_set_exp c sexp2)
149    | _ -> assert false
150    
151 (* valuta una MathQL.boole_exp e ritorna un boole *)
152
153 and exec_boole_exp c = function
154      MathQL.False      -> false
155    | MathQL.True       -> true
156    | MathQL.Not x      -> not (exec_boole_exp c x)
157    | MathQL.And (x, y) -> (exec_boole_exp c x) && (exec_boole_exp c y)
158    | MathQL.Or (x, y)  -> (exec_boole_exp c x) || (exec_boole_exp c y)
159    | MathQL.Sub (vexp1, vexp2) -> sub_ex (exec_val_exp c vexp1) (exec_val_exp c vexp2)
160    | MathQL.Meet (vexp1, vexp2) -> meet_ex (exec_val_exp c vexp1) (exec_val_exp c vexp2)
161    | MathQL.Eq (vexp1, vexp2) -> (exec_val_exp c vexp1) = (exec_val_exp c vexp2)
162    | MathQL.Ex l bexp -> 
163         if l = [] then (exec_boole_exp c bexp)
164         else
165          let latt = List.map (fun uri -> 
166                                 let (r,attl) = List.assoc uri c.rvars in (uri,attl)) l (*latt = l + attributi*)
167          in
168          try
169          let rec prod c = function
170               [] -> if (exec_boole_exp c bexp) then raise BooleExpTrue 
171             | (uri,attl)::tail1 -> let rec sub_prod attl =
172                                       match attl with
173 (*per ogni el. di attl  *)              [] -> () 
174 (*devo andare in ric. su tail1*)      | att::tail2 -> let c1 = upd_groups c ((uri,att)::c.groups) in             
175                                                        prod c1 tail1; sub_prod tail2 
176                                      in       
177                                       sub_prod attl 
178          in
179          prod c latt; false
180          with BooleExpTrue -> true
181
182 (* valuta una MathQL.val_exp e ritorna un MathQL.value *)
183
184 and exec_val_exp c = function
185      MathQL.Const x -> let
186         ol = List.sort compare x in 
187                         let rec edup = function
188                         
189                            [] -> [] 
190                          | s::tl -> if tl <> [] then  
191                                                  if s = (List.hd tl) then edup tl
192                                                  else s::(edup tl)
193                                     else s::[]
194                         in
195                          edup ol
196    | MathQL.Record (rvar, vvar) -> List.assoc vvar (List.assoc rvar c.groups) 
197                                   
198    | MathQL.VVar s -> List.assoc s c.vvars                                
199    | MathQL.RefOf sexp -> List.map (fun (s,_) -> s) (exec_set_exp c sexp)
200    | MathQL.Fun (s, vexp) -> fun_ex s (exec_val_exp c vexp)
201    | MathQL.Attribute (rop, path, vexp) -> [] 
202
203 (* valuta una MathQL.set_exp nel contesto vuoto e ritorna un MathQL.resource_set *)
204 and execute x =
205    exec_set_exp {svars = []; rvars = []; groups = []; vvars = []} x