(*LP2 06/07*)
(*correction tp4 entier, L.Gonnord, J-F.Monin, M.Peron*)

(* pour evaluer, decommenter *)
(* #load "camlp4o.cma"  *)

(*sinon, compiler avec :*)
(* ocamlc -pp "camlp4o pa_extend.cmo" -I +camlp4 -c tp4-cor_entier.ml *)
(* ocamlc tp4-cor_entier.cmo -o tp4 *)

(*executer les exemples avec:*)
(* ./tp4 tests.txt *)

open Format 

(*Types utiles*)
type oper1 = 
  | Non | Opp

type oper2 = 
  | Plus | Moins | Mult | Div | Ou | Et | Eq

type expr = 
  | Int of int
  | Bool of bool
  | Var of string
  | Op1 of oper1 * expr
  | Op2 of oper2 * expr * expr
  | Si of expr * expr * expr
  | Let of string * expr * expr
  | Rec of string * expr * expr
  | Fun of string * expr
  | App of expr * expr

type valeur =
  | Vint of int
  | Vbool of bool
  | Vfun of environnement * string * expr

and environnement = 
  | Evide
  | Elie of environnement * string * valeur
(*voir le cours pour les environnements*)

let pp_print_valeur fmt (vall:valeur) = match vall with
  | Vint(n) -> pp_print_int fmt n
  | Vbool(b) -> pp_print_bool fmt b
  | Vfun(env,str,expr) -> pp_print_string fmt "Fun"

exception Non_defini of string

(*Quelle est la valeur de mon id i dans l'environnement ?*)
let rec valeur i = function
  | Evide -> raise (Non_defini(i))
  | Elie(env, s, v) when i = s -> v
  | Elie(env, _, _) -> valeur i env

exception Autre_type_attendu of string

(*les fonction suivantes permettent de gérer le mixage entier/bool*)
let fop1 = function
  | Non ->
      (function
	| Vbool(v) -> Vbool(not v)
	| _ -> raise (Autre_type_attendu "bool"))
  | Opp ->
      (function
	| Vint(v) -> Vint(- v) 
	| _ -> raise (Autre_type_attendu "entier"))


let releve_int f = fun v1 v2 ->
  match v1,v2 with
  | Vint(x1), Vint(x2) -> Vint(f x1 x2)
  | _, _ -> raise (Autre_type_attendu "entier")

let releve_bool f = fun v1 v2 ->
  match v1,v2 with
  | Vbool(x1), Vbool(x2) -> Vbool(f x1 x2)
  | _, _ -> raise (Autre_type_attendu "bool")

type boite_cmp = {fcmp : 'a.'a -> 'a -> bool}

let releve_cmp f = fun v1 v2 ->
  match v1,v2 with
  | Vint(x1), Vint(x2) -> Vbool(f.fcmp x1 x2)
  | Vbool(x1), Vbool(x2) -> Vbool(f.fcmp x1 x2)
  | _, _ -> raise (Autre_type_attendu "comparaison sur types identiques")

let fop2 = function
  | Plus -> releve_int (+)
  | Moins -> releve_int (-)
  | Mult -> releve_int ( * )
  | Div -> releve_int (/)
  | Ou -> releve_bool (||)
  | Et -> releve_bool (&&)
  | Eq -> releve_cmp {fcmp = (=)}

(*LA fonction d'évaluation dans un environnement fixé !*)
let rec eval env = function
  | Int(n) -> Vint(n)
  | Bool(b) -> Vbool(b)
  | Var(i) -> valeur i env
  | Op1(op, e1) -> fop1 op (eval env e1)
  | Op2(op, e1, e2) -> fop2 op (eval env e1) (eval env e2)
  | Si(b, e1, e2) -> 
      (match eval env b with
      | Vbool(vb) -> if vb then eval env e1 else eval env e2
      | _ -> raise (Autre_type_attendu "bool"))
  | Fun(i_v, e) -> Vfun(env, i_v, e)
  | App(e1, e2) ->
      let v2 = eval env e2 in
      (match eval env e1 with
      | Vfun(env', i, e) -> eval (Elie (env', i, v2)) e
      | _ -> raise (Autre_type_attendu "fonction"))
  | Let(i, e1, e2) ->
      let v1 = eval env e1 in
      let env' = Elie(env, i, v1) in
      eval env' e2
  | Rec(i_f, Fun(i_v, e1), e2) ->
      let rec v1 = Vfun(env', i_v, e1)  (* construit une structure bouclée *)
      and env' = Elie(env, i_f, v1) in  
      eval env' e2
  | Rec(i, e1, e2) -> failwith "expr non permise dans 'soit rec'"

(* 
Pour tester, il est plus facile d'entrer un arbre sous forme infixe.
On commence par l'analyseur lexical, qui parcourt un flot de caractères
et produit un flot de lexèmes destiné à l'analyseur lexical.
Ce dernier produit un arbre de type expr.
*)

(* ANALYSEUR LEXICAL sur un flot de caractères *)

(* Pour le test *)
let rec list_of_stream = parser
  | [< 'x; l = list_of_stream >] -> x :: l
  | [< >] -> []

(* test *)
let _ =  list_of_stream (Stream.of_string "45089")


(* Schéma de Horner *)
let valchiffre c = int_of_char c - int_of_char '0'
let rec horner n = parser 
  | [< '  '0'..'9' as c; s >] -> horner (10 * n + valchiffre c) s
  | [< >] -> n

(* test *)
let _ =  horner 0 (Stream.of_string "45089")

(* Identificateurs *)
let ident =
  let bu = Buffer.create 16 in 
  let rec ident_aux = parser
    | [< '  'a'..'z' as c; s >] -> 
	Buffer.add_char bu c; ident_aux s
    | [< >] -> Buffer.contents bu in
  let ident c s = Buffer.clear bu; Buffer.add_char bu c; ident_aux s in
  ident

(* test *)
let _ =  ident 'c' (Stream.of_string "oucou 45")
let _ =  ident 'y' (Stream.of_string "oucou 45")

(* Type des lexèmes *)
type token = 
    Tent of int | Tident of string | 
    Tlet | Trec | Tin | Tfun | To |
    Tplus | Tmoins | Tmult | Tdiv |
    Tou | Tet | Tnon | Teg |
    Tsi | Talors | Tsinon |
    Tvrai | Tfaux |
    Tparouv | Tparfer

(* 
Le procédé efficace pour produire un flot de lexèmes (sous Ocaml)
consiste à utiliser la primitive Stream.from 
*)
let rec next_token = parser
  | [< '  ' '|'\n'; tk = next_token >] -> tk
  | [< '  '0'..'9' as c; n = horner (valchiffre c) >] -> Some (Tent (n))
  | [< '  'a'..'z' as c; s = ident c >] ->
      let tok = match s with
      | "fun" -> Tfun
      | "soit" -> Tlet
      | "rec" -> Trec
      | "to" -> To
      | "dans" -> Tin
      | "si" -> Tsi
      | "alors" -> Talors
      | "ou" -> Tou
      | "et" -> Tet
      | "non" -> Tnon
      | "sinon" -> Tsinon
      | "vrai" -> Tvrai
      | "faux" -> Tfaux
      | _ -> Tident (s)
      in Some (tok)
  | [< ''+' >] -> Some (Tplus)
  | [< ''-'; t = moins >] -> t
  | [< ''*' >] -> Some (Tmult)
  | [< ''/'; t = slash >] -> t
  | [< ''=' >] -> Some (Teg)
  | [< ''(' >] -> Some (Tparouv)
  | [< '')' >] -> Some (Tparfer)
  | [< >] -> None

and slash = parser
  | [< ''\\' >] -> Some (Tet)
  | [< >] -> Some (Tdiv)

and moins = parser
  | [< ''>' >] -> Some (To)
  | [< >] -> Some (Tmoins)

let lex s = Stream.from (fun _ -> next_token s)

(* let s1 = list_of_stream (lex (Stream.of_string "3 - 6/\6* si a=a alors 4")) *)

(* ANALYSEUR SYNTAXIQUE sur un flot de lexèmes *)

(* Récursif descendant *)

let rec p_expr = parser
  | [< ' Tfun; ' Tident(i); ' To;  e = p_expr>] -> 
      Fun(i, e)
  | [< ' Tlet; e = p_rec >] -> e
  | [< ' Tsi; eb = p_expr; ' Talors; e1 = p_expr; ' Tsinon; e2 = p_expr>] -> 
      Si(eb, e1, e2)
  | [< t = p_conj; e = p_s_disj t >] -> e
and p_rec = parser
  | [< ' Trec; e = p_let true>] -> e
  | [< e = p_let false>] -> e
and p_let b = parser
  | [< ' Tident(i); ' Teg;  e1 = p_expr; ' Tin; e2 = p_expr>] -> 
      if b then Rec(i, e1, e2) else  Let(i, e1, e2)
and p_s_disj a = parser 
  | [< ' Tou; t = p_conj; e = p_s_disj (Op2(Ou,a,t)) >] -> e
  | [< >] -> a
and p_conj = parser 
  | [< f = p_litteral; t = p_s_conj f >] -> t
and p_s_conj a = parser 
  | [< ' Tet; f = p_litteral; t = p_s_conj (Op2(Et,a,f)) >] -> t
  | [< >] -> a
and p_litteral = parser 
  | [< ' Tnon; f = p_litteral>] -> Op1(Non,f)
  | [< e = p_comparable; c = p_comparaison e >] -> c
and p_comparaison e1 = parser
  | [<' Teg; e2 = p_comparable>] -> Op2(Eq,e1,e2)
  | [< >] -> e1
and p_comparable = parser
  | [< t = p_terme; e = p_s_add t >] -> e
and p_s_add a = parser 
  | [< ' Tplus; t = p_terme; e = p_s_add (Op2(Plus,a,t)) >] -> e
  | [< ' Tmoins; t = p_terme; e = p_s_add (Op2(Moins,a,t)) >] -> e
  | [< >] -> a
and p_terme = parser 
  | [< f = p_appli; t = p_s_mul f >] -> t
and p_s_mul a = parser 
  | [< ' Tmult; f = p_appli; t = p_s_mul (Op2(Mult,a,f)) >] -> t
  | [< ' Tdiv; f = p_appli; t = p_s_mul (Op2(Div,a,f)) >] -> t
  | [< >] -> a
and p_appli = parser 
  | [< b = p_oppose; f = p_facteur; r = p_args f>] -> 
      if b then Op1(Opp,r) else r
and p_oppose = parser
  | [< ' Tmoins >] -> true
  | [< >] -> false
and p_args f = parser
  | [< a = p_facteur; r = p_args (App(f, a))>] -> r
  | [< >] -> f
and p_facteur = parser 
  | [< ' Tent(n)>] -> Int(n)
  | [< ' Tvrai>] -> Bool(true)
  | [< ' Tfaux>] -> Bool(false)
  | [< ' Tident(i)>] -> Var(i)
  | [< ' Tparouv; e = p_expr; ' Tparfer>] -> e


exception WrongNb
(*fonction exécutée afin de traiter le in_channel chan_fich*)
(*elle est de type void, elle imprime uniquement le résultat de l'évaluation*)
(*La différence avec la correction précédente, c'est qu'elle traite les fichiers*)
(*qui ont plusieurs lignes, une expression par ligne*)
let main chan_fich = (
  try (
    while (true) do 
      begin
	let string = input_line chan_fich (*on suppose qu'on lit la premiere ligne*)
	in 
	  printf "expression à traiter : %s --> " string;
	  let flux1 = lex (Stream.of_string string) in
	  try (
	    let resu = eval Evide (p_expr flux1) in
	      (*on evalue l'expression dans l'environnement initial vide*)
	      printf "resultat = %a \n" pp_print_valeur resu
	  ) 
	  with 
	    | Autre_type_attendu(s) -> printf "une sous-expression n'a pas le type attendu : %s\n" s
	    | Non_defini(s) -> printf "%s n'est pas définie\n" s
	    | _ -> printf "autre pb ?\n"
      end
    done
  )
  with | End_of_file -> ()
)


(*FONCTION PRINCIPALE DU PROGRAMME, c'est elle qui est exécutée*)
let _ =
  try
    (
      let nb_of_args = Array.length (Sys.argv) 
      in 
	if nb_of_args <> 2 then 
	  raise WrongNb
	else 
	  let name = Sys.argv.(1) in
	  let chan = open_in name in 
	    printf "%s is now open  \n" name;
	    (*apres ouverture du fichier, exécuter la fonction nommée main*)
	    main chan; 
	    (*on ferme proprement*)
	    close_in chan;
	    printf "%s has closed successfully \n" name;
    )
  with
    | Sys_error(s) -> prerr_string ("Sys_error "^s);prerr_newline()
    | WrongNb -> prerr_string ("File not found") ;prerr_newline()