helm/ocaml/mathql_interpreter/mQIExecute.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 (* modifiers  ***************************************************************)
  27
  28 let galax_char = 'G'
  29
  30 let stat_char = 'S'
  31
  32 let warn_char = 'W'
  33
  34 (* contexts *****************************************************************)
  35
  36 type svar_context = (MathQL.svar * MathQL.resource_set) list
  37
  38 type avar_context = (MathQL.avar * MathQL.resource) list
  39
  40 type group_context = (MathQL.avar * MathQL.attribute_group) list
  41
  42 type vvar_context = (MathQL.vvar * MathQL.value) list
  43
  44 type context = {svars: svar_context;
  45                 avars: avar_context;
  46                 groups: group_context; (* auxiliary context *)
  47                 vvars: vvar_context
  48                }
  49
  50 (* execute  *****************************************************************)
  51
  52 exception Found
  53
  54 module M = MathQL
  55 module P = MQueryUtil
  56 module U = MQIUtil
  57
  58 let execute out m x =
  59    let warn q =
  60      if String.contains m warn_char then
  61      begin
  62         out "MQIExecute: waring: reference to undefined variables: ";
  63         P.text_of_query out q "\n"
  64      end
  65    in
  66    let rec eval_val c = function
  67       | M.False -> U.mql_false
  68       | M.True -> U.mql_true
  69       | M.Const s -> [s]
  70       | M.Set l -> U.iter (eval_val c) l
  71       | M.Test k y1 y2 ->
  72          let cand y1 y2 =
  73             if eval_val c y1 = U.mql_false then U.mql_false else eval_val c y2
  74          in
  75          let cor y1 y2 =
  76             let v1 = eval_val c y1 in
  77             if v1 = U.mql_false then eval_val c y2 else v1
  78          in
  79          let h f y1 y2 = f (eval_val c y1) (eval_val c y2) in
  80          let f = match k with
  81             | M.And  -> cand
  82             | M.Or   -> cor
  83             | M.Xor  -> h U.xor
  84             | M.Sub  -> h U.set_sub
  85             | M.Meet -> h U.set_meet
  86             | M.Eq   -> h U.set_eq
  87             | M.Le   -> h U.le
  88             | M.Lt   -> h U.lt
  89          in
  90          f y1 y2
  91       | M.Not y ->
  92          if eval_val c y = U.mql_false then U.mql_true else U.mql_false
  93       | M.VVar i -> begin
  94          try List.assoc i c.vvars
  95          with Not_found -> warn (M.Subj (M.VVar i)); [] end
  96       | M.Dot i p -> begin
  97          try List.assoc p (List.assoc i c.groups)
  98          with Not_found -> warn (M.Subj (M.Dot i p)); [] end
  99       | M.Proj None x -> List.map (fun (r, _) -> r) (eval_query c x)
 100       | M.Proj (Some p) x ->
 101          let proj_group_aux (q, v) = if q = p then v else [] in
 102          let proj_group a = U.iter proj_group_aux a in
 103          let proj_set (_, g) = U.iter proj_group g in
 104          U.iter proj_set (eval_query c x)
 105       | M.Ex l y ->
 106          let rec ex_aux h = function
 107             | []        ->
 108                let d = {c with groups = h} in
 109                if eval_val d y = U.mql_false then () else raise Found
 110             | i :: tail ->
 111                begin
 112                   try
 113                      let (_, a) = List.assoc i c.avars in
 114                      let rec add_group = function
 115                         | []     -> ()
 116                         | g :: t -> ex_aux ((i, g) :: h) tail; add_group t
 117                      in
 118                      add_group a
 119                   with Not_found -> ()
 120                end
 121          in
 122          (try ex_aux [] l; U.mql_false with Found -> U.mql_true)
 123       | M.StatVal y ->
 124          let t = U.start_time () in
 125          let r = (eval_val c y) in
 126          let s = U.stop_time t in
 127          out (Printf.sprintf "Stat: %s,%i\n" s (List.length r));
 128          r
 129       | M.Count y -> [string_of_int (List.length (eval_val c y))]
 130       | M.Align s y -> U.iter (U.align s) (eval_val c y)
 131    and eval_query c = function
 132       | M.Empty -> []
 133       | M.Subj x ->
 134          List.map (fun s -> (s, [])) (eval_val c x)
 135       | M.Log _ b x ->
 136          if b then begin
 137             let t = U.start_time () in
 138             P.text_of_query out x "\n";
 139             let s = U.stop_time t in
 140             if String.contains m stat_char then
 141                out (Printf.sprintf "Log source: %s\n" s);
 142             eval_query c x
 143          end else begin
 144             let s = (eval_query c x) in
 145             let t = U.start_time () in
 146             P.text_of_result out s "\n";
 147             let r = U.stop_time t in
 148             if String.contains m stat_char then
 149                out (Printf.sprintf "Log: %s\n" r);
 150             s
 151          end
 152       | M.If y x1 x2 ->
 153          if (eval_val c y) = U.mql_false
 154             then (eval_query c x2) else (eval_query c x1)
 155       | M.Bin k x1 x2 ->
 156          let f = match k with
 157             | M.BinFJoin -> U.mql_union
 158             | M.BinFMeet -> U.mql_intersect
 159             | M.BinFDiff -> U.mql_diff
 160          in
 161          f (eval_query c x1) (eval_query c x2)
 162       | M.SVar i -> begin
 163          try List.assoc i c.svars
 164          with Not_found -> warn (M.SVar i); [] end
 165       | M.AVar i -> begin
 166          try [List.assoc i c.avars]
 167          with Not_found -> warn (M.AVar i); [] end
 168       | M.LetSVar i x1 x2 ->
 169          let d = {c with svars = U.set (i, eval_query c x1) c.svars} in
 170          eval_query d x2
 171       | M.LetVVar i y x ->
 172          let d = {c with vvars = U.set (i, eval_val c y) c.vvars} in
 173          eval_query d x
 174       | M.For k i x1 x2 ->
 175          let f = match k with
 176             | M.GenFJoin -> U.mql_union
 177             | M.GenFMeet -> U.mql_intersect
 178          in
 179          let rec for_aux = function
 180             | []     -> []
 181             | h :: t ->
 182                let d = {c with avars = U.set (i, h) c.avars} in
 183                f (eval_query d x2) (for_aux t)
 184          in
 185          for_aux (eval_query c x1)
 186       | M.Add b z x ->
 187          let f = if b then U.mql_prod else U.set_union in
 188          let g a s = (fst a, f (snd a) (eval_grp c z)) :: s in
 189          List.fold_right g (eval_query c x) []
 190       | M.Property q0 q1 q2 mc ct cf el pat y ->
 191          let subj, mct =
 192             if q0 then [], (pat, q2 @ mc, eval_val c y)
 193                   else (q2 @ mc), (pat, [], eval_val c y)
 194          in
 195          let f = if String.contains m galax_char
 196             then MQIProperty.galax else MQIProperty.postgres
 197          in
 198          let eval_cons (pat, p, y) = (pat, q2 @ p, eval_val c y) in
 199          let cons_true = mct :: List.map eval_cons ct in
 200          let cons_false = List.map eval_cons cf in
 201          let eval_exp (p, po) = (q2 @ p, po) in
 202          let exp = List.map eval_exp el in
 203          let t = U.start_time () in
 204          let r = f q1 subj cons_true cons_false exp in
 205          let s = U.stop_time t in
 206          if String.contains m stat_char then
 207             out (Printf.sprintf "Property: %s,%i\n" s (List.length r));
 208          r
 209       | M.StatQuery x ->
 210          let t = U.start_time () in
 211          let r = (eval_query c x) in
 212          let s = U.stop_time t in
 213          out (Printf.sprintf "Stat: %s,%i\n" s (List.length r));
 214          r
 215       | M.Select i x y ->
 216          let rec select_aux = function
 217             | []     -> []
 218             | h :: t ->
 219                let d = {c with avars = U.set (i, h) c.avars} in
 220                if eval_val d y = U.mql_false
 221                   then select_aux t else h :: select_aux t
 222          in
 223          select_aux (eval_query c x)
 224       | M.Keep b l x ->
 225          let keep_path (p, v) t =
 226             if List.mem p l = b then t else (p, v) :: t in
 227          let keep_grp a = List.fold_right keep_path a [] in
 228          let keep_set a g =
 229             let kg = keep_grp a in
 230             if kg = [] then g else kg :: g
 231          in
 232          let keep_av (s, g) = (s, List.fold_right keep_set g []) in
 233          List.map keep_av (eval_query c x)
 234    and eval_grp c = function
 235       | M.Attr gs ->
 236          let attr_aux g (p, y) = U.mql_union g [(p, eval_val c y)] in
 237          let attr_auxs s l = U.set_union s [List.fold_left attr_aux [] l] in
 238          List.fold_left attr_auxs [] gs
 239       | M.From i ->
 240          try snd (List.assoc i c.avars)
 241          with Not_found -> warn (M.AVar i); []
 242    in
 243    let c = {svars = []; avars = []; groups = []; vvars = []} in
 244    let t = U.start_time () in
 245    let r = eval_query c x in
 246    let s = U.stop_time t in
 247    if String.contains m stat_char then
 248       out (Printf.sprintf "MQIExecute: %s,%s\n" s m);
 249    r