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>
38 let test f v1 v2 = U.avs_of_bool (f v1 v2)
40 let num_test f v1 v2 = U.avs_of_bool (f (U.int_of_avs v1) (U.int_of_avs v2))
42 (* FALSE / EMPTY ************************************************************)
45 let s = if b then "false" else "empty" in
46 L.fun_arity0 [] s U.val_false
48 let _ = L.fun_register ["empty"] (false_fun false)
50 let _ = L.fun_register ["false"] (false_fun true)
52 (* TRUE *********************************************************************)
54 let true_fun = L.fun_arity0 [] "true" U.val_true
56 let _ = L.fun_register ["true"] true_fun
58 (* NOT **********************************************************************)
61 let aux r = if r = U.val_false then U.val_true else U.val_false in
62 L.fun_arity1 [] "!" aux
64 let _ = L.fun_register ["not"] not_fun
66 (* COUNT ********************************************************************)
69 let aux r = U.avs_of_int (U.count r) in
70 L.fun_arity1 [] "#" aux
72 let _ = L.fun_register ["count"] count_fun
74 (* PEEK *********************************************************************)
81 | I.Many (s, gl) -> U.make_x s gl
83 L.fun_arity1 [] "peek" aux
85 let _ = L.fun_register ["peek"] peek_fun
87 (* DIFF *********************************************************************)
89 let diff_fun = L.fun_arity2 [] "diff" I.diff
91 let _ = L.fun_register ["diff"] diff_fun
93 (* XOR **********************************************************************)
97 let b = v1 <> U.val_false in
98 if b && v2 <> U.val_false then U.val_false else
101 L.fun_arity2 [] "xor" aux
103 let _ = L.fun_register ["xor"] xor_fun
105 (* SUB **********************************************************************)
107 let sub_fun = L.fun_arity2 [] "sub" (test I.sub)
109 let _ = L.fun_register ["sub"] sub_fun
111 (* MEET *********************************************************************)
113 let meet_fun = L.fun_arity2 [] "meet" (test I.meet)
115 let _ = L.fun_register ["meet"] meet_fun
117 (* EQ ***********************************************************************)
119 let eq_fun = L.fun_arity2 [] "==" (test I.eq)
121 let _ = L.fun_register ["eq"] eq_fun
123 (* LE ***********************************************************************)
125 let le_fun = L.fun_arity2 [] "<=" (num_test (<=))
127 let _ = L.fun_register ["le"] le_fun
129 (* LT ***********************************************************************)
131 let lt_fun = L.fun_arity2 [] "<" (num_test (<))
133 let _ = L.fun_register ["lt"] lt_fun
135 (* STAT *********************************************************************)
138 let arity_p = L.Const 0 in
139 let arity_s = L.Const 1 in
140 let body e o _ _ = function
142 let t = P.start_time () in
143 let r = (e.L.eval x) in
144 let s = P.stop_time t in
145 o.L.out (Printf.sprintf "Stat: %s,%i\n" s (U.count r));
149 let txt_out o _ = function
150 | [x] -> let o = L.std o in o.L.s_out "stat "; o.L.s_query x
153 {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}
155 let _ = L.fun_register ["stat"] stat_fun
157 (* LOG **********************************************************************)
159 let log_fun xml src =
161 let t = P.start_time () in o.L.s_query x;
162 let s = P.stop_time t in
163 if C.set e.L.conn C.Times then o.L.s_out (Printf.sprintf "Log source: %s\n" s);
167 let s = e.L.eval x in
168 let t = P.start_time () in o.L.s_result s;
169 let r = P.stop_time t in
170 if C.set e.L.conn C.Times then o.L.s_out (Printf.sprintf "Log: %s\n" r); s
173 if xml then o.L.s_out "xml ";
174 if src then o.L.s_out "source "
176 let arity_p = L.Const 0 in
177 let arity_s = L.Const 1 in
178 let body e o _ _ = function
179 | [x] -> let o = L.std o in if src then log_src e o x else log_res e o x
182 let txt_out o _ = function
183 | [x] -> let o = L.std o in o.L.s_out "log "; txt_log o; o.L.s_query x
186 {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}
188 let _ = L.fun_register ["log"; "text"; "result"] (log_fun false false)
190 let _ = L.fun_register ["log"; "text"; "source"] (log_fun false true)
192 (* RENDER *******************************************************************)
195 let arity_p = L.Const 0 in
196 let arity_s = L.Const 1 in
197 let body e o _ _ = function
200 let out s = rs := ! rs ^ s in
201 o.L.result out "" (e.L.eval x);
202 I.make ! rs I.grp_empty
205 let txt_out o _ = function
206 | [x] -> let o = L.std o in o.L.s_out "render "; o.L.s_query x
209 {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}
211 let _ = L.fun_register ["render"] render_fun
213 (* READ *********************************************************************)
216 let arity_p = L.Const 0 in
217 let arity_s = L.Const 1 in
218 let body e o i _ = function
221 let ich = open_in s in
222 let r = i.L.result_in (Lexing.from_channel ich) in
223 close_in ich; I.union avs r
225 I.iter aux I.empty (e.L.eval x)
228 let txt_out o _ = function
229 | [x] -> let o = L.std o in o.L.s_out "read "; o.L.s_query x
232 {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}
234 let _ = L.fun_register ["read"] read_fun
236 (* ALIGN ********************************************************************)
240 let c = String.length v in
241 if c < l then String.make (l - c) ' ' ^ v else v
243 let aux l r s gl _ = I.union r (U.make_x (aux2 l s) gl) in
244 let arity_p = L.Const 0 in
245 let arity_s = L.Const 2 in
246 let body e _ _ _ = function
248 let l = U.int_of_avs (e.L.eval y) in
249 I.x_iter (aux l) I.empty (I.optimize (e.L.eval x))
252 let txt_out o _ = function
255 o.L.s_out "align "; o.L.s_query y; o.L.s_out " in "; o.L.s_query x
258 {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}
260 let _ = L.fun_register ["align"] align_fun
262 (* IF ***********************************************************************)
265 let arity_p = L.Const 0 in
266 let arity_s = L.Const 3 in
267 let body e _ _ _ = function
269 if U.bool_of_avs (e.L.eval y) then (e.L.eval x1) else (e.L.eval x2)
272 let txt_out o _ = function
275 o.L.s_out "if "; o.L.s_query y; o.L.s_out " then "; o.L.s_query x1;
276 o.L.s_out " else "; o.L.s_query x2
279 {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}
281 let _ = L.fun_register["if"] if_fun
283 (* INTERSECT ****************************************************************)
286 let rec iter f = function
289 | head :: tail -> I.intersect (f head) (iter f tail)
291 let arity_p = L.Const 0 in
292 let arity_s = L.Positive in
293 let body e _ _ _ xl = iter e.L.eval xl in
294 let txt_out o _ = function
296 | [x1; x2] -> let o = L.std o in L.out_txt2 o "/\\" x1 x2
297 | xl -> let o = L.std o in L.out_txt_ o ["intersect"] xl
299 {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}
301 let _ = L.fun_register ["intersect"] intersect_fun
303 (* UNION ********************************************************************)
306 let arity_p = L.Const 0 in
307 let arity_s = L.Any in
308 let body e _ _ _ xl = U.iter e.L.eval xl in
309 let txt_out o _ xl = let o = L.std o in L.out_txt_ o [] xl
311 {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}
313 let _ = L.fun_register ["union"] union_fun
315 (* OR ***********************************************************************)
318 let rec iter f = function
322 if U.bool_of_avs r1 then r1 else (iter f tail)
324 let arity_p = L.Const 0 in
325 let arity_s = L.Any in
326 let body e _ _ _ xl = iter e.L.eval xl in
327 let txt_out o _ = function
328 | [x1; x2] -> let o = L.std o in L.out_txt2 o "||" x1 x2
329 | xl -> let o = L.std o in L.out_txt_ o ["or"] xl
331 {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}
333 let _ = L.fun_register ["or"] or_fun
335 (* AND **********************************************************************)
338 let rec iter f = function
342 if U.bool_of_avs (f head) then iter f tail else U.val_false
344 let arity_p = L.Const 0 in
345 let arity_s = L.Any in
346 let body e _ _ _ xl = iter e.L.eval xl in
347 let txt_out o _ = function
348 | [x1; x2] -> let o = L.std o in L.out_txt2 o "&&" x1 x2
349 | xl -> let o = L.std o in L.out_txt_ o ["and"] xl
351 {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}
353 let _ = L.fun_register ["and"] and_fun
355 (* PROJ *********************************************************************)
358 let aux2 p a q v _ = if p = q then I.union a (U.subj v) else a in
360 I.union a (U.iter (I.x_grp_iter (aux2 p) I.empty) gl)
362 let arity_p = L.Const 1 in
363 let arity_s = L.Const 1 in
364 let body e _ _ pl xl =
366 | [p], [x] -> I.x_iter (aux p) I.empty (e.L.eval x)
369 let txt_out o pl xl =
373 o.L.s_out "proj "; o.L.s_path p; o.L.s_out " of "; o.L.s_query x
376 {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}
378 let _ = L.fun_register ["proj"] proj_fun
380 (* KEEP *********************************************************************)
383 let aux2 s l a q v _ =
385 (if List.mem q l = b then I.grp_empty else U.grp_make_x q v)
390 if l = [] then I.make s I.grp_empty else
391 U.iter (I.x_grp_iter (aux2 s l) I.empty) gl)
393 let txt_allbut o = if b then o.L.s_out "allbut " in
394 let txt_path_list o l = P.flat_list o.L.s_out o.L.s_path ", " l in
395 let arity_p = L.Any in
396 let arity_s = L.Const 1 in
397 let body e _ _ pl xl =
399 | true, [], [x] -> e.L.eval x
400 | _, l, [x] -> I.x_iter (aux l) I.empty (I.optimize (e.L.eval x))
403 let txt_out o pl xl =
407 o.L.s_out "keep "; txt_allbut o; o.L.s_query x
410 o.L.s_out "keep "; txt_allbut o; txt_path_list o l;
411 o.L.s_out " in "; o.L.s_query x
414 {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}
416 let _ = L.fun_register ["keep"; "these"] (keep_fun false)
418 let _ = L.fun_register ["keep"; "allbut"] (keep_fun true)