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 Property;;
  41 open Sub;;
  42 open Context;;
  43 open Diff;;
  44 open Relation;;
  45 open Func;;
  46 open Pattern;;
  47
  48 exception SVarUnbound of string;;
  49 exception RVarUnbound of string;;
  50 exception VVarUnbound of string;;
  51 exception PathUnbound of (string * string list);;
  52
  53 exception BooleExpTrue
  54
  55 let init connection_param = Dbconn.init connection_param
  56
  57 let close () = Dbconn.close ()
  58
  59 let check () =
  60    let status = Dbconn.pgc ()
  61    in ()
  62
  63 let stat = ref true
  64
  65 let set_stat b = stat := b
  66
  67 let get_stat () = ! stat
  68
  69 let postgres_db = "postgres"
  70
  71 let galax_db = "galax"
  72
  73 let dbname = ref galax_db
  74
  75 let set_database s =
  76     if s = postgres_db || s = galax_db then dbname := s
  77     else raise (Invalid_argument s)
  78
  79 let get_database () = ! dbname
  80
  81 (* valuta una MathQL.set_exp e ritorna un MathQL.resource_set *)
  82
  83 let rec exec_set_exp c = function
  84      MathQL.SVar svar ->
  85       (try
  86         List.assoc svar c.svars
  87        with Not_found ->
  88         raise (SVarUnbound svar))
  89    | MathQL.RVar rvar ->
  90       (try
  91         [List.assoc rvar c.rvars]
  92        with Not_found ->
  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
 105         if !stat then
 106         (prerr_endline("INTERSECT(" ^ ll1 ^ "," ^ ll2 ^ ") = " ^ string_of_int (List.length res) ^
 107          ": " ^ diff ^ "s");
 108          flush stdout);
 109         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
 115         if !stat then
 116         (prerr_endline ("UNION: " ^ diff ^ "s");
 117          flush stdout);
 118         res
 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
 123         if ! stat then
 124         (prerr_string ("LETIN " ^ svar ^ " = " ^ string_of_int (List.length res) ^ ": ");
 125          prerr_endline (string_of_float (Sys.time() -. before) ^ "s");
 126          flush stdout);
 127         res
 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
 132         if ! stat then
 133         (prerr_string ("LETIN " ^ vvar ^ " = " ^ string_of_int (List.length res) ^ ": ");
 134          prerr_endline (string_of_float (Sys.time() -. before) ^ "s");
 135          flush stdout);
 136         res
 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
 141          if ! stat then
 142          (prerr_string ("RELATION " ^ (fst path) ^ " = " ^ string_of_int(List.length res) ^ ": ");
 143           prerr_endline (string_of_float (Sys.time() -. before) ^ "s");
 144           flush stdout);
 145          res)
 146
 147         else
 148         (let res = relation_galax_ex inv rop path (exec_set_exp c sexp) assl in
 149          if !stat then
 150          (prerr_string ("RELATION-GALAX " ^ (fst path) ^ " = " ^ string_of_int(List.length res) ^ ": ");
 151           prerr_endline (string_of_float (Sys.time() -. before) ^ "s");
 152           flush stdout);
 153          res)
 154
 155
 156    | MathQL.Select (rvar, sexp, bexp) ->
 157         let before = Sys.time() in
 158         let rset = (exec_set_exp c sexp) in
 159         let rec select_ex =
 160          function
 161             [] -> []
 162           | r::tl ->
 163              let c1 = upd_rvars c ((rvar,r)::c.rvars) in
 164               if (exec_boole_exp c1 bexp) then
 165                r::(select_ex tl)
 166               else
 167                select_ex tl
 168         in
 169         let res = select_ex rset in
 170         if ! stat then
 171         (prerr_string ("SELECT " ^ rvar ^ " = " ^ string_of_int (List.length res) ^ ": ");
 172          prerr_endline (string_of_float (Sys.time() -. before) ^ "s");
 173          flush stdout);
 174         res
 175    | MathQL.Diff (sexp1, sexp2) -> diff_ex (exec_set_exp c sexp1) (exec_set_exp c sexp2)
 176
 177 (* valuta una MathQL.boole_exp e ritorna un boole *)
 178
 179 and exec_boole_exp c =
 180  function
 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 ->
 192      if l = [] then
 193       (exec_boole_exp c bexp)
 194      else
 195          let latt =
 196           List.map
 197            (fun uri ->
 198              let (r,attl) =
 199               (try
 200                 List.assoc uri c.rvars
 201                with Not_found -> assert false)
 202              in
 203               (uri,attl)
 204            ) l (*latt = l + attributi*)
 205          in
 206           try
 207            let rec prod c =
 208             function
 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 =
 213                   match attl with
 214                      [] -> ()
 215                    | att::tail2 ->
 216                       let c1 = upd_groups c ((uri,att)::c.groups) in
 217                        prod c1 tail1; sub_prod tail2
 218                  in
 219                   sub_prod attl
 220            in
 221             prod c latt;
 222             false
 223           with BooleExpTrue -> true
 224
 225 (* valuta una MathQL.val_exp e ritorna un MathQL.value *)
 226
 227 and exec_val_exp c = function
 228      MathQL.Const x -> let
 229         ol = List.sort compare x in
 230                         let rec edup = function
 231
 232                            [] -> []
 233                          | s::tl -> if tl <> [] then
 234                                                  if s = (List.hd tl) then edup tl
 235                                                  else s::(edup tl)
 236                                     else s::[]
 237                         in
 238                          edup ol
 239    | MathQL.Record (rvar, path) ->
 240       (try
 241         List.assoc path
 242          (try
 243            List.assoc rvar c.groups
 244           with Not_found ->
 245            raise (RVarUnbound rvar))
 246        with Not_found ->
 247         raise (PathUnbound path))
 248    | MathQL.VVar s ->
 249       (try
 250         List.assoc s c.vvars
 251        with Not_found ->
 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)
 256
 257 (* valuta una MathQL.set_exp nel contesto vuoto e ritorna un MathQL.resource_set *)
 258 and execute x =
 259    exec_set_exp {svars = []; rvars = []; groups = []; vvars = []} x