1 (* Copyright (C) 2000, HELM Team.
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.
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.
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.
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,
22 * For details, see the HELM World-Wide-Web page,
23 * http://cs.unibo.it/helm/.
26 (* AUTOR: Ferruccio Guidi <fguidi@cs.unibo.it>
34 (* external function specification ******************************************)
36 type arity_t = Const of int
40 type eval_spec = {eval : M.query -> M.result;
44 type txt_out_spec = {out : string -> unit;
45 path : M.path -> unit;
46 query : M.query -> unit;
47 result : M.result -> unit
50 type fun_spec = {arity_p : arity_t;
52 body : eval_spec -> txt_out_spec ->
53 M.path list -> M.query list -> M.result;
54 txt_out : txt_out_spec ->
55 M.path list -> M.query list -> unit
58 exception ArityError of M.path * arity_t * int
60 exception NameError of M.path
62 exception NumberError of M.result
64 (* external functions implementation ****************************************)
68 | [s, _] -> int_of_string s
69 | _ -> raise (Failure "int_of_string")
70 with Failure "int_of_string" -> raise (NumberError s)
72 let out_txt2 out commit n x1 x2 =
73 out "(" ; commit x1; out (" " ^ n ^ " "); commit x2; out ")"
75 let out_txt_ out path commit p xl =
76 path p; out " {"; P.flat_list out commit ", " xl; out "}"
78 let out_txt_full out path commit p pl xl =
79 path p; out " {"; P.flat_list out path ", " pl; out "} {";
80 P.flat_list out commit ", " xl; out "}"
83 let arity_p = Const 0 in
84 let arity_s = Const 0 in
85 let body _ _ _ _ = U.mql_true in
86 let txt_out s _ _ = s.out n in
87 {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
90 let arity_p = Const 0 in
91 let arity_s = Const 1 in
92 let body eval _ _ = function
96 let txt_out out _ commit _ = function
97 | [x] -> out (n ^ " "); commit x
100 {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
103 let arity_p = Const 0 in
104 let arity_s = Const 2 in
105 let body eval _ _ = function
106 | [x1; x2] -> f (eval x1) (eval x2)
109 let txt_out out _ commit _ = function
110 | [x1; x2] -> out_txt2 out commit n x1 x2
113 {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
115 let false_fun = arity0 "false" U.mql_false
117 let true_fun = arity0 "true" U.mql_true
120 let aux r = if r = U.mql_false then U.mql_true else U.mql_false in
124 let aux r = [string_of_int (List.length r), []] in
127 let diff_fun = arity2 "diff" U.mql_diff
129 let xor_fun = arity2 "xor" U.xor
131 let sub_fun = arity2 "sub" U.set_sub
133 let meet_fun = arity2 "meet" U.set_meet
135 let eq_fun = arity2 "eq" U.set_eq
139 if int_of_set v1 <= int_of_set v2 then U.mql_true else U.mql_false
145 if int_of_set v1 < int_of_set v2 then U.mql_true else U.mql_false
150 let arity_p = Const 0 in
151 let arity_s = Const 1 in
152 let body eval h _ = function
154 let t = P.start_time () in
156 let s = P.stop_time t in
157 C.log h (Printf.sprintf "Stat: %s,%i\n" s (List.length r));
161 let txt_out out _ commit _ = function
162 | [x] -> out "stat "; commit x
165 {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
169 let c = String.length v in
170 if c < l then [(String.make (l - c) ' ' ^ v), g] else [v, g]
172 let arity_p = Const 0 in
173 let arity_s = Const 2 in
174 let body eval _ _ = function
176 let l = int_of_set (eval y) in
177 U.mql_iter (aux l) (eval x)
180 let txt_out out _ commit _ = function
181 | [y; x] -> out "align "; commit y; out " in "; commit x
184 {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
187 let arity_p = Const 0 in
188 let arity_s = Const 3 in
189 let body eval _ _ = function
191 if (eval y) = U.mql_false then (eval x2) else (eval x1)
194 let txt_out out _ commit _ = function
196 out "if "; commit y; out " then "; commit x1; out " else "; commit x2
199 {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
202 let rec iter f = function
205 | head :: tail -> U.mql_intersect (f head) (iter f tail)
207 let arity_p = Const 0 in
208 let arity_s = Positive in
209 let body eval _ _ xl = iter eval xl in
210 let txt_out out path commit _ = function
212 | [x1; x2] -> out_txt2 out commit "intersect" x1 x2
213 | xl -> out_txt_ out path commit ["intersect"] xl
215 {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
218 let arity_p = Const 0 in
220 let body eval _ _ xl = U.mql_iter eval xl in
221 let txt_out out path commit _ = function
222 | [x1; x2] -> out_txt2 out commit "union" x1 x2
223 | xl -> out_txt_ out path commit ["union"] xl
225 {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
228 let rec iter f = function
232 if r1 = U.mql_false then (iter f tail) else r1
234 let arity_p = Const 0 in
236 let body eval _ _ xl = iter eval xl in
237 let txt_out out path commit _ = function
238 | [x1; x2] -> out_txt2 out commit "or" x1 x2
239 | xl -> out_txt_ out path commit ["or"] xl
241 {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
244 let rec iter f = function
247 if f head = U.mql_false then U.mql_false else (iter f tail)
249 let arity_p = Const 0 in
251 let body eval _ _ xl = iter eval xl in
252 let txt_out out path commit _ = function
253 | [x1; x2] -> out_txt2 out commit "and" x1 x2
254 | xl -> out_txt_ out path commit ["and"] xl
256 {arity_p = arity_p; arity_s = arity_s; body = body; txt_out = txt_out}
258 (* external functions interface *********************************************)
260 let get_spec = function
261 | ["false"] -> false_fun
262 | ["true"] -> true_fun
264 | ["count"] -> count_fun
265 | ["stat"] -> stat_fun
266 | ["diff"] -> diff_fun
269 | ["meet"] -> meet_fun
273 | ["align"] -> align_fun
275 | ["intersect"] -> intersect_fun
276 | ["union"] -> union_fun
279 | p -> raise (NameError p)
281 let check_arity p m n =
283 | Const k when i = k -> ()
284 | Positive when i > 0 -> ()
286 | a -> raise (ArityError (p, a, i))
288 aux m (get_spec p).arity_p; aux n (get_spec p).arity_s
290 let exec eval h p pl xl = (get_spec p).body eval h pl xl
292 let txt_out out path commit p pl xl =
293 try (get_spec p).txt_out out path commit pl xl
294 with NameError q when q = p -> out_txt_full out path commit p pl xl
297 | M.Proj (Some p) x -> out "proj "; txt_path out p; out "of "; txt_set x
298 | M.Log a b x -> out "log "; txt_log a b; txt_set x
299 | M.Keep b l x -> out "keep "; txt_allbut b; txt_path_list l;
301 let txt_path_list l = P.flat_list out (txt_path out) ", " l in
303 if a then out "xml ";
304 if b then out "source "
306 let txt_allbut b = if b then out "allbut " in
308 | M.Proj None x -> List.map (fun (r, _) -> (r, [])) (eval_query c x)
309 | M.Proj (Some p) x ->
310 let proj_group_aux (q, v) = if q = p then subj v else [] in
311 let proj_group a = U.mql_iter proj_group_aux a in
312 let proj_set (_, g) = U.mql_iter proj_group g in
313 U.mql_iter proj_set (eval_query c x)
318 let t = P.start_time () in
319 F.text_of_query (C.log h) x "\n";
320 let s = P.stop_time t in
321 if C.set h C.Stat then
322 C.log h (Printf.sprintf "Log source: %s\n" s);
325 let s = (eval_query c x) in
326 let t = P.start_time () in
327 F.text_of_result (C.log h) s "\n";
328 let r = P.stop_time t in
329 if C.set h C.Stat then
330 C.log h (Printf.sprintf "Log: %s\n" r);
335 let keep_path (p, v) t =
336 if List.mem p l = b then t else (p, v) :: t in
337 let keep_grp a = List.fold_right keep_path a [] in
339 let kg = keep_grp a in
340 if kg = [] then g else kg :: g
342 let keep_av (s, g) = (s, List.fold_right keep_set g []) in
343 List.map keep_av (eval_query c x)