-- src/candidates.lean

import «src».normal

open Term

variable [lc : LevelClass]

inductive Interp (i : lc.L) (I : ∀ j, j < i → Term → Prop) : Term → (Term → Prop) → Prop where
  | ne a : ne a → Interp i I a wne
  | pi a b Pa (Pf : Term → (Term → Prop) → Prop) :
    Interp i I a Pa →
    (∀ x, Pa x → ∃ Pb, Pf x Pb) →
    (∀ x Pb, Pf x Pb → Interp i I (subst (x +: var) b) Pb) →
    Interp i I (pi a b) (λ f ↦ ∀ x Pb, Pa x → Pf x Pb → Pb (app f x))
  | 𝒰 j (lt : j < i) : Interp i I (𝒰 (lof j)) (I j lt)
  | mty : Interp i I mty wne
  | lvl b : nf b → Interp i I (lvl b)
    (λ a ↦ (∃ j k, j < k ∧ a ⇒⋆ lof j ∧ b ⇒⋆ lof k) ∨ wne a)
  | step a b P :
    a ⇒ b →
    Interp i I b P →
    Interp i I a P

notation:40 "⟦" a "⟧" i "," I "↘" P => Interp i I a P

notation:40 "⟦" a "⟧" i "↘" P => Interps i a P

-- Repository definitions used:
content: notation:40 "⟦" a "⟧" i "," I "↘" P => Interp i I a P

content: notation:40 "⟦" a "⟧" i "↘" P => Interps i a P

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

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 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: @[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: class LevelClass where
  L : Type
  lc : LevelClasses L

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

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: infixr:50 "+:" => cons

content: prefix:95 "⇑" => up

-- Repository lemmas used:
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 parsLofInv {j b} (r : lof j ⇒⋆ b) : b = lof j

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

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

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

content: theorem parRefl a : a ⇒ a

-- Local definitions used:
content: inductive Interp (i : lc.L) (I : ∀ j, j < i → Term → Prop) : Term → (Term → Prop) → Prop where
  | ne a : ne a → Interp i I a wne
  | pi a b Pa (Pf : Term → (Term → Prop) → Prop) :
    Interp i I a Pa →
    (∀ x, Pa x → ∃ Pb, Pf x Pb) →
    (∀ x Pb, Pf x Pb → Interp i I (subst (x +: var) b) Pb) →
    Interp i I (pi a b) (λ f ↦ ∀ x Pb, Pa x → Pf x Pb → Pb (app f x))
  | 𝒰 j (lt : j < i) : Interp i I (𝒰 (lof j)) (I j lt)
  | mty : Interp i I mty wne
  | lvl b : nf b → Interp i I (lvl b)
    (λ a ↦ (∃ j k, j < k ∧ a ⇒⋆ lof j ∧ b ⇒⋆ lof k) ∨ wne a)
  | step a b P :
    a ⇒ b →
    Interp i I b P →
    Interp i I a P

-- Local lemmas used:
content: theorem interpLvlEq {b c} (r : b ⇒ c) :
  (λ a ↦ (∃ j k, j < k ∧ a ⇒⋆ lof j ∧ b ⇒⋆ lof k) ∨ wne a) =
  (λ a ↦ (∃ j k, j < k ∧ a ⇒⋆ lof j ∧ c ⇒⋆ lof k) ∨ wne a)

-- Target theorem and proof:
theorem interpFwd {i I a b P} (r : a ⇒ b) (h : ⟦ a ⟧ i , I ↘ P) : ⟦ b ⟧ i , I ↘ P
:= by
  induction h generalizing b
  case pi iha ihb =>
    cases r; constructor
    all_goals intros; apply_rules [parCong, parRefl]
  case ne nea => constructor; exact nePar r nea
  case 𝒰 => cases r; case 𝒰 r => cases r; constructor
  case mty => cases r; exact Interp.mty
  case lvl => cases r; case lvl nfb _ r =>
    rw [interpLvlEq r]; constructor; exact nfPars (parPars r) nfb
  case step r' _ ih =>
    let ⟨c, rc, rc'⟩ := diamond r r'
    constructor <;> apply_rules