open import Definition.Typed.Restrictions
open import Graded.Modality
module Definition.Typed.Properties.Admissible.Pi
{ℓ} {M : Set ℓ}
{𝕄 : Modality M}
(R : Type-restrictions 𝕄)
where
open Type-restrictions R
open import Definition.Untyped M
open import Definition.Untyped.Lift M
open import Definition.Untyped.Pi M
open import Definition.Untyped.Pi-Sigma M
open import Definition.Untyped.Properties M
open import Definition.Typed R
open import Definition.Typed.Inversion.Primitive R
open import Definition.Typed.Properties.Admissible.Equality R
open import Definition.Typed.Properties.Admissible.Level R
open import Definition.Typed.Properties.Admissible.Lift R
open import Definition.Typed.Properties.Admissible.Pi-Sigma R
open import Definition.Typed.Properties.Admissible.Var R
open import Definition.Typed.Properties.Reduction R
open import Definition.Typed.Properties.Well-formed R
open import Definition.Typed.Reasoning.Reduction R
open import Definition.Typed.Reasoning.Term R
open import Definition.Typed.Substitution.Primitive R
import Definition.Typed.Substitution.Primitive.Primitive R as S
open import Definition.Typed.Weakening R as W
open import Definition.Typed.Well-formed R
open import Tools.Fin
open import Tools.Function
open import Tools.Nat
open import Tools.Product
import Tools.PropositionalEquality as PE
open import Tools.Reasoning.PropositionalEquality
private variable
n : Nat
∇ : DCon _ _
Δ : Con _ _
Γ : Cons _ _
A B C D E F a f g l l₁ l₂ t t′ t₁ t₂ u u₁ u₂ u₃ u₄ u₅ v : Term _
p p′ p₁ p₂ p₃ p₄ p₅ q q₁ q₂ q₃ q₄ q₅ : M
opaque
lamⱼ′ :
Π-allowed p q →
Γ »∙ A ⊢ t ∷ B →
Γ ⊢ lam p t ∷ Π p , q ▷ A ▹ B
lamⱼ′ ok ⊢t = lamⱼ (wf-⊢∷ ⊢t) ⊢t ok
opaque
lam-cong :
Γ »∙ A ⊢ t ≡ u ∷ B →
Π-allowed p q →
Γ ⊢ lam p t ≡ lam p u ∷ Π p , q ▷ A ▹ B
lam-cong t≡u =
let ⊢B , ⊢t , ⊢u = wf-⊢≡∷ t≡u in
S.lam-cong ⊢B ⊢t ⊢u t≡u
opaque
η-eq′ :
Γ ⊢ t ∷ Π p , q ▷ A ▹ B →
Γ ⊢ u ∷ Π p , q ▷ A ▹ B →
Γ »∙ A ⊢ wk1 t ∘⟨ p ⟩ var x0 ≡ wk1 u ∘⟨ p ⟩ var x0 ∷ B →
Γ ⊢ t ≡ u ∷ Π p , q ▷ A ▹ B
η-eq′ ⊢t ⊢u t0≡u0 =
let _ , ⊢B , ok = inversion-ΠΣ (wf-⊢∷ ⊢t) in
η-eq ⊢B ⊢t ⊢u t0≡u0 ok
opaque
app-subst* :
Γ ⊢ t ⇒* t′ ∷ Π p , q ▷ A ▹ B →
Γ ⊢ u ∷ A →
Γ ⊢ t ∘⟨ p ⟩ u ⇒* t′ ∘⟨ p ⟩ u ∷ B [ u ]₀
app-subst* (id ⊢t) ⊢u = id (⊢t ∘ⱼ ⊢u)
app-subst* (t⇒t′ ⇨ t′⇒t″) ⊢u = app-subst t⇒t′ ⊢u ⇨ app-subst* t′⇒t″ ⊢u
opaque
β-red-⇒ :
Γ »∙ A ⊢ t ∷ B →
Γ ⊢ u ∷ A →
Π-allowed p q →
Γ ⊢ lam p t ∘⟨ p ⟩ u ⇒ t [ u ]₀ ∷ B [ u ]₀
β-red-⇒ ⊢t ⊢u =
β-red (wf-⊢∷ ⊢t) ⊢t ⊢u PE.refl
opaque
β-red-≡ :
Γ »∙ A ⊢ t ∷ B →
Γ ⊢ u ∷ A →
Π-allowed p q →
Γ ⊢ lam p t ∘⟨ p ⟩ u ≡ t [ u ]₀ ∷ B [ u ]₀
β-red-≡ ⊢t ⊢u ok =
subsetTerm (β-red-⇒ ⊢t ⊢u ok)
opaque
β-red-⇒₂′ :
Π-allowed p₁ q₁ →
Π-allowed p₂ q₂ →
Γ »∙ A »∙ B ⊢ t ∷ C →
Γ ⊢ u₁ ∷ A →
Γ ⊢ u₂ ∷ B [ u₁ ]₀ →
Γ ⊢ lam p₁ (lam p₂ t) ∘⟨ p₁ ⟩ u₁ ∘⟨ p₂ ⟩ u₂ ⇒* t [ u₁ , u₂ ]₁₀ ∷
C [ u₁ , u₂ ]₁₀
β-red-⇒₂′ {p₁} {p₂} {t} {C} {u₁} {u₂} ok₁ ok₂ ⊢t ⊢u₁ ⊢u₂ =
lam p₁ (lam p₂ t) ∘⟨ p₁ ⟩ u₁ ∘⟨ p₂ ⟩ u₂ ⇒⟨ PE.subst (_⊢_⇒_∷_ _ _ _) (singleSubstComp _ _ C) $
app-subst (β-red-⇒ (lamⱼ′ ok₂ ⊢t) ⊢u₁ ok₁) ⊢u₂ ⟩
lam p₂ (t [ sgSubst u₁ ⇑ ]) ∘⟨ p₂ ⟩ u₂ ⇒⟨ PE.subst (_⊢_⇒_∷_ _ _ _) (singleSubstComp _ _ C) $
β-red-⇒ (subst-⊢∷-⇑ ⊢t (⊢ˢʷ∷-sgSubst ⊢u₁)) ⊢u₂ ok₂ ⟩∎≡
t [ sgSubst u₁ ⇑ ] [ u₂ ]₀ ≡⟨ singleSubstComp _ _ t ⟩
t [ u₁ , u₂ ]₁₀ ∎
opaque
β-red-⇒₃′ :
Π-allowed p₁ q₁ →
Π-allowed p₂ q₂ →
Π-allowed p₃ q₃ →
Γ »∙ A »∙ B »∙ C ⊢ t ∷ D →
Γ ⊢ u₁ ∷ A →
Γ ⊢ u₂ ∷ B [ u₁ ]₀ →
Γ ⊢ u₃ ∷ C [ u₁ , u₂ ]₁₀ →
Γ ⊢ lam p₁ (lam p₂ (lam p₃ t)) ∘⟨ p₁ ⟩ u₁ ∘⟨ p₂ ⟩ u₂ ∘⟨ p₃ ⟩ u₃ ⇒*
t [ consSubst (consSubst (sgSubst u₁) u₂) u₃ ] ∷
D [ consSubst (consSubst (sgSubst u₁) u₂) u₃ ]
β-red-⇒₃′
{p₁} {p₂} {p₃} {t} {D} {u₁} {u₂} {u₃}
ok₁ ok₂ ok₃ ⊢t ⊢u₁ ⊢u₂ ⊢u₃ =
lam p₁ (lam p₂ (lam p₃ t)) ∘⟨ p₁ ⟩ u₁ ∘⟨ p₂ ⟩ u₂ ∘⟨ p₃ ⟩ u₃ ⇒*⟨ PE.subst (_⊢_⇒*_∷_ _ _ _) (singleSubstComp _ _ D) $
app-subst* (β-red-⇒₂′ ok₁ ok₂ (lamⱼ′ ok₃ ⊢t) ⊢u₁ ⊢u₂) ⊢u₃ ⟩
lam p₃ (t [ consSubst (sgSubst u₁) u₂ ⇑ ]) ∘⟨ p₃ ⟩ u₃ ⇒⟨ PE.subst (_⊢_⇒_∷_ _ _ _) (singleSubstComp _ _ D) $
β-red-⇒ (subst-⊢∷-⇑ ⊢t (→⊢ˢʷ∷∙ (⊢ˢʷ∷-sgSubst ⊢u₁) ⊢u₂)) ⊢u₃ ok₃ ⟩∎≡
t [ consSubst (sgSubst u₁) u₂ ⇑ ] [ u₃ ]₀ ≡⟨ singleSubstComp _ _ t ⟩
t [ consSubst (consSubst (sgSubst u₁) u₂) u₃ ] ∎
opaque
β-red-⇒₄′ :
Π-allowed p₁ q₁ →
Π-allowed p₂ q₂ →
Π-allowed p₃ q₃ →
Π-allowed p₄ q₄ →
Γ »∙ A »∙ B »∙ C »∙ D ⊢ t ∷ E →
Γ ⊢ u₁ ∷ A →
Γ ⊢ u₂ ∷ B [ u₁ ]₀ →
Γ ⊢ u₃ ∷ C [ u₁ , u₂ ]₁₀ →
Γ ⊢ u₄ ∷ D [ consSubst (consSubst (sgSubst u₁) u₂) u₃ ] →
Γ ⊢
lam p₁ (lam p₂ (lam p₃ (lam p₄ t)))
∘⟨ p₁ ⟩ u₁ ∘⟨ p₂ ⟩ u₂ ∘⟨ p₃ ⟩ u₃ ∘⟨ p₄ ⟩ u₄ ⇒*
t [ consSubst (consSubst (consSubst (sgSubst u₁) u₂) u₃) u₄ ] ∷
E [ consSubst (consSubst (consSubst (sgSubst u₁) u₂) u₃) u₄ ]
β-red-⇒₄′
{p₁} {p₂} {p₃} {p₄} {t} {E} {u₁} {u₂} {u₃} {u₄}
ok₁ ok₂ ok₃ ok₄ ⊢t ⊢u₁ ⊢u₂ ⊢u₃ ⊢u₄ =
lam p₁ (lam p₂ (lam p₃ (lam p₄ t))) ∘⟨ p₁ ⟩ u₁ ∘⟨ p₂ ⟩ u₂ ∘⟨ p₃ ⟩ u₃
∘⟨ p₄ ⟩ u₄ ⇒*⟨ PE.subst (_⊢_⇒*_∷_ _ _ _) (singleSubstComp _ _ E) $
app-subst* (β-red-⇒₃′ ok₁ ok₂ ok₃ (lamⱼ′ ok₄ ⊢t) ⊢u₁ ⊢u₂ ⊢u₃) ⊢u₄ ⟩
lam p₄ (t [ consSubst (consSubst (sgSubst u₁) u₂) u₃ ⇑ ]) ∘⟨ p₄ ⟩ u₄ ⇒⟨ PE.subst (_⊢_⇒_∷_ _ _ _) (singleSubstComp _ _ E) $
β-red-⇒ (subst-⊢∷-⇑ ⊢t (→⊢ˢʷ∷∙ (→⊢ˢʷ∷∙ (⊢ˢʷ∷-sgSubst ⊢u₁) ⊢u₂) ⊢u₃))
⊢u₄ ok₄ ⟩∎≡
t [ consSubst (consSubst (sgSubst u₁) u₂) u₃ ⇑ ] [ u₄ ]₀ ≡⟨ singleSubstComp _ _ t ⟩
t [ consSubst (consSubst (consSubst (sgSubst u₁) u₂) u₃) u₄ ] ∎
opaque
β-red-⇒₅′ :
Π-allowed p₁ q₁ →
Π-allowed p₂ q₂ →
Π-allowed p₃ q₃ →
Π-allowed p₄ q₄ →
Π-allowed p₅ q₅ →
Γ »∙ A »∙ B »∙ C »∙ D »∙ E ⊢ t ∷ F →
Γ ⊢ u₁ ∷ A →
Γ ⊢ u₂ ∷ B [ u₁ ]₀ →
Γ ⊢ u₃ ∷ C [ u₁ , u₂ ]₁₀ →
Γ ⊢ u₄ ∷ D [ consSubst (consSubst (sgSubst u₁) u₂) u₃ ] →
Γ ⊢ u₅ ∷
E [ consSubst (consSubst (consSubst (sgSubst u₁) u₂) u₃) u₄ ] →
Γ ⊢
lam p₁ (lam p₂ (lam p₃ (lam p₄ (lam p₅ t))))
∘⟨ p₁ ⟩ u₁ ∘⟨ p₂ ⟩ u₂ ∘⟨ p₃ ⟩ u₃ ∘⟨ p₄ ⟩ u₄ ∘⟨ p₅ ⟩ u₅ ⇒*
t [ consSubst
(consSubst (consSubst (consSubst (sgSubst u₁) u₂) u₃) u₄)
u₅ ] ∷
F [ consSubst
(consSubst (consSubst (consSubst (sgSubst u₁) u₂) u₃) u₄)
u₅ ]
β-red-⇒₅′
{p₁} {p₂} {p₃} {p₄} {p₅} {t} {F} {u₁} {u₂} {u₃} {u₄} {u₅}
ok₁ ok₂ ok₃ ok₄ ok₅ ⊢t ⊢u₁ ⊢u₂ ⊢u₃ ⊢u₄ ⊢u₅ =
lam p₁ (lam p₂ (lam p₃ (lam p₄ (lam p₅ t)))) ∘⟨ p₁ ⟩ u₁ ∘⟨ p₂ ⟩ u₂
∘⟨ p₃ ⟩ u₃ ∘⟨ p₄ ⟩ u₄ ∘⟨ p₅ ⟩ u₅ ⇒*⟨ PE.subst (_⊢_⇒*_∷_ _ _ _) (singleSubstComp _ _ F) $
app-subst* (β-red-⇒₄′ ok₁ ok₂ ok₃ ok₄ (lamⱼ′ ok₅ ⊢t) ⊢u₁ ⊢u₂ ⊢u₃ ⊢u₄)
⊢u₅ ⟩
lam p₅
(t [ consSubst (consSubst (consSubst (sgSubst u₁) u₂) u₃) u₄ ⇑ ])
∘⟨ p₅ ⟩ u₅ ⇒⟨ PE.subst (_⊢_⇒_∷_ _ _ _) (singleSubstComp _ _ F) $
β-red-⇒
(subst-⊢∷-⇑ ⊢t $
→⊢ˢʷ∷∙ (→⊢ˢʷ∷∙ (→⊢ˢʷ∷∙ (⊢ˢʷ∷-sgSubst ⊢u₁) ⊢u₂) ⊢u₃) ⊢u₄)
⊢u₅ ok₅ ⟩∎≡
t [ consSubst (consSubst (consSubst (sgSubst u₁) u₂) u₃) u₄ ⇑ ]
[ u₅ ]₀ ≡⟨ singleSubstComp _ _ t ⟩
t [ consSubst
(consSubst (consSubst (consSubst (sgSubst u₁) u₂) u₃) u₄) u₅ ] ∎
opaque
unfolding Πs
⊢Πs :
Π-allowed p q or-empty Δ →
∇ » Δ ⊢ A →
∇ » ε ⊢ Πs p q Δ A
⊢Πs {Δ = ε} _ ⊢A = ⊢A
⊢Πs {Δ = _ ∙ _} (possibly-nonempty ⦃ ok ⦄) ⊢A =
⊢Πs possibly-nonempty (ΠΣⱼ ⊢A ok)
opaque
unfolding Πs
inversion-Πs :
∇ » ε ⊢ Πs p q Δ A →
∇ » Δ ⊢ A
inversion-Πs {Δ = ε} ⊢A = ⊢A
inversion-Πs {Δ = _ ∙ _} ⊢A =
inversion-ΠΣ (inversion-Πs ⊢A) .proj₂ .proj₁
opaque
unfolding Πs lams
⊢lams :
Π-allowed p q or-empty Δ →
∇ » Δ ⊢ t ∷ A →
∇ » ε ⊢ lams p Δ t ∷ Πs p q Δ A
⊢lams {Δ = ε} _ ⊢t = ⊢t
⊢lams {Δ = _ ∙ _} (possibly-nonempty ⦃ ok ⦄) ⊢t =
⊢lams possibly-nonempty (lamⱼ′ ok ⊢t)
opaque
unfolding Πs apps
⊢apps :
Π-allowed p q or-empty Δ →
∇ » ε ⊢ t ∷ Πs p q Δ A →
∇ » Δ ⊢ apps p Δ t ∷ A
⊢apps {Δ = ε} _ ⊢t = ⊢t
⊢apps {Δ = _ ∙ _} possibly-nonempty ⊢t =
let ⊢A , _ = inversion-ΠΣ (inversion-Πs (wf-⊢∷ ⊢t)) in
PE.subst (_⊢_∷_ _ _) (wkSingleSubstId _) $
wkTerm₁ ⊢A (⊢apps possibly-nonempty ⊢t) ∘ⱼ var₀ ⊢A
opaque
unfolding ΠΣʰ lamʰ
⊢lamʰ :
Π-allowed p q →
Γ ⊢ l₁ ∷Level →
Γ ⊢ l₂ ∷Level →
Γ »∙ A ⊢ t ∷ B →
Γ ⊢ lamʰ p t ∷ Πʰ p q l₁ l₂ A B
⊢lamʰ ok ⊢l₁ ⊢l₂ ⊢t =
let ⊢A = ⊢∙→⊢ (wfTerm ⊢t) in
lamⱼ′ ok (liftⱼ′ (wkLevel₁ (Liftⱼ ⊢l₂ ⊢A) ⊢l₁) (lower₀Term ⊢l₂ ⊢t))
opaque
unfolding ΠΣʰ ∘ʰ
app-congʰ :
Γ »∙ A ⊢ B →
Γ ⊢ t₁ ≡ t₂ ∷ Πʰ p q l₁ l₂ A B →
Γ ⊢ u₁ ≡ u₂ ∷ A →
Γ ⊢ ∘ʰ p t₁ u₁ ≡ ∘ʰ p t₂ u₂ ∷ B [ u₁ ]₀
app-congʰ ⊢B t₁≡t₂ u₁≡u₂ =
let ⊢A , ⊢u₁ , ⊢u₂ = wf-⊢≡∷ u₁≡u₂
_ , ⊢l₂ , _ = inversion-ΠΣʰ-⊢ (wf-⊢≡∷ t₁≡t₂ .proj₁)
in
conv (lower-cong (app-cong t₁≡t₂ (lift-cong ⊢l₂ u₁≡u₂)))
(lower₀[lift]₀ ⊢B ⊢u₁)
opaque
⊢∘ʰ :
Γ »∙ A ⊢ B →
Γ ⊢ t ∷ Πʰ p q l₁ l₂ A B →
Γ ⊢ u ∷ A →
Γ ⊢ ∘ʰ p t u ∷ B [ u ]₀
⊢∘ʰ ⊢B ⊢t ⊢u =
wf-⊢≡∷ (app-congʰ ⊢B (refl ⊢t) (refl ⊢u)) .proj₂ .proj₁
opaque
unfolding lamʰ ∘ʰ
β-redʰ :
Γ »∙ A ⊢ t ∷ B →
Γ ⊢ u ∷ A →
Π-allowed p q →
Γ ⊢ ∘ʰ p (lamʰ p t) u ≡ t [ u ]₀ ∷ B [ u ]₀
β-redʰ {t} {u} {p} ⊢t ⊢u ok =
let ⊢0 = ⊢zeroᵘ (wfTerm ⊢u)
⊢wk-l₁ = wkLevel₁ (Liftⱼ ⊢0 (wf-⊢∷ ⊢u)) ⊢0
⊢lift-u = liftⱼ′ ⊢0 ⊢u
in
∘ʰ p (lamʰ p t) u ≡⟨⟩⊢
lower (lam p (lift (lower₀ t)) ∘⟨ p ⟩ lift u) ≡⟨ lower-cong $
_⊢_≡_∷_.conv (β-red-≡ (liftⱼ′ ⊢wk-l₁ (lower₀Term ⊢0 ⊢t)) ⊢lift-u ok) $
Lift-cong (refl-⊢≡∷L (substLevel ⊢wk-l₁ ⊢lift-u)) (lower₀[lift]₀ (wf-⊢∷ ⊢t) ⊢u) ⟩⊢
lower (lift (lower₀ t) [ lift u ]₀) ≡⟨ lower-cong (lift-cong ⊢0 (lower₀[lift]₀∷ ⊢t ⊢u)) ⟩⊢
lower (lift (t [ u ]₀)) ⇒⟨ Lift-β⇒ (substTerm ⊢t ⊢u) ⟩⊢∎
t [ u ]₀ ∎
opaque
unfolding ΠΣʰ ∘ʰ lower₀
η-eqʰ :
Γ ⊢ t ∷ Πʰ p q l₁ l₂ A B →
Γ ⊢ u ∷ Πʰ p q l₁ l₂ A B →
Γ »∙ A ⊢ ∘ʰ p (wk1 t) (var x0) ≡ ∘ʰ p (wk1 u) (var x0) ∷ B →
Γ ⊢ t ≡ u ∷ Πʰ p q l₁ l₂ A B
η-eqʰ {Γ} {t} {p} {q} {l₁} {l₂} {A} {B} {u} ⊢t ⊢u t≡u =
let _ , ⊢l₂ , _ = inversion-ΠΣʰ-⊢ {B = B} (wf-⊢∷ ⊢t)
⊢B , _ = wf-⊢≡∷ t≡u
⊢Lift-A = Liftⱼ ⊢l₂ (⊢∙→⊢ (wf ⊢B))
⊢0 = var₀ ⊢Lift-A
lemma :
Γ ⊢ v ∷ Πʰ p q l₁ l₂ A B →
Γ »∙ Lift l₂ A ⊢ lower₀ (lower (wk1 v ∘⟨ p ⟩ lift (var x0))) ≡
lower (wk1 v ∘⟨ p ⟩ var x0) ∷ lower₀ B
lemma ⊢t =
conv
(lower-cong $
app-cong
(PE.subst₃ (_⊢_≡_∷_ _)
(PE.sym (wk1-[][]↑ 1)) PE.refl PE.refl
(refl (wkTerm₁ ⊢Lift-A ⊢t)))
(sym′ (Lift-η-swap ⊢0 (refl (lowerⱼ ⊢0)))))
(PE.subst (_⊢_≡_ _ _) (wkSingleSubstId _) $
substTypeEq
(_⊢_≡_.refl $
W.wk (liftʷ (step id) (wk₁ ⊢Lift-A ⊢Lift-A)) $
lower₀Type ⊢l₂ ⊢B)
(sym′ (Lift-η-swap ⊢0 (refl (lowerⱼ ⊢0)))))
in
η-eq′ ⊢t ⊢u $
Lift-η′
(PE.subst (_⊢_∷_ _ _) (wkSingleSubstId _) $
wkTerm₁ ⊢Lift-A ⊢t ∘ⱼ ⊢0)
(PE.subst (_⊢_∷_ _ _) (wkSingleSubstId _) $
wkTerm₁ ⊢Lift-A ⊢u ∘ⱼ ⊢0)
(lower (wk1 t ∘⟨ p ⟩ var x0) ≡˘⟨ lemma ⊢t ⟩⊢
lower₀ (lower (wk1 t ∘⟨ p ⟩ lift (var x0))) ≡⟨ lower₀TermEq ⊢l₂ t≡u ⟩⊢
lower₀ (lower (wk1 u ∘⟨ p ⟩ lift (var x0))) ≡⟨ lemma ⊢u ⟩⊢∎
lower (wk1 u ∘⟨ p ⟩ var x0) ∎)