(* Evaluation d'une expression *)
#open "expr";;
#open "divers";;
#open "printf";;

type Valeur =
| ValEntier of int
| ValUnit
| ValBooleen of bool
| ValCar of char
| ValChaine of string
| ValRef of mutable Valeur
| ValPaire of Valeur*Valeur
| ValListe of Valeur list
| ValFerm  of ((ID*Valeur) list * ID * Expression)
| ValIndir of Valeur ref
| ValPrim  of (Valeur->Valeur);;

exception TypeMismatch of string;;
exception EmptyList of string;;

let rec afficher_valeur = function
| ValIndir v -> pr "=>"; afficher_valeur !v
| ValUnit -> print_string "()"
| ValEntier n -> print_int n
| ValBooleen b -> if b then print_string "true" else print_string "false"
| ValCar c -> printf "'%c'" c
| ValChaine s -> printf "\"%s\"" (string_for_read s)
| ValPaire (x,y) -> print_string "("; afficher_valeur x; print_string ","; afficher_valeur y; print_string ")"
| ValListe vl -> pr "["; do_list_sep afficher_valeur (fun ()->pr ";") vl; pr "]"
| ValRef r -> pr "ref "; afficher_valeur r
| ValFerm  f  -> print_string "<fun>"
| ValPrim  _ -> print_string "<prim>";;

let rec print_env env = pr "<"; do_list (fun (i,v) -> pr i; pr " ") env; pr ">\n"; flush std_out;;

let rec indirect = function ValIndir v -> indirect !v | v -> v;;

let env_eval = make_table ();;

let init_env_eval () =
  env_eval.clear ();
  env_eval.add "hd" (ValPrim (function ValListe x -> hd x | _ -> failwith "hd"));
  env_eval.add "tl" (ValPrim (function ValListe x -> ValListe (tl x) | _ -> failwith "tl"));
  env_eval.add "fst" (ValPrim (function ValPaire x -> fst x | _ -> failwith "fst"));
  env_eval.add "snd" (ValPrim (function ValPaire x -> snd x | _ -> failwith "snd"));
  env_eval.add "ref" (ValPrim (function x -> ValRef x));
  env_eval.add "print_int" (ValPrim (function ValEntier x -> print_int x; pr " "; ValUnit | _ -> failwith "print_int"));
  env_eval.add "print_string" (ValPrim (function ValChaine s -> print_string s;ValUnit | _ -> failwith "print_string"));;

let rec evaluer expr = match expr.e_desc with
| ExprCst (CstEntier n) -> ValEntier n
| ExprCst (CstBooleen n) -> ValBooleen n
| ExprCst (CstCar c) -> ValCar c
| ExprCst (CstChaine s) -> ValChaine s
| ExprCst CstListeVide  -> ValListe []
| ExprCst CstUnit  -> ValUnit
| ExprIdent i          -> indirect (env_eval.find i)
| ExprOp (OpITH, {e_desc=ExprPaire (cond, {e_desc=ExprPaire(sioui,sinon)})}) ->
       let evalcond=evaluer cond in
       (
       match evalcond with
         |ValBooleen b -> if b then evaluer sioui else evaluer sinon
         |_ -> raise (TypeMismatch "If Then Else")
       )
| ExprOp (op,arg)       -> (
  let valarg=evaluer arg in match op with
  | OpAdd -> evalAdd valarg
  | OpMult -> evalMult valarg
  | OpMoins -> evalMoins valarg
  | OpDiv -> evalDiv valarg
  | OpEt -> evalEt valarg
  | OpOu -> evalOu valarg
  | OpNot -> evalNot valarg
  | OpInf -> evalInf valarg
  | OpInfEgal -> evalInfEgal valarg
  | OpEgal -> evalEgal valarg
  | OpFirst -> evalFirst valarg
  | OpSecond -> evalSecond valarg
  | OpHead  -> evalHead valarg
  | OpTail  -> evalTail valarg
  | OpCons -> evalCons valarg
  | OpSeq  -> evalSecond valarg
  | OpRef  -> ValRef valarg
  | OpIndirect -> evalIndirect valarg
  | OpAffect -> evalAffect valarg
  | _ -> failwith "evaluer"
  )
| ExprPaire (a,b)       -> let a=evaluer a in let b=evaluer b in ValPaire (a,b)
| ExprFunc  (x,e)  -> ValFerm (map (fun id->(id,env_eval.find id)) expr.e_vars,x,e)
(*    if f="" then ValFerm (e, x, expr)
    else
    let ind = ref ValUnit in
    let ferm=ValFerm ( add_env (f,ValIndir ind) e , x,expr) in
      ind:=ferm;
      ferm *)
| ExprAppl  (f,arg)     -> (let evalf=evaluer f in match evalf with
    | ValFerm (local,nomarg,expr) -> let evalarg=evaluer arg in
        env_eval.add nomarg evalarg;
        do_list (fun (id,v) -> env_eval.add id v) local;
        let res=evaluer expr in
        do_list (fun (id,v) -> env_eval.remove id) local;
        env_eval.remove nomarg;
        res
    | ValPrim p -> let evalarg=evaluer arg in p evalarg
    | _ -> raise (TypeMismatch "Appl")
    )
| ExprLet   (recurs, decl, corps) ->
      	evaluer_letdecl (recurs,decl);
        let res=evaluer corps in
        do_list (fun (x,def) -> env_eval.remove x) decl;
        res
and evalAdd = function
| (ValPaire (ValEntier x, ValEntier y)) -> ValEntier (x+y)
| _ -> raise (TypeMismatch "+")

and evalMult = function
| (ValPaire (ValEntier x, ValEntier y)) -> ValEntier (x*y)
| _ -> raise (TypeMismatch "*")

and evalMoins = function
| (ValPaire (ValEntier x, ValEntier y)) -> ValEntier (x-y)
| _ -> raise (TypeMismatch "-")

and evalDiv = function
| (ValPaire (ValEntier x, ValEntier y)) -> ValEntier (x/y)
| _ -> raise (TypeMismatch "/")

and evalEt = function
| (ValPaire (ValBooleen x, ValBooleen y)) -> ValBooleen (x & y)
| _ -> raise (TypeMismatch "and")

and evalOu = function
| (ValPaire (ValBooleen x, ValBooleen y)) -> ValBooleen (x & y)
| _ -> raise (TypeMismatch "or")


and evalNot = function
| (ValBooleen x) -> ValBooleen (not x)
| _ -> raise (TypeMismatch "not")


and evalInf = function
| (ValPaire (ValEntier x, ValEntier y)) -> ValBooleen (x<y)
| _ -> raise (TypeMismatch "<")

and evalInfEgal = function
| (ValPaire (ValEntier x, ValEntier y)) -> ValBooleen (x<=y)
| _ -> raise (TypeMismatch "<=")

and evalEgal = function
| (ValPaire (ValFerm x, ValFerm y)) -> ValBooleen (false)
| (ValPaire (x, y)) -> ValBooleen (x=y)
| _ -> raise (TypeMismatch "=")

and evalFirst = function
| (ValPaire (x, y)) -> x
| _ -> raise (TypeMismatch "fst")

and evalSecond = function
| (ValPaire (x, y)) -> y
| _ -> raise (TypeMismatch "snd")

and evalHead = function
| ValListe (h::t) -> h
| ValListe _  -> raise (EmptyList "hd")
| _ -> raise (TypeMismatch "hd")

and evalTail = function
| ValListe (h::t) -> ValListe t
| ValListe _  -> raise (EmptyList "tl")
| _ -> raise (TypeMismatch "tl")

and evalCons = function
| (ValPaire (tete, ValListe queue)) -> ValListe (tete::queue)
| v -> afficher_valeur v; raise (TypeMismatch "::")

and evalIndirect = function
| (ValRef a) -> a
| _ ->  raise (TypeMismatch "!")

and evalAffect = function
| ValPaire (ValRef a, b) -> a<-b; ValUnit
| _ ->  raise (TypeMismatch ":=")

and evaluer_letdecl = function
| (false, decl) ->
        let evaldecl=map (fun (x,def) -> evaluer def) decl in
        do_list2 (fun (x,def) v -> env_eval.add x v) decl evaldecl
| (true, decl) ->
        let ind=map (fun (x,def) -> ref ValUnit) decl in
        do_list2 (fun (x,def) v -> env_eval.add x (ValIndir v)) decl ind;
        do_list2 (fun (x,def) i -> i:=evaluer def) decl ind;;