#nowarn "62" // --mlcompatibility
#light "off"
open System.Collections.Generic

type program = statement list
and statement = {
  name : string;
  exp  : exp;
  cond : exp;
  io   : io }
and exp =
| Empty
| 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 io =
| Input
| Output
| Temp
and id = string
and binop =
| Plus
| Minus
| Times
| Div
and relbinop =
| Eq
| Less
| Great
| Leq
| Geq
| Diff
| And
| Or

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

module List = begin
  let assoc x = List.find (fst >> (=) x) >> snd

  let mem x = List.exists ((=) x)

  let union xs ys =
    List.foldBack (fun y zs -> if mem y xs then zs else y :: zs) ys xs

  let diff xs ys =
    List.foldBack (fun x zs -> if mem x ys then zs else x :: zs) xs []

  let equal xs ys = (diff xs ys) = [] && (diff ys xs) = []
end

[<AutoOpen>]
module Utils = begin
  let private binOpStr = [ Plus, "+"; Times, "*"; Minus, "-"; Div, "/" ]
  let private relBinOpStr = [ Eq, "="; Less, "<"; Great, ">"; Leq, "<="; Geq, ">="; Diff, "!="; And, "&&"; Or, "||" ]

  let binOps = [ Plus, (+); Times, (*); Minus, (-); Div, (/) ]
  let relBinOps = [ Eq, (=); Less, (<); Great, (>); Leq, (<=); Geq, (>=); Diff, (<>) ]

  let rec pgToStr pg =
    pg |> List.fold (fun acc st -> sprintf "%s%s\n" acc (stToStr st)) ""
  and stToStr st =
    sprintf "(%s; %s; %s; %s)" st.name (expToStr st.exp) (expToStr st.cond) (ioToStr st.io)
  and private expToStr = function
  | Empty -> ""
  | Int i -> string i
  | Bool b -> string b
  | Var v -> v
  | Not c -> sprintf "!(%s)" (expToStr c)
  | Par e -> sprintf "(%s)" (expToStr e)
  | BinOp (op, e1, e2) -> sprintf "%s %s %s" (expToStr e1) (List.assoc op binOpStr) (expToStr e2)
  | RelBinOp (op, e1, e2) -> sprintf "%s %s %s" (expToStr e1) (List.assoc op relBinOpStr) (expToStr e2)
  and private ioToStr = function
  | Input -> "Input"
  | Output -> "Output"
  | Temp -> ""
end

[<AutoOpen>]
module TP = begin
  let rec private useExp = function
  | Var v -> [ v ]
  | Par e -> useExp e
  | BinOp (_, e1, e2)
  | RelBinOp (_, e1, e2) -> List.union (useExp e1) (useExp e2)
  | _ -> []

  let private useStat st = List.union (useExp st.exp) (useExp st.cond)

  let private defStat st = st.name

  let private fixPoint f eq x0 =
    let rec fixFunc x =
      let y = f x in
      if eq x y then y else fixFunc y
    in
    fixFunc x0

  let private statByIO io = List.filter (fun st -> st.io = io)

  let inStat = statByIO Input

  let outStat = statByIO Output

  let usePg pg = List.fold (fun ids st -> List.union ids (useStat st)) [] pg

  let defPg pg = List.map defStat pg

  let private getSomeStat pg id = List.tryFind (defStat >> (=) id) pg

  let getStat pg id =
    match getSomeStat pg id with Some st -> st | _ -> raise (KeyNotFoundException ())

  let useDirectIndirect pg st =
    let f ids = List.union ids (usePg (List.choose (getSomeStat pg) ids)) in
    fixPoint f List.equal (useStat st)

  let cyclicStat pg st = List.mem (defStat st) (useDirectIndirect pg st)

  let cyclicPg pg = pg |> List.exists (cyclicStat pg)

  let incompleteStat pg =
    let def = defPg pg in
    let udi = useDirectIndirect pg in
    List.fold (fun acc st -> if List.diff (udi st) def = [] then acc else st :: acc) [] pg

  let superfluousStat pg =
    let output = outStat pg in
    let used = List.fold (fun acc st -> List.union acc (useDirectIndirect pg st)) [] output in
    let allButOut = List.diff (defPg pg) (defPg output) in
    List.diff allButOut used
    |> List.map (getStat pg)

  let slice pg id =
    let st = getStat pg id in
    (useDirectIndirect pg st |> List.map (getStat pg)) @ [ st ]

  let outputSlices pg =
    outStat pg
    |> List.map (defStat >> fun id -> id, slice pg id)

  let private sortPg pg =
    let lower st1 st2 = if List.mem (defStat st1) (useDirectIndirect pg st2) then -1 else 1 in
    List.sortWith lower pg

  let evalPg env pg =
    let rec evalStat env = function
    | { io = Input } -> 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 exp =
      try
        match exp 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 (And, e1, e2) ->
          (match evalExp env e1, evalExp env e2 with
          | B b1, B b2 -> B (b1 && b2)
          | _ -> Null)
        | RelBinOp (Or, e1, e2) ->
          (match evalExp env e1, evalExp env e2 with
          | B b1, B b2 -> B (b1 || b2)
          | _ -> Null)
        | BinOp (op, e1, e2) ->
          (match evalExp env e1, evalExp env e2 with
          | I i1, I i2 -> I (List.assoc op binOps i1 i2)
          | _ -> Null)
        | RelBinOp (op, e1, e2) ->
          (match evalExp env e1, evalExp env e2 with
          | I i1, I i2 -> B (List.assoc op relBinOps i1 i2)
          | _ -> Null)
        | Var v -> List.assoc v env
        | Empty -> failwith "theorically must'nt happen"
      with
      | :? KeyNotFoundException -> Null
    in
    List.fold evalStat env (sortPg pg)
end

[<AutoOpen>]
module Tests = begin
  let private st01 = { name = "e"; exp = Empty; cond = Bool true; io = Input }
  let private st02 = { name = "f"; exp = Empty; cond = Bool true; io = Input }
  let private st03 = { name = "g"; exp = Empty; cond = Bool true; io = Input }
  let private st04 = { name = "h"; exp = BinOp (Plus, Var "e", Int 1); cond = Bool true; io = Temp }
  let private st05 = { name = "d"; exp = Int 0; cond = Bool true; io = Output }
  let private st06 = { name = "j"; exp = RelBinOp (Less, Var "i", Int 11); cond = RelBinOp (Great, Var "e", Int 1); io = Output }
  let private st07 = { name = "i"; exp = BinOp (Times, Var "e", Var "f"); cond = Bool true; io = Temp }
  let private st08 = { name = "b"; exp = Var "i"; cond = RelBinOp (Great, Var "i", Int 1); io = Output }
  let private st09 = { name = "c"; exp = BinOp (Minus, Int 2, Var "b"); cond = RelBinOp (Great, Var "b", Int 2); io = Output }
  let private st10 = { name = "a"; exp = Var "b"; cond = RelBinOp (Leq, Var "c", Int 0); io = Output }

  let pg01 : program = [ st06; st09; st03; st05; st10; st01; st07; st04; st02; st08 ]

  let private st11 = { name = "k"; exp = BinOp (Times, Int 2, Var "l"); cond = Bool true; io = Output }
  let private st12 = { name = "l"; exp = BinOp (Times, Int 2, Var "m"); cond = Bool true; io = Output }
  let private st13 = { name = "m"; exp = BinOp (Times, Int 2, Var "k"); cond = Bool true; io = Output }

  let pg02 : program = [ st11; st12; st13 ]

  let private st14 = { name = "o"; exp = Var "z"; cond = Bool true; io = Temp }
  let private st15 = { name = "p"; exp = Var "o"; cond = Bool true; io = Output }

  let pg03 : program = [ st14; st15 ]

  let samples = [ pg01; pg02; pg03 ]

  let env1 = [ "e", I 5; "f", I 2; "g", I 0 ]
  let env2 = [ "e", I 6; "f", I 2; "g", I 0 ]
  let env3 = [ "e", I 1; "f", I 1; "g", I 0 ]
  let env4 = [ "e", I 2; "f", I 1; "g", I 0 ]
  let env5 = [ "e", I 6 ]

  let ``Display Sample`` () =
    printfn "\nDisplay Sample:";
    printfn "-----------------";
    samples |> List.iter (pgToStr >> printfn "%s")

  let ``inStat Sample`` () =
    printfn "\ninStat Sample:";
    printfn "----------------";
    samples |> List.iter (inStat >> pgToStr >> printfn "%s")

  let ``outStat Sample`` () =
    printfn "\noutStat Sample:";
    printfn "-----------------";
    samples |> List.iter (outStat >> pgToStr >> printfn "%s")

  let ``usePg Sample`` () =
    printfn "\nusePg Sample:";
    printfn "---------------";
    samples |> List.iter (usePg >> printfn "%A")

  let ``defPg Sample`` () =
    printfn "\ndefPg Sample:";
    printfn "---------------";
    samples |> List.iter (defPg >> printfn "%A")

  let ``getStat Sample`` () =
    printfn "\ngetStat Sample:";
    printfn "-----------------";
    (getStat pg01 "a") |> stToStr |> printfn "%s";
    (getStat pg02 "l") |> stToStr |> printfn "%s";
    try (getStat pg01 "y") |> stToStr |> printfn "%s" with :? KeyNotFoundException -> printfn "erreur"

  let ``useDirectIndirect Sample`` () =
    printfn "\nuseDirectIndirect Sample:";
    printfn "---------------------------";
    samples |> List.map (fun pg ->
      pg |> List.map (fun st -> st.name, useDirectIndirect pg st))
    |> List.iter (printfn "%A")

  let ``cyclicStat Sample`` () =
    printfn "\ncyclicStat Sample:";
    printfn "--------------------";
    samples |> List.map (fun pg ->
      pg |> List.map (cyclicStat pg))
    |> List.iter (printfn "%A")

  let ``cyclicPg Sample`` () =
    printfn "\ncyclicPg Sample:";
    printfn "------------------";
    samples |> List.iter (cyclicPg >> printfn "%A")

  let ``incompleteStat Sample`` () =
    printfn "\nincompleteStat Sample:";
    printfn "------------------------";
    samples |> List.iter (incompleteStat >> printfn "%A")

  let ``superfluousStat Sample`` () =
    printfn "\nsuperfluousStat Sample:";
    printfn "-------------------------";
    samples |> List.iter (superfluousStat >> printfn "%A")

  let ``slice Sample`` () =
    printfn "\nslice Sample:";
    printfn "---------------";
    [ "a"; "i"; "b" ] |> List.iter (slice pg01 >> pgToStr >> printfn "%s")

  let ``outputSlices Sample`` () =
    printfn "\noutputSlices Sample:";
    printfn "----------------------";
    pg01 |> outputSlices |> List.iter (fun (id, pg) -> printfn "%s:\n%s" id (pgToStr pg))

  let ``evalPg Sample`` () =
    printfn "\nevalPg Sample:";
    printfn "----------------";
    evalPg env1 pg01 |> printfn "%A";
    evalPg env2 pg01 |> printfn "%A";
    evalPg env3 pg01 |> printfn "%A";
    evalPg env4 pg01 |> printfn "%A";
    evalPg env5 pg01 |> printfn "%A";
    evalPg [] pg02 |> printfn "%A";
    evalPg [] pg03 |> printfn "%A"
end

module Sample = begin
  ``Display Sample`` ();
  ``inStat Sample`` ();
  ``outStat Sample`` ();
  ``usePg Sample`` ();
  ``defPg Sample`` ();
  ``getStat Sample`` ();
  ``useDirectIndirect Sample`` ();
  ``cyclicStat Sample`` ();
  ``cyclicPg Sample`` ();
  ``incompleteStat Sample`` ();
  ``superfluousStat Sample`` ();
  ``slice Sample`` ();
  ``outputSlices Sample`` ();
  ``evalPg Sample`` ()
end