%{
(*Header*)
(********************************************************************)
(*                                                                  *)
(*                       ICAR toplevel, parser                      *)
(*                                                                  *)
(*                          Jean-Yves Moyen                         *)
(*                              Mai 2001                            *)
(*                                                                  *)
(********************************************************************)

open Langage
open Eval
open Quasi_interpretations
open Ordering

let string_to_prog s=Parser.prog Lexer.token (Lexing.from_string s)
let string_to_term s=Parser.term Lexer.token (Lexing.from_string s)
let string_to_polyl s=Parser.polyl Lexer.token (Lexing.from_string s)

let ic_to_prog ic=Parser.prog Lexer.token (Lexing.from_channel ic)
let ic_to_term ic=Parser.term Lexer.token (Lexing.from_channel ic)
let ic_to_polyl ic=Parser.polyl Lexer.token (Lexing.from_channel ic)


let clearall()=Parser.clearall Lexer.token (Lexing.from_string "")

let file_to_prog s=
  let ic = open_in s in
  let prg = ic_to_prog ic in
    close_in ic;
    prg

let file_to_polyl s=
  let ic = open_in s in
  let prg = ic_to_polyl ic in
    close_in ic;
    prg

let time=ref 0 and heap=ref 0 and stack=ref 0 and total=ref 0

let current_prog = 
  ref { rules = [] ; 
	interp = Interp.empty ;
	funname = Hashtbl.create 1 ;
	conname = Hashtbl.create 1 }

let merge_prg prg1 prg2=
  Hashtbl.iter (fun k a -> Hashtbl.add prg2.funname k a) prg1.funname;
  Hashtbl.iter (fun k a -> Hashtbl.add prg2.conname k a) prg1.conname;
  { rules = prg1.rules@prg2.rules ;
    interp = Interp.fold Interp.add prg1.interp prg2.interp ;
    funname = prg2.funname ;
    conname = prg2.conname }

let eval sem term=
  time:=0;
  heap:=0;
  stack:=0;
  total:=0;
  sem !current_prog time heap stack total term

let list_to_string ets sep l =
   let rec go =
     function
	 [] -> ""
       | [a] -> ets a
       | a::r -> (ets a) ^ sep ^ (go r)
   in Printf.sprintf "%s" (go l) 

let rec term_to_string prg=
   function
       Var x -> Printf.sprintf "x%i" x
     | Con(c,[]) -> Hashtbl.find prg.conname c.idc
     | Con(c,tl) -> 
	 Printf.sprintf "%s(%s)" 
	 (Hashtbl.find prg.conname c.idc) 
	 (list_to_string (term_to_string prg) "," tl)
     | Fun(f,tl) -> 
	 Printf.sprintf "%s(%s)" 
	 (Hashtbl.find prg.funname f.idf)
	 (list_to_string (term_to_string prg) "," tl)

let eq_to_string prg eq =
   Printf.sprintf "%s -> %s" 
     (term_to_string prg (Fun(eq.lfun,List.map pat_to_term eq.lpat)))
     (term_to_string prg eq.rside)

let varp_to_string i = Printf.sprintf "x%i" i
let varpl_to_string = list_to_string varp_to_string ","

let interp_to_string prg g (pol,varl) =
   match g with
       F f -> 
	 Printf.sprintf "[%s](%s)=%s" 	 
	 (Hashtbl.find prg.funname f) (varpl_to_string varl)
	 (pol_to_string pol)
     | C c -> 
	 Printf.sprintf "[%s](%s)=%s" 	 
	 (Hashtbl.find prg.conname c) (varpl_to_string varl)
	 (pol_to_string pol)


let prg_to_string prg=
  Interp.fold 
    (fun x y s -> (Printf.sprintf "%s\n%s" s (interp_to_string prg x y)))
    prg.interp ((list_to_string (eq_to_string prg) "\n" prg.rules) ^ "\n\n")
  ^ "\n"

let evaluate sem term=
  let t=eval sem term in
    Printf.printf "Time usage : %i\n" !time;
    Printf.printf "Maximum heap size: %i\n" !heap;
    Printf.printf "Maximum stack size: %i\n" !stack;
    Printf.printf "Total space usage: %i\n" !total;
    Printf.printf "Result     : %s\n" (term_to_string !current_prog t)

let semcbv=ref true

let eval' t= evaluate (if !semcbv then cbv else memoize) t

let cbv = evaluate cbv
and mem = evaluate memoize

let rec nat=
  function
      0 -> []
    | n -> n::(nat (n-1))

let qi_chk()=
  let lpol = check_qi !current_prog in
    List.filter (fun x -> snd x<>True)
      (List.combine (List.rev (nat (List.length lpol))) lpol) 
  
let qi_print tochk=
  try
    if tochk=[]
    then Printf.printf "Quasi-interpretation are OK.\n"
    else 
      let i = fst (List.find (fun x -> snd x = False) tochk) in
	Printf.printf 
	  "The equation %i is not decreasing for the Quasi-interpretation.\n"
	  i
  with
      Not_found ->
	begin
	  let rec go =
	    function
		[] -> ()
	      | (i,p)::l ->
		  Printf.printf "Cannot check equation %i: %s.\n"
		  i (pol_to_string p);
		  go l
	  in go tochk
	end

let qi_main()=
  try
    qi_print (qi_chk())
  with
      NoQI -> Printf.printf "Some quasi-interpretations are missing\n"
	
let order_chk b name=
  try
    if b
    then Printf.printf "The program terminates by %s.\n" name
    else Printf.printf "The program doesn't terminates by %s.\n" name
  with
      _ -> Printf.printf "The program doesn't terminates by %s.\n" name

let mpo_chk () = order_chk (is_ord Mpo.mpo !current_prog) "MPO"
and lpo_chk () = order_chk (is_ord Lpo.lpo !current_prog) "LPO"

let all_check ()=
  let mpo = try is_ord Mpo.mpo !current_prog with _->false in
    order_chk mpo "MPO";
    if mpo
    then
      try 
	let qi = qi_chk () in
	  qi_print qi;
	  if qi=[]
	  then Printf.printf "the function is Ptime computable.\n"
	  else Printf.printf "the function is Primitive Recursive.\n"
      with
	  NoQI -> 
	    Printf.printf "Some quasi-interpretations are missing\n";
	    Printf.printf "the function is Primitive Recursive.\n"
    else
      let lpo = is_ord Lpo.lpo !current_prog in
	order_chk lpo "LPO";
	if lpo
	then
	  try
	    let qi = qi_chk () in
	      qi_print qi;
	      if qi=[]
	      then Printf.printf "the function is Pspace computable.\n"
	      else Printf.printf "The function is Multiple recursive.\n"
	  with
	      NoQI -> 
		Printf.printf "Some quasi-interpretations are missing\n";
		Printf.printf "The function is Multiple recursive.\n"
	else
	  ()

let print () = print_string (prg_to_string !current_prog)
	  
let helpvide =
  "Commands are: load, add, cbv, mem, eval, getsem, setcbv, setmem\n               mpo, lpo, check, qi, print, help, quit\n"
and helpload =
  "load <file>\nLoad the equations and quasi-interpretations in <file> and replace the\ncurrent program.\n"
and helpadd =
  "add <file>\nLoad the equations and quasi-interpretations in <file> and add them to\nthe current program.\n"
and helpcbv =
  "cbv <term>\nEvaluate the term using call-by-value (no cache) semantics.\n"
and helpmem =
  "mem <term>\nEvaluate the term using memoization.\n"
and helpeval =
  "eval <term>\nEvaluate the term using the current semantics\n(memoization or call-by-value).\n"
and helpgetsem =
  "Print the current semantics (memoization or call-by-value).\n"
and helpsetcbv = 
  "Set the current semantics to call-by-value.\n"
and helpsetmem = 
  "Set the current semantics to memoization.\n"
and helpcheck =
  "Check if the current program terminates either by MPO or LPO,\nand check if the quasi-interpretations are OK.\n"
and helplpo = 
  "Check if the current program terminates by LPO.\n"
and helpmpo = 
  "Check if the current program terminates by MPO.\n"
and helpqi =
  "Check if the quasi-interpretations are OK.\n"
and helpprint =
  "Print the current program and the quasi-interpretations.\n"
and helphelp =
  "help <command>\nGive information about the command.\n"
and helpquit =
  "Leave ICAR."

%}
/*declaration*/
%token LOAD ADD CBV MEM EVAL GETSEM SETCBV SETMEM CHK LPO MPO QI 
%token PRINT HELP QUIT EOL
%token <string> IDENT 

%start cmd
%type <unit> cmd

%%
/*rules*/

cmd:    /*unit*/
   LOAD IDENT {clearall() ; current_prog:=file_to_prog $2}
 | ADD IDENT {current_prog := merge_prg !current_prog (file_to_prog $2)}
 | CBV IDENT {cbv (string_to_term $2)}
 | MEM IDENT {mem (string_to_term $2)}
 | EVAL IDENT {eval' (string_to_term $2)}
 | SETCBV {semcbv:=true}
 | SETMEM {semcbv:=false}
 | GETSEM 
     {print_string (if !semcbv then "Call by value\n" else "Memoization\n")}
 | CHK {all_check ()}
 | LPO {lpo_chk ()}
 | MPO {mpo_chk ()}
 | QI {qi_main()}
 | PRINT {print ()}
 | HELP EOL {print_string helpvide}
 | HELP LOAD {print_string helpload}
 | HELP ADD {print_string helpadd}
 | HELP CBV {print_string helpcbv}
 | HELP MEM {print_string helpmem}
 | HELP EVAL {print_string helpeval}
 | HELP GETSEM {print_string helpgetsem}
 | HELP SETCBV {print_string helpsetcbv}
 | HELP SETMEM {print_string helpsetmem}
 | HELP CHK {print_string helpcheck}
 | HELP LPO {print_string helplpo}
 | HELP MPO {print_string helpmpo}
 | HELP QI {print_string helpqi}
 | HELP PRINT {print_string helpprint}
 | HELP HELP {print_string helphelp}
 | HELP QUIT {print_string helpquit}
 | QUIT {exit 0}
 | HELP {print_string helpvide}
 | IDENT {print_string helpvide}

%%
(*trailer*)

