(* Expressions *)
#open "printf";;
#open "types";;
#open "divers";;
#open "global";;

type Constant =
  CstEntier of int
| CstBooleen of bool
| CstCar of char
| CstChaine of string
| CstUnit
| CstListeVide;;
type ID == string;;
type Operateur = OpAdd | OpMult | OpMoins | OpDiv |OpEt | OpOu| OpNeg | OpNot | OpInf | OpEgal | OpInfEgal | OpFirst | OpSecond | OpHead | OpTail | OpITH | OpCons |
  OpRef | OpAffect | OpIndirect | OpSeq;;

(*
type Pat =
  PatCst of Constant
| PatCouple of Pat*Pat
| PatId of ID
| PatConstr of ID*Pat;;
*)

type Pat = 
| PatConstr of Construct*ID
| PatId of ID;;

type Expression = { e_desc:ExpressionDesc; mutable e_type:TypeExpr; mutable e_vars:ID list }
and  ExpressionDesc =
  ExprCst of Constant
| ExprIdent of ID
| ExprOp of Operateur*Expression
| ExprFunc of ID*Expression
| ExprAppl of Expression*Expression
| ExprLet of bool*((ID*Expression) list)*Expression
| ExprPaire of Expression*Expression
| ExprMatch of (Expression* ((Pat*Expression) list))
;;

let print_op = function
  | OpAdd   -> "+"
  | OpMult  -> "*"
  | OpMoins -> "-"
  | OpDiv   -> "/"
  | OpEt    -> "and"
  | OpOu    -> "or"
  | OpNot   -> "not"
  | OpNeg   -> "neg"
  | OpInf   -> "?<"
  | OpInfEgal->"?<="
  | OpEgal  -> "?="
  | OpFirst -> "fst"
  | OpSecond-> "snd"
  | OpHead  -> "hd"
  | OpTail  -> "tl"
  | OpITH   -> "if-then-else"
  | OpCons  -> "::"
  | OpRef   -> "ref"
  | OpAffect-> ":="
  | OpIndirect->"!"
  | OpSeq   -> ";";;

let rec affiche_expr expr = print_string "<"; do_list print_string expr.e_vars; print_string ">"; match expr.e_desc with
  | ExprCst (CstEntier n) -> print_int n
  | ExprCst (CstCar n )   -> printf "'%c'" n
  | ExprCst (CstChaine s) -> printf "\"%s\"" (string_for_read s)
  | ExprCst (CstBooleen b) -> if b then print_string "true" else print_string "false"
  | ExprCst (CstListeVide) -> print_string "[]"
  | ExprCst (CstUnit) -> print_string "()"
  | ExprIdent s -> print_string s
  | ExprOp (o,a)  -> print_string (print_op o); pr "("; affiche_expr a; pr ")"
  | ExprFunc (x,a) -> printf "fun %s -> " x; affiche_expr a
  | ExprAppl (a1,a2) -> affiche_expr a1; print_string "("; affiche_expr a2; print_string ")"
  | ExprLet (recurs,decl,corps)->
        pr "let "; if recurs then pr "rec ";
        do_list_sep
         (fun (x,def) -> pr x; pr "="; affiche_expr def)
         (fun () -> pr "\n    and ")
         decl;
        pr "\nin\n ";
        affiche_expr corps
  | ExprPaire (a1,a2) ->print_string "("; affiche_expr a1; print_string ","; affiche_expr a2; print_string ")"
  | ExprMatch _ -> print_string "match ..."; 
;;


let rec filter p = function
  [] -> []
| t::q -> if (p t) then t::(filter p q) else filter p q;;

let rec calcule_vars locvars expr = 
let v =
match expr.e_desc with   (* locvars  : identificateurs définis dans un niveau supérieur non global *)
 ExprCst _ -> []
|ExprIdent x    -> if mem x locvars then [x] else [] (* if global_ids.mem x then [] else [x] *)
|ExprOp (_,e)   -> calcule_vars locvars e
|ExprFunc (x,e) -> sub_set x (calcule_vars (x::locvars) e)
|ExprAppl (a,b) -> fus_set (calcule_vars locvars b) (calcule_vars locvars a)
|ExprLet (recurs,decl,ex) ->
      let ids v = it_list (fun i (x,e) -> sub_set x i) v decl
      and nlocvars = it_list (fun v (x,e) -> x::v) locvars decl in
      let vars_defs= 
      	if recurs then 
      	 it_list (fun v (x,e) -> fus_set v (calcule_vars nlocvars e)) [] decl
        else
      	 it_list (fun v (x,e) -> fus_set v (calcule_vars (x::locvars) e)) [] decl
      and vars_ex  = calcule_vars nlocvars ex in
      if recurs
      then ids (fus_set vars_ex vars_defs)
      else fus_set (ids vars_ex) vars_defs
|ExprPaire (a,b)-> fus_set (calcule_vars locvars b) (calcule_vars locvars a)
|ExprMatch (e,act) ->
      it_list (fun accu (p,e) -> fus_set accu (calcule_vars_action locvars p e))
        (calcule_vars locvars e) act

in expr.e_vars <- v; v

and
  calcule_vars_pat = function
(*
 PatCst _ -> []
|PatCouple (a,b) -> fus_set_disj (calcule_vars_pat a) (calcule_vars_pat b)
|PatId x -> (*if global_ids.mem x then [] else *)[x]
|PatConstr (_,p) -> calcule_vars_pat p
*)
|PatId x -> [x]
|PatConstr (_,x) -> [x]
and
 calcule_vars_action locvars pat ex =
       let vpat= calcule_vars_pat pat in
       let vex = calcule_vars (vpat@locvars) ex in
(*       let r=*)
       it_list (fun i x -> sub_set x i) vex vpat
(*       in pr "action:"; do_list_sep print_string (fun () -> pr ",") r; r*)
;;




let dummytype = Type_base Base_Unit;;
let exprCst    x   = { e_desc=ExprCst x; e_type=dummytype; e_vars = [] };;
let exprIdent  x   = { e_desc=ExprIdent x; e_type=dummytype; e_vars = [] };;
let exprOp     x   = { e_desc=ExprOp x; e_type=dummytype; e_vars = [] };;
let exprFunc   x   = { e_desc=ExprFunc x; e_type=dummytype; e_vars = [] };;
let exprAppl   x   = { e_desc=ExprAppl x; e_type=dummytype; e_vars = [] };;
let exprLet    x   = { e_desc=ExprLet x; e_type=dummytype; e_vars = [] };;
let exprPaire  x   = { e_desc=ExprPaire x; e_type=dummytype; e_vars = [] };;
let exprMatch  x   = { e_desc=ExprMatch x; e_type=dummytype; e_vars = [] };;


let ifthenelse cond a1 a2 = exprOp (OpITH, exprPaire(cond, exprPaire(a1,a2)));;
let egal a1 a2 = exprOp(OpEgal, exprPaire(a1,a2));;

let fonction_vars (x,e) = exprFunc (x,e);;

let fonction param corps =
 let rec aux = function [] -> corps | t::q -> fonction_vars (t, aux q)
 in aux param;;

let extractfunc expr = match expr.e_desc with
 ExprFunc y -> y
|_ -> failwith "extractfunc";;