helm/ocaml/mathql_interpreter/mQueryStandard.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 (*  AUTOR: Ferruccio Guidi <fguidi@cs.unibo.it>
  27  *)
  28
  29 module P = MQueryUtil
  30 module C = MQIConn
  31 module U = MQIUtil
  32 module L = MQILib
  33
  34 let init = ()
  35
  36 (* FALSE / EMPTY ************************************************************)
  37
  38 let false_fun b =
  39    let s = if b then "false" else "empty" in
  40    L.fun_arity0 [] s U.mql_false
  41
  42 let _ = L.fun_register ["empty"] (false_fun false)
  43
  44 let _ = L.fun_register ["false"] (false_fun true)
  45
  46 (* TRUE *********************************************************************)
  47
  48 let true_fun = L.fun_arity0 [] "true" U.mql_true
  49
  50 let _ = L.fun_register ["true"] true_fun
  51
  52 (* NOT **********************************************************************)
  53
  54 let not_fun =
  55    let aux r = if r = U.mql_false then U.mql_true else U.mql_false in
  56    L.fun_arity1 [] "!" aux
  57
  58 let _ = L.fun_register ["not"] not_fun
  59
  60 (* COUNT ********************************************************************)
  61
  62 let count_fun =
  63    let aux r = [string_of_int (List.length r), []] in
  64    L.fun_arity1 [] "#" aux
  65
  66 let _ = L.fun_register ["count"] count_fun
  67
  68 (* PEEK *********************************************************************)
  69
  70 let peek_fun =
  71    let aux = function [] -> [] | hd :: _ -> [hd] in
  72    L.fun_arity1 [] "peek" aux
  73
  74 let _ = L.fun_register ["peek"] peek_fun
  75
  76 (* DIFF *********************************************************************)
  77
  78 let diff_fun = L.fun_arity2 [] "diff" U.mql_diff
  79
  80 let _ = L.fun_register ["diff"] diff_fun
  81
  82 (* XOR **********************************************************************)
  83
  84 let xor_fun = L.fun_arity2 [] "xor" U.xor
  85
  86 let _ = L.fun_register ["xor"] xor_fun
  87
  88 (* SUB **********************************************************************)
  89
  90 let sub_fun = L.fun_arity2 [] "sub" U.set_sub
  91
  92 let _ = L.fun_register ["sub"] sub_fun
  93
  94 (* MEET *********************************************************************)
  95
  96 let meet_fun = L.fun_arity2 [] "meet" U.set_meet
  97
  98 let _ = L.fun_register ["meet"] meet_fun
  99
 100 (* EQ ***********************************************************************)
 101
 102 let eq_fun = L.fun_arity2 [] "==" U.set_eq
 103
 104 let _ = L.fun_register ["eq"] eq_fun
 105
 106 (* LE ***********************************************************************)
 107
 108 let le_fun =
 109    let le v1 v2 =
 110       if U.int_of_set v1 <= U.int_of_set v2 then U.mql_true else U.mql_false
 111    in
 112    L.fun_arity2 [] "<=" le
 113
 114 let _ = L.fun_register ["le"] le_fun
 115
 116 (* LT ***********************************************************************)
 117
 118 let lt_fun =
 119    let lt v1 v2 =
 120       if U.int_of_set v1 < U.int_of_set v2 then U.mql_true else U.mql_false
 121    in
 122    L.fun_arity2 [] "<" lt
 123
 124 let _ = L.fun_register ["lt"] lt_fun
 125
 126 (* STAT *********************************************************************)
 127
 128 let stat_fun =
 129    let arity_p = L.Const 0 in
 130    let arity_s = L.Const 1 in
 131    let body e o _ _ = function
 132       | [x] ->
 133          let t = P.start_time () in
 134          let r = (e.L.eval x) in
 135          let s = P.stop_time t in
 136          o.L.out (Printf.sprintf "Stat: %s,%i\n" s (List.length r));
 137          r
 138       | _   -> assert false
 139    in
 140    let txt_out o _ = function
 141       | [x] -> let o = L.std o in o.L.s_out "stat "; o.L.s_query x
 142       | _   -> assert false
 143    in
 144    {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}
 145
 146 let _ = L.fun_register ["stat"] stat_fun
 147
 148 (* LOG **********************************************************************)
 149
 150 let log_fun xml src =
 151    let log_src e o x =
 152       let t = P.start_time () in o.L.s_query x;
 153       let s = P.stop_time t in
 154       if C.set e.L.conn C.Stat then o.L.s_out (Printf.sprintf "Log source: %s\n" s);
 155       e.L.eval x
 156    in
 157    let log_res e o x =
 158       let s = e.L.eval x in
 159       let t = P.start_time () in o.L.s_result s;
 160       let r = P.stop_time t in
 161       if C.set e.L.conn C.Stat then o.L.s_out (Printf.sprintf "Log: %s\n" r); s
 162    in
 163    let txt_log o =
 164       if xml then o.L.s_out "xml ";
 165       if src then o.L.s_out "source "
 166    in
 167    let arity_p = L.Const 0 in
 168    let arity_s = L.Const 1 in
 169    let body e o _ _ = function
 170       | [x] -> let o = L.std o in if src then log_src e o x else log_res e o x
 171       | _   -> assert false
 172    in
 173    let txt_out o _ = function
 174       | [x] -> let o = L.std o in o.L.s_out "log "; txt_log o; o.L.s_query x
 175       | _   -> assert false
 176    in
 177    {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}
 178
 179 let _ = L.fun_register ["log"; "text"; "result"] (log_fun false false)
 180
 181 let _ = L.fun_register ["log"; "text"; "source"] (log_fun false true)
 182
 183 (* RENDER *******************************************************************)
 184
 185 let render_fun =
 186    let arity_p = L.Const 0 in
 187    let arity_s = L.Const 1 in
 188    let body e o _ _ = function
 189       | [x] ->
 190          let rs = ref "" in
 191          let out s = rs := ! rs ^ s in
 192          o.L.result out " " (e.L.eval x);
 193          [! rs, []]
 194       | _   -> assert false
 195    in
 196    let txt_out o _ = function
 197       | [x] -> let o = L.std o in o.L.s_out "render "; o.L.s_query x
 198       | _   -> assert false
 199    in
 200    {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}
 201
 202 let _ = L.fun_register ["render"] render_fun
 203
 204 (* READ *********************************************************************)
 205
 206 let read_fun =
 207    let arity_p = L.Const 0 in
 208    let arity_s = L.Const 1 in
 209    let body e o i _ = function
 210       | [x] ->
 211          let aux av =
 212             let ich = open_in (fst av) in
 213             let r = i.L.result_in (Lexing.from_channel ich) in
 214             close_in ich; r
 215          in
 216          U.mql_iter aux (e.L.eval x)
 217       | _   -> assert false
 218    in
 219    let txt_out o _ = function
 220       | [x] -> let o = L.std o in o.L.s_out "read "; o.L.s_query x
 221       | _   -> assert false
 222    in
 223    {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}
 224
 225 let _ = L.fun_register ["read"] read_fun
 226
 227 (* ALIGN ********************************************************************)
 228
 229 let align_fun =
 230    let aux l (v, g) =
 231       let c = String.length v in
 232       if c < l then [(String.make (l - c) ' ' ^ v), g] else [v, g]
 233    in
 234    let arity_p = L.Const 0 in
 235    let arity_s = L.Const 2 in
 236    let body e _ _ _ = function
 237       | [y; x] ->
 238          let l = U.int_of_set (e.L.eval y) in
 239          U.mql_iter (aux l) (e.L.eval x)
 240       | _      -> assert false
 241    in
 242    let txt_out o _ = function
 243       | [y; x] ->
 244          let o = L.std o in
 245          o.L.s_out "align "; o.L.s_query y; o.L.s_out " in "; o.L.s_query x
 246       | _      -> assert false
 247    in
 248    {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}
 249
 250 let _ = L.fun_register ["align"] align_fun
 251
 252 (* IF ***********************************************************************)
 253
 254 let if_fun =
 255    let arity_p = L.Const 0 in
 256    let arity_s = L.Const 3 in
 257    let body e _ _ _ = function
 258       | [y; x1; x2] ->
 259          if (e.L.eval y) = U.mql_false then (e.L.eval x2) else (e.L.eval x1)
 260       | _           -> assert false
 261    in
 262    let txt_out o _ = function
 263       | [y; x1; x2] ->
 264          let o = L.std o in
 265          o.L.s_out "if "; o.L.s_query y; o.L.s_out " then "; o.L.s_query x1;
 266          o.L.s_out " else "; o.L.s_query x2
 267       | _           -> assert false
 268    in
 269    {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}
 270
 271 let _ = L.fun_register["if"] if_fun
 272
 273 (* INTERSECT ****************************************************************)
 274
 275 let intersect_fun =
 276    let rec iter f = function
 277       | []           -> assert false
 278       | [head]       -> f head
 279       | head :: tail -> U.mql_intersect (f head) (iter f tail)
 280    in
 281    let arity_p = L.Const 0 in
 282    let arity_s = L.Positive in
 283    let body e _ _ _ xl = iter e.L.eval xl in
 284    let txt_out o _ = function
 285       | []           -> assert false
 286       | [x1; x2]     -> let o = L.std o in L.out_txt2 o "/\\" x1 x2
 287       | xl           -> let o = L.std o in L.out_txt_ o ["intersect"] xl
 288    in
 289    {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}
 290
 291 let _ = L.fun_register ["intersect"] intersect_fun
 292
 293 (* UNION ********************************************************************)
 294
 295 let union_fun =
 296    let arity_p = L.Const 0 in
 297    let arity_s = L.Any in
 298    let body e _ _ _ xl = U.mql_iter e.L.eval xl in
 299    let txt_out o _ xl = let o = L.std o in L.out_txt_ o [] xl
 300    in
 301    {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}
 302
 303 let _ = L.fun_register ["union"] union_fun
 304
 305 (* OR ***********************************************************************)
 306
 307 let or_fun =
 308    let rec iter f = function
 309       | []           -> U.mql_false
 310       | head :: tail ->
 311          let r1 = f head in
 312          if r1 = U.mql_false then (iter f tail) else r1
 313    in
 314    let arity_p = L.Const 0 in
 315    let arity_s = L.Any in
 316    let body e _ _ _ xl = iter e.L.eval xl in
 317    let txt_out o _ = function
 318       | [x1; x2]     -> let o = L.std o in L.out_txt2 o "||" x1 x2
 319       | xl           -> let o = L.std o in L.out_txt_ o ["or"] xl
 320    in
 321    {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}
 322
 323 let _ = L.fun_register ["or"] or_fun
 324
 325 (* AND **********************************************************************)
 326
 327 let and_fun =
 328    let rec iter f = function
 329       | []           -> U.mql_true
 330       | [head]       -> f head
 331       | head :: tail ->
 332          if f head = U.mql_false then U.mql_false else iter f tail
 333    in
 334    let arity_p = L.Const 0 in
 335    let arity_s = L.Any in
 336    let body e _ _ _ xl = iter e.L.eval xl in
 337    let txt_out o _ = function
 338       | [x1; x2]  -> let o = L.std o in L.out_txt2 o "&&" x1 x2
 339       | xl        -> let o = L.std o in L.out_txt_ o ["and"] xl
 340    in
 341    {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}
 342
 343 let _ = L.fun_register ["and"] and_fun
 344
 345 (* PROJ *********************************************************************)
 346
 347 let proj_fun =
 348    let proj_group_aux p (q, v) = if q = p then U.mql_subj v else [] in
 349    let proj_group p a = U.mql_iter (proj_group_aux p) a in
 350    let proj_set p (_, g) = U.mql_iter (proj_group p) (List.rev g) in
 351    let arity_p = L.Const 1 in
 352    let arity_s = L.Const 1 in
 353    let body e _ _ pl xl =
 354       match pl, xl with
 355          | [p], [x] -> U.mql_iter (proj_set p) (e.L.eval x)
 356          | _        -> assert false
 357    in
 358    let txt_out o pl xl =
 359       match pl, xl with
 360          | [p], [x] ->
 361             let o = L.std o in
 362             o.L.s_out "proj "; o.L.s_path p; o.L.s_out " of "; o.L.s_query x
 363          | _        -> assert false
 364    in
 365    {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}
 366
 367 let _ = L.fun_register ["proj"] proj_fun
 368
 369 (* KEEP *********************************************************************)
 370
 371 let keep_fun b =
 372    let proj (r, _) = (r, []) in
 373    let keep_path l (p, v) t = if List.mem p l = b then t else (p, v) :: t in
 374    let keep_grp l a = List.fold_right (keep_path l) a [] in
 375    let keep_set l a g =
 376       let kg = keep_grp l a in
 377       if kg = [] then g else kg :: g
 378    in
 379    let keep_av l (s, g) = (s, List.fold_right (keep_set l) g []) in
 380    let txt_allbut o = if b then o.L.s_out "allbut " in
 381    let txt_path_list o l = P.flat_list o.L.s_out o.L.s_path ", " l in
 382    let arity_p = L.Any in
 383    let arity_s = L.Const 1 in
 384    let body e _ _ pl xl =
 385       match b, pl, xl with
 386          | true, [], [x]  -> e.L.eval x
 387          | false, [], [x] -> List.map proj (e.L.eval x)
 388          | _, l, [x]      -> List.map (keep_av l) (e.L.eval x)
 389          | _              -> assert false
 390   in
 391   let txt_out o pl xl =
 392       match pl, xl with
 393          | [], [x] ->
 394             let o = L.std o in
 395             o.L.s_out "keep "; txt_allbut o; o.L.s_query x
 396          | l, [x]  ->
 397             let o = L.std o in
 398             o.L.s_out "keep "; txt_allbut o; txt_path_list o l;
 399             o.L.s_out " in "; o.L.s_query x
 400          | _      -> assert false
 401    in
 402    {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}
 403
 404 let _ = L.fun_register ["keep"; "these"] (keep_fun false)
 405
 406 let _ = L.fun_register ["keep"; "allbut"] (keep_fun true)