helm/ocaml/mathql_interpreter/mQueryInterpreter.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 open Dbconn;;
  27 open Union;;
  28 open Intersect;;
  29 open Meet;;
  30 open Property;;
  31 open Sub;;
  32 open Context;;
  33 open Diff;;
  34 open Relation;;
  35 open Func;;
  36 open Pattern;;
  37
  38 exception SVarUnbound of string;;
  39 exception RVarUnbound of string;;
  40 exception VVarUnbound of string;;
  41 exception PathUnbound of (string * string list);;
  42
  43 exception BooleExpTrue
  44
  45 (* valuta una MathQL.set_exp e ritorna un MathQL.resource_set *)
  46
  47 let galax_char = 'G'
  48 let stat_char = 'S'
  49
  50 let execute_aux handle x =
  51    let module M = MathQL in
  52    let module X = MQueryMisc in
  53 let rec exec_set_exp c = function
  54      M.SVar svar ->
  55       (try
  56         List.assoc svar c.svars
  57        with Not_found ->
  58         raise (SVarUnbound svar))
  59    | M.RVar rvar ->
  60       (try
  61         [List.assoc rvar c.rvars]
  62        with Not_found ->
  63         raise (RVarUnbound rvar))
  64    | M.Ref vexp -> List.map (fun s -> (s,[])) (exec_val_exp c vexp)
  65    | M.Pattern vexp -> pattern_ex handle (exec_val_exp c vexp)
  66    | M.Intersect (sexp1, sexp2) ->
  67         let before = X.start_time() in
  68         let rs1 = exec_set_exp c sexp1 in
  69         let rs2 = exec_set_exp c sexp2 in
  70         let res = intersect_ex rs1 rs2 in
  71         let diff = X.stop_time before in
  72         let ll1 = string_of_int (List.length rs1) in
  73         let ll2 = string_of_int (List.length rs2) in
  74         if MQIConn.set handle MQIConn.Stat then
  75         MQIConn.log handle ("INTERSECT(" ^ ll1 ^ "," ^ ll2 ^ ") = " ^ string_of_int (List.length res) ^
  76          ": " ^ diff ^ "\n");
  77         res
  78    | M.Union (sexp1, sexp2) ->
  79         let before = X.start_time () in
  80         let res = union_ex (exec_set_exp c sexp1) (exec_set_exp c sexp2) in
  81         let diff = X.stop_time before in
  82         if MQIConn.set handle MQIConn.Stat then MQIConn.log handle ("UNION: " ^ diff ^ "\n");
  83         res
  84    | M.LetSVar (svar, sexp1, sexp2) ->
  85         let before = X.start_time() in
  86         let c1 = upd_svars c ((svar, exec_set_exp c sexp1) :: c.svars) in
  87         let res = exec_set_exp c1 sexp2 in
  88         if MQIConn.set handle MQIConn.Stat then begin
  89            MQIConn.log handle ("LETIN " ^ svar ^ " = " ^ string_of_int (List.length res) ^ ": ");
  90            MQIConn.log handle (X.stop_time before ^ "\n");
  91         end;
  92         res
  93    | M.LetVVar (vvar, vexp, sexp) ->
  94         let before = X.start_time() in
  95         let c1 = upd_vvars c ((vvar, exec_val_exp c vexp) :: c.vvars) in
  96         let res = exec_set_exp c1 sexp in
  97         if MQIConn.set handle MQIConn.Stat then begin
  98            MQIConn.log handle ("LETIN " ^ vvar ^ " = " ^ string_of_int (List.length res) ^ ": ");
  99            MQIConn.log handle (X.stop_time before ^ "\n");
 100         end;
 101         res
 102    | M.Relation (inv, rop, path, sexp, assl) ->
 103         let before = X.start_time() in
 104         if MQIConn.set handle MQIConn.Galax  then begin
 105            let res = relation_galax_ex handle inv rop path (exec_set_exp c sexp) assl in
 106            if MQIConn.set handle MQIConn.Stat then begin
 107               MQIConn.log handle  ("RELATION-GALAX " ^ (fst path) ^ " = " ^ string_of_int(List.length res) ^ ": ");
 108               MQIConn.log handle (X.stop_time before ^ "\n")
 109           end;
 110           res
 111         end else begin
 112            let res = relation_ex handle inv rop path (exec_set_exp c sexp) assl in
 113            if MQIConn.set handle MQIConn.Stat then begin
 114               MQIConn.log handle ("RELATION " ^ (fst path) ^ " = " ^ string_of_int(List.length res) ^ ": ");
 115               MQIConn.log handle (X.stop_time before ^ "\n")
 116            end;
 117            res
 118         end
 119    | M.Select (rvar, sexp, bexp) ->
 120         let before = X.start_time() in
 121         let rset = (exec_set_exp c sexp) in
 122         let rec select_ex =
 123          function
 124             [] -> []
 125           | r::tl ->
 126              let c1 = upd_rvars c ((rvar,r)::c.rvars) in
 127               if (exec_boole_exp c1 bexp) then
 128                r::(select_ex tl)
 129               else
 130                select_ex tl
 131         in
 132         let res = select_ex rset in
 133         if MQIConn.set handle MQIConn.Stat then begin
 134            MQIConn.log handle ("SELECT " ^ rvar ^ " = " ^ string_of_int (List.length res) ^ ": ");
 135            MQIConn.log handle (X.stop_time before ^ "\n");
 136         end;
 137         res
 138    | M.Diff (sexp1, sexp2) -> diff_ex (exec_set_exp c sexp1) (exec_set_exp c sexp2)
 139
 140 (* valuta una MathQL.boole_exp e ritorna un boole *)
 141
 142 and exec_boole_exp c =
 143  function
 144     M.False      -> false
 145   | M.True       -> true
 146   | M.Not x      -> not (exec_boole_exp c x)
 147   | M.And (x, y) -> (exec_boole_exp c x) && (exec_boole_exp c y)
 148   | M.Or (x, y)  -> (exec_boole_exp c x) || (exec_boole_exp c y)
 149   | M.Sub (vexp1, vexp2) ->
 150      sub_ex (exec_val_exp c vexp1) (exec_val_exp c vexp2)
 151   | M.Meet (vexp1, vexp2) ->
 152      meet_ex (exec_val_exp c vexp1) (exec_val_exp c vexp2)
 153   | M.Eq (vexp1, vexp2) -> (exec_val_exp c vexp1) = (exec_val_exp c vexp2)
 154   | M.Ex l bexp ->
 155      if l = [] then
 156       (exec_boole_exp c bexp)
 157      else
 158          let latt =
 159           List.map
 160            (fun uri ->
 161              let (r,attl) =
 162               (try
 163                 List.assoc uri c.rvars
 164                with Not_found -> assert false)
 165              in
 166               (uri,attl)
 167            ) l (*latt = l + attributi*)
 168          in
 169           try
 170            let rec prod c =
 171             function
 172                [] -> if (exec_boole_exp c bexp) then raise BooleExpTrue
 173              | (uri,attl)::tail1 ->
 174                  (*per ogni el. di attl devo andare in ric. su tail1*)
 175                  let rec sub_prod attl =
 176                   match attl with
 177                      [] -> ()
 178                    | att::tail2 ->
 179                       let c1 = upd_groups c ((uri,att)::c.groups) in
 180                        prod c1 tail1; sub_prod tail2
 181                  in
 182                   sub_prod attl
 183            in
 184             prod c latt;
 185             false
 186           with BooleExpTrue -> true
 187
 188 (* valuta una MathQL.val_exp e ritorna un MathQL.value *)
 189
 190 and exec_val_exp c = function
 191      M.Const x -> let
 192         ol = List.sort compare x in
 193                         let rec edup = function
 194
 195                            [] -> []
 196                          | s::tl -> if tl <> [] then
 197                                                  if s = (List.hd tl) then edup tl
 198                                                  else s::(edup tl)
 199                                     else s::[]
 200                         in
 201                          edup ol
 202    | M.Record (rvar, path) ->
 203       (try
 204         List.assoc path
 205          (try
 206            List.assoc rvar c.groups
 207           with Not_found ->
 208            raise (RVarUnbound rvar))
 209        with Not_found ->
 210         raise (PathUnbound path))
 211    | M.VVar s ->
 212       (try
 213         List.assoc s c.vvars
 214        with Not_found ->
 215         raise (VVarUnbound s))
 216    | M.RefOf sexp -> List.map (fun (s,_) -> s) (exec_set_exp c sexp)
 217    | M.Fun (s, vexp) -> fun_ex handle s (exec_val_exp c vexp)
 218    | M.Property (inv, rop, path, vexp) -> property_ex handle rop path inv (exec_val_exp c vexp)
 219
 220 (* valuta una MathQL.set_exp nel contesto vuoto e ritorna un MathQL.resource_set *)
 221 in
 222    exec_set_exp {svars = []; rvars = []; groups = []; vvars = []} x
 223
 224 (* new interface  ***********************************************************)
 225
 226 let execute handle x = execute_aux handle x
 227