(* aintv.ml, Objective Caml version 3.08.1 *)

open Print;;
open Entrent;;

(*** erreurs a l'execution (detectables par un compilateur) ***)
exception Failure of string ;;

(*** syntaxe abstraite ***)

(* parametre formel par valeur *)
type fpar = FPVAL of string 
            | FPNECSTAT of string (* par necessite statique *)
            | FPNECDYN of string (* par necessite dynamique *)
;;

(* liste de parametres formels *)
type fpar_list = fpar list ;;

(* fonction anonyme : liste des parametres formel, corps *)
type anonymous_function = (fpar_list * expr) ;;

(* declaration de fonction :  nom fonction, fonction anonyme *)
type function_declaration  = (string * anonymous_function) ;;

(* liste de declarations de fonctions *)
type function_declaration_list = function_declaration list ;;

(* programme : liste de declarations de fonctions, corps *)
type prog = function_declaration_list * expr ;;

(* recherche de la liste de parametres formels et du corps *)
(* d'une fonction dans une liste de declarations           *)
type isdeclfun = FUNDECLARED of anonymous_function 
               | FUNnotDECLARED ;;

(* valeur d'un parametre formel dans la pile d'execution *)
type find = FOUND of parval | NotFOUND ;;

(* affectation d'une valeur a un parametre formel dans la *)
(* pile d'execution                                       *)
type assign = ASSIGNED of bindings | NotASSIGNED of bindings ;;

(* recherche de la liste de parametres formels et du corps *)
(* d'une fonction dans une liste de declarations           *)
let rec fparsbody =
  function (f, (fj, h) :: fds) -> if f = fj then FUNDECLARED(h)
                                       else fparsbody(f, fds)
   | (f, [])              -> FUNnotDECLARED ;;

(*** interpretation des fonctions primitives ***)

let iadd =
 function ((NCST n1), (NCST n2)) -> (NCST (n1 + n2))
  |  ((ECST s), e)          -> (ECST s)
  |  (e, (ECST s))          -> (ECST s)
  |  (e1, e2)               -> (ECST "addition of non-integer values")
;;

let isub =
 function ((NCST n1), (NCST n2)) -> (NCST (n1 - n2))
  |  ((ECST s), e)          -> (ECST s)
  |  (e, (ECST s))          -> (ECST s)
  |  (e1, e2)               -> (ECST "subtraction of non-integer values")
;;

let imult =
 function ((NCST n1), (NCST n2)) -> (NCST (n1 * n2))
  |  ((ECST s), e)          -> (ECST s)
  |  (e, (ECST s))          -> (ECST s)
  |  (e1, e2)               -> (ECST "multiplication of non-integer values")
;;

let idiv =
 function ((NCST n1), (NCST n2)) -> (NCST (n1 / n2))
  |  ((ECST s), e)          -> (ECST s)
  |  (e, (ECST s))          -> (ECST s)
  |  (e1, e2)               -> (ECST "division of non-integer values")
;;

let iless =
 function ((NCST n1), (NCST n2)) -> (BCST (n1 < n2))
  |  ((ECST s), e)          -> (ECST s)
  |  (e, (ECST s))          -> (ECST s)
  |  (e1, e2)               -> (ECST "inequality of non-integer values")
;;

let iequal =
 function ((NCST n1), (NCST n2)) -> (BCST (n1 = n2))
(* Personnalisation : egalite entre booleens *)
  | ( ( BCST n1 ), (BCST n2 ) ) -> ( BCST (n1 = n2) )
(* Fin de personnalisation *)
  |  ((ECST s), e)          -> (ECST s)
  |  (e, (ECST s))          -> (ECST s)
  |  (e1, e2)               -> (ECST "equality of values de types distincts")
;;

let inot =
 function (BCST true)  -> (BCST false)
  |  (BCST false) -> (BCST true)
  |  (ECST s)     -> (ECST s)
  |  e            -> (ECST "negation of non-boolean values") 
;;

let iand =
 function ((BCST b1), (BCST b2)) -> (BCST (b1 & b2))
  |  ((ECST s), e)          -> (ECST s)
  |  (e, (ECST s))          -> (ECST s)
  |  (e1, e2)               -> (ECST "conjunction of non-boolean values")
;;

let irand = function
  | NCST s -> NCST (Random.int s)
  | ECST s -> ECST s
  | _ -> ECST "random of non-integer limit"
;;

let iin () = NCST (entree_entier ());;

(*** pile a l'execution ***)

(* appel de fonction : empiler la liaison de parametres b sur *)
(* l'environnement r                                          *)
let push =
 function (b,  r) -> b :: r ;;

(* retour de fonction: depiler la liaison de parametres b de *)
(* l'environnement r                                         *) 
let pull =
 function (b :: r, v) -> (r, v)
  |  _           -> raise (Failure "pull") ;;

(* recherche dans une liaison de parametres *)
let rec val_in_bindings =
 function (x, (y, v) :: b) -> if x = y then (FOUND v)
                                  else (val_in_bindings (x, b))
  |  (x, [])          -> NotFOUND ;;

(* recherche dans la pile d'execution *)
let rec val_in_env =
 function (x, (f, b) :: r) -> (match val_in_bindings (x, b) with
                               (FOUND v) -> (FOUND v)
                           |   NotFOUND  -> (val_in_env (x, r))
                         )
  |  (x, [])          -> NotFOUND ;;

(* affectation dans une liaison de parametres *)
let rec assign_in_bindings =
 function (x, v, ((y, p) :: b))
       -> if x = y then 
            (ASSIGNED ((x, (VALUE v)) :: b))
          else
            (match assign_in_bindings (x, v, b) with
              (ASSIGNED bm)    -> (ASSIGNED ((y, p) :: bm))
            | (NotASSIGNED bm) -> (NotASSIGNED ((y, p) :: bm))
            )
 |   (x, v, [])  
       -> (NotASSIGNED []);;

(* affectation dans la pile d'execution *)
let rec assign_env =
 function (x, v, (f, b) :: r)
       -> (match assign_in_bindings (x, v, b) with
            (ASSIGNED bm)    -> (f, bm) :: r
          | (NotASSIGNED bm) -> (f, bm) :: (assign_env (x, v, r))
          )
  |  (x, v, [])        
       -> [("main",
            [(x, (VALUE (ECST "variable affectee mais non declaree")))])];;

(*** interpretation d'un programme ***)

(* trace d'execution elementaire *)
let istracing = ref false ;;
let trace_eval () = istracing := true ;;
let untrace_eval () = istracing := false ;;

(* impression du resultat de l'evaluation *)
let echo_result re =
  match re with
    ([], v) -> echo_val v; print_string "\n"
  | _       -> print_string "\n echo_result: unexpected result \n" ;;
  
open Print;;

(* evaluation du programme p *)
let evalprog = function (fds, ep) ->
 let rec
  (* (bind ((fps, aps), r)) lier les parametres formels fps *)
  (* aux parametres effectifs aps dans l'environnement r.   *)
  bind = 
      function ((((FPVAL x) :: fps), (e :: aps)), r) 
              -> if !istracing then
                  (print_string ("\nbind == "^x); print_newline ()
                  );
                  let (r', v') = (eval (e, r)) in
                   let (r'', b) = (bind ((fps, aps), r')) in
                     (r'', ((x, (VALUE v')) :: b))
 
       |  ((((FPNECDYN x) :: fps), (e :: aps)), r) -> 
                  if !istracing then
                  (print_string ("\nbind lazy_dyn == "^x); print_newline ()
                  );
(*                  let (r', v') = (eval (e, r)) in *)
                   let (r'', b) = (bind ((fps, aps), r )) in
                     (r'', ((x, (LAZYDYN (e, ref None))) :: b))

       |  ((((FPNECSTAT x) :: fps), (e :: aps)), r) -> 
                  if !istracing then
                  (print_string ("\nbind lazy_stat == "^x); print_newline ()
                  );
(*                  let (r', v') = (eval (e, r)) in *)
                   let (r'', b) = (bind ((fps, aps), r )) in
                     (r'', ((x, (LAZYSTAT ((e,r), ref None))) :: b)) (* attention, r, pas r'' *)


       |  (([], []), r)  ->  (r, [])
       |  (([], aps), r) -> raise (Failure "too many actual parameters")
       |  ((fps, []), r) -> raise (Failure "too few actual parameters")
 and
  (* eval (e, r) evalue l'expression e dans l'environnement r et *)
  (* retourne  (r', v),  ou r' est l'environnement modifie et v  *)
  (* est la valeur de e                                          *)
  eval c =
    if !istracing then
        (print_string "\neval ===> \n";
         print_expr_env c
        );
    let reseval =
      match c with
          ((CST "true"), r)  -> (r, (BCST true))
       |  ((CST "false"), r) -> (r, (BCST false))
       |  ((CST n), r) -> (r, (try (NCST (int_of_string n)) with
                               Failure s -> (ECST "boolean or integer required")
                              ))
       |  ((VAR x), r) ->
             (match val_in_env(x, r) with
                (FOUND (VALUE v)) -> (r, v)

             | FOUND (LAZYDYN (e1, vr)) ->
                 begin
                   match !vr with
                     | Some v -> (r,v)
                     | None -> let (_, v') as res = eval (e1,r) in (vr := Some v'; res)
                 end 

             | FOUND (LAZYSTAT (c1, vr)) ->
                 begin
                   match !vr with
                     | Some v -> (r,v)
                     | None -> let (_, v') = eval c1 in (vr := Some v'; (r,v'))
                 end 

             |  NotFOUND -> (r, (ECST ("variable " ^ x ^ " not declared")))
             )
       |  ((ADD (e1, e2)), r) ->
            let (r1, v1) = (eval (e1, r)) in
              let (r2, v2) = (eval (e2, r1)) in
                (r2, iadd(v1, v2))
       |  ((SUB (e1, e2)), r) ->
            let (r1, v1) = (eval (e1, r)) in
              let (r2, v2) = (eval (e2, r1)) in
                (r2, isub(v1, v2))
       |  ((MULT (e1, e2)), r) ->
            let (r1, v1) = (eval (e1, r)) in
              let (r2, v2) = (eval (e2, r1)) in
                (r2, imult(v1, v2))
       |  ((DIV (e1, e2)), r) ->
            let (r1, v1) = (eval (e1, r)) in
              let (r2, v2) = (eval (e2, r1)) in
                (r2, idiv(v1, v2))
       |  ((LESS (e1, e2)), r) ->
            let (r1, v1) = (eval (e1, r)) in
              let (r2, v2) = (eval (e2, r1)) in
                (r2, iless(v1, v2))
       |  ((EQUAL (e1, e2)), r) ->
            let (r1, v1) = (eval (e1, r)) in
              let (r2, v2) = (eval (e2, r1)) in
                (r2, iequal(v1, v2))
       |  ((NOT e), r) ->
            let (rp, v) = (eval (e, r)) in
              (rp, inot(v))
       |  ((AND (e1, e2)), r) ->
            let (r1, v1) = (eval (e1, r)) in
              let (r2, v2) = (eval (e2, r1)) in
                (r2, iand(v1, v2))
       | ((IF (e1, (e2, e3))), r) ->
            (match (eval (e1, r)) with
              (r1, (BCST b)) -> if b then (eval (e2, r1))
                                else (eval (e3, r1))
            | (r1, (NCST n)) -> (r1, (ECST "integer result in a test"))
            | (r1, (ECST s)) -> (r1, (ECST s))
            )
       | ((CALL (f, aps)), r) ->
            (match (fparsbody (f, fds)) with
              (FUNDECLARED (fps, bf)) -> 
                let (r', b) = (bind ((fps, aps), r)) in
                (pull (eval (bf, (push ((f, b), r'))) ) )
            | FUNnotDECLARED ->
                (r, (ECST ("function " ^ f ^ " not declared")))
            )

       | (EXPRSEQ (e1, e2), r) ->
           let r1, _ = eval (e1, r) in eval (e2, r1)
       | (OUTPUT e, r) -> (let (_, v) as res = eval (e, r) in echo_val v; print_newline ();  res)
       | (INPUT, r) -> (r, iin ())
       | (RANDOM e, r) -> let (r1, v1) = eval (e, r) in (r1, irand v1)

    in
      if !istracing then
        (print_string "\n<=== \n";
         print_reseval reseval
        );
      reseval
 in
    (echo_result (eval (ep, []))) ;;

(* let message_initial =
print_newline ();
print_string "evalprog p      : execution du programme p (syntaxe abstraite) ;";
print_newline ();
print_string "trace_eval ()   : trace d'execution elementaire ;";
print_newline ();
print_string "untrace_eval () : pas de trace (par defaut).";
print_newline ();; *)