{-# OPTIONS --without-K --safe #-}

module Definition.Typed.Weakening where

open import Definition.Untyped as U hiding (wk)
open import Definition.Untyped.Properties
open import Definition.Typed

import Tools.PropositionalEquality as PE

-- Weakening type

data _∷_⊆_ : Wk → Con Term → Con Term → Set where
  id   : ∀ {Γ}       → id ∷ Γ ⊆ Γ
  step : ∀ {Γ Δ A ρ} → ρ  ∷ Δ ⊆ Γ → step ρ ∷ Δ ∙ A        ⊆ Γ
  lift : ∀ {Γ Δ A ρ} → ρ  ∷ Δ ⊆ Γ → lift ρ ∷ Δ ∙ U.wk ρ A ⊆ Γ ∙ A

-- -- Weakening composition

_•ₜ_ : ∀ {ρ ρ′ Γ Δ Δ′} → ρ ∷ Γ ⊆ Δ → ρ′ ∷ Δ ⊆ Δ′ → ρ • ρ′ ∷ Γ ⊆ Δ′
id     •ₜ η′ = η′
step η •ₜ η′ = step (η •ₜ η′)
lift η •ₜ id = lift η
lift η •ₜ step η′ = step (η •ₜ η′)
_•ₜ_ {lift ρ} {lift ρ′} {Δ′ = Δ′ ∙ A} (lift η) (lift η′) =
  PE.subst (λ x → lift (ρ • ρ′) ∷ x ⊆ Δ′ ∙ A)
           (PE.cong₂ _∙_ PE.refl (PE.sym (wk-comp ρ ρ′ A)))
           (lift (η •ₜ η′))

-- Weakening of judgements

wkIndex : ∀ {Γ Δ n A ρ} → ρ ∷ Δ ⊆ Γ →
        let ρA = U.wk ρ A
            ρn = wkVar ρ n
        in  ⊢ Δ → n ∷ A ∈ Γ → ρn ∷ ρA ∈ Δ
wkIndex id ⊢Δ i = PE.subst (λ x → _ ∷ x ∈ _) (PE.sym (wk-id _)) i
wkIndex (step ρ) (⊢Δ ∙ A) i = PE.subst (λ x → _ ∷ x ∈ _)
                                       (wk1-wk _ _)
                                       (there (wkIndex ρ ⊢Δ i))
wkIndex (lift ρ) (⊢Δ ∙ A) (there i) = PE.subst (λ x → _ ∷ x ∈ _)
                                               (wk1-wk≡lift-wk1 _ _)
                                               (there (wkIndex ρ ⊢Δ i))
wkIndex (lift ρ) ⊢Δ here =
  let G = _
      n = _
  in  PE.subst (λ x → n ∷ x ∈ G)
               (wk1-wk≡lift-wk1 _ _)
               here

mutual
  wk : ∀ {Γ Δ A ρ} → ρ ∷ Δ ⊆ Γ →
     let ρA = U.wk ρ A
     in  ⊢ Δ → Γ ⊢ A → Δ ⊢ ρA
  wk ρ ⊢Δ (ℕⱼ ⊢Γ) = ℕⱼ ⊢Δ
  wk ρ ⊢Δ (Uⱼ ⊢Γ) = Uⱼ ⊢Δ
  wk ρ ⊢Δ (Πⱼ F ▹ G) = let ρF = wk ρ ⊢Δ F
                       in  Πⱼ ρF ▹ (wk (lift ρ) (⊢Δ ∙ ρF) G)
  wk ρ ⊢Δ (univ A) = univ (wkTerm ρ ⊢Δ A)

  wkTerm : ∀ {Γ Δ A t ρ} → ρ ∷ Δ ⊆ Γ →
         let ρA = U.wk ρ A
             ρt = U.wk ρ t
         in ⊢ Δ → Γ ⊢ t ∷ A → Δ ⊢ ρt ∷ ρA
  wkTerm ρ ⊢Δ (ℕⱼ ⊢Γ) = ℕⱼ ⊢Δ
  wkTerm ρ ⊢Δ (Πⱼ F ▹ G) = let ρF = wkTerm ρ ⊢Δ F
                          in  Πⱼ ρF ▹ (wkTerm (lift ρ) (⊢Δ ∙ univ ρF) G)
  wkTerm ρ ⊢Δ (var ⊢Γ x) = var ⊢Δ (wkIndex ρ ⊢Δ x)
  wkTerm ρ ⊢Δ (lamⱼ F t) = let ρF = wk ρ ⊢Δ F
                          in lamⱼ ρF (wkTerm (lift ρ) (⊢Δ ∙ ρF) t)
  wkTerm ρ ⊢Δ (_∘ⱼ_ {G = G} g a) = PE.subst (λ x → _ ⊢ _ ∷ x)
                                           (PE.sym (wk-β G))
                                           (wkTerm ρ ⊢Δ g ∘ⱼ wkTerm ρ ⊢Δ a)
  wkTerm ρ ⊢Δ (zeroⱼ ⊢Γ) = zeroⱼ ⊢Δ
  wkTerm ρ ⊢Δ (sucⱼ n) = sucⱼ (wkTerm ρ ⊢Δ n)
  wkTerm {Δ = Δ} {ρ = ρ} [ρ] ⊢Δ (natrecⱼ {G = G} {s = s} ⊢G ⊢z ⊢s ⊢n) =
    PE.subst (λ x → _ ⊢ natrec _ _ _ _ ∷ x) (PE.sym (wk-β G))
             (natrecⱼ (wk (lift [ρ]) (⊢Δ ∙ ℕⱼ ⊢Δ) ⊢G)
                      (PE.subst (λ x → _ ⊢ _ ∷ x) (wk-β G) (wkTerm [ρ] ⊢Δ ⊢z))
                      (PE.subst (λ x → Δ ⊢ U.wk ρ s ∷ x)
                                (wk-β-natrec ρ G)
                                (wkTerm [ρ] ⊢Δ ⊢s))
                      (wkTerm [ρ] ⊢Δ ⊢n))
  wkTerm ρ ⊢Δ (conv t A≡B) = conv (wkTerm ρ ⊢Δ t) (wkEq ρ ⊢Δ A≡B)

  wkEq : ∀ {Γ Δ A B ρ} → ρ ∷ Δ ⊆ Γ →
       let ρA = U.wk ρ A
           ρB = U.wk ρ B
       in ⊢ Δ → Γ ⊢ A ≡ B → Δ ⊢ ρA ≡ ρB
  wkEq ρ ⊢Δ (univ A≡B) = univ (wkEqTerm ρ ⊢Δ A≡B)
  wkEq ρ ⊢Δ (refl A) = refl (wk ρ ⊢Δ A)
  wkEq ρ ⊢Δ (sym A≡B) = sym (wkEq ρ ⊢Δ A≡B)
  wkEq ρ ⊢Δ (trans A≡B B≡C) = trans (wkEq ρ ⊢Δ A≡B) (wkEq ρ ⊢Δ B≡C)
  wkEq ρ ⊢Δ (Π-cong F F≡H G≡E) = let ρF = wk ρ ⊢Δ F
                                 in  Π-cong ρF (wkEq ρ ⊢Δ F≡H)
                                               (wkEq (lift ρ) (⊢Δ ∙ ρF) G≡E)

  wkEqTerm : ∀ {Γ Δ A t u ρ} → ρ ∷ Δ ⊆ Γ →
           let ρA = U.wk ρ A
               ρt = U.wk ρ t
               ρu = U.wk ρ u
           in ⊢ Δ → Γ ⊢ t ≡ u ∷ A → Δ ⊢ ρt ≡ ρu ∷ ρA
  wkEqTerm ρ ⊢Δ (refl t) = refl (wkTerm ρ ⊢Δ t)
  wkEqTerm ρ ⊢Δ (sym t≡u) = sym (wkEqTerm ρ ⊢Δ t≡u)
  wkEqTerm ρ ⊢Δ (trans t≡u u≡r) = trans (wkEqTerm ρ ⊢Δ t≡u) (wkEqTerm ρ ⊢Δ u≡r)
  wkEqTerm ρ ⊢Δ (conv t≡u A≡B) = conv (wkEqTerm ρ ⊢Δ t≡u) (wkEq ρ ⊢Δ A≡B)
  wkEqTerm ρ ⊢Δ (Π-cong F F≡H G≡E) =
    let ρF = wk ρ ⊢Δ F
    in  Π-cong ρF (wkEqTerm ρ ⊢Δ F≡H)
                  (wkEqTerm (lift ρ) (⊢Δ ∙ ρF) G≡E)
  wkEqTerm ρ ⊢Δ (app-cong {G = G} f≡g a≡b) =
    PE.subst (λ x → _ ⊢ _ ≡ _ ∷ x)
             (PE.sym (wk-β G))
             (app-cong (wkEqTerm ρ ⊢Δ f≡g) (wkEqTerm ρ ⊢Δ a≡b))
  wkEqTerm ρ ⊢Δ (β-red {a = a} {t = t} {G = G} F ⊢t ⊢a) =
    let ρF = wk ρ ⊢Δ F
    in  PE.subst (λ x → _ ⊢ _ ≡ _ ∷ x)
                 (PE.sym (wk-β G))
                 (PE.subst (λ x → _ ⊢ U.wk _ ((lam t) ∘ a) ≡ x ∷ _)
                           (PE.sym (wk-β t))
                           (β-red ρF (wkTerm (lift ρ) (⊢Δ ∙ ρF) ⊢t)
                                     (wkTerm ρ ⊢Δ ⊢a)))
  wkEqTerm ρ ⊢Δ (η-eq F f g f0≡g0) =
    let ρF = wk ρ ⊢Δ F
    in  η-eq ρF (wkTerm ρ ⊢Δ f)
                (wkTerm ρ ⊢Δ g)
                (PE.subst (λ t → _ ⊢ t ∘ _ ≡ _ ∷ _)
                          (PE.sym (wk1-wk≡lift-wk1 _ _))
                          (PE.subst (λ t → _ ⊢ _ ≡ t ∘ _ ∷ _)
                                    (PE.sym (wk1-wk≡lift-wk1 _ _))
                                    (wkEqTerm (lift ρ) (⊢Δ ∙ ρF) f0≡g0)))
  wkEqTerm ρ ⊢Δ (suc-cong m≡n) = suc-cong (wkEqTerm ρ ⊢Δ m≡n)
  wkEqTerm {Δ = Δ} {ρ = ρ} [ρ] ⊢Δ (natrec-cong {s = s} {s′ = s′} {F = F}
                                     F≡F′ z≡z′ s≡s′ n≡n′) =
    PE.subst (λ x → Δ ⊢ natrec _ _ _ _ ≡ _ ∷ x) (PE.sym (wk-β F))
             (natrec-cong (wkEq (lift [ρ]) (⊢Δ ∙ ℕⱼ ⊢Δ) F≡F′)
                          (PE.subst (λ x → Δ ⊢ _ ≡ _ ∷ x) (wk-β F)
                                    (wkEqTerm [ρ] ⊢Δ z≡z′))
                          (PE.subst (λ x → Δ ⊢ U.wk ρ s
                                             ≡ U.wk ρ s′ ∷ x)
                                    (wk-β-natrec _ F)
                                    (wkEqTerm [ρ] ⊢Δ s≡s′))
                          (wkEqTerm [ρ] ⊢Δ n≡n′))
  wkEqTerm {Δ = Δ} {ρ = ρ} [ρ] ⊢Δ (natrec-zero {z} {s} {F} ⊢F ⊢z ⊢s) =
    PE.subst (λ x → Δ ⊢ natrec (U.wk (lift _) F) _ _ _ ≡ _ ∷ x)
             (PE.sym (wk-β F))
             (natrec-zero (wk (lift [ρ]) (⊢Δ ∙ ℕⱼ ⊢Δ) ⊢F)
                          (PE.subst (λ x → Δ ⊢ U.wk ρ z ∷ x)
                                    (wk-β F)
                                    (wkTerm [ρ] ⊢Δ ⊢z))
                          (PE.subst (λ x → Δ ⊢ U.wk ρ s ∷ x)
                                    (wk-β-natrec _ F)
                                    (wkTerm [ρ] ⊢Δ ⊢s)))
  wkEqTerm {Δ = Δ} {ρ = ρ} [ρ] ⊢Δ (natrec-suc {n} {z} {s} {F} ⊢n ⊢F ⊢z ⊢s) =
    PE.subst (λ x → Δ ⊢ natrec (U.wk (lift _) F) _ _ _
                      ≡ _ ∘ (natrec _ _ _ _) ∷ x)
             (PE.sym (wk-β F))
             (natrec-suc (wkTerm [ρ] ⊢Δ ⊢n)
                         (wk (lift [ρ]) (⊢Δ ∙ ℕⱼ ⊢Δ) ⊢F)
                         (PE.subst (λ x → Δ ⊢ U.wk ρ z ∷ x)
                                   (wk-β F)
                                   (wkTerm [ρ] ⊢Δ ⊢z))
                         (PE.subst (λ x → Δ ⊢ U.wk ρ s ∷ x)
                                   (wk-β-natrec _ F)
                                   (wkTerm [ρ] ⊢Δ ⊢s)))

mutual
  wkRed : ∀ {Γ Δ A B ρ} → ρ ∷ Δ ⊆ Γ →
           let ρA = U.wk ρ A
               ρB = U.wk ρ B
           in ⊢ Δ → Γ ⊢ A ⇒ B → Δ ⊢ ρA ⇒ ρB
  wkRed ρ ⊢Δ (univ A⇒B) = univ (wkRedTerm ρ ⊢Δ A⇒B)

  wkRedTerm : ∀ {Γ Δ A t u ρ} → ρ ∷ Δ ⊆ Γ →
           let ρA = U.wk ρ A
               ρt = U.wk ρ t
               ρu = U.wk ρ u
           in ⊢ Δ → Γ ⊢ t ⇒ u ∷ A → Δ ⊢ ρt ⇒ ρu ∷ ρA
  wkRedTerm ρ ⊢Δ (conv t⇒u A≡B) = conv (wkRedTerm ρ ⊢Δ t⇒u) (wkEq ρ ⊢Δ A≡B)
  wkRedTerm ρ ⊢Δ (app-subst {B = B} t⇒u a) =
    PE.subst (λ x → _ ⊢ _ ⇒ _ ∷ x) (PE.sym (wk-β B))
             (app-subst (wkRedTerm ρ ⊢Δ t⇒u) (wkTerm ρ ⊢Δ a))
  wkRedTerm ρ ⊢Δ (β-red {A} {B} {a} {t} ⊢A ⊢t ⊢a) =
    let ⊢ρA = wk ρ ⊢Δ ⊢A
    in  PE.subst (λ x → _ ⊢ _ ⇒ _ ∷ x) (PE.sym (wk-β B))
                 (PE.subst (λ x → _ ⊢ U.wk _ ((lam t) ∘ a) ⇒ x ∷ _)
                           (PE.sym (wk-β t))
                           (β-red ⊢ρA (wkTerm (lift ρ) (⊢Δ ∙ ⊢ρA) ⊢t)
                                      (wkTerm ρ ⊢Δ ⊢a)))
  wkRedTerm {Δ = Δ} {ρ = ρ} [ρ] ⊢Δ (natrec-subst {s = s} {F = F} ⊢F ⊢z ⊢s n⇒n′) =
    PE.subst (λ x → _ ⊢ natrec _ _ _ _ ⇒ _ ∷ x) (PE.sym (wk-β F))
             (natrec-subst (wk (lift [ρ]) (⊢Δ ∙ ℕⱼ ⊢Δ) ⊢F)
                           (PE.subst (λ x → _ ⊢ _ ∷ x) (wk-β F)
                                     (wkTerm [ρ] ⊢Δ ⊢z))
                           (PE.subst (λ x → Δ ⊢ U.wk ρ s ∷ x)
                                     (wk-β-natrec _ F)
                                     (wkTerm [ρ] ⊢Δ ⊢s))
                           (wkRedTerm [ρ] ⊢Δ n⇒n′))
  wkRedTerm {Δ = Δ} {ρ = ρ} [ρ] ⊢Δ (natrec-zero {s = s} {F = F} ⊢F ⊢z ⊢s) =
    PE.subst (λ x → _ ⊢ natrec (U.wk (lift ρ) F) _ _ _ ⇒ _ ∷ x)
             (PE.sym (wk-β F))
             (natrec-zero (wk (lift [ρ]) (⊢Δ ∙ ℕⱼ ⊢Δ) ⊢F)
                          (PE.subst (λ x → _ ⊢ _ ∷ x)
                                    (wk-β F)
                                    (wkTerm [ρ] ⊢Δ ⊢z))
                          (PE.subst (λ x → Δ ⊢ U.wk ρ s ∷ x)
                                    (wk-β-natrec ρ F)
                                    (wkTerm [ρ] ⊢Δ ⊢s)))
  wkRedTerm {Δ = Δ} {ρ = ρ} [ρ] ⊢Δ (natrec-suc {s = s} {F = F} ⊢n ⊢F ⊢z ⊢s) =
    PE.subst (λ x → _ ⊢ natrec _ _ _ _ ⇒ _ ∘ natrec _ _ _ _ ∷ x)
             (PE.sym (wk-β F))
             (natrec-suc (wkTerm [ρ] ⊢Δ ⊢n)
                         (wk (lift [ρ]) (⊢Δ ∙ ℕⱼ ⊢Δ) ⊢F)
                         (PE.subst (λ x → _ ⊢ _ ∷ x)
                                   (wk-β F)
                                   (wkTerm [ρ] ⊢Δ ⊢z))
                         (PE.subst (λ x → Δ ⊢ U.wk ρ s ∷ x)
                                   (wk-β-natrec ρ F)
                                   (wkTerm [ρ] ⊢Δ ⊢s)))

wkRed* : ∀ {Γ Δ A B ρ} → ρ ∷ Δ ⊆ Γ →
           let ρA = U.wk ρ A
               ρB = U.wk ρ B
           in ⊢ Δ → Γ ⊢ A ⇒* B → Δ ⊢ ρA ⇒* ρB
wkRed* ρ ⊢Δ (id A) = id (wk ρ ⊢Δ A)
wkRed* ρ ⊢Δ (A⇒A′ ⇨ A′⇒*B) = wkRed ρ ⊢Δ A⇒A′ ⇨ wkRed* ρ ⊢Δ A′⇒*B

wkRed*Term : ∀ {Γ Δ A t u ρ} → ρ ∷ Δ ⊆ Γ →
           let ρA = U.wk ρ A
               ρt = U.wk ρ t
               ρu = U.wk ρ u
           in ⊢ Δ → Γ ⊢ t ⇒* u ∷ A → Δ ⊢ ρt ⇒* ρu ∷ ρA
wkRed*Term ρ ⊢Δ (id t) = id (wkTerm ρ ⊢Δ t)
wkRed*Term ρ ⊢Δ (t⇒t′ ⇨ t′⇒*u) = wkRedTerm ρ ⊢Δ t⇒t′ ⇨ wkRed*Term ρ ⊢Δ t′⇒*u

wkRed:*: : ∀ {Γ Δ A B ρ} → ρ ∷ Δ ⊆ Γ →
         let ρA = U.wk ρ A
             ρB = U.wk ρ B
         in ⊢ Δ → Γ ⊢ A :⇒*: B → Δ ⊢ ρA :⇒*: ρB
wkRed:*: ρ ⊢Δ [ ⊢A , ⊢B , D ] = [ wk ρ ⊢Δ ⊢A , wk ρ ⊢Δ ⊢B , wkRed* ρ ⊢Δ D ]

wkRed:*:Term : ∀ {Γ Δ A t u ρ} → ρ ∷ Δ ⊆ Γ →
             let ρA = U.wk ρ A
                 ρt = U.wk ρ t
                 ρu = U.wk ρ u
             in ⊢ Δ → Γ ⊢ t :⇒*: u ∷ A → Δ ⊢ ρt :⇒*: ρu ∷ ρA
wkRed:*:Term ρ ⊢Δ [ ⊢t , ⊢u , d ] =
  [ wkTerm ρ ⊢Δ ⊢t , wkTerm ρ ⊢Δ ⊢u , wkRed*Term ρ ⊢Δ d ]


{-# OPTIONS --prop --show-irrelevant #-}

open import Agda.Builtin.Equality

postulate
  A : Set
  P : Prop
  f : P → A
  g : A → P

{-# TERMINATING #-}
loop : A → A
loop y = loop y

mutual
  X : A
  X = _

  test : ∀ y → X ≡ f (g (loop y))
  test y = refl

-- The occurs check should not try to normalize the argument `loop y`
-- because it only appears in an irrelevant context.


A : Set

B : Set₁
B = Set

C : Set


postulate
  R : Set → Set1
  r : {X : Set} {{ _ : R X }} → X → Set
  A : Set
  a : A

instance
  RI : R A
  -- RI = {!!} -- uncommenting lets instance resolution succeed

foo : r a


{-# OPTIONS --erased-cubical #-}

-- Modules that use --cubical can be imported when --erased-cubical is
-- used.

import Erased-cubical-Module-application.Cubical
module EC = Erased-cubical-Module-application.Cubical Set

-- However, definitions from such modules can only be used in erased
-- contexts.

_ : {A : Set} → A → EC.∥ A ∥
_ = EC.∣_∣


open import SOAS.Common
open import SOAS.Families.Core
open import Categories.Object.Initial
open import SOAS.Coalgebraic.Strength
import SOAS.Metatheory.MetaAlgebra

-- Traversals parametrised by a pointed coalgebra
module SOAS.Metatheory.Traversal {T : Set}
  (⅀F : Functor 𝔽amiliesₛ 𝔽amiliesₛ) (⅀:Str : Strength ⅀F)
  (𝔛 : Familyₛ) (open SOAS.Metatheory.MetaAlgebra ⅀F 𝔛)
  (𝕋:Init : Initial 𝕄etaAlgebras)
  where

open import SOAS.Context
open import SOAS.Variable
open import SOAS.Abstract.Hom
import SOAS.Abstract.Coalgebra as →□ ; open →□.Sorted
import SOAS.Abstract.Box as □ ; open □.Sorted

open import SOAS.Metatheory.Algebra ⅀F
open import SOAS.Metatheory.Semantics ⅀F ⅀:Str 𝔛 𝕋:Init

open Strength ⅀:Str

private
  variable
    Γ Δ Θ Π : Ctx
    α β : T
    𝒫 𝒬 𝒜 : Familyₛ

-- Parametrised interpretation into an internal hom
module Traversal (𝒫ᴮ : Coalgₚ 𝒫)(𝑎𝑙𝑔 : ⅀ 𝒜 ⇾̣ 𝒜)
                 (φ : 𝒫 ⇾̣ 𝒜)(χ : 𝔛 ⇾̣ 〖 𝒜 , 𝒜 〗) where

  open Coalgₚ 𝒫ᴮ

  -- Under the assumptions 𝒜 and 〖 𝒫 , 𝒜 〗 are both meta-algebras
  𝒜ᵃ : MetaAlg 𝒜
  𝒜ᵃ = record { 𝑎𝑙𝑔 = 𝑎𝑙𝑔 ; 𝑣𝑎𝑟 = λ x → φ (η x) ; 𝑚𝑣𝑎𝑟 = χ }

  Travᵃ : MetaAlg 〖 𝒫 , 𝒜 〗
  Travᵃ = record
    { 𝑎𝑙𝑔  = λ t σ → 𝑎𝑙𝑔 (str 𝒫ᴮ 𝒜 t σ)
    ; 𝑣𝑎𝑟  = λ x σ → φ (σ x)
    ; 𝑚𝑣𝑎𝑟 = λ 𝔪 ε σ → χ 𝔪 (λ 𝔫 → ε 𝔫 σ)
    }

  -- 〖 𝒫 , 𝒜 〗 is also a pointed □-coalgebra
  Travᵇ : Coalg 〖 𝒫 , 𝒜 〗
  Travᵇ = record { r = λ h ρ σ → h (σ ∘ ρ) ; counit = refl ; comult = refl }

  Travᴮ : Coalgₚ 〖 𝒫 , 𝒜 〗
  Travᴮ = record { ᵇ = Travᵇ ; η = λ x σ → φ (σ x) ; r∘η = refl }

  open Semantics Travᵃ public renaming (𝕤𝕖𝕞 to 𝕥𝕣𝕒𝕧)

  -- Traversal-specific homomorphism properties that incorporate a substitution
  𝕥⟨𝕧⟩ : {σ : Γ ~[ 𝒫 ]↝ Δ}{x : ℐ α Γ} → 𝕥𝕣𝕒𝕧 (𝕧𝕒𝕣 x) σ ≡ φ (σ x)
  𝕥⟨𝕧⟩ {σ = σ} = cong (λ - → - σ) ⟨𝕧⟩

  𝕥⟨𝕞⟩ : {σ : Γ ~[ 𝒫 ]↝ Δ}{𝔪 : 𝔛 α Π}{ε : Π ~[ 𝕋 ]↝ Γ}
       → 𝕥𝕣𝕒𝕧 (𝕞𝕧𝕒𝕣 𝔪 ε) σ ≡ χ 𝔪 (λ p → 𝕥𝕣𝕒𝕧 (ε p) σ)
  𝕥⟨𝕞⟩ {σ = σ} = cong (λ - → - σ) ⟨𝕞⟩

  𝕥⟨𝕒⟩ : {σ : Γ ~[ 𝒫 ]↝ Δ}{t : ⅀ 𝕋 α Γ}
       → 𝕥𝕣𝕒𝕧 (𝕒𝕝𝕘 t) σ ≡ 𝑎𝑙𝑔 (str 𝒫ᴮ 𝒜 (⅀₁ 𝕥𝕣𝕒𝕧 t) σ)
  𝕥⟨𝕒⟩ {σ = σ} = cong (λ - → - σ) ⟨𝕒⟩

  -- Congruence in the two arguments of 𝕥𝕣𝕒𝕧
  𝕥≈₁ : {σ : Γ ~[ 𝒫 ]↝ Δ}{t₁ t₂ : 𝕋 α Γ} → t₁ ≡ t₂ → 𝕥𝕣𝕒𝕧 t₁ σ ≡ 𝕥𝕣𝕒𝕧 t₂ σ
  𝕥≈₁ {σ = σ} p = cong (λ - → 𝕥𝕣𝕒𝕧 - σ) p

  𝕥≈₂ : {σ₁ σ₂ : Γ ~[ 𝒫 ]↝ Δ}{t : 𝕋 α Γ}
      → ({τ : T}{x : ℐ τ Γ} → σ₁ x ≡ σ₂ x)
      → 𝕥𝕣𝕒𝕧 t σ₁ ≡ 𝕥𝕣𝕒𝕧 t σ₂
  𝕥≈₂ {t = t} p = cong (𝕥𝕣𝕒𝕧 t) (dext′ p)

-- A pointed meta-Λ-algebra induces 𝕒𝕝𝕘 traversal into □ 𝒜
module □Traversal {𝒜} (𝒜ᵃ : MetaAlg 𝒜) =
  Traversal ℐᴮ (MetaAlg.𝑎𝑙𝑔 𝒜ᵃ) (MetaAlg.𝑣𝑎𝑟 𝒜ᵃ) (MetaAlg.𝑚𝑣𝑎𝑟 𝒜ᵃ)

-- Corollary: □ lifts to an endofunctor on pointed meta-Λ-algebras
□ᵃ : (𝒜ᵃ : MetaAlg 𝒜) → MetaAlg (□ 𝒜)
□ᵃ = □Traversal.Travᵃ

-- Helper records for proving equality of maps f, g out of 𝕋,
-- with 0, 1 or 2 parameters
record MapEq₀ (𝒜 : Familyₛ)(f g : 𝕋 ⇾̣ 𝒜) : Set where
  field
    ᵃ : MetaAlg 𝒜
  open Semantics ᵃ
  open 𝒜

  field
    f⟨𝑣⟩ : {x : ℐ α Γ}
         → f (𝕧𝕒𝕣 x) ≡ 𝑣𝑎𝑟 x
    f⟨𝑚⟩ : {𝔪 : 𝔛 α Π}{ε : Π ~[ 𝕋 ]↝ Γ}
         → f (𝕞𝕧𝕒𝕣 𝔪 ε) ≡ 𝑚𝑣𝑎𝑟 𝔪 (f ∘ ε)
    f⟨𝑎⟩ : {t : ⅀ 𝕋 α Γ}
         → f (𝕒𝕝𝕘 t) ≡ 𝑎𝑙𝑔 (⅀₁ f t)
    g⟨𝑣⟩ : {x : ℐ α Γ}
         → g (𝕧𝕒𝕣 x) ≡ 𝑣𝑎𝑟 x
    g⟨𝑚⟩ : {𝔪 : 𝔛 α Π}{ε : Π ~[ 𝕋 ]↝ Γ}
         → g (𝕞𝕧𝕒𝕣 𝔪 ε) ≡ 𝑚𝑣𝑎𝑟 𝔪 (g ∘ ε)
    g⟨𝑎⟩ : {t : ⅀ 𝕋 α Γ}
         → g (𝕒𝕝𝕘 t) ≡ 𝑎𝑙𝑔 (⅀₁ g t)

  fᵃ : MetaAlg⇒ 𝕋ᵃ ᵃ f
  fᵃ = record { ⟨𝑎𝑙𝑔⟩ =  f⟨𝑎⟩ ; ⟨𝑣𝑎𝑟⟩ =  f⟨𝑣⟩ ; ⟨𝑚𝑣𝑎𝑟⟩ =  f⟨𝑚⟩ }
  gᵃ : MetaAlg⇒ 𝕋ᵃ ᵃ g
  gᵃ = record { ⟨𝑎𝑙𝑔⟩ =  g⟨𝑎⟩ ; ⟨𝑣𝑎𝑟⟩ =  g⟨𝑣⟩ ; ⟨𝑚𝑣𝑎𝑟⟩ =  g⟨𝑚⟩ }

  ≈ : (t : 𝕋 α Γ) → f t ≡ g t
  ≈ t = eq fᵃ gᵃ t

record MapEq₁ (𝒫ᴮ : Coalgₚ 𝒫)(𝑎𝑙𝑔 : ⅀ 𝒜 ⇾̣ 𝒜)
              (f g : 𝕋 ⇾̣ 〖 𝒫 , 𝒜 〗) : Set where
  field
    φ : 𝒫 ⇾̣ 𝒜
    χ : 𝔛 ⇾̣ 〖 𝒜 , 𝒜 〗

  open Traversal 𝒫ᴮ 𝑎𝑙𝑔 φ χ

  field
    f⟨𝑣⟩ : {σ : Γ ~[ 𝒫 ]↝ Δ}{x : ℐ α Γ}
         → f (𝕧𝕒𝕣 x) σ ≡ φ (σ x)
    f⟨𝑚⟩ : {σ : Γ ~[ 𝒫 ]↝ Δ}{𝔪 : 𝔛 α Π}{ε : Π ~[ 𝕋 ]↝ Γ}
         → f (𝕞𝕧𝕒𝕣 𝔪 ε) σ ≡ χ 𝔪 (λ p → f (ε p) σ)
    f⟨𝑎⟩ : {σ : Γ ~[ 𝒫 ]↝ Δ}{t : ⅀ 𝕋 α Γ}
         → f (𝕒𝕝𝕘 t) σ ≡ 𝑎𝑙𝑔 (str 𝒫ᴮ 𝒜 (⅀₁ f t) σ)
    g⟨𝑣⟩ : {σ : Γ ~[ 𝒫 ]↝ Δ}{x : ℐ α Γ}
         → g (𝕧𝕒𝕣 x) σ ≡ φ (σ x)
    g⟨𝑚⟩ : {σ : Γ ~[ 𝒫 ]↝ Δ}{𝔪 : 𝔛 α Π}{ε : Π ~[ 𝕋 ]↝ Γ}
         → g (𝕞𝕧𝕒𝕣 𝔪 ε) σ ≡ χ 𝔪 (λ p → g (ε p) σ)
    g⟨𝑎⟩ : {σ : Γ ~[ 𝒫 ]↝ Δ}{t : ⅀ 𝕋 α Γ}
         → g (𝕒𝕝𝕘 t) σ ≡ 𝑎𝑙𝑔 (str 𝒫ᴮ 𝒜 (⅀₁ g t) σ)

  fᵃ : MetaAlg⇒ 𝕋ᵃ Travᵃ f
  fᵃ = record { ⟨𝑎𝑙𝑔⟩ = dext′ f⟨𝑎⟩ ; ⟨𝑣𝑎𝑟⟩ = dext′ f⟨𝑣⟩ ; ⟨𝑚𝑣𝑎𝑟⟩ = dext′ f⟨𝑚⟩ }
  gᵃ : MetaAlg⇒ 𝕋ᵃ Travᵃ g
  gᵃ = record { ⟨𝑎𝑙𝑔⟩ = dext′ g⟨𝑎⟩ ; ⟨𝑣𝑎𝑟⟩ = dext′ g⟨𝑣⟩ ; ⟨𝑚𝑣𝑎𝑟⟩ = dext′ g⟨𝑚⟩ }

  ≈ : {σ : Γ ~[ 𝒫 ]↝ Δ}(t : 𝕋 α Γ) → f t σ ≡ g t σ
  ≈ {σ = σ} t = cong (λ - → - σ) (eq fᵃ gᵃ t)

record MapEq₂ (𝒫ᴮ : Coalgₚ 𝒫)(𝒬ᴮ : Coalgₚ 𝒬)(𝑎𝑙𝑔 : ⅀ 𝒜 ⇾̣ 𝒜)
                (f g : 𝕋 ⇾̣ 〖 𝒫 , 〖 𝒬 , 𝒜 〗 〗) : Set where
  field
    φ : 𝒬 ⇾̣ 𝒜
    ϕ : 𝒫 ⇾̣ 〖 𝒬 , 𝒜 〗
    χ : 𝔛 ⇾̣ 〖 𝒜 , 𝒜 〗

  open Traversal 𝒫ᴮ (Traversal.𝒜.𝑎𝑙𝑔 𝒬ᴮ 𝑎𝑙𝑔 φ χ) ϕ (λ 𝔪 ε σ → χ 𝔪 (λ 𝔫 → ε 𝔫 σ))

  field
    f⟨𝑣⟩ : {σ : Γ ~[ 𝒫 ]↝ Δ}{ς : Δ ~[ 𝒬 ]↝ Θ}{x : ℐ α Γ}
         → f (𝕧𝕒𝕣 x) σ ς ≡ ϕ (σ x) ς
    f⟨𝑚⟩ : {σ : Γ ~[ 𝒫 ]↝ Δ}{ς : Δ ~[ 𝒬 ]↝ Θ}{𝔪 : 𝔛 α Π}{ε : Π ~[ 𝕋 ]↝ Γ}
         → f (𝕞𝕧𝕒𝕣 𝔪 ε) σ ς ≡ χ 𝔪 (λ 𝔫 → f (ε 𝔫) σ ς)
    f⟨𝑎⟩ : {σ : Γ ~[ 𝒫 ]↝ Δ}{ς : Δ ~[ 𝒬 ]↝ Θ}{t : ⅀ 𝕋 α Γ}
         → f (𝕒𝕝𝕘 t) σ ς ≡ 𝑎𝑙𝑔 (str 𝒬ᴮ 𝒜 (str 𝒫ᴮ 〖 𝒬 , 𝒜 〗 (⅀₁ f t) σ) ς)
    g⟨𝑣⟩ : {σ : Γ ~[ 𝒫 ]↝ Δ}{ς : Δ ~[ 𝒬 ]↝ Θ}{x : ℐ α Γ}
         → g (𝕧𝕒𝕣 x) σ ς ≡ ϕ (σ x) ς
    g⟨𝑚⟩ : {σ : Γ ~[ 𝒫 ]↝ Δ}{ς : Δ ~[ 𝒬 ]↝ Θ}{𝔪 : 𝔛 α Π}{ε : Π ~[ 𝕋 ]↝ Γ}
         → g (𝕞𝕧𝕒𝕣 𝔪 ε) σ ς ≡ χ 𝔪 (λ 𝔫 → g (ε 𝔫) σ ς)
    g⟨𝑎⟩ : {σ : Γ ~[ 𝒫 ]↝ Δ}{ς : Δ ~[ 𝒬 ]↝ Θ}{t : ⅀ 𝕋 α Γ}
         → g (𝕒𝕝𝕘 t) σ ς ≡ 𝑎𝑙𝑔 (str 𝒬ᴮ 𝒜 (str 𝒫ᴮ 〖 𝒬 , 𝒜 〗 (⅀₁ g t) σ) ς)

  fᵃ : MetaAlg⇒ 𝕋ᵃ Travᵃ f
  fᵃ = record { ⟨𝑎𝑙𝑔⟩ = dext′ (dext′ f⟨𝑎⟩) ; ⟨𝑣𝑎𝑟⟩ = dext′ (dext′ f⟨𝑣⟩)
              ; ⟨𝑚𝑣𝑎𝑟⟩ = dext′ (dext′ f⟨𝑚⟩) }
  gᵃ : MetaAlg⇒ 𝕋ᵃ Travᵃ g
  gᵃ = record { ⟨𝑎𝑙𝑔⟩ = dext′ (dext′ g⟨𝑎⟩) ; ⟨𝑣𝑎𝑟⟩ = dext′ (dext′ g⟨𝑣⟩)
              ; ⟨𝑚𝑣𝑎𝑟⟩ = dext′ (dext′ g⟨𝑚⟩) }

  ≈ : {σ : Γ ~[ 𝒫 ]↝ Δ}{ς : Δ ~[ 𝒬 ]↝ Θ}(t : 𝕋 α Γ) → f t σ ς ≡ g t σ ς
  ≈ {σ = σ}{ς} t = cong (λ - → - σ ς) (eq fᵃ gᵃ t)

-- Interaction of traversal and interpretation
module _ (𝒫ᴮ : Coalgₚ 𝒫)(𝒜ᵃ : MetaAlg 𝒜)(φ : 𝒫 ⇾̣ 𝒜) where
  open MetaAlg 𝒜ᵃ
  open Coalgₚ 𝒫ᴮ
  open Semantics 𝒜ᵃ
  open Traversal 𝒫ᴮ 𝑎𝑙𝑔 φ 𝑚𝑣𝑎𝑟 using (𝕥𝕣𝕒𝕧 ; 𝕥⟨𝕒⟩ ; 𝕥⟨𝕧⟩ ; 𝕥⟨𝕞⟩)
  open ≡-Reasoning

  -- Traversal with the point of 𝒫 is the same as direct interpretation
  𝕥𝕣𝕒𝕧-η≈𝕤𝕖𝕞 : (φ∘η≈𝑣𝑎𝑟 : ∀{α Γ}{v : ℐ α Γ} → φ (η v) ≡ 𝑣𝑎𝑟 v){t : 𝕋 α Γ}
        → 𝕥𝕣𝕒𝕧 t η ≡ 𝕤𝕖𝕞 t
  𝕥𝕣𝕒𝕧-η≈𝕤𝕖𝕞 φ∘η≈𝑣𝑎𝑟 {t = t} = Semantics.eq 𝒜ᵃ (record
    { ⟨𝑎𝑙𝑔⟩ = λ{ {t = t} → trans 𝕥⟨𝕒⟩ (cong 𝑎𝑙𝑔 (begin
          str 𝒫ᴮ 𝒜 (⅀₁ 𝕥𝕣𝕒𝕧 t) η
      ≡⟨ str-nat₁ (ηᴮ⇒ 𝒫ᴮ) (⅀₁ 𝕥𝕣𝕒𝕧 t) id ⟩
          str ℐᴮ 𝒜 (⅀₁ (λ{ h ρ → h (η ∘ ρ)}) ((⅀₁ 𝕥𝕣𝕒𝕧 t))) id
      ≡⟨ str-unit 𝒜 ((⅀₁ (λ{ h ρ → h (η ∘ ρ)}) ((⅀₁ 𝕥𝕣𝕒𝕧 t)))) ⟩
          ⅀₁ (i 𝒜) (⅀₁ (λ { h ρ → h (η ∘ ρ) }) (⅀₁ 𝕥𝕣𝕒𝕧 t))
      ≡˘⟨ trans ⅀.homomorphism ⅀.homomorphism ⟩
          ⅀₁ (λ t → 𝕥𝕣𝕒𝕧 t η) t
      ∎))}
    ; ⟨𝑣𝑎𝑟⟩ = λ{ {v = v} → trans 𝕥⟨𝕧⟩ φ∘η≈𝑣𝑎𝑟 }
    ; ⟨𝑚𝑣𝑎𝑟⟩ = λ{ {𝔪}{ε} → 𝕥⟨𝕞⟩ } }) 𝕤𝕖𝕞ᵃ⇒ t

-- Traversal with the point of 𝒫 into 𝕋  is the identity
𝕥𝕣𝕒𝕧-η≈id : (𝒫ᴮ : Coalgₚ 𝒫)(open Coalgₚ 𝒫ᴮ)(φ : 𝒫 ⇾̣ 𝕋)
          (φ∘η≈𝑣𝑎𝑟 : ∀{α Γ}{v : ℐ α Γ} → φ (η v) ≡ 𝕧𝕒𝕣 v){t : 𝕋 α Γ}
         → Traversal.𝕥𝕣𝕒𝕧 𝒫ᴮ 𝕒𝕝𝕘 φ 𝕞𝕧𝕒𝕣 t η ≡ t
𝕥𝕣𝕒𝕧-η≈id 𝒫ᴮ φ φ∘η≈𝑣𝑎𝑟 = trans (𝕥𝕣𝕒𝕧-η≈𝕤𝕖𝕞 𝒫ᴮ 𝕋ᵃ φ φ∘η≈𝑣𝑎𝑟) 𝕤𝕖𝕞-id

-- Corollaries for ℐ-parametrised traversals
□𝕥𝕣𝕒𝕧-id≈𝕤𝕖𝕞 : (𝒜ᵃ : MetaAlg 𝒜){t : 𝕋 α Γ}
            → □Traversal.𝕥𝕣𝕒𝕧 𝒜ᵃ t id ≡ Semantics.𝕤𝕖𝕞 𝒜ᵃ t
□𝕥𝕣𝕒𝕧-id≈𝕤𝕖𝕞 𝒜ᵃ {t} = 𝕥𝕣𝕒𝕧-η≈𝕤𝕖𝕞 ℐᴮ 𝒜ᵃ (MetaAlg.𝑣𝑎𝑟 𝒜ᵃ) refl

□𝕥𝕣𝕒𝕧-id≈id : {t : 𝕋 α Γ} → □Traversal.𝕥𝕣𝕒𝕧 𝕋ᵃ t id ≡ t
□𝕥𝕣𝕒𝕧-id≈id = 𝕥𝕣𝕒𝕧-η≈id ℐᴮ 𝕧𝕒𝕣 refl


module DSyntax where

open import Data.List
open import Data.List.All
open import Data.Nat

open import Typing

data DExpr φ : Type → Set where
  var : ∀ {t}
      → (x : t ∈ φ)
      → DExpr φ t

  nat : (unr-φ : All Unr φ)
      → (i : ℕ)
      → DExpr φ TInt

  unit : (unr-φ : All Unr φ)
      → DExpr φ TUnit

  pair : ∀ {φ₁ φ₂ t₁ t₂}
    → (sp : Split φ φ₁ φ₂)
    → (e₁ : DExpr φ₁ t₁)
    → (e₂ : DExpr φ₂ t₂)
    → DExpr φ (TPair t₁ t₂)

  letpair : ∀ {φ₁ φ₂ t₁ t₂ t}
    → (sp : Split φ φ₁ φ₂)
    → (epair : DExpr φ₁ (TPair t₁ t₂))
    → (ebody : DExpr (t₁ ∷ t₂ ∷ φ₂) t)
    → DExpr φ t

  fork : (e : DExpr φ TUnit)
    → DExpr φ TUnit

  new : (unr-φ : All Unr φ)
      → (s : SType)
      → DExpr φ (TPair (TChan (SType.force s)) (TChan (SType.force (dual s))))

  send : ∀ {φ₁ φ₂ s t}
      → (sp : Split φ φ₁ φ₂)
      → (ech : DExpr φ₁ (TChan (send t s)))
      → (earg : DExpr φ₂ t)
      → DExpr φ (TChan (SType.force s))

  recv : ∀ {s t}
      → (ech : DExpr φ (TChan (recv t s)))
      → DExpr φ (TPair (TChan (SType.force s)) t)

  close : (ech : DExpr φ (TChan send!))
      → DExpr φ TUnit

  wait : (ech : DExpr φ (TChan send?))
      → DExpr φ TUnit

  select : ∀ {s₁ s₂}
      → (lab : Selector)
      → (ech : DExpr φ (TChan (sintern s₁ s₂)))
      → DExpr φ (TChan (selection lab (SType.force s₁) (SType.force s₂)))

  branch : ∀ {s₁ s₂ φ₁ φ₂ t}
      → (sp : Split φ φ₁ φ₂)
      → (ech : DExpr φ₁ (TChan (sextern s₁ s₂)))
      → (eleft : DExpr (TChan (SType.force s₁) ∷ φ₂) t)
      → (erght : DExpr (TChan (SType.force s₂) ∷ φ₂) t)
      → DExpr φ t

  ulambda : ∀ {t₁ t₂}
      → (unr-φ : All Unr φ)
      → (ebody : DExpr (t₁ ∷ φ) t₂)
      → DExpr φ (TFun UU t₁ t₂)

  llambda : ∀ {t₁ t₂}
      → (ebody : DExpr (t₁ ∷ φ) t₂)
      → DExpr φ (TFun LL t₁ t₂)

  app : ∀ {φ₁ φ₂ lu t₁ t₂}
      → (sp : Split φ φ₁ φ₂)
      → (efun : DExpr φ₁ (TFun lu t₁ t₂))
      → (earg : DExpr φ₂ t₁)
      → DExpr φ t₂

  subsume : ∀ {t₁ t₂}
      → (e : DExpr φ t₁)
      → (t≤t' : SubT t₁ t₂)
      → DExpr φ t₂


------------------------------------------------------------------------
-- Normalization/simplification of kinding in Fω with interval kinds
------------------------------------------------------------------------

{-# OPTIONS --safe --without-K #-}

module FOmegaInt.Kinding.Simple.Normalization where

open import Data.Fin using (Fin; zero; suc; raise; lift)
open import Data.Fin.Substitution using (module VarSubst)
open import Data.Fin.Substitution.Lemmas
open import Data.Fin.Substitution.ExtraLemmas
open import Data.List using ([]; _∷_; _∷ʳ_; map)
open import Data.Nat using (ℕ; zero; suc; _+_)
open import Data.Product as Prod using (_,_)
open import Data.Vec as Vec using ([]; _∷_)
import Data.Vec.Properties as VecProp
open import Function using (flip; _∘_)
open import Relation.Binary.PropositionalEquality hiding ([_])

open import FOmegaInt.Syntax
open import FOmegaInt.Syntax.SingleVariableSubstitution
  renaming (sub to hsub; _↑ to _H↑)
open import FOmegaInt.Syntax.HereditarySubstitution
open import FOmegaInt.Syntax.Normalization
open import FOmegaInt.Syntax.WeakEquality
open import FOmegaInt.Kinding.Simple as Simple
open import FOmegaInt.Kinding.Simple.EtaExpansion
open import FOmegaInt.Kinding.Declarative as Declarative

------------------------------------------------------------------------
-- Normalization/simplification of kinded types to simply kinded
-- types.
--
-- TODO: explain the point of this and how "simple" kinding differs
-- from "canonical" kinding.

open Syntax
open TermCtx
open SimpleCtx    using (kd; tp; ⌊_⌋Asc; kd-inj′)
open Substitution hiding (subst)
open ContextConversions
open RenamingCommutesNorm
open WeakHereditarySubstitutionEquality
open WeakEqEtaExpansion
open WeakEqNormalization
open KindedHereditarySubstitution
open Simple.Kinding
open Declarative.Kinding

private
  module S where
    open Simple.Kinding public
    open SimpleCtx      public
    open SimplyWfCtx    public
  module D where
    open Declarative.Kinding public
    open TermCtx             public
  module E = ElimCtx

mutual

  -- Normalization and simultaneous simplification of kinding:
  -- well-kinded types normalize to simply kinded normal forms.
  nf-Tp∈ : ∀ {n} {Γ : Ctx n} {a k} →
           let Γ′ = nfCtx Γ in Γ ⊢Tp a ∈ k → ⌊ Γ′ ⌋Ctx ⊢Nf nf Γ′ a ∈ ⌊ k ⌋
  nf-Tp∈ {_} {Γ} (∈-var {j} x Γ-ctx Γ[x]≡kd-k)
    with E.lookup (nfCtx Γ) x | nfCtx-lookup-kd x Γ Γ[x]≡kd-k
  nf-Tp∈ {_} {Γ} (∈-var {j} x Γ-ctx Γ[x]≡kd-j) | kd ._ | refl =
    subst (_ ⊢Nf η-exp (nfKind _ j) (var∙ x) ∈_) (⌊⌋-nf _)
          (η-exp-Var∈ (lookup-kd x (nf-ctx Γ-ctx) nf-Γ[x]≡kd-nf-j)
                      (∈-var x (⌊⌋-lookup (nfCtx Γ) x nf-Γ[x]≡kd-nf-j)))
    where
      open WfsCtxOps using (lookup-kd)
      nf-Γ[x]≡kd-nf-j = nfCtx-lookup-kd x Γ Γ[x]≡kd-j
  nf-Tp∈ (∈-var x Γ-ctx Γ[x]≡kd-k) | tp _  | ()
  nf-Tp∈ (∈-⊥-f Γ-ctx)    = ∈-⊥-f
  nf-Tp∈ (∈-⊤-f Γ-ctx)    = ∈-⊤-f
  nf-Tp∈ (∈-∀-f k-kd a∈*) = ∈-∀-f (nf-kd k-kd) (nf-Tp∈ a∈*)
  nf-Tp∈ (∈-→-f a∈* b∈*)  = ∈-→-f (nf-Tp∈ a∈*) (nf-Tp∈ b∈*)
  nf-Tp∈ (∈-Π-i {j} {a} j-kd a∈k k-kd) =
    let j′ = nfKind _ j
    in subst (λ l → _ ⊢Nf Λ∙ j′ (nf (kd j′ ∷ _) a) ∈ l ⇒ _) (⌊⌋-nf j)
             (∈-Π-i (nf-kd j-kd) (nf-Tp∈ a∈k))
  nf-Tp∈ (∈-Π-e {a} {b} a∈Πjk b∈j _ _) =
    subst (_ ⊢Nf nf _ a ↓⌜·⌝ nf _ b ∈_) (sym (⌊⌋-Kind/ _))
          (Nf∈-Π-e′ (nf-Tp∈ a∈Πjk) (nf-Tp∈ b∈j))
  nf-Tp∈ (∈-s-i a∈a⋯b)  = nf-Tp∈ a∈a⋯b
  nf-Tp∈ (∈-⇑ a∈j j<∷k) = subst (_ ⊢Nf _ ∈_) (<∷-⌊⌋ j<∷k) (nf-Tp∈ a∈j)

  -- Normalization and simultaneous simplification of kind
  -- well-formedness: well-formed kinds normalize to simply
  -- well-formed kinds.
  nf-kd : ∀ {n} {Γ : Ctx n} {k} →
          let Γ′ = nfCtx Γ in Γ ⊢ k kd → ⌊ Γ′ ⌋Ctx ⊢ nfKind Γ′ k kds
  nf-kd (kd-⋯ a∈* b∈*)   = kds-⋯ (nf-Tp∈ a∈*) (nf-Tp∈ b∈*)
  nf-kd (kd-Π j-kd k-kd) = kds-Π (nf-kd j-kd) (nf-kd k-kd)

  -- Normalization and simultaneous simplification of contexts:
  -- well-formed contexts normalize to simply well-formed simple
  -- contexts.

  nf-wf : ∀ {n} {Γ : Ctx n} {a} →
          let Γ′ = nfCtx Γ in Γ ⊢ a wf → ⌊ Γ′ ⌋Ctx ⊢ nfAsc Γ′ a wfs
  nf-wf (wf-kd k-kds) = wfs-kd (nf-kd k-kds)
  nf-wf (wf-tp a∈*)   = wfs-tp (nf-Tp∈ a∈*)

  nf-ctx : ∀ {n} {Γ : Ctx n} → Γ ctx → nfCtx Γ ctxs
  nf-ctx D.[]             = S.[]
  nf-ctx (a-wf D.∷ Γ-ctx) = nf-wf a-wf S.∷ nf-ctx Γ-ctx

-- Normal forms of type operators are η-long.
≈-η-nf : ∀ {n} {Γ : Ctx n} {a j k} → Γ ⊢Tp a ∈ Π j k →
         let nf-Γ = nfCtx Γ
         in nf nf-Γ (Λ j (weaken a · var zero)) ≈ nf nf-Γ a
≈-η-nf a∈Πjk with Nf∈-⇒-inv (nf-Tp∈ a∈Πjk)
≈-η-nf {_} {Γ} {a} {j} {k} a∈Πjk
  | l , b , l-kds , b∈⌊k⌋ , ⌊l⌋≡⌊j⌋ , nf-a≡Λlb =
  begin
    nf nf-Γ (Λ j (weaken a · var zero))
  ≈⟨ ≈-Λ∙ ⌊nf-j⌋≡⌊l⌋ (begin
        nf-a′ ↓⌜·⌝ η-exp (weakenKind′ nf-j) (var∙ zero)
      ≡⟨ cong (_↓⌜·⌝ η-exp (weakenKind′ nf-j) (var∙ zero))
              (trans (sym (nf-weaken (kd nf-j) a)) (cong weakenElim nf-a≡Λlb)) ⟩
        weakenElim (Λ∙ l b) ↓⌜·⌝ η-exp (weakenKind′ nf-j) (var∙ zero)
      ≡⟨⟩
        b Elim/Var (VarSubst.wk VarSubst.↑) /⟨ ⌊ weakenKind′ l ⌋ ⟩
          hsub (η-exp (weakenKind′ nf-j) (var∙ zero))
      ≈⟨ ≈-[∈] (≈-refl (b Elim/Var (VarSubst.wk VarSubst.↑)))
               (≈-η-exp ⌊nf-j/wk⌋≡⌊l/wk⌋ (≈-var∙ zero)) ⟩
        b Elim/Var (VarSubst.wk VarSubst.↑) /⟨ ⌊ weakenKind′ l ⌋ ⟩
          hsub (η-exp (weakenKind′ l) (var∙ zero))
      ≈⟨ Nf∈-[]-η-var [] l-kds
                      (subst (λ l → kd l ∷ _ ⊢Nf b ∈ _) (sym ⌊l⌋≡⌊j⌋) b∈⌊k⌋) ⟩
        b
      ∎) ⟩
    Λ∙ l b
  ≡⟨ sym nf-a≡Λlb ⟩
    nf nf-Γ a
  ∎
  where
    nf-Γ   = nfCtx Γ
    nf-j   = nfKind nf-Γ j
    nf-j∷Γ = kd nf-j ∷ nf-Γ
    nf-a′  = nf nf-j∷Γ (weaken a)
    ⌊nf-j⌋≡⌊l⌋ = begin
      ⌊ nf-j ⌋ ≡⟨ ⌊⌋-nf j ⟩
      ⌊ j ⌋    ≡⟨ sym ⌊l⌋≡⌊j⌋ ⟩
      ⌊ l ⌋    ∎
      where open ≡-Reasoning
    ⌊nf-j/wk⌋≡⌊l/wk⌋ = begin
      ⌊ weakenKind′ nf-j ⌋   ≡⟨ ⌊⌋-Kind′/Var nf-j ⟩
      ⌊ nf-j ⌋               ≡⟨ ⌊nf-j⌋≡⌊l⌋ ⟩
      ⌊ l ⌋                  ≡⟨ sym (⌊⌋-Kind′/Var l) ⟩
      ⌊ weakenKind′ l ⌋      ∎
      where open ≡-Reasoning
    open ≈-Reasoning

-- Well-kinded hereditary substitions.

infix 4 _⊢/Tp⟨_⟩_∈_

data _⊢/Tp⟨_⟩_∈_ : ∀ {m n} → Ctx n → SKind → SVSub m n → Ctx m → Set where
  ∈-hsub : ∀ {n} {Γ : Ctx n} {k a} →
           Γ ⊢Tp a ∈ k → Γ ⊢/Tp⟨ ⌊ k ⌋ ⟩ hsub ⌜ a ⌝ ∈ kd k ∷ Γ
  ∈-H↑   : ∀ {m n Δ k Γ} {σ : SVSub m n} {a} →
           Δ ⊢/Tp⟨ k ⟩ σ ∈ Γ → (a TermAsc/ toSub σ) ∷ Δ ⊢/Tp⟨ k ⟩ σ H↑ ∈ a ∷ Γ

-- Normalize and simplify a well-kinded hereditary substitution.

nf-/⟨⟩∈ : ∀ {m n k Δ} {σ : SVSub m n} {Γ} → Δ ⊢/Tp⟨ k ⟩ σ ∈ Γ →
          ⌊ nfCtx Δ ⌋Ctx ⊢/⟨ k ⟩ nfSVSub (nfCtx Δ) σ ∈ ⌊ nfCtx Γ ⌋Ctx
nf-/⟨⟩∈ (∈-hsub {Γ = Γ} {k} {a} a∈k) =
  subst₂ (⌊ nfCtx Γ ⌋Ctx ⊢/⟨ ⌊ k ⌋ ⟩_∈_)
         (cong (hsub ∘ nf (nfCtx Γ)) (sym (⌞⌟∘⌜⌝-id a)))
         (cong (λ j → kd j ∷ ⌊ nfCtx Γ ⌋Ctx) (sym (⌊⌋-nf k)))
         (∈-hsub (nf-Tp∈ a∈k))
nf-/⟨⟩∈ (∈-H↑ {Δ = Δ} {k} {Γ} {σ} {a} σ∈Γ) =
  subst (_⊢/⟨ k ⟩ nfSVSub (nfCtx (a/σ ∷ Δ)) (σ H↑) ∈ ⌊ nfCtx (a ∷ Γ) ⌋Ctx)
        (cong (_∷ ⌊ nfCtx Δ ⌋Ctx) (begin
          ⌊ nfAsc (nfCtx Γ) a ⌋Asc                     ≡⟨ ⌊⌋Asc-nf a ⟩
          ⌊ a ⌋Asc                                     ≡˘⟨ S.⌊⌋-TermAsc/ a ⟩
          ⌊ a TermAsc/ toSub σ ⌋Asc                    ≡˘⟨ ⌊⌋Asc-nf _ ⟩
          ⌊ nfAsc (nfCtx Δ) (a TermAsc/ toSub σ) ⌋Asc  ∎))
        (∈-H↑ (nf-/⟨⟩∈ σ∈Γ))
  where
    open ≡-Reasoning
    a/σ = a TermAsc/ toSub σ

open ≈-Reasoning
private module P = ≡-Reasoning

mutual

  -- Substitution (weakly) commutes with normalization.

  nf-/⟨⟩ : ∀ {m n Δ k Γ} {σ : SVSub m n} {a j} →
           Γ ⊢Tp a ∈ j → Δ ⊢/Tp⟨ k ⟩ σ ∈ Γ →
           nf (nfCtx Δ) (a / toSub σ)  ≈
             nf (nfCtx Γ) a /⟨ k ⟩ nfSVSub (nfCtx Δ) σ
  nf-/⟨⟩ {Γ = Γ} (∈-var x Γ-ctx Γ[x]≡kd-j) σ∈Γ
    with E.lookup (nfCtx Γ) x | nfCtx-lookup-kd x Γ Γ[x]≡kd-j
  nf-/⟨⟩ {Δ = Δ} {k} {Γ} {σ} {_} {j} (∈-var x Γ-ctx Γ[x]≡kd-j) σ∈Γ
    | kd nf-j | refl with hit? σ x
  ... | hit a hitP =
    let open WfsCtxOps using (lookup-kd)
        nf-Γ-ctxs       = nf-ctx Γ-ctx
        nf-Γ[x]≡kd-nf-j = nfCtx-lookup-kd x Γ Γ[x]≡kd-j
        nf-j-kds  = lookup-kd x nf-Γ-ctxs nf-Γ[x]≡kd-nf-j
        hitP-nf-σ = nf-Hit (nfCtx Δ) hitP
        x∈⌊j⌋     = ∈-var x (⌊⌋-lookup (nfCtx Γ) x nf-Γ[x]≡kd-nf-j)
    in begin
      nf (nfCtx Δ) (Vec.lookup (toSub σ) x)
    ≡⟨ cong (nf (nfCtx Δ)) (lookup-toSub σ x) ⟩
      nf (nfCtx Δ) (⌞ toElim (lookupSV σ x) ⌟)
    ≡⟨ cong (nf (nfCtx Δ) ∘ ⌞_⌟ ∘ toElim) (lookup-Hit hitP) ⟩
      nf (nfCtx Δ) ⌞ a ⌟
    ≡˘⟨ cong (_?∙∙⟨ k ⟩ []) (lookup-Hit hitP-nf-σ) ⟩
      var∙ x /⟨ k ⟩ nfSVSub (nfCtx Δ) σ
    ≈˘⟨ η-exp-var-Hit-/⟨⟩ hitP-nf-σ nf-j-kds x∈⌊j⌋ (nf-/⟨⟩∈ σ∈Γ) ⟩
      η-exp (nfKind (nfCtx Γ) j) (var∙ x) /⟨ k ⟩ nfSVSub (nfCtx Δ) σ
    ∎
  ... | miss y missP =
    let open WfsCtxOps using (lookup-kd)
        nf-Γ-ctxs       = nf-ctx Γ-ctx
        nf-Γ[x]≡kd-nf-j = nfCtx-lookup-kd x Γ Γ[x]≡kd-j
        nf-j-kds   = lookup-kd x nf-Γ-ctxs nf-Γ[x]≡kd-nf-j
        missP-nf-σ = nf-Miss (nfCtx Δ) missP
        x∈⌊j⌋      = ∈-var x (⌊⌋-lookup (nfCtx Γ) x nf-Γ[x]≡kd-nf-j)
    in begin
      nf (nfCtx Δ) (Vec.lookup (toSub σ) x)
    ≡⟨ cong (nf (nfCtx Δ)) (lookup-toSub σ x) ⟩
      nf (nfCtx Δ) ⌞ toElim (lookupSV σ x) ⌟
    ≡⟨ cong (nf (nfCtx Δ) ∘ ⌞_⌟ ∘ toElim) (lookup-Miss missP) ⟩
      nf (nfCtx Δ) (var y)
    ≈⟨ nf-var-kd-⌊⌋ (nfCtx Δ) y (P.begin
          ⌊ E.lookup (nfCtx Δ) y ⌋Asc
        P.≡˘⟨ ⌊⌋Asc-lookup (nfCtx Δ) y ⟩
          S.lookup ⌊ nfCtx Δ ⌋Ctx y
        P.≡⟨ lookup-/⟨⟩∈-Miss (nf-/⟨⟩∈ σ∈Γ) x∈⌊j⌋ missP-nf-σ  ⟩
          S.lookup ⌊ nfCtx Γ ⌋Ctx x
        P.≡⟨ ⌊⌋-lookup (nfCtx Γ) x nf-Γ[x]≡kd-nf-j ⟩
          kd ⌊ nfKind (nfCtx Γ) j ⌋
        P.≡˘⟨ cong kd (⌊⌋-Kind/⟨⟩ (nfKind (nfCtx Γ) j)) ⟩
          kd ⌊ nfKind (nfCtx Γ) j Kind/⟨ k ⟩ nfSVSub (nfCtx Δ) σ ⌋
        P.∎) ⟩
      η-exp (nfKind (nfCtx Γ) j Kind/⟨ k ⟩ nfSVSub (nfCtx Δ) σ) (var∙ y)
    ≡˘⟨ η-exp-ne-Miss-/⟨⟩ x y [] (nfKind (nfCtx Γ) j) missP-nf-σ ⟩
      η-exp (nfKind (nfCtx Γ) j) (var∙ x) /⟨ k ⟩ nfSVSub (nfCtx Δ) σ
    ∎
  nf-/⟨⟩ (∈-var _ _ _) σ∈Γ | tp a | ()
  nf-/⟨⟩ (∈-⊥-f Γ-ctx) σ∈Γ = ≈-refl _
  nf-/⟨⟩ (∈-⊤-f Γ-ctx) σ∈Γ = ≈-refl _
  nf-/⟨⟩ (∈-∀-f {j} j-kd a∈*) σ∈Γ =
    ≈-∀∙ (nfKind-/⟨⟩ j-kd σ∈Γ) (nf-/⟨⟩ a∈* (∈-H↑ σ∈Γ))
  nf-/⟨⟩ (∈-→-f a∈* b∈*) σ∈Γ =
    ≈-⇒∙ (nf-/⟨⟩ a∈* σ∈Γ) (nf-/⟨⟩ b∈* σ∈Γ)
  nf-/⟨⟩ (∈-Π-i j-kd a∈k k-kd) σ∈Γ =
    ≈-Λ∙ (≋-⌊⌋ (nfKind-/⟨⟩ j-kd σ∈Γ)) (nf-/⟨⟩ a∈k (∈-H↑ σ∈Γ))
  nf-/⟨⟩ {Δ = Δ} {k} {Γ} {σ} {a · b} (∈-Π-e a∈Πjk b∈j _ _) σ∈Γ = begin
      nf (nfCtx Δ) (a / toSub σ) ↓⌜·⌝ nf (nfCtx Δ) (b / toSub σ)
    ≈⟨ ≈-↓⌜·⌝ (nf-/⟨⟩ a∈Πjk σ∈Γ) (nf-/⟨⟩ b∈j σ∈Γ) ⟩
      (nf (nfCtx Γ) a /⟨ k ⟩ nfSVSub (nfCtx Δ) σ) ↓⌜·⌝
        (nf (nfCtx Γ) b /⟨ k ⟩ nfSVSub (nfCtx Δ) σ)
    ≡⟨ sym (Nf∈-Π-e-/⟨⟩′ (nf-Tp∈ a∈Πjk) (nf-Tp∈ b∈j) (nf-/⟨⟩∈ σ∈Γ)) ⟩
      nf (nfCtx Γ) a ↓⌜·⌝ nf (nfCtx Γ) b /⟨ k ⟩ nfSVSub (nfCtx Δ) σ
    ∎
  nf-/⟨⟩ (∈-s-i a∈c⋯d)  σ∈Γ = nf-/⟨⟩ a∈c⋯d σ∈Γ
  nf-/⟨⟩ (∈-⇑ a∈j j<∷k) σ∈Γ = nf-/⟨⟩ a∈j σ∈Γ

  nfKind-/⟨⟩ : ∀ {m n Δ k Γ} {σ : SVSub m n} {j} →
               Γ ⊢ j kd → Δ ⊢/Tp⟨ k ⟩ σ ∈ Γ →
               nfKind (nfCtx Δ) (j Kind/ toSub σ)  ≋
                 nfKind (nfCtx Γ) j Kind/⟨ k ⟩ nfSVSub (nfCtx Δ) σ
  nfKind-/⟨⟩ (kd-⋯ a∈* b∈*)   σ∈Γ = ≋-⋯ (nf-/⟨⟩ a∈* σ∈Γ) (nf-/⟨⟩ b∈* σ∈Γ)
  nfKind-/⟨⟩ (kd-Π j-kd k-kd) σ∈Γ =
    ≋-Π (nfKind-/⟨⟩ j-kd σ∈Γ) (nfKind-/⟨⟩ k-kd (∈-H↑ σ∈Γ))

-- Shorthands.

nf-[] : ∀ {n} {Γ : Ctx n} {k a j b} →
        kd k ∷ Γ ⊢Tp a ∈ j → Γ ⊢Tp b ∈ k →
        nf (nfCtx Γ) (a [ b ])  ≈
          nf (nfCtx (kd k ∷ Γ)) a [ nf (nfCtx Γ) b ∈ ⌊ k ⌋ ]
nf-[] {_} {Γ} {k} {a} a∈j b∈k =
  subst (λ c → nf (nfCtx Γ) (a [ c ]) ≈
               (nf (nfCtx (kd k ∷ Γ)) a [ nf (nfCtx Γ) c ∈ ⌊ k ⌋ ]))
        (⌞⌟∘⌜⌝-id _) (nf-/⟨⟩ a∈j (∈-hsub b∈k))

nfKind-[] : ∀ {n} {Γ : Ctx n} {k j b} →
            kd k ∷ Γ ⊢ j kd → Γ ⊢Tp b ∈ k →
            nfKind (nfCtx Γ) (j Kind[ b ])  ≋
              nfKind (nfCtx (kd k ∷ Γ)) j Kind[ nf (nfCtx Γ) b ∈ ⌊ k ⌋ ]
nfKind-[] {_} {Γ} {k} {j} j-kd b∈k =
  subst (λ c → nfKind (nfCtx Γ) (j Kind[ c ]) ≋
               (nfKind (nfCtx (kd k ∷ Γ)) j Kind[ nf (nfCtx Γ) c ∈ ⌊ k ⌋ ]))
        (⌞⌟∘⌜⌝-id _) (nfKind-/⟨⟩ j-kd (∈-hsub b∈k))


------------------------------------------------------------------------
-- Queue instances for the queues in Queue.Quotiented
------------------------------------------------------------------------

{-# OPTIONS --erased-cubical --safe #-}

import Equality.Path as P
open import Prelude
import Queue

module Queue.Quotiented.Instances
  {e⁺}
  (eq : ∀ {a p} → P.Equality-with-paths a p e⁺)
  (open P.Derived-definitions-and-properties eq)

  {Q : ∀ {ℓ} → Type ℓ → Type ℓ}
  ⦃ is-queue :
      ∀ {ℓ} → Queue.Is-queue equality-with-J Q (λ _ → ↑ _ ⊤) ℓ ⦄
  ⦃ is-queue-with-map :
      ∀ {ℓ₁ ℓ₂} → Queue.Is-queue-with-map equality-with-J Q ℓ₁ ℓ₂ ⦄
  where

open Queue equality-with-J
open import Queue.Quotiented eq as Q using (Queue)

open import Bijection equality-with-J using (_↔_)
open import H-level.Closure equality-with-J
open import List equality-with-J as L hiding (map)
open import Maybe equality-with-J
open import Monad equality-with-J hiding (map)

private
  variable
    a ℓ ℓ₁ ℓ₂ : Level
    A         : Type a
    xs        : List A

instance

  -- Instances.

  Queue-is-queue : Is-queue (Queue Q) Is-set ℓ
  Queue-is-queue .Is-queue.to-List           = Q.to-List
  Queue-is-queue .Is-queue.from-List         = Q.from-List
  Queue-is-queue .Is-queue.to-List-from-List = Q.to-List-from-List
  Queue-is-queue .Is-queue.enqueue           = Q.enqueue
  Queue-is-queue .Is-queue.to-List-enqueue   = Q.to-List-enqueue
  Queue-is-queue .Is-queue.dequeue           = Q.dequeue
  Queue-is-queue .Is-queue.to-List-dequeue   = Q.to-List-dequeue
  Queue-is-queue .Is-queue.dequeue⁻¹         = Q.dequeue⁻¹
  Queue-is-queue .Is-queue.to-List-dequeue⁻¹ = Q.to-List-dequeue⁻¹

  Queue-is-queue-with-map : Is-queue-with-map (Queue Q) ℓ₁ ℓ₂
  Queue-is-queue-with-map .Is-queue-with-map.map         = Q.map
  Queue-is-queue-with-map .Is-queue-with-map.to-List-map = Q.to-List-map

  Queue-is-queue-with-unique-representations :
    Is-queue-with-unique-representations (Queue Q) ℓ
  Queue-is-queue-with-unique-representations
    .Is-queue-with-unique-representations.from-List-to-List =
    Q.from-List-to-List _

------------------------------------------------------------------------
-- Some examples

private

  ⌊_⌋      = to-List (λ {_ _} → ℕ-set)
  dequeue′ = dequeue (λ {_ _} → ℕ-set)
  empty′   = empty ⦂ Queue Q ℕ

  example₁ : map suc (enqueue 3 empty) ≡ enqueue 4 empty′
  example₁ = _↔_.to ≡-for-lists↔≡ (
    ⌊ map suc (enqueue 3 empty) ⌋  ≡⟨ to-List-map ⟩
    L.map suc ⌊ enqueue 3 empty ⌋  ≡⟨ cong (L.map suc) $ to-List-foldl-enqueue-empty (_ ∷ []) ⟩
    L.map suc (3 ∷ [])             ≡⟨⟩
    4 ∷ []                         ≡⟨ sym $ to-List-foldl-enqueue-empty (_ ∷ []) ⟩∎
    ⌊ enqueue 4 empty ⌋            ∎)

  example₂ :
    dequeue′ (map (_* 2) (enqueue 3 (enqueue 5 empty))) ≡
    just (10 , enqueue 6 empty)
  example₂ =
    dequeue′ (map (_* 2) (enqueue 3 (enqueue 5 empty)))  ≡⟨ cong dequeue′ lemma ⟩
    dequeue′ (cons 10 (enqueue 6 empty))                 ≡⟨ _↔_.right-inverse-of (Queue↔Maybe[×Queue] _) _ ⟩∎
    just (10 , enqueue 6 empty)                          ∎
    where
    lemma = _↔_.to ≡-for-lists↔≡ (
      ⌊ map (_* 2) (enqueue 3 (enqueue 5 empty)) ⌋  ≡⟨ to-List-map ⟩
      L.map (_* 2) ⌊ enqueue 3 (enqueue 5 empty) ⌋  ≡⟨ cong (L.map (_* 2)) $ to-List-foldl-enqueue-empty (_ ∷ _ ∷ []) ⟩
      L.map (_* 2) (5 ∷ 3 ∷ [])                     ≡⟨⟩
      10 ∷ 6 ∷ []                                   ≡⟨ cong (10 ∷_) $ sym $ to-List-foldl-enqueue-empty (_ ∷ []) ⟩
      10 ∷ ⌊ enqueue 6 empty ⌋                      ≡⟨ sym $ to-List-cons ⟩∎
      ⌊ cons 10 (enqueue 6 empty) ⌋                 ∎)

  example₃ :
    (do x , q ← dequeue′ (map (_* 2) (enqueue 3 (enqueue 5 empty)))
        return (enqueue (3 * x) q)) ≡
    just (enqueue 30 (enqueue 6 empty))
  example₃ =
    (do x , q ← dequeue′ (map (_* 2) (enqueue 3 (enqueue 5 empty)))
        return (enqueue (3 * x) q))                                  ≡⟨ cong (_>>= λ _ → return (enqueue _ _)) example₂ ⟩

    (do x , q ← just (10 , enqueue 6 empty)
        return (enqueue (3 * x) (q ⦂ Queue Q ℕ)))                    ≡⟨⟩

    just (enqueue 30 (enqueue 6 empty))                              ∎

  example₄ :
    (do x , q ← dequeue′ (map (_* 2) (enqueue 3 (enqueue 5 empty)))
        let q = enqueue (3 * x) q
        return ⌊ q ⌋) ≡
    just (6 ∷ 30 ∷ [])
  example₄ =
    (do x , q ← dequeue′ (map (_* 2) (enqueue 3 (enqueue 5 empty)))
        let q = enqueue (3 * x) q
        return ⌊ q ⌋)                                                ≡⟨ cong (_>>= λ _ → return ⌊ enqueue _ _ ⌋) example₂ ⟩

    (do x , q ← just (10 , enqueue 6 empty)
        let q = enqueue (3 * x) (q ⦂ Queue Q ℕ)
        return ⌊ q ⌋)                                                ≡⟨⟩

    just ⌊ enqueue 30 (enqueue 6 empty) ⌋                            ≡⟨ cong just $ to-List-foldl-enqueue-empty (_ ∷ _ ∷ []) ⟩∎

    just (6 ∷ 30 ∷ [])                                               ∎

  example₅ :
    ∀ {xs} →
    dequeue′ (from-List (1 ∷ 2 ∷ 3 ∷ xs)) ≡
    just (1 , from-List (2 ∷ 3 ∷ xs))
  example₅ {xs = xs} =
    dequeue′ (from-List (1 ∷ 2 ∷ 3 ∷ xs))       ≡⟨ cong dequeue′ lemma ⟩
    dequeue′ (cons 1 (from-List (2 ∷ 3 ∷ xs)))  ≡⟨ _↔_.right-inverse-of (Queue↔Maybe[×Queue] _) _ ⟩∎
    just (1 , from-List (2 ∷ 3 ∷ xs))           ∎
    where
    lemma = _↔_.to ≡-for-lists↔≡ (
      ⌊ from-List (1 ∷ 2 ∷ 3 ∷ xs) ⌋       ≡⟨ _↔_.right-inverse-of (Queue↔List _) _ ⟩
      1 ∷ 2 ∷ 3 ∷ xs                       ≡⟨ cong (1 ∷_) $ sym $ _↔_.right-inverse-of (Queue↔List _) _ ⟩
      1 ∷ ⌊ from-List (2 ∷ 3 ∷ xs) ⌋       ≡⟨ sym to-List-cons ⟩∎
      ⌊ cons 1 (from-List (2 ∷ 3 ∷ xs)) ⌋  ∎)

  example₆ :
    foldr enqueue empty′ (3 ∷ 2 ∷ 1 ∷ []) ≡
    from-List (1 ∷ 2 ∷ 3 ∷ [])
  example₆ = sym $ from-List≡foldl-enqueue-empty (λ {_ _} → ℕ-set)


{-# OPTIONS --without-K --rewriting #-}

open import HoTT
open import homotopy.FinWedge
open import homotopy.Bouquet
open import groups.SphereEndomorphism
open import cohomology.Theory

module cohomology.RephraseSubFinCoboundary (OT : OrdinaryTheory lzero) where

open OrdinaryTheory OT
open import cohomology.SphereEndomorphism cohomology-theory
open import cohomology.Sphere OT
open import cohomology.SubFinBouquet OT

abstract
  rephrase-in-degree : ∀ n {I : ℕ} {JA JB : Type₀}
    (JB-ac : has-choice 0 JB lzero)
    (JB-dec : has-dec-eq JB)
    {J} (p : Fin J ≃ Coprod JA JB)
    (f : ⊙FinBouquet I (S n) ⊙→ ⊙Susp (⊙Bouquet JB n)) g
    → GroupIso.f (C-FinBouquet-diag (S n) I)
        (CEl-fmap (ℕ-to-ℤ (S n)) f
          (<– (CEl-Susp (ℕ-to-ℤ n) (⊙Bouquet JB n))
            (GroupIso.g (C-SubFinBouquet-diag n JB-ac (–> p)) g)))
    ∼ λ <I → Group.subsum-r (C2 0) (–> p)
          (λ b → Group.exp (C2 0) (g b) (⊙SphereS-endo-degree n (⊙Susp-fmap (⊙bwproj JB-dec b) ⊙∘ f ⊙∘ ⊙fwin <I)))
  rephrase-in-degree n {I} {JA} {JB} JB-ac JB-dec {J} p f g <I =
    GroupIso.f (C-FinBouquet-diag (S n) I)
      (CEl-fmap (ℕ-to-ℤ (S n)) f
        (<– (CEl-Susp (ℕ-to-ℤ n) (⊙Bouquet JB n))
          (GroupIso.g (C-SubFinBouquet-diag n JB-ac (–> p)) g)))
      <I
      =⟨ ap
          (λ g → GroupIso.f (C-FinBouquet-diag (S n) I)
            (CEl-fmap (ℕ-to-ℤ (S n)) f
              (<– (CEl-Susp (ℕ-to-ℤ n) (⊙Bouquet JB n))
                g)) <I)
          (inverse-C-SubFinBouquet-diag-β n JB-ac JB-dec p g) ⟩
    GroupIso.f (C-FinBouquet-diag (S n) I)
      (CEl-fmap (ℕ-to-ℤ (S n)) f
        (<– (CEl-Susp (ℕ-to-ℤ n) (⊙Bouquet JB n))
          (Group.subsum-r (C (ℕ-to-ℤ n) (⊙Bouquet JB n)) (–> p)
            (λ b → CEl-fmap (ℕ-to-ℤ n) (⊙bwproj JB-dec b)
              (CEl-fmap (ℕ-to-ℤ n) ⊙lift
                (GroupIso.g (C-Sphere-diag n) (g b)))))))
      <I
      =⟨ ap (λ g → GroupIso.f (C-FinBouquet-diag (S n) I) g <I) $
          GroupHom.pres-subsum-r
            (C-fmap (ℕ-to-ℤ (S n)) f ∘ᴳ GroupIso.g-hom (C-Susp (ℕ-to-ℤ n) (⊙Bouquet JB n)))
            (–> p)
            (λ b → CEl-fmap (ℕ-to-ℤ n) (⊙bwproj JB-dec b)
              (CEl-fmap (ℕ-to-ℤ n) ⊙lift
                (GroupIso.g (C-Sphere-diag n) (g b)))) ⟩
    GroupIso.f (C-FinBouquet-diag (S n) I)
      (Group.subsum-r (C (ℕ-to-ℤ (S n)) (⊙FinBouquet I (S n))) (–> p)
        (λ b → CEl-fmap (ℕ-to-ℤ (S n)) f
          (<– (CEl-Susp (ℕ-to-ℤ n) (⊙Bouquet JB n))
            (CEl-fmap (ℕ-to-ℤ n) (⊙bwproj JB-dec b)
              (CEl-fmap (ℕ-to-ℤ n) ⊙lift
                (GroupIso.g (C-Sphere-diag n) (g b)))))))
      <I
      =⟨ ap
          (λ f → GroupIso.f (C-FinBouquet-diag (S n) I)
            (Group.subsum-r (C (ℕ-to-ℤ (S n)) (⊙FinBouquet I (S n))) (–> p) f) <I)
          (λ= λ b → ap (CEl-fmap (ℕ-to-ℤ (S n)) f) $
            C-Susp-fmap' (ℕ-to-ℤ n) (⊙bwproj JB-dec b) □$ᴳ
              CEl-fmap (ℕ-to-ℤ n) ⊙lift (GroupIso.g (C-Sphere-diag n) (g b))) ⟩
    GroupIso.f (C-FinBouquet-diag (S n) I)
      (Group.subsum-r (C (ℕ-to-ℤ (S n)) (⊙FinBouquet I (S n))) (–> p)
        (λ b → CEl-fmap (ℕ-to-ℤ (S n)) f
          (CEl-fmap (ℕ-to-ℤ (S n)) (⊙Susp-fmap (⊙bwproj JB-dec b))
            (<– (CEl-Susp (ℕ-to-ℤ n) (⊙Sphere n))
              (CEl-fmap (ℕ-to-ℤ n) ⊙lift
                (GroupIso.g (C-Sphere-diag n) (g b)))))))
      <I
      =⟨ C-FinBouquet-diag-β (S n) I
          (Group.subsum-r (C (ℕ-to-ℤ (S n)) (⊙FinBouquet I (S n))) (–> p)
            (λ b → CEl-fmap (ℕ-to-ℤ (S n)) f
              (CEl-fmap (ℕ-to-ℤ (S n)) (⊙Susp-fmap (⊙bwproj JB-dec b))
                (<– (CEl-Susp (ℕ-to-ℤ n) (⊙Sphere n))
                  (CEl-fmap (ℕ-to-ℤ n) ⊙lift
                    (GroupIso.g (C-Sphere-diag n) (g b)))))))
          <I ⟩
    GroupIso.f (C-Sphere-diag (S n))
      (CEl-fmap (ℕ-to-ℤ (S n)) ⊙lower
        (CEl-fmap (ℕ-to-ℤ (S n)) (⊙fwin <I)
          (Group.subsum-r (C (ℕ-to-ℤ (S n)) (⊙FinBouquet I (S n))) (–> p)
            (λ b → CEl-fmap (ℕ-to-ℤ (S n)) f
              (CEl-fmap (ℕ-to-ℤ (S n)) (⊙Susp-fmap (⊙bwproj JB-dec b))
                (<– (CEl-Susp (ℕ-to-ℤ n) (⊙Sphere n))
                  (CEl-fmap (ℕ-to-ℤ n) ⊙lift
                    (GroupIso.g (C-Sphere-diag n) (g b)))))))))
      =⟨ GroupHom.pres-subsum-r
          (  GroupIso.f-hom (C-Sphere-diag (S n))
          ∘ᴳ C-fmap (ℕ-to-ℤ (S n)) ⊙lower
          ∘ᴳ C-fmap (ℕ-to-ℤ (S n)) (⊙fwin <I))
          (–> p)
          (λ b → CEl-fmap (ℕ-to-ℤ (S n)) f
            (CEl-fmap (ℕ-to-ℤ (S n)) (⊙Susp-fmap (⊙bwproj JB-dec b))
              (<– (CEl-Susp (ℕ-to-ℤ n) (⊙Sphere n))
                (CEl-fmap (ℕ-to-ℤ n) ⊙lift
                  (GroupIso.g (C-Sphere-diag n) (g b)))))) ⟩
    Group.subsum-r (C2 0) (–> p)
      (λ b → GroupIso.f (C-Sphere-diag (S n))
        (CEl-fmap (ℕ-to-ℤ (S n)) ⊙lower
          (CEl-fmap (ℕ-to-ℤ (S n)) (⊙fwin <I)
            (CEl-fmap (ℕ-to-ℤ (S n)) f
              (CEl-fmap (ℕ-to-ℤ (S n)) (⊙Susp-fmap (⊙bwproj JB-dec b))
                (<– (CEl-Susp (ℕ-to-ℤ n) (⊙Sphere n))
                  (CEl-fmap (ℕ-to-ℤ n) ⊙lift
                    (GroupIso.g (C-Sphere-diag n) (g b)))))))))
      =⟨ ap (Group.subsum-r (C2 0) (–> p))
          (λ= λ b → ap (GroupIso.f (C-Sphere-diag (S n)) ∘ CEl-fmap (ℕ-to-ℤ (S n)) ⊙lower) $
              ∘-CEl-fmap (ℕ-to-ℤ (S n)) (⊙fwin <I) f _
            ∙ ∘-CEl-fmap (ℕ-to-ℤ (S n)) (f ⊙∘ ⊙fwin <I) (⊙Susp-fmap (⊙bwproj JB-dec b)) _
            ∙ CEl-fmap-⊙Sphere-endo-η (ℕ-to-ℤ (S n)) n
                (⊙Susp-fmap (⊙bwproj JB-dec b) ⊙∘ f ⊙∘ ⊙fwin <I)
                (<– (CEl-Susp (ℕ-to-ℤ n) (⊙Sphere n))
                  (CEl-fmap (ℕ-to-ℤ n) ⊙lift
                    (GroupIso.g (C-Sphere-diag n) (g b))))) ⟩
    Group.subsum-r (C2 0) (–> p)
      (λ b → GroupIso.f (C-Sphere-diag (S n))
        (CEl-fmap (ℕ-to-ℤ (S n)) ⊙lower
          (Group.exp (C (ℕ-to-ℤ (S n)) (⊙Sphere (S n)))
            (<– (CEl-Susp (ℕ-to-ℤ n) (⊙Sphere n))
              (CEl-fmap (ℕ-to-ℤ n) ⊙lift
                (GroupIso.g (C-Sphere-diag n) (g b))))
            (⊙SphereS-endo-degree n (⊙Susp-fmap (⊙bwproj JB-dec b) ⊙∘ f ⊙∘ ⊙fwin <I)))))
      =⟨ ap (Group.subsum-r (C2 0) (–> p))
          (λ= λ b →
            GroupHom.pres-exp
              (GroupIso.f-hom (C-Sphere-diag (S n)) ∘ᴳ C-fmap (ℕ-to-ℤ (S n)) ⊙lower)
              (<– (CEl-Susp (ℕ-to-ℤ n) (⊙Sphere n))
                (CEl-fmap (ℕ-to-ℤ n) ⊙lift
                  (GroupIso.g (C-Sphere-diag n) (g b))))
              (⊙SphereS-endo-degree n (⊙Susp-fmap (⊙bwproj JB-dec b) ⊙∘ f ⊙∘ ⊙fwin <I))) ⟩
    Group.subsum-r (C2 0) (–> p)
      (λ b → Group.exp (C2 0)
        (GroupIso.f (C-Sphere-diag n)
          (–> (CEl-Susp (ℕ-to-ℤ n) (⊙Lift (⊙Sphere n)))
            (CEl-fmap (ℕ-to-ℤ (S n)) (⊙lift {j = lzero} ⊙∘ ⊙Susp-fmap {Y = ⊙Sphere n} ⊙lower)
              (CEl-fmap (ℕ-to-ℤ (S n)) ⊙lower
                (<– (CEl-Susp (ℕ-to-ℤ n) (⊙Sphere n))
                  (CEl-fmap (ℕ-to-ℤ n) ⊙lift
                    (GroupIso.g (C-Sphere-diag n) (g b))))))))
        (⊙SphereS-endo-degree n (⊙Susp-fmap (⊙bwproj JB-dec b) ⊙∘ f ⊙∘ ⊙fwin <I)))
      =⟨ ap (Group.subsum-r (C2 0) (–> p))
          (λ= λ b → ap (λ g → Group.exp (C2 0) g (⊙SphereS-endo-degree n (⊙Susp-fmap (⊙bwproj JB-dec b) ⊙∘ f ⊙∘ ⊙fwin <I))) $
            ap (GroupIso.f (C-Sphere-diag n) ∘ –> (CEl-Susp (ℕ-to-ℤ n) (⊙Lift (⊙Sphere n))))
              ( CEl-fmap-∘ (ℕ-to-ℤ (S n)) ⊙lift (⊙Susp-fmap {Y = ⊙Sphere n} ⊙lower) _
              ∙ ap (CEl-fmap (ℕ-to-ℤ (S n)) (⊙Susp-fmap {Y = ⊙Sphere n} ⊙lower))
                  ( ∘-CEl-fmap (ℕ-to-ℤ (S n)) ⊙lift ⊙lower _
                  ∙ CEl-fmap-idf (ℕ-to-ℤ (S n)) _))
            ∙ ap (GroupIso.f (C-Sphere-diag n))
                ( (C-Susp-fmap (ℕ-to-ℤ n) ⊙lower □$ᴳ _)
                ∙ ap (CEl-fmap (ℕ-to-ℤ n) ⊙lower) (GroupIso.f-g (C-Susp (ℕ-to-ℤ n) (⊙Sphere n)) _)
                ∙ ∘-CEl-fmap (ℕ-to-ℤ n) ⊙lower ⊙lift _
                ∙ CEl-fmap-idf (ℕ-to-ℤ n) _)
            ∙ GroupIso.f-g (C-Sphere-diag n) (g b)) ⟩
    Group.subsum-r (C2 0) (–> p)
      (λ b → Group.exp (C2 0) (g b)
        (⊙SphereS-endo-degree n (⊙Susp-fmap (⊙bwproj JB-dec b) ⊙∘ f ⊙∘ ⊙fwin <I)))
      =∎

  {- the version specialzied to [Fin J]. -}
  rephrase-in-degree' : ∀ n {I J : ℕ} (f : ⊙FinBouquet I (S n) ⊙→ ⊙Susp (⊙FinBouquet J n)) g
    → GroupIso.f (C-FinBouquet-diag (S n) I)
        (CEl-fmap (ℕ-to-ℤ (S n)) f
          (<– (CEl-Susp (ℕ-to-ℤ n) (⊙FinBouquet J n))
            (GroupIso.g (C-FinBouquet-diag n J) g)))
    ∼ λ <I → Group.sum (C2 0)
          (λ <J → Group.exp (C2 0) (g <J) (⊙SphereS-endo-degree n (⊙Susp-fmap (⊙fwproj <J) ⊙∘ f ⊙∘ ⊙fwin <I)))
  rephrase-in-degree' n {I} {J} f g =
    rephrase-in-degree n {I} {JA = Empty} {JB = Fin J}
      (Fin-has-choice 0 lzero) Fin-has-dec-eq (⊔₁-Empty (Fin J) ⁻¹) f g


{-# OPTIONS --omega-in-omega --no-termination-check --overlapping-instances #-}

module Light.Implementation.Action where

open import Light.Library.Action using (Library ; Dependencies)
open import Light.Level using (++_ ; 0ℓ)
open import Light.Library.Data.Unit using (Unit)
open import Light.Library.Data.Natural using (ℕ)
open import Light.Variable.Sets
open import Light.Variable.Levels
import Light.Package
import Light.Implementation.Data.Natural
import Light.Implementation.Data.Unit

instance dependencies : Dependencies
dependencies = record {}

instance library : Library dependencies
library = record { Implementation }
      where
      module Implementation where
            postulate Main : Set
            private
                  postulate
                        pure′ : 𝕒 → Main
                        bind′ : Main → (𝕒 → Main) → Main
                        follow : Main → Main → Main

            {-# COMPILE JS pure′ = () => () => () => a => () => a #-}
            {-# COMPILE JS bind′ = () => () => () => m => f => f(m()) #-}
            {-# COMPILE JS follow = () => () => m => m2 => () => (m(), m2()) #-}

            {-# NO_UNIVERSE_CHECK #-}
            data Action (𝕒 : Set ℓ) : Set ℓ where
                  pure : 𝕒 → Action 𝕒
                  _>>=_ : Action 𝕓 → (𝕓 → Action 𝕒) → Action 𝕒
                  _>>_ : Action 𝕓 → Action 𝕒 → Action 𝕒
                  lift : Main → Action 𝕒

            run : Action 𝕒 → Main
            run (pure a) = pure′ a
            run (a >>= f) = bind′ (run a) (λ a → run (f a))
            run (a >> b) = follow (run a) (run b)
            run (lift m) = m

            private
                  postulate log′ alert′ : 𝕒 → Main
                  postulate prompt′ : Main

            log : 𝕒 → Action Unit
            log a = lift (log′ a)

            prompt = lift prompt′

            alert : 𝕒 → Action Unit
            alert a = lift (alert′ a)

            {-# COMPILE JS log′ = () => () => a => () => console.log(a) #-}
            {-# COMPILE JS prompt′ = () => () => BigInt(prompt()) #-}
            {-# COMPILE JS alert′ = () => () => () => a => alert(a) #-}


-- Andreas, 2015-07-13  Better parse errors for illegal type signatures

(A B) : Set1
A B = Set


{-# OPTIONS --safe #-}

open import Definition.Typed.EqualityRelation

module Definition.LogicalRelation.Substitution.Introductions.IdUniv {{eqrel : EqRelSet}} where
open EqRelSet {{...}}

open import Definition.Untyped
open import Definition.Untyped.Properties
open import Definition.Typed
open import Definition.Typed.Properties
import Definition.Typed.Weakening as Twk
open import Definition.Typed.EqualityRelation
open import Definition.Typed.RedSteps
open import Definition.LogicalRelation
open import Definition.LogicalRelation.ShapeView
open import Definition.LogicalRelation.Irrelevance
open import Definition.LogicalRelation.Properties
open import Definition.LogicalRelation.Application
open import Definition.LogicalRelation.Substitution
import Definition.LogicalRelation.Weakening as Lwk
open import Definition.LogicalRelation.Substitution.Properties
import Definition.LogicalRelation.Substitution.Irrelevance as S
open import Definition.LogicalRelation.Substitution.Reflexivity
open import Definition.LogicalRelation.Substitution.Weakening
-- open import Definition.LogicalRelation.Substitution.Introductions.Nat
open import Definition.LogicalRelation.Substitution.Introductions.Empty
open import Definition.LogicalRelation.Substitution.Introductions.Pi
open import Definition.LogicalRelation.Substitution.Introductions.Idlemmas
open import Definition.LogicalRelation.Substitution.MaybeEmbed
-- open import Definition.LogicalRelation.Substitution.Introductions.SingleSubst
open import Definition.LogicalRelation.Substitution.Introductions.Universe

open import Tools.Product
open import Tools.Empty
import Tools.Unit as TU
import Tools.PropositionalEquality as PE
import Data.Nat as Nat

[Id]SProp : ∀ {t u Γ}
         (⊢Γ : ⊢ Γ)
         ([t] : Γ ⊩⟨ ι ⁰ ⟩ t ^ [ % , ι ⁰ ])
         ([u] : Γ ⊩⟨ ι ⁰ ⟩ u ^ [ % , ι ⁰ ])
         → Γ ⊩⟨ ι ¹ ⟩ Id (SProp ⁰) t u ^ [ % , ι ¹ ]
[Id]SProp {t} {u} {Γ} ⊢Γ [t] [u] =
  let
    ⊢t = escape [t]
    ⊢u = escape [u]
    ⊢wkt = Twk.wk (Twk.step Twk.id) (⊢Γ ∙ ⊢u) ⊢t
    ⊢wku = Twk.wk (Twk.step Twk.id) (⊢Γ ∙ ⊢t) ⊢u
    [wkt] = λ {ρ} {Δ} ([ρ] : ρ Twk.∷ Δ ⊆ Γ) (⊢Δ : ⊢ Δ) → Lwk.wk [ρ] ⊢Δ [t]
    [wku] = λ {ρ} {Δ} ([ρ] : ρ Twk.∷ Δ ⊆ Γ) (⊢Δ : ⊢ Δ) → Lwk.wk [ρ] ⊢Δ [u]

    [t▹u] : Γ ⊩⟨ ι ⁰ ⟩ t ^ % ° ⁰ ▹▹ u ° ⁰ ° ¹ ^ [ % , ι ¹ ]
    [t▹u] = Πᵣ′ % ⁰ ⁰ (<is≤ 0<1) (<is≤ 0<1) t (wk1 u)
      (idRed:*: (univ (Πⱼ <is≤ 0<1 ▹ <is≤ 0<1 ▹ un-univ ⊢t ▹ un-univ ⊢wku))) ⊢t ⊢wku
      (≅-univ (≅ₜ-Π-cong (<is≤ 0<1) (<is≤ 0<1) ⊢t (≅-un-univ (escapeEqRefl [t])) (≅-un-univ (≅-wk (Twk.step Twk.id) (⊢Γ ∙ ⊢t) (escapeEqRefl [u])))))
      [wkt] ([nondep] [u] [wkt]) ([nondepext] [u] [wkt])
    [u▹t] : Γ ⊩⟨ ι ⁰ ⟩ u ^ % ° ⁰ ▹▹ t ° ⁰ ° ¹ ^ [ % , ι ¹ ]
    [u▹t] = Πᵣ′ % ⁰ ⁰ (<is≤ 0<1) (<is≤ 0<1) u (wk1 t)
      (idRed:*: (univ (Πⱼ <is≤ 0<1 ▹ <is≤ 0<1 ▹ un-univ ⊢u ▹ un-univ ⊢wkt))) ⊢u ⊢wkt
      (≅-univ (≅ₜ-Π-cong (<is≤ 0<1) (<is≤ 0<1) ⊢u (≅-un-univ (escapeEqRefl [u])) (≅-un-univ (≅-wk (Twk.step Twk.id) (⊢Γ ∙ ⊢u) (escapeEqRefl [t])))))
      [wku] ([nondep] [t] [wku]) ([nondepext] [t] [wku])
    [wkt▹u] = λ {ρ} {Δ} ([ρ] : ρ Twk.∷ Δ ⊆ Γ) (⊢Δ : ⊢ Δ) → Lwk.wk [ρ] ⊢Δ (emb emb< [t▹u])
    ⊢t▹u = escape [t▹u]
    ⊢u▹t = Twk.wk (Twk.step Twk.id) (⊢Γ ∙ ⊢t▹u) (escape [u▹t])

    ⊢Id = univ (Idⱼ (univ 0<1 ⊢Γ) (un-univ ⊢t) (un-univ ⊢u))
    ⊢Eq = univ (∃ⱼ un-univ ⊢t▹u ▹ un-univ ⊢u▹t)
  in ∃ᵣ′ (t ^ % ° ⁰ ▹▹ u ° ⁰ ° ¹) (wk1 (u ^ % ° ⁰ ▹▹ t ° ⁰ ° ¹))
    [[ ⊢Id , ⊢Eq , univ (Id-SProp (un-univ ⊢t) (un-univ ⊢u)) ⇨ id ⊢Eq ]] ⊢t▹u ⊢u▹t
    (≅-univ (≅ₜ-∃-cong ⊢t▹u (≅-un-univ (escapeEqRefl [t▹u])) (≅-un-univ (≅-wk (Twk.step Twk.id) (⊢Γ ∙ ⊢t▹u) (escapeEqRefl [u▹t])))))
    [wkt▹u] ([nondep] (emb emb< [u▹t]) [wkt▹u]) ([nondepext] (emb emb< [u▹t]) [wkt▹u])

[IdExt]SProp : ∀ {t t′ u u′ Γ}
         (⊢Γ : ⊢ Γ)
         ([t] : Γ ⊩⟨ ι ⁰ ⟩ t ^ [ % , ι ⁰ ])
         ([t′] : Γ ⊩⟨ ι ⁰ ⟩ t′ ^ [ % , ι ⁰ ])
         ([t≡t′] : Γ ⊩⟨ ι ⁰ ⟩ t ≡ t′ ^ [ % , ι ⁰ ] / [t])
         ([u] : Γ ⊩⟨ ι ⁰ ⟩ u ^ [ % , ι ⁰ ])
         ([u′] : Γ ⊩⟨ ι ⁰ ⟩ u′ ^ [ % , ι ⁰ ])
         ([u≡u′] : Γ ⊩⟨ ι ⁰ ⟩ u ≡ u′ ^ [ % , ι ⁰ ] / [u])
         → Γ ⊩⟨ ι ¹ ⟩ Id (SProp ⁰) t u ≡ Id (SProp ⁰) t′ u′ ^ [ % , ι ¹ ] / [Id]SProp ⊢Γ [t] [u]
[IdExt]SProp {t} {t′} {u} {u′} {Γ} ⊢Γ [t] [t′] [t≡t′] [u] [u′] [u≡u′] =
  let ⊢t = escape [t]
      ⊢t′ = escape [t′]
      ⊢u = escape [u]
      ⊢u′ = escape [u′]
      ⊢t≡t′ = ≅-un-univ (escapeEq [t] [t≡t′])
      ⊢u≡u′ = ≅-un-univ (escapeEq [u] [u≡u′])

      ⊢wkt = Twk.wk (Twk.step Twk.id) (⊢Γ ∙ ⊢u) ⊢t
      ⊢wku = Twk.wk (Twk.step Twk.id) (⊢Γ ∙ ⊢t) ⊢u
      [wkt] = λ {ρ} {Δ} ([ρ] : ρ Twk.∷ Δ ⊆ Γ) (⊢Δ : ⊢ Δ) → Lwk.wk [ρ] ⊢Δ [t]
      [wku] = λ {ρ} {Δ} ([ρ] : ρ Twk.∷ Δ ⊆ Γ) (⊢Δ : ⊢ Δ) → Lwk.wk [ρ] ⊢Δ [u]

      ⊢wkt′ = Twk.wk (Twk.step Twk.id) (⊢Γ ∙ ⊢u′) ⊢t′
      ⊢wku′ = Twk.wk (Twk.step Twk.id) (⊢Γ ∙ ⊢t′) ⊢u′
      [wkt′] = λ {ρ} {Δ} ([ρ] : ρ Twk.∷ Δ ⊆ Γ) (⊢Δ : ⊢ Δ) → Lwk.wk [ρ] ⊢Δ [t′]
      [wku′] = λ {ρ} {Δ} ([ρ] : ρ Twk.∷ Δ ⊆ Γ) (⊢Δ : ⊢ Δ) → Lwk.wk [ρ] ⊢Δ [u′]

      [t▹u] : Γ ⊩⟨ ι ⁰ ⟩ t ^ % ° ⁰ ▹▹ u ° ⁰ ° ¹ ^ [ % , ι ¹ ]
      [t▹u] = Πᵣ′ % ⁰ ⁰ (<is≤ 0<1) (<is≤ 0<1) t (wk1 u)
        (idRed:*: (univ (Πⱼ <is≤ 0<1 ▹ <is≤ 0<1 ▹ un-univ ⊢t ▹ un-univ ⊢wku))) ⊢t ⊢wku
        (≅-univ (≅ₜ-Π-cong (<is≤ 0<1) (<is≤ 0<1) ⊢t (≅-un-univ (escapeEqRefl [t])) (≅-un-univ (≅-wk (Twk.step Twk.id) (⊢Γ ∙ ⊢t) (escapeEqRefl [u])))))
        [wkt] ([nondep] [u] [wkt]) ([nondepext] [u] [wkt])
      [u▹t] : Γ ⊩⟨ ι ⁰ ⟩ u ^ % ° ⁰ ▹▹ t ° ⁰ ° ¹ ^ [ % , ι ¹ ]
      [u▹t] = Πᵣ′ % ⁰ ⁰ (<is≤ 0<1) (<is≤ 0<1) u (wk1 t)
        (idRed:*: (univ (Πⱼ <is≤ 0<1 ▹ <is≤ 0<1 ▹ un-univ ⊢u ▹ un-univ ⊢wkt))) ⊢u ⊢wkt
        (≅-univ (≅ₜ-Π-cong (<is≤ 0<1) (<is≤ 0<1) ⊢u (≅-un-univ (escapeEqRefl [u])) (≅-un-univ (≅-wk (Twk.step Twk.id) (⊢Γ ∙ ⊢u) (escapeEqRefl [t])))))
        [wku] ([nondep] [t] [wku]) ([nondepext] [t] [wku])

      [t▹u′] : Γ ⊩⟨ ι ⁰ ⟩ t′ ^ % ° ⁰ ▹▹ u′ ° ⁰ ° ¹ ^ [ % , ι ¹ ]
      [t▹u′] = Πᵣ′ % ⁰ ⁰ (<is≤ 0<1) (<is≤ 0<1) t′ (wk1 u′)
        (idRed:*: (univ (Πⱼ <is≤ 0<1 ▹ <is≤ 0<1 ▹ un-univ ⊢t′ ▹ un-univ ⊢wku′))) ⊢t′ ⊢wku′
        (≅-univ (≅ₜ-Π-cong (<is≤ 0<1) (<is≤ 0<1) ⊢t′ (≅-un-univ (escapeEqRefl [t′])) (≅-un-univ (≅-wk (Twk.step Twk.id) (⊢Γ ∙ ⊢t′) (escapeEqRefl [u′])))))
        [wkt′] ([nondep] [u′] [wkt′]) ([nondepext] [u′] [wkt′])
      [u▹t′] : Γ ⊩⟨ ι ⁰ ⟩ u′ ^ % ° ⁰ ▹▹ t′ ° ⁰ ° ¹ ^ [ % , ι ¹ ]
      [u▹t′] = Πᵣ′ % ⁰ ⁰ (<is≤ 0<1) (<is≤ 0<1) u′ (wk1 t′)
        (idRed:*: (univ (Πⱼ <is≤ 0<1 ▹ <is≤ 0<1 ▹ un-univ ⊢u′ ▹ un-univ ⊢wkt′)))
        ⊢u′ ⊢wkt′
        (≅-univ (≅ₜ-Π-cong (<is≤ 0<1) (<is≤ 0<1) ⊢u′ (≅-un-univ (escapeEqRefl [u′])) (≅-un-univ (≅-wk (Twk.step Twk.id) (⊢Γ ∙ ⊢u′) (escapeEqRefl [t′])))))
        [wku′] ([nondep] [t′] [wku′]) ([nondepext] [t′] [wku′])

      [t▹u≡t▹u′] : Γ ⊩⟨ ι ⁰ ⟩ t ^ % ° ⁰ ▹▹ u ° ⁰ ° ¹  ≡ t′ ^ % ° ⁰ ▹▹ u′ ° ⁰ ° ¹  ^ [ % , ι ¹ ] / [t▹u]
      [t▹u≡t▹u′] = Π₌ t′ (wk1 u′) (id (univ (Πⱼ <is≤ 0<1 ▹ <is≤ 0<1 ▹ un-univ ⊢t′ ▹ un-univ ⊢wku′)))
                      (≅-univ (≅ₜ-Π-cong (<is≤ 0<1) (<is≤ 0<1) ⊢t ⊢t≡t′ (≅ₜ-wk (Twk.step Twk.id) (⊢Γ ∙ ⊢t) ⊢u≡u′)))
                      (λ {ρ} {Δ} ([ρ] : ρ Twk.∷ Δ ⊆ Γ) (⊢Δ : ⊢ Δ) → Lwk.wkEq [ρ] ⊢Δ (emb emb< [t]) [t≡t′])
                      ([nondepext'] [u] [u′] [u≡u′] [wkt] [wkt′])

      [u▹t≡u▹t′] : Γ ⊩⟨ ι ⁰ ⟩ u ^ % ° ⁰ ▹▹ t ° ⁰ ° ¹  ≡ u′ ^ % ° ⁰ ▹▹ t′ ° ⁰ ° ¹  ^ [ % , ι ¹ ] / [u▹t]
      [u▹t≡u▹t′] = Π₌ u′ (wk1 t′) (id (univ (Πⱼ <is≤ 0<1 ▹ <is≤ 0<1 ▹ un-univ ⊢u′ ▹ un-univ ⊢wkt′)))
                      (≅-univ (≅ₜ-Π-cong (<is≤ 0<1) (<is≤ 0<1) ⊢u ⊢u≡u′ (≅ₜ-wk (Twk.step Twk.id) (⊢Γ ∙ ⊢u) ⊢t≡t′)))
                      (λ {ρ} {Δ} ([ρ] : ρ Twk.∷ Δ ⊆ Γ) (⊢Δ : ⊢ Δ) → Lwk.wkEq [ρ] ⊢Δ (emb emb< [u]) [u≡u′])
                      ([nondepext'] [t] [t′] [t≡t′] [wku] [wku′])

      ⊢t▹u = escape [t▹u]

  in ∃₌ {l′ = ¹} (t′ ^ % ° ⁰ ▹▹ u′ ° ⁰ ° ¹ ) (wk1 (u′ ^ % ° ⁰ ▹▹ t′ ° ⁰ ° ¹ ))
        (univ (Id-SProp (un-univ ⊢t′) (un-univ ⊢u′)) ⇨ id (univ (××ⱼ (▹▹ⱼ <is≤ 0<1 ▹ <is≤ 0<1 ▹ un-univ ⊢t′ ▹ un-univ ⊢u′) ▹
                                                                     (▹▹ⱼ <is≤ 0<1 ▹ <is≤ 0<1 ▹ un-univ ⊢u′ ▹ un-univ ⊢t′))))
        (≅-univ (≅ₜ-∃-cong ⊢t▹u
                           (≅ₜ-Π-cong (<is≤ 0<1) (<is≤ 0<1) ⊢t ⊢t≡t′ (≅ₜ-wk (Twk.step Twk.id) (⊢Γ ∙ ⊢t) ⊢u≡u′))
                           (≅ₜ-Π-cong (<is≤ 0<1) (<is≤ 0<1) (Twk.wk (Twk.step Twk.id) (⊢Γ ∙ ⊢t▹u) ⊢u)
                                      (≅ₜ-wk (Twk.step Twk.id) (⊢Γ ∙ ⊢t▹u) ⊢u≡u′)
                                      (≅ₜ-wk (Twk.lift (Twk.step Twk.id)) ((⊢Γ ∙ ⊢t▹u) ∙
                                                       (Twk.wk (Twk.step Twk.id) (⊢Γ ∙ ⊢t▹u) ⊢u))
                                             (≅ₜ-wk (Twk.step Twk.id) (⊢Γ ∙ ⊢u) ⊢t≡t′)) )))
        (λ {ρ} {Δ} ([ρ] : ρ Twk.∷ Δ ⊆ Γ) (⊢Δ : ⊢ Δ) → Lwk.wkEq [ρ] ⊢Δ [t▹u] [t▹u≡t▹u′])
        ([nondepext'] (emb emb< [u▹t]) (emb emb< [u▹t′]) [u▹t≡u▹t′]
                      (λ {ρ} {Δ} ([ρ] : ρ Twk.∷ Δ ⊆ Γ) (⊢Δ : ⊢ Δ) → Lwk.wk [ρ] ⊢Δ (emb emb< [t▹u]))
                      (λ {ρ} {Δ} ([ρ] : ρ Twk.∷ Δ ⊆ Γ) (⊢Δ : ⊢ Δ) → Lwk.wk [ρ] ⊢Δ (emb emb< [t▹u′])))

[Id]U : ∀ {A B Γ}
         (⊢Γ : ⊢ Γ)
         ([A] : Γ ⊩⟨ ι ⁰ ⟩ A ^ [ ! , ι ⁰ ])
         ([B] : Γ ⊩⟨ ι ⁰ ⟩ B ^ [ ! , ι ⁰ ])
         → Γ ⊩⟨ ι ¹ ⟩ Id (U ⁰) A B ^ [ % , ι ¹ ]
[IdExtShape]U : ∀ {A A′ B B′ Γ}
         (⊢Γ : ⊢ Γ)
         ([A] : Γ ⊩⟨ ι ⁰ ⟩ A ^ [ ! , ι ⁰ ])
         ([A′] : Γ ⊩⟨ ι ⁰ ⟩ A′ ^ [ ! , ι ⁰ ])
         (ShapeA : ShapeView Γ (ι ⁰) (ι ⁰) A A′ [ ! , ι ⁰ ] [ ! , ι ⁰ ] [A] [A′])
         ([A≡A′] : Γ ⊩⟨ ι ⁰ ⟩ A ≡ A′ ^ [ ! , ι ⁰ ] / [A])
         ([B] : Γ ⊩⟨ ι ⁰ ⟩ B ^ [ ! , ι ⁰ ])
         ([B′] : Γ ⊩⟨ ι ⁰ ⟩ B′ ^ [ ! , ι ⁰ ])
         (ShapeB : ShapeView Γ (ι ⁰) (ι ⁰) B B′ [ ! , ι ⁰ ] [ ! , ι ⁰ ] [B] [B′])
         ([B≡B′] : Γ ⊩⟨ ι ⁰ ⟩ B ≡ B′ ^ [ ! , ι ⁰ ] / [B])
         → Γ ⊩⟨ ι ¹ ⟩ Id (U ⁰) A B ≡ Id (U ⁰) A′ B′ ^ [ % , ι ¹ ] / [Id]U ⊢Γ [A] [B]
[IdExt]U : ∀ {A A′ B B′ Γ}
         (⊢Γ : ⊢ Γ)
         ([A] : Γ ⊩⟨ ι ⁰ ⟩ A ^ [ ! , ι ⁰ ])
         ([A′] : Γ ⊩⟨ ι ⁰ ⟩ A′ ^ [ ! , ι ⁰ ])
         ([A≡A′] : Γ ⊩⟨ ι ⁰ ⟩ A ≡ A′ ^ [ ! , ι ⁰ ] / [A])
         ([B] : Γ ⊩⟨ ι ⁰ ⟩ B ^ [ ! , ι ⁰ ])
         ([B′] : Γ ⊩⟨ ι ⁰ ⟩ B′ ^ [ ! , ι ⁰ ])
         ([B≡B′] : Γ ⊩⟨ ι ⁰ ⟩ B ≡ B′ ^ [ ! , ι ⁰ ] / [B])
         → Γ ⊩⟨ ι ¹ ⟩ Id (U ⁰) A B ≡ Id (U ⁰) A′ B′ ^ [ % , ι ¹ ] / [Id]U ⊢Γ [A] [B]

[Id]U {A} {B} ⊢Γ (ne′ K D neK K≡K) [B] =
  let ⊢B = escape [B]
      B≡B = escapeEqRefl [B]
  in ne (ne (Id (U ⁰) K B) (univ:⇒*: (IdURed*Term (un-univ:⇒*: D) (un-univ ⊢B))) (IdUₙ neK) (~-IdU ⊢Γ K≡K (≅-un-univ B≡B)))

[Id]U ⊢Γ (ℕᵣ [[ ⊢A , ⊢K , D ]]) (ℕᵣ [[ ⊢B , ⊢L , D₁ ]]) =
  let
    ⊢tA = (subset* D)
  in proj₁ (redSubst* (trans⇒* (univ⇒* (IdURed*Term′ (un-univ ⊢A) (un-univ ⊢K) (un-univ⇒* D) (un-univ ⊢B)))
                        (trans⇒* (univ⇒* (IdUℕRed*Term′ (un-univ ⊢B) (un-univ ⊢L) (un-univ⇒* D₁))) (univ (Id-U-ℕℕ ⊢Γ) ⇨ id (univ (Unitⱼ ⊢Γ))))) (UnitType ⊢Γ))

[Id]U ⊢Γ (ℕᵣ D) (ne′ K D₁ neK K≡K) =
  let [B] = ne′ K D₁ neK K≡K
      ⊢B = escape {l = ι ¹} [B]
  in ne′ (Id (U ⁰) ℕ K) (univ:⇒*: (transTerm:⇒:* (IdURed*Term (un-univ:⇒*: D) (un-univ ⊢B) ) (IdUℕRed*Term (un-univ:⇒*: D₁))))
         (IdUℕₙ neK) (~-IdUℕ ⊢Γ K≡K)

[Id]U ⊢Γ (ℕᵣ [[ ⊢A , ⊢ℕ , D ]]) (Πᵣ′ rF lF lG (≡is≤ PE.refl) (≡is≤ PE.refl) F G D′ ⊢F ⊢G A≡A [F] [G] G-ext) =
  let [B] = Πᵣ′ rF lF lG (≡is≤ PE.refl) (≡is≤ PE.refl) F G D′ ⊢F ⊢G A≡A [F] [G] G-ext
      ⊢B = escape [B]
  in proj₁ (redSubst* (trans⇒* (univ⇒* (IdURed*Term′ (un-univ ⊢A) (un-univ ⊢ℕ) (un-univ⇒* D) (un-univ ⊢B)))
                        (trans⇒* (univ⇒* (IdUℕRed*Term′ (un-univ ⊢B) (Πⱼ ≡is≤ PE.refl ▹ ≡is≤ PE.refl ▹ (un-univ ⊢F) ▹ (un-univ ⊢G)) (un-univ⇒* (red D′))))
                                 (univ (Id-U-ℕΠ (un-univ ⊢F) (un-univ ⊢G)) ⇨ id (univ (Emptyⱼ ⊢Γ))))) (EmptyType ⊢Γ))

[Id]U ⊢Γ (Πᵣ′ rF lF lG (≡is≤ PE.refl) (≡is≤ PE.refl) F G [[ ⊢A , ⊢Π , D ]] ⊢F ⊢G A≡A [F] [G] G-ext) (ℕᵣ [[ ⊢B , ⊢ℕ , D' ]]) =
  proj₁ (redSubst* (trans⇒* (univ⇒* (IdURed*Term′ (un-univ ⊢A) (un-univ ⊢Π) (un-univ⇒* D) (un-univ ⊢B)))
                        (trans⇒* (univ⇒* (IdUΠRed*Term′ (un-univ ⊢F) (un-univ ⊢G) (un-univ ⊢B) (un-univ ⊢ℕ) (un-univ⇒* D')))
                                 (univ (Id-U-Πℕ (un-univ ⊢F) (un-univ ⊢G)) ⇨ id (univ (Emptyⱼ ⊢Γ))))) (EmptyType ⊢Γ))

[Id]U ⊢Γ (Πᵣ′ rF lF lG (≡is≤ PE.refl) (≡is≤ PE.refl) F G D ⊢F ⊢G A≡A [F] [G] G-ext) (ne′ K D₁ neK K≡K) =
  let [B] = ne′ K D₁ neK K≡K
      ⊢B = escape {l = ι ¹} [B]
      -- [F]' = PE.subst (λ X → _  ⊩⟨ _ ⟩ X ^ [ _ , _ ]) (wk-id F) ([F] Twk.id ⊢Γ)
      -- ⊢F≅F = ≅-un-univ (escapeEqRefl [F]')
      -- [G]' = PE.subst (λ X → _  ⊩⟨ _ ⟩ X ^ [ _ , _ ]) (wkSingleSubstId G) ([G] {a = var 0} (Twk.step Twk.id) (⊢Γ ∙ ⊢F) {!!})
      -- ⊢G≅G = ≅-un-univ (escapeEqRefl [G]')
  in ne′ (Id (U ⁰) (Π F ^ rF ° lF ▹ G ° lG ° ⁰) K)
         (univ:⇒*: (transTerm:⇒:* (IdURed*Term (un-univ:⇒*: D) (un-univ ⊢B) ) (IdUΠRed*Term (un-univ ⊢F) (un-univ ⊢G) (un-univ:⇒*: D₁))))
         (IdUΠₙ neK) (~-IdUΠ (≅-un-univ A≡A) K≡K)

[Id]U {A} {B} {Γ} ⊢Γ (Πᵣ′ ! .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F G [[ ⊢A , ⊢ΠFG , D ]] ⊢F ⊢G A≡A [F] [G] G-ext)
  (Πᵣ′ ! .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F₁ G₁ [[ ⊢B , ⊢ΠF₁G₁ , D₁ ]] ⊢F₁ ⊢G₁ B≡B [F₁] [G₁] G₁-ext) =
  ∃ᵣ′ (Id (U ⁰) F F₁) (IdGG₁ (step id) (var 0))
    [[ (univ (Idⱼ (univ 0<1 ⊢Γ) (un-univ ⊢A) (un-univ ⊢B))) , ⊢∃ , D∃ ]]
    ⊢IdFF₁ ⊢IdGG₁ ∃≡∃ [IdFF₁]
    (λ {ρ} {Δ} {a} [ρ] ⊢Δ [a] → PE.subst (λ X → Δ ⊩⟨ ι ¹ ⟩ X ^ [ % , ι ¹ ]) (PE.sym (wksubst-IdTel ρ a)) ([IdGG₁] [ρ] ⊢Δ [a]))
    (λ {ρ} {Δ} {a} {b} [ρ] ⊢Δ [a] [b] [a≡b] → irrelevanceEq″ (PE.sym (wksubst-IdTel ρ a)) (PE.sym (wksubst-IdTel ρ b)) PE.refl PE.refl
      ([IdGG₁] [ρ] ⊢Δ [a]) (PE.subst (λ X → Δ ⊩⟨ ι ¹ ⟩ X ^ [ % , ι ¹ ]) (PE.sym (wksubst-IdTel ρ a)) ([IdGG₁] [ρ] ⊢Δ [a]))
      ([IdGG₁-ext] [ρ] ⊢Δ [a] [b] [a≡b]))
  where
    open IdTypeU-lemmas ⊢Γ ⊢A ⊢ΠFG D ⊢F ⊢G A≡A [F] [G] G-ext ⊢B ⊢ΠF₁G₁ D₁ ⊢F₁ ⊢G₁ B≡B [F₁] [G₁] G₁-ext
      (λ [ρ] ⊢Δ → [Id]U ⊢Δ ([F] [ρ] ⊢Δ) ([F₁] [ρ] ⊢Δ))
      (λ [ρ] ⊢Δ [x] [y] → [Id]U ⊢Δ ([G] [ρ] ⊢Δ [x]) ([G₁] [ρ] ⊢Δ [y]))
      (λ [ρ] ⊢Δ [x] [x′] [x≡x′] [y] [y′] [y≡y′] →
        [IdExt]U ⊢Δ ([G] [ρ] ⊢Δ [x]) ([G] [ρ] ⊢Δ [x′]) (G-ext [ρ] ⊢Δ [x] [x′] [x≡x′]) ([G₁] [ρ] ⊢Δ [y]) ([G₁] [ρ] ⊢Δ [y′]) (G₁-ext [ρ] ⊢Δ [y] [y′] [y≡y′]))

[Id]U {A} {B} {Γ} ⊢Γ (Πᵣ′ % .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F G [[ ⊢A , ⊢ΠFG , D ]] ⊢F ⊢G A≡A [F] [G] G-ext)
  (Πᵣ′ % .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F₁ G₁ [[ ⊢B , ⊢ΠF₁G₁ , D₁ ]] ⊢F₁ ⊢G₁ B≡B [F₁] [G₁] G₁-ext) =
  ∃ᵣ′ (Id (SProp ⁰) F F₁) (IdGG₁ (step id) (var 0))
    [[ (univ (Idⱼ (univ 0<1 ⊢Γ) (un-univ ⊢A) (un-univ ⊢B))) , ⊢∃ , D∃ ]]
    ⊢IdFF₁ ⊢IdGG₁ ∃≡∃ [IdFF₁]
    (λ {ρ} {Δ} {a} [ρ] ⊢Δ [a] → PE.subst (λ X → Δ ⊩⟨ ι ¹ ⟩ X ^ [ % , ι ¹ ]) (PE.sym (wksubst-IdTel ρ a)) ([IdGG₁] [ρ] ⊢Δ [a]))
    (λ {ρ} {Δ} {a} {b} [ρ] ⊢Δ [a] [b] [a≡b] → irrelevanceEq″ (PE.sym (wksubst-IdTel ρ a)) (PE.sym (wksubst-IdTel ρ b)) PE.refl PE.refl
      ([IdGG₁] [ρ] ⊢Δ [a]) (PE.subst (λ X → Δ ⊩⟨ ι ¹ ⟩ X ^ [ % , ι ¹ ]) (PE.sym (wksubst-IdTel ρ a)) ([IdGG₁] [ρ] ⊢Δ [a]))
      ([IdGG₁-ext] [ρ] ⊢Δ [a] [b] [a≡b]))
  where
    open IdTypeU-lemmas ⊢Γ ⊢A ⊢ΠFG D ⊢F ⊢G A≡A [F] [G] G-ext ⊢B ⊢ΠF₁G₁ D₁ ⊢F₁ ⊢G₁ B≡B [F₁] [G₁] G₁-ext
      (λ [ρ] ⊢Δ → [Id]SProp ⊢Δ ([F] [ρ] ⊢Δ) ([F₁] [ρ] ⊢Δ))
      (λ [ρ] ⊢Δ [x] [y] → [Id]U ⊢Δ ([G] [ρ] ⊢Δ [x]) ([G₁] [ρ] ⊢Δ [y]))
      (λ [ρ] ⊢Δ [x] [x′] [x≡x′] [y] [y′] [y≡y′] →
        [IdExt]U ⊢Δ ([G] [ρ] ⊢Δ [x]) ([G] [ρ] ⊢Δ [x′]) (G-ext [ρ] ⊢Δ [x] [x′] [x≡x′]) ([G₁] [ρ] ⊢Δ [y]) ([G₁] [ρ] ⊢Δ [y′]) (G₁-ext [ρ] ⊢Δ [y] [y′] [y≡y′]))

[Id]U ⊢Γ (Πᵣ′ ! .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F G [[ ⊢A , ⊢ΠFG , D ]] ⊢F ⊢G A≡A [F] [G] G-ext)
         (Πᵣ′ % .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F₁ G₁ [[ ⊢B , ⊢ΠF₁G₁ , D' ]] ⊢F₁ ⊢G₁ B≡B [F₁] [G₁] G₁-ext) =
    proj₁ (redSubst* (trans⇒* (univ⇒* (IdURed*Term′ (un-univ ⊢A) (un-univ ⊢ΠFG) (un-univ⇒* D) (un-univ ⊢B)))
                        (trans⇒* (univ⇒* (IdUΠRed*Term′ (un-univ ⊢F) (un-univ ⊢G) (un-univ ⊢B) (un-univ ⊢ΠF₁G₁) (un-univ⇒* D')))
                                 (univ (Id-U-ΠΠ!% !≢% (un-univ ⊢F) (un-univ ⊢G) (un-univ ⊢F₁) (un-univ ⊢G₁)) ⇨ id (univ (Emptyⱼ ⊢Γ))))) (EmptyType ⊢Γ))

[Id]U ⊢Γ (Πᵣ′ % .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F G [[ ⊢A , ⊢ΠFG , D ]] ⊢F ⊢G A≡A [F] [G] G-ext)
  (Πᵣ′ ! .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F₁ G₁ [[ ⊢B , ⊢ΠF₁G₁ , D' ]] ⊢F₁ ⊢G₁ B≡B [F₁] [G₁] G₁-ext) =
    proj₁ (redSubst* (trans⇒* (univ⇒* (IdURed*Term′ (un-univ ⊢A) (un-univ ⊢ΠFG) (un-univ⇒* D) (un-univ ⊢B)))
                       (trans⇒* (univ⇒* (IdUΠRed*Term′ (un-univ ⊢F) (un-univ ⊢G) (un-univ ⊢B) (un-univ ⊢ΠF₁G₁) (un-univ⇒* D')))
                                 (univ (Id-U-ΠΠ!% (λ e → !≢% (PE.sym e)) (un-univ ⊢F) (un-univ ⊢G) (un-univ ⊢F₁) (un-univ ⊢G₁)) ⇨ id (univ (Emptyⱼ ⊢Γ))))) (EmptyType ⊢Γ))

[IdExtShape]U ⊢Γ _ _ (ℕᵥ ℕA [[ ⊢A , ⊢K , D ]]) [A≡A′] _ _ (ℕᵥ NB [[ ⊢B , ⊢L , D₁ ]]) [B≡B′] =
  Π₌ (Empty _) (Empty _)
    (trans⇒* (univ⇒* (IdURed*Term′ (un-univ ⊢A) (un-univ ⊢K) (un-univ⇒* D) (un-univ ⊢B)))
                        (trans⇒* (univ⇒* (IdUℕRed*Term′ (un-univ ⊢B) (un-univ ⊢L) (un-univ⇒* D₁))) (univ (Id-U-ℕℕ ⊢Γ) ⇨ id (univ (Unitⱼ ⊢Γ)))))
                        (≅-univ (Unit≡Unit ⊢Γ))
    (λ [ρ] ⊢Δ → id (univ (Emptyⱼ ⊢Δ)))
    λ [ρ] ⊢Δ [a] → id (univ (Emptyⱼ ⊢Δ))

[IdExtShape]U ⊢Γ _ _ (ℕᵥ ℕA D) [A≡A′] _ _ (ne neB neB') (ne₌ M D′ neM K≡M) =
  let [[ ⊢B , _ ,  _ ]] = D′
  in ne₌ (Id (U ⁰) ℕ M) (univ:⇒*: (transTerm:⇒:* (IdURed*Term (un-univ:⇒*: D) (un-univ ⊢B) ) (IdUℕRed*Term (un-univ:⇒*: D′))))
         (IdUℕₙ neM) (~-IdUℕ ⊢Γ K≡M)

[IdExtShape]U ⊢Γ _ _ (ℕᵥ [[ ⊢A , ⊢ℕ , D ]] [[ ⊢A' , ⊢ℕ' , D' ]]) [A≡A′] _ _
                     (Πᵥ (Πᵣ rF lF lG (≡is≤ PE.refl) (≡is≤ PE.refl) F G D′ ⊢F ⊢G A≡A [F] [G] G-ext)
                         (Πᵣ rF' lF' lG' (≡is≤ PE.refl) (≡is≤ PE.refl) F' G' D′' ⊢F' ⊢G' A≡A' [F]' [G]' G-ext')) [B≡B′] =
  let [B]' = Πᵣ′ rF' lF' lG' (≡is≤ PE.refl) (≡is≤ PE.refl) F' G' D′' ⊢F' ⊢G' A≡A' [F]' [G]' G-ext'
      ⊢B' = escape [B]'
  in trans⇒* (univ⇒* (IdURed*Term′ (un-univ ⊢A') (un-univ ⊢ℕ') (un-univ⇒* D') (un-univ ⊢B')))
                        (trans⇒* (univ⇒* (IdUℕRed*Term′ (un-univ ⊢B') (Πⱼ ≡is≤ PE.refl ▹ ≡is≤ PE.refl ▹ (un-univ ⊢F') ▹ (un-univ ⊢G')) (un-univ⇒* (red D′'))))
                                 (univ (Id-U-ℕΠ (un-univ ⊢F') (un-univ ⊢G')) ⇨ id (univ (Emptyⱼ ⊢Γ))))

[IdExtShape]U {A} {A′} {B} {B′} ⊢Γ _ _ (ne neA neA') (ne₌ M D neM K≡M) [B] [B'] [ShapeB] [B≡B′] =
  let ⊢B' = escape [B']
      B≡B' = escapeEq [B] [B≡B′]
  in ne₌ (Id (U ⁰) M B′) (univ:⇒*: (IdURed*Term (un-univ:⇒*: D) (un-univ ⊢B')))
         (IdUₙ neM) (~-IdU ⊢Γ K≡M (≅-un-univ B≡B'))

[IdExtShape]U ⊢Γ _ _ (Πᵥ (Πᵣ rF lF lG (≡is≤ PE.refl) (≡is≤ PE.refl) F G D′ ⊢F ⊢G A≡A [F] [G] G-ext)
                         (Πᵣ rF' lF' lG' (≡is≤ PE.refl) (≡is≤ PE.refl) F' G' [[ ⊢A' , ⊢Π' , DΠ' ]] ⊢F' ⊢G' A≡A' [F]' [G]' G-ext')) [A≡A′] _ _
                     (ℕᵥ [[ ⊢A , ⊢ℕ , D ]] [[ ⊢B' , ⊢ℕ' , D' ]]) [B≡B′] =
   trans⇒* (univ⇒* (IdURed*Term′ (un-univ ⊢A') (un-univ ⊢Π') (un-univ⇒* DΠ') (un-univ ⊢B')))
                        (trans⇒* (univ⇒* (IdUΠRed*Term′ (un-univ ⊢F') (un-univ ⊢G') (un-univ ⊢B') (un-univ ⊢ℕ') (un-univ⇒* D')))
                                 (univ (Id-U-Πℕ (un-univ ⊢F') (un-univ ⊢G')) ⇨ id (univ (Emptyⱼ ⊢Γ))))

[IdExtShape]U ⊢Γ _ _ (Πᵥ (Πᵣ rF' .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F' G' De' ⊢F' ⊢G' A≡A' [F]' [G]' G-ext')
                         (Πᵣ rF .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F G D ⊢F ⊢G A≡A [F] [G] G-ext)) (Π₌ F′ G′ D′₁ A≡B [F≡F′] [G≡G′])
                 _ _ (ne neA neB) (ne₌ M D′ neM K≡M) =
  let [[ ⊢B , _ ,  _ ]] = D′
      Π≡Π = whrDet* (red D , Whnf.Πₙ) (D′₁ , Whnf.Πₙ)
      F≡F' , rF≡rF' , _ , G≡G' , _  = Π-PE-injectivity Π≡Π
  in ne₌ (Id (U ⁰) (Π F ^ rF ° ⁰ ▹ G ° ⁰ ° ⁰) M)
         (univ:⇒*: (transTerm:⇒:* (IdURed*Term (un-univ:⇒*: D) (un-univ ⊢B) ) (IdUΠRed*Term (un-univ ⊢F) (un-univ ⊢G) (un-univ:⇒*: D′))))
         (IdUΠₙ neM) (PE.subst (λ X → _  ⊢ Id (U ⁰) (Π F' ^ rF' ° ⁰ ▹ G' ° ⁰ ° ⁰) _ ~ Id (U ⁰) (Π F ^ X ° ⁰ ▹ G ° ⁰ ° ⁰) M ∷ SProp _ ^ _) (PE.sym rF≡rF')
                               (~-IdUΠ (≅-un-univ
                                 (PE.subst (λ X → _ ⊢ Π F' ^ rF' ° ⁰ ▹ G' ° ⁰ ° ⁰ ≅  Π F ^ rF' ° ⁰ ▹ X ° ⁰ ° ⁰ ^ _ ) (PE.sym G≡G')
                                   (PE.subst (λ X → _ ⊢ Π F' ^ rF' ° ⁰ ▹ G' ° ⁰ ° ⁰ ≅  Π X ^ rF' ° ⁰ ▹ G′ ° ⁰ ° ⁰ ^ _ ) (PE.sym F≡F') A≡B))) K≡M))

[IdExtShape]U ⊢Γ _ _ (Πᵥ (Πᵣ % .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F₁ G₁ [[ ⊢A₁ , ⊢ΠF₁G₁ , D₁ ]] ⊢F₁ ⊢G₁ A₁≡A₁ [F₁] [G₁] G₁-ext)
                         (Πᵣ ! .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F₂ G₂ [[ ⊢A₂ , ⊢ΠF₂G₂ , D₂ ]] ⊢F₂ ⊢G₂ A₂≡A₂ [F₂] [G₂] G₂-ext))
                      (Π₌ F′ G′ D′ A≡B [F≡F′] [G≡G′])
                 _ _ (Πᵥ _ _) (Π₌ F′₁ G′₁ D′₁ A≡B₁ [F≡F′]₁ [G≡G′]₁) =
  let ΠFG′≡ΠFG′₁ = whrDet* (D₂ , Πₙ) (D′ , Πₙ)
      F′≡F′₁ , rF≡rF′ , _ , G′≡G′₁ , _  = Π-PE-injectivity ΠFG′≡ΠFG′₁
  in ⊥-elim (!≢% rF≡rF′)

[IdExtShape]U ⊢Γ _ _ (Πᵥ (Πᵣ ! .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F₁ G₁ [[ ⊢A₁ , ⊢ΠF₁G₁ , D₁ ]] ⊢F₁ ⊢G₁ A₁≡A₁ [F₁] [G₁] G₁-ext)
                         (Πᵣ % .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F₂ G₂ [[ ⊢A₂ , ⊢ΠF₂G₂ , D₂ ]] ⊢F₂ ⊢G₂ A₂≡A₂ [F₂] [G₂] G₂-ext))
                      (Π₌ F′ G′ D′ A≡B [F≡F′] [G≡G′])
                 _ _ (Πᵥ _ _) (Π₌ F′₁ G′₁ D′₁ A≡B₁ [F≡F′]₁ [G≡G′]₁) =
  let ΠFG′≡ΠFG′₁ = whrDet* (D₂ , Πₙ) (D′ , Πₙ)
      F′≡F′₁ , rF≡rF′ , _ , G′≡G′₁ , _  = Π-PE-injectivity ΠFG′≡ΠFG′₁
  in ⊥-elim (!≢% (PE.sym rF≡rF′))

[IdExtShape]U ⊢Γ _ _ (Πᵥ _ _)
                      (Π₌ F′ G′ D′ A≡B [F≡F′] [G≡G′])
                 _ _ (Πᵥ (Πᵣ % .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F₁ G₁ [[ ⊢A₁ , ⊢ΠF₁G₁ , D₁ ]] ⊢F₁ ⊢G₁ A₁≡A₁ [F₁] [G₁] G₁-ext)
                         (Πᵣ ! .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F₂ G₂ [[ ⊢A₂ , ⊢ΠF₂G₂ , D₂ ]] ⊢F₂ ⊢G₂ A₂≡A₂ [F₂] [G₂] G₂-ext)) (Π₌ F′₁ G′₁ D′₁ A≡B₁ [F≡F′]₁ [G≡G′]₁) =
  let ΠFG′≡ΠFG′₁ = whrDet* (D₂ , Πₙ) (D′₁ , Πₙ)
      F′≡F′₁ , rF≡rF′ , _ , G′≡G′₁ , _  = Π-PE-injectivity ΠFG′≡ΠFG′₁
  in ⊥-elim (!≢% rF≡rF′)

[IdExtShape]U ⊢Γ _ _ (Πᵥ _ _)
                      (Π₌ F′ G′ D′ A≡B [F≡F′] [G≡G′])
                 _ _ (Πᵥ (Πᵣ ! .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F₁ G₁ [[ ⊢A₁ , ⊢ΠF₁G₁ , D₁ ]] ⊢F₁ ⊢G₁ A₁≡A₁ [F₁] [G₁] G₁-ext)
                         (Πᵣ % .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F₂ G₂ [[ ⊢A₂ , ⊢ΠF₂G₂ , D₂ ]] ⊢F₂ ⊢G₂ A₂≡A₂ [F₂] [G₂] G₂-ext)) (Π₌ F′₁ G′₁ D′₁ A≡B₁ [F≡F′]₁ [G≡G′]₁) =
  let ΠFG′≡ΠFG′₁ = whrDet* (D₂ , Πₙ) (D′₁ , Πₙ)
      F′≡F′₁ , rF≡rF′ , _ , G′≡G′₁ , _  = Π-PE-injectivity ΠFG′≡ΠFG′₁
  in ⊥-elim (!≢% (PE.sym rF≡rF′))

[IdExtShape]U ⊢Γ _ _ (Πᵥ (Πᵣ ! .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F₁ G₁ [[ ⊢A₁ , ⊢ΠF₁G₁ , D₁ ]] ⊢F₁ ⊢G₁ A₁≡A₁ [F₁] [G₁] G₁-ext)
                         (Πᵣ ! .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F₂ G₂ [[ ⊢A₂ , ⊢ΠF₂G₂ , D₂ ]] ⊢F₂ ⊢G₂ A₂≡A₂ [F₂] [G₂] G₂-ext))
                      (Π₌ F′ G′ D′ A≡B [F≡F′] [G≡G′])
                 _ _ (Πᵥ (Πᵣ % .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F₃ G₃ [[ ⊢A₃ , ⊢ΠF₃G₃ , D₃ ]] ⊢F₃ ⊢G₃ A₃≡A₃ [F₃] [G₃] G₃-ext)
                         (Πᵣ % .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F₄ G₄ [[ ⊢A₄ , ⊢ΠF₄G₄ , D₄ ]] ⊢F₄ ⊢G₄ A₄≡A₄ [F₄] [G₄] G₄-ext)) (Π₌ F′₁ G′₁ D′₁ A≡B₁ [F≡F′]₁ [G≡G′]₁) =
  trans⇒* (univ⇒* (IdURed*Term′ (un-univ ⊢A₂) (un-univ ⊢ΠF₂G₂) (un-univ⇒* D₂) (un-univ ⊢A₄)))
                        (trans⇒* (univ⇒* (IdUΠRed*Term′ (un-univ ⊢F₂) (un-univ ⊢G₂) (un-univ ⊢A₄) (un-univ ⊢ΠF₄G₄) (un-univ⇒* D₄)))
                                 (univ (Id-U-ΠΠ!% !≢% (un-univ ⊢F₂) (un-univ ⊢G₂) (un-univ ⊢F₄) (un-univ ⊢G₄)) ⇨ id (univ (Emptyⱼ ⊢Γ))))

[IdExtShape]U ⊢Γ _ _ (Πᵥ (Πᵣ % .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F₁ G₁ [[ ⊢A₁ , ⊢ΠF₁G₁ , D₁ ]] ⊢F₁ ⊢G₁ A₁≡A₁ [F₁] [G₁] G₁-ext)
                         (Πᵣ % .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F₂ G₂ [[ ⊢A₂ , ⊢ΠF₂G₂ , D₂ ]] ⊢F₂ ⊢G₂ A₂≡A₂ [F₂] [G₂] G₂-ext))
                      (Π₌ F′ G′ D′ A≡B [F≡F′] [G≡G′])
                 _ _ (Πᵥ (Πᵣ ! .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F₃ G₃ [[ ⊢A₃ , ⊢ΠF₃G₃ , D₃ ]] ⊢F₃ ⊢G₃ A₃≡A₃ [F₃] [G₃] G₃-ext)
                         (Πᵣ ! .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F₄ G₄ [[ ⊢A₄ , ⊢ΠF₄G₄ , D₄ ]] ⊢F₄ ⊢G₄ A₄≡A₄ [F₄] [G₄] G₄-ext)) (Π₌ F′₁ G′₁ D′₁ A≡B₁ [F≡F′]₁ [G≡G′]₁) =
  trans⇒* (univ⇒* (IdURed*Term′ (un-univ ⊢A₂) (un-univ ⊢ΠF₂G₂) (un-univ⇒* D₂) (un-univ ⊢A₄)))
                        (trans⇒* (univ⇒* (IdUΠRed*Term′ (un-univ ⊢F₂) (un-univ ⊢G₂) (un-univ ⊢A₄) (un-univ ⊢ΠF₄G₄) (un-univ⇒* D₄)))
                                 (univ (Id-U-ΠΠ!% (λ e → !≢% (PE.sym e)) (un-univ ⊢F₂) (un-univ ⊢G₂) (un-univ ⊢F₄) (un-univ ⊢G₄)) ⇨ id (univ (Emptyⱼ ⊢Γ))))

[IdExtShape]U {A₁} {A₂} {A₃} {A₄} {Γ}  ⊢Γ _ _
                   (Πᵥ (Πᵣ ! .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F₁ G₁ [[ ⊢A₁ , ⊢ΠF₁G₁ , D₁ ]] ⊢F₁ ⊢G₁ A₁≡A₁ [F₁] [G₁] G₁-ext)
                   (Πᵣ ! .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F₂ G₂ [[ ⊢A₂ , ⊢ΠF₂G₂ , D₂ ]] ⊢F₂ ⊢G₂ A₂≡A₂ [F₂] [G₂] G₂-ext))
                   (Π₌ F₂′ G₂′ D₂′ A₁≡A₂′ [F₁≡F₂′] [G₁≡G₂′])
               _ _ (Πᵥ (Πᵣ ! .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F₃ G₃ [[ ⊢A₃ , ⊢ΠF₃G₃ , D₃ ]] ⊢F₃ ⊢G₃ A₃≡A₃ [F₃] [G₃] G₃-ext)
                   (Πᵣ ! .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F₄ G₄ [[ ⊢A₄ , ⊢ΠF₄G₄ , D₄ ]] ⊢F₄ ⊢G₄ A₄≡A₄ [F₄] [G₄] G₄-ext))
                   (Π₌ F₄′ G₄′ D₄′ A₃≡A₄′ [F₃≡F₄′] [G₃≡G₄′]) =
    ∃₌ (Id (U ⁰) F₂ F₄) (E₂.IdGG₁ (step id) (var 0))
    E₂.D∃ ∃₁≡∃₂
    [IdFF₁≡IdFF₂]
    (λ {ρ} {Δ} {e} [ρ] ⊢Δ [e] → irrelevanceEq″ (PE.sym (E₁.wksubst-IdTel ρ e)) (PE.sym (E₂.wksubst-IdTel ρ e)) PE.refl PE.refl
      (E₁.[IdGG₁] [ρ] ⊢Δ [e]) (PE.subst (λ X → Δ ⊩⟨ ι ¹ ⟩ X ^ [ % , ι ¹ ]) (PE.sym (E₁.wksubst-IdTel ρ e)) (E₁.[IdGG₁] [ρ] ⊢Δ [e]))
      ([IdGG₁≡IdGG₂] [ρ] ⊢Δ [e]))
  where
    Π≡Π = whrDet* (D₂ , Whnf.Πₙ) (D₂′ , Whnf.Πₙ)
    F₂≡F₂′ = let x , _ , _ , _ , _ = Π-PE-injectivity Π≡Π in x
    G₂≡G₂′ = let _ , _ , _ , x , _ = Π-PE-injectivity Π≡Π in x
    Π≡Π′ = whrDet* (D₄ , Whnf.Πₙ) (D₄′ , Whnf.Πₙ)
    F₄≡F₄′ = let x , _ , _ , _ , _ = Π-PE-injectivity Π≡Π′ in x
    G₄≡G₄′ = let _ , _ , _ , x , _ = Π-PE-injectivity Π≡Π′ in x

    A₁≡A₂ = PE.subst₂ (λ X Y → Γ ⊢ Π F₁ ^ ! ° ⁰ ▹ G₁ ° ⁰ ° ⁰ ≅ Π X ^ ! ° ⁰ ▹ Y ° ⁰ ° ⁰ ^ [ ! , ι ⁰ ]) (PE.sym F₂≡F₂′) (PE.sym G₂≡G₂′) A₁≡A₂′
    A₃≡A₄ = PE.subst₂ (λ X Y → Γ ⊢ Π F₃ ^ ! ° ⁰ ▹ G₃ ° ⁰ ° ⁰ ≅ Π X ^ ! ° ⁰ ▹ Y ° ⁰ ° ⁰ ^ [ ! , ι ⁰ ]) (PE.sym F₄≡F₄′) (PE.sym G₄≡G₄′) A₃≡A₄′
    [F₁≡F₂] = PE.subst (λ X → ∀ {ρ Δ} → ([ρ] : ρ Twk.∷ Δ ⊆ Γ) (⊢Δ : ⊢ Δ) → Δ ⊩⟨ ι ⁰ ⟩ wk ρ F₁ ≡ wk ρ X ^ [ ! , ι ⁰ ] / [F₁] [ρ] ⊢Δ)
                       (PE.sym F₂≡F₂′) [F₁≡F₂′]
    [F₃≡F₄] = PE.subst (λ X → ∀ {ρ Δ} → ([ρ] : ρ Twk.∷ Δ ⊆ Γ) (⊢Δ : ⊢ Δ) → Δ ⊩⟨ ι ⁰ ⟩ wk ρ F₃ ≡ wk ρ X ^ [ ! , ι ⁰ ] / [F₃] [ρ] ⊢Δ)
                       (PE.sym F₄≡F₄′) [F₃≡F₄′]
    [G₁≡G₂] = PE.subst (λ X → ∀ {ρ Δ a} → ([ρ] : ρ Twk.∷ Δ ⊆ Γ) (⊢Δ : ⊢ Δ)
                              → ([a] : Δ ⊩⟨ ι ⁰ ⟩ a ∷ wk ρ F₁ ^ [ ! , ι ⁰ ] / [F₁] [ρ] ⊢Δ)
                              → Δ ⊩⟨ ι ⁰ ⟩ wk (lift ρ) G₁ [ a ] ≡ wk (lift ρ) X [ a ] ^ [ ! , ι ⁰ ] / [G₁] [ρ] ⊢Δ [a])
                       (PE.sym G₂≡G₂′) [G₁≡G₂′]
    [G₃≡G₄] = PE.subst (λ X → ∀ {ρ Δ a} → ([ρ] : ρ Twk.∷ Δ ⊆ Γ) (⊢Δ : ⊢ Δ)
                              → ([a] : Δ ⊩⟨ ι ⁰ ⟩ a ∷ wk ρ F₃ ^ [ ! , ι ⁰ ] / [F₃] [ρ] ⊢Δ)
                              → Δ ⊩⟨ ι ⁰ ⟩ wk (lift ρ) G₃ [ a ] ≡ wk (lift ρ) X [ a ] ^ [ ! , ι ⁰ ] / [G₃] [ρ] ⊢Δ [a])
                       (PE.sym G₄≡G₄′) [G₃≡G₄′]

    open IdTypeU-lemmas-2 ⊢Γ ⊢A₁ ⊢ΠF₁G₁ D₁ ⊢F₁ ⊢G₁ A₁≡A₁ [F₁] [G₁] G₁-ext
      ⊢A₂ ⊢ΠF₂G₂ D₂ ⊢F₂ ⊢G₂ A₂≡A₂ [F₂] [G₂] G₂-ext
      ⊢A₃ ⊢ΠF₃G₃ D₃ ⊢F₃ ⊢G₃ A₃≡A₃ [F₃] [G₃] G₃-ext
      ⊢A₄ ⊢ΠF₄G₄ D₄ ⊢F₄ ⊢G₄ A₄≡A₄ [F₄] [G₄] G₄-ext
      A₁≡A₂ A₃≡A₄ [F₁≡F₂] [F₃≡F₄] [G₁≡G₂] [G₃≡G₄]
      (λ [ρ] ⊢Δ → [Id]U ⊢Δ ([F₁] [ρ] ⊢Δ) ([F₃] [ρ] ⊢Δ))
      (λ [ρ] ⊢Δ [x] [y] → [Id]U ⊢Δ ([G₁] [ρ] ⊢Δ [x]) ([G₃] [ρ] ⊢Δ [y]))
      (λ [ρ] ⊢Δ → [Id]U ⊢Δ ([F₂] [ρ] ⊢Δ) ([F₄] [ρ] ⊢Δ))
      (λ [ρ] ⊢Δ [x] [y] → [Id]U ⊢Δ ([G₂] [ρ] ⊢Δ [x]) ([G₄] [ρ] ⊢Δ [y]))
      (λ [ρ] ⊢Δ [x] [x′] [x≡x′] [y] [y′] [y≡y′] →
        [IdExt]U ⊢Δ ([G₁] [ρ] ⊢Δ [x]) ([G₁] [ρ] ⊢Δ [x′]) (G₁-ext [ρ] ⊢Δ [x] [x′] [x≡x′]) ([G₃] [ρ] ⊢Δ [y]) ([G₃] [ρ] ⊢Δ [y′]) (G₃-ext [ρ] ⊢Δ [y] [y′] [y≡y′]))
      (λ [ρ] ⊢Δ [x] [x′] [x≡x′] [y] [y′] [y≡y′] →
        [IdExt]U ⊢Δ ([G₂] [ρ] ⊢Δ [x]) ([G₂] [ρ] ⊢Δ [x′]) (G₂-ext [ρ] ⊢Δ [x] [x′] [x≡x′]) ([G₄] [ρ] ⊢Δ [y]) ([G₄] [ρ] ⊢Δ [y′]) (G₄-ext [ρ] ⊢Δ [y] [y′] [y≡y′]))
      (λ [ρ] ⊢Δ → [IdExt]U ⊢Δ ([F₁] [ρ] ⊢Δ) ([F₂] [ρ] ⊢Δ) ([F₁≡F₂] [ρ] ⊢Δ) ([F₃] [ρ] ⊢Δ) ([F₄] [ρ] ⊢Δ) ([F₃≡F₄] [ρ] ⊢Δ))
      (λ [ρ] ⊢Δ [x₁] [x₂] [G₁x₁≡G₂x₂] [x₃] [x₄] [G₃x₃≡G₄x₄] → [IdExt]U ⊢Δ ([G₁] [ρ] ⊢Δ [x₁]) ([G₂] [ρ] ⊢Δ [x₂]) [G₁x₁≡G₂x₂] ([G₃] [ρ] ⊢Δ [x₃]) ([G₄] [ρ] ⊢Δ [x₄]) [G₃x₃≡G₄x₄])

[IdExtShape]U {A₁} {A₂} {A₃} {A₄} {Γ}  ⊢Γ _ _
                   (Πᵥ (Πᵣ % .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F₁ G₁ [[ ⊢A₁ , ⊢ΠF₁G₁ , D₁ ]] ⊢F₁ ⊢G₁ A₁≡A₁ [F₁] [G₁] G₁-ext)
                   (Πᵣ % .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F₂ G₂ [[ ⊢A₂ , ⊢ΠF₂G₂ , D₂ ]] ⊢F₂ ⊢G₂ A₂≡A₂ [F₂] [G₂] G₂-ext))
                   (Π₌ F₂′ G₂′ D₂′ A₁≡A₂′ [F₁≡F₂′] [G₁≡G₂′])
               _ _ (Πᵥ (Πᵣ % .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F₃ G₃ [[ ⊢A₃ , ⊢ΠF₃G₃ , D₃ ]] ⊢F₃ ⊢G₃ A₃≡A₃ [F₃] [G₃] G₃-ext)
                   (Πᵣ % .⁰ .⁰ (≡is≤ PE.refl) (≡is≤ PE.refl) F₄ G₄ [[ ⊢A₄ , ⊢ΠF₄G₄ , D₄ ]] ⊢F₄ ⊢G₄ A₄≡A₄ [F₄] [G₄] G₄-ext))
                   (Π₌ F₄′ G₄′ D₄′ A₃≡A₄′ [F₃≡F₄′] [G₃≡G₄′]) =
    ∃₌ (Id (SProp ⁰) F₂ F₄) (E₂.IdGG₁ (step id) (var 0))
    E₂.D∃ ∃₁≡∃₂
    [IdFF₁≡IdFF₂]
    (λ {ρ} {Δ} {e} [ρ] ⊢Δ [e] → irrelevanceEq″ (PE.sym (E₁.wksubst-IdTel ρ e)) (PE.sym (E₂.wksubst-IdTel ρ e)) PE.refl PE.refl
      (E₁.[IdGG₁] [ρ] ⊢Δ [e]) (PE.subst (λ X → Δ ⊩⟨ ι ¹ ⟩ X ^ [ % , ι ¹ ]) (PE.sym (E₁.wksubst-IdTel ρ e)) (E₁.[IdGG₁] [ρ] ⊢Δ [e]))
      ([IdGG₁≡IdGG₂] [ρ] ⊢Δ [e]))
  where
    Π≡Π = whrDet* (D₂ , Whnf.Πₙ) (D₂′ , Whnf.Πₙ)
    F₂≡F₂′ = let x , _ , _ , _ , _ = Π-PE-injectivity Π≡Π in x
    G₂≡G₂′ = let _ , _ , _ , x , _ = Π-PE-injectivity Π≡Π in x
    Π≡Π′ = whrDet* (D₄ , Whnf.Πₙ) (D₄′ , Whnf.Πₙ)
    F₄≡F₄′ = let x , _ , _ , _ , _ = Π-PE-injectivity Π≡Π′ in x
    G₄≡G₄′ = let _ , _ , _ , x , _ = Π-PE-injectivity Π≡Π′ in x

    A₁≡A₂ = PE.subst₂ (λ X Y → Γ ⊢ Π F₁ ^ % ° ⁰ ▹ G₁ ° ⁰ ° ⁰ ≅ Π X ^ % ° ⁰ ▹ Y ° ⁰ ° ⁰ ^ [ ! , ι ⁰ ]) (PE.sym F₂≡F₂′) (PE.sym G₂≡G₂′) A₁≡A₂′
    A₃≡A₄ = PE.subst₂ (λ X Y → Γ ⊢ Π F₃ ^ % ° ⁰ ▹ G₃ ° ⁰ ° ⁰ ≅ Π X ^ % ° ⁰ ▹ Y ° ⁰ ° ⁰ ^ [ ! , ι ⁰ ]) (PE.sym F₄≡F₄′) (PE.sym G₄≡G₄′) A₃≡A₄′
    [F₁≡F₂] = PE.subst (λ X → ∀ {ρ Δ} → ([ρ] : ρ Twk.∷ Δ ⊆ Γ) (⊢Δ : ⊢ Δ) → Δ ⊩⟨ ι ⁰ ⟩ wk ρ F₁ ≡ wk ρ X ^ [ % , ι ⁰ ] / [F₁] [ρ] ⊢Δ)
                       (PE.sym F₂≡F₂′) [F₁≡F₂′]
    [F₃≡F₄] = PE.subst (λ X → ∀ {ρ Δ} → ([ρ] : ρ Twk.∷ Δ ⊆ Γ) (⊢Δ : ⊢ Δ) → Δ ⊩⟨ ι ⁰ ⟩ wk ρ F₃ ≡ wk ρ X ^ [ % , ι ⁰ ] / [F₃] [ρ] ⊢Δ)
                       (PE.sym F₄≡F₄′) [F₃≡F₄′]
    [G₁≡G₂] = PE.subst (λ X → ∀ {ρ Δ a} → ([ρ] : ρ Twk.∷ Δ ⊆ Γ) (⊢Δ : ⊢ Δ)
                              → ([a] : Δ ⊩⟨ ι ⁰ ⟩ a ∷ wk ρ F₁ ^ [ % , ι ⁰ ] / [F₁] [ρ] ⊢Δ)
                              → Δ ⊩⟨ ι ⁰ ⟩ wk (lift ρ) G₁ [ a ] ≡ wk (lift ρ) X [ a ] ^ [ ! , ι ⁰ ] / [G₁] [ρ] ⊢Δ [a])
                       (PE.sym G₂≡G₂′) [G₁≡G₂′]
    [G₃≡G₄] = PE.subst (λ X → ∀ {ρ Δ a} → ([ρ] : ρ Twk.∷ Δ ⊆ Γ) (⊢Δ : ⊢ Δ)
                              → ([a] : Δ ⊩⟨ ι ⁰ ⟩ a ∷ wk ρ F₃ ^ [ % , ι ⁰ ] / [F₃] [ρ] ⊢Δ)
                              → Δ ⊩⟨ ι ⁰ ⟩ wk (lift ρ) G₃ [ a ] ≡ wk (lift ρ) X [ a ] ^ [ ! , ι ⁰ ] / [G₃] [ρ] ⊢Δ [a])
                       (PE.sym G₄≡G₄′) [G₃≡G₄′]

    open IdTypeU-lemmas-2 ⊢Γ ⊢A₁ ⊢ΠF₁G₁ D₁ ⊢F₁ ⊢G₁ A₁≡A₁ [F₁] [G₁] G₁-ext
      ⊢A₂ ⊢ΠF₂G₂ D₂ ⊢F₂ ⊢G₂ A₂≡A₂ [F₂] [G₂] G₂-ext
      ⊢A₃ ⊢ΠF₃G₃ D₃ ⊢F₃ ⊢G₃ A₃≡A₃ [F₃] [G₃] G₃-ext
      ⊢A₄ ⊢ΠF₄G₄ D₄ ⊢F₄ ⊢G₄ A₄≡A₄ [F₄] [G₄] G₄-ext
      A₁≡A₂ A₃≡A₄ [F₁≡F₂] [F₃≡F₄] [G₁≡G₂] [G₃≡G₄]
      (λ [ρ] ⊢Δ → [Id]SProp ⊢Δ ([F₁] [ρ] ⊢Δ) ([F₃] [ρ] ⊢Δ))
      (λ [ρ] ⊢Δ [x] [y] → [Id]U ⊢Δ ([G₁] [ρ] ⊢Δ [x]) ([G₃] [ρ] ⊢Δ [y]))
      (λ [ρ] ⊢Δ → [Id]SProp ⊢Δ ([F₂] [ρ] ⊢Δ) ([F₄] [ρ] ⊢Δ))
      (λ [ρ] ⊢Δ [x] [y] → [Id]U ⊢Δ ([G₂] [ρ] ⊢Δ [x]) ([G₄] [ρ] ⊢Δ [y]))
      (λ [ρ] ⊢Δ [x] [x′] [x≡x′] [y] [y′] [y≡y′] →
        [IdExt]U ⊢Δ ([G₁] [ρ] ⊢Δ [x]) ([G₁] [ρ] ⊢Δ [x′]) (G₁-ext [ρ] ⊢Δ [x] [x′] [x≡x′]) ([G₃] [ρ] ⊢Δ [y]) ([G₃] [ρ] ⊢Δ [y′]) (G₃-ext [ρ] ⊢Δ [y] [y′] [y≡y′]))
      (λ [ρ] ⊢Δ [x] [x′] [x≡x′] [y] [y′] [y≡y′] →
        [IdExt]U ⊢Δ ([G₂] [ρ] ⊢Δ [x]) ([G₂] [ρ] ⊢Δ [x′]) (G₂-ext [ρ] ⊢Δ [x] [x′] [x≡x′]) ([G₄] [ρ] ⊢Δ [y]) ([G₄] [ρ] ⊢Δ [y′]) (G₄-ext [ρ] ⊢Δ [y] [y′] [y≡y′]))
      (λ [ρ] ⊢Δ → [IdExt]SProp ⊢Δ ([F₁] [ρ] ⊢Δ) ([F₂] [ρ] ⊢Δ) ([F₁≡F₂] [ρ] ⊢Δ) ([F₃] [ρ] ⊢Δ) ([F₄] [ρ] ⊢Δ) ([F₃≡F₄] [ρ] ⊢Δ))
      (λ [ρ] ⊢Δ [x₁] [x₂] [G₁x₁≡G₂x₂] [x₃] [x₄] [G₃x₃≡G₄x₄] → [IdExt]U ⊢Δ ([G₁] [ρ] ⊢Δ [x₁]) ([G₂] [ρ] ⊢Δ [x₂]) [G₁x₁≡G₂x₂] ([G₃] [ρ] ⊢Δ [x₃]) ([G₄] [ρ] ⊢Δ [x₄]) [G₃x₃≡G₄x₄])

[IdExt]U ⊢Γ [A] [A′] [A≡A′] [B] [B′] [B≡B′] = [IdExtShape]U ⊢Γ [A] [A′] (goodCases [A] [A′] [A≡A′]) [A≡A′] [B] [B′] (goodCases [B] [B′] [B≡B′]) [B≡B′]

Ugen' : ∀ {Γ rU l} → (⊢Γ : ⊢ Γ) →  ((next l) LogRel.⊩¹U logRelRec (next l) ^ Γ) (Univ rU l) (next l)
Ugen' {Γ} {rU} {⁰} ⊢Γ = Uᵣ rU ⁰ emb< PE.refl ((idRed:*: (Ugenⱼ ⊢Γ)))
Ugen' {Γ} {rU} {¹} ⊢Γ = Uᵣ rU ¹ ∞< PE.refl (idRed:*: (Uⱼ ⊢Γ))

[Id]UGen : ∀ {A t u Γ l}
         (⊢Γ : ⊢ Γ)
         ([A] : (l LogRel.⊩¹U logRelRec l ^ Γ) A (ι ¹))
         ([t] : Γ ⊩⟨ l ⟩ t ∷ A ^ [ ! , ι ¹ ] / Uᵣ [A])
         ([u] : Γ ⊩⟨ l ⟩ u ∷ A ^ [ ! , ι ¹ ] / Uᵣ [A])
       → Γ ⊩⟨ l ⟩ Id A t u ^ [ % , ι ¹ ]
[Id]UGen {A} {t} {u} {Γ} {ι .¹} ⊢Γ (Uᵣ ! ⁰ emb< PE.refl [[ ⊢A , ⊢B , D ]]) (Uₜ K d typeK K≡K [t]) (Uₜ M d₁ typeM M≡M [u]) =
  let
    [t0] : Γ ⊩⟨ ι ⁰ ⟩ t ^ [ ! , ι ⁰ ]
    [t0] = PE.subst (λ X → Γ ⊩⟨ ι ⁰ ⟩ X ^ [ ! , ι ⁰ ]) (wk-id t) ([t] Twk.id ⊢Γ)
    [u0] = PE.subst (λ X → Γ ⊩⟨ ι ⁰ ⟩ X ^ [ ! , ι ⁰ ]) (wk-id u) ([u] Twk.id ⊢Γ)
    ⊢tA = conv (un-univ (escape [t0])) (sym (subset* D))
    ⊢uA = conv (un-univ (escape [u0])) (sym (subset* D))
  in proj₁ (redSubst* (IdRed* ⊢tA ⊢uA D) ([Id]U ⊢Γ [t0] [u0]))

[Id]UGen {A} {t} {u} {Γ} {ι .¹} ⊢Γ (Uᵣ % ⁰ emb< PE.refl [[ ⊢A , ⊢B , D ]]) (Uₜ K d typeK K≡K [t]) (Uₜ M d₁ typeM M≡M [u]) =
  let
    [t0] : Γ ⊩⟨ ι ⁰ ⟩ t ^ [ % , ι ⁰ ]
    [t0] = PE.subst (λ X → Γ ⊩⟨ ι ⁰ ⟩ X ^ [ % , ι ⁰ ]) (wk-id t) ([t] Twk.id ⊢Γ)
    [u0] = PE.subst (λ X → Γ ⊩⟨ ι ⁰ ⟩ X ^ [ % , ι ⁰ ]) (wk-id u) ([u] Twk.id ⊢Γ)
    ⊢tA = conv (un-univ (escape [t0])) (sym (subset* D))
    ⊢uA = conv (un-univ (escape [u0])) (sym (subset* D))
  in proj₁ (redSubst* (IdRed* ⊢tA ⊢uA D) ([Id]SProp ⊢Γ [t0] [u0]))

[IdExt]UGen : ∀ {A B t v u w Γ l l'}
         (⊢Γ : ⊢ Γ)
         ([A] : (l LogRel.⊩¹U logRelRec l ^ Γ) A (ι ¹))
         ([B] : (l' LogRel.⊩¹U logRelRec l' ^ Γ) B (ι ¹))
         ([A≡B] : Γ ⊩⟨ l ⟩ A ≡ B ^ [ ! , ι ¹ ] / Uᵣ [A])
         ([t] : Γ ⊩⟨ l ⟩ t ∷ A ^ [ ! , ι ¹ ] / Uᵣ [A])
         ([v] : Γ ⊩⟨ l' ⟩ v ∷ B ^ [ ! , ι ¹ ] / Uᵣ [B])
         ([t≡v] : Γ ⊩⟨ l ⟩ t ≡ v ∷ A ^ [ ! , ι ¹ ] / Uᵣ [A])
         ([u] : Γ ⊩⟨ l ⟩ u ∷ A ^ [ ! , ι ¹ ] / Uᵣ [A])
         ([w] : Γ ⊩⟨ l' ⟩ w ∷ B ^ [ ! , ι ¹ ] / Uᵣ [B])
         ([u≡w] : Γ ⊩⟨ l ⟩ u ≡ w ∷ A ^ [ ! , ι ¹ ] / Uᵣ [A])
       → Γ ⊩⟨ l ⟩ Id A t u ≡ Id B v w ^ [ % , ι ¹ ] / [Id]UGen ⊢Γ [A] [t] [u]
[IdExt]UGen {A} {B} {t} {v} {u} {w} {Γ} {.(ι ¹)} {.(ι ¹)} ⊢Γ (Uᵣ ! ⁰ emb< PE.refl d) (Uᵣ r₁ ⁰ emb< PE.refl d₁) [A≡B] [t] [v] [t≡v] [u] [w] [u≡w] =
  let U≡U = whrDet* (red d₁ , Uₙ) ([A≡B] , Uₙ)
      r≡r , _ = Univ-PE-injectivity U≡U
      [UA] = Uᵣ ! ⁰ emb< PE.refl d
      [UB] = Uᵣ r₁ ⁰ emb< PE.refl d₁
      [U] = Ugen' ⊢Γ
      [U]' = Ugen' ⊢Γ
      [UA]' , [UAeq] = redSubst* (red d) (Uᵣ [U])
      [UB]' , [UBeq] = redSubst* (PE.subst (λ X → Γ ⊢ _ ⇒* Univ X _ ^ _) r≡r (red d₁)) (Uᵣ [U]')
      [t]′ = convTerm₁ {t = t} [UA]' (Uᵣ [U]) [UAeq] (irrelevanceTerm (Uᵣ [UA]) [UA]' [t])
      [t^] = univEq (Uᵣ [U]) [t]′
      [v]′ = convTerm₁ {t = v} [UB]' (Uᵣ [U]) [UBeq] (irrelevanceTerm (Uᵣ [UB]) [UB]' [v])
      [v^] = univEq (Uᵣ [U]) [v]′
      [t≡v]′ = convEqTerm₁ {t = t} {u = v} [UA]' (Uᵣ [U]) [UAeq] (irrelevanceEqTerm (Uᵣ [UA]) [UA]' [t≡v])
      [t≡v^] = univEqEq (Uᵣ [U]) [t^] [t≡v]′
      [u]′ = convTerm₁ {t = u} [UA]' (Uᵣ [U]) [UAeq] (irrelevanceTerm (Uᵣ [UA]) [UA]' [u])
      [u^] = univEq (Uᵣ [U]) [u]′
      [w]′ = convTerm₁ {t = w} [UB]' (Uᵣ [U]) [UBeq] (irrelevanceTerm (Uᵣ [UB]) [UB]'  [w])
      [w^] = univEq (Uᵣ [U]) [w]′
      [u≡w]′ = convEqTerm₁ {t = u} {u = w} [UA]' (Uᵣ [U]) [UAeq] (irrelevanceEqTerm (Uᵣ [UA]) [UA]' [u≡w])
      [u≡w^] = univEqEq (Uᵣ [U]) [u^] [u≡w]′
      X = irrelevanceEq {A = Id (U ⁰) t u} {B = Id (U ⁰) v w} ([Id]U ⊢Γ [t^] [u^]) ([Id]UGen ⊢Γ [U] [t]′ [u]′) ([IdExt]U ⊢Γ [t^] [v^] [t≡v^] [u^] [w^] [u≡w^])
      [IdA] , [IdA≡U] = redSubst* (IdRed* (escapeTerm (Uᵣ [UA]) [t]) (escapeTerm (Uᵣ [UA]) [u]) (red d)) ([Id]UGen ⊢Γ [U] [t]′ [u]′)
      [IdB] , [IdB≡U] = redSubst* (IdRed* (escapeTerm (Uᵣ [UB]) [v]) (escapeTerm (Uᵣ [UB]) [w]) (PE.subst (λ X → Γ ⊢ _ ⇒* Univ X _ ^ _) r≡r (red d₁))) ([Id]UGen ⊢Γ [U] [v]′ [w]′)
      [IdA≡U]′ = irrelevanceEq {A = Id A t u} {B = Id (U ⁰) t u} [IdA] ([Id]UGen ⊢Γ [UA] [t] [u]) [IdA≡U]
      [IdB≡U]′ = irrelevanceEq {A = Id B v w} {B = Id (U ⁰) v w} [IdB] ([Id]UGen ⊢Γ [UB] [v] [w]) [IdB≡U]
  in transEq {A = Id A t u} {B = Id (U _) t u} {C = Id B v w}  ([Id]UGen ⊢Γ [UA] [t] [u]) ([Id]UGen ⊢Γ [U] [t]′ [u]′) ([Id]UGen ⊢Γ [UB] [v] [w])
                  [IdA≡U]′
                  (transEq {A = Id (U _) t u} {B = Id (U _) v w} {C = Id B v w} ([Id]UGen ⊢Γ [U] [t]′ [u]′) ([Id]UGen ⊢Γ [U] [v]′ [w]′) ([Id]UGen ⊢Γ [UB] [v] [w])
                                   X (symEq {A = Id B v w} {B = Id (U _) v w} ([Id]UGen ⊢Γ [UB] [v] [w]) ([Id]UGen ⊢Γ [U] [v]′ [w]′) [IdB≡U]′))

[IdExt]UGen {A} {B} {t} {v} {u} {w} {Γ} {.(ι ¹)} {.(ι ¹)} ⊢Γ (Uᵣ % ⁰ emb< PE.refl d) (Uᵣ r₁ ⁰ emb< PE.refl d₁) [A≡B] [t] [v] [t≡v] [u] [w] [u≡w] =
  let U≡U = whrDet* (red d₁ , Uₙ) ([A≡B] , Uₙ)
      r≡r , _ = Univ-PE-injectivity U≡U
      [UA] = Uᵣ % ⁰ emb< PE.refl d
      [UB] = Uᵣ r₁ ⁰ emb< PE.refl d₁
      [U] = Ugen' ⊢Γ
      [U]' = Ugen' ⊢Γ
      [UA]' , [UAeq] = redSubst* (red d) (Uᵣ [U])
      [UB]' , [UBeq] = redSubst* (PE.subst (λ X → Γ ⊢ _ ⇒* Univ X _ ^ _) r≡r (red d₁)) (Uᵣ [U]')
      [t]′ = convTerm₁ {t = t} [UA]' (Uᵣ [U]) [UAeq] (irrelevanceTerm (Uᵣ [UA]) [UA]' [t])
      [t^] = univEq (Uᵣ [U]) [t]′
      [v]′ = convTerm₁ {t = v} [UB]' (Uᵣ [U]) [UBeq] (irrelevanceTerm (Uᵣ [UB]) [UB]' [v])
      [v^] = univEq (Uᵣ [U]) [v]′
      [t≡v]′ = convEqTerm₁ {t = t} {u = v} [UA]' (Uᵣ [U]) [UAeq] (irrelevanceEqTerm (Uᵣ [UA]) [UA]' [t≡v])
      [t≡v^] = univEqEq (Uᵣ [U]) [t^] [t≡v]′
      [u]′ = convTerm₁ {t = u} [UA]' (Uᵣ [U]) [UAeq] (irrelevanceTerm (Uᵣ [UA]) [UA]' [u])
      [u^] = univEq (Uᵣ [U]) [u]′
      [w]′ = convTerm₁ {t = w} [UB]' (Uᵣ [U]) [UBeq] (irrelevanceTerm (Uᵣ [UB]) [UB]'  [w])
      [w^] = univEq (Uᵣ [U]) [w]′
      [u≡w]′ = convEqTerm₁ {t = u} {u = w} [UA]' (Uᵣ [U]) [UAeq] (irrelevanceEqTerm (Uᵣ [UA]) [UA]' [u≡w])
      [u≡w^] = univEqEq (Uᵣ [U]) [u^] [u≡w]′
      X = irrelevanceEq {A = Id (SProp ⁰) t u} {B = Id (SProp ⁰) v w} ([Id]SProp ⊢Γ [t^] [u^]) ([Id]UGen ⊢Γ [U] [t]′ [u]′) ([IdExt]SProp ⊢Γ [t^] [v^] [t≡v^] [u^] [w^] [u≡w^])
      [IdA] , [IdA≡U] = redSubst* (IdRed* (escapeTerm (Uᵣ [UA]) [t]) (escapeTerm (Uᵣ [UA]) [u]) (red d)) ([Id]UGen ⊢Γ [U] [t]′ [u]′)
      [IdB] , [IdB≡U] = redSubst* (IdRed* (escapeTerm (Uᵣ [UB]) [v]) (escapeTerm (Uᵣ [UB]) [w]) (PE.subst (λ X → Γ ⊢ _ ⇒* Univ X _ ^ _) r≡r (red d₁))) ([Id]UGen ⊢Γ [U] [v]′ [w]′)
      [IdA≡U]′ = irrelevanceEq {A = Id A t u} {B = Id (SProp ⁰) t u} [IdA] ([Id]UGen ⊢Γ [UA] [t] [u]) [IdA≡U]
      [IdB≡U]′ = irrelevanceEq {A = Id B v w} {B = Id (SProp ⁰) v w} [IdB] ([Id]UGen ⊢Γ [UB] [v] [w]) [IdB≡U]
  in transEq {A = Id A t u} {B = Id (SProp _) t u} {C = Id B v w}  ([Id]UGen ⊢Γ [UA] [t] [u]) ([Id]UGen ⊢Γ [U] [t]′ [u]′) ([Id]UGen ⊢Γ [UB] [v] [w])
                  [IdA≡U]′
                  (transEq {A = Id (SProp _) t u} {B = Id (SProp _) v w} {C = Id B v w} ([Id]UGen ⊢Γ [U] [t]′ [u]′) ([Id]UGen ⊢Γ [U] [v]′ [w]′) ([Id]UGen ⊢Γ [UB] [v] [w])
                                   X (symEq {A = Id B v w} {B = Id (SProp _) v w} ([Id]UGen ⊢Γ [UB] [v] [w]) ([Id]UGen ⊢Γ [U] [v]′ [w]′) [IdB≡U]′))


module Haskell.Prim.Char where

open import Agda.Builtin.IO
open import Agda.Builtin.String
open import Agda.Builtin.Char
open import Agda.Builtin.Bool
open import Agda.Builtin.Int using (pos; negsuc)

open import Haskell.Prim
open import Haskell.Prim.Int
open import Haskell.Prim.Integer
open import Haskell.Prim.Enum
open import Haskell.Prim.Real

ord : Char -> Int
ord c = fromEnum ((pos ∘ primCharToNat) c)

chr1 : Integer -> Char
chr1 (pos n) = primNatToChar n
chr1 _ = '_'

chr : Int -> Char
chr n = chr1 (toInteger n)


open import Agda.Builtin.Nat

record R : Set where
  field
    x : Nat

open R {{...}}

f₁ : R

-- This is fine.
x ⦃ f₁ ⦄ = 0

-- WAS: THIS WORKS BUT MAKES NO SENSE!!!
_ : Nat
_ = f₁ {{ .x }}

-- Should raise an error.

-- Illegal hiding in postfix projection  ⦃ .x ⦄
-- when scope checking f₁ ⦃ .x ⦄


{-# IMPORT Issue223 #-}

data A : Set
{-# COMPILED_DECLARE_DATA A Issue223.A #-}
data B : Set
{-# COMPILED_DECLARE_DATA B Issue223.B #-}

data A where
  BA : B → A
{-# COMPILED_DATA A Issue223.A Issue223.BA #-}

data B where
  AB : A → B
  BB : B
{-# COMPILED_DATA B Issue223.B Issue223.AB Issue223.BB #-}


------------------------------------------------------------------------
-- An alternative backend
------------------------------------------------------------------------

-- Acknowledgements:
--
-- • The use of parsing "processes" is based on implementation C from
--   Koen Claessen's paper Parallel parsing processes.
--
-- • The idea to use toProc is due to Jean-Philippe Bernardy.

-- It is not obvious how to adapt this backend so that it can handle
-- parsers which are simultaneously left and right recursive, like
-- TotalRecognisers.LeftRecursion.leftRight.

open import Relation.Binary
open import Relation.Binary.PropositionalEquality

module TotalRecognisers.Simple.AlternativeBackend
         (Tok : Set)
         (_≟_ : Decidable (_≡_ {A = Tok}))
         -- The tokens must come with decidable equality.
         where

open import Codata.Musical.Notation
open import Data.Bool hiding (_≟_)
open import Data.List
open import Relation.Nullary.Decidable

import TotalRecognisers.Simple as S
open S Tok _≟_ hiding (_∈?_)

------------------------------------------------------------------------
-- Parsing "processes"

data Proc : Set where
  tokenBind : (p : Tok → ∞ Proc) → Proc
  emptyOr   : (p : Proc) → Proc
  fail      : Proc

-- The semantics of Proc is given by run: run p s is true iff s is a
-- member of the language defined by p.

run : Proc → List Tok → Bool
run (tokenBind p) (c ∷ s) = run (♭ (p c)) s
run (emptyOr p)   s       = null s ∨ run p s
run _             _       = false

------------------------------------------------------------------------
-- Parsers can be turned into processes

-- Here I use my technique for "beating the productivity checker".

-- Process "programs".

infixl 5 _∣_

data ProcP : Set where
  -- Process primitives.
  tokenBind : (p : Tok → ∞ ProcP) → ProcP
  emptyOr   : (p : ProcP) → ProcP
  fail      : ProcP

  -- Symmetric choice.
  _∣_     : (p₁ p₂ : ProcP) → ProcP

  -- Embedding of parsers.
  toProc  : ∀ {n} (p : P n) (κ : ProcP) → ProcP

-- WHNFs.

data ProcW : Set where
  tokenBind : (p : Tok → ∞ ProcP) → ProcW
  emptyOr   : (p : ProcW) → ProcW
  fail      : ProcW

-- WHNFs can be turned into programs.

program : ProcW → ProcP
program (tokenBind p) = tokenBind p
program (emptyOr p)   = emptyOr (program p)
program fail          = fail

-- Symmetric choice for WHNFs.

_∣W_ : ProcW → ProcW → ProcW
tokenBind p₁ ∣W tokenBind p₂ = tokenBind (λ c → ♯ (♭ (p₁ c) ∣ ♭ (p₂ c)))
emptyOr p₁   ∣W emptyOr p₂   = emptyOr (p₁ ∣W p₂)
emptyOr p₁   ∣W p₂           = emptyOr (p₁ ∣W p₂)
p₁           ∣W emptyOr p₂   = emptyOr (p₁ ∣W p₂)
fail         ∣W p₂           = p₂
p₁           ∣W fail         = p₁

-- Interpretation of toProc.

mutual

  toProcW′ : ∀ {n} → P n → if n then ProcW else ProcP → ProcW
  toProcW′ fail                                  κ = fail
  toProcW′ empty                                 κ = κ
  toProcW′ (tok t)                               κ = tokenBind (λ t′ →
                                                       if ⌊ t ≟ t′ ⌋ then ♯ κ else ♯ fail)
  toProcW′ (_∣_ {n₁ = true } {n₂ = true } p₁ p₂) κ = toProcW′ p₁ κ ∣W toProcW′ p₂ κ
  toProcW′ (_∣_ {n₁ = true } {n₂ = false} p₁ p₂) κ = toProcW′ p₁ κ ∣W toProcW  p₂ κ
  toProcW′ (_∣_ {n₁ = false} {n₂ = true } p₁ p₂) κ = toProcW  p₁ κ ∣W toProcW′ p₂ κ
  toProcW′ (_∣_ {n₁ = false} {n₂ = false} p₁ p₂) κ = toProcW′ p₁ κ ∣W toProcW′ p₂ κ
  toProcW′ (_·_ {n₁ = true }              p₁ p₂) κ = toProcW′ p₁ (toProcW′  p₂  κ)
  toProcW′ (_·_ {n₁ = false}              p₁ p₂) κ = toProcW′ p₁ (toProc (♭ p₂) κ)

  toProcW : ∀ {n} → P n → ProcW → ProcW
  toProcW {true } p κ = toProcW′ p          κ
  toProcW {false} p κ = toProcW′ p (program κ)

-- Programs can be turned into WHNFs.

whnf : ProcP → ProcW
whnf (tokenBind p) = tokenBind p
whnf (emptyOr p)   = emptyOr (whnf p)
whnf fail          = fail
whnf (p₁ ∣ p₂)     = whnf p₁ ∣W whnf p₂
whnf (toProc p κ)  = toProcW p (whnf κ)

-- Programs can be turned into processes.

mutual

  ⟦_⟧W : ProcW → Proc
  ⟦ tokenBind p ⟧W = tokenBind (λ c → ♯ ⟦ ♭ (p c) ⟧P)
  ⟦ emptyOr p   ⟧W = emptyOr ⟦ p ⟧W
  ⟦ fail        ⟧W = fail

  ⟦_⟧P : ProcP → Proc
  ⟦ p ⟧P = ⟦ whnf p ⟧W

------------------------------------------------------------------------
-- Alternative backend

-- I have not proved that this implementation is correct.

infix 4 _∈?_

_∈?_ : ∀ {n} → List Tok → P n → Bool
s ∈? p = run ⟦ toProc p (emptyOr fail) ⟧P s


module MJ.Examples.Integer where

open import Prelude
open import Data.Maybe
open import Data.Vec
import Data.Vec.All as Vec∀
open import Data.Star
open import Data.Bool
open import Data.List
open import Data.List.Any
open import Data.List.Membership.Propositional
open import Data.List.All hiding (lookup)
open import Data.Product hiding (Σ)
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary.Decidable
open import Data.String

open import MJ.Types

{-
    class Integer {
      int x = 0;
      int get() {
        return this.x;
      }
      int set(Integer b) {
        this.x = b.get()
        return;
      }
    }
-}

open import MJ.Classtable.Core 1

INT : Cid 1
INT = (cls (# 0))

decls : (ns : NS) → List (String × typing ns)
decls METHOD =
    ("get" , ([] , int))
  ∷ ("set" , (ref INT ∷ [] , void))
  ∷ []
decls FIELD =
    ("x" , int)
  ∷ []

IntegerSig = (class Object (int ∷ []) decls)

-- class table signature
Σ : Classtable
Σ = record {
  Σ = λ{
    (cls zero) → IntegerSig ;
    (cls (suc ())) ;
    Object → ObjectClass} ;
  founded = refl ;
  rooted = λ{
    (cls zero) → super ◅ ε ;
    (cls (suc ())) ;
    Object → ε };
  Σ-Object = refl }

open import MJ.Classtable.Code Σ
open import MJ.Syntax Σ
open import MJ.Syntax.Program Σ

-- Integer class body
IntegerImpl : Implementation INT
IntegerImpl = implementation
    (body (body
      (set
        (var (here refl))
        "x"
        (var (there (here refl))) ◅ ε)
      unit))

    -- methods
    (
      -- get
      body (body ε (get (var (here refl)) "x"))

      -- set
      ∷ (body (body
          (set
            (var (here refl))
            "x"
            {int}
            (get (var (there (here refl))) "x") ◅ ε)
          unit))

      ∷ []
    )

-- Implementation of the class table
Lib : Code
Lib (cls zero) = IntegerImpl
Lib (cls (suc ()))
Lib Object = implementation (body (body ε unit)) []

open import MJ.Semantics Σ Lib
open import MJ.Semantics.Values Σ

-- a simple program
p₀ : Prog int
p₀ = Lib ,
  let
    x = (here refl)
    y = (there (here refl))
  in body
    (
        loc (ref INT)
      ◅ loc (ref INT)
      ◅ asgn x (new INT ((num 9) ∷ []))
      ◅ asgn y (new INT ((num 18) ∷ []))
      ◅ run (call (var x) "set" {_}{void} (var y ∷ []))
      ◅ ε
    )
    (get (var x) "x")

test0 : p₀ ⇓⟨ 100 ⟩ (λ {W} (v : Val W int) → v ≡ num 18)
test0 = refl