{-# OPTIONS --safe #-}

open import Definition.Typed.EqualityRelation

module Definition.LogicalRelation.Properties.Neutral {{eqrel : EqRelSet}} where
open EqRelSet {{...}}

open import Definition.Untyped as U
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Typed.Weakening
open import Definition.LogicalRelation
open import Definition.LogicalRelation.ShapeView
open import Definition.LogicalRelation.Irrelevance
open import Definition.LogicalRelation.Properties.Reflexivity
open import Definition.LogicalRelation.Properties.Escape
open import Definition.LogicalRelation.Properties.Symmetry
import Definition.LogicalRelation.Weakening as W

open import Tools.Product
import Tools.PropositionalEquality as PE

import Data.Fin as Fin
import Data.Nat as Nat

-- Neutral reflexive types are reducible.
neu : ∀ {l Γ A r ll} (neA : Neutral A)
    → Γ ⊢ A ^ [ r , ι ll ]
    → Γ ⊢ A ~ A ∷ Univ r ll ^ [ ! , next ll ]
    → Γ ⊩⟨ l ⟩ A ^ [ r , ι ll ]
neu neA A A~A = ne′ _ (idRed:*: A) neA A~A

  -- Helper function for reducible neutral equality of a specific type of derivation.
neuEq′ : ∀ {l Γ A B r ll} ([A] : Γ ⊩⟨ l ⟩ne A ^[ r , ll ])
         (neA : Neutral A)
         (neB : Neutral B)
       → Γ ⊢ A ^ [ r , ι ll ] → Γ ⊢ B ^ [ r , ι ll ]
       → Γ ⊢ A ~ B ∷ Univ r ll ^ [ ! , next ll ]
       → Γ ⊩⟨ l ⟩ A ≡ B ^ [ r , ι ll ] / ne-intr [A]
neuEq′ (noemb (ne K [[ ⊢A , ⊢B , D ]] neK K≡K)) neA neB A B A~B =
  let A≡K = whnfRed* D (ne neA)
  in  ne₌ _ (idRed:*: B) neB (PE.subst (λ x → _ ⊢ x ~ _ ∷ _ ^ _) A≡K A~B)
neuEq′ {ι ¹} (emb emb< X) = neuEq′ X
neuEq′ {∞} (emb ∞< X) = neuEq′ X

-- Neutrally equal types are of reducible equality.
neuEq : ∀ {l Γ A B r ll} ([A] : Γ ⊩⟨ l ⟩ A ^ [ r , ι ll ])
        (neA : Neutral A)
        (neB : Neutral B)
      → Γ ⊢ A ^ [ r , ι ll ] → Γ ⊢ B ^ [ r , ι ll ]
      → Γ ⊢ A ~ B ∷ Univ r ll ^ [ ! , next ll ]
      → Γ ⊩⟨ l ⟩ A ≡ B ^ [ r , ι ll ] / [A]
neuEq [A] neA neB A B A~B =
  irrelevanceEq (ne-intr (ne-elim neA [A]))
                [A]
                (neuEq′ (ne-elim neA [A]) neA neB A B A~B)

mutual
  neuTerm⁰ : ∀ {Γ A r n} ([A] : Γ ⊩⟨ ι ⁰ ⟩ A ^ r) (neN : Neutral n)
          → Γ ⊢ n ∷ A ^ r
          → Γ ⊢ n ~ n ∷ A ^ r
          → Γ ⊩⟨ ι ⁰ ⟩ n ∷ A ^ r / [A]

  neuTerm⁰ (ℕᵣ [[ ⊢A , ⊢B , D ]]) neN n n~n =
    let A≡ℕ  = subset* D
        n~n′ = ~-conv n~n A≡ℕ
        n≡n  = ~-to-≅ₜ n~n′
    in  ℕₜ _ (idRedTerm:*: (conv n A≡ℕ)) n≡n (ne (neNfₜ neN (conv n A≡ℕ) n~n′))
  neuTerm⁰ {r = [ ! , ll ]} (ne′ K [[ ⊢A , ⊢B , D ]] neK K≡K) neN n n~n =
    let A≡K = subset* D
    in  neₜ _ (idRedTerm:*: (conv n A≡K)) (neNfₜ neN (conv n A≡K)
            (~-conv n~n A≡K))
  neuTerm⁰ {r = [ ! , ll ]} (Πᵣ′ rF lF lG lF≤ lG≤ F G D ⊢F ⊢G A≡A [F] [G] G-ext) neN n n~n =
    let A≡ΠFG = subset* (red D)
    in  Πₜ _ (idRedTerm:*: (conv n A≡ΠFG)) (ne neN) (~-to-≅ₜ (~-conv n~n A≡ΠFG))
           (λ {ρ} [ρ] ⊢Δ [a] [b] [a≡b] →
              let A≡ΠFG = subset* (red D)
                  ρA≡ρΠFG = wkEq [ρ] ⊢Δ (subset* (red D))
                  G[a]≡G[b] = escapeEq ([G] [ρ] ⊢Δ [b])
                                          (symEq ([G] [ρ] ⊢Δ [a]) ([G] [ρ] ⊢Δ [b])
                                                 (G-ext [ρ] ⊢Δ [a] [b] [a≡b]))
                  a = escapeTerm ([F] [ρ] ⊢Δ) [a]
                  b = escapeTerm ([F] [ρ] ⊢Δ) [b]
                  a≡b = escapeTermEq ([F] [ρ] ⊢Δ) [a≡b]
                  ρn = conv (wkTerm [ρ] ⊢Δ n) ρA≡ρΠFG
                  neN∘a = ∘ₙ (wkNeutral ρ neN)
                  neN∘b = ∘ₙ (wkNeutral ρ neN)
              in  neuEqTerm⁰ ([G] [ρ] ⊢Δ [a]) neN∘a neN∘b
                            (ρn ∘ⱼ a)
                            (conv (ρn ∘ⱼ b) (≅-eq G[a]≡G[b]))
                            (~-app (~-wk [ρ] ⊢Δ (~-conv n~n A≡ΠFG)) a≡b))
           (λ {ρ} [ρ] ⊢Δ [a] →
              let ρA≡ρΠFG = wkEq [ρ] ⊢Δ (subset* (red D))
                  a = escapeTerm ([F] [ρ] ⊢Δ) [a]
                  a≡a = escapeTermEq ([F] [ρ] ⊢Δ) (reflEqTerm ([F] [ρ] ⊢Δ) [a])
              in  neuTerm⁰ ([G] [ρ] ⊢Δ [a]) (∘ₙ (wkNeutral ρ neN))
                          (conv (wkTerm [ρ] ⊢Δ n) ρA≡ρΠFG ∘ⱼ a)
                          (~-app (~-wk [ρ] ⊢Δ (~-conv n~n A≡ΠFG)) a≡a))
  neuTerm⁰ (Emptyᵣ [[ ⊢A , ⊢B , D ]]) neN n n~n =
    let A≡ℕ  = subset* D
    in Emptyₜ (ne (conv n A≡ℕ))
  neuTerm⁰ {r = [ % , ll ]} (ne′ K [[ ⊢A , ⊢B , D ]] neK K≡K) neN n n~n =
    let A≡K = subset* D
    in  neₜ n
  neuTerm⁰ {r = [ % , ll ]} (Πᵣ′ rF lF lG lF≤ lG≤ F G D ⊢F ⊢G A≡A [F] [G] G-ext) neN n n~n = let A≡ΠFG = subset* (red D) in conv n A≡ΠFG
  neuTerm⁰ {r = [ % , ll ]} (∃ᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext) neN n n~n = let A≡ΠFG = subset* (red D) in conv n A≡ΠFG

  neuEqTerm⁰ : ∀ {Γ A n n′ r} ([A] : Γ ⊩⟨ ι ⁰ ⟩ A ^ r)
              (neN : Neutral n) (neN′ : Neutral n′)
            → Γ ⊢ n  ∷ A ^ r
            → Γ ⊢ n′ ∷ A ^ r
            → Γ ⊢ n ~ n′ ∷ A ^ r
            → Γ ⊩⟨ ι ⁰ ⟩ n ≡ n′ ∷ A ^ r / [A]

  neuEqTerm⁰ (ℕᵣ [[ ⊢A , ⊢B , D ]]) neN neN′ n n′ n~n′ =
    let A≡ℕ = subset* D
        n~n′₁ = ~-conv n~n′ A≡ℕ
        n≡n′ = ~-to-≅ₜ n~n′₁
    in  ℕₜ₌ _ _ (idRedTerm:*: (conv n A≡ℕ)) (idRedTerm:*: (conv n′ A≡ℕ))
            n≡n′ (ne (neNfₜ₌ neN neN′ n~n′₁))
  neuEqTerm⁰ (Emptyᵣ [[ ⊢A , ⊢B , D ]]) neN neN′ n n′ n~n′ =
    let A≡Empty = subset* D
    in  Emptyₜ₌  (ne (conv n A≡Empty) (conv n′ A≡Empty))
  neuEqTerm⁰ {r = [ ! , ll ]} (ne (ne K [[ ⊢A , ⊢B , D ]] neK K≡K)) neN neN′ n n′ n~n′ =
    let A≡K = subset* D
    in  neₜ₌ _ _ (idRedTerm:*: (conv n A≡K)) (idRedTerm:*: (conv n′ A≡K))
             (neNfₜ₌ neN neN′ (~-conv n~n′ A≡K))
  neuEqTerm⁰ {r = [ % , ll ]} (ne (ne K [[ ⊢A , ⊢B , D ]] neK K≡K)) neN neN′ n n′ n~n′ =
    let A≡K = subset* D
    in neₜ₌ n n′
  neuEqTerm⁰ {r = [ ! , ll ]} (Πᵣ′ rF lF lG lF≤ lG≤ F G [[ ⊢A , ⊢B , D ]] ⊢F ⊢G A≡A [F] [G] G-ext) neN neN′ n n′ n~n′ =
    let [ΠFG] = Πᵣ′ rF lF lG lF≤ lG≤ F G [[ ⊢A , ⊢B , D ]] ⊢F ⊢G A≡A [F] [G] G-ext
        A≡ΠFG = subset* D
        n~n′₁ = ~-conv n~n′ A≡ΠFG
        n≡n′ = ~-to-≅ₜ n~n′₁
        n~n = ~-trans n~n′ (~-sym n~n′)
        n′~n′ = ~-trans (~-sym n~n′) n~n′
    in  Πₜ₌ _ _ (idRedTerm:*: (conv n A≡ΠFG)) (idRedTerm:*: (conv n′ A≡ΠFG))
            (ne neN) (ne neN′) n≡n′
            (neuTerm⁰ [ΠFG] neN n n~n) (neuTerm⁰ [ΠFG] neN′ n′ n′~n′)
            (λ {ρ} [ρ] ⊢Δ [a] →
               let ρA≡ρΠFG = wkEq [ρ] ⊢Δ A≡ΠFG
                   ρn = wkTerm [ρ] ⊢Δ n
                   ρn′ = wkTerm [ρ] ⊢Δ n′
                   a = escapeTerm ([F] [ρ] ⊢Δ) [a]
                   a≡a = escapeTermEq ([F] [ρ] ⊢Δ)
                                          (reflEqTerm ([F] [ρ] ⊢Δ) [a])
                   neN∙a   = ∘ₙ (wkNeutral ρ neN)
                   neN′∙a′ = ∘ₙ (wkNeutral ρ neN′)
               in  neuEqTerm⁰ ([G] [ρ] ⊢Δ [a]) neN∙a neN′∙a′
                             (conv ρn  ρA≡ρΠFG ∘ⱼ a)
                             (conv ρn′ ρA≡ρΠFG ∘ⱼ a)
                             (~-app (~-wk [ρ] ⊢Δ n~n′₁) a≡a))
  neuEqTerm⁰ {r = [ % , ll ]} (Πᵣ′ rF lF lG lF≤ lG≤ F G [[ ⊢A , ⊢B , D ]] ⊢F ⊢G A≡A [F] [G] G-ext) neN neN′ n n′ n~n′ =
    let A≡ΠFG = subset* D
    in conv n A≡ΠFG , conv n′ A≡ΠFG
  neuEqTerm⁰ {r = [ % , ll ]} (∃ᵣ′ F G [[ ⊢A , ⊢B , D ]] ⊢F ⊢G A≡A [F] [G] G-ext) neN neN′ n n′ n~n′ =
    let A≡ΠFG = subset* D
    in conv n A≡ΠFG , conv n′ A≡ΠFG

mutual
  -- Neutral reflexive terms are reducible.
  neuTerm : ∀ {l Γ A r n} ([A] : Γ ⊩⟨ l ⟩ A ^ r) (neN : Neutral n)
          → Γ ⊢ n ∷ A ^ r
          → Γ ⊢ n ~ n ∷ A ^ r
          → Γ ⊩⟨ l ⟩ n ∷ A ^ r / [A]
  neuTerm {ι ¹} (Uᵣ′ A .(next ⁰) r ⁰ l< PE.refl [[ ⊢A , ⊢U , D ]]) neN n n~n =
    let n' = (conv n (subset* D))
        n~n' = ~-conv  n~n (subset* D)
        [n] = neu {l = ι ¹} neN (univ n') n~n'
    in Uₜ _ (idRedTerm:*: n') (ne neN) (~-to-≅ₜ n~n')
            (λ {ρ} [ρ] ⊢Δ → let n'ρ = wkTerm [ρ] ⊢Δ n'
                                n~n'ρ = ~-wk [ρ] ⊢Δ n~n'
                                [nρ] = neu (wkNeutral ρ neN) (univ n'ρ) n~n'ρ
                            in [nρ])
  neuTerm {∞} (Uᵣ′ A .(next ¹) r ¹ l< PE.refl [[ ⊢A , ⊢U , D ]]) neN n n~n =
    let n' = (conv n (subset* D))
        n~n' = ~-conv  n~n (subset* D)
        [n] = neu {l = ∞} neN (univ n') n~n'
    in Uₜ _ (idRedTerm:*: n') (ne neN) (~-to-≅ₜ n~n')
            (λ {ρ} [ρ] ⊢Δ → let n'ρ = wkTerm [ρ] ⊢Δ n'
                                n~n'ρ = ~-wk [ρ] ⊢Δ n~n'
                                [nρ] = neu (wkNeutral ρ neN) (univ n'ρ) n~n'ρ
                            in [nρ])
  neuTerm (ℕᵣ [[ ⊢A , ⊢B , D ]]) neN n n~n =
    let A≡ℕ  = subset* D
        n~n′ = ~-conv n~n A≡ℕ
        n≡n  = ~-to-≅ₜ n~n′
    in  ℕₜ _ (idRedTerm:*: (conv n A≡ℕ)) n≡n (ne (neNfₜ neN (conv n A≡ℕ) n~n′))
  neuTerm {r = [ ! , ll ]} (ne′ K [[ ⊢A , ⊢B , D ]] neK K≡K) neN n n~n =
    let A≡K = subset* D
    in  neₜ _ (idRedTerm:*: (conv n A≡K)) (neNfₜ neN (conv n A≡K)
            (~-conv n~n A≡K))
  neuTerm {r = [ ! , ll ]} (Πᵣ′ rF lF lG lF≤ lG≤ F G D ⊢F ⊢G A≡A [F] [G] G-ext) neN n n~n =
    let A≡ΠFG = subset* (red D)
    in  Πₜ _ (idRedTerm:*: (conv n A≡ΠFG)) (ne neN) (~-to-≅ₜ (~-conv n~n A≡ΠFG))
           (λ {ρ} [ρ] ⊢Δ [a] [b] [a≡b] →
              let A≡ΠFG = subset* (red D)
                  ρA≡ρΠFG = wkEq [ρ] ⊢Δ (subset* (red D))
                  G[a]≡G[b] = escapeEq ([G] [ρ] ⊢Δ [b])
                                          (symEq ([G] [ρ] ⊢Δ [a]) ([G] [ρ] ⊢Δ [b])
                                                 (G-ext [ρ] ⊢Δ [a] [b] [a≡b]))
                  a = escapeTerm ([F] [ρ] ⊢Δ) [a]
                  b = escapeTerm ([F] [ρ] ⊢Δ) [b]
                  a≡b = escapeTermEq ([F] [ρ] ⊢Δ) [a≡b]
                  ρn = conv (wkTerm [ρ] ⊢Δ n) ρA≡ρΠFG
                  neN∘a = ∘ₙ (wkNeutral ρ neN)
                  neN∘b = ∘ₙ (wkNeutral ρ neN)
              in  neuEqTerm ([G] [ρ] ⊢Δ [a]) neN∘a neN∘b
                            (ρn ∘ⱼ a)
                            (conv (ρn ∘ⱼ b) (≅-eq G[a]≡G[b]))
                            (~-app (~-wk [ρ] ⊢Δ (~-conv n~n A≡ΠFG)) a≡b))
           (λ {ρ} [ρ] ⊢Δ [a] →
              let ρA≡ρΠFG = wkEq [ρ] ⊢Δ (subset* (red D))
                  a = escapeTerm ([F] [ρ] ⊢Δ) [a]
                  a≡a = escapeTermEq ([F] [ρ] ⊢Δ) (reflEqTerm ([F] [ρ] ⊢Δ) [a])
              in  neuTerm ([G] [ρ] ⊢Δ [a]) (∘ₙ (wkNeutral ρ neN))
                          (conv (wkTerm [ρ] ⊢Δ n) ρA≡ρΠFG ∘ⱼ a)
                          (~-app (~-wk [ρ] ⊢Δ (~-conv n~n A≡ΠFG)) a≡a))
  neuTerm (Emptyᵣ [[ ⊢A , ⊢B , D ]]) neN n n~n =
    let A≡ℕ  = subset* D
    in Emptyₜ (ne (conv n A≡ℕ))
  neuTerm {r = [ % , ll ]} (ne′ K [[ ⊢A , ⊢B , D ]] neK K≡K) neN n n~n =
    let A≡K = subset* D
    in  neₜ n
  neuTerm {r = [ % , ll ]} (Πᵣ′ rF lF lG lF≤ lG≤ F G D ⊢F ⊢G A≡A [F] [G] G-ext) neN n n~n = let A≡ΠFG = subset* (red D) in conv n A≡ΠFG
  neuTerm {r = [ % , ll ]} (∃ᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext) neN n n~n = let A≡ΠFG = subset* (red D) in conv n A≡ΠFG
  neuTerm {ι ¹} (emb l< X) neN n = neuTerm X neN n
  neuTerm {∞} (emb l< X) neN n = neuTerm X neN n

  -- Neutrally equal terms are of reducible equality.
  neuEqTerm : ∀ {l Γ A n n′ r} ([A] : Γ ⊩⟨ l ⟩ A ^ r)
              (neN : Neutral n) (neN′ : Neutral n′)
            → Γ ⊢ n  ∷ A ^ r
            → Γ ⊢ n′ ∷ A ^ r
            → Γ ⊢ n ~ n′ ∷ A ^ r
            → Γ ⊩⟨ l ⟩ n ≡ n′ ∷ A ^ r / [A]
  neuEqTerm {ι ¹} (Uᵣ′ A _ r ⁰ l< PE.refl D) neN neN′ n n′ n~n' =
    let n~n = ~-trans n~n' (~-sym n~n')
        n'~n' = ~-trans (~-sym n~n') n~n'
        [[n]]   = neuTerm (Uᵣ (Uᵣ r ⁰ l< PE.refl D)) neN n n~n
        [[n']]  = neuTerm (Uᵣ (Uᵣ r ⁰ l< PE.refl D)) neN′ n′ n'~n'
        n' = conv n (subset* (red D))
        n′' = conv n′ (subset* (red D))
        n~n'U = ~-conv n~n' (subset* (red D))
        [n]  = neu {l = ι ¹} neN  (univ n') (~-conv n~n (subset* (red D)))
        [n′] = neu {l = ι ¹} neN′ (univ n′') (~-conv n'~n' (subset* (red D)))
    in Uₜ₌ [[n]] [[n']] (~-to-≅ₜ n~n'U)
           (λ [ρ] ⊢Δ → W.wkEq [ρ] ⊢Δ [n] ((neuEq [n] neN neN′ (univ n') (univ n′') n~n'U)))
  neuEqTerm {∞} (Uᵣ′ A _ r ¹ l< PE.refl D) neN neN′ n n′ n~n' =
    let n~n = ~-trans n~n' (~-sym n~n')
        n'~n' = ~-trans (~-sym n~n') n~n'
        [[n]]   = neuTerm (Uᵣ (Uᵣ r ¹ l< PE.refl D)) neN n n~n
        [[n']]  = neuTerm (Uᵣ (Uᵣ r ¹ l< PE.refl D)) neN′ n′ n'~n'
        n' = conv n (subset* (red D))
        n′' = conv n′ (subset* (red D))
        n~n'U = ~-conv n~n' (subset* (red D))
        [n]  = neu {l = ∞} neN  (univ n') (~-conv n~n (subset* (red D)))
        [n′] = neu {l = ∞} neN′ (univ n′') (~-conv n'~n' (subset* (red D)))
    in Uₜ₌ [[n]] [[n']] (~-to-≅ₜ n~n'U)
           (λ [ρ] ⊢Δ → W.wkEq [ρ] ⊢Δ [n] ((neuEq [n] neN neN′ (univ n') (univ n′') n~n'U)))
  neuEqTerm (ℕᵣ [[ ⊢A , ⊢B , D ]]) neN neN′ n n′ n~n′ =
    let A≡ℕ = subset* D
        n~n′₁ = ~-conv n~n′ A≡ℕ
        n≡n′ = ~-to-≅ₜ n~n′₁
    in  ℕₜ₌ _ _ (idRedTerm:*: (conv n A≡ℕ)) (idRedTerm:*: (conv n′ A≡ℕ))
            n≡n′ (ne (neNfₜ₌ neN neN′ n~n′₁))
  neuEqTerm (Emptyᵣ [[ ⊢A , ⊢B , D ]]) neN neN′ n n′ n~n′ =
    let A≡Empty = subset* D
    in  Emptyₜ₌  (ne (conv n A≡Empty) (conv n′ A≡Empty))
  neuEqTerm {r = [ ! , ll ]} (ne (ne K [[ ⊢A , ⊢B , D ]] neK K≡K)) neN neN′ n n′ n~n′ =
    let A≡K = subset* D
    in  neₜ₌ _ _ (idRedTerm:*: (conv n A≡K)) (idRedTerm:*: (conv n′ A≡K))
             (neNfₜ₌ neN neN′ (~-conv n~n′ A≡K))
  neuEqTerm {r = [ % , ll ]} (ne (ne K [[ ⊢A , ⊢B , D ]] neK K≡K)) neN neN′ n n′ n~n′ =
    let A≡K = subset* D
    in neₜ₌ n n′
  neuEqTerm {r = [ ! , ll ]} (Πᵣ′ rF lF lG lF≤ lG≤ F G [[ ⊢A , ⊢B , D ]] ⊢F ⊢G A≡A [F] [G] G-ext) neN neN′ n n′ n~n′ =
    let [ΠFG] = Πᵣ′ rF lF lG lF≤ lG≤ F G [[ ⊢A , ⊢B , D ]] ⊢F ⊢G A≡A [F] [G] G-ext
        A≡ΠFG = subset* D
        n~n′₁ = ~-conv n~n′ A≡ΠFG
        n≡n′ = ~-to-≅ₜ n~n′₁
        n~n = ~-trans n~n′ (~-sym n~n′)
        n′~n′ = ~-trans (~-sym n~n′) n~n′
    in  Πₜ₌ _ _ (idRedTerm:*: (conv n A≡ΠFG)) (idRedTerm:*: (conv n′ A≡ΠFG))
            (ne neN) (ne neN′) n≡n′
            (neuTerm [ΠFG] neN n n~n) (neuTerm [ΠFG] neN′ n′ n′~n′)
            (λ {ρ} [ρ] ⊢Δ [a] →
               let ρA≡ρΠFG = wkEq [ρ] ⊢Δ A≡ΠFG
                   ρn = wkTerm [ρ] ⊢Δ n
                   ρn′ = wkTerm [ρ] ⊢Δ n′
                   a = escapeTerm ([F] [ρ] ⊢Δ) [a]
                   a≡a = escapeTermEq ([F] [ρ] ⊢Δ)
                                          (reflEqTerm ([F] [ρ] ⊢Δ) [a])
                   neN∙a   = ∘ₙ (wkNeutral ρ neN)
                   neN′∙a′ = ∘ₙ (wkNeutral ρ neN′)
               in  neuEqTerm ([G] [ρ] ⊢Δ [a]) neN∙a neN′∙a′
                             (conv ρn  ρA≡ρΠFG ∘ⱼ a)
                             (conv ρn′ ρA≡ρΠFG ∘ⱼ a)
                             (~-app (~-wk [ρ] ⊢Δ n~n′₁) a≡a))
  neuEqTerm {r = [ % , ll ]} (Πᵣ′ rF lF lG lF≤ lG≤ F G [[ ⊢A , ⊢B , D ]] ⊢F ⊢G A≡A [F] [G] G-ext) neN neN′ n n′ n~n′ =
    let A≡ΠFG = subset* D
    in conv n A≡ΠFG , conv n′ A≡ΠFG
  neuEqTerm {r = [ % , ll ]} (∃ᵣ′ F G [[ ⊢A , ⊢B , D ]] ⊢F ⊢G A≡A [F] [G] G-ext) neN neN′ n n′ n~n′ =
    let A≡ΠFG = subset* D
    in conv n A≡ΠFG , conv n′ A≡ΠFG
  neuEqTerm {ι ¹} (emb l< X) neN n neN′ n:≡:n′ = neuEqTerm X neN n neN′ n:≡:n′
  neuEqTerm {∞} (emb l< X) neN n neN′ n:≡:n′ = neuEqTerm X neN n neN′ n:≡:n′

-- Neutral reflexive types are reducible.
neu:⇒*: : ∀ {l Γ A K r ll} (neK : Neutral K)
    → Γ ⊢ A :⇒*: K ^ [ r , ι ll ]
    → Γ ⊢ K ~ K ∷ Univ r ll ^ [ ! , next ll ]
    → Γ ⊩⟨ l ⟩ A ^ [ r , ι ll ]
neu:⇒*: neK D K~K = ne′ _ D neK K~K

  -- Helper function for reducible neutral equality of a specific type of derivation.
neuEq:⇒*:′ : ∀ {l Γ A B K L r ll} ([A] : Γ ⊩⟨ l ⟩ne A ^[ r , ll ])
         (neK : Neutral K)
         (neL : Neutral L)
       → Γ ⊢ A :⇒*: K ^ [ r , ι ll ]
       → Γ ⊢ B :⇒*: L ^ [ r , ι ll ]
       → Γ ⊢ K ~ L ∷ Univ r ll ^ [ ! , next ll ]
       → Γ ⊩⟨ l ⟩ A ≡ B ^ [ r , ι ll ] / ne-intr [A]
neuEq:⇒*:′ (noemb (ne A' [[ ⊢A , ⊢B , D ]] neA A≡A)) neK neL [[ ⊢A' , ⊢K , D' ]] [B] A~B =
  let A≡K = whrDet* (D , ne neA) (D' , ne neK) -- (ne neA)
  in ne₌ _ [B] neL (PE.subst (λ x → _ ⊢ x ~ _ ∷ _ ^ _) (PE.sym A≡K) A~B)
neuEq:⇒*:′ {ι ¹} (emb emb< X) = neuEq:⇒*:′ X
neuEq:⇒*:′ {∞} (emb ∞< X) = neuEq:⇒*:′ X

-- Neutrally equal types are of reducible equality.
neuEq:⇒*: : ∀ {l Γ A B K L r ll} ([A] : Γ ⊩⟨ l ⟩ A ^ [ r , ι ll ])
         (neK : Neutral K)
         (neL : Neutral L)
       → Γ ⊢ A :⇒*: K ^ [ r , ι ll ]
       → Γ ⊢ B :⇒*: L ^ [ r , ι ll ]
       → Γ ⊢ K ~ L ∷ Univ r ll ^ [ ! , next ll ]
      → Γ ⊩⟨ l ⟩ A ≡ B ^ [ r , ι ll ] / [A]
neuEq:⇒*: [A] neK neL [[ ⊢A , ⊢K , D ]] B A~B =
  let ne-intrA = ne-elim′ D neK [A] PE.refl
  in irrelevanceEq (ne-intr ne-intrA)
                [A]
                (neuEq:⇒*:′ ne-intrA neK neL [[ ⊢A , ⊢K , D ]] B A~B)

app:⇒*: : ∀ {Γ a t u A B rA lA lB l}
          (⊢a : Γ ⊢ a ∷ A ^ [ rA , ι lA ])
          (D : Γ ⊢ t :⇒*: u ∷ (Π A ^ rA ° lA ▹ B ° lB ° l) ^ ι l)
        → Γ ⊢ t ∘ a ^ l :⇒*: u ∘ a ^ l ∷ B [ a ] ^ ι lB
app:⇒*: ⊢a [[ ⊢t , ⊢u , D ]] = [[ ⊢t ∘ⱼ ⊢a , ⊢u ∘ⱼ ⊢a , appRed* ⊢a D ]]

mutual
  neuTerm:⇒*:⁰ : ∀ {Γ A ll t n} ([A] : Γ ⊩⟨ ι ⁰ ⟩ A ^ [ ! , ll ]) (neN : Neutral n)
          → Γ ⊢ t :⇒*: n ∷ A ^ ll
          → Γ ⊢ n ~ n ∷ A ^ [ ! , ll ]
          → Γ ⊩⟨ ι ⁰ ⟩ t ∷ A ^ [ ! , ll ] / [A]

  neuTerm:⇒*:⁰ (ℕᵣ [[ ⊢A , ⊢B , D ]]) neN [[ ⊢t , n , D' ]] n~n =
    let A≡ℕ  = subset* D
        n~n′ = ~-conv n~n A≡ℕ
        n≡n  = ~-to-≅ₜ n~n′
    in  ℕₜ _ (conv:⇒*: [[ ⊢t , n , D' ]] A≡ℕ) n≡n (ne (neNfₜ neN (conv n A≡ℕ) n~n′))
  neuTerm:⇒*:⁰ (ne′ K [[ ⊢A , ⊢B , D ]] neK K≡K) neN [[ ⊢t , n , D' ]] n~n =
    let A≡K = subset* D
    in  neₜ _ (conv:⇒*: [[ ⊢t , n , D' ]] A≡K) (neNfₜ neN (conv n A≡K)
            (~-conv n~n A≡K))
  neuTerm:⇒*:⁰ (Πᵣ′ rF lF lG lF≤ lG≤ F G D ⊢F ⊢G A≡A [F] [G] G-ext) neN [[ ⊢t , n , D' ]] n~n =
    let A≡ΠFG = subset* (red D)
    in  Πₜ _ (conv:⇒*: [[ ⊢t , n , D' ]] A≡ΠFG) (ne neN) (~-to-≅ₜ (~-conv n~n A≡ΠFG))
           (λ {ρ} [ρ] ⊢Δ [a] [b] [a≡b] →
              let A≡ΠFG = subset* (red D)
                  ρA≡ρΠFG = wkEq [ρ] ⊢Δ (subset* (red D))
                  G[a]≡G[b] = escapeEq ([G] [ρ] ⊢Δ [b])
                                          (symEq ([G] [ρ] ⊢Δ [a]) ([G] [ρ] ⊢Δ [b])
                                                 (G-ext [ρ] ⊢Δ [a] [b] [a≡b]))
                  a = escapeTerm ([F] [ρ] ⊢Δ) [a]
                  b = escapeTerm ([F] [ρ] ⊢Δ) [b]
                  a≡b = escapeTermEq ([F] [ρ] ⊢Δ) [a≡b]
                  ρn = conv (wkTerm [ρ] ⊢Δ n) ρA≡ρΠFG
                  neN∘a = ∘ₙ (wkNeutral ρ neN)
                  neN∘b = ∘ₙ (wkNeutral ρ neN)
              in  neuEqTerm⁰ ([G] [ρ] ⊢Δ [a]) neN∘a neN∘b (ρn ∘ⱼ a) (conv (ρn ∘ⱼ b) (≅-eq G[a]≡G[b]))
                             ((~-app (~-wk [ρ] ⊢Δ (~-conv n~n A≡ΠFG)) a≡b)))
           (λ {ρ} [ρ] ⊢Δ [a] →
              let ρA≡ρΠFG = wkEq [ρ] ⊢Δ (subset* (red D))
                  a = escapeTerm ([F] [ρ] ⊢Δ) [a]
                  a≡a = escapeTermEq ([F] [ρ] ⊢Δ) (reflEqTerm ([F] [ρ] ⊢Δ) [a])
              in  neuTerm ([G] [ρ] ⊢Δ [a]) (∘ₙ (wkNeutral ρ neN))
                          (conv (wkTerm [ρ] ⊢Δ n) ρA≡ρΠFG ∘ⱼ a)
                          (~-app (~-wk [ρ] ⊢Δ (~-conv n~n A≡ΠFG)) a≡a))

  neuEqTerm:⇒*:⁰ : ∀ {Γ A n n′ t u ll} ([A] : Γ ⊩⟨ ι ⁰ ⟩ A ^ [ ! , ll ])
              (neN : Neutral n) (neN′ : Neutral n′)
            → Γ ⊢ t :⇒*: n ∷ A ^ ll
            → Γ ⊢ u :⇒*: n′ ∷ A ^ ll
            → Γ ⊢ n ~ n′ ∷ A ^ [ ! , ll ]
            → Γ ⊩⟨ ι ⁰ ⟩ t ≡ u ∷ A ^ [ ! , ll ] / [A]

  neuEqTerm:⇒*:⁰ (ℕᵣ [[ ⊢A , ⊢B , D ]]) neN neN′ [[ ⊢t , n , D' ]] [[ ⊢u , n′ , D′ ]] n~n′ =
    let A≡ℕ = subset* D
        n~n′₁ = ~-conv n~n′ A≡ℕ
        n≡n′ = ~-to-≅ₜ n~n′₁
    in  ℕₜ₌ _ _ (conv:⇒*: [[ ⊢t , n , D' ]] A≡ℕ) (conv:⇒*: [[ ⊢u , n′ , D′ ]] A≡ℕ)
            n≡n′ (ne (neNfₜ₌ neN neN′ n~n′₁))
  neuEqTerm:⇒*:⁰ (ne (ne K [[ ⊢A , ⊢B , D ]] neK K≡K)) neN neN′ [[ ⊢t , n , D' ]] [[ ⊢u , n′ , D′ ]] n~n′ =
    let A≡K = subset* D
    in  neₜ₌ _ _ (conv:⇒*: [[ ⊢t , n , D' ]] A≡K) (conv:⇒*: [[ ⊢u , n′ , D′ ]] A≡K)
             (neNfₜ₌ neN neN′ (~-conv n~n′ A≡K))
  neuEqTerm:⇒*:⁰ (Πᵣ′ rF lF lG lF≤ lG≤ F G [[ ⊢A , ⊢B , D ]] ⊢F ⊢G A≡A [F] [G] G-ext) neN neN′ [[ ⊢t , n , D' ]] [[ ⊢u , n′ , D′ ]] n~n′ =
    let [ΠFG] = Πᵣ′ rF lF lG lF≤ lG≤ F G [[ ⊢A , ⊢B , D ]] ⊢F ⊢G A≡A [F] [G] G-ext
        A≡ΠFG = subset* D
        n~n′₁ = ~-conv n~n′ A≡ΠFG
        n≡n′ = ~-to-≅ₜ n~n′₁
        n~n = ~-trans n~n′ (~-sym n~n′)
        n′~n′ = ~-trans (~-sym n~n′) n~n′
    in  Πₜ₌ _ _ (conv:⇒*: [[ ⊢t , n , D' ]] A≡ΠFG) (conv:⇒*: [[ ⊢u , n′ , D′ ]] A≡ΠFG)
            (ne neN) (ne neN′) n≡n′
            (neuTerm:⇒*:⁰ [ΠFG] neN [[ ⊢t , n , D' ]] n~n) (neuTerm:⇒*:⁰ [ΠFG] neN′ [[ ⊢u , n′ , D′ ]] n′~n′)
            (λ {ρ} [ρ] ⊢Δ [a] →
               let ρA≡ρΠFG = wkEq [ρ] ⊢Δ A≡ΠFG
                   ρn = wkTerm [ρ] ⊢Δ n
                   ρn′ = wkTerm [ρ] ⊢Δ n′
                   a = escapeTerm ([F] [ρ] ⊢Δ) [a]
                   a≡a = escapeTermEq ([F] [ρ] ⊢Δ)
                                          (reflEqTerm ([F] [ρ] ⊢Δ) [a])
                   neN∙a   = ∘ₙ (wkNeutral ρ neN)
                   neN′∙a′ = ∘ₙ (wkNeutral ρ neN′)
               in  neuEqTerm ([G] [ρ] ⊢Δ [a]) neN∙a neN′∙a′
                             (conv ρn  ρA≡ρΠFG ∘ⱼ a)
                             (conv ρn′ ρA≡ρΠFG ∘ⱼ a)
                             (~-app (~-wk [ρ] ⊢Δ n~n′₁) a≡a) )

mutual
  -- Neutral reflexive terms are reducible.
  neuTerm:⇒*: : ∀ {l Γ A ll t n} ([A] : Γ ⊩⟨ l ⟩ A ^ [ ! , ll ]) (neN : Neutral n)
          → Γ ⊢ t :⇒*: n ∷ A ^ ll
          → Γ ⊢ n ~ n ∷ A ^ [ ! , ll ]
          → Γ ⊩⟨ l ⟩ t ∷ A ^ [ ! , ll ] / [A]
  neuTerm:⇒*: {ι ¹} (Uᵣ′ A .(next ⁰) r ⁰ l< PE.refl [[ ⊢A , ⊢U , D ]]) neN [[ ⊢t , n , D' ]] n~n =
    let D'' = conv:⇒*: [[ ⊢t , n , D' ]] (subset* D)
        n~n' = ~-conv  n~n (subset* D)
    in Uₜ _ (conv:⇒*: [[ ⊢t , n , D' ]] (subset* D))
            (ne neN) (~-to-≅ₜ n~n')
            (λ {ρ} [ρ] ⊢Δ → let ρD' = wkRed:*:Term [ρ] ⊢Δ D''
                                n~n'ρ = ~-wk [ρ] ⊢Δ n~n'
                            in neu:⇒*: (wkNeutral ρ neN) (univ:⇒*: ρD') n~n'ρ)
  neuTerm:⇒*: {∞} (Uᵣ′ A .(next ¹) r ¹ l< PE.refl [[ ⊢A , ⊢U , D ]]) neN  [[ ⊢t , n , D' ]] n~n =
    let D'' = conv:⇒*: [[ ⊢t , n , D' ]] (subset* D)
        n~n' = ~-conv  n~n (subset* D)
    in Uₜ _ (conv:⇒*: [[ ⊢t , n , D' ]] (subset* D))
            (ne neN) (~-to-≅ₜ n~n')
            (λ {ρ} [ρ] ⊢Δ → let ρD' = wkRed:*:Term [ρ] ⊢Δ D''
                                n~n'ρ = ~-wk [ρ] ⊢Δ n~n'
                            in neu:⇒*: (wkNeutral ρ neN) (univ:⇒*: ρD') n~n'ρ)
  neuTerm:⇒*: (ℕᵣ [[ ⊢A , ⊢B , D ]]) neN [[ ⊢t , n , D' ]] n~n =
    let A≡ℕ  = subset* D
        n~n′ = ~-conv n~n A≡ℕ
        n≡n  = ~-to-≅ₜ n~n′
    in  ℕₜ _ (conv:⇒*: [[ ⊢t , n , D' ]] A≡ℕ) n≡n (ne (neNfₜ neN (conv n A≡ℕ) n~n′))
  neuTerm:⇒*: (ne′ K [[ ⊢A , ⊢B , D ]] neK K≡K) neN [[ ⊢t , n , D' ]] n~n =
    let A≡K = subset* D
    in  neₜ _ (conv:⇒*: [[ ⊢t , n , D' ]] A≡K) (neNfₜ neN (conv n A≡K)
            (~-conv n~n A≡K))
  neuTerm:⇒*: (Πᵣ′ rF lF lG lF≤ lG≤ F G D ⊢F ⊢G A≡A [F] [G] G-ext) neN [[ ⊢t , n , D' ]] n~n =
    let A≡ΠFG = subset* (red D)
    in  Πₜ _ (conv:⇒*: [[ ⊢t , n , D' ]] A≡ΠFG) (ne neN) (~-to-≅ₜ (~-conv n~n A≡ΠFG))
           (λ {ρ} [ρ] ⊢Δ [a] [b] [a≡b] →
              let A≡ΠFG = subset* (red D)
                  ρA≡ρΠFG = wkEq [ρ] ⊢Δ (subset* (red D))
                  G[a]≡G[b] = escapeEq ([G] [ρ] ⊢Δ [b])
                                          (symEq ([G] [ρ] ⊢Δ [a]) ([G] [ρ] ⊢Δ [b])
                                                 (G-ext [ρ] ⊢Δ [a] [b] [a≡b]))
                  a = escapeTerm ([F] [ρ] ⊢Δ) [a]
                  b = escapeTerm ([F] [ρ] ⊢Δ) [b]
                  a≡b = escapeTermEq ([F] [ρ] ⊢Δ) [a≡b]
                  ρn = conv (wkTerm [ρ] ⊢Δ n) ρA≡ρΠFG
                  neN∘a = ∘ₙ (wkNeutral ρ neN)
                  neN∘b = ∘ₙ (wkNeutral ρ neN)
              in  neuEqTerm ([G] [ρ] ⊢Δ [a]) neN∘a neN∘b (ρn ∘ⱼ a) (conv (ρn ∘ⱼ b) (≅-eq G[a]≡G[b]))
                            ((~-app (~-wk [ρ] ⊢Δ (~-conv n~n A≡ΠFG)) a≡b)))
           (λ {ρ} [ρ] ⊢Δ [a] →
              let ρA≡ρΠFG = wkEq [ρ] ⊢Δ (subset* (red D))
                  a = escapeTerm ([F] [ρ] ⊢Δ) [a]
                  a≡a = escapeTermEq ([F] [ρ] ⊢Δ) (reflEqTerm ([F] [ρ] ⊢Δ) [a])
              in  neuTerm ([G] [ρ] ⊢Δ [a]) (∘ₙ (wkNeutral ρ neN))
                          (conv (wkTerm [ρ] ⊢Δ n) ρA≡ρΠFG ∘ⱼ a)
                          (~-app (~-wk [ρ] ⊢Δ (~-conv n~n A≡ΠFG)) a≡a))
  neuTerm:⇒*: {ι ¹} (emb l< X) neN n n:≡:n′ = neuTerm:⇒*: X neN n n:≡:n′
  neuTerm:⇒*: {∞} (emb l< X) neN n n:≡:n′ = neuTerm:⇒*: X neN n n:≡:n′

  -- Neutrally equal terms are of reducible equality.
  neuEqTerm:⇒*: : ∀ {l Γ A t u n n′ ll} ([A] : Γ ⊩⟨ l ⟩ A ^ [ ! , ll ])
              (neN : Neutral n) (neN′ : Neutral n′)
            → Γ ⊢ t :⇒*: n ∷ A ^ ll
            → Γ ⊢ u :⇒*: n′ ∷ A ^ ll
            → Γ ⊢ n ~ n′ ∷ A ^ [ ! , ll ]
            → Γ ⊩⟨ l ⟩ t ≡ u ∷ A ^ [ ! , ll ] / [A]
  neuEqTerm:⇒*: {ι ¹} (Uᵣ′ A _ r ⁰ l< PE.refl [[ ⊢A , ⊢U , D ]]) neN neN′  [[ ⊢t , n , D' ]] [[ ⊢u , n′ , D′ ]] n~n' =
    let n~n = ~-trans n~n' (~-sym n~n')
        n'~n' = ~-trans (~-sym n~n') n~n'
        n~n'U = ~-conv n~n' (subset* D)
        n~nU = ~-conv n~n (subset* D)
        [t] = neuTerm:⇒*: (Uᵣ′ A _ r ⁰ l< PE.refl [[ ⊢A , ⊢U , D ]]) neN [[ ⊢t , n , D' ]] n~n
        Uₜ _ _ _ _ [Δt] = [t]
        D'' = conv:⇒*: [[ ⊢t , n , D' ]] (subset* D)
        D′' = conv:⇒*: [[ ⊢u , n′ , D′ ]] (subset* D)
    in Uₜ₌ [t]
           (neuTerm:⇒*: (Uᵣ′ A _ r ⁰ l< PE.refl [[ ⊢A , ⊢U , D ]]) neN′ [[ ⊢u , n′ , D′ ]] n'~n')
           (~-to-≅ₜ n~n'U)
           λ {ρ} [ρ] ⊢Δ → let ρD' = wkRed:*:Term [ρ] ⊢Δ D''
                              ρD′ = wkRed:*:Term [ρ] ⊢Δ D′'
                              n~nUρ = ~-wk [ρ] ⊢Δ n~nU
                              n~n'Uρ = ~-wk [ρ] ⊢Δ n~n'U
                          in neuEq:⇒*: {l = ι ¹} (neu:⇒*: (wkNeutral ρ neN) (univ:⇒*: ρD') n~nUρ) (wkNeutral ρ neN) (wkNeutral ρ neN′)
                                       (univ:⇒*: ρD') (univ:⇒*: ρD′) n~n'Uρ
  neuEqTerm:⇒*: {∞} (Uᵣ′ A _ r ¹ l< PE.refl [[ ⊢A , ⊢U , D ]]) neN neN′  [[ ⊢t , n , D' ]] [[ ⊢u , n′ , D′ ]] n~n' =
    let n~n = ~-trans n~n' (~-sym n~n')
        n'~n' = ~-trans (~-sym n~n') n~n'
        n~n'U = ~-conv n~n' (subset* D)
        n~nU = ~-conv n~n (subset* D)
        [t] = neuTerm:⇒*: (Uᵣ′ A _ r ¹ l< PE.refl [[ ⊢A , ⊢U , D ]]) neN [[ ⊢t , n , D' ]] n~n
        Uₜ _ _ _ _ [Δt] = [t]
        D'' = conv:⇒*: [[ ⊢t , n , D' ]] (subset* D)
        D′' = conv:⇒*: [[ ⊢u , n′ , D′ ]] (subset* D)
    in Uₜ₌ [t]
           (neuTerm:⇒*: (Uᵣ′ A _ r ¹ l< PE.refl [[ ⊢A , ⊢U , D ]]) neN′ [[ ⊢u , n′ , D′ ]] n'~n')
           (~-to-≅ₜ n~n'U)
           λ {ρ} [ρ] ⊢Δ → let ρD' = wkRed:*:Term [ρ] ⊢Δ D''
                              ρD′ = wkRed:*:Term [ρ] ⊢Δ D′'
                              n~nUρ = ~-wk [ρ] ⊢Δ n~nU
                              n~n'Uρ = ~-wk [ρ] ⊢Δ n~n'U
                          in neuEq:⇒*: {l = ∞} (neu:⇒*: (wkNeutral ρ neN) (univ:⇒*: ρD') n~nUρ) (wkNeutral ρ neN) (wkNeutral ρ neN′)
                                       (univ:⇒*: ρD') (univ:⇒*: ρD′) n~n'Uρ
  neuEqTerm:⇒*: (ℕᵣ [[ ⊢A , ⊢B , D ]]) neN neN′ [[ ⊢t , n , D' ]] [[ ⊢u , n′ , D′ ]] n~n′ =
    let A≡ℕ = subset* D
        n~n′₁ = ~-conv n~n′ A≡ℕ
        n≡n′ = ~-to-≅ₜ n~n′₁
    in  ℕₜ₌ _ _ (conv:⇒*: [[ ⊢t , n , D' ]] A≡ℕ) (conv:⇒*: [[ ⊢u , n′ , D′ ]] A≡ℕ)
            n≡n′ (ne (neNfₜ₌ neN neN′ n~n′₁))
  neuEqTerm:⇒*: (ne (ne K [[ ⊢A , ⊢B , D ]] neK K≡K)) neN neN′ [[ ⊢t , n , D' ]] [[ ⊢u , n′ , D′ ]] n~n′ =
    let A≡K = subset* D
    in  neₜ₌ _ _ (conv:⇒*: [[ ⊢t , n , D' ]] A≡K) (conv:⇒*: [[ ⊢u , n′ , D′ ]] A≡K)
             (neNfₜ₌ neN neN′ (~-conv n~n′ A≡K))
  neuEqTerm:⇒*: (Πᵣ′ rF lF lG lF≤ lG≤ F G [[ ⊢A , ⊢B , D ]] ⊢F ⊢G A≡A [F] [G] G-ext) neN neN′ [[ ⊢t , n , D' ]] [[ ⊢u , n′ , D′ ]] n~n′ =
    let [ΠFG] = Πᵣ′ rF lF lG lF≤ lG≤ F G [[ ⊢A , ⊢B , D ]] ⊢F ⊢G A≡A [F] [G] G-ext
        A≡ΠFG = subset* D
        n~n′₁ = ~-conv n~n′ A≡ΠFG
        n≡n′ = ~-to-≅ₜ n~n′₁
        n~n = ~-trans n~n′ (~-sym n~n′)
        n′~n′ = ~-trans (~-sym n~n′) n~n′
    in  Πₜ₌ _ _ (conv:⇒*: [[ ⊢t , n , D' ]] A≡ΠFG) (conv:⇒*: [[ ⊢u , n′ , D′ ]] A≡ΠFG)
            (ne neN) (ne neN′) n≡n′
            (neuTerm:⇒*: [ΠFG] neN [[ ⊢t , n , D' ]] n~n) (neuTerm:⇒*: [ΠFG] neN′ [[ ⊢u , n′ , D′ ]] n′~n′)
            (λ {ρ} [ρ] ⊢Δ [a] →
               let ρA≡ρΠFG = wkEq [ρ] ⊢Δ A≡ΠFG
                   ρn = wkTerm [ρ] ⊢Δ n
                   ρn′ = wkTerm [ρ] ⊢Δ n′
                   a = escapeTerm ([F] [ρ] ⊢Δ) [a]
                   a≡a = escapeTermEq ([F] [ρ] ⊢Δ)
                                          (reflEqTerm ([F] [ρ] ⊢Δ) [a])
                   neN∙a   = ∘ₙ (wkNeutral ρ neN)
                   neN′∙a′ = ∘ₙ (wkNeutral ρ neN′)
               in  neuEqTerm ([G] [ρ] ⊢Δ [a]) neN∙a neN′∙a′
                             (conv ρn  ρA≡ρΠFG ∘ⱼ a)
                             (conv ρn′ ρA≡ρΠFG ∘ⱼ a)
                             (~-app (~-wk [ρ] ⊢Δ n~n′₁) a≡a) )
  neuEqTerm:⇒*: {ι ¹} (emb l< X) neN n neN′ n:≡:n′ = neuEqTerm:⇒*: X neN n neN′ n:≡:n′
  neuEqTerm:⇒*: {∞} (emb l< X) neN n neN′ n:≡:n′ = neuEqTerm:⇒*: X neN n neN′ n:≡:n′


-- Andreas, 2016-02-02, issue reported by Nisse

record R : Set₁ where
  field F : Set

postulate r : R

open R r using (F)

S : Set
S = F

-- Run "Explain why a particular name is in scope" (C-c C-w) for F.
-- Expected result:
--
-- F is in scope as
--   * a record field Issue1804._.F brought into scope by
--     - the application of R at ...
--     - its definition at ...


record _×_ (A B : Set) : Set where
  constructor _,_
  field
    fst : A
    snd : B

open _×_

app : {A B : Set} → (A → B) × A → B
app (f , x) = f x

data D : Set where d : D

postulate
  P   : {A : Set} → A → Set
  p   : (f : D → D) → P f → P (f d)
  foo : (F : Set → Set) → F D
  bar : (F : Set → Set) → P (foo F)

q : P (app (foo (λ A → (A → A) × A)))
q =
  let H : Set → Set
      H = _ in
  p (foo H) (bar H)

-- An internal error has occurred. Please report this as a bug.
-- Location of the error: src/full/Agda/TypeChecking/Conversion.hs:668


------------------------------------------------------------------------
-- Parsing of mixfix operators
------------------------------------------------------------------------

-- This module defines a grammar for the precedence graph g. The
-- grammar is neither left nor right recursive.

open import Mixfix.Expr
open import Mixfix.Acyclic.PrecedenceGraph
  using (acyclic; precedence)

module Mixfix.Acyclic.Grammar
         (g : PrecedenceGraphInterface.PrecedenceGraph acyclic)
         where

open import Codata.Musical.Notation
open import Data.List using (List; []; _∷_)
open import Data.List.Membership.Propositional using (_∈_)
open import Data.List.Relation.Unary.Any using (here; there)
open import Data.List.NonEmpty using (foldr; foldl)
open import Data.Product
open import Data.Bool
import Data.String as String
import Relation.Binary.PropositionalEquality as P

open PrecedenceCorrect acyclic g

import StructurallyRecursiveDescentParsing.Simplified as Simplified
open Simplified hiding (Parser; ⟦_⟧)
open import Mixfix.Fixity
open import Mixfix.Operator
open import Mixfix.Acyclic.Lib renaming (ParserProg to Parser)

-- The following definition uses a lexicographic combination of
-- guarded corecursion and structural recursion. The only "corecursive
-- call", where the size of the inductive input can increase
-- arbitrarily, is the one in expr.

mutual

  -- Expressions.

  expr : ∞ (Parser (Expr g))
  expr = ♯ precs g

  -- Expressions corresponding to zero or more nodes in the precedence
  -- graph: operator applications where the outermost operator has one
  -- of the precedences ps. The graph g is used for internal
  -- expressions.

  precs : (ps : List Precedence) → Parser (Expr ps)
  precs []       = fail
  precs (p ∷ ps) = (λ e → here P.refl ∙ proj₂ e) <$> prec p
                 ∣ weakenE                       <$> precs ps

  -- Expressions corresponding to one node in the precedence graph:
  -- operator applications where the outermost operator has
  -- precedence p. The graph g is used for internal expressions.

  prec : (p : Precedence) → Parser (∃ (ExprIn p))
  prec (precedence ops sucs) =
      ⟪_⟫    <$>       [ closed   ]
    ∥ _⟨_⟩_  <$>  p↑ ⊛ [ infx non ] ⊛ p↑
    ∥ appʳ   <$>       preRight +   ⊛ p↑
    ∥ appˡ   <$>  p↑ ⊛ postLeft +
    ∥ fail
    module Prec where
    p = precedence ops sucs

    -- [ fix ] parses the internal parts of operators with the
    -- current precedence level and fixity fix.
    [_] = λ (fix : Fixity) → inner (ops fix)

    -- Operator applications where the outermost operator binds
    -- tighter than the current precedence level.
    p↑ = precs sucs

    -- Right associative and prefix operators.
    preRight : Parser (Outer p right → ExprIn p right)
    preRight =  ⟪_⟩_  <$>      [ prefx      ]
             ∣ _⟨_⟩ʳ_ <$> p↑ ⊛ [ infx right ]

    -- Left associative and postfix operators.
    postLeft : Parser (Outer p left → ExprIn p left)
    postLeft = (λ op    e₁ → e₁ ⟨ op ⟫    ) <$> [ postfx    ]
             ∣ (λ op e₂ e₁ → e₁ ⟨ op ⟩ˡ e₂) <$> [ infx left ] ⊛ p↑

    -- Post-processing for the non-empty lists returned by _+.
    appʳ = λ fs e → foldr (λ f e → f (similar e)) (λ f → f (tighter e)) fs
    appˡ = λ e fs → foldl (λ e f → f (similar e)) (λ f → f (tighter e)) fs

  -- Internal parts (all name parts plus internal expressions) of
  -- operators of the given precedence and fixity.

  inner : ∀ {fix} (ops : List (∃ (Operator fix))) →
          Parser (Inner ops)
  inner []               = fail
  inner ((_ , op) ∷ ops) =
      (λ args → here P.refl ∙ args) <$> (expr between nameParts op)
    ∣ weakenI                       <$> inner ops

-- Expression parsers.

expression : Simplified.Parser NamePart false (Expr g)
expression = ⟦ ♭ expr ⟧


module Issue1760c where

-- Skipping an old-style mutual block: Before the `mutual` keyword.
{-# NO_POSITIVITY_CHECK #-}
mutual
  data D : Set where
    lam : (D → D) → D

  record U : Set where
    field ap : U → U


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

module MakeTracks where

open import Data.Fin        using (Fin; #_; toℕ)
open import Data.List       using (List; _∷_; []; map; concat; _++_; replicate; zip; length; take; drop)
open import Data.Nat        using (_*_; ℕ; suc; _+_)
open import Data.Nat.Show   using (show)
open import Data.Product    using (_,_; uncurry)
open import Data.Vec        using (fromList; toList; Vec; _∷_; []; lookup) renaming (replicate to rep; zip to vzip; map to vmap; concat to vconcat; _++_ to _+v_)

open import Instruments
open import Interval
open import Note
open import Pitch
open import MidiEvent
open import Util            using (fins')
open import Transformation

velocity : Velocity
velocity = # 60

makeTrack : InstrumentNumber-1 → ℕ → Channel-1 → List Note → MidiTrack
makeTrack inst tempo n notes = track (show (suc (toℕ n))) inst n tempo (notes→events velocity notes)

makeTracks : {k : Fin maxChannels} → Vec InstrumentNumber-1 maxChannels → ℕ → Vec (List Note) (toℕ k) → Vec MidiTrack (toℕ k)
makeTracks {k} insts tempo lines =
  vmap (λ (i , ns) → makeTrack (lookup insts i) tempo i ns)
       (vzip (fins' maxChannels k) lines)

makeTrackList : {k : Fin maxChannels} → Vec InstrumentNumber-1 maxChannels → ℕ → Vec (List Note) (toℕ k) → List MidiTrack
makeTrackList insts tempo lines = toList (makeTracks insts tempo lines)


{-# OPTIONS --universe-polymorphism #-}

module Issue229 where

open import Common.Level

data Works a b : Set (lsuc a ⊔ lsuc b) where
  w : (A : Set a)(B : Set b) → Works a b

record Doesn'tWork a b : Set (lsuc a ⊔ lsuc b) where
  field
    A : Set a
    B : Set b

-- An internal error has occurred. Please report this as a bug.
-- Location of the error: src/full/Agda/Interaction/Highlighting/Generate.hs:469


------------------------------------------------------------------------
-- The semantics given in OneSemantics and TwoSemantics are equivalent
------------------------------------------------------------------------

module Lambda.Substitution.Equivalence where

open import Codata.Musical.Notation

open import Lambda.Syntax
open WHNF
open import Lambda.Substitution.OneSemantics
open import Lambda.Substitution.TwoSemantics

⇒⟶⇓ : ∀ {n t} {v : Value n} → t ⇒ val v → t ⇓ v
⇒⟶⇓ val                 = val
⇒⟶⇓ (app t₁⇓ t₂⇓ t₁t₂⇒) = app (⇒⟶⇓ t₁⇓) (⇒⟶⇓ t₂⇓) (⇒⟶⇓ t₁t₂⇒)

⇒⊥⟶⇑ : ∀ {n} {t : Tm n} → t ⇒ ⊥ → t ⇑
⇒⊥⟶⇑ (·ˡ t₁⇑)            = ·ˡ (♯ (⇒⊥⟶⇑ (♭ t₁⇑)))
⇒⊥⟶⇑ (·ʳ t₁⇓ t₂⇑)        = ·ʳ (⇒⟶⇓ t₁⇓) (♯ (⇒⊥⟶⇑ (♭ t₂⇑)))
⇒⊥⟶⇑ (app t₁⇓ t₂⇓ t₁t₂⇒) = app (⇒⟶⇓ t₁⇓) (⇒⟶⇓ t₂⇓) (♯ (⇒⊥⟶⇑ (♭ t₁t₂⇒)))

⇓⟶⇒ : ∀ {n t} {v : Value n} → t ⇓ v → t ⇒ val v
⇓⟶⇒ val                 = val
⇓⟶⇒ (app t₁⇓ t₂⇓ t₁t₂⇓) = app (⇓⟶⇒ t₁⇓) (⇓⟶⇒ t₂⇓) (⇓⟶⇒ t₁t₂⇓)

⇑⟶⇒⊥ : ∀ {n} {t : Tm n} → t ⇑ → t ⇒ ⊥
⇑⟶⇒⊥ (·ˡ t₁⇑)            = ·ˡ (♯ (⇑⟶⇒⊥ (♭ t₁⇑)))
⇑⟶⇒⊥ (·ʳ t₁⇓ t₂⇑)        = ·ʳ (⇓⟶⇒ t₁⇓) (♯ (⇑⟶⇒⊥ (♭ t₂⇑)))
⇑⟶⇒⊥ (app t₁⇓ t₂⇓ t₁t₂⇓) = app (⇓⟶⇒ t₁⇓) (⇓⟶⇒ t₂⇓) (♯ (⇑⟶⇒⊥ (♭ t₁t₂⇓)))


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

open import Prelude
import GSeTT.Syntax
import GSeTT.Rules
import GSeTT.Typed-Syntax
open import MCaTT.Desuspension
open import CaTT.Ps-contexts
import CaTT.CaTT

module MCaTT.MCaTT where

  J = CaTT.CaTT.J
  eqdecJ = CaTT.CaTT.eqdecJ

  open import Globular-TT.Syntax J

  ↓C : Pre-Ctx → Pre-Ctx
  ↓T : Pre-Ctx → Pre-Ty → Pre-Ty
  ↓t : Pre-Ctx → Pre-Tm → Pre-Tm
  ↓S : Pre-Ctx → Pre-Sub → Pre-Sub

  ↓C ⊘ = ⊘
  ↓C (Γ ∙ x # ∗) = ↓C Γ
  ↓C (Γ ∙ x # A@(_ ⇒[ _ ] _)) = (↓C Γ) ∙ x # (↓T Γ A)

  ↓T Γ ∗ = ∗
  ↓T Γ (t ⇒[ ∗ ] u) = ∗
  ↓T Γ (t ⇒[ A@(_ ⇒[ _ ] _) ] u) = (↓t Γ t) ⇒[ ↓T Γ A ] (↓t Γ u)

  count-objects-in_until_ : Pre-Ctx → ℕ → ℕ
  count-objects-in ⊘ until x = 0
  count-objects-in Γ ∙ y # ∗ until x with dec-≤ y x
  ... | inl y≤x = S (count-objects-in Γ until x)
  ... | inr x<y = count-objects-in Γ until x
  count-objects-in Γ ∙ y # (_ ⇒[ _ ] _) until x = count-objects-in Γ until x

  ↓t Γ (Var x) = Var (x - (count-objects-in Γ until x))
  ↓t Δ (Tm-constructor i@(((Γ , _) , _) , _) γ) = Tm-constructor i (↓S (GPre-Ctx Γ) γ)

  ↓S Γ <> = <>
  ↓S Γ < γ , x ↦ t > = < ↓S Γ γ , x ↦ ↓t Γ t >

  rule : J → GSeTT.Typed-Syntax.Ctx × Pre-Ty
  rule (((Γ , Γ⊢ps) , A) , _) =
    let Γ⊢ = Γ⊢ps→Γ⊢ Γ⊢ps in
    (↓GC Γ Γ⊢ , ↓⊢C Γ Γ⊢) , ↓T (GPre-Ctx Γ) (CaTT.CaTT.Ty→Pre-Ty A)

  open import Globular-TT.Rules J rule
  open import Globular-TT.CwF-Structure J rule
  open import Globular-TT.Uniqueness-Derivations J rule eqdecJ
  open import Globular-TT.Disks J rule eqdecJ


{-# OPTIONS --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 r ρ} → ρ  ∷ Δ ⊆ Γ → step ρ ∷ Δ ∙ A ^ r ⊆ Γ
  lift : ∀ {Γ Δ A r ρ} → ρ  ∷ Δ ⊆ Γ → lift ρ ∷ Δ ∙ U.wk ρ A ^ r ⊆ Γ ∙ A ^ r

-- -- Weakening composition

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

-- Weakening of judgements

wkIndex : ∀ {Γ Δ n A r ρ} → ρ ∷ Δ ⊆ Γ →
        let ρA = U.wk ρ A
            ρn = wkVar ρ n
        in  ⊢ Δ → n ∷ A ^ r ∈ Γ → ρn ∷ ρA ^ r ∈ Δ
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 r ρ} → ρ ∷ Δ ⊆ Γ →
     let ρA = U.wk ρ A
     in  ⊢ Δ → Γ ⊢ A ^ r → Δ ⊢ ρA ^ r
  wk ρ ⊢Δ (Uⱼ ⊢Γ) = Uⱼ ⊢Δ
  wk ρ ⊢Δ (univ A) = univ (wkTerm ρ ⊢Δ A)

  wkTerm : ∀ {Γ Δ A t r ρ} → ρ ∷ Δ ⊆ Γ →
         let ρA = U.wk ρ A
             ρt = U.wk ρ t
         in ⊢ Δ → Γ ⊢ t ∷ A ^ r → Δ ⊢ ρt ∷ ρA ^ r
  wkTerm ρ ⊢Δ (univ <l ⊢Γ) = univ <l ⊢Δ
  wkTerm ρ ⊢Δ (ℕⱼ ⊢Γ) = ℕⱼ ⊢Δ
  wkTerm ρ ⊢Δ (Emptyⱼ ⊢Γ) = Emptyⱼ ⊢Δ
  wkTerm ρ ⊢Δ (Πⱼ <l ▹ <l' ▹ F ▹ G) = let ρF = wkTerm ρ ⊢Δ F
                                      in  Πⱼ <l ▹ <l' ▹ ρF ▹ (wkTerm (lift ρ) (⊢Δ ∙ univ ρF) G)
  wkTerm ρ ⊢Δ (∃ⱼ F ▹ G) = let ρF = wkTerm ρ ⊢Δ F
                          in  ∃ⱼ ρF ▹ (wkTerm (lift ρ) (⊢Δ ∙ univ ρF) G)
  wkTerm ρ ⊢Δ (var ⊢Γ x) = var ⊢Δ (wkIndex ρ ⊢Δ x)
  wkTerm ρ ⊢Δ (lamⱼ <l <l' F t) = let ρF = wk ρ ⊢Δ F
                                  in lamⱼ <l <l' ρF (wkTerm (lift ρ) (⊢Δ ∙ ρF) t)
  wkTerm ρ ⊢Δ (_∘ⱼ_ {G = G} g a) = PE.subst (λ x → _ ⊢ _ ∷ x ^ _)
                                           (PE.sym (wk-β G))
                                           (wkTerm ρ ⊢Δ g ∘ⱼ wkTerm ρ ⊢Δ a)
  wkTerm ρ ⊢Δ (⦅_,_,_,_⦆ⱼ {G = GG} F G t u )
    = let ρF = wk ρ ⊢Δ F in ⦅ wk ρ ⊢Δ F , wk (lift ρ) (⊢Δ ∙ ρF) G , wkTerm ρ ⊢Δ t ,  PE.subst (λ X → _ ⊢ _ ∷ X ^ [ % , _ ]) (wk-β GG) (wkTerm ρ ⊢Δ u) ⦆ⱼ
  wkTerm ρ ⊢Δ (fstⱼ F G t) = let ρF = wkTerm ρ ⊢Δ F in
    let ρG = (wkTerm (lift ρ) (⊢Δ ∙ univ ρF) G) in
    fstⱼ ρF ρG (wkTerm ρ ⊢Δ t)
  wkTerm ρ ⊢Δ (sndⱼ {G = G} F Gⱼ t) = let ρF = wkTerm ρ ⊢Δ F in
    let ρG = (wkTerm (lift ρ) (⊢Δ ∙ univ ρF) Gⱼ) in
    PE.subst (λ X → _ ⊢ _ ∷ X ^ [ % , _ ]) (PE.sym (wk-β G)) (sndⱼ ρF ρG (wkTerm ρ ⊢Δ t))
  wkTerm ρ ⊢Δ (zeroⱼ ⊢Γ) = zeroⱼ ⊢Δ
  wkTerm ρ ⊢Δ (sucⱼ n) = sucⱼ (wkTerm ρ ⊢Δ n)
  wkTerm {Δ = Δ} {ρ = ρ} [ρ] ⊢Δ (natrecⱼ {G = G} {rG = rG} {lG = lG}  {s = s} ⊢G ⊢z ⊢s ⊢n) =
    PE.subst (λ x → _ ⊢ natrec _ _ _ _ _ ∷ x ^ _) (PE.sym (wk-β G))
             (natrecⱼ (wk (lift [ρ]) (⊢Δ ∙ univ (ℕⱼ ⊢Δ)) ⊢G)
                      (PE.subst (λ x → _ ⊢ _ ∷ x ^ _) (wk-β G) (wkTerm [ρ] ⊢Δ ⊢z))
                      (PE.subst (λ x → Δ ⊢ U.wk ρ s ∷ x ^ [ rG , ι lG ])
                                (wk-β-natrec ρ G rG lG)
                                (wkTerm [ρ] ⊢Δ ⊢s))
                      (wkTerm [ρ] ⊢Δ ⊢n))
  wkTerm {Δ = Δ} {ρ = ρ} [ρ] ⊢Δ (Emptyrecⱼ {A = A} {e = e} ⊢A ⊢e) =
    (Emptyrecⱼ (wk [ρ] ⊢Δ ⊢A) (wkTerm [ρ] ⊢Δ ⊢e))
  wkTerm ρ ⊢Δ (Idⱼ A t u) = Idⱼ (wkTerm ρ ⊢Δ A) (wkTerm ρ ⊢Δ t) (wkTerm ρ ⊢Δ u)
  wkTerm ρ ⊢Δ (Idreflⱼ t) = Idreflⱼ (wkTerm ρ ⊢Δ t)
  wkTerm ρ ⊢Δ (transpⱼ {P = P} A Pⱼ t s u e) =
    let ρA = wk ρ ⊢Δ A in
    let ρP = wk (lift ρ) (⊢Δ ∙ ρA) Pⱼ in
    let ρt = wkTerm ρ ⊢Δ t in
    let ρs = PE.subst (λ x → _ ⊢ _ ∷ x ^ _) (wk-β P) (wkTerm ρ ⊢Δ s) in
    let ρu = wkTerm ρ ⊢Δ u in
    let ρe = wkTerm ρ ⊢Δ e in
    PE.subst (λ x → _ ⊢ transp _ _ _ _ _ _ ∷ x ^ _) (PE.sym (wk-β P))
      (transpⱼ ρA ρP ρt ρs ρu ρe)
  wkTerm ρ ⊢Δ (castⱼ A B e t) =
    castⱼ (wkTerm ρ ⊢Δ A) (wkTerm ρ ⊢Δ B) (wkTerm ρ ⊢Δ e) (wkTerm ρ ⊢Δ t)
  wkTerm ρ ⊢Δ (castreflⱼ A t) =
    castreflⱼ (wkTerm ρ ⊢Δ A) (wkTerm ρ ⊢Δ t)
  wkTerm ρ ⊢Δ (conv t A≡B) = conv (wkTerm ρ ⊢Δ t) (wkEq ρ ⊢Δ A≡B)

  wkEq : ∀ {Γ Δ A B r ρ} → ρ ∷ Δ ⊆ Γ →
       let ρA = U.wk ρ A
           ρB = U.wk ρ B
       in ⊢ Δ → Γ ⊢ A ≡ B ^ r → Δ ⊢ ρA ≡ ρB ^ r
  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)

  wkEqTerm : ∀ {Γ Δ A t u r ρ} → ρ ∷ Δ ⊆ Γ →
           let ρA = U.wk ρ A
               ρt = U.wk ρ t
               ρu = U.wk ρ u
           in ⊢ Δ → Γ ⊢ t ≡ u ∷ A ^ r → Δ ⊢ ρt ≡ ρu ∷ ρA ^ r
  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 <l <l' F F≡H G≡E) =
    let ρF = wk ρ ⊢Δ F
    in  Π-cong <l <l' ρF (wkEqTerm ρ ⊢Δ F≡H)
                         (wkEqTerm (lift ρ) (⊢Δ ∙ ρF) G≡E)
  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} l< l<' 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 l< l<' ρF (wkTerm (lift ρ) (⊢Δ ∙ ρF) ⊢t)
                                     (wkTerm ρ ⊢Δ ⊢a)))
  wkEqTerm ρ ⊢Δ (η-eq lF lG F f g f0≡g0) =
    let ρF = wk ρ ⊢Δ F
    in  η-eq lF lG ρ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} {l = l}
                                     F≡F′ z≡z′ s≡s′ n≡n′) =
    PE.subst (λ x → Δ ⊢ natrec _ _ _ _ _ ≡ _ ∷ x ^ _) (PE.sym (wk-β F))
             (natrec-cong (wkEq (lift [ρ]) (⊢Δ ∙ univ (ℕⱼ ⊢Δ)) F≡F′)
                          (PE.subst (λ x → Δ ⊢ _ ≡ _ ∷ x ^ _) (wk-β F)
                                    (wkEqTerm [ρ] ⊢Δ z≡z′))
                          (PE.subst (λ x → Δ ⊢ U.wk ρ s
                                             ≡ U.wk ρ s′ ∷ x ^ [ ! , ι l ])
                                    (wk-β-natrec _ F ! l)
                                    (wkEqTerm [ρ] ⊢Δ s≡s′))
                          (wkEqTerm [ρ] ⊢Δ n≡n′))
  wkEqTerm {Δ = Δ} {ρ = ρ} [ρ] ⊢Δ (natrec-zero {z} {s} {F} {l = l} ⊢F ⊢z ⊢s) =
    PE.subst (λ x → Δ ⊢ natrec _ (U.wk (lift _) F) _ _ _ ≡ _ ∷ x ^ _)
             (PE.sym (wk-β F))
             (natrec-zero (wk (lift [ρ]) (⊢Δ ∙ univ (ℕⱼ ⊢Δ)) ⊢F)
                          (PE.subst (λ x → Δ ⊢ U.wk ρ z ∷ x ^ _)
                                    (wk-β F)
                                    (wkTerm [ρ] ⊢Δ ⊢z))
                          (PE.subst (λ x → Δ ⊢ U.wk ρ s ∷ x ^ [ ! , ι l ])
                                    (wk-β-natrec _ F ! l)
                                    (wkTerm [ρ] ⊢Δ ⊢s)))
  wkEqTerm {Δ = Δ} {ρ = ρ} [ρ] ⊢Δ (natrec-suc {n} {z} {s} {F} {l = l} ⊢n ⊢F ⊢z ⊢s) =
    PE.subst (λ x → Δ ⊢ natrec _ (U.wk (lift _) F) _ _ _
                      ≡ _ ∘ (natrec _ _ _ _ _) ^ _ ∷ x ^ _)
             (PE.sym (wk-β F))
             (natrec-suc (wkTerm [ρ] ⊢Δ ⊢n)
                         (wk (lift [ρ]) (⊢Δ ∙ univ (ℕⱼ ⊢Δ)) ⊢F)
                         (PE.subst (λ x → Δ ⊢ U.wk ρ z ∷ x ^ _)
                                   (wk-β F)
                                   (wkTerm [ρ] ⊢Δ ⊢z))
                         (PE.subst (λ x → Δ ⊢ U.wk ρ s ∷ x ^ [ ! , ι l ])
                                   (wk-β-natrec _ F ! l)
                                   (wkTerm [ρ] ⊢Δ ⊢s)))
  wkEqTerm {Δ = Δ} {ρ = ρ} [ρ] ⊢Δ (Emptyrec-cong {A = A} {A' = A'} {e = e} {e' = e'} A≡A' ⊢e ⊢e') =
    Emptyrec-cong (wkEq [ρ] ⊢Δ A≡A') (wkTerm [ρ] ⊢Δ ⊢e) (wkTerm [ρ] ⊢Δ ⊢e')
  wkEqTerm [ρ] ⊢Δ (proof-irrelevance t u) = proof-irrelevance (wkTerm [ρ] ⊢Δ t) (wkTerm [ρ] ⊢Δ u)
  wkEqTerm ρ ⊢Δ (Id-cong A t u) = Id-cong (wkEqTerm ρ ⊢Δ A) (wkEqTerm ρ ⊢Δ t) (wkEqTerm ρ ⊢Δ u)
  wkEqTerm {ρ = ρ} [ρ] ⊢Δ (Id-Π {rA = rA} {t = t} {u = u} <l <l' Aⱼ Bⱼ tⱼ uⱼ) =
    let ρA = wkTerm [ρ] ⊢Δ Aⱼ in
    let ρB = wkTerm (lift [ρ]) (⊢Δ ∙ univ ρA) Bⱼ in
    let ρt = wkTerm [ρ] ⊢Δ tⱼ in
    let ρu = wkTerm [ρ] ⊢Δ uⱼ in
    PE.subst
      (λ x → _ ⊢ Id _ (U.wk ρ t) _ ≡ Π _ ^ _ ° _ ▹ Id _ (x ∘ _ ^ _) _ ° _ ° _ ∷ _ ^ [ ! , _ ])
      (wk1-wk≡lift-wk1 ρ t)
      (PE.subst
        (λ x → _ ⊢ Id _ _ (U.wk ρ u) ≡ Π _ ^ _ ° _ ▹ Id _ _ (x ∘ _ ^ _) ° _ ° _ ∷ _ ^ [ ! , _ ])
        (wk1-wk≡lift-wk1 ρ u)
        (Id-Π <l <l' ρA ρB ρt ρu))
  wkEqTerm ρ ⊢Δ (Id-ℕ-00 ⊢Γ) = Id-ℕ-00 ⊢Δ
  wkEqTerm ρ ⊢Δ (Id-ℕ-SS m n) = Id-ℕ-SS (wkTerm ρ ⊢Δ m) (wkTerm ρ ⊢Δ n)
  wkEqTerm {Δ = Δ} {ρ = ρ} [ρ] ⊢Δ (Id-U-ΠΠ {A = A} {A' = A'} {rA = rA} {B = B} {B' = B'} Aⱼ Bⱼ A'ⱼ B'ⱼ) =
    let ρA = wkTerm [ρ] ⊢Δ Aⱼ in
    let ρA' = wkTerm [ρ] ⊢Δ A'ⱼ in
    let ρB = wkTerm (lift [ρ]) (⊢Δ ∙ (univ ρA)) Bⱼ in
    let ρB' = wkTerm (lift [ρ]) (⊢Δ ∙ (univ ρA')) B'ⱼ in
    let l = ⁰ in
    let l' = ¹ in
    let pred = λ A1 A1' A2' B1 B1' → Δ ⊢ U.wk ρ (Id (U l) (Π A ^ rA ° ⁰ ▹ B ° ⁰ ° l) (Π A' ^ rA ° ⁰ ▹ B' ° ⁰ ° l)) ≡ ∃ U.wk ρ (Id (Univ rA l) A A') ▹ (Π A1' ^ rA ° ⁰ ▹ Id (U l) (B1 [ cast l A2' A1 (Idsym (Univ rA l) A1 A2' (var 1)) (var 0) ]↑) B1' ° l' ° l') ∷ SProp l' ^ [ ! , next l' ] in
    let j1 : pred (wk1 (wk1 (U.wk ρ A))) (wk1 (U.wk ρ A')) (wk1 (wk1 (U.wk ρ A'))) (wk1d (U.wk (lift ρ) B)) (wk1d (U.wk (lift ρ) B'))
        j1 = Id-U-ΠΠ ρA ρB ρA' ρB' in
    let j2 = PE.subst (λ x → pred (wk1 (wk1 (U.wk ρ A))) x (wk1 (wk1 (U.wk ρ A'))) (wk1d (U.wk (lift ρ) B)) (wk1d (U.wk (lift ρ) B'))) (wk1-wk≡lift-wk1 ρ A') j1 in
    let j3 = PE.subst (λ x → pred x (U.wk (lift ρ) (wk1 A')) (wk1 (wk1 (U.wk ρ A'))) (wk1d (U.wk (lift ρ) B)) (wk1d (U.wk (lift ρ) B'))) (wk1wk1-wk≡liftlift-wk1 ρ A) j2 in
    let j4 = PE.subst (λ x → pred (U.wk (lift (lift ρ)) (wk1 (wk1 A))) (U.wk (lift ρ) (wk1 A')) x (wk1d (U.wk (lift ρ) B)) (wk1d (U.wk (lift ρ) B'))) (wk1wk1-wk≡liftlift-wk1 ρ A') j3 in
    let j5 = PE.subst (λ x → pred (U.wk (lift (lift ρ)) (wk1 (wk1 A))) (U.wk (lift ρ) (wk1 A')) (U.wk (lift (lift ρ)) (wk1 (wk1 A'))) x (wk1d (U.wk (lift ρ) B'))) (wk1d-wk≡lift-wk1d ρ B) j4 in
    let j6 = PE.subst (λ x → pred (U.wk (lift (lift ρ)) (wk1 (wk1 A))) (U.wk (lift ρ) (wk1 A')) (U.wk (lift (lift ρ)) (wk1 (wk1 A'))) (U.wk (lift (lift ρ)) (wk1d B)) x) (wk1d-wk≡lift-wk1d ρ B') j5 in
    let j7 = PE.subst (λ x → Δ ⊢ U.wk ρ (Id (U l) (Π A ^ rA ° ⁰ ▹ B ° ⁰ ° l) (Π A' ^ rA ° ⁰ ▹ B' ° ⁰ ° l)) ≡ ∃ U.wk ρ (Id (Univ rA l) A A') ▹ (Π U.wk (lift ρ) (wk1 A') ^ rA ° ⁰ ▹ Id (U l) (U.wk (lift (lift ρ)) (wk1d B) [ (cast l (U.wk (lift (lift ρ)) (wk1 (wk1 A'))) (U.wk (lift (lift ρ)) (wk1 (wk1 A))) x (var 0)) ]↑) (U.wk (lift (lift ρ)) (wk1d B')) ° l' ° l') ∷ SProp l' ^ [ ! , next l' ]) (PE.sym (wk-Idsym (lift (lift ρ)) (Univ rA l) (wk1 (wk1 A)) (wk1 (wk1 A')) (var 1))) j6 in
    PE.subst (λ x → Δ ⊢ U.wk ρ (Id (U l) (Π A ^ rA ° ⁰ ▹ B ° ⁰ ° l) (Π A' ^ rA ° ⁰ ▹ B' ° ⁰ ° l)) ≡ ∃ U.wk ρ (Id (Univ rA l) A A') ▹ (Π U.wk (lift ρ) (wk1 A') ^ rA ° ⁰ ▹ Id (U l) x (U.wk (lift (lift ρ)) (wk1d B')) ° l' ° l') ∷ SProp l' ^ [ ! , _ ]) (PE.sym (wk-β↑ {ρ = lift ρ} {a = cast l (wk1 (wk1 A')) (wk1 (wk1 A)) (Idsym (Univ rA l) (wk1 (wk1 A)) (wk1 (wk1 A')) (var 1)) (var 0)} (wk1d B))) j7
  wkEqTerm ρ ⊢Δ (Id-U-ℕℕ ⊢Γ) = Id-U-ℕℕ ⊢Δ
  wkEqTerm {Δ = Δ} {ρ = ρ} [ρ] ⊢Δ (Id-SProp {A = A} {B = B} Aⱼ Bⱼ) =
    let ρA = wkTerm [ρ] ⊢Δ Aⱼ
        ρB = wkTerm [ρ] ⊢Δ Bⱼ
        l = ⁰
        l' = ¹
    in
    PE.subst
      (λ x → _ ⊢ Id (SProp l) (U.wk ρ A) _ ≡ ∃ (Π U.wk ρ A ^ % ° ⁰ ▹ _ ° ⁰ ° l') ▹ (Π _ ^ % ° ⁰ ▹ x ° _ ° l') ∷ _ ^ [ ! , _ ])
      (wk1d-wk≡lift-wk1d ρ (wk1 A))
      (PE.subst
              (λ x → _ ⊢ Id (SProp l) (U.wk ρ A) _ ≡ ∃ (Π U.wk ρ A ^ % ° ⁰ ▹ _ ° ⁰ ° l') ▹ (Π _ ^ % ° ⁰ ▹  U.wk (lift (step id)) x ° _ ° l') ∷ _ ^ [ ! , _ ])
              (wk1-wk≡lift-wk1 ρ A)
              (PE.subst
                 (λ x → _ ⊢ Id (SProp l) (U.wk ρ A) (U.wk ρ B) ≡ ∃ (Π U.wk ρ A ^ % ° ⁰ ▹ x ° ⁰ ° l') ▹ (Π x ^ % ° ⁰ ▹ _ ° ⁰ ° l') ∷ SProp ¹ ^ [ ! , _ ])
                 (wk1-wk≡lift-wk1 ρ B) (Id-SProp {A = U.wk ρ A} {B = U.wk ρ B} ρA ρB)))
  wkEqTerm ρ ⊢Δ (Id-ℕ-0S n) = Id-ℕ-0S (wkTerm ρ ⊢Δ n)
  wkEqTerm ρ ⊢Δ (Id-ℕ-S0 n) = Id-ℕ-S0 (wkTerm ρ ⊢Δ n)
  wkEqTerm ρ ⊢Δ (Id-U-ℕΠ A B) =
    let ρA = wkTerm ρ ⊢Δ A in
    let ρB = wkTerm (lift ρ) (⊢Δ ∙ (univ ρA)) B in
    Id-U-ℕΠ ρA ρB
  wkEqTerm ρ ⊢Δ (Id-U-Πℕ A B) =
    let ρA = wkTerm ρ ⊢Δ A in
    let ρB = wkTerm (lift ρ) (⊢Δ ∙ (univ ρA)) B in
    Id-U-Πℕ ρA ρB
  wkEqTerm ρ ⊢Δ (Id-U-ΠΠ!% eq A B A' B') =
    let ρA = wkTerm ρ ⊢Δ A
        ρB = wkTerm (lift ρ) (⊢Δ ∙ (univ ρA)) B
        ρA' = wkTerm ρ ⊢Δ A'
        ρB' = wkTerm (lift ρ) (⊢Δ ∙ (univ ρA')) B'
    in Id-U-ΠΠ!% eq ρA ρB ρA' ρB'
  wkEqTerm ρ ⊢Δ (cast-cong A B t e e') = cast-cong (wkEqTerm ρ ⊢Δ A) (wkEqTerm ρ ⊢Δ B) (wkEqTerm ρ ⊢Δ t) (wkTerm ρ ⊢Δ e) (wkTerm ρ ⊢Δ e')
  wkEqTerm {Δ = Δ} {ρ = ρ} [ρ] ⊢Δ (cast-Π {A = A} {A' = A'} {rA = rA} {B = B} {B' = B'} {e = e} {f = f} Aⱼ Bⱼ A'ⱼ B'ⱼ eⱼ fⱼ) = let l = ⁰ in let lA = ⁰ in let lB = ⁰ in
    let ρA = wkTerm [ρ] ⊢Δ Aⱼ in
    let ρA' = wkTerm [ρ] ⊢Δ A'ⱼ in
    let ρB = wkTerm (lift [ρ]) (⊢Δ ∙ (univ ρA)) Bⱼ in
    let ρB' = wkTerm (lift [ρ]) (⊢Δ ∙ (univ ρA')) B'ⱼ in
    let ρe = wkTerm [ρ] ⊢Δ eⱼ in
    let ρf = wkTerm [ρ] ⊢Δ fⱼ in
    let pred = λ A1 A1' e1 f1 → Δ ⊢ U.wk ρ (cast l (Π A ^ rA ° lA ▹ B ° lB ° l) (Π A' ^ rA ° lA ▹ B' ° lB ° l) e f) ≡ (lam (U.wk ρ A') ▹ (let a = cast l A1' A1 (Idsym (Univ rA l) A1 A1' (fst e1)) (var 0) in cast l ((U.wk (lift ρ) B) [ a ]↑) (U.wk (lift ρ) B') ((snd e1) ∘ (var 0) ^ ¹) (f1 ∘ a ^ l)) ^ l) ∷ U.wk ρ (Π A' ^ rA ° lA ▹ B' ° lB ° l) ^ [ ! , _ ] in
    let j0 : pred (wk1 (U.wk ρ A)) (wk1 (U.wk ρ A')) (wk1 (U.wk ρ e)) (wk1 (U.wk ρ f))
        j0 = cast-Π ρA ρB ρA' ρB' ρe ρf
    in
    let j1 = PE.subst (λ x → pred x (wk1 (U.wk ρ A')) (wk1 (U.wk ρ e)) (wk1 (U.wk ρ f))) (wk1-wk≡lift-wk1 ρ A) j0 in
    let j2 = PE.subst (λ x → pred (U.wk (lift ρ) (wk1 A)) x (wk1 (U.wk ρ e)) (wk1 (U.wk ρ f))) (wk1-wk≡lift-wk1 ρ A') j1 in
    let j3 = PE.subst (λ x → pred (U.wk (lift ρ) (wk1 A)) (U.wk (lift ρ) (wk1 A')) x (wk1 (U.wk ρ f))) (wk1-wk≡lift-wk1 ρ e) j2 in
    let j4 = PE.subst (λ x → pred (U.wk (lift ρ) (wk1 A)) (U.wk (lift ρ) (wk1 A')) (U.wk (lift ρ) (wk1 e)) x) (wk1-wk≡lift-wk1 ρ f) j3 in
    let j5 = PE.subst (λ x → Δ ⊢ U.wk ρ (cast l (Π A ^ rA ° lA ▹ B ° lB ° l) (Π A' ^ rA ° lA ▹ B' ° lB ° l) e f) ≡ (lam (U.wk ρ A') ▹ (let a = cast l (U.wk (lift ρ) (wk1 A')) (U.wk (lift ρ) (wk1 A)) x (var 0) in cast l ((U.wk (lift ρ) B) [ a ]↑) (U.wk (lift ρ) B') ((snd (U.wk (lift ρ) (wk1 e))) ∘ (var 0) ^ ¹) ((U.wk (lift ρ) (wk1 f)) ∘ a ^ l)) ^ l) ∷ U.wk ρ (Π A' ^ rA ° lA ▹ B' ° lB ° l) ^ [ ! , ι l ]) (PE.sym (wk-Idsym (lift ρ) (Univ rA l) (wk1 A) (wk1 A') (fst (wk1 e)))) j4 in
    PE.subst (λ x → Δ ⊢ U.wk ρ (cast l (Π A ^ rA ° lA ▹ B ° lB ° l) (Π A' ^ rA ° lA ▹ B' ° lB ° l) e f) ≡ (lam (U.wk ρ A') ▹ (let a = U.wk (lift ρ) (cast l (wk1 A') (wk1 A) (Idsym (Univ rA l) (wk1 A) (wk1 A') (fst (wk1 e))) (var 0)) in cast l x (U.wk (lift ρ) B') ((snd (U.wk (lift ρ) (wk1 e))) ∘ (var 0) ^ ¹) ((U.wk (lift ρ) (wk1 f)) ∘ a ^ l)) ^ l) ∷ U.wk ρ (Π A' ^ rA ° lA ▹ B' ° lB ° l) ^ [ ! , ι l ]) (PE.sym (wk-β↑ {ρ = ρ} {a = (cast l (wk1 A') (wk1 A) (Idsym (Univ rA l) (wk1 A) (wk1 A') (fst (wk1 e))) (var 0))} B)) j5
  wkEqTerm ρ ⊢Δ (cast-ℕ-0 e) = cast-ℕ-0 (wkTerm ρ ⊢Δ e)
  wkEqTerm ρ ⊢Δ (cast-ℕ-S e n) = cast-ℕ-S (wkTerm ρ ⊢Δ e) (wkTerm ρ ⊢Δ n)

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

  wkRedTerm : ∀ {Γ Δ A l t u ρ} → ρ ∷ Δ ⊆ Γ →
           let ρA = U.wk ρ A
               ρt = U.wk ρ t
               ρu = U.wk ρ u
           in ⊢ Δ → Γ ⊢ t ⇒ u ∷ A ^ l → Δ ⊢ ρt ⇒ ρu ∷ ρA ^ l
  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} {lF} {lG} {a} {t} l< l<' ⊢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 l< l<' ⊢ρA (wkTerm (lift ρ) (⊢Δ ∙ ⊢ρA) ⊢t)
                                      (wkTerm ρ ⊢Δ ⊢a)))
  wkRedTerm {Δ = Δ} {ρ = ρ} [ρ] ⊢Δ (natrec-subst {s = s} {F = F} {l = l} ⊢F ⊢z ⊢s n⇒n′) =
    PE.subst (λ x → _ ⊢ natrec _ _ _ _ _ ⇒ _ ∷ x ^ _) (PE.sym (wk-β F))
             (natrec-subst (wk (lift [ρ]) (⊢Δ ∙ univ (ℕⱼ ⊢Δ)) ⊢F)
                           (PE.subst (λ x → _ ⊢ _ ∷ x ^ _) (wk-β F)
                                     (wkTerm [ρ] ⊢Δ ⊢z))
                           (PE.subst (λ x → Δ ⊢ U.wk ρ s ∷ x ^ [ ! , ι l ])
                                     (wk-β-natrec _ F ! l)
                                     (wkTerm [ρ] ⊢Δ ⊢s))
                           (wkRedTerm [ρ] ⊢Δ n⇒n′))
  wkRedTerm {Δ = Δ} {ρ = ρ} [ρ] ⊢Δ (natrec-zero {s = s} {F = F} {l = l} ⊢F ⊢z ⊢s) =
    PE.subst (λ x → _ ⊢ natrec _ (U.wk (lift ρ) F) _ _ _ ⇒ _ ∷ x ^ _)
             (PE.sym (wk-β F))
             (natrec-zero (wk (lift [ρ]) (⊢Δ ∙ univ (ℕⱼ ⊢Δ)) ⊢F)
                          (PE.subst (λ x → _ ⊢ _ ∷ x ^ _)
                                    (wk-β F)
                                    (wkTerm [ρ] ⊢Δ ⊢z))
                          (PE.subst (λ x → Δ ⊢ U.wk ρ s ∷ x ^ [ ! , ι l ])
                                    (wk-β-natrec ρ F ! l)
                                    (wkTerm [ρ] ⊢Δ ⊢s)))
  wkRedTerm {Δ = Δ} {ρ = ρ} [ρ] ⊢Δ (natrec-suc {s = s} {F = F} {l = l} ⊢n ⊢F ⊢z ⊢s) =
    PE.subst (λ x → _ ⊢ natrec _ _ _ _ _ ⇒ _ ∘ natrec _ _ _ _ _ ^ _ ∷ x  ^ _)
             (PE.sym (wk-β F))
             (natrec-suc (wkTerm [ρ] ⊢Δ ⊢n)
                         (wk (lift [ρ]) (⊢Δ ∙ univ (ℕⱼ ⊢Δ)) ⊢F)
                         (PE.subst (λ x → _ ⊢ _ ∷ x ^ _)
                                   (wk-β F)
                                   (wkTerm [ρ] ⊢Δ ⊢z))
                         (PE.subst (λ x → Δ ⊢ U.wk ρ s ∷ x ^ [ ! , ι l ])
                                   (wk-β-natrec ρ F ! l)
                                   (wkTerm [ρ] ⊢Δ ⊢s)))
  wkRedTerm ρ ⊢Δ (Id-subst A t u) = Id-subst (wkRedTerm ρ ⊢Δ A) (wkTerm ρ ⊢Δ t) (wkTerm ρ ⊢Δ u)
  wkRedTerm ρ ⊢Δ (Id-ℕ-subst m n) = Id-ℕ-subst (wkRedTerm ρ ⊢Δ m) (wkTerm ρ ⊢Δ n)
  wkRedTerm ρ ⊢Δ (Id-ℕ-0-subst n) = Id-ℕ-0-subst (wkRedTerm ρ ⊢Δ n)
  wkRedTerm ρ ⊢Δ (Id-ℕ-S-subst m n) = Id-ℕ-S-subst (wkTerm ρ ⊢Δ m) (wkRedTerm ρ ⊢Δ n)
  wkRedTerm ρ ⊢Δ (Id-U-subst A B) = Id-U-subst (wkRedTerm ρ ⊢Δ A) (wkTerm ρ ⊢Δ B)
  wkRedTerm ρ ⊢Δ (Id-U-ℕ-subst B) = Id-U-ℕ-subst (wkRedTerm ρ ⊢Δ B)
  wkRedTerm ρ ⊢Δ (Id-U-Π-subst A P B) = let ρA = wkTerm ρ ⊢Δ A in Id-U-Π-subst ρA (wkTerm (lift ρ) (⊢Δ ∙ (univ ρA)) P) (wkRedTerm ρ ⊢Δ B)
  wkRedTerm {ρ = ρ} [ρ] ⊢Δ (Id-Π {t = t} {u = u} <l <l' Aⱼ Bⱼ tⱼ uⱼ) =
    let ρA = wkTerm [ρ] ⊢Δ Aⱼ in
    let ρB = wkTerm (lift [ρ]) (⊢Δ ∙ (univ ρA)) Bⱼ in
    let ρt = wkTerm [ρ] ⊢Δ tⱼ in
    let ρu = wkTerm [ρ] ⊢Δ uⱼ in
    PE.subst
      (λ x → _ ⊢ Id _ (U.wk ρ t) _ ⇒ Π _ ^ _ ° _ ▹ Id _ (x ∘ _ ^ _) _ ° _ ° _ ∷ _ ^ _)
      (wk1-wk≡lift-wk1 ρ t)
      (PE.subst
        (λ x → _ ⊢ Id _ _ (U.wk ρ u) ⇒ Π _ ^ _ ° _ ▹ Id _ _ (x ∘ _ ^ _) ° _ ° _ ∷ _ ^ _)
        (wk1-wk≡lift-wk1 ρ u)
        (Id-Π <l <l' ρA ρB ρt ρu))
  wkRedTerm ρ ⊢Δ (Id-ℕ-00 ⊢Γ) = Id-ℕ-00 ⊢Δ
  wkRedTerm ρ ⊢Δ (Id-ℕ-SS m n) = Id-ℕ-SS (wkTerm ρ ⊢Δ m) (wkTerm ρ ⊢Δ n)
  wkRedTerm {Δ = Δ} {ρ = ρ} [ρ] ⊢Δ (Id-U-ΠΠ {A = A} {A' = A'} {rA = rA} {B = B} {B' = B'} Aⱼ Bⱼ A'ⱼ B'ⱼ) =
    let l = ⁰ in
    let l' = ¹ in
    let ρA = wkTerm [ρ] ⊢Δ Aⱼ in
    let ρA' = wkTerm [ρ] ⊢Δ A'ⱼ in
    let ρB = wkTerm (lift [ρ]) (⊢Δ ∙ (univ ρA)) Bⱼ in
    let ρB' = wkTerm (lift [ρ]) (⊢Δ ∙ (univ ρA')) B'ⱼ in
    let pred = λ A1 A1' A2' B1 B1' → Δ ⊢ U.wk ρ (Id (U l) (Π A ^ rA ° ⁰ ▹ B ° ⁰ ° l) (Π A' ^ rA ° ⁰ ▹ B' ° ⁰ ° l)) ⇒ ∃ U.wk ρ (Id (Univ rA l) A A') ▹ (Π A1' ^ rA ° ⁰ ▹ Id (U l) (B1 [ cast l A2' A1 (Idsym (Univ rA l) A1 A2' (var 1)) (var 0) ]↑) B1' ° l' ° l') ∷ SProp l' ^ next l' in
    let j1 : pred (wk1 (wk1 (U.wk ρ A))) (wk1 (U.wk ρ A')) (wk1 (wk1 (U.wk ρ A'))) (wk1d (U.wk (lift ρ) B)) (wk1d (U.wk (lift ρ) B'))
        j1 = Id-U-ΠΠ ρA ρB ρA' ρB' in
    let j2 = PE.subst (λ x → pred (wk1 (wk1 (U.wk ρ A))) x (wk1 (wk1 (U.wk ρ A'))) (wk1d (U.wk (lift ρ) B)) (wk1d (U.wk (lift ρ) B'))) (wk1-wk≡lift-wk1 ρ A') j1 in
    let j3 = PE.subst (λ x → pred x (U.wk (lift ρ) (wk1 A')) (wk1 (wk1 (U.wk ρ A'))) (wk1d (U.wk (lift ρ) B)) (wk1d (U.wk (lift ρ) B'))) (wk1wk1-wk≡liftlift-wk1 ρ A) j2 in
    let j4 = PE.subst (λ x → pred (U.wk (lift (lift ρ)) (wk1 (wk1 A))) (U.wk (lift ρ) (wk1 A')) x (wk1d (U.wk (lift ρ) B)) (wk1d (U.wk (lift ρ) B'))) (wk1wk1-wk≡liftlift-wk1 ρ A') j3 in
    let j5 = PE.subst (λ x → pred (U.wk (lift (lift ρ)) (wk1 (wk1 A))) (U.wk (lift ρ) (wk1 A')) (U.wk (lift (lift ρ)) (wk1 (wk1 A'))) x (wk1d (U.wk (lift ρ) B'))) (wk1d-wk≡lift-wk1d ρ B) j4 in
    let j6 = PE.subst (λ x → pred (U.wk (lift (lift ρ)) (wk1 (wk1 A))) (U.wk (lift ρ) (wk1 A')) (U.wk (lift (lift ρ)) (wk1 (wk1 A'))) (U.wk (lift (lift ρ)) (wk1d B)) x) (wk1d-wk≡lift-wk1d ρ B') j5 in
    let j7 = PE.subst (λ x → Δ ⊢ U.wk ρ (Id (U l) (Π A ^ rA ° ⁰ ▹ B ° ⁰ ° l) (Π A' ^ rA ° ⁰ ▹ B' ° ⁰ ° l)) ⇒ ∃ U.wk ρ (Id (Univ rA l) A A') ▹ (Π U.wk (lift ρ) (wk1 A') ^ rA ° ⁰ ▹ Id (U l) (U.wk (lift (lift ρ)) (wk1d B) [ (cast l (U.wk (lift (lift ρ)) (wk1 (wk1 A'))) (U.wk (lift (lift ρ)) (wk1 (wk1 A))) x (var 0)) ]↑) (U.wk (lift (lift ρ)) (wk1d B')) ° l' ° l') ∷ SProp l' ^ next l') (PE.sym (wk-Idsym (lift (lift ρ)) (Univ rA l) (wk1 (wk1 A)) (wk1 (wk1 A')) (var 1))) j6 in
    PE.subst (λ x → Δ ⊢ U.wk ρ (Id (U l) (Π A ^ rA ° ⁰ ▹ B ° ⁰ ° l) (Π A' ^ rA ° ⁰ ▹ B' ° ⁰ ° l)) ⇒ ∃ U.wk ρ (Id (Univ rA l) A A') ▹ (Π U.wk (lift ρ) (wk1 A') ^ rA ° ⁰ ▹ Id (U l) x (U.wk (lift (lift ρ)) (wk1d B')) ° l' ° l') ∷ SProp l' ^ next l') (PE.sym (wk-β↑ {ρ = lift ρ} {a = cast l (wk1 (wk1 A')) (wk1 (wk1 A)) (Idsym (Univ rA l) (wk1 (wk1 A)) (wk1 (wk1 A')) (var 1)) (var 0)} (wk1d B))) j7
  wkRedTerm ρ ⊢Δ (Id-U-ℕℕ ⊢Γ) = Id-U-ℕℕ ⊢Δ
  wkRedTerm {ρ = ρ} [ρ] ⊢Δ (Id-SProp {A = A} {B = B} Aⱼ Bⱼ) =
    let ρA = wkTerm [ρ] ⊢Δ Aⱼ
        ρB = wkTerm [ρ] ⊢Δ Bⱼ
        l = ⁰
        l' = ¹
    in
    PE.subst
      (λ x → _ ⊢ Id (SProp l) (U.wk ρ A) _ ⇒ ∃ (Π U.wk ρ A ^ % ° ⁰ ▹ _ ° ⁰ ° _) ▹ (Π _ ^ % ° ⁰ ▹ x ° _ ° _) ∷ _ ^ _)
      (wk1d-wk≡lift-wk1d ρ (wk1 A))
      (PE.subst
              (λ x → _ ⊢ Id (SProp l) (U.wk ρ A) _ ⇒ ∃ (Π U.wk ρ A ^ % ° ⁰ ▹ _ ° ⁰ ° _) ▹ (Π _ ^ % ° ⁰ ▹  U.wk (lift (step id)) x ° _ ° _) ∷ _ ^ _ )
              (wk1-wk≡lift-wk1 ρ A)
              (PE.subst
                 (λ x → _ ⊢ Id (SProp l) (U.wk ρ A) (U.wk ρ B) ⇒ ∃ (Π U.wk ρ A ^ % ° ⁰ ▹ x ° ⁰ ° _) ▹ (Π x ^ % ° ⁰ ▹ _ ° ⁰ ° _) ∷ SProp ¹ ^ _ )
                 (wk1-wk≡lift-wk1 ρ B) (Id-SProp {A = U.wk ρ A} {B = U.wk ρ B} ρA ρB)))
  wkRedTerm ρ ⊢Δ (Id-ℕ-0S n) = Id-ℕ-0S (wkTerm ρ ⊢Δ n)
  wkRedTerm ρ ⊢Δ (Id-ℕ-S0 n) = Id-ℕ-S0 (wkTerm ρ ⊢Δ n)
  wkRedTerm ρ ⊢Δ (Id-U-ℕΠ A B) =
    let ρA = wkTerm ρ ⊢Δ A in
    let ρB = wkTerm (lift ρ) (⊢Δ ∙ (univ ρA)) B in
    Id-U-ℕΠ ρA ρB
  wkRedTerm ρ ⊢Δ (Id-U-Πℕ A B) =
    let ρA = wkTerm ρ ⊢Δ A in
    let ρB = wkTerm (lift ρ) (⊢Δ ∙ (univ ρA)) B in
    Id-U-Πℕ ρA ρB
  wkRedTerm ρ ⊢Δ (Id-U-ΠΠ!% eq A B A' B') =
    let ρA = wkTerm ρ ⊢Δ A
        ρB = wkTerm (lift ρ) (⊢Δ ∙ (univ ρA)) B
        ρA' = wkTerm ρ ⊢Δ A'
        ρB' = wkTerm (lift ρ) (⊢Δ ∙ (univ ρA')) B'
    in Id-U-ΠΠ!% eq ρA ρB ρA' ρB'
  wkRedTerm ρ ⊢Δ  (cast-subst A B e t) = cast-subst (wkRedTerm ρ ⊢Δ A) (wkTerm ρ ⊢Δ  B) (wkTerm ρ ⊢Δ e) (wkTerm ρ ⊢Δ t)
  wkRedTerm ρ ⊢Δ  (cast-ℕ-subst B e t) = cast-ℕ-subst (wkRedTerm ρ ⊢Δ B) (wkTerm ρ ⊢Δ e) (wkTerm ρ ⊢Δ t)
  wkRedTerm ρ ⊢Δ  (cast-Π-subst A P B e t) = let ρA = wkTerm ρ ⊢Δ A in cast-Π-subst ρA (wkTerm (lift ρ) (⊢Δ ∙ (univ ρA)) P) (wkRedTerm ρ ⊢Δ B) (wkTerm ρ ⊢Δ e) (wkTerm ρ ⊢Δ t)
  wkRedTerm {Δ = Δ} {ρ = ρ} [ρ] ⊢Δ (cast-Π {A = A} {A' = A'} {rA = rA} {B = B} {B' = B'} {e = e} {f = f} Aⱼ Bⱼ A'ⱼ B'ⱼ eⱼ fⱼ) = let l = ⁰ in let lA = ⁰ in let lB = ⁰ in
    let ρA = wkTerm [ρ] ⊢Δ Aⱼ in
    let ρA' = wkTerm [ρ] ⊢Δ A'ⱼ in
    let ρB = wkTerm (lift [ρ]) (⊢Δ ∙ (univ ρA)) Bⱼ in
    let ρB' = wkTerm (lift [ρ]) (⊢Δ ∙ (univ ρA')) B'ⱼ in
    let ρe = wkTerm [ρ] ⊢Δ eⱼ in
    let ρf = wkTerm [ρ] ⊢Δ fⱼ in
    let pred = λ A1 A1' e1 f1 → Δ ⊢ U.wk ρ (cast l (Π A ^ rA ° lA ▹ B ° lB ° l) (Π A' ^ rA ° lA ▹ B' ° lB ° l) e f) ⇒ (lam (U.wk ρ A') ▹ (let a = cast l A1' A1 (Idsym (Univ rA l) A1 A1' (fst e1)) (var 0) in cast l ((U.wk (lift ρ) B) [ a ]↑) (U.wk (lift ρ) B') ((snd e1) ∘ (var 0) ^ ¹) (f1 ∘ a ^ l))  ^ l) ∷ U.wk ρ (Π A' ^ rA ° lA ▹ B' ° lB ° l) ^ _ in
    let j0 : pred (wk1 (U.wk ρ A)) (wk1 (U.wk ρ A')) (wk1 (U.wk ρ e)) (wk1 (U.wk ρ f))
        j0 = cast-Π ρA ρB ρA' ρB' ρe ρf
    in
    let j1 = PE.subst (λ x → pred x (wk1 (U.wk ρ A')) (wk1 (U.wk ρ e)) (wk1 (U.wk ρ f))) (wk1-wk≡lift-wk1 ρ A) j0 in
    let j2 = PE.subst (λ x → pred (U.wk (lift ρ) (wk1 A)) x (wk1 (U.wk ρ e)) (wk1 (U.wk ρ f))) (wk1-wk≡lift-wk1 ρ A') j1 in
    let j3 = PE.subst (λ x → pred (U.wk (lift ρ) (wk1 A)) (U.wk (lift ρ) (wk1 A')) x (wk1 (U.wk ρ f))) (wk1-wk≡lift-wk1 ρ e) j2 in
    let j4 = PE.subst (λ x → pred (U.wk (lift ρ) (wk1 A)) (U.wk (lift ρ) (wk1 A')) (U.wk (lift ρ) (wk1 e)) x) (wk1-wk≡lift-wk1 ρ f) j3 in
    let j5 = PE.subst (λ x → Δ ⊢ U.wk ρ (cast l (Π A ^ rA ° lA ▹ B ° lB ° l) (Π A' ^ rA ° lA ▹ B' ° lB ° l) e f) ⇒ (lam (U.wk ρ A') ▹ (let a = cast l (U.wk (lift ρ) (wk1 A')) (U.wk (lift ρ) (wk1 A)) x (var 0) in cast l ((U.wk (lift ρ) B) [ a ]↑) (U.wk (lift ρ) B') ((snd (U.wk (lift ρ) (wk1 e))) ∘ (var 0) ^ ¹) ((U.wk (lift ρ) (wk1 f)) ∘ a ^ l)) ^ l) ∷ U.wk ρ (Π A' ^ rA ° lA ▹ B' ° lB ° l) ^ ι l) (PE.sym (wk-Idsym (lift ρ) (Univ rA l) (wk1 A) (wk1 A') (fst (wk1 e)))) j4 in
   PE.subst (λ x → Δ ⊢ U.wk ρ (cast l (Π A ^ rA ° lA ▹ B ° lB ° l) (Π A' ^ rA ° lA ▹ B' ° lB ° l) e f) ⇒ (lam (U.wk ρ A') ▹ (let a = U.wk (lift ρ) (cast l (wk1 A') (wk1 A) (Idsym (Univ rA l) (wk1 A) (wk1 A') (fst (wk1 e))) (var 0)) in cast l x (U.wk (lift ρ) B') ((snd (U.wk (lift ρ) (wk1 e))) ∘ (var 0) ^ ¹) ((U.wk (lift ρ) (wk1 f)) ∘ a ^ l)) ^ l) ∷ U.wk ρ (Π A' ^ rA ° lA ▹ B' ° lB ° l) ^ ι l) (PE.sym (wk-β↑ {ρ = ρ} {a = (cast l (wk1 A') (wk1 A) (Idsym (Univ rA l) (wk1 A) (wk1 A') (fst (wk1 e))) (var 0))} B)) j5
  wkRedTerm ρ ⊢Δ (cast-ℕ-0 e) = cast-ℕ-0 (wkTerm ρ ⊢Δ e)
  wkRedTerm ρ ⊢Δ (cast-ℕ-S e n) = cast-ℕ-S (wkTerm ρ ⊢Δ e) (wkTerm ρ ⊢Δ n)
  wkRedTerm ρ ⊢Δ (cast-ℕ-cong e n) = cast-ℕ-cong (wkTerm ρ ⊢Δ e) (wkRedTerm ρ ⊢Δ n)

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

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

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

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


open import Nat
open import Prelude
open import List

open import contexts
open import core

open import lemmas-general
open import preservation

module eval-checks where
  eval-unicity : ∀{⛽ Δ Σ' Γ E e τ r r' K K'} →
                   Δ , Σ' , Γ ⊢ E →
                   Δ , Σ' , Γ ⊢ e :: τ →
                   E ⊢ e ⌊ ⛽ ⌋⇒ r ⊣ K →
                   E ⊢ e ⌊ ⛽ ⌋⇒ r' ⊣ K' →
                   r == r' ∧ K == K'

  xc-unicity : ∀{Δ Σ' r1 r2 τ K K'} →
                 Δ , Σ' ⊢ r1 ·: τ →
                 Δ , Σ' ⊢ r2 ·: τ →
                 Constraints⦃ r1 , r2 ⦄:= K →
                 Constraints⦃ r1 , r2 ⦄:= K' →
                 K == K'

  eval-unicity Γ⊢E (TAFix _) EFix EFix = refl , refl
  eval-unicity Γ⊢E (TAVar _) (EVar h) (EVar h') = ctxunicity h h' , refl
  eval-unicity Γ⊢E (TAApp _ ta-f ta-arg) (EAppFix f1 form eval-f eval-arg eval) (EAppFix f2 form' eval-f' eval-arg' eval')
    rewrite form | form'
    with eval-unicity Γ⊢E ta-f eval-f eval-f' | eval-unicity Γ⊢E ta-arg eval-arg eval-arg'
  ... | refl , refl | refl , refl
    with preservation Γ⊢E ta-f eval-f
  ... | TAFix Γ'⊢Ef (TAFix ta-ef)
    rewrite Fuel-depletion-unicity f1 f2
    with eval-unicity (EnvInd (EnvInd Γ'⊢Ef (preservation Γ⊢E ta-f eval-f)) (preservation Γ⊢E ta-arg eval-arg)) ta-ef eval eval'
  ... | refl , refl = refl , refl
  eval-unicity Γ⊢E TAUnit EUnit EUnit = refl , refl
  eval-unicity Γ⊢E (TAApp x ta-e ta-e₁) (EAppFix x₁ form eval eval₁ eval₂) (EAppUnfinished eval' nf eval'')
    with eval-unicity Γ⊢E ta-e eval eval'
  ... | refl , refl
    rewrite form
      = abort (nf refl)
  eval-unicity Γ⊢E (TAApp x ta-e ta-e₁) (EAppUnfinished eval nf eval₁) (EAppFix x₂ form eval' eval'' eval''')
    with eval-unicity Γ⊢E ta-e eval eval'
  ... | refl , refl
    rewrite form
      = abort (nf refl)
  eval-unicity Γ⊢E (TAApp x ta-f ta-arg) (EAppUnfinished eval-f x₁ eval-arg) (EAppUnfinished eval-f' x₂ eval-arg')
    with eval-unicity Γ⊢E ta-f eval-f eval-f' | eval-unicity Γ⊢E ta-arg eval-arg eval-arg'
  ... | refl , refl | refl , refl = refl , refl
  eval-unicity Γ⊢E (TAPair x ta-e1 ta-e2) (EPair eval1 eval2) (EPair eval1' eval2')
    with eval-unicity Γ⊢E ta-e1 eval1 eval1' | eval-unicity Γ⊢E ta-e2 eval2 eval2'
  ... | refl , refl | refl , refl = refl , refl
  eval-unicity Γ⊢E (TAFst ta-e) (EFst eval) (EFst eval')
    with eval-unicity Γ⊢E ta-e eval eval'
  ... | refl , refl = refl , refl
  eval-unicity Γ⊢E (TAFst ta-e) (EFst eval) (EFstUnfinished eval' np)
    with eval-unicity Γ⊢E ta-e eval eval'
  ... | refl , refl = abort (np refl)
  eval-unicity Γ⊢E (TAFst ta-e) (EFstUnfinished eval np) (EFst eval')
    with eval-unicity Γ⊢E ta-e eval eval'
  ... | refl , refl = abort (np refl)
  eval-unicity Γ⊢E (TAFst ta-e) (EFstUnfinished eval x) (EFstUnfinished eval' x₁)
    with eval-unicity Γ⊢E ta-e eval eval'
  ... | refl , refl = refl , refl
  eval-unicity Γ⊢E (TASnd ta-e) (ESnd eval) (ESnd eval')
    with eval-unicity Γ⊢E ta-e eval eval'
  ... | refl , refl = refl , refl
  eval-unicity Γ⊢E (TASnd ta-e) (ESnd eval) (ESndUnfinished eval' np)
    with eval-unicity Γ⊢E ta-e eval eval'
  ... | refl , refl = abort (np refl)
  eval-unicity Γ⊢E (TASnd ta-e) (ESndUnfinished eval np) (ESnd eval')
    with eval-unicity Γ⊢E ta-e eval eval'
  ... | refl , refl = abort (np refl)
  eval-unicity Γ⊢E (TASnd ta-e) (ESndUnfinished eval x) (ESndUnfinished eval' x₁)
    with eval-unicity Γ⊢E ta-e eval eval'
  ... | refl , refl = refl , refl
  eval-unicity Γ⊢E (TACtor x x₁ ta-e) (ECtor eval) (ECtor eval')
    with eval-unicity Γ⊢E ta-e eval eval'
  ... | refl , refl = refl , refl
  eval-unicity Γ⊢E (TACase d∈σ' ta-e x₁ ta-rules) (EMatch f1 form eval-e eval-ec) (EMatch f2 form' eval'-e eval'-ec)
    with eval-unicity Γ⊢E ta-e eval-e eval'-e
  ... | refl , refl
    with ctxunicity form form'
  ... | refl
    with ta-rules form
  ... | _ , _ , _ , c∈cctx , ta-ec
    with preservation Γ⊢E ta-e eval-e
  ... | TACtor d∈'σ' c∈'cctx ta-r'
    rewrite ctxunicity d∈σ' d∈'σ' | ctxunicity c∈cctx c∈'cctx | Fuel-depletion-unicity f1 f2
    with eval-unicity (EnvInd Γ⊢E ta-r') ta-ec eval-ec eval'-ec
  ... | refl , refl = refl , refl
  eval-unicity Γ⊢E (TACase x ta-e x₁ x₂) (EMatch x₃ x₄ eval eval₁) (EMatchUnfinished eval' nc)
    with eval-unicity Γ⊢E ta-e eval eval'
  ... | refl , refl = abort (nc refl)
  eval-unicity Γ⊢E (TACase x ta-e x₁ x₂) (EMatchUnfinished eval nc) (EMatch x₄ x₅ eval' eval'')
    with eval-unicity Γ⊢E ta-e eval eval'
  ... | refl , refl = abort (nc refl)
  eval-unicity Γ⊢E (TACase x ta-e x₁ x₂) (EMatchUnfinished eval x₃) (EMatchUnfinished eval' x₄)
    with eval-unicity Γ⊢E ta-e eval eval'
  ... | refl , refl = refl , refl
  eval-unicity Γ⊢E (TAHole x) EHole EHole = refl , refl
  eval-unicity Γ⊢E (TAAsrt x ta-e1 ta-e2) (EAsrt eval1 eval2 xc) (EAsrt eval1' eval2' xc')
    with eval-unicity Γ⊢E ta-e1 eval1 eval1' | eval-unicity Γ⊢E ta-e2 eval2 eval2'
  ... | refl , refl | refl , refl
    rewrite xc-unicity (preservation Γ⊢E ta-e1 eval1) (preservation Γ⊢E ta-e2 eval2) xc xc'
      = refl , refl

  xc-unicity ta1 ta2 RCRefl RCRefl = refl
  xc-unicity ta1 ta2 RCRefl (RCPair x rc2 rc3) = abort (x refl)
  xc-unicity ta1 ta2 RCRefl (RCCtor x rc2) = abort (x refl)
  xc-unicity ta1 ta2 RCRefl (RCVal1 x x₁ x₂ x₃) = abort (x refl)
  xc-unicity ta1 ta2 RCRefl (RCVal2 x x₁ x₂ x₃) = abort (x refl)
  xc-unicity ta1 ta2 (RCPair x rc1 rc2) RCRefl = abort (x refl)
  xc-unicity (TAPair ta1 ta2) (TAPair ta3 ta4) (RCPair x rc1 rc2) (RCPair x₁ rc3 rc4)
    rewrite xc-unicity ta1 ta3 rc1 rc3 | xc-unicity ta2 ta4 rc2 rc4
      = refl
  xc-unicity ta1 ta2 (RCPair x rc1 rc2) (RCVal1 x₁ (Inl x₂) x₃ x₄) = abort (x₂ refl)
  xc-unicity ta1 ta2 (RCPair x rc1 rc2) (RCVal1 x₁ (Inr x₂) x₃ x₄) = abort (x₂ refl)
  xc-unicity ta1 ta2 (RCPair x rc1 rc2) (RCVal2 x₁ (Inl x₂) x₃ x₄) = abort (x₂ refl)
  xc-unicity ta1 ta2 (RCPair x rc1 rc2) (RCVal2 x₁ (Inr x₂) x₃ x₄) = abort (x₂ refl)
  xc-unicity ta1 ta2 (RCCtor x rc1) RCRefl = abort (x refl)
  xc-unicity (TACtor d∈σ' c∈cctx ta1) (TACtor d∈'σ' c∈'cctx ta2) (RCCtor x rc1) (RCCtor x₁ rc2)
    rewrite ctxunicity d∈σ' d∈'σ' | ctxunicity c∈cctx c∈'cctx
      = xc-unicity ta1 ta2 rc1 rc2
  xc-unicity ta1 ta2 (RCCtor x rc1) (RCVal1 x₁ x₂ (Inl x₃) x₄) = abort (x₃ refl)
  xc-unicity ta1 ta2 (RCCtor x rc1) (RCVal1 x₁ x₂ (Inr x₃) x₄) = abort (x₃ refl)
  xc-unicity ta1 ta2 (RCCtor x rc1) (RCVal2 x₁ x₂ (Inl x₃) x₄) = abort (x₃ refl)
  xc-unicity ta1 ta2 (RCCtor x rc1) (RCVal2 x₁ x₂ (Inr x₃) x₄) = abort (x₃ refl)
  xc-unicity ta1 ta2 (RCVal1 x x₁ x₂ x₃) RCRefl = abort (x refl)
  xc-unicity ta1 ta2 (RCVal1 x (Inl x₁) x₂ x₃) (RCPair x₄ rc2 rc3) = abort (x₁ refl)
  xc-unicity ta1 ta2 (RCVal1 x (Inr x₁) x₂ x₃) (RCPair x₄ rc2 rc3) = abort (x₁ refl)
  xc-unicity ta1 ta2 (RCVal1 x _ (Inl x₁) x₃) (RCCtor x₄ rc2) = abort (x₁ refl)
  xc-unicity ta1 ta2 (RCVal1 x _ (Inr x₁) x₃) (RCCtor x₄ rc2) = abort (x₁ refl)
  xc-unicity ta1 ta2 (RCVal1 x x₁ x₂ x₃) (RCVal1 x₄ x₅ x₆ x₇)
    rewrite Coerce-unicity x₃ x₇
      = refl
  xc-unicity TAUnit TAUnit (RCVal1 x x₁ x₂ x₃) (RCVal2 x₄ x₅ x₆ x₇) = abort (x₄ refl)
  xc-unicity (TAPair ta1 ta2) (TAPair ta3 ta4) (RCVal1 x (Inl x₂) _ x₃) (RCVal2 x₄ x₅ x₆ x₇) = abort (x₂ refl)
  xc-unicity (TAPair ta1 ta2) (TAPair ta3 ta4) (RCVal1 x (Inr x₂) _ x₃) (RCVal2 x₄ x₅ x₆ x₇) = abort (x₂ refl)
  xc-unicity (TACtor x₈ x₉ ta1) (TACtor x₁₀ x₁₁ ta2) (RCVal1 x x₁ (Inl h) x₃) (RCVal2 x₄ x₅ x₆ x₇) = abort (h refl)
  xc-unicity (TACtor x₈ x₉ ta1) (TACtor x₁₀ x₁₁ ta2) (RCVal1 x x₁ (Inr h) x₃) (RCVal2 x₄ x₅ x₆ x₇) = abort (h refl)
  xc-unicity ta1 ta2 (RCVal2 x x₁ x₂ x₃) RCRefl = abort (x refl)
  xc-unicity ta1 ta2 (RCVal2 x (Inl x₁) x₂ x₃) (RCPair x₄ rc2 rc3) = abort (x₁ refl)
  xc-unicity ta1 ta2 (RCVal2 x (Inr x₁) x₂ x₃) (RCPair x₄ rc2 rc3) = abort (x₁ refl)
  xc-unicity ta1 ta2 (RCVal2 x x₁ (Inl x₂) x₃) (RCCtor x₄ rc2) = abort (x₂ refl)
  xc-unicity ta1 ta2 (RCVal2 x x₁ (Inr x₂) x₃) (RCCtor x₄ rc2) = abort (x₂ refl)
  xc-unicity TAUnit TAUnit (RCVal2 x x₁ x₂ x₃) (RCVal1 x₄ x₅ x₆ x₇) = abort (x refl)
  xc-unicity (TAPair ta1 ta2) (TAPair ta3 ta4) (RCVal2 x (Inl h) x₂ x₃) (RCVal1 x₄ x₅ x₆ x₇) = abort (h refl)
  xc-unicity (TAPair ta1 ta2) (TAPair ta3 ta4) (RCVal2 x (Inr h) x₂ x₃) (RCVal1 x₄ x₅ x₆ x₇) = abort (h refl)
  xc-unicity (TACtor x₈ x₉ ta1) (TACtor x₁₀ x₁₁ ta2) (RCVal2 x x₁ (Inl h) x₃) (RCVal1 x₄ x₅ x₆ x₇) = abort (h refl)
  xc-unicity (TACtor x₈ x₉ ta1) (TACtor x₁₀ x₁₁ ta2) (RCVal2 x x₁ (Inr h) x₃) (RCVal1 x₄ x₅ x₆ x₇) = abort (h refl)
  xc-unicity ta1 ta2 (RCVal2 x x₁ x₂ x₃) (RCVal2 x₄ x₅ x₆ x₇)
    rewrite Coerce-unicity x₃ x₇
      = refl

  -- useful in practice, since threading type-checks around everywhere can be a pain
  -- note that this does not prove unicity of constraints, which isn't true for poorly-typed terms
  untyped-eval-unicity : ∀{⛽ E e r r' K K'} →
                           E ⊢ e ⌊ ⛽ ⌋⇒ r ⊣ K →
                           E ⊢ e ⌊ ⛽ ⌋⇒ r' ⊣ K' →
                           r == r'
  untyped-eval-unicity EFix EFix = refl
  untyped-eval-unicity (EVar h) (EVar h') = ctxunicity h h'
  untyped-eval-unicity (EAppFix f1 form eval-f eval-arg eval) (EAppFix f2 form' eval-f' eval-arg' eval')
    rewrite form | form'
    with untyped-eval-unicity eval-f eval-f' | untyped-eval-unicity eval-arg eval-arg'
  ... | refl | refl
    rewrite Fuel-depletion-unicity f1 f2 | untyped-eval-unicity eval eval'
      = refl
  untyped-eval-unicity EUnit EUnit = refl
  untyped-eval-unicity (EAppFix x₁ form eval eval₁ eval₂) (EAppUnfinished eval' nf eval'')
    rewrite untyped-eval-unicity eval eval' | form
      = abort (nf refl)
  untyped-eval-unicity (EAppUnfinished eval nf eval₁) (EAppFix x₂ form eval' eval'' eval''')
    rewrite untyped-eval-unicity eval eval' | form
      = abort (nf refl)
  untyped-eval-unicity (EAppUnfinished eval-f x₁ eval-arg) (EAppUnfinished eval-f' x₂ eval-arg')
    rewrite untyped-eval-unicity eval-f eval-f' | untyped-eval-unicity eval-arg eval-arg'
      = refl
  untyped-eval-unicity (EPair eval1 eval2) (EPair eval1' eval2')
    rewrite untyped-eval-unicity eval1 eval1' | untyped-eval-unicity eval2 eval2'
      = refl
  untyped-eval-unicity (EFst eval) (EFst eval')
    with untyped-eval-unicity eval eval'
  ... | refl = refl
  untyped-eval-unicity (EFst eval) (EFstUnfinished eval' np)
    with untyped-eval-unicity eval eval'
  ... | refl = abort (np refl)
  untyped-eval-unicity (EFstUnfinished eval np) (EFst eval')
    with untyped-eval-unicity eval eval'
  ... | refl = abort (np refl)
  untyped-eval-unicity (EFstUnfinished eval x) (EFstUnfinished eval' x₁)
    with untyped-eval-unicity eval eval'
  ... | refl = refl
  untyped-eval-unicity (ESnd eval) (ESnd eval')
    with untyped-eval-unicity eval eval'
  ... | refl = refl
  untyped-eval-unicity (ESnd eval) (ESndUnfinished eval' np)
    with untyped-eval-unicity eval eval'
  ... | refl = abort (np refl)
  untyped-eval-unicity (ESndUnfinished eval np) (ESnd eval')
    with untyped-eval-unicity eval eval'
  ... | refl = abort (np refl)
  untyped-eval-unicity (ESndUnfinished eval x) (ESndUnfinished eval' x₁)
    with untyped-eval-unicity eval eval'
  ... | refl = refl
  untyped-eval-unicity (ECtor eval) (ECtor eval')
    with untyped-eval-unicity eval eval'
  ... | refl = refl
  untyped-eval-unicity (EMatch f1 form eval-e eval-ec) (EMatch f2 form' eval'-e eval'-ec)
    with untyped-eval-unicity eval-e eval'-e
  ... | refl
    with ctxunicity form form'
  ... | refl
    rewrite Fuel-depletion-unicity f1 f2
    with untyped-eval-unicity eval-ec eval'-ec
  ... | refl = refl
  untyped-eval-unicity (EMatch x₃ x₄ eval eval₁) (EMatchUnfinished eval' nc)
    with untyped-eval-unicity eval eval'
  ... | refl = abort (nc refl)
  untyped-eval-unicity (EMatchUnfinished eval nc) (EMatch x₄ x₅ eval' eval'')
    with untyped-eval-unicity eval eval'
  ... | refl = abort (nc refl)
  untyped-eval-unicity (EMatchUnfinished eval x₃) (EMatchUnfinished eval' x₄)
    with untyped-eval-unicity eval eval'
  ... | refl = refl
  untyped-eval-unicity EHole EHole = refl
  untyped-eval-unicity (EAsrt eval1 eval2 xc) (EAsrt eval1' eval2' xc')
    with untyped-eval-unicity eval1 eval1' | untyped-eval-unicity eval2 eval2'
  ... | refl | refl = refl


{-# OPTIONS --safe #-}

module Issue2442-postulate where

postulate

  A : Set


-- Currently postulates are not allowed in mutual blocks.
-- This might change.
module PostulateInMutual where

mutual
  postulate A : Set
  postulate B : Set


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

open import Agda.Primitive
open import Prelude
import GSeTT.Syntax
import GSeTT.Rules
open import GSeTT.Typed-Syntax
import Globular-TT.Syntax

module Globular-TT.Rules {l} (index : Set l) (rule : index → GSeTT.Typed-Syntax.Ctx × (Globular-TT.Syntax.Pre-Ty index)) where
  open import Globular-TT.Syntax index

  {- Notational shortcuts : the context corresponding to an index -}
  Ci : index → Pre-Ctx
  Ci i = GPre-Ctx (fst (fst (rule i)))

  Ti : index → Pre-Ty
  Ti i = snd (rule i)

  data _⊢C : Pre-Ctx → Set (lsuc l)
  data _⊢T_ : Pre-Ctx → Pre-Ty → Set (lsuc l)
  data _⊢t_#_ : Pre-Ctx → Pre-Tm → Pre-Ty → Set (lsuc l)
  data _⊢S_>_ : Pre-Ctx → Pre-Sub → Pre-Ctx → Set (lsuc l)

  data _⊢C where
    ec : ⊘ ⊢C
    cc : ∀ {Γ A x} → Γ ⊢C → Γ ⊢T A → x == C-length Γ → (Γ ∙ x # A) ⊢C

  data _⊢T_ where
    ob : ∀ {Γ} → Γ ⊢C → Γ ⊢T ∗
    ar : ∀ {Γ A t u} → Γ ⊢T A → Γ ⊢t t # A → Γ ⊢t u # A → Γ ⊢T ⇒ A t u

  data _⊢t_#_ where
    var : ∀ {Γ x A} → Γ ⊢C → x # A ∈ Γ → Γ ⊢t (Var x) # A
    tm : ∀ {Δ γ A i} → Ci i ⊢T Ti i → Δ ⊢S γ > Ci i → (A == (Ti i [ γ ]Pre-Ty)) → Δ ⊢t Tm-constructor i γ # A

  data _⊢S_>_ where
    es : ∀ {Δ} → Δ ⊢C → Δ ⊢S <> > ⊘
    sc : ∀ {Δ Γ γ x y A t} → Δ ⊢S γ > Γ → (Γ ∙ x # A) ⊢C → (Δ ⊢t t # (A [ γ ]Pre-Ty)) → x == y → Δ ⊢S < γ , y ↦ t > > (Γ ∙ x # A)

  {- Derivability is preserved by the translation from GSeTT to our TT -}
  x∈GCtx : ∀ {x A Γ} → x GSeTT.Syntax.# A ∈ Γ → x # GPre-Ty A ∈ GPre-Ctx Γ
  x∈GCtx {Γ = Γ :: a} (inl x∈Γ) = inl (x∈GCtx x∈Γ)
  x∈GCtx {Γ = Γ :: (x,A)} (inr (idp , idp)) = inr (idp , idp)

  G-length : ∀ Γ → length Γ == C-length (GPre-Ctx Γ)
  G-length nil = idp
  G-length (Γ :: _) = S= (G-length Γ)

  GCtx : ∀ (Γ : GSeTT.Syntax.Pre-Ctx) → Γ GSeTT.Rules.⊢C → (GPre-Ctx Γ) ⊢C
  GTy : ∀ (Γ : GSeTT.Syntax.Pre-Ctx) (A : GSeTT.Syntax.Pre-Ty) → Γ GSeTT.Rules.⊢T A → (GPre-Ctx Γ) ⊢T (GPre-Ty A)
  GTm : ∀ (Γ : GSeTT.Syntax.Pre-Ctx) (A : GSeTT.Syntax.Pre-Ty) (t : GSeTT.Syntax.Pre-Tm) → Γ GSeTT.Rules.⊢t t # A  → (GPre-Ctx Γ) ⊢t (GPre-Tm t) # (GPre-Ty A)

  GCtx .nil GSeTT.Rules.ec = ec
  GCtx (Γ :: (.(length Γ) , A)) (GSeTT.Rules.cc Γ⊢ Γ⊢A idp) = coe (ap (λ n → (GPre-Ctx (Γ :: (n , A)) ⊢C)) (G-length Γ) ^) (cc (GCtx Γ Γ⊢) (GTy Γ A Γ⊢A) idp)
  GTy Γ .GSeTT.Syntax.∗ (GSeTT.Rules.ob Γ⊢) = ob (GCtx Γ Γ⊢)
  GTy Γ (GSeTT.Syntax.⇒ A t u) (GSeTT.Rules.ar Γ⊢t:A Γ⊢u:A) = ar (GTy Γ A (GSeTT.Rules.Γ⊢t:A→Γ⊢A Γ⊢t:A)) (GTm Γ A t Γ⊢t:A) (GTm Γ A u Γ⊢u:A)
  GTm Γ A (GSeTT.Syntax.Var x) (GSeTT.Rules.var Γ⊢ x∈Γ) = var (GCtx Γ Γ⊢) (x∈GCtx x∈Γ)

  {- Properties of the type theory -}
  {- weakening admissibility -}
  wkT : ∀ {Γ A y B} → Γ ⊢T A → (Γ ∙ y # B) ⊢C → (Γ ∙ y # B) ⊢T A
  wkt : ∀ {Γ A t y B} → Γ ⊢t t # A → (Γ ∙ y # B) ⊢C → (Γ ∙ y # B) ⊢t t # A
  wkS : ∀ {Δ Γ γ y B} → Δ ⊢S γ > Γ → (Δ ∙ y # B) ⊢C → (Δ ∙ y # B) ⊢S γ > Γ

  wkT (ob _) Γ,y:B⊢ = ob Γ,y:B⊢
  wkT (ar Γ⊢A Γ⊢t:A Γ⊢u:A) Γ,y:B⊢ = ar (wkT Γ⊢A Γ,y:B⊢) (wkt Γ⊢t:A Γ,y:B⊢) (wkt Γ⊢u:A Γ,y:B⊢)
  wkt (var Γ⊢C x∈Γ) Γ,y:B⊢ = var Γ,y:B⊢ (inl x∈Γ)
  wkt (tm Ci⊢Ti Γ⊢γ:Δ idp) Γ,y:B⊢ = tm Ci⊢Ti (wkS Γ⊢γ:Δ Γ,y:B⊢) idp
  wkS (es _) Δ,y:B⊢ = es Δ,y:B⊢
  wkS (sc Δ⊢γ:Γ Γ,x:A⊢ Δ⊢t:A[γ] idp) Δ,y:B⊢ = sc (wkS Δ⊢γ:Γ Δ,y:B⊢) Γ,x:A⊢ (wkt Δ⊢t:A[γ] Δ,y:B⊢) idp

  {- Consistency : all objects appearing in derivable judgments are derivable -}
  Γ⊢A→Γ⊢ : ∀ {Γ A} → Γ ⊢T A → Γ ⊢C
  Γ⊢t:A→Γ⊢ : ∀ {Γ A t} → Γ ⊢t t # A → Γ ⊢C
  Δ⊢γ:Γ→Δ⊢ : ∀ {Δ Γ γ} → Δ ⊢S γ > Γ → Δ ⊢C

  Γ⊢A→Γ⊢ (ob Γ⊢) = Γ⊢
  Γ⊢A→Γ⊢ (ar Γ⊢A Γ⊢t:A Γ⊢u:A) = Γ⊢t:A→Γ⊢ Γ⊢t:A
  Γ⊢t:A→Γ⊢ (var Γ⊢ _) = Γ⊢
  Γ⊢t:A→Γ⊢ (tm _ Γ⊢γ:Δ idp) = Δ⊢γ:Γ→Δ⊢ Γ⊢γ:Δ
  Δ⊢γ:Γ→Δ⊢ (es Δ⊢) = Δ⊢
  Δ⊢γ:Γ→Δ⊢ (sc Δ⊢γ:Γ Γ,x:A⊢ Δ⊢t:A[γ] idp) = Δ⊢γ:Γ→Δ⊢ Δ⊢γ:Γ

  Δ⊢γ:Γ→Γ⊢ : ∀ {Δ Γ γ} → Δ ⊢S γ > Γ → Γ ⊢C
  Δ⊢γ:Γ→Γ⊢ (es Δ⊢) = ec
  Δ⊢γ:Γ→Γ⊢ (sc Δ⊢γ:Γ Γ,x:A⊢ Δ⊢t:A[γ] idp) = Γ,x:A⊢

  Γ,x:A⊢→Γ,x:A⊢A : ∀ {Γ x A} → (Γ ∙ x # A) ⊢C → (Γ ∙ x # A) ⊢T A
  Γ,x:A⊢→Γ,x:A⊢A Γ,x:A⊢@(cc Γ⊢ Γ⊢A idp) = wkT Γ⊢A Γ,x:A⊢

  Γ,x:A⊢→Γ,x:A⊢x:A : ∀ {Γ x A} → (Γ ∙ x # A) ⊢C → (Γ ∙ x # A) ⊢t (Var x) # A
  Γ,x:A⊢→Γ,x:A⊢x:A Γ,x:A⊢ = var Γ,x:A⊢ (inr (idp , idp))

  Γ⊢src : ∀ {Γ A t u} → Γ ⊢T ⇒ A t u → Γ ⊢t t # A
  Γ⊢src (ar Γ⊢ Γ⊢t Γ⊢u) = Γ⊢t

  Γ⊢tgt : ∀ {Γ A t u} → Γ ⊢T ⇒ A t u → Γ ⊢t u # A
  Γ⊢tgt (ar Γ⊢ Γ⊢t Γ⊢u) = Γ⊢u

  -- The proposition Γ⊢t:A→Γ⊢A is slightly harder and is moved in CwF-Struture since it depends on lemmas there

  -- Type epressing that the rules are well-founded (useful to show that judgments are decidable)
  well-founded : Set (lsuc l)
  well-founded = ∀ (i : index) → Ci i ⊢T Ti i → dimC (Ci i) ≤ dim (Ti i)

  -- Derivation of a term constructed by a term constructor
  Γ⊢tm→Ci⊢Ti : ∀ {i Γ γ A} → Γ ⊢t (Tm-constructor i γ) # A → Ci i ⊢T Ti i
  Γ⊢tm→Ci⊢Ti (tm Ci⊢Ti _ idp) = Ci⊢Ti

  Γ⊢tm→Γ⊢γ : ∀ {i Γ γ A} → Γ ⊢t (Tm-constructor i γ) # A → Γ ⊢S γ > Ci i
  Γ⊢tm→Γ⊢γ (tm _ Γ⊢γ idp) = Γ⊢γ


open import Agda.Primitive.Cubical

test : (J : IUniv) → J → J
test J j = primHComp {φ = i0} (λ k → λ ()) j


------------------------------------------------------------------------
-- Inversion of (sub)typing in Fω with interval kinds
------------------------------------------------------------------------

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

module FOmegaInt.Typing.Inversion where

open import Data.Product using (_,_; proj₁; proj₂; _×_; map)
open import Relation.Binary.PropositionalEquality using (_≡_; refl)
open import Relation.Nullary using (¬_)

open import FOmegaInt.Syntax
open import FOmegaInt.Typing
open import FOmegaInt.Typing.Validity
open import FOmegaInt.Kinding.Declarative.Normalization
open import FOmegaInt.Kinding.Canonical.Equivalence
  using (sound-<:; sound-<∷; complete-<∷; complete-<:-⋯)
import FOmegaInt.Kinding.Canonical.Inversion as CanInv

open Syntax
open TermCtx hiding (map)
open Typing
open Substitution using (_[_]; weaken)
open WfCtxOps using (lookup-tp)
open TypedSubstitution
open TypedNarrowing

------------------------------------------------------------------------
-- Generation/inversion of typing.

infix 4 _⊢Tm-gen_∈_

-- The possible types of a term (i.e. the possible results of
-- generating/inverting _⊢Tp_∈_).
data _⊢Tm-gen_∈_ {n} (Γ : Ctx n) : Term n → Term n → Set where
  ∈-var : ∀ {a b} x → Γ ctx → lookup Γ x ≡ tp a → Γ ⊢ a <: b ∈ * →
          Γ ⊢Tm-gen var x ∈ b
  ∈-∀-i : ∀ {k a b c} → Γ ⊢ k kd → kd k ∷ Γ ⊢Tm a ∈ b → Γ ⊢ Π k b <: c ∈ * →
          Γ ⊢Tm-gen Λ k a ∈ c
  ∈-→-i : ∀ {a b c d} → Γ ⊢Tp a ∈ * → tp a ∷ Γ ⊢Tm b ∈ weaken c →
          Γ ⊢ a ⇒ c <: d ∈ * → Γ ⊢Tm-gen ƛ a b ∈ d
  ∈-∀-e : ∀ {a b k c d} → Γ ⊢Tm a ∈ Π k c → Γ ⊢Tp b ∈ k → Γ ⊢ c [ b ] <: d ∈ * →
          Γ ⊢Tm-gen a ⊡ b ∈ d
  ∈-→-e : ∀ {a b c d e} → Γ ⊢Tm a ∈ c ⇒ d → Γ ⊢Tm b ∈ c → Γ ⊢ d <: e ∈ * →
          Γ ⊢Tm-gen a · b ∈ e

-- Generation/inversion of typing.
Tm∈-gen : ∀ {n} {Γ : Ctx n} {a b} → Γ ⊢Tm a ∈ b → Γ ⊢Tm-gen a ∈ b
Tm∈-gen (∈-var x Γ-ctx Γ[x]≡kd-a) =
  ∈-var x Γ-ctx Γ[x]≡kd-a (<:-refl (Tm∈-valid (∈-var x Γ-ctx Γ[x]≡kd-a)))
Tm∈-gen (∈-∀-i k-kd a∈b) =
  ∈-∀-i k-kd a∈b (<:-refl (Tm∈-valid (∈-∀-i k-kd a∈b)))
Tm∈-gen (∈-→-i a∈* b∈c c∈*) =
  ∈-→-i a∈* b∈c (<:-refl (Tm∈-valid (∈-→-i a∈* b∈c c∈*)))
Tm∈-gen (∈-∀-e a∈∀kc b∈k) =
  ∈-∀-e a∈∀kc b∈k (<:-refl (Tm∈-valid (∈-∀-e a∈∀kc b∈k)))
Tm∈-gen (∈-→-e a∈c⇒d b∈c) =
  ∈-→-e a∈c⇒d b∈c (<:-refl (Tm∈-valid (∈-→-e a∈c⇒d b∈c)))
Tm∈-gen (∈-⇑ a∈b   b<:c) with Tm∈-gen a∈b
Tm∈-gen (∈-⇑ x∈b   c<:d) | ∈-var x Γ-ctx Γ[x]≡kd-a a<:b =
  ∈-var x Γ-ctx Γ[x]≡kd-a (<:-trans a<:b c<:d)
Tm∈-gen (∈-⇑ Λka∈b b<:c) | ∈-∀-i k-kd a∈d ∀kd<:b   =
  ∈-∀-i k-kd a∈d (<:-trans ∀kd<:b b<:c)
Tm∈-gen (∈-⇑ ƛab∈c c<:d) | ∈-→-i a∈* b∈c a⇒c<:d    =
  ∈-→-i a∈* b∈c (<:-trans a⇒c<:d c<:d)
Tm∈-gen (∈-⇑ a·b∈e e<:f) | ∈-∀-e a∈Πcd b∈c d[b]<:e =
  ∈-∀-e a∈Πcd b∈c (<:-trans d[b]<:e e<:f)
Tm∈-gen (∈-⇑ a·b∈e e<:f) | ∈-→-e a∈c⇒d b∈c d<:e    =
  ∈-→-e a∈c⇒d b∈c (<:-trans d<:e e<:f)

------------------------------------------------------------------------
-- Inversion of subtyping (in the empty context).

-- NOTE.  The following two lemmas only hold in the empty context
-- because we can not invert instances of the interval projection
-- rules (<:-⟨| and (<:-|⟩) in arbitrary contexts.  This is because
-- instances of these rules can reflect arbitrary subtyping
-- assumptions into the subtyping relation.  Consider, e.g.
--
--     Γ, X :: ⊤..⊥ ctx    Γ(X) = ⊥..⊤
--     ------------------------------- (∈-var)
--     Γ, X :: ⊤..⊥ ⊢ X :: ⊤..⊥
--     -------------------------- (<:-⟨|, <:-|⟩)
--     Γ, X :: ⊤..⊥ ⊢ ⊤ <: X <: ⊥
--
-- Which allows us to prove that ⊤ <: ⊥ using (<:-trans) under the
-- assumption (X : ⊤..⊥).  On the other hand, it is impossible to give
-- a transitivity-free proof of ⊤ <: ⊥.  In general, it is therefore
-- impossible to invert subtyping statements in non-empty contexts,
-- i.e. one cannot prove lemmas like (<:-→-inv) or (<:-∀-inv) below
-- for arbitrary contexts.

<:-∀-inv : ∀ {k₁ k₂ : Kind Term 0} {a₁ a₂} → [] ⊢ Π k₁ a₁ <: Π k₂ a₂ ∈ * →
           [] ⊢ k₂ <∷ k₁ × kd k₂ ∷ [] ⊢ a₁ <: a₂ ∈ *
<:-∀-inv ∀k₁a₁<:∀k₂a₂∈* =
  let nf-∀k₁a₁<:nf-∀k₂a₂          = complete-<:-⋯ ∀k₁a₁<:∀k₂a₂∈*
      nf-k₂<∷nf-k₁ , nf-a₁<:nf-a₂ = CanInv.<:-∀-inv nf-∀k₁a₁<:nf-∀k₂a₂
      ∀k₁a₁∈* , ∀k₂a₂∈*           = <:-valid ∀k₁a₁<:∀k₂a₂∈*
      k₁≅nf-k₁∈* , a₁≃nf-a₁∈*     = Tp∈-∀-≃-⌞⌟-nf ∀k₁a₁∈*
      k₂≅nf-k₂∈* , a₂≃nf-a₂∈*     = Tp∈-∀-≃-⌞⌟-nf ∀k₂a₂∈*
      k₂<∷nf-k₂∈*                 = ≅⇒<∷ k₂≅nf-k₂∈*
      k₂<∷k₁ = <∷-trans (<∷-trans k₂<∷nf-k₂∈* (sound-<∷ nf-k₂<∷nf-k₁))
                        (≅⇒<∷ (≅-sym k₁≅nf-k₁∈*))
  in k₂<∷k₁ ,
     <:-trans (<:-trans (⇓-<: k₂<∷k₁ (≃⇒<: a₁≃nf-a₁∈*))
                        (⇓-<: k₂<∷nf-k₂∈* (sound-<: nf-a₁<:nf-a₂)))
              (≃⇒<: (≃-sym a₂≃nf-a₂∈*))

<:-→-inv : ∀ {a₁ a₂ b₁ b₂ : Term 0} → [] ⊢ a₁ ⇒ b₁ <: a₂ ⇒ b₂ ∈ * →
           [] ⊢ a₂ <: a₁ ∈ * × [] ⊢ b₁ <: b₂ ∈ *
<:-→-inv a₁⇒b₁<:a₂⇒b₂∈* =
  let nf-a₁⇒b₁<:nf-a₂⇒b₂          = complete-<:-⋯ a₁⇒b₁<:a₂⇒b₂∈*
      nf-a₂<:nf-a₁ , nf-b₁<:nf-b₂ = CanInv.<:-→-inv nf-a₁⇒b₁<:nf-a₂⇒b₂
      a₁⇒b₁∈* , a₂⇒b₂∈*           = <:-valid a₁⇒b₁<:a₂⇒b₂∈*
      a₁≃nf-a₁∈* , b₁≃nf-b₁∈*     = Tp∈-→-≃-⌞⌟-nf a₁⇒b₁∈*
      a₂≃nf-a₂∈* , b₂≃nf-b₂∈*     = Tp∈-→-≃-⌞⌟-nf a₂⇒b₂∈*
  in <:-trans (<:-trans (≃⇒<: a₂≃nf-a₂∈*) (sound-<: nf-a₂<:nf-a₁))
              (≃⇒<: (≃-sym a₁≃nf-a₁∈*)) ,
     <:-trans (<:-trans (≃⇒<: b₁≃nf-b₁∈*) (sound-<: nf-b₁<:nf-b₂))
              (≃⇒<: (≃-sym b₂≃nf-b₂∈*))

-- ⊤ is not a subtype of ⊥.

⊤-≮:-⊥ : ∀ {a : Term 0} → ¬ [] ⊢ ⊤ <: ⊥ ∈ *
⊤-≮:-⊥ ⊤<:⊥ with CanInv.⊤-<:-max (complete-<:-⋯ ⊤<:⊥)
⊤-≮:-⊥ ⊤<:⊥ | ()

-- Arrows are not canonical subtypes of universals and vice-versa.

⇒-≮:-Π : ∀ {a₁ b₁ : Term 0} {k₂ a₂} → ¬ [] ⊢ a₁ ⇒ b₁ <: Π k₂ a₂ ∈ *
⇒-≮:-Π a₁⇒b₁<:∀k₂a₂∈* = CanInv.⇒-≮:-Π (complete-<:-⋯ a₁⇒b₁<:∀k₂a₂∈*)

Π-≮:-⇒ : ∀ {k₁ a₁} {a₂ b₂ : Term 0} → ¬ [] ⊢ Π k₁ a₁ <: a₂ ⇒ b₂ ∈ *
Π-≮:-⇒ ∀k₁a₁<:a₂⇒b₂∈* = CanInv.Π-≮:-⇒ (complete-<:-⋯ ∀k₁a₁<:a₂⇒b₂∈*)


record R (A : Set) : Set where field giveA : A
open R ⦃ … ⦄

record WrapR (A : Set) : Set where field instance ⦃ wrappedR ⦄ : R A
open WrapR ⦃ … ⦄

postulate
  instance R-instance : ∀ {X} → WrapR X

data D : Set where

works : D
works = giveA ⦃ WrapR.wrappedR (R-instance {D}) ⦄

fails : D
fails = giveA ⦃ {!!} ⦄
-- No instance of type R D was found in scope.

-- open import Agda.Primitive

-- {-
-- record IsBottom₀ (⊥ : Set) : Set (lsuc lzero) where
--   field
--     ⊥₀-elim : ⊥ → {A : Set lzero} → A

-- open IsBottom₀ ⦃ … ⦄ public

-- record Bottom₀ : Set (lsuc lzero) where
--   field
--     ⊥₀ : Set
--     ⦃ isBottom ⦄ : IsBottom₀ ⊥₀

-- open Bottom₀ ⦃ … ⦄ public

-- test : ⦃ bottom : ∀ {l : Set} → Bottom₀ ⦄ {fake : ⊥₀ ⦃ bottom {Level} ⦄} {real : Set} → real
-- test ⦃ bottom ⦄ {fake} {real} = ⊥₀-elim {⊥₀ ⦃ bottom ⦄} ⦃ Bottom₀.isBottom (bottom {Level}) ⦄ fake
-- -}

-- record IsBottom₀ (⊥ : Set) a : Set (lsuc a) where
--   field
--     ⊥₀-elim : ⊥ → {A : Set a} → A

-- open IsBottom₀ ⦃ … ⦄ public

-- record Bottom₀ a : Set (lsuc a) where
--   field
--     ⊥₀ : Set
--     ⦃ isBottom ⦄ : IsBottom₀ ⊥₀ a

-- open Bottom₀ ⦃ … ⦄ public

-- postulate
--   instance Bi : ∀ {a} → Bottom₀ a

-- --test : ⦃ bottom : ∀ {a} → Bottom₀ a ⦄ {fake : ⊥₀ {lzero}} {real : Set} → real
-- --test ⦃ bottom ⦄ {fake} {real} = let instance b = Bottom₀.isBottom (bottom {lzero}) in ⊥₀-elim {⊥₀ {lzero} ⦃ bottom ⦄} {lzero} ⦃ {!Bottom₀.isBottom bottom!} ⦄ fake

-- test : {fake : ⊥₀ {lzero}} {real : Set} → real
-- test {fake} {real} = ⊥₀-elim {⊥₀ {lzero} ⦃ Bi ⦄} {lzero} ⦃ Bottom₀.isBottom Bi ⦄ fake

-- -- record Bottom₀ a : Set (lsuc a) where
-- --   field
-- --     ⊥₀ : Set
-- --     ⊥₀-elim : ⊥₀ → {A : Set a} → A

-- -- open Bottom₀ ⦃ … ⦄ public

-- -- test : ⦃ bottom : ∀ {a} → Bottom₀ a ⦄ {fake : ⊥₀ {lzero}} {real : Set} → real
-- -- test ⦃ bottom ⦄ {fake} {real} = ⊥₀-elim fake -- ⊥₀-elim {⊥₀ {lzero} ⦃ bottom ⦄} {lzero} ⦃ bottom ⦄ fake

-- -- postulate
-- --   B : Set

-- -- record IsB (r : Set) a : Set (lsuc a) where
-- --   field
-- --     gotB : B
-- --     xx : r

-- -- open IsB ⦃ … ⦄ public

-- -- record RB a : Set (lsuc a) where
-- --   field
-- --     r : Set
-- --     ⦃ isB ⦄ : IsB r a

-- -- open RB ⦃ … ⦄ public

-- -- testB : ⦃ bottom : ∀ {a} → RB a ⦄ → B
-- -- testB ⦃ bottom ⦄ = gotB ⦃ {!isB bottom {lzero}!} ⦄


module test where

open import cry.gfp
open import cry.ec

{-
-- open import IO.Primitive
-- open import Foreign.Haskell

open import Agda.Builtin.List using (List; []; _∷_)
open import Agda.Builtin.Char using (Char) renaming (primCharToNat to toNat)
open import Agda.Builtin.String using (String) renaming (primStringAppend to _++_; primStringToList to toList)
open import Agda.Builtin.Unit using (⊤)
-}

open import Data.Char using (Char; toNat)
open import Data.Nat as N using (ℕ; zero)
open import Data.Nat.Show using (show)
open import Data.List using (List; []; _∷_)
-- open import Data.Product using (_×_; _,_; proj₁)
open import Data.String using (String; _++_; toList)
open import Relation.Nullary using (yes; no)
open import IO using (IO; run; putStrLn)
open import Coinduction using (♯_)
open import Function using (_∘_; _$_)

-- open import Agda.Builtin.IO public using (IO)

_>>=_ : ∀ {a} {A B : Set a} → IO A → (A → IO B) → IO B
m >>= f = ♯ m IO.>>= λ a → ♯ f a

_>>_ : ∀ {a} {A B : Set a} → IO A → IO B → IO B
m >> n = ♯ m IO.>> ♯ n

open cry.ec using (module test-ec)
open test-ec

showElem : 𝔽 → String
showElem n = show n

read₁₀ : ℕ → List Char → ℕ × List Char
read₁₀ n [] = n , []
read₁₀ n (c ∷ cs) with toNat '0' N.≤? toNat c
... | no _ = n , cs
... | yes _ with toNat c N.≤? toNat '9'
... | no _ = n , cs
... | yes _ = read₁₀ (10 N.* n N.+ (toNat c N.∸ toNat '0')) cs

readsElem : List Char → 𝔽 × List Char
readsElem cs with read₁₀ 0 cs
... | n , cs′ = n , cs′ where

readElem : String → 𝔽
readElem = proj₁ ∘ readsElem ∘ toList

showPoint : Point → String
showPoint (x ∶ y ∶ z) = showElem x ++ ":" ++ showElem y ++ ":" ++ showElem z

readsPoint : List Char → Point × List Char
readsPoint s with readsElem s
... | x , s′ with readsElem s′
... | y , s″ with readsElem s″
... | z , s‴ = (x ∶ y ∶ z) , s‴ where

readPoint : String → Point
readPoint = proj₁ ∘ readsPoint ∘ toList

showPoint′ : Point → String
showPoint′ p = showPoint p ++ " = " ++ showPoint (aff p)

main′ : IO _
main′ = do
  let
    p = readPoint "4:2:1"
    2p = dbl p
    3p = add 2p p
    3p′ = add p 2p
    4p = dbl 2p
    4p′ = add p 3p
    4p″ = add p 3p′
    5p = add 4p p
    5p′ = add 2p 3p
    5p+0 = add 5p 𝕆
    6p = dbl 3p
    6p′ = add 5p p
    6p″ = add p 5p
  putStrLn ("p = " ++ showPoint′ p)
  putStrLn ("2p = " ++ showPoint′ 2p)
  putStrLn ("3p = " ++ showPoint′ 3p)
  putStrLn ("3p′ = " ++ showPoint′ 3p′)
  putStrLn ("4p = " ++ showPoint′ 4p)
  putStrLn ("4p′ = " ++ showPoint′ 4p′)
  putStrLn ("4p″ = " ++ showPoint′ 4p″)
  putStrLn ("5p = " ++ showPoint′ 5p)
  putStrLn ("5p′ = " ++ showPoint′ 5p′)
  putStrLn ("5p+0 = " ++ showPoint′ 5p+0)
  putStrLn ("6p = " ++ showPoint′ 6p)
  putStrLn ("6p′ = " ++ showPoint′ 6p′)
  putStrLn ("6p″ = " ++ showPoint′ 6p″)

main = run main′