-- src/safety.lean

import «src».typing

open Nat

open Term

variable [LevelClass]

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

-- 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: notation:40 Γ:41 "∋" x:41 "∶" A:41 => In x A Γ

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 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

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 Wf : Ctxt → Prop where
  | nil : ⊢ ⬝
  | cons {Γ A k} :
    ⊢ Γ →
    Γ ⊢ A ∶ 𝒰 k →
    
    ⊢ Γ ∷ A

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

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 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: inductive In : Nat → Term → Ctxt → Prop where
  | here {Γ A} : In 0 (rename succ A) (Γ ∷ A)
  | there {Γ x A B} : In x A Γ → In (succ x) (rename succ A) (Γ ∷ B)

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: 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: 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: def substComp σ τ : ∀ s, (subst σ ∘ subst τ) s = subst (subst σ ∘ τ) s :=
  substComp' _ _ (subst σ ∘ τ) (by admit /- proof elided -/
  )

content: def substId : ∀ s, subst var s = s :=
  substId' var (by admit /- proof elided -/
  )

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

content: notation:40 Γ:41 "∋" x:41 "∶" A:41 => In x A Γ

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

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

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

-- Repository lemmas used:
content: theorem renameLiftRename ξ a : rename succ (rename ξ a) = rename (lift ξ) (rename succ a)

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

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

content: theorem renameComp' ξ ζ ς (h : ∀ x, (ξ ∘ ζ) x = ς x) : ∀ s, (rename ξ ∘ rename ζ) s = rename ς s

content: omit lc in
theorem liftComp ξ ζ ς (h : ∀ x, (ξ ∘ ζ) x = ς x) :
  ∀ x, (lift ξ ∘ lift ζ) x = lift ς x

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

content: omit lc in
theorem liftExt ξ ζ (h : ∀ x, ξ x = ζ x) : ∀ x, lift ξ x = lift ζ x

content: theorem wtfPiInvA {Γ A B 𝒰'}
  (h : Γ ⊢ pi A B ∶ 𝒰') :
  ∃ j, Γ ⊢ A ∶ 𝒰 j

content: theorem wtfPiInvA𝒰 {Γ A B 𝒰'}
  (h : Γ ⊢ pi A B ∶ 𝒰') :
  ∃ j, Γ ⊢ A ∶ 𝒰 j ∧ 𝒰 j ≈ 𝒰'

content: theorem eqvConv {a b} (r : a ≈ b) : a ⇔ b

content: theorem convRename {a b} ξ : a ⇔ b → rename ξ a ⇔ rename ξ b

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

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

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

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

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

content: theorem wRenameLift {ξ : ℕ → ℕ} {Γ Δ A}
  (h : Δ ⊢ ξ ∶ Γ) :
  Δ ∷ (rename ξ A) ⊢ lift ξ ∶ Γ ∷ A

content: theorem inHere {Γ A A'} (e : A' = rename succ A) : (Γ ∷ A) ∋ 0 ∶ A'

content: theorem inThere {Γ x A A' B} (h : Γ ∋ x ∶ A) (e : A' = rename succ A) : Γ ∷ B ∋ succ x ∶ A'

content: theorem convEqv {a b} : a ⇔ b → a ≈ b

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

content: theorem parEqv {a b} (r : a ⇒ b) : a ≈ b

content: theorem wRenameSucc {Γ A} : Γ ∷ A ⊢ succ ∶ Γ

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

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

content: theorem wtWf {Γ} {a A : Term} (h : Γ ⊢ a ∶ A) : ⊢ Γ

content: theorem convSubst {a b} σ : a ⇔ b → subst σ a ⇔ subst σ b

content: theorem parsSubst {a b} σ (r : a ⇒⋆ b) : subst σ a ⇒⋆ subst σ b

content: theorem parSubst {a b} σ (r : a ⇒ b) : subst σ a ⇒ subst σ b

content: theorem parRefl a : a ⇒ a

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 substDist σ a s : subst (subst σ a +: var) (subst (⇑ σ) s) = subst σ (subst (a +: var) s)

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

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

content: theorem wtfLvlInv {Γ a 𝒰'}
  (h : Γ ⊢ lvl a ∶ 𝒰') :
  ∃ b k, Γ ⊢ a ∶ lvl b ∧ 𝒰 k ≈ 𝒰'

content: theorem wtfPiInvB {Γ A B 𝒰'}
  (h : Γ ⊢ pi A B ∶ 𝒰') :
  ∃ j, Γ ∷ A ⊢ B ∶ 𝒰 j

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

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

content: theorem wtfAbsInv {Γ A' b C}
  (h : Γ ⊢ abs A' b ∶ C) :
  ∃ A B, Γ ∷ A ⊢ b ∶ B ∧ A ≈ A' ∧ pi A B ≈ C

content: theorem convCong {a a' b b'} : a ⇔ a' → b ⇔ b' → subst (a +: var) b ⇔ subst (a' +: var) b'

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

content: theorem convPiInv {a₁ a₂ b₁ b₂} : pi a₁ b₁ ⇔ pi a₂ b₂ → a₁ ⇔ a₂ ∧ b₁ ⇔ b₂

content: theorem parsPiInv {a b c} (r : pi a b ⇒⋆ c) : ∃ a' b', c = pi a' b' ∧ a ⇒⋆ a' ∧ b ⇒⋆ b'

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

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

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

-- Local definitions used:

-- Local lemmas used:
content: theorem wtRename {ξ : ℕ → ℕ} {Γ Δ} {a A : Term}
  (hξ : Δ ⊢ ξ ∶ Γ) (hΔ : ⊢ Δ) (h : Γ ⊢ a ∶ A) :
  Δ ⊢ rename ξ a ∶ rename ξ A

content: theorem wtWeaken {Γ k} {a A B : Term}
  (hΓ : ⊢ Γ) (hB : Γ ⊢ B ∶ 𝒰 k) (h : Γ ⊢ a ∶ A) :
  Γ ∷ B ⊢ rename succ a ∶ rename succ A

content: theorem wSubstUp {σ Δ Γ k A}
  (hA : Δ ⊢ subst σ A ∶ 𝒰 k)
  (h : Δ ⊢ σ ∶ Γ) :
  Δ ∷ subst σ A ⊢ ⇑ σ ∶ Γ ∷ A

content: theorem wSubstCons {Γ} {a A : Term}
  (h : Γ ⊢ a ∶ A) :
  Γ ⊢ a +: var ∶ Γ ∷ A

content: theorem wtMorph {σ : ℕ → Term} {Γ Δ} {a A : Term}
  (hσ : Δ ⊢ σ ∶ Γ) (hΔ : ⊢ Δ) (h : Γ ⊢ a ∶ A) :
  Δ ⊢ subst σ a ∶ subst σ A

content: theorem wtSubst {Γ} {a A b B : Term}
  (hb : Γ ⊢ b ∶ B) (h : Γ ∷ B ⊢ a ∶ A) :
  Γ ⊢ subst (b +: var) a ∶ subst (b +: var) A

content: theorem wtReplace {Γ} {A B c C k : Term}
  (e : A ≈ B)
  (hB : Γ ⊢ B ∶ 𝒰 k)
  (h : Γ ∷ A ⊢ c ∶ C) :
  Γ ∷ B ⊢ c ∶ C

content: theorem wtMem {Γ x A} (mem : Γ ∋ x ∶ A) (h : ⊢ Γ) : ∃ k, Γ ⊢ A ∶ 𝒰 k

content: theorem wtRegularity {Γ} {a A : Term} (h : Γ ⊢ a ∶ A) : ∃ k, Γ ⊢ A ∶ 𝒰 k

-- Target theorem and proof:
theorem wtPar {Γ} {a b A : Term} (r : a ⇒ b) (h : Γ ⊢ a ∶ A) : Γ ⊢ b ∶ A
:= by
  induction h generalizing b
  case var => cases r; constructor <;> assumption
  case 𝒰 ih => cases r with | 𝒰 r' => exact Wt.𝒰 (ih r')
  case pi ihA ihB =>
    cases r with | pi ra rb =>
    let ihA' := ihA ra
    exact Wt.pi ihA' (wtReplace (parEqv ra) ihA' (ihB rb))
  case abs B _ _ hPi _ _ ihPi ihA ihb => cases r with | abs rA rb =>
    let rPi := Par.pi rA (parRefl B)
    let hb := wtReplace (convEqv (parConv rA)) (ihA rA) (ihb rb)
    exact Wt.conv
      (convEqv (convSym (parConv rPi)))
      (Wt.abs (ihPi rPi) (ihA rA) hb) hPi
  case app hb ha ihb iha =>
    cases r
    case β rb ra =>
      let ⟨_, hA⟩ := wtRegularity ha
      let ⟨_, hPi⟩ := wtRegularity hb
      let ⟨_, hB⟩ := wtfPiInvB hPi
      let ⟨A', B', hb', _, e⟩ := wtfAbsInv (ihb (Par.abs (parRefl _) rb))
      let ⟨eA, eB⟩ := convPiInv (eqvConv e)
      exact Wt.conv
        (convEqv (convCong (convSym (parConv ra)) eB))
        (wtSubst (iha ra) (wtReplace (convEqv eA) hA hb'))
        (wtSubst ha hB)
    case app rb ra =>
      let ⟨k, hBa⟩ := wtRegularity (Wt.app hb ha)
      exact Wt.conv
        (convEqv (convSym (parConv (parCong ra (parRefl _)))))
        (Wt.app (ihb rb) (iha ra)) hBa
  case mty ih => cases r; exact Wt.mty (ih (parRefl _))
  case exf hA _ ihA ihb => cases r with | exf rA rb =>
    exact Wt.conv
      (convEqv (convSym (parConv rA)))
      (Wt.exf (ihA rA) (ihb rb)) hA
  case lvl hj iha _ => cases r with | lvl r' => exact Wt.lvl (iha r') hj
  case lof => cases r; constructor <;> assumption
  case trans hj ihi _ => exact Wt.trans (ihi r) hj
  case conv e _ hB iha _ => exact Wt.conv e (iha r) hB
  case sub hj _ _ ihA => exact Wt.sub hj (ihA r)