(* Copyright (C) 2000, HELM Team.
 * 
 * This file is part of HELM, an Hypertextual, Electronic
 * Library of Mathematics, developed at the Computer Science
 * Department, University of Bologna, Italy.
 * 
 * HELM is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or (at your option) any later version.
 * 
 * HELM is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with HELM; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
 * MA  02111-1307, USA.
 * 
 * For details, see the HELM World-Wide-Web page,
 * http://cs.unibo.it/helm/.
 *)

(*  AUTOR: Ferruccio Guidi <fguidi@cs.unibo.it>
 *)

module U = AvsUtil
module M = MathQL
module I = M.I
module P = MQueryUtil 
module C = MQIConn 
module L = MQILib

let init = ()

let test f v1 v2 = U.avs_of_bool (f v1 v2) 

let num_test f v1 v2 = U.avs_of_bool (f (U.int_of_avs v1) (U.int_of_avs v2)) 

(* FALSE / EMPTY ************************************************************)

let false_fun b =
   let s = if b then "false" else "empty" in 
   L.fun_arity0 [] s U.val_false

let _ = L.fun_register ["empty"] (false_fun false)

let _ = L.fun_register ["false"] (false_fun true)

(* TRUE *********************************************************************)

let true_fun = L.fun_arity0 [] "true" U.val_true

let _ = L.fun_register ["true"] true_fun

(* NOT **********************************************************************)

let not_fun = 
   let aux r = if r = U.val_false then U.val_true else U.val_false in
   L.fun_arity1 [] "!" aux 

let _ = L.fun_register ["not"] not_fun

(* COUNT ********************************************************************)

let count_fun =
   let aux r = U.avs_of_int (U.count r) in
   L.fun_arity1 [] "#" aux

let _ = L.fun_register ["count"] count_fun

(* PEEK *********************************************************************)

let peek_fun =
   let aux r = 
      match (I.peek r) with
         | I.Empty 
	 | I.Single _     -> r
	 | I.Many (s, gl) -> U.make_x s gl
   in
   L.fun_arity1 [] "peek" aux

let _ = L.fun_register ["peek"] peek_fun

(* DIFF *********************************************************************)

let diff_fun = L.fun_arity2 [] "diff" I.diff

let _ = L.fun_register ["diff"] diff_fun

(* XOR **********************************************************************)

let xor_fun =
   let aux v1 v2 =
      let b = v1 <> U.val_false in 
      if b && v2 <> U.val_false then U.val_false else
      if b then v1 else v2
   in
   L.fun_arity2 [] "xor" aux

let _ = L.fun_register ["xor"] xor_fun

(* SUB **********************************************************************)

let sub_fun = L.fun_arity2 [] "sub" (test I.sub)

let _ = L.fun_register ["sub"] sub_fun

(* MEET *********************************************************************)

let meet_fun = L.fun_arity2 [] "meet" (test I.meet)

let _ = L.fun_register ["meet"] meet_fun

(* EQ ***********************************************************************)

let eq_fun = L.fun_arity2 [] "==" (test I.eq)

let _ = L.fun_register ["eq"] eq_fun

(* LE ***********************************************************************)

let le_fun = L.fun_arity2 [] "<=" (num_test (<=))

let _ = L.fun_register ["le"] le_fun

(* LT ***********************************************************************)

let lt_fun = L.fun_arity2 [] "<" (num_test (<))

let _ = L.fun_register ["lt"] lt_fun

(* STAT *********************************************************************)

let stat_fun =
   let arity_p = L.Const 0 in
   let arity_s = L.Const 1 in
   let body e o _ _ = function
      | [x] -> 
         let t = P.start_time () in
	 let r = (e.L.eval x) in
	 let s = P.stop_time t in
         o.L.out (Printf.sprintf "Stat: %s,%i\n" s (U.count r));
	 r
      | _   -> assert false
   in
   let txt_out o _ = function
      | [x] -> let o = L.std o in o.L.s_out "stat "; o.L.s_query x
      | _   -> assert false
   in   
   {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}

let _ = L.fun_register ["stat"] stat_fun

(* LOG **********************************************************************)

let log_fun xml src =
   let log_src e o x =
      let t = P.start_time () in o.L.s_query x;
      let s = P.stop_time t in
      if C.set e.L.conn C.Stat then o.L.s_out (Printf.sprintf "Log source: %s\n" s);
      e.L.eval x 
   in
   let log_res e o x =  
      let s = e.L.eval x in
      let t = P.start_time () in o.L.s_result s;
      let r = P.stop_time t in
      if C.set e.L.conn C.Stat then o.L.s_out (Printf.sprintf "Log: %s\n" r); s
   in
   let txt_log o = 
      if xml then o.L.s_out "xml ";
      if src then o.L.s_out "source "
   in
   let arity_p = L.Const 0 in
   let arity_s = L.Const 1 in
   let body e o _ _ = function
      | [x] -> let o = L.std o in if src then log_src e o x else log_res e o x
      | _   -> assert false
   in        
   let txt_out o _ = function
      | [x] -> let o = L.std o in o.L.s_out "log "; txt_log o; o.L.s_query x
      | _   -> assert false
   in   
   {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}

let _ = L.fun_register ["log"; "text"; "result"] (log_fun false false)

let _ = L.fun_register ["log"; "text"; "source"] (log_fun false true)

(* RENDER *******************************************************************)

let render_fun = 
   let arity_p = L.Const 0 in
   let arity_s = L.Const 1 in
   let body e o _ _ = function
      | [x] -> 
         let rs = ref "" in
	 let out s = rs := ! rs ^ s in 
         o.L.result out " " (e.L.eval x);
	 I.make ! rs I.grp_empty
      | _   -> assert false
   in
   let txt_out o _ = function
      | [x] -> let o = L.std o in o.L.s_out "render "; o.L.s_query x
      | _   -> assert false
   in   
   {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}

let _ = L.fun_register ["render"] render_fun

(* READ *********************************************************************)

let read_fun = 
   let arity_p = L.Const 0 in
   let arity_s = L.Const 1 in
   let body e o i _ = function
      | [x] -> 
         let aux avs s _ = 
	    let ich = open_in s in
	    let r = i.L.result_in (Lexing.from_channel ich) in
	    close_in ich; I.union avs r
	 in
	 I.iter aux I.empty (e.L.eval x)
      | _   -> assert false
   in
   let txt_out o _ = function
      | [x] -> let o = L.std o in o.L.s_out "read "; o.L.s_query x
      | _   -> assert false
   in   
   {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}

let _ = L.fun_register ["read"] read_fun

(* ALIGN ********************************************************************)

let align_fun =
   let aux2 l v =
      let c = String.length v in
      if c < l then String.make (l - c) ' ' ^ v else v
   in
   let aux l r s gl _ = I.append r (U.make_x (aux2 l s) gl) in
   let arity_p = L.Const 0 in
   let arity_s = L.Const 2 in
   let body e _ _ _ = function
      | [y; x] ->
         let l = U.int_of_avs (e.L.eval y) in
         I.x_iter (aux l) I.empty (e.L.eval x)      
      | _      -> assert false
   in
   let txt_out o _ = function
      | [y; x] -> 
         let o = L.std o in
	 o.L.s_out "align "; o.L.s_query y; o.L.s_out " in "; o.L.s_query x
      | _      -> assert false
   in
   {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}

let _ = L.fun_register ["align"] align_fun

(* IF ***********************************************************************)

let if_fun =
   let arity_p = L.Const 0 in
   let arity_s = L.Const 3 in
   let body e _ _ _ = function
      | [y; x1; x2] ->
         if U.bool_of_avs (e.L.eval y) then (e.L.eval x1) else (e.L.eval x2)
      | _           -> assert false
   in
   let txt_out o _ = function
      | [y; x1; x2] ->
         let o = L.std o in
         o.L.s_out "if "; o.L.s_query y; o.L.s_out " then "; o.L.s_query x1; 
	 o.L.s_out " else "; o.L.s_query x2
      | _           -> assert false
   in
   {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}

let _ = L.fun_register["if"] if_fun 

(* INTERSECT ****************************************************************)

let intersect_fun =
   let rec iter f = function
      | []           -> assert false
      | [head]       -> f head
      | head :: tail -> I.intersect (f head) (iter f tail)  
   in
   let arity_p = L.Const 0 in
   let arity_s = L.Positive in
   let body e _ _ _ xl = iter e.L.eval xl in
   let txt_out o _ = function
      | []           -> assert false
      | [x1; x2]     -> let o = L.std o in L.out_txt2 o "/\\" x1 x2
      | xl           -> let o = L.std o in L.out_txt_ o ["intersect"] xl  
   in   
   {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}

let _ = L.fun_register ["intersect"] intersect_fun

(* UNION ********************************************************************)

let union_fun = 
   let arity_p = L.Const 0 in
   let arity_s = L.Any in
   let body e _ _ _ xl = U.iter e.L.eval xl in
   let txt_out o _ xl = let o = L.std o in L.out_txt_ o [] xl  
   in      
   {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}

let _ = L.fun_register ["union"] union_fun

(* OR ***********************************************************************)

let or_fun = 
   let rec iter f = function
      | []           -> U.val_false
      | head :: tail -> 
         let r1 = f head in
	 if U.bool_of_avs r1 then r1 else (iter f tail)
   in
   let arity_p = L.Const 0 in
   let arity_s = L.Any in
   let body e _ _ _ xl = iter e.L.eval xl in
   let txt_out o _ = function
      | [x1; x2]     -> let o = L.std o in L.out_txt2 o "||" x1 x2
      | xl           -> let o = L.std o in L.out_txt_ o ["or"] xl  
   in
   {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}

let _ = L.fun_register ["or"] or_fun

(* AND **********************************************************************)

let and_fun = 
   let rec iter f = function
      | []           -> U.val_true
      | [head]       -> f head
      | head :: tail -> 
         if U.bool_of_avs (f head) then iter f tail else U.val_false 
   in
   let arity_p = L.Const 0 in
   let arity_s = L.Any in
   let body e _ _ _ xl = iter e.L.eval xl in
   let txt_out o _ = function 
      | [x1; x2]  -> let o = L.std o in L.out_txt2 o "&&" x1 x2
      | xl        -> let o = L.std o in L.out_txt_ o ["and"] xl
   in
   {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}

let _ = L.fun_register ["and"] and_fun 

(* PROJ *********************************************************************)

let proj_fun =
   let aux2 p a q v _ = if p = q then I.union a (U.subj v) else a in   
   let aux p a _ gl _ = 
      I.union a (U.iter (I.x_grp_iter (aux2 p) I.empty) gl) 
   in
   let arity_p = L.Const 1 in
   let arity_s = L.Const 1 in
   let body e _ _ pl xl =
      match pl, xl with
         | [p], [x] -> I.x_iter (aux p) I.empty (e.L.eval x)
	 | _        -> assert false
   in
   let txt_out o pl xl =
      match pl, xl with
         | [p], [x] -> 
	    let o = L.std o in
	    o.L.s_out "proj "; o.L.s_path p; o.L.s_out " of "; o.L.s_query x
	 | _        -> assert false
   in
   {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}

let _ = L.fun_register ["proj"] proj_fun

(* KEEP *********************************************************************)

let keep_fun b =   
   let aux2 s l a q v _ = 
      if List.mem q l = b then a else I.union a (I.make s (U.grp_make_x q v))
   in
   let aux l a s gl _ = 
      I.append a (
         if l = [] then I.make s I.grp_empty else 
	 U.iter (I.x_grp_iter (aux2 s l) I.empty) gl) 
   in  
   let txt_allbut o = if b then o.L.s_out "allbut " in
   let txt_path_list o l = P.flat_list o.L.s_out o.L.s_path ", " l in 
   let arity_p = L.Any in
   let arity_s = L.Const 1 in
   let body e _ _ pl xl =
      match b, pl, xl with
         | true, [], [x]  -> e.L.eval x
         | _, l, [x]      -> I.x_iter (aux l) I.empty (e.L.eval x)
         | _              -> assert false
  in
  let txt_out o pl xl =
      match pl, xl with
         | [], [x] -> 
	    let o = L.std o in 
	    o.L.s_out "keep "; txt_allbut o; o.L.s_query x
	 | l, [x]  -> 
	    let o = L.std o in
	    o.L.s_out "keep "; txt_allbut o; txt_path_list o l; 
	    o.L.s_out " in "; o.L.s_query x
	 | _      -> assert false
   in
   {L.arity_p = arity_p; L.arity_s = arity_s; L.body = body; L.txt_out = txt_out}

let _ = L.fun_register ["keep"; "these"] (keep_fun false)

let _ = L.fun_register ["keep"; "allbut"] (keep_fun true)