-- src/reduction.lean

import «src».tactics

import «src».syntactics

open Term

variable [LevelClass]

section

inductive Par : Term → Term → Prop where
  | β {b b' a a' c} :
    b ⇒ b' →
    a ⇒ a' →
    
    app (abs c b) a ⇒ subst (a' +: var) b'
  | var s : var s ⇒ var s
  | 𝒰 {a a'} :
    a ⇒ a' →
    
    𝒰 a ⇒ 𝒰 a'
  | pi {a a' b b'} :
    a ⇒ a' →
    b ⇒ b' →
    
    pi a b ⇒ pi a' b'
  | abs {a a' b b'} :
    a ⇒ a' →
    b ⇒ b' →
    
    abs a b ⇒ abs a' b'
  | app {b b' a a'} :
    b ⇒ b' →
    a ⇒ a' →
    
    app b a ⇒ app b' a'
  | mty : mty ⇒ mty
  | exf {a a' b b'} :
    a ⇒ a' →
    b ⇒ b' →
    
    exf a b ⇒ exf a' b'
  | lvl {a a'} :
    a ⇒ a' →
    
    lvl a ⇒ lvl a'
  | lof k : lof k ⇒ lof k

end

infix:40 "⇒" => Par

-- Repository definitions used:
content: inductive Term : Type where
  | var : Nat → Term
  | 𝒰 : Term → Term
  | pi : Term → Term → Term
  | abs : Term → Term → Term
  | app : Term → Term → Term
  | mty : Term
  | exf : Term → Term → Term
  | lvl : Term → Term
  | lof : lc.L → Term

content: @[simp]
def subst (σ : Nat → Term) : Term → Term
  | var s => σ s
  | 𝒰 a => 𝒰 (subst σ a)
  | pi a b => pi (subst σ a) (subst (⇑ σ) b)
  | abs a b => abs (subst σ a) (subst (⇑ σ) b)
  | app b a => app (subst σ b) (subst σ a)
  | mty => mty
  | exf a b => exf (subst σ a) (subst σ b)
  | lvl a => lvl (subst σ a)
  | lof k => lof k

content: inductive Par : Term → Term → Prop where
  | β {b b' a a' c} :
    b ⇒ b' →
    a ⇒ a' →
    
    app (abs c b) a ⇒ subst (a' +: var) b'
  | var s : var s ⇒ var s
  | 𝒰 {a a'} :
    a ⇒ a' →
    
    𝒰 a ⇒ 𝒰 a'
  | pi {a a' b b'} :
    a ⇒ a' →
    b ⇒ b' →
    
    pi a b ⇒ pi a' b'
  | abs {a a' b b'} :
    a ⇒ a' →
    b ⇒ b' →
    
    abs a b ⇒ abs a' b'
  | app {b b' a a'} :
    b ⇒ b' →
    a ⇒ a' →
    
    app b a ⇒ app b' a'
  | mty : mty ⇒ mty
  | exf {a a' b b'} :
    a ⇒ a' →
    b ⇒ b' →
    
    exf a b ⇒ exf a' b'
  | lvl {a a'} :
    a ⇒ a' →
    
    lvl a ⇒ lvl a'
  | lof k : lof k ⇒ lof k

content: inductive Pars : Term → Term → Prop where
  | refl a : a ⇒⋆ a
  | trans {a b c} : a ⇒ b → b ⇒⋆ c → a ⇒⋆ c

content: infix:40 "⇒⋆" => Pars

content: @[simp]
def nf : Term → Prop
  | 𝒰 a => nf a
  | pi a b => nf a ∧ nf b
  | abs a b => nf a ∧ nf b
  | app b a => ne b ∧ nf a
  | exf a b => nf a ∧ ne b
  | lvl a => nf a
  | _ => True

content: @[simp]
def ne : Term → Prop
  | var _ => True
  | app b a => ne b ∧ nf a
  | exf a b => nf a ∧ ne b
  | _ => False

content: @[simp] def wnf (a : Term) : Prop := ∃ b, nf b ∧ a ⇒⋆ b

content: @[simp] def wne (a : Term) : Prop := ∃ b, ne b ∧ a ⇒⋆ b

content: @[simp]
def rename (ξ : Nat → Nat) : Term → Term
  | var s => var (ξ s)
  | 𝒰 a => 𝒰 (rename ξ a)
  | pi a b => pi (rename ξ a) (rename (lift ξ) b)
  | abs a b => abs (rename ξ a) (rename (lift ξ) b)
  | app b a => app (rename ξ b) (rename ξ a)
  | mty => mty
  | exf a b => exf (rename ξ a) (rename ξ b)
  | lvl a => lvl (rename ξ a)
  | lof k => lof k

content: @[simp]
def lift (ξ : Nat → Nat) : Nat → Nat :=
  zero +: (succ ∘ ξ)

content: @[simp]
def cons {A : Type} (x : A) (ξ : Nat → A) : Nat → A
  | 0 => x
  | n + 1 => ξ n

content: def substRename ξ σ : ∀ s, subst σ (rename ξ s) = subst (σ ∘ ξ) s :=
  substRename' _ _ (σ ∘ ξ) (by admit /- proof elided -/
  )

content: def renameSubst ξ σ : ∀ s, rename ξ (subst σ s) = subst (rename ξ ∘ σ) s :=
  renameSubst' _ _ (rename ξ ∘ σ) (by admit /- proof elided -/
  )

content: @[simp]
def up (σ : Nat → Term) : Nat → Term :=
  var 0 +: (rename succ ∘ σ)

content: infixr:50 "+:" => cons

content: prefix:95 "⇑" => up

-- Repository lemmas used:
content: theorem liftExt ξ ζ (h : ∀ x, ξ x = ζ x) : ∀ x, lift ξ x = lift ζ x

content: theorem liftId ξ (h : ∀ x, ξ x = x) : ∀ x, lift ξ x = x

content: theorem liftSucc ξ : ∀ x, (lift ξ ∘ succ) x = (succ ∘ ξ) x

content: theorem renameExt ξ ζ (h : ∀ x, ξ x = ζ x) : ∀ s, rename ξ s = rename ζ s

content: theorem renameId s : rename id s = s

content: theorem renameComp ξ ζ s : rename ξ (rename ζ s) = rename (ξ ∘ ζ) s

content: theorem upExt σ τ (h : ∀ x, σ x = τ x) : ∀ x, (⇑ σ) x = (⇑ τ) x

content: theorem upSucc σ : ∀ x, (⇑ σ ∘ succ) x = (rename succ ∘ σ) x

content: theorem substExt σ τ (h : ∀ x, σ x = τ x) : ∀ s, subst σ s = subst τ s

content: theorem substId' σ (h : ∀ x, σ x = var x) : ∀ s, subst σ s = s

content: theorem substRename' ξ σ τ (h : ∀ x, (σ ∘ ξ) x = τ x) : ∀ s, subst σ (rename ξ s) = subst τ s

content: theorem renameSubst' ξ σ τ (h : ∀ x, (rename ξ ∘ σ) x = τ x) : ∀ s, rename ξ (subst σ s) = subst τ s

content: theorem renameDist ξ a s : subst (rename ξ a +: var) (rename (lift ξ) s) = rename ξ (subst (a +: var) s)

content: theorem substDrop σ a b : subst (a +: σ) (rename succ b) = subst σ b

content: theorem substUnion σ a s : subst (a +: σ) s = subst (a +: var) (subst (⇑ σ) s)

content: theorem neNf {a} : ne a → nf a

content: theorem nfPars {a b} (r : a ⇒⋆ b) : nf a → nf b

content: theorem nePars {a b} (r : a ⇒⋆ b) : ne a → ne b

content: theorem wnfRename {ξ a} : wnf (rename ξ a) → wnf a

content: theorem wneRename {ξ a} : wne (rename ξ a) → wne a

content: theorem renameToSubst ξ : ∀ s, rename ξ s = subst (var ∘ ξ) s

content: theorem renameLiftRename ξ a : rename succ (rename ξ a) = rename (lift ξ) (rename succ a)

content: theorem renameUpSubst σ a : rename succ (subst σ a) = subst (⇑ σ) (rename succ a)

content: theorem substDropAll a b : b = subst (a +: var) (rename succ b)

content: theorem wnfBwds {a b} (r : a ⇒⋆ b) : wnf b → wnf a

content: theorem wneBwds {a b} (r : a ⇒⋆ b) : wne b → wne a

content: theorem wnfFwds {a b} (r : a ⇒⋆ b) : wnf a → wnf b

content: theorem wneFwds {a b} (r : a ⇒⋆ b) : wne a → wne b

-- Local definitions used:
content: inductive Par : Term → Term → Prop where
  | β {b b' a a' c} :
    b ⇒ b' →
    a ⇒ a' →
    
    app (abs c b) a ⇒ subst (a' +: var) b'
  | var s : var s ⇒ var s
  | 𝒰 {a a'} :
    a ⇒ a' →
    
    𝒰 a ⇒ 𝒰 a'
  | pi {a a' b b'} :
    a ⇒ a' →
    b ⇒ b' →
    
    pi a b ⇒ pi a' b'
  | abs {a a' b b'} :
    a ⇒ a' →
    b ⇒ b' →
    
    abs a b ⇒ abs a' b'
  | app {b b' a a'} :
    b ⇒ b' →
    a ⇒ a' →
    
    app b a ⇒ app b' a'
  | mty : mty ⇒ mty
  | exf {a a' b b'} :
    a ⇒ a' →
    b ⇒ b' →
    
    exf a b ⇒ exf a' b'
  | lvl {a a'} :
    a ⇒ a' →
    
    lvl a ⇒ lvl a'
  | lof k : lof k ⇒ lof k

-- Local lemmas used:
content: theorem parRefl a : a ⇒ a

-- Target theorem and proof:
theorem antirenaming {ξ a b'} (r : rename ξ a ⇒ b') : ∃ b, b' = rename ξ b ∧ a ⇒ b
:= by
  generalize e : rename ξ a = a' at r
  induction r generalizing ξ a
  all_goals cases a <;> injections; subst_eqs; specialize_rfls
  case β ihb b _ e _ iha =>
    cases b <;> injections; subst_eqs; specialize_rfls
    let ⟨a, ea, ra⟩ := iha
    let ⟨b, eb, rb⟩ := ihb
    subst ea; subst eb
    exact ⟨subst (a +: var) b, renameDist ξ a b, Par.β rb ra⟩
  case var => exact ⟨var _, rfl, parRefl _⟩
  case 𝒰 ih =>
    let ⟨a, e, r⟩ := ih
    subst e
    exact ⟨𝒰 a, rfl, Par.𝒰 r⟩
  case pi iha ihb =>
    let ⟨a, ea, ra⟩ := iha
    let ⟨b, eb, rb⟩ := ihb
    subst ea; subst eb
    exact ⟨pi a b, rfl, Par.pi ra rb⟩
  case abs iha ihb =>
    let ⟨a, ea, ra⟩ := iha
    let ⟨b, eb, rb⟩ := ihb
    subst ea; subst eb
    exact ⟨abs a b, rfl, Par.abs ra rb⟩
  case app ihb iha =>
    let ⟨a, ea, ra⟩ := iha
    let ⟨b, eb, rb⟩ := ihb
    subst ea; subst eb
    exact ⟨app b a, rfl, Par.app rb ra⟩
  case mty => exact ⟨mty, rfl, Par.mty⟩
  case exf iha ihb =>
    let ⟨a, ea, ra⟩ := iha
    let ⟨b, eb, rb⟩ := ihb
    subst ea; subst eb
    exact ⟨exf a b, rfl, Par.exf ra rb⟩
  case lvl ih =>
    let ⟨a, e, r⟩ := ih
    subst e
    exact ⟨lvl a, rfl, Par.lvl r⟩
  case lof => exact ⟨lof _, rfl, parRefl _⟩