-- src/typing.lean

import «src».reduction

open Nat

open Term

variable [LevelClass]

section

inductive Eqv : Term → Term → Prop where
  | β {b a c} : app (abs c b) a ≈ subst (a +: var) b
  | 𝒰 {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'
  | exf {a a' b b'} :
    a ≈ a' →
    b ≈ b' →
    
    exf a b ≈ exf a' b'
  | lvl {a a'} :
    a ≈ a' →
    
    lvl a ≈ lvl a'
  | refl {a} : a ≈ a
  | sym {a b} :
    a ≈ b →
    
    b ≈ a
  | trans {a b c} :
    a ≈ b →
    b ≈ c →
    
    a ≈ c

end

infix:40 (priority := 1001) "≈" => Eqv

section

inductive Wf : Ctxt → Prop where
  | nil : ⊢ ⬝
  | cons {Γ A k} :
    ⊢ Γ →
    Γ ⊢ A ∶ 𝒰 k →
    
    ⊢ Γ ∷ A

inductive Wt : Ctxt → Term → Term → Prop where
  | var {Γ x A} :
    ⊢ Γ →
    Γ ∋ x ∶ A →
    
    Γ ⊢ var x ∶ A
  | 𝒰 {Γ j k} :
    Γ ⊢ j ∶ lvl k →
    
    Γ ⊢ 𝒰 j ∶ 𝒰 k
  | pi {Γ A B k} :
    Γ ⊢ A ∶ 𝒰 k →
    Γ ∷ A ⊢ B ∶ 𝒰 (rename succ k) →
    
    Γ ⊢ pi A B ∶ 𝒰 k
  | abs {Γ A B b k} :
    Γ ⊢ pi A B ∶ 𝒰 k →
    Γ ⊢ A ∶ 𝒰 k →
    Γ ∷ A ⊢ b ∶ B →
    
    Γ ⊢ abs A b ∶ pi A B
  | app {Γ A B b a} :
    Γ ⊢ b ∶ pi A B →
    Γ ⊢ a ∶ A →
    
    Γ ⊢ app b a ∶ subst (a +: var) B
  | mty {Γ j k} :
    Γ ⊢ 𝒰 j ∶ 𝒰 k →
    
    Γ ⊢ mty ∶ 𝒰 j
  | exf {Γ A b k} :
    Γ ⊢ A ∶ 𝒰 k →
    Γ ⊢ b ∶ mty →
    
    Γ ⊢ exf A b ∶ A
  | lvl {Γ a b j k} :
    Γ ⊢ a ∶ lvl b →
    Γ ⊢ 𝒰 j ∶ 𝒰 k →
    
    Γ ⊢ lvl a ∶ 𝒰 j
  | lof {Γ j k} :
    ⊢ Γ →
    j < k →
    
    Γ ⊢ lof j ∶ lvl (lof k)
  | trans {Γ i j k} :
    Γ ⊢ i ∶ lvl j →
    Γ ⊢ j ∶ lvl k →
    
    Γ ⊢ i ∶ lvl k
  | conv {Γ A B a k} :
    A ≈ B →
    Γ ⊢ a ∶ A →
    Γ ⊢ B ∶ 𝒰 k →
    
    Γ ⊢ a ∶ B
  | sub {Γ j k A} :
    Γ ⊢ j ∶ lvl k →
    Γ ⊢ A ∶ 𝒰 j →
    
    Γ ⊢ A ∶ 𝒰 k

end

end

notation:40 "⊢" Γ:40 => Wf Γ

notation:40 Γ:41 "⊢" a:41 "∶" A:41 => Wt Γ a A

-- Repository definitions used:
content: notation:40 Δ:41 "⊢" ξ:41 "∶" Γ:41 => wRename ξ Γ Δ

content: notation:40 "⊢" Γ:40 => Wf Γ

content: notation:40 Γ:41 "⊢" a:41 "∶" A:41 => Wt Γ a A

content: notation:40 Δ:41 "⊢" σ:41 "∶" Γ:41 => wSubst σ Γ Δ

content: inductive Ctxt : Type where
  | nil : Ctxt
  | cons : Ctxt → Term → Ctxt

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: 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: def Conv (a : Term) (b : Term) : Prop := ∃ c, a ⇒⋆ c ∧ b ⇒⋆ c

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

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: @[simp]
def taka : Term → Term
  | 𝒰 a => 𝒰 (taka a)
  | pi a b => pi (taka a) (taka b)
  | abs a b => abs (taka a) (taka b)
  | app b a => match b with
    | abs _ b => subst (taka a +: var) (taka b)
    | b => app (taka b) (taka a)
  | exf a b => exf (taka a) (taka b)
  | lvl a => lvl (taka a)
  | t => t

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

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: infix:40 "⇒" => Par

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

content: infix:40 "⇔" => Conv

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

content: prefix:95 "⇑" => up

content: notation:50 "⬝" => Ctxt.nil

content: infixl:50 "∷" => Ctxt.cons

-- Repository lemmas used:
content: theorem conv𝒰 {a a'} : a ⇔ a' → 𝒰 a ⇔ 𝒰 a'

content: theorem pars𝒰 {a a'} (r : a ⇒⋆ a') : 𝒰 a ⇒⋆ 𝒰 a'

content: theorem convAbs {a a' b b'} : a ⇔ a' → b ⇔ b' → abs a b ⇔ abs a' b'

content: theorem parsAbs {a a' b b'} (ra : a ⇒⋆ a') (rb : b ⇒⋆ b') : abs a b ⇒⋆ abs a' b'

content: theorem parRefl a : a ⇒ a

content: theorem convPi {a a' b b'} : a ⇔ a' → b ⇔ b' → pi a b ⇔ pi a' b'

content: theorem parsPi {a a' b b'} (ra : a ⇒⋆ a') (rb : b ⇒⋆ b') : pi a b ⇒⋆ pi a' b'

content: theorem convApp {b b' a a'} : b ⇔ b' → a ⇔ a' → app b a ⇔ app b' a'

content: theorem parsApp {a a' b b'} (rb : b ⇒⋆ b') (ra : a ⇒⋆ a') : app b a ⇒⋆ app b' a'

content: theorem convSym {a b} : a ⇔ b → b ⇔ a

content: theorem convTrans {a b c} : a ⇔ b → b ⇔ c → a ⇔ c

content: theorem confluence {a b c} (r₁ : a ⇒⋆ b) (r₂ : a ⇒⋆ c) : ∃ d, b ⇒⋆ d ∧ c ⇒⋆ d

content: theorem diacon {a b c} (r₁ : a ⇒⋆ b) (r₂ : a ⇒ c) : ∃ d, b ⇒⋆ d ∧ c ⇒⋆ d

content: theorem diamond {a b c} (r₁ : a ⇒ b) (r₂ : a ⇒ c) : ∃ d, b ⇒ d ∧ c ⇒ d

content: theorem parTaka {a b} (r : a ⇒ b) : b ⇒ taka a

content: theorem parCong {a a' b b'} (ra : a ⇒ a') (rb : b ⇒ b') : subst (a +: var) b ⇒ subst (a' +: var) b'

content: theorem parMorphing {a b} σ τ (h : ∀ x, σ x ⇒ τ x) (r : a ⇒ b) : subst σ a ⇒ subst τ b

content: theorem parLift σ τ (h : ∀ x, σ x ⇒ τ x) : ∀ x, (⇑ σ) x ⇒ (⇑ τ) x

content: theorem parRename {a b} ξ (r : a ⇒ b) : rename ξ a ⇒ rename ξ b

content: theorem parPars {a b} (r : a ⇒ b) : a ⇒⋆ b

content: theorem parsTrans {a b c} (r₁ : a ⇒⋆ b) (r₂ : b ⇒⋆ c) : a ⇒⋆ c

content: theorem convExf {a a' b b'} : a ⇔ a' → b ⇔ b' → exf a b ⇔ exf a' b'

content: theorem parsExf {a a' b b'} (ra : a ⇒⋆ a') (rb : b ⇒⋆ b') : exf a b ⇒⋆ exf a' b'

content: theorem convRefl {a} : a ⇔ a

content: theorem parConv {a b} (r : a ⇒ b) : a ⇔ b

content: theorem parsConv {a b} (r : a ⇒⋆ b) : a ⇔ b

content: theorem convLvl {a a'} : a ⇔ a' → lvl a ⇔ lvl a'

content: theorem parsLvl {a a'} (r : a ⇒⋆ a') : lvl a ⇒⋆ lvl a'

content: theorem convLvl𝒰 {j k} : ¬ lvl j ⇔ 𝒰 k

content: theorem parsLvlInv {i b} (r : lvl i ⇒⋆ b) : ∃ j, b = lvl j ∧ i ⇒⋆ j

content: theorem pars𝒰Inv {a b} (r : 𝒰 a ⇒⋆ b) : ∃ a', b = 𝒰 a' ∧ a ⇒⋆ a'

-- Local definitions used:
content: inductive Eqv : Term → Term → Prop where
  | β {b a c} : app (abs c b) a ≈ subst (a +: var) b
  | 𝒰 {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'
  | exf {a a' b b'} :
    a ≈ a' →
    b ≈ b' →
    
    exf a b ≈ exf a' b'
  | lvl {a a'} :
    a ≈ a' →
    
    lvl a ≈ lvl a'
  | refl {a} : a ≈ a
  | sym {a b} :
    a ≈ b →
    
    b ≈ a
  | trans {a b c} :
    a ≈ b →
    b ≈ c →
    
    a ≈ c

content: inductive Wf : Ctxt → Prop where
  | nil : ⊢ ⬝
  | cons {Γ A k} :
    ⊢ Γ →
    Γ ⊢ A ∶ 𝒰 k →
    
    ⊢ Γ ∷ A

content: inductive Wt : Ctxt → Term → Term → Prop where
  | var {Γ x A} :
    ⊢ Γ →
    Γ ∋ x ∶ A →
    
    Γ ⊢ var x ∶ A
  | 𝒰 {Γ j k} :
    Γ ⊢ j ∶ lvl k →
    
    Γ ⊢ 𝒰 j ∶ 𝒰 k
  | pi {Γ A B k} :
    Γ ⊢ A ∶ 𝒰 k →
    Γ ∷ A ⊢ B ∶ 𝒰 (rename succ k) →
    
    Γ ⊢ pi A B ∶ 𝒰 k
  | abs {Γ A B b k} :
    Γ ⊢ pi A B ∶ 𝒰 k →
    Γ ⊢ A ∶ 𝒰 k →
    Γ ∷ A ⊢ b ∶ B →
    
    Γ ⊢ abs A b ∶ pi A B
  | app {Γ A B b a} :
    Γ ⊢ b ∶ pi A B →
    Γ ⊢ a ∶ A →
    
    Γ ⊢ app b a ∶ subst (a +: var) B
  | mty {Γ j k} :
    Γ ⊢ 𝒰 j ∶ 𝒰 k →
    
    Γ ⊢ mty ∶ 𝒰 j
  | exf {Γ A b k} :
    Γ ⊢ A ∶ 𝒰 k →
    Γ ⊢ b ∶ mty →
    
    Γ ⊢ exf A b ∶ A
  | lvl {Γ a b j k} :
    Γ ⊢ a ∶ lvl b →
    Γ ⊢ 𝒰 j ∶ 𝒰 k →
    
    Γ ⊢ lvl a ∶ 𝒰 j
  | lof {Γ j k} :
    ⊢ Γ →
    j < k →
    
    Γ ⊢ lof j ∶ lvl (lof k)
  | trans {Γ i j k} :
    Γ ⊢ i ∶ lvl j →
    Γ ⊢ j ∶ lvl k →
    
    Γ ⊢ i ∶ lvl k
  | conv {Γ A B a k} :
    A ≈ B →
    Γ ⊢ a ∶ A →
    Γ ⊢ B ∶ 𝒰 k →
    
    Γ ⊢ a ∶ B
  | sub {Γ j k A} :
    Γ ⊢ j ∶ lvl k →
    Γ ⊢ A ∶ 𝒰 j →
    
    Γ ⊢ A ∶ 𝒰 k

-- Local lemmas used:
content: theorem eqvConv {a b} (r : a ≈ b) : a ⇔ b

-- Target theorem and proof:
theorem wtfLvlInv {Γ a 𝒰'}
  (h : Γ ⊢ lvl a ∶ 𝒰') :
  ∃ b k, Γ ⊢ a ∶ lvl b ∧ 𝒰 k ≈ 𝒰'
:= by
  generalize e : lvl a = t at h
  induction h
  all_goals injections <;> subst_eqs <;> specialize_rfls
  case lvl ha _ => exact ⟨_, _, ha, Eqv.refl⟩
  case trans ih =>
    let ⟨_, _, _, e⟩ := ih
    cases convLvl𝒰 (convSym (eqvConv e))
  case conv e₁ _ _ _ ih =>
    let ⟨b, _, ha, e₂⟩ := ih
    exact ⟨b, _, ha, Eqv.trans e₂ e₁⟩
  case sub ih =>
    let ⟨b, _, ha, _⟩ := ih
    exact ⟨b, _, ha, Eqv.refl⟩