-- Frap/Types.lean

import Frap.SmallStep

namespace TM

inductive Tm : Type :=
  | tru : Tm
  | fls : Tm
  | ite : Tm → Tm → Tm → Tm
  | zro : Tm
  | scc : Tm → Tm
  | prd : Tm → Tm
  | iszero : Tm → Tm

open Tm

inductive BValue : Tm → Prop :=
  | bv_true : BValue tru
  | bv_false : BValue fls

inductive NValue : Tm → Prop :=
  | nv_0 : NValue zro
  | nv_succ t : NValue t → NValue (scc t)

open BValue

open NValue

abbrev value (t : Tm) := BValue t ∨ NValue t

inductive Step : Tm → Tm → Prop :=
  | st_ifTrue t₁ t₂ : Step (ite tru t₁ t₂) t₁
  | st_ifFalse t₁ t₂ : Step (ite fls t₁ t₂) t₂
  | st_if c c' t₁ t₂ :
      Step c c' → Step (ite c t₁ t₂) (ite c' t₁ t₂)
  | st_succ t₁ t₁' : Step t₁ t₁' → Step (scc t₁) (scc t₁')
  | st_pred0 : Step (prd zro) zro
  | st_predSucc v : NValue v → Step (prd (scc v)) v
  | st_pred t₁ t₁' : Step t₁ t₁' → Step (prd t₁) (prd t₁')
  | st_iszero0 : Step (iszero zro) tru
  | st_iszeroSucc v : NValue v → Step (iszero (scc v)) fls
  | st_iszero t₁ t₁' :
      Step t₁ t₁' → Step (iszero t₁) (iszero t₁')

open Step

inductive Ty : Type :=
  | bool : Ty
  | nat : Ty

open Ty

inductive HasType : Tm → Ty → Prop :=
  | t_true : HasType tru bool
  | t_false : HasType fls bool
  | t_if t₁ t₂ t₃ T :
      HasType t₁ bool → HasType t₂ T → HasType t₃ T
      → HasType (ite t₁ t₂ t₃) T
  | t_0 : HasType zro nat
  | t_succ t₁ : HasType t₁ nat → HasType (scc t₁) nat
  | t_pred t₁ : HasType t₁ nat → HasType (prd t₁) nat
  | t_iszero t₁ : HasType t₁ nat → HasType (iszero t₁) bool

open HasType

example  -- `⊢ if false then 0 else (succ 0) ∈ nat`
    : HasType (ite fls zro (scc zro)) nat := by
  apply t_if
  . apply t_false
  . apply t_0
  . apply t_succ
    apply t_0

/-
It's important to realize that the typing relation is a _conservative_ (or _static_) approximation: it does not consider what happens when the term is reduced.
In particular, it does not calculate the type of its normal form.
-/

example  -- `⊢ if false then zero else true ∉ bool`
    : ¬ HasType (ite fls zro tru) bool := by
  intro contra
  cases contra
  rename_i contra _
  cases contra

/-
exercise (1-star)
-/
example t : HasType (scc t) nat → HasType t nat := by
  intro ht
  cases ht
  assumption

-- Repository definitions used:
content: syntax term "==>" term : term

syntax term "~~>" term : term

syntax term "~~>*" term : term

syntax:30 term " =[ " imp " ]=> " term : term

syntax term "!->" term "; " term : term

syntax:36 term "<<->>" term : term

content: macro_rules
  | `(term|$t:term ==> $n:term) => `(Eval $t $n)

content: macro_rules
  | `(term|$t₁:term ~~> $t₂:term) => `(Step $t₁ $t₂)

example :
    p
      (p (c 1) (c 3))
      (p (c 2) (c 4))
    ~~>
    p
      (c 4)
      (p (c 2) (c 4)) := by admit /- proof elided -/

content: macro_rules
  | `(term|$t₁:term ~~>* $t₂:term) => `(Multi Step $t₁ $t₂)

content: macro_rules
  | `(term|$p <<->> $q) => `($p ->> $q ∧ $q ->> $p)

content: macro_rules
  | `(term|{*$p*} $c {*$q*}) => `(valid_hoare_triple $p $c $q)

content: macro_rules
  | `(term|$st =[ $c ]=> $st') => `(CEval <{$c}> $st $st')

content: macro_rules
  | `(term|$x:term !-> $a:term ; $st) => `(update $st $x $a)

example : empty =[
      x := 2;
      if (x <= 1) then y := 3 else z := 4 end
    ]=> (z !-> 4; x !-> 2; empty) := by admit /- proof elided -/

content: inductive Step : Tm → Tm → Prop :=
  | st_ifTrue t₁ t₂ : Step (ite tru t₁ t₂) t₁
  | st_ifFalse t₁ t₂ : Step (ite fls t₁ t₂) t₂
  | st_if c c' t₁ t₂ :
      Step c c' → Step (ite c t₁ t₂) (ite c' t₁ t₂)
  | st_succ t₁ t₁' : Step t₁ t₁' → Step (scc t₁) (scc t₁')
  | st_pred0 : Step (prd zro) zro
  | st_predSucc v : NValue v → Step (prd (scc v)) v
  | st_pred t₁ t₁' : Step t₁ t₁' → Step (prd t₁) (prd t₁')
  | st_iszero0 : Step (iszero zro) tru
  | st_iszeroSucc v : NValue v → Step (iszero (scc v)) fls
  | st_iszero t₁ t₁' :
      Step t₁ t₁' → Step (iszero t₁) (iszero t₁')

content: inductive Tm : Type :=
  | tru : Tm
  | fls : Tm
  | ite : Tm → Tm → Tm → Tm
  | zro : Tm
  | scc : Tm → Tm
  | prd : Tm → Tm
  | iszero : Tm → Tm

content: inductive NValue : Tm → Prop :=
  | nv_0 : NValue zro
  | nv_succ t : NValue t → NValue (scc t)

content: inductive Ty : Type :=
  | bool : Ty
  | nat : Ty

content: inductive HasType : Tm → Ty → Prop :=
  | t_true : HasType tru bool
  | t_false : HasType fls bool
  | t_if t₁ t₂ t₃ T :
      HasType t₁ bool → HasType t₂ T → HasType t₃ T
      → HasType (ite t₁ t₂ t₃) T
  | t_0 : HasType zro nat
  | t_succ t₁ : HasType t₁ nat → HasType (scc t₁) nat
  | t_pred t₁ : HasType t₁ nat → HasType (prd t₁) nat
  | t_iszero t₁ : HasType t₁ nat → HasType (iszero t₁) bool

content: inductive Tm : Type :=
  | c : Nat → Tm       
  | p : Tm → Tm → Tm   

content: inductive BValue : Tm → Prop :=
  | bv_true : BValue tru
  | bv_false : BValue fls

-- Repository lemmas used:
content: theorem List.getElem_append_left{α : Type u_1} {l₁ l₂ : List α} {i : Nat} (hn : i < l₁.length) :\n(l₁ ++ l₂)[i] = l₁[i]

-- Local definitions used:
content: inductive Tm : Type :=
  | tru : Tm
  | fls : Tm
  | ite : Tm → Tm → Tm → Tm
  | zro : Tm
  | scc : Tm → Tm
  | prd : Tm → Tm
  | iszero : Tm → Tm

content: inductive BValue : Tm → Prop :=
  | bv_true : BValue tru
  | bv_false : BValue fls

content: inductive NValue : Tm → Prop :=
  | nv_0 : NValue zro
  | nv_succ t : NValue t → NValue (scc t)

content: abbrev value (t : Tm) := BValue t ∨ NValue t

content: inductive Step : Tm → Tm → Prop :=
  | st_ifTrue t₁ t₂ : Step (ite tru t₁ t₂) t₁
  | st_ifFalse t₁ t₂ : Step (ite fls t₁ t₂) t₂
  | st_if c c' t₁ t₂ :
      Step c c' → Step (ite c t₁ t₂) (ite c' t₁ t₂)
  | st_succ t₁ t₁' : Step t₁ t₁' → Step (scc t₁) (scc t₁')
  | st_pred0 : Step (prd zro) zro
  | st_predSucc v : NValue v → Step (prd (scc v)) v
  | st_pred t₁ t₁' : Step t₁ t₁' → Step (prd t₁) (prd t₁')
  | st_iszero0 : Step (iszero zro) tru
  | st_iszeroSucc v : NValue v → Step (iszero (scc v)) fls
  | st_iszero t₁ t₁' :
      Step t₁ t₁' → Step (iszero t₁) (iszero t₁')

content: inductive Ty : Type :=
  | bool : Ty
  | nat : Ty

content: inductive HasType : Tm → Ty → Prop :=
  | t_true : HasType tru bool
  | t_false : HasType fls bool
  | t_if t₁ t₂ t₃ T :
      HasType t₁ bool → HasType t₂ T → HasType t₃ T
      → HasType (ite t₁ t₂ t₃) T
  | t_0 : HasType zro nat
  | t_succ t₁ : HasType t₁ nat → HasType (scc t₁) nat
  | t_pred t₁ : HasType t₁ nat → HasType (prd t₁) nat
  | t_iszero t₁ : HasType t₁ nat → HasType (iszero t₁) bool

-- Local lemmas used:
content: theorem bool_canonical t : HasType t bool → value t → BValue t

content: theorem nat_canonical t : HasType t nat → value t → NValue t

-- Target theorem and proof:
theorem progress t T
    : HasType t T → value t ∨ ∃ t', Step t t'
:= by
  intro ht
  induction ht with
  | t_if t₁ t₂ t₃ T =>
    rename_i ih₁ ih₂ ih₃
    right; cases ih₁
    . -- t₁ is a value
      have h : BValue t₁ := by
        apply bool_canonical <;> assumption
      cases h
      . exists t₂; apply st_ifTrue
      . exists t₃; apply st_ifFalse
    . -- t₁ can take a step
      rename_i h
      obtain ⟨t₁', h₁⟩ := h
      exists ite t₁' t₂ t₃
      apply st_if; exact h₁
  | t_true =>
    left;unfold value; left; apply bv_true
  | t_false =>
    left; unfold value; left; apply bv_false
  | t_0 =>
    left; unfold value; right; apply nv_0
  | t_succ t =>
    rename_i ih
    cases ih
    . -- t is a value
      left
      have h : NValue t := by
        apply nat_canonical <;> assumption
      cases h
      . unfold value; right; apply nv_succ; apply nv_0
      . unfold value; right; apply nv_succ; apply nv_succ; assumption
    . -- t can take a step
      right
      rename_i ih
      obtain ⟨t', h⟩ := ih
      exists (scc t')
      apply st_succ; exact h
  | t_pred t =>
    rename_i ih
    right; cases ih
    . -- t is a value
      have h : NValue t := by
        apply nat_canonical <;> assumption
      cases h
      . exists zro; apply st_pred0
      . constructor; apply st_predSucc; assumption
    . -- t can take a step
      rename_i h
      obtain ⟨t', h⟩ := h
      exists (prd t')
      apply st_pred; exact h
  | t_iszero t =>
    rename_i ih
    right; cases ih
    . -- t is a value
      have h : NValue t := by
        apply nat_canonical <;> assumption
      cases h
      . exists tru; apply st_iszero0
      . exists fls; apply st_iszeroSucc; assumption
    . -- t can take a step
      rename_i h
      obtain ⟨t', h⟩ := h
      exists (iszero t')
      apply st_iszero; exact h

/-
### Type preservation

The second critical property of typing is that, when a well-typed term takes a step, the result is a well-typed term (of the same type).
-/

/-
exercise (3-star)
Complete the following informal proof:

_Theorem_: If `⊢ t ∈ T` and `t ~~> t'`, then `⊢ t' ∈ T`.
_Proof_: By induction on a derivation of `⊢ t ∈ T`.

* If the last rule in the derivation is `t_if`, then `t = if t₁ then t₂ else t₃`, with `⊢ t₁ ∈ bool`, `⊢ t₂ ∈ T`, and `⊢ t₃ ∈ T`.
  Inspecting the rules for the small-step reduction relation and remembering that `t` is the form `if ...`, we see that the only ones that could have been used to prove `t ~~> t'` are `st_ifTrue`, `st_ifFalse`, or `st_if`.
 * If the last rule was `st_ifTrue`, then `t' = t₂`.
   But we know that `⊢ t₂ ∈ T`, so we are done.
 * If the last rule was `st_ifFalse`, then `t' = t₃`.
   But we know that `⊢ t₃ ∈ T`, so we are done.
 * If the last rule was `st_if`, then `t' = if t₁' then t₂ else t₃`, where `t₁ ~~> t₁'`.
   We know `⊢ t₁ ∈ bool`, so by the IH, `⊢ t₁' ∈ bool`.
   The `t_if` rule then gives us `⊢ if if t₁' then t₂ else t₃ ∈ T`, as required.
/- **FILL IN HERE** -/
-/