(***************************************************************************)
(* TP Hiver 2012 - IFT-3000                                                *)
(*                                                                         *)
(* Transformation automatique de programmes.                               *)
(***************************************************************************)
(* NOM: TROTTIER-HEBERT             PRÉNOM: JOEL                           *)
(* MATRICULE: 910 126 534           PROGRAMME: IFT                         *)
(***************************************************************************)
(* Les fonctions à compléter sont indiquées par *****                      *)
(***************************************************************************)

#use "tp1.mli";;

(***************************************************************************)
(* Implantation                                                            *)
(***************************************************************************)

module Tp1 : TP1 = struct

  open List

  (* *****************************************************************)
  (* Déclarations de types                                           *)
  (* *****************************************************************)

  type id = string

  type exp = EmptyExp | Int of int | Bool of bool | Var of id
           | Not of exp | Par of exp | BinOp of binop * exp * exp
       | RelBinOp of relbinop * exp * exp

  and binop = Plus | Minus | Times | Div
  and relbinop = Eq | Less | Great | Leq | Geq | Diff | And | Or

  type io = IS | OS | Temp

  type statement = {name : id; exp : exp; cond : exp; io : io}
  type program = statement list

  type value = Null | I of int | B of bool
  type env = (id * value) list


  (* *****************************************************************)
  (* Listes utiles                                                   *)
  (* *****************************************************************)

  let binOpStrList1 = [(Plus, "+");(Times, "*");(Minus, "-");(Div, "/")]

  let binOpStrList2 = [(Eq, "="); (Less, "<"); (Great, ">");
               (Leq, "<="); (Geq, ">="); (Diff, "<>");
               (And, "and"); (Or, "or")]

  let binOpList = [(Plus, ( + )); (Times, ( * )); (Minus, ( - ));
           (Div, ( / ))]

  let relBinOpList1 = [(Eq, ( = )); (Less, ( < )); (Great, ( > ));
               (Leq, ( <= ) ); (Geq, ( >= ) ); (Diff, ( <> ))]

  let relBinOpList2 = [(And, ( && )); (Or, ( || ))]

  (* *****************************************************************)
  (* FONCTION UTILES (on peut en ajouter au besoin ...)              *)
  (* *****************************************************************)

  (* Autres fonctions utiles                                         *)
  let isMember e l = exists (fun x -> x = e) l

  let union l1 l2 =
    fold_right (fun x l -> if (isMember x l1) then l else x::l) l2 l1

  let diff l1 l2 =
    fold_right (fun x l -> if (isMember x l2) then l else x::l) l1 []

  let join l1 l2 =
    fold_right (fun x l -> if (isMember x l2) then x::l else l) l1 []

  let equal l1 l2 = (diff l1 l2) = [] && (diff l2 l1) = []

  let inSet l1 l2 = for_all (fun x -> isMember x l2) l1

  let rec updateEnv env ((x,_) as p) = p::(remove_assoc x env)

  let fixPoint f eq x0 =
    let rec fixFunc x =
      let x' = f x in
      if (eq x x') then x' else fixFunc x'
    in
    fixFunc x0

  let (|>) f x = x f

  let unionMany l =
    let rec aux l' = match l' with
    | [] -> []
    | x::r -> union x (aux r)
    in
    aux l

  let choose l =
    let rec f m = begin match m with
    | [] -> []
    | x::r ->
    begin match x with
    | Some x -> x :: (f r)
    | _ -> f r
    end
    end
    in
  f l

  (* *****************************************************************)
  (* FONCTION DU TP1-H2012 (certaines (*****) à compléter)           *)
  (* *****************************************************************)

   let rec pgmToStr p =
     fold_left (fun result s -> result ^ (statToStr s) ^ "\n") "" p

   and statToStr {name=n; exp=e; cond=c; io=io} =
     let ioToStr io = match io with
     | IS -> "IS"
     | OS -> "OS"
     | Temp -> ""
     in
     "(" ^ n ^ "; " ^ (expToStr e) ^ "; " ^ (expToStr c) ^ "; " ^
     (ioToStr io) ^ ")"

   and expToStr e = match e with
   | EmptyExp -> ""
   | Int i -> string_of_int i
   | Bool b -> string_of_bool b
   | Var x -> x
   | Not c -> "not" ^ (expToStr c)
   | Par e -> "(" ^ (expToStr e) ^ ")"
   | BinOp(op1,e1,e2) -> (expToStr e1) ^" "^ (assoc op1 binOpStrList1) ^" "^ (expToStr e2)
   | RelBinOp(op1,e1,e2) -> (expToStr e1) ^" "^ (assoc op1 binOpStrList2) ^" "^ (expToStr e2)

  let rec useExp e = match e with
  | Var x -> [x]
  | Par e -> useExp e
  | BinOp(_,e1,e2) -> union (useExp e1) (useExp e2)
  | RelBinOp(_,e1,e2) -> union (useExp e1) (useExp e2)
  | _ -> []

  let useStat {exp = e; cond = c} = union (useExp e) (useExp c)

  let defStat {name = n} = n

(*****)
  let inStat p = filter (fun x -> x.io = IS) p

(*****)
  let outStat p = filter (fun x -> x.io = OS) p

(*****)
  let usePgm p =
    let rec aux p' =
      match p' with
      | [] -> []
      | x::r -> union (useStat x) (aux r)
    in aux p

(*****)
  let defPgm p = map defStat p

(*****)
  let getStat p x = find (fun ({name = n} : statement) -> n = x) p

  let getStat2 p x =
    try
     Some (getStat p x)
    with
    | not_found -> None


(*****)
let useDirectIndirect p s =
  let x0 = useStat s in
  let f ids = union ids (usePgm (choose (map (getStat2 p) ids))) in
  fixPoint f equal x0

(*****)
  let cyclicStat p s = isMember (defStat s) (useDirectIndirect p s)

(*****)
  let cyclicPgm p = exists (cyclicStat p) p

(*****)
let incompleteStat pgm =
  let estDeclare var = exists (fun stat -> stat.name = var) pgm in
  let checkVars vars = isMember false (map estDeclare vars) and
      resultat = [] and
      couples = map (fun stat -> stat, (useDirectIndirect pgm) stat) pgm
  in
  let rec aux liste = match liste with
  | [] -> []
  | x::r -> union (
      if checkVars (snd x) = true
      then union [(fst x).name] resultat
  else union [] resultat) (aux r)
 in aux couples |> map (getStat pgm)

(*****)

let superfluousStat =
  let aux = map defStat in
  fun pgm ->
    let used = map (useDirectIndirect pgm) (outStat pgm) |> unionMany in
    let all, out = aux pgm , aux (outStat pgm) in
    (diff (diff all out) used) |> map (getStat pgm)


  let sortp p =
    let lower s1 s2 = if mem (defStat s1) (useDirectIndirect p s2) then -1 else 1
    in
    sort lower p

(*****)
  let slice p n =
    union [(getStat p n)] (useDirectIndirect p (getStat p n) |> map (getStat p))

(*****)
  let outputSlices p =
    outStat p
  |> map defStat
  |> map (fun id -> id, slice p id)

(*****)
  let evalPgm env p =
    let rec evalStat env s =
      match s with
      | {io = IS} -> env
      | {name = n; exp = e; cond = c; io = _} ->
    match evalExp env c with
    | B true -> (n, evalExp env e) :: env
    | _ -> (n, Null) :: env
    and evalExp env e =
      try
    match e with
    | Int i -> I i
    | Bool b -> B b
    | Par e -> evalExp env e
    | Not c -> (match evalExp env c with
      | B b -> B (not b)
      | _ -> Null)
    | RelBinOp (op, e1, e2) ->
            (match op, evalExp env e1, evalExp env e2 with
            | (And | Or), B b1, B b2 -> B (assoc op relBinOpList2 b1 b2)
            | _, I i1, I i2 -> B (assoc op relBinOpList1 i1 i2)
            | _ -> Null)
    | BinOp (op, e1, e2) ->
        (match evalExp env e1, evalExp env e2 with
        |  I i1,  I i2 -> I (assoc op binOpList i1 i2)
        | _ -> Null)
    | Var v -> List.assoc v env
    | EmptyExp -> failwith "ne devrait pas arriver."
      with
      | _ -> Null
    in
    List.fold_left evalStat env (sortp p)

end;;