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

--open import HoTT
open import homotopy.3x3.PushoutPushout
open import homotopy.3x3.Transpose
open import homotopy.3x3.Common

module homotopy.3x3.From {i} (d : Span^2 {i}) where

open Span^2 d
open M d hiding (Pushout^2)
open M (transpose d) using () renaming (A₀∙ to A∙₀; A₂∙ to A∙₂; A₄∙ to A∙₄;
                                        module F₁∙ to F∙₁; f₁∙ to f∙₁;
                                        module F₃∙ to F∙₃; f₃∙ to f∙₃;
                                        v-h-span to h-v-span)
open M using (Pushout^2)

module I∙₀ = PushoutRec {D = Pushout^2 d}
                        (left ∘ left) (right ∘ left) (glue ∘ left)

i∙₀ : A∙₀ → Pushout^2 d
i∙₀ = I∙₀.f

module I∙₄ = PushoutRec {D = Pushout^2 d}
                        (left ∘ right) (right ∘ right) (glue ∘ right)

i∙₄ : A∙₄ → Pushout^2 d
i∙₄ = I∙₄.f

module E∙₂Red (c : A₂₂) where

  lhs-o : _
  lhs-o =
      ap (i∙₄ ∘ f∙₃) (glue c)
         =⟨ ap-∘ i∙₄ f∙₃ (glue c) ⟩
      ap i∙₄ (ap f∙₃ (glue c))
           =⟨ F∙₃.glue-β c |in-ctx (ap i∙₄) ⟩
      ap i∙₄ (ap left (H₁₃ c) ∙ glue (f₂₃ c) ∙ ap right (! (H₃₃ c)))
           =⟨ ap-∙∙!`∘`∘ i∙₄ left right (H₁₃ c) (glue (f₂₃ c)) (H₃₃ c) ⟩
      ap (left ∘ right) (H₁₃ c) ∙ ap i∙₄ (glue (f₂₃ c)) ∙ ! (ap (right ∘ right) (H₃₃ c))
           =⟨ I∙₄.glue-β (f₂₃ c) |in-ctx (λ u → ap (left ∘ right) (H₁₃ c) ∙ u ∙ ! (ap (right ∘ right) (H₃₃ c))) ⟩
      ap (left ∘ right) (H₁₃ c) ∙ glue (right (f₂₃ c)) ∙ ! (ap (right ∘ right) (H₃₃ c)) ∎

  rhs-o : _
  rhs-o =
      ! (ap (left ∘ left) (H₁₁ c)) ∙ glue (left (f₂₁ c)) ∙ ap (right ∘ left) (H₃₁ c)
           =⟨ ! (I∙₀.glue-β (f₂₁ c)) |in-ctx (λ u → (! (ap (left ∘ left) (H₁₁ c)) ∙ u ∙ ap (right ∘ left) (H₃₁ c))) ⟩
      ! (ap (left ∘ left) (H₁₁ c)) ∙ ap i∙₀ (glue (f₂₁ c)) ∙ ap (right ∘ left) (H₃₁ c)
           =⟨ ! (ap-!∙∙`∘`∘ i∙₀ left right (H₁₁ c) (glue (f₂₁ c)) (H₃₁ c)) ⟩
      ap i∙₀ (ap left (! (H₁₁ c)) ∙ glue (f₂₁ c) ∙ ap right (H₃₁ c))
           =⟨ ! (F∙₁.glue-β c) |in-ctx (λ u → ap i∙₀ u) ⟩
      ap i∙₀ (ap f∙₁ (glue c))
           =⟨ ∘-ap i∙₀ f∙₁ (glue c) ⟩
      ap (i∙₀ ∘ f∙₁) (glue c) ∎

  T-lhs : Type _
  T-lhs = right (left (f₃₀ (f₂₁ c))) == right (right (f₃₄ (f₂₃ c))) :> Pushout^2 d

  lhs-i : _ == _ :> T-lhs
  lhs-i =
      ap (right ∘ left) (H₃₁ c) ∙ ap right (glue (f₃₂ c)) ∙ ap (right ∘ right) (H₃₃ c)
        =⟨ ! (ap-∙∙`∘`∘ right left right (H₃₁ c) (glue (f₃₂ c)) (H₃₃ c)) ⟩
      ap right (ap left (H₃₁ c) ∙ glue (f₃₂ c) ∙ ap right (H₃₃ c))
        =⟨ ! (ap (ap right) (F₃∙.glue-β c)) ⟩
      ap right (ap f₃∙ (glue c))
        =⟨ ∘-ap right f₃∙ (glue c) ⟩
      ap (right ∘ f₃∙) (glue c) ∎

  T-rhs : Type _
  T-rhs = left (left (f₁₀ (f₂₁ c))) == left (right (f₁₄ (f₂₃ c))) :> Pushout^2 d

  rhs-i : _ == _ :> T-rhs
  rhs-i =
      ap (left ∘ f₁∙) (glue c)
        =⟨ ap-∘ left f₁∙ (glue c) ⟩
      ap left (ap f₁∙ (glue c))
        =⟨ F₁∙.glue-β c |in-ctx (ap left) ⟩
      ap left (ap left (H₁₁ c) ∙ glue (f₁₂ c) ∙ ap right (H₁₃ c))
        =⟨ ap-∙∙`∘`∘ left left right (H₁₁ c) (glue (f₁₂ c)) (H₁₃ c) ⟩
      (ap (left ∘ left) (H₁₁ c) ∙ ap left (glue (f₁₂ c)) ∙ ap (left ∘ right) (H₁₃ c)) ∎

  coh! : (p : (_ , _ =□ _ , _)) → _
  coh! = pp-coh! {A = Pushout^2 d}
               {u = glue (left (f₂₁ c))}
               {ap (right ∘ left) (H₃₁ c)}
               {ap right (glue (f₃₂ c))}
               {ap (right ∘ right) (H₃₃ c)}
               {ap (left ∘ left) (H₁₁ c)}
               {ap left (glue (f₁₂ c))}
               {ap (left ∘ right) (H₁₃ c)}
               {glue (right (f₂₃ c))}

  coh : (p : (_ , _ =□ _ , _)) → _
  coh = pp-coh {A = Pushout^2 d}
               {p = ap left (glue (f₁₂ c))}
               {ap (left ∘ right) (H₁₃ c)}
               {glue (right (f₂₃ c))}
               {ap (right ∘ right) (H₃₃ c)}
               {ap (left ∘ left) (H₁₁ c)}
               {glue (left (f₂₁ c))}
               {ap (right ∘ left) (H₃₁ c)}
               {ap right (glue (f₃₂ c))}

  module _ (to : Pushout^2 d → Pushout^2 (transpose d)) where

    ap-ap-coh! : (p : _ , _ =□ _ , _) → _
    ap-ap-coh! = pp-coh!  {u = ap to (glue (left (f₂₁ c)))}
                          {ap (to ∘ right ∘ left) (H₃₁ c)}
                          {ap to (ap right (glue (f₃₂ c)))}
                          {ap (to ∘ right ∘ right) (H₃₃ c)}
                          {ap (to ∘ left ∘ left) (H₁₁ c)}
                          {ap to (ap left (glue (f₁₂ c)))}
                          {ap (to ∘ left ∘ right) (H₁₃ c)}
                          {ap to (glue (right (f₂₃ c)))}

    ap-ap-coh : (p : _ , _ =□ _ , _) → _
    ap-ap-coh = pp-coh {p = ap to (ap left (glue (f₁₂ c)))}
                       {ap (to ∘ left ∘ right) (H₁₃ c)}
                       {ap to (glue (right (f₂₃ c)))}
                       {ap (to ∘ right ∘ right) (H₃₃ c)}
                       {ap (to ∘ left ∘ left) (H₁₁ c)}
                       {ap to (glue (left (f₂₁ c)))}
                       {ap (to ∘ right ∘ left) (H₃₁ c)}
                       {ap to (ap right (glue (f₃₂ c)))}

    ap-ap-coh!-lhs-i : _
    ap-ap-coh!-lhs-i = ! (ap-∙∙`∘`∘ to (right ∘ left) (right ∘ right) (H₃₁ c) (ap right (glue (f₃₂ c))) (H₃₃ c))

    ap-ap-coh!-rhs-i : _
    ap-ap-coh!-rhs-i = ap-∙∙`∘`∘ to (left ∘ left) (left ∘ right) (H₁₁ c) (ap left (glue (f₁₂ c))) (H₁₃ c)

    ap-ap-coh!-lhs-o : _
    ap-ap-coh!-lhs-o = ap-∙∙!'`∘`∘ to (left ∘ right) (right ∘ right) (H₁₃ c) (glue (right (f₂₃ c))) (H₃₃ c)

    ap-ap-coh!-rhs-o : _
    ap-ap-coh!-rhs-o = ! (ap-!'∙∙`∘`∘ to (left ∘ left) (right ∘ left) (H₁₁ c) (glue (left (f₂₁ c))) (H₃₁ c))

    ap-ap-coh!-β : (α : _)
            → ap□ to (coh! α) == ap-ap-coh! (ap□ to α
                                             ∙□-i/ ap-ap-coh!-lhs-i
                                                 / ap-ap-coh!-rhs-i /)
                                 ∙□-i/ ap-ap-coh!-lhs-o
                                     / ap-ap-coh!-rhs-o /
    ap-ap-coh!-β α = ap□-coh! {g₁ = left ∘ right} {right ∘ right} {left ∘ left} {right ∘ left} to
                              {u = glue (left (f₂₁ c))} {H₃₁ c} {ap right (glue (f₃₂ c))} {H₃₃ c}
                              {H₁₁ c} {ap left (glue (f₁₂ c))} {H₁₃ c} {glue (right (f₂₃ c))}
                              α

open E∙₂Red

module E∙₂ = PushoutElim {d = span _ _ _ f₁₂ f₃₂} {P = λ c → i∙₀ (f∙₁ c) == i∙₄ (f∙₃ c)}
  (ap left ∘ glue) (ap right ∘ glue)
  (λ c → ↓-='-in (coh! c (↓-='-out (apd (glue {d = v-h-span}) (glue c))
                          ∙□-i/ lhs-i c / rhs-i c /)
                  ∙□-i/ lhs-o c / rhs-o c /))

e∙₂ : (c : A∙₂) → i∙₀ (f∙₁ c) == i∙₄ (f∙₃ c)
e∙₂ = E∙₂.f

module From = PushoutRec {d = h-v-span} {D = Pushout^2 d}
                       i∙₀ i∙₄ e∙₂

from : Pushout^2 (transpose d) → Pushout^2 d
from = From.f

from-glue-glue-β : (c : A₂₂) → ap↓ (ap from) (apd glue (glue c))
                          == (↓-='-in (coh! c (↓-='-out (apd (glue {d = v-h-span}) (glue c))
                                              ∙□-i/ lhs-i c / rhs-i c /)
                                       ∙□-i/ lhs-o c / rhs-o c /))
                              ◃/ From.glue-β (left (f₁₂ c)) / ! (From.glue-β (right (f₃₂ c))) /
from-glue-glue-β c = ∘'-apd (ap from) glue (glue c)
                   ∙ coh1 {p = apd (ap from ∘ glue) (glue c)} {From.glue-β (right (f₃₂ c))}
                          {From.glue-β (left (f₁₂ c))} {apd e∙₂ (glue c)}
                          (↓-=-out (apd From.glue-β (glue c)))
                   ∙ (E∙₂.glue-β c |in-ctx (λ u → u ◃/ From.glue-β (left (f₁₂ c)) / ! (From.glue-β (right (f₃₂ c)))/))


------------------------------------------------------------------------------
-- Testing nested axioms
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

{-

Processing this file should be generate a TPTP file with the following
axioms

fof(..., axiom, ( a = b )).
fof(..., axiom, ( b = c )).
fof(..., axiom, ( c = d )).
-}

module NestedAxioms.C where

open import NestedAxioms.A
open import NestedAxioms.B

------------------------------------------------------------------------------

postulate
  d : D
  c≡d : c ≡ d
{-# ATP axiom c≡d #-}

postulate foo : d ≡ a
{-# ATP prove foo #-}


primitive

ID : Set → Set
ID A = A


{-# OPTIONS --cubical --no-import-sorts --guardedness --safe #-}

module Cubical.Codata.M.AsLimit.Coalg where

open import Cubical.Codata.M.AsLimit.Coalg.Base public


module Issue279-4 where

module M (X : Set) where

  data R : Set where
    r : X → R

postulate
  P Q : Set

open M P using (r)

shouldn't-check : M.R Q → Q
shouldn't-check (r q) = q


module _ (C Dummy : Set) where

data Maybe : Set where
  nothing : Maybe

IfJust : Maybe → Set → Set
IfJust nothing P = P

postulate
  qCtx     : C
  inferRes : Maybe

                             -- v-- Implicit is important here
inferResBest : IfJust inferRes ({G : Maybe} → C)
inferResBest with inferRes
inferResBest | nothing = qCtx    -- Error: Dummy != C when checking qCtx : C

-- Test also with an existing implicit argument
inferResBest₁ : {A : Set} → IfJust inferRes ({G : Maybe} → C)
inferResBest₁ with inferRes
inferResBest₁ | nothing = qCtx    -- Error: Dummy != C when checking qCtx : C

-- Make sure it does break down on underapplied clauses
underapplied : Maybe → C
underapplied with inferRes
underapplied | nothing = λ _ → qCtx


{-# OPTIONS --guarded #-}
module _ where

primitive
  primLockUniv : _

postulate
  A B : primLockUniv
  c : A → B
  foo : (@tick x y : B) → Set

bar2 : (@tick x : A) → Set
bar2 x = foo (c x) (c x)


open import Agda.Primitive using (_⊔_ ; lsuc ; Level)

import Categories.Category as Category
import Categories.Category.Cartesian as Cartesian
open import Categories.Object.Terminal using (Terminal)
open import Categories.Object.Product using (Product)

open import MultiSorted.AlgebraicTheory
open import MultiSorted.Substitution
import MultiSorted.Product as Product
import MultiSorted.Interpretation as Interpretation
import MultiSorted.Model as Is-Model
import MultiSorted.InterpretationCategory as InterpretationCategory

module MultiSorted.ModelCategory
         {ℓt o ℓ e}
         {𝓈 ℴ}
         {Σ : Signature {𝓈} {ℴ}}
         (T : Theory ℓt Σ)
         {𝒞 : Category.Category o ℓ e}
         (cartesian-𝒞 : Cartesian.Cartesian 𝒞) where
  open Signature Σ
  open Theory T
  open Category.Category 𝒞
  open Interpretation Σ cartesian-𝒞
  open Is-Model {o = o} {ℓ = ℓ} {e = e} {Σ = Σ} T

  -- Useful shortcuts for levels
  ℓℴ : Level
  ℓℴ = lsuc (o ⊔ ℓ ⊔ e ⊔ 𝓈 ⊔ ℴ ⊔ ℓt)

  ℓ𝒽 : Level
  ℓ𝒽 = ℓ ⊔ o ⊔ e ⊔ 𝓈 ⊔ ℴ

  ℓ𝓇 : Level
  ℓ𝓇 = e ⊔ 𝓈

  -- New definition of models (as a set, not only a property of interpretations)
  record Model : Set ℓℴ where
    field
      interpretation : Interpretation
      is-model : Is-Model.Is-Model T interpretation

  open Model

  -- Homomorphisms of models
  _⇒M_ : ∀ (M N : Model) → Set ℓ𝒽
  _⇒M_ M N = (interpretation M) ⇒I (interpretation N)

  -- Equality of homomorphisms of models (the same as for the interpretations)
  _≈M_ : ∀ {M N : Model} → M ⇒M N → M ⇒M N → Set ℓ𝓇
  _≈M_ {M} {N} ϕ ψ =
                   let open _⇒I_ in
                   ∀ A → (hom-morphism ϕ {A}) ≈ (hom-morphism ψ)

  -- The identity morphism on models
  id-M : (M : Model) → M ⇒M M
  id-M = λ M → id-I {interpretation M}

  -- Composition of morphisms of Models
  _∘M_ : ∀ {M N O : Model} →  N ⇒M O → M ⇒M N → M ⇒M O
  _∘M_ ϕ ψ = ϕ ∘I ψ

  -- The category of Models of Σ in 𝒞
  ℳ : Category.Category ℓℴ ℓ𝒽 ℓ𝓇
  ℳ = record
          { Obj = Model
          ; _⇒_ = _⇒M_
          ; _≈_ = λ {M} {N} ϕ ψ → _≈M_ {M} {N} ϕ ψ
          ; id = λ {M} → id-M M
          ; _∘_ = λ {M} {N} {O} ϕ ψ → _∘M_ {M} {N} {O} ϕ ψ
          ; assoc = λ A → assoc -- λ A → assoc
          ; sym-assoc = λ A → sym-assoc
          ; identityˡ = λ A → identityˡ
          ; identityʳ = λ A → identityʳ
          ; identity² = λ A → identity²
          ; equiv = record { refl = λ A → Equiv.refl
                           ; sym = λ p A → Equiv.sym (p A)
                           ; trans = λ p₁ p₂ A → Equiv.trans (p₁ A) (p₂ A)
                           }
          ; ∘-resp-≈ = λ p₁ p₂ A → ∘-resp-≈ (p₁ A) (p₂ A)
          }

  -- The product of "Model proofs"

  module _ (M N : Model) where
    open Product.Producted
    open HomReasoning
    open InterpretationCategory
    open Cartesian.Cartesian cartesian-𝒞
    open Interpretation.Interpretation
    open import Categories.Object.Product.Morphisms {o} {ℓ} {e} 𝒞
    open Equation

    -- A proof that an axiom holds in a product interpretation amounts to a apir of proofs that the axiom holds in each model
    is-model-pairs : ∀ ε → (interp-term (interpretation M) (Equation.eq-lhs (ax-eq ε)) ⁂  interp-term (interpretation N) (Equation.eq-lhs (ax-eq ε)))
                               ≈ (interp-term (interpretation M) (Equation.eq-rhs (ax-eq ε)) ⁂  interp-term (interpretation N) (Equation.eq-rhs (ax-eq ε))) →
                               Interpretation.interp-term (A×B-ℐ𝓃𝓉 Σ cartesian-𝒞 (interpretation M) (interpretation N)) (Equation.eq-lhs (ax-eq ε))
                               ≈ Interpretation.interp-term (A×B-ℐ𝓃𝓉 Σ cartesian-𝒞 (interpretation M) (interpretation N)) (Equation.eq-rhs (ax-eq ε))
    is-model-pairs ε p =
                            begin
                              Interpretation.interp-term
                                (A×B-ℐ𝓃𝓉 Σ cartesian-𝒞 (interpretation M) (interpretation N))
                                (Equation.eq-lhs (ax-eq ε)) ≈⟨ ⟺
                                                                 (Cartesian.Cartesian.unique cartesian-𝒞
                                                                   (natural-π₁ Σ cartesian-𝒞 {I = interpretation M} {interpretation N} (ax-lhs ε))
                                                                   (natural-π₂ Σ cartesian-𝒞 {I = interpretation M} {interpretation N} (ax-lhs ε))) ⟩
                              product.⟨
                                Interpretation.interp-term (interpretation M) (eq-lhs (ax-eq ε)) ∘
                                π₁
                                ,
                                Interpretation.interp-term (interpretation N) (eq-lhs (ax-eq ε)) ∘
                                π₂
                                ⟩ ≈⟨ ⟨⟩-cong₂ (∘-resp-≈ˡ (Is-Model.model-eq (is-model M) ε)) (∘-resp-≈ˡ (Is-Model.model-eq (is-model N) ε)) ⟩
                              product.⟨
                                Interpretation.interp-term (interpretation M) (eq-rhs (ax-eq ε)) ∘
                                π₁
                                ,
                                Interpretation.interp-term (interpretation N) (eq-rhs (ax-eq ε)) ∘
                                π₂
                                ⟩ ≈⟨ Cartesian.Cartesian.unique cartesian-𝒞
                                     (natural-π₁ Σ cartesian-𝒞 {I = interpretation M} {interpretation N} (ax-rhs ε))
                                     (natural-π₂ Σ cartesian-𝒞 {I = interpretation M} {interpretation N} (ax-rhs ε)) ⟩
                              Interpretation.interp-term
                                (A×B-ℐ𝓃𝓉 Σ cartesian-𝒞 (interpretation M) (interpretation N))
                                (eq-rhs (ax-eq ε)) ∎

    -- The proof that the product interpetation of two models is a model
    is-model-product : Is-Model (A×B-ℐ𝓃𝓉 Σ cartesian-𝒞 (interpretation M) (interpretation N))
    Is-Model.model-eq is-model-product ε =
                                           begin
                                             Interpretation.interp-term
                                               (A×B-ℐ𝓃𝓉 Σ cartesian-𝒞 (interpretation M) (interpretation N))
                                               (Equation.eq-lhs (ax-eq ε)) ≈⟨ is-model-pairs ε (⁂-cong₂ (Is-Model.model-eq (is-model M) ε) (Is-Model.model-eq (is-model N) ε)) ⟩
                                             Interpretation.interp-term
                                               (A×B-ℐ𝓃𝓉 Σ cartesian-𝒞 (interpretation M) (interpretation N))
                                               (Equation.eq-rhs (ax-eq ε)) ∎

  -- The product of ℐ𝓃𝓉 carries over the models : the product of two models is a model
  module _ (M N : Model) where
    open Product.Producted
    open HomReasoning
    open InterpretationCategory
    A×B-ℳ : Model
    A×B-ℳ = record
              { interpretation = A×B-ℐ𝓃𝓉 Σ cartesian-𝒞 (interpretation M) (interpretation N)
              ; is-model = is-model-product M N
              }

  -- The cartesian structure of the category of models

  module _ {M N : Model} where
    import Categories.Object.Product.Core
    open Categories.Object.Product.Core.Product
    open InterpretationCategory Σ cartesian-𝒞
    private
      UM UN : Interpretation
      UM = interpretation M
      UN = interpretation N
      UM×UN : Product ℐ𝓃𝓉 UM UN
      UM×UN = product-ℐ𝓃𝓉
    product-ℳ : Product ℳ M N
    -- Structure
    A×B      product-ℳ = A×B-ℳ M N
    π₁       product-ℳ = π₁    UM×UN
    π₂       product-ℳ = π₂    UM×UN
    ⟨_,_⟩    product-ℳ = ⟨_,_⟩ UM×UN
    -- Properties
    project₁ product-ℳ {O} {h} {i}     = project₁ UM×UN {interpretation O} {h} {i}
    project₂ product-ℳ {O} {h} {i}     = project₂ UM×UN {interpretation O} {h} {i}
    unique   product-ℳ {O} {h} {i} {j} = unique   UM×UN {interpretation O} {h} {i} {j}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Some properties related to Data.Star
--
-- This module is DEPRECATED. Please use the
-- Relation.Binary.Construct.Closure.ReflexiveTransitive.Properties
-- module directly.
------------------------------------------------------------------------

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

module Data.Star.Properties where

open import Relation.Binary.Construct.Closure.ReflexiveTransitive.Properties
  public


------------------------------------------------------------------------------
-- FOTC looping (error) combinator
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module FOTC.Base.Loop where

open import FOTC.Base

------------------------------------------------------------------------------

postulate error : D

-- Conversion rule
--
-- The equation error-eq adds anything to the logic (because
-- reflexivity is already an axiom of equality), therefore we won't
-- add this equation as a first-order logic axiom.
--
-- postulate error-eq : error ≡ error


module Human.String where

open import Human.Bool
open import Human.List renaming ( length to llength )
open import Human.Char
open import Human.Nat

postulate String : Set
{-# BUILTIN STRING String #-}

primitive
  primStringToList   : String → List Char
  primStringFromList : List Char → String
  primStringAppend   : String → String → String
  primStringEquality : String → String → Bool
  primShowChar       : Char → String
  primShowString     : String → String

{-# COMPILE JS primStringToList = function(x) { return x.split(""); } #-}
{-# COMPILE JS primStringFromList = function(x) { return x.join(""); } #-}
{-# COMPILE JS primStringAppend = function(x) { return function(y) { return x+y; }; } #-}
{-# COMPILE JS primStringEquality = function(x) { return function(y) { return x===y; }; } #-}
{-# COMPILE JS primShowChar = function(x) { return JSON.stringify(x); } #-}
{-# COMPILE JS primShowString = function(x) { return JSON.stringify(x); } #-}

toList : String → List Char
toList = primStringToList

{-# COMPILE JS primStringToList = function(x) { return x.split(""); } #-}

slength : String → Nat
slength s = llength (toList s)

{-# COMPILE JS slength = function(s) { return s.length; } #-}


{-# OPTIONS --rewriting #-}

open import Agda.Builtin.Equality
open import Agda.Builtin.Equality.Rewrite
open import Agda.Builtin.Unit

postulate
  A : Set
  a : A
  f : {X : Set} → X → A
  g : {X : Set} → A → X
  rew-fg : {X : Set} (a : A) → f (g {X} a) ≡ a
{-# REWRITE rew-fg #-}

test : f tt ≡ a
test = refl


module Issue453 where

postulate
  A     : Set
  fails : {x : _} → A


------------------------------------------------------------------------
-- The reader monad transformer
------------------------------------------------------------------------

-- The interface is based on that used by the "mtl" package on
-- Hackage.

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

open import Equality

module Monad.Reader
  {reflexive} (eq : ∀ {a p} → Equality-with-J a p reflexive) where

open import Prelude

open Derived-definitions-and-properties eq
open import Monad eq

-- The reader monad transformer, defined using a wrapper type to make
-- instance resolution easier.

record ReaderT {s} (S : Type s)
               (M : Type s → Type s)
               (A : Type s) : Type s where
  constructor wrap
  field
    run : S → M A

open ReaderT public

instance

  -- ReaderT is a "raw monad" transformer.

  raw-monad-transformer :
    ∀ {s} {S : Type s} →
    Raw-monad-transformer (ReaderT S)
  run (Raw-monad.return (Raw-monad-transformer.transform
                           raw-monad-transformer) x) =
    λ _ → return x
  run (Raw-monad._>>=_ (Raw-monad-transformer.transform
                          raw-monad-transformer) x f) =
    λ s → run x s >>= λ x → run (f x) s

  run (Raw-monad-transformer.liftʳ raw-monad-transformer m) =
    λ _ → m

  transform : ∀ {s} {S : Type s} {M} ⦃ is-raw-monad : Raw-monad M ⦄ →
              Raw-monad (ReaderT S M)
  transform = Raw-monad-transformer.transform raw-monad-transformer

-- ReaderT is a monad transformer (assuming extensionality).

monad-transformer :
  ∀ {s} {S : Type s} →
  Extensionality s s →
  Monad-transformer (ReaderT S)
Monad.raw-monad (Monad-transformer.transform (monad-transformer _)) =
  Raw-monad-transformer.transform raw-monad-transformer

Monad.left-identity (Monad-transformer.transform
                       (monad-transformer ext)) x f =
  cong wrap (apply-ext ext λ s →
    (return x >>= λ x → run (f x) s)  ≡⟨ left-identity _ _ ⟩∎
    run (f x) s                       ∎)

Monad.right-identity (Monad-transformer.transform
                        (monad-transformer ext)) x =
  cong wrap (apply-ext ext λ s →
    run x s >>= return  ≡⟨ right-identity _ ⟩∎
    run x s             ∎)

Monad.associativity (Monad-transformer.transform
                       (monad-transformer ext)) x f g =
  cong wrap (apply-ext ext λ s →
    (run x s >>= λ x → run (f x) s >>= λ x → run (g x) s)    ≡⟨ associativity _ _ _ ⟩∎
    ((run x s >>= λ x → run (f x) s) >>= λ x → run (g x) s)  ∎)

Monad-transformer.liftᵐ (monad-transformer _) = liftʳ

Monad-transformer.lift-return (monad-transformer ext) x =
  cong wrap (apply-ext ext λ _ →
    return x  ∎)

Monad-transformer.lift->>= (monad-transformer ext) x f =
  cong wrap (apply-ext ext λ _ →
    x >>= f  ∎)

-- Returns the "state".

ask : ∀ {s} {S : Type s} {M} ⦃ is-monad : Raw-monad M ⦄ →
      ReaderT S M S
run ask = return

-- Modifies the "state" in a given computation.

local : ∀ {s} {S : Type s} {M A} ⦃ is-monad : Raw-monad M ⦄ →
        (S → S) → ReaderT S M A → ReaderT S M A
run (local f m) = run m ∘ f


{-# OPTIONS  --safe #-}

module Definition.Typed.Properties where

open import Definition.Untyped
open import Definition.Untyped.Properties
open import Definition.Typed
open import Definition.Typed.RedSteps
import Definition.Typed.Weakening as Twk

open import Tools.Empty using (⊥; ⊥-elim)
open import Tools.Product
open import Tools.Sum hiding (id ; sym)
import Tools.PropositionalEquality as PE

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

-- Escape context extraction

wfTerm : ∀ {Γ A t r} → Γ ⊢ t ∷ A ^ r → ⊢ Γ
wfTerm (univ <l ⊢Γ) = ⊢Γ
wfTerm (ℕⱼ ⊢Γ) = ⊢Γ
wfTerm (Emptyⱼ ⊢Γ) = ⊢Γ
wfTerm (Πⱼ <l ▹ <l' ▹ F ▹ G) = wfTerm F
wfTerm (∃ⱼ F ▹ G) = wfTerm F
wfTerm (var ⊢Γ x₁) = ⊢Γ
wfTerm (lamⱼ _ _ F t) with wfTerm t
wfTerm (lamⱼ _ _ F t) | ⊢Γ ∙ F′ = ⊢Γ
wfTerm (g ∘ⱼ a) = wfTerm a
wfTerm (⦅ F , G , t , u ⦆ⱼ) = wfTerm t
wfTerm (fstⱼ A B t) = wfTerm t
wfTerm (sndⱼ A B t) = wfTerm t
wfTerm (zeroⱼ ⊢Γ) = ⊢Γ
wfTerm (sucⱼ n) = wfTerm n
wfTerm (natrecⱼ F z s n) = wfTerm z
wfTerm (Emptyrecⱼ A e) = wfTerm e
wfTerm (Idⱼ A t u) = wfTerm t
wfTerm (Idreflⱼ t) = wfTerm t
wfTerm (transpⱼ A P t s u e) = wfTerm t
wfTerm (castⱼ A B e t) = wfTerm t
wfTerm (castreflⱼ A t) = wfTerm t
wfTerm (conv t A≡B) = wfTerm t

wf : ∀ {Γ A r} → Γ ⊢ A ^ r → ⊢ Γ
wf (Uⱼ ⊢Γ) = ⊢Γ
wf (univ A) = wfTerm A

mutual
  wfEqTerm : ∀ {Γ A t u r} → Γ ⊢ t ≡ u ∷ A ^ r → ⊢ Γ
  wfEqTerm (refl t) = wfTerm t
  wfEqTerm (sym t≡u) = wfEqTerm t≡u
  wfEqTerm (trans t≡u u≡r) = wfEqTerm t≡u
  wfEqTerm (conv t≡u A≡B) = wfEqTerm t≡u
  wfEqTerm (Π-cong _ _ F F≡H G≡E) = wfEqTerm F≡H
  wfEqTerm (∃-cong F F≡H G≡E) = wfEqTerm F≡H
  wfEqTerm (app-cong f≡g a≡b) = wfEqTerm f≡g
  wfEqTerm (β-red _ _ F t a) = wfTerm a
  wfEqTerm (η-eq _ _ F f g f0≡g0) = wfTerm f
  wfEqTerm (suc-cong n) = wfEqTerm n
  wfEqTerm (natrec-cong F≡F′ z≡z′ s≡s′ n≡n′) = wfEqTerm z≡z′
  wfEqTerm (natrec-zero F z s) = wfTerm z
  wfEqTerm (natrec-suc n F z s) = wfTerm n
  wfEqTerm (Emptyrec-cong A≡A' _ _) = wfEq A≡A'
  wfEqTerm (proof-irrelevance t u) = wfTerm t
  wfEqTerm (Id-cong A t u) = wfEqTerm u
  wfEqTerm (Id-Π _ _ A B t u) = wfTerm t
  wfEqTerm (Id-ℕ-00 ⊢Γ) = ⊢Γ
  wfEqTerm (Id-ℕ-SS m n) = wfTerm n
  wfEqTerm (Id-U-ΠΠ A B A' B') = wfTerm A
  wfEqTerm (Id-U-ℕℕ ⊢Γ) = ⊢Γ
  wfEqTerm (Id-SProp A B) = wfTerm A
  wfEqTerm (Id-ℕ-0S n) = wfTerm n
  wfEqTerm (Id-ℕ-S0 n) = wfTerm n
  wfEqTerm (Id-U-ℕΠ A B) = wfTerm A
  wfEqTerm (Id-U-Πℕ A B) = wfTerm A
  wfEqTerm (Id-U-ΠΠ!% eq A B A' B') = wfTerm A
  wfEqTerm (cast-cong A B t _ _) = wfEqTerm t
  wfEqTerm (cast-Π A B A' B' e f) = wfTerm f
  wfEqTerm (cast-ℕ-0 e) = wfTerm e
  wfEqTerm (cast-ℕ-S e n) = wfTerm n

  wfEq : ∀ {Γ A B r} → Γ ⊢ A ≡ B ^ r → ⊢ Γ
  wfEq (univ A≡B) = wfEqTerm A≡B
  wfEq (refl A) = wf A
  wfEq (sym A≡B) = wfEq A≡B
  wfEq (trans A≡B B≡C) = wfEq A≡B

-- Reduction is a subset of conversion

subsetTerm : ∀ {Γ A t u l} → Γ ⊢ t ⇒ u ∷ A ^ l → Γ ⊢ t ≡ u ∷ A ^ [ ! , l ]
subset : ∀ {Γ A B r} → Γ ⊢ A ⇒ B ^ r → Γ ⊢ A ≡ B ^ r

subsetTerm (natrec-subst F z s n⇒n′) =
  natrec-cong (refl F) (refl z) (refl s) (subsetTerm n⇒n′)
subsetTerm (natrec-zero F z s) = natrec-zero F z s
subsetTerm (natrec-suc n F z s) = natrec-suc n F z s
subsetTerm (app-subst {rA = !} t⇒u a) = app-cong (subsetTerm t⇒u) (refl a)
subsetTerm (app-subst {rA = %} t⇒u a) = app-cong (subsetTerm t⇒u) (proof-irrelevance a a)
subsetTerm (β-red l< l<' A t a) = β-red l< l<' A t a
subsetTerm (conv t⇒u A≡B) = conv (subsetTerm t⇒u) A≡B
subsetTerm (Id-subst A t u) = Id-cong (subsetTerm A) (refl t) (refl u)
subsetTerm (Id-ℕ-subst m n) = Id-cong (refl (ℕⱼ (wfTerm n))) (subsetTerm m) (refl n)
subsetTerm (Id-ℕ-0-subst n) = let ⊢Γ = wfEqTerm (subsetTerm n) in Id-cong (refl (ℕⱼ ⊢Γ)) (refl (zeroⱼ ⊢Γ)) (subsetTerm n)
subsetTerm (Id-ℕ-S-subst m n) = Id-cong (refl (ℕⱼ (wfTerm m))) (refl (sucⱼ m)) (subsetTerm n)
subsetTerm (Id-U-subst A B) = Id-cong (refl (univ 0<1 (wfTerm B))) (subsetTerm A) (refl B)
subsetTerm (Id-U-ℕ-subst B) = let ⊢Γ = wfEqTerm (subsetTerm B) in Id-cong (refl (univ 0<1 ⊢Γ)) (refl (ℕⱼ ⊢Γ)) (subsetTerm B)
subsetTerm (Id-U-Π-subst A P B) = Id-cong (refl (univ 0<1 (wfTerm A))) (refl (Πⱼ (≡is≤ PE.refl) ▹ (≡is≤ PE.refl) ▹ A ▹ P)) (subsetTerm B)
subsetTerm (Id-Π <l <l' A B t u) = Id-Π <l <l' A B t u
subsetTerm (Id-ℕ-00 ⊢Γ) = Id-ℕ-00 ⊢Γ
subsetTerm (Id-ℕ-SS m n) = Id-ℕ-SS m n
subsetTerm (Id-U-ΠΠ A B A' B') = Id-U-ΠΠ A B A' B'
subsetTerm (Id-U-ℕℕ ⊢Γ) = Id-U-ℕℕ ⊢Γ
subsetTerm (Id-SProp A B) = Id-SProp A B
subsetTerm (Id-ℕ-0S n) = Id-ℕ-0S n
subsetTerm (Id-ℕ-S0 n) = Id-ℕ-S0 n
subsetTerm (Id-U-ℕΠ A B) = Id-U-ℕΠ A B
subsetTerm (Id-U-Πℕ A B) = Id-U-Πℕ A B
subsetTerm (Id-U-ΠΠ!% eq A B A' B') = Id-U-ΠΠ!% eq A B A' B'
subsetTerm (cast-subst A B e t) = let ⊢Γ = wfEqTerm (subsetTerm A)
                                  in cast-cong (subsetTerm A) (refl B) (refl t) e (conv e (univ (Id-cong (refl (univ 0<1 ⊢Γ)) (subsetTerm A) (refl B))))
subsetTerm (cast-ℕ-subst B e t) = let ⊢Γ = wfEqTerm (subsetTerm B)
                                  in cast-cong (refl (ℕⱼ (wfTerm t))) (subsetTerm B) (refl t) e (conv e (univ (Id-cong (refl (univ 0<1 ⊢Γ)) (refl (ℕⱼ ⊢Γ)) (subsetTerm B))))
subsetTerm (cast-Π-subst A P B e t) = let ⊢Γ = wfTerm A
                                      in cast-cong (refl (Πⱼ (≡is≤ PE.refl) ▹ (≡is≤ PE.refl) ▹ A ▹ P)) (subsetTerm B) (refl t) e
                                                   (conv e (univ (Id-cong (refl (univ 0<1 ⊢Γ)) (refl (Πⱼ ≡is≤ PE.refl ▹ ≡is≤ PE.refl ▹ A ▹ P)) (subsetTerm B) )))
subsetTerm (cast-Π A B A' B' e f) = cast-Π A B A' B' e f
subsetTerm (cast-ℕ-0 e) = cast-ℕ-0 e
subsetTerm (cast-ℕ-S e n) = cast-ℕ-S e n
subsetTerm (cast-ℕ-cong e n) = let ⊢Γ = wfTerm e
                                   ⊢ℕ = ℕⱼ ⊢Γ
                               in cast-cong (refl ⊢ℕ) (refl ⊢ℕ) (subsetTerm n) e e

subset (univ A⇒B) = univ (subsetTerm A⇒B)

subset*Term : ∀ {Γ A t u l } → Γ ⊢ t ⇒* u ∷ A ^ l → Γ ⊢ t ≡ u ∷ A ^ [ ! , l ]
subset*Term (id t) = refl t
subset*Term (t⇒t′ ⇨ t⇒*u) = trans (subsetTerm t⇒t′) (subset*Term t⇒*u)

subset* : ∀ {Γ A B r} → Γ ⊢ A ⇒* B ^ r → Γ ⊢ A ≡ B ^ r
subset* (id A) = refl A
subset* (A⇒A′ ⇨ A′⇒*B) = trans (subset A⇒A′) (subset* A′⇒*B)

-- Transitivity of reduction

transTerm⇒* : ∀ {Γ A t u v l } → Γ ⊢ t ⇒* u ∷ A ^ l → Γ ⊢ u ⇒* v ∷ A ^ l → Γ ⊢ t ⇒* v ∷ A ^ l
transTerm⇒* (id x) y = y
transTerm⇒* (x ⇨ x₁) y = x ⇨ transTerm⇒* x₁ y

trans⇒* : ∀ {Γ A B C r} → Γ ⊢ A ⇒* B ^ r → Γ ⊢ B ⇒* C ^ r → Γ ⊢ A ⇒* C ^ r
trans⇒* (id x) y = y
trans⇒* (x ⇨ x₁) y = x ⇨ trans⇒* x₁ y

transTerm:⇒:* : ∀ {Γ A t u v l } → Γ ⊢ t :⇒*: u ∷ A ^ l → Γ ⊢ u :⇒*: v ∷ A ^ l → Γ ⊢ t :⇒*: v ∷ A ^ l
transTerm:⇒:* [[ ⊢t , ⊢u , d ]] [[ ⊢t₁ , ⊢u₁ , d₁ ]] = [[ ⊢t , ⊢u₁ , (transTerm⇒* d d₁) ]]

conv⇒* : ∀ {Γ A B l t u} → Γ ⊢ t ⇒* u ∷ A ^ l → Γ ⊢ A ≡ B ^ [ ! , l ] → Γ ⊢ t ⇒* u ∷ B ^ l
conv⇒* (id x) e = id (conv x e)
conv⇒* (x ⇨ D) e = conv x e ⇨ conv⇒* D e

conv:⇒*: : ∀ {Γ A B l t u} → Γ ⊢ t :⇒*: u ∷ A ^ l → Γ ⊢ A ≡ B ^ [ ! , l ] → Γ ⊢ t :⇒*: u ∷ B ^ l
conv:⇒*: [[ ⊢t , ⊢u , d ]] e = [[ (conv ⊢t e) , (conv ⊢u e) , (conv⇒* d e) ]]

-- Can extract left-part of a reduction

redFirstTerm : ∀ {Γ t u A l } → Γ ⊢ t ⇒ u ∷ A ^ l → Γ ⊢ t ∷ A ^ [ ! , l ]
redFirst : ∀ {Γ A B r} → Γ ⊢ A ⇒ B ^ r → Γ ⊢ A ^ r

redFirstTerm (conv t⇒u A≡B) = conv (redFirstTerm t⇒u) A≡B
redFirstTerm (app-subst t⇒u a) = (redFirstTerm t⇒u) ∘ⱼ a
redFirstTerm (β-red {lA = lA} {lB = lB} lA< lB< ⊢A ⊢t ⊢a) = (lamⱼ lA< lB< ⊢A ⊢t) ∘ⱼ ⊢a
redFirstTerm (natrec-subst F z s n⇒n′) = natrecⱼ F z s (redFirstTerm n⇒n′)
redFirstTerm (natrec-zero F z s) = natrecⱼ F z s (zeroⱼ (wfTerm z))
redFirstTerm (natrec-suc n F z s) = natrecⱼ F z s (sucⱼ n)
redFirstTerm (Id-subst A t u) = Idⱼ (redFirstTerm A) t u
redFirstTerm (Id-ℕ-subst m n) = Idⱼ (ℕⱼ (wfTerm n)) (redFirstTerm m) n
redFirstTerm (Id-ℕ-0-subst n) = Idⱼ (ℕⱼ (wfEqTerm (subsetTerm n))) (zeroⱼ (wfEqTerm (subsetTerm n))) (redFirstTerm n)
redFirstTerm (Id-ℕ-S-subst m n) = Idⱼ (ℕⱼ (wfTerm m)) (sucⱼ m) (redFirstTerm n)
redFirstTerm (Id-U-subst A B) = Idⱼ (univ 0<1 (wfTerm B)) (redFirstTerm A) B
redFirstTerm (Id-U-ℕ-subst B) = let ⊢Γ = (wfEqTerm (subsetTerm B)) in Idⱼ (univ 0<1 ⊢Γ) (ℕⱼ ⊢Γ) (redFirstTerm B)
redFirstTerm (Id-U-Π-subst A P B) = Idⱼ (univ 0<1 (wfTerm A)) (Πⱼ (≡is≤ PE.refl) ▹ (≡is≤ PE.refl) ▹ A ▹ P) (redFirstTerm B)
redFirstTerm (Id-Π {rA = rA} <l <l' A B t u) = Idⱼ (Πⱼ <l ▹ <l' ▹ A ▹ B) t u
redFirstTerm (Id-ℕ-00 ⊢Γ) = Idⱼ (ℕⱼ ⊢Γ) (zeroⱼ ⊢Γ) (zeroⱼ ⊢Γ)
redFirstTerm (Id-ℕ-SS m n) = Idⱼ (ℕⱼ (wfTerm m)) (sucⱼ m) (sucⱼ n)
redFirstTerm (Id-U-ΠΠ A B A' B') = Idⱼ (univ 0<1 (wfTerm A)) (Πⱼ (≡is≤ PE.refl) ▹ (≡is≤ PE.refl) ▹ A ▹ B) (Πⱼ (≡is≤ PE.refl) ▹ (≡is≤ PE.refl) ▹ A' ▹ B')
redFirstTerm (Id-U-ℕℕ ⊢Γ) = Idⱼ (univ 0<1 ⊢Γ) (ℕⱼ ⊢Γ) (ℕⱼ ⊢Γ)
redFirstTerm (Id-SProp A B) = Idⱼ (univ 0<1 (wfTerm A)) A B
redFirstTerm (Id-ℕ-0S n) = Idⱼ (ℕⱼ (wfTerm n)) (zeroⱼ (wfTerm n)) (sucⱼ n)
redFirstTerm (Id-ℕ-S0 n) = Idⱼ (ℕⱼ (wfTerm n)) (sucⱼ n) (zeroⱼ (wfTerm n))
redFirstTerm (Id-U-ℕΠ A B) = Idⱼ (univ 0<1 (wfTerm A)) (ℕⱼ (wfTerm A)) (Πⱼ (≡is≤ PE.refl) ▹ (≡is≤ PE.refl) ▹ A ▹ B)
redFirstTerm (Id-U-Πℕ A B) = Idⱼ (univ 0<1 (wfTerm A)) (Πⱼ (≡is≤ PE.refl) ▹ (≡is≤ PE.refl) ▹ A ▹ B) (ℕⱼ (wfTerm A))
redFirstTerm (Id-U-ΠΠ!% eq A B A' B') = Idⱼ (univ 0<1 (wfTerm A)) (Πⱼ (≡is≤ PE.refl) ▹ (≡is≤ PE.refl) ▹ A ▹ B) (Πⱼ (≡is≤ PE.refl) ▹ (≡is≤ PE.refl) ▹ A' ▹ B')
redFirstTerm (cast-subst A B e t) = castⱼ (redFirstTerm A) B e t
redFirstTerm (cast-ℕ-subst B e t) = castⱼ (ℕⱼ (wfTerm t)) (redFirstTerm B) e t
redFirstTerm (cast-Π-subst A P B e t) = castⱼ (Πⱼ (≡is≤ PE.refl) ▹ (≡is≤ PE.refl) ▹ A ▹ P) (redFirstTerm B) e t
redFirstTerm (cast-Π A B A' B' e f) = castⱼ (Πⱼ (≡is≤ PE.refl) ▹ (≡is≤ PE.refl) ▹ A ▹ B) (Πⱼ (≡is≤ PE.refl) ▹ (≡is≤ PE.refl) ▹ A' ▹ B') e f
redFirstTerm (cast-ℕ-0 e) = castⱼ (ℕⱼ (wfTerm e)) (ℕⱼ (wfTerm e)) e (zeroⱼ (wfTerm e))
redFirstTerm (cast-ℕ-S e n) = castⱼ (ℕⱼ (wfTerm e)) (ℕⱼ (wfTerm e)) e (sucⱼ n)
redFirstTerm (cast-ℕ-cong e n) = castⱼ (ℕⱼ (wfTerm e)) (ℕⱼ (wfTerm e)) e (redFirstTerm n)

redFirst (univ A⇒B) = univ (redFirstTerm A⇒B)

redFirst*Term : ∀ {Γ t u A l} → Γ ⊢ t ⇒* u ∷ A ^ l → Γ ⊢ t ∷ A ^ [ ! , l ]
redFirst*Term (id t) = t
redFirst*Term (t⇒t′ ⇨ t′⇒*u) = redFirstTerm t⇒t′

redFirst* : ∀ {Γ A B r} → Γ ⊢ A ⇒* B ^ r → Γ ⊢ A ^ r
redFirst* (id A) = A
redFirst* (A⇒A′ ⇨ A′⇒*B) = redFirst A⇒A′

-- Neutral types are always small

-- tyNe : ∀ {Γ t r} → Γ ⊢ t ^ r → Neutral t → Γ ⊢ t ∷ (Univ r) ^ !
-- tyNe (univ x) tn = x
-- tyNe (Idⱼ A x y) tn = Idⱼ A x y

-- Neutrals do not weak head reduce

neRedTerm : ∀ {Γ t u l A} (d : Γ ⊢ t ⇒ u ∷ A ^ l) (n : Neutral t) → ⊥
neRed : ∀ {Γ t u r} (d : Γ ⊢ t ⇒ u ^ r) (n : Neutral t) → ⊥
whnfRedTerm : ∀ {Γ t u A l} (d : Γ ⊢ t ⇒ u ∷ A ^ l) (w : Whnf t) → ⊥
whnfRed : ∀ {Γ A B r} (d : Γ ⊢ A ⇒ B ^ r) (w : Whnf A) → ⊥

neRedTerm (conv d x) n = neRedTerm d n
neRedTerm (app-subst d x) (∘ₙ n) = neRedTerm d n
neRedTerm (β-red _ _ x x₁ x₂) (∘ₙ ())
neRedTerm (natrec-zero x x₁ x₂) (natrecₙ ())
neRedTerm (natrec-suc x x₁ x₂ x₃) (natrecₙ ())
neRedTerm (natrec-subst x x₁ x₂ tr) (natrecₙ tn) = neRedTerm tr tn
neRedTerm (Id-subst tr x y) (Idₙ tn) = neRedTerm tr tn
neRedTerm (Id-ℕ-subst tr x) (Idℕₙ tn) = neRedTerm tr tn
neRedTerm (Id-ℕ-0-subst tr) (Idℕ0ₙ tn) = neRedTerm tr tn
neRedTerm (Id-ℕ-S-subst x tr) (IdℕSₙ tn) = neRedTerm tr tn
neRedTerm (Id-U-subst tr x) (IdUₙ tn) = neRedTerm tr tn
neRedTerm (Id-U-ℕ-subst tr) (IdUℕₙ tn) = neRedTerm tr tn
neRedTerm (Id-U-Π-subst A B tr) (IdUΠₙ tn) = neRedTerm tr tn
neRedTerm (Id-subst tr x y) (Idℕₙ tn) = whnfRedTerm tr ℕₙ
neRedTerm (Id-subst tr x y) (Idℕ0ₙ tn) = whnfRedTerm tr ℕₙ
neRedTerm (Id-subst tr x y) (IdℕSₙ tn) = whnfRedTerm tr ℕₙ
neRedTerm (Id-subst tr x y) (IdUₙ tn) = whnfRedTerm tr Uₙ
neRedTerm (Id-subst tr x y) (IdUℕₙ tn) = whnfRedTerm tr Uₙ
neRedTerm (Id-subst tr x y) (IdUΠₙ tn) = whnfRedTerm tr Uₙ
neRedTerm (Id-ℕ-subst tr x) (Idℕ0ₙ tn) = whnfRedTerm tr zeroₙ
neRedTerm (Id-ℕ-subst tr x) (IdℕSₙ tn) = whnfRedTerm tr sucₙ
neRedTerm (Id-U-subst tr x) (IdUℕₙ tn) = whnfRedTerm tr ℕₙ
neRedTerm (Id-U-subst tr x) (IdUΠₙ tn) = whnfRedTerm tr Πₙ
neRedTerm (Id-Π _ _ A B t u) (Idₙ ())
neRedTerm (Id-ℕ-00 tr) (Idₙ ())
neRedTerm (Id-ℕ-00 tr) (Idℕₙ ())
neRedTerm (Id-ℕ-00 tr) (Idℕ0ₙ ())
neRedTerm (Id-ℕ-SS x tr) (Idₙ ())
neRedTerm (Id-ℕ-SS x tr) (Idℕₙ ())
neRedTerm (Id-U-ΠΠ A B A' B') (Idₙ ())
neRedTerm (Id-U-ΠΠ A B A' B') (IdUₙ ())
neRedTerm (Id-U-ΠΠ A B A' B') (IdUΠₙ ())
neRedTerm (Id-U-ℕℕ x) (Idₙ ())
neRedTerm (Id-U-ℕℕ x) (IdUₙ ())
neRedTerm (Id-U-ℕℕ x) (IdUℕₙ ())
neRedTerm (Id-SProp A B) (Idₙ ())
neRedTerm (Id-ℕ-0S x) (Idₙ ())
neRedTerm (Id-ℕ-S0 x) (Idₙ ())
neRedTerm (Id-U-ℕΠ A B) (Idₙ ())
neRedTerm (Id-U-Πℕ A B) (Idₙ ())
neRedTerm (Id-U-ΠΠ!% eq A B A' B') (Idₙ ())
neRedTerm (cast-subst tr B e x) (castₙ tn) = neRedTerm tr tn
neRedTerm (cast-ℕ-subst tr e x) (castℕₙ tn) = neRedTerm tr tn
neRedTerm (cast-Π-subst A B tr e x) (castΠₙ tn) = neRedTerm tr tn
neRedTerm (cast-Π-subst A B tr e x) (castΠℕₙ) = whnfRedTerm tr ℕₙ
neRedTerm (cast-subst tr x x₁ x₂) (castℕₙ tn) = whnfRedTerm tr ℕₙ
neRedTerm (cast-subst tr x x₁ x₂) (castΠₙ tn) = whnfRedTerm tr Πₙ
neRedTerm (cast-subst tr x x₁ x₂) (castℕℕₙ tn) = whnfRedTerm tr ℕₙ
neRedTerm (cast-subst tr x x₁ x₂) (castℕΠₙ) = whnfRedTerm tr ℕₙ
neRedTerm (cast-subst tr x x₁ x₂) (castΠℕₙ) = whnfRedTerm tr Πₙ
neRedTerm (cast-ℕ-subst tr x x₁) (castℕℕₙ tn) = whnfRedTerm tr ℕₙ
neRedTerm (cast-ℕ-subst tr x x₁) (castℕΠₙ) = whnfRedTerm tr Πₙ
neRedTerm (cast-Π A B A' B' e f) (castₙ ())
neRedTerm (cast-Π A B A' B' e f) (castΠₙ ())
neRedTerm (cast-ℕ-0 x) (castₙ ())
neRedTerm (cast-ℕ-0 x) (castℕₙ ())
neRedTerm (cast-ℕ-0 x) (castℕℕₙ ())
neRedTerm (cast-ℕ-S x x₁) (castₙ ())
neRedTerm (cast-ℕ-S x x₁) (castℕₙ ())
neRedTerm (cast-ℕ-S x x₁) (castℕℕₙ ())
neRedTerm (cast-ℕ-cong x x₁) (castₙ ())
neRedTerm (cast-ℕ-cong x x₁) (castℕₙ ())
neRedTerm (cast-ℕ-cong x x₁) (castℕℕₙ t) = neRedTerm x₁ t
neRedTerm (cast-subst d x x₁ x₂) castΠΠ%!ₙ = whnfRedTerm d Πₙ
neRedTerm (cast-subst d x x₁ x₂) castΠΠ!%ₙ = whnfRedTerm d Πₙ
neRedTerm (cast-Π-subst x x₁ d x₂ x₃) castΠΠ%!ₙ = whnfRedTerm d Πₙ
neRedTerm (cast-Π-subst x x₁ d x₂ x₃) castΠΠ!%ₙ = whnfRedTerm d Πₙ

neRed (univ x) N = neRedTerm x N

whnfRedTerm (conv d x) w = whnfRedTerm d w
whnfRedTerm (app-subst d x) (ne (∘ₙ x₁)) = neRedTerm d x₁
whnfRedTerm (β-red _ _ x x₁ x₂) (ne (∘ₙ ()))
whnfRedTerm (natrec-subst x x₁ x₂ d) (ne (natrecₙ x₃)) = neRedTerm d x₃
whnfRedTerm (natrec-zero x x₁ x₂) (ne (natrecₙ ()))
whnfRedTerm (natrec-suc x x₁ x₂ x₃) (ne (natrecₙ ()))
whnfRedTerm (Id-subst d x x₁) (ne (Idₙ x₂)) = neRedTerm d x₂
whnfRedTerm (Id-subst d x x₁) (ne (Idℕₙ x₂)) = whnfRedTerm d ℕₙ
whnfRedTerm (Id-subst d x x₁) (ne (Idℕ0ₙ x₂)) = whnfRedTerm d ℕₙ
whnfRedTerm (Id-subst d x x₁) (ne (IdℕSₙ x₂)) = whnfRedTerm d ℕₙ
whnfRedTerm (Id-subst d x x₁) (ne (IdUₙ x₂)) = whnfRedTerm d Uₙ
whnfRedTerm (Id-subst d x x₁) (ne (IdUℕₙ x₂)) = whnfRedTerm d Uₙ
whnfRedTerm (Id-subst d x x₁) (ne (IdUΠₙ x₂)) = whnfRedTerm d Uₙ
whnfRedTerm (Id-ℕ-subst d x) (ne (Idℕₙ x₁)) = neRedTerm d x₁
whnfRedTerm (Id-ℕ-subst d x) (ne (Idℕ0ₙ x₁)) = whnfRedTerm d zeroₙ
whnfRedTerm (Id-ℕ-subst d x) (ne (IdℕSₙ x₁)) = whnfRedTerm d sucₙ
whnfRedTerm (Id-ℕ-0-subst d) (ne (Idℕ0ₙ x)) = neRedTerm d x
whnfRedTerm (Id-ℕ-S-subst x d) (ne (IdℕSₙ x₁)) = neRedTerm d x₁
whnfRedTerm (Id-U-subst d x) (ne (IdUₙ x₁)) = neRedTerm d x₁
whnfRedTerm (Id-U-subst d x) (ne (IdUℕₙ x₁)) = whnfRedTerm d ℕₙ
whnfRedTerm (Id-U-subst d x) (ne (IdUΠₙ x₁)) = whnfRedTerm d Πₙ
whnfRedTerm (Id-U-ℕ-subst d) (ne (IdUℕₙ x)) = neRedTerm d x
whnfRedTerm (Id-U-Π-subst x x₁ d) (ne (IdUΠₙ x₂)) = neRedTerm d x₂
whnfRedTerm (Id-Π _ _ x x₁ x₂ x₃) (ne (Idₙ ()))
whnfRedTerm (Id-ℕ-00 x) (ne (Idₙ ()))
whnfRedTerm (Id-ℕ-00 x) (ne (Idℕₙ ()))
whnfRedTerm (Id-ℕ-00 x) (ne (Idℕ0ₙ ()))
whnfRedTerm (Id-ℕ-SS x x₁) (ne (Idₙ ()))
whnfRedTerm (Id-ℕ-SS x x₁) (ne (Idℕₙ ()))
whnfRedTerm (Id-ℕ-SS x x₁) (ne (IdℕSₙ ()))
whnfRedTerm (Id-U-ΠΠ x x₁ x₂ x₃) (ne (Idₙ ()))
whnfRedTerm (Id-U-ΠΠ x x₁ x₂ x₃) (ne (IdUₙ ()))
whnfRedTerm (Id-U-ΠΠ x x₁ x₂ x₃) (ne (IdUΠₙ ()))
whnfRedTerm (Id-U-ℕℕ x) (ne (Idₙ ()))
whnfRedTerm (Id-U-ℕℕ x) (ne (IdUₙ ()))
whnfRedTerm (Id-U-ℕℕ x) (ne (IdUℕₙ ()))
whnfRedTerm (Id-SProp x x₁) (ne (Idₙ ()))
whnfRedTerm (Id-ℕ-0S x) (ne (Idₙ ()))
whnfRedTerm (Id-ℕ-S0 x) (ne (Idₙ ()))
whnfRedTerm (Id-U-ℕΠ A B) (ne (Idₙ ()))
whnfRedTerm (Id-U-Πℕ A B) (ne (Idₙ ()))
whnfRedTerm (Id-U-ΠΠ!% eq A B A' B') (ne (Idₙ ()))
whnfRedTerm (cast-subst d x x₁ x₂) (ne (castₙ x₃)) = neRedTerm d x₃
whnfRedTerm (cast-subst d x x₁ x₂) (ne (castℕₙ x₃)) = whnfRedTerm d ℕₙ
whnfRedTerm (cast-subst d x x₁ x₂) (ne (castΠₙ x₃)) = whnfRedTerm d Πₙ
whnfRedTerm (cast-subst d x x₁ x₂) (ne (castℕℕₙ x₃)) = whnfRedTerm d ℕₙ
whnfRedTerm (cast-subst d x x₁ x₂) (ne castℕΠₙ) = whnfRedTerm d ℕₙ
whnfRedTerm (cast-subst d x x₁ x₂) (ne castΠℕₙ) = whnfRedTerm d Πₙ
whnfRedTerm (cast-ℕ-subst d x x₁) (ne (castℕₙ x₂)) = neRedTerm d x₂
whnfRedTerm (cast-ℕ-subst d x x₁) (ne (castℕℕₙ x₂)) = whnfRedTerm d ℕₙ
whnfRedTerm (cast-ℕ-subst d x x₁) (ne castℕΠₙ) = whnfRedTerm d Πₙ
whnfRedTerm (cast-Π-subst x x₁ d x₂ x₃) (ne (castΠₙ x₄)) = neRedTerm d x₄
whnfRedTerm (cast-Π-subst x x₁ d x₂ x₃) (ne castΠℕₙ) = whnfRedTerm d ℕₙ
whnfRedTerm (cast-Π x x₁ x₂ x₃ x₄ x₅) (ne (castₙ ()))
whnfRedTerm (cast-Π x x₁ x₂ x₃ x₄ x₅) (ne (castΠₙ ()))
whnfRedTerm (cast-ℕ-0 x) (ne (castₙ ()))
whnfRedTerm (cast-ℕ-0 x) (ne (castℕₙ ()))
whnfRedTerm (cast-ℕ-0 x) (ne (castℕℕₙ ()))
whnfRedTerm (cast-ℕ-S x x₁) (ne (castₙ ()))
whnfRedTerm (cast-ℕ-S x x₁) (ne (castℕₙ ()))
whnfRedTerm (cast-ℕ-S x x₁) (ne (castℕℕₙ ()))
whnfRedTerm (cast-ℕ-cong x x₁) (ne (castₙ ()))
whnfRedTerm (cast-ℕ-cong x x₁) (ne (castℕₙ ()))
whnfRedTerm (cast-ℕ-cong x x₁) (ne (castℕℕₙ t)) = neRedTerm x₁ t
whnfRedTerm (cast-subst d x x₁ x₂) (ne castΠΠ%!ₙ) = whnfRedTerm d Πₙ
whnfRedTerm (cast-subst d x x₁ x₂) (ne castΠΠ!%ₙ) = whnfRedTerm d Πₙ
whnfRedTerm (cast-Π-subst x x₁ d x₂ x₃) (ne castΠΠ%!ₙ) = whnfRedTerm d Πₙ
whnfRedTerm (cast-Π-subst x x₁ d x₂ x₃) (ne castΠΠ!%ₙ) = whnfRedTerm d Πₙ

whnfRed (univ x) w = whnfRedTerm x w

whnfRed*Term : ∀ {Γ t u A l} (d : Γ ⊢ t ⇒* u ∷ A ^ l) (w : Whnf t) → t PE.≡ u
whnfRed*Term (id x) Uₙ = PE.refl
whnfRed*Term (id x) Πₙ = PE.refl
whnfRed*Term (id x) ∃ₙ = PE.refl
whnfRed*Term (id x) ℕₙ = PE.refl
whnfRed*Term (id x) Emptyₙ = PE.refl
whnfRed*Term (id x) lamₙ = PE.refl
whnfRed*Term (id x) zeroₙ = PE.refl
whnfRed*Term (id x) sucₙ = PE.refl
whnfRed*Term (id x) (ne x₁) = PE.refl
whnfRed*Term (conv x x₁ ⇨ d) w = ⊥-elim (whnfRedTerm x w)
whnfRed*Term (x ⇨ d) (ne x₁) = ⊥-elim (neRedTerm x x₁)

whnfRed* : ∀ {Γ A B r} (d : Γ ⊢ A ⇒* B ^ r) (w : Whnf A) → A PE.≡ B
whnfRed* (id x) w = PE.refl
whnfRed* (x ⇨ d) w = ⊥-elim (whnfRed x w)

-- Whr is deterministic

-- somehow the cases (cast-Π, cast-Π) and (Id-U-ΠΠ, Id-U-ΠΠ) fail if
-- we do not introduce a dummy relevance rA'. This is why we need the two
-- auxiliary functions.
whrDetTerm-aux1 : ∀{Γ t u F lF A A' rA lA lB rA' l B B' e f}
  → (d :  t PE.≡ cast l (Π A ^ rA ° lA ▹ B ° lB ° l) (Π A' ^ rA' ° lA ▹ B' ° lB ° l) e f)
  → (d′ : Γ ⊢ t ⇒ u ∷ F ^ lF)
  → (lam A' ▹ (let a = cast l (wk1 A') (wk1 A) (Idsym (Univ rA l) (wk1 A) (wk1 A') (fst (wk1 e))) (var 0) in cast l (B [ a ]↑) B' ((snd (wk1 e)) ∘ (var 0) ^ ¹) ((wk1 f) ∘ a ^ l)) ^ l) PE.≡ u
whrDetTerm-aux1 d (conv d' x) = whrDetTerm-aux1 d d'
whrDetTerm-aux1 PE.refl (cast-subst d' x x₁ x₂) = ⊥-elim (whnfRedTerm d' Πₙ)
whrDetTerm-aux1 PE.refl (cast-Π-subst x x₁ d' x₂ x₃) = ⊥-elim (whnfRedTerm d' Πₙ)
whrDetTerm-aux1 PE.refl (cast-Π x x₁ x₂ x₃ x₄ x₅) = PE.refl

whrDetTerm-aux2 : ∀{Γ t u F lF A rA B A' rA' B'}
  → (rA≡rA' : rA PE.≡ rA')
  → (d : t PE.≡ Id (U ⁰) (Π A ^ rA ° ⁰ ▹ B ° ⁰ ° ⁰) (Π A' ^ rA' ° ⁰ ▹ B' ° ⁰ ° ⁰))
  → (d' : Γ ⊢ t ⇒ u ∷ F ^ lF)
  → (∃ (Id (Univ rA ⁰) A A') ▹ (Π (wk1 A') ^ rA ° ⁰ ▹ Id (U ⁰) ((wk (lift (step id)) B) [ cast ⁰ (wk1 (wk1 A')) (wk1 (wk1 A)) (Idsym (Univ rA ⁰) (wk1 (wk1 A)) (wk1 (wk1 A')) (var 1)) (var 0) ]↑) (wk (lift (step id)) B') ° ¹ ° ¹ ) ) PE.≡ u
whrDetTerm-aux2 eq d (conv d' x) = whrDetTerm-aux2 eq d d'
whrDetTerm-aux2 _ PE.refl (Id-subst d' x x₁) = ⊥-elim (whnfRedTerm d' Uₙ)
whrDetTerm-aux2 _ PE.refl (Id-U-subst d' x) = ⊥-elim (whnfRedTerm d' Πₙ)
whrDetTerm-aux2 _ PE.refl (Id-U-Π-subst x x₁ d') = ⊥-elim (whnfRedTerm d' Πₙ)
whrDetTerm-aux2 _ PE.refl (Id-U-ΠΠ x x₁ x₂ x₃) = PE.refl
whrDetTerm-aux2 PE.refl PE.refl (Id-U-ΠΠ!% eq A B A' B') = ⊥-elim (eq PE.refl)
whrDetTerm : ∀{Γ t u A l u′ A′ l′} (d : Γ ⊢ t ⇒ u ∷ A ^ l) (d′ : Γ ⊢ t ⇒ u′ ∷ A′ ^ l′) → u PE.≡ u′
whrDet : ∀{Γ A B B′ r r'} (d : Γ ⊢ A ⇒ B ^ r) (d′ : Γ ⊢ A ⇒ B′ ^ r') → B PE.≡ B′

whrDetTerm (conv d x) d′ = whrDetTerm d d′
whrDetTerm (app-subst d x) (app-subst d′ x₁) rewrite whrDetTerm d d′ = PE.refl
whrDetTerm (app-subst d x) (β-red _ _ x₁ x₂ x₃) = ⊥-elim (whnfRedTerm d lamₙ)
whrDetTerm (β-red _ _ x x₁ x₂) (app-subst d' x₃) = ⊥-elim (whnfRedTerm d' lamₙ)
whrDetTerm (β-red _ _ x x₁ x₂) (β-red _ _ x₃ x₄ x₅) = PE.refl
whrDetTerm (natrec-subst x x₁ x₂ d) (natrec-subst x₃ x₄ x₅ d') rewrite whrDetTerm d d' = PE.refl
whrDetTerm (natrec-subst x x₁ x₂ d) (natrec-zero x₃ x₄ x₅) = ⊥-elim (whnfRedTerm d zeroₙ)
whrDetTerm (natrec-subst x x₁ x₂ d) (natrec-suc x₃ x₄ x₅ x₆) = ⊥-elim (whnfRedTerm d sucₙ)
whrDetTerm (natrec-zero x x₁ x₂) (natrec-subst x₃ x₄ x₅ d') = ⊥-elim (whnfRedTerm d' zeroₙ)
whrDetTerm (natrec-zero x x₁ x₂) (natrec-zero x₃ x₄ x₅) = PE.refl
whrDetTerm (natrec-suc x x₁ x₂ x₃) (natrec-subst x₄ x₅ x₆ d') = ⊥-elim (whnfRedTerm d' sucₙ)
whrDetTerm (natrec-suc x x₁ x₂ x₃) (natrec-suc x₄ x₅ x₆ x₇) = PE.refl
whrDetTerm (Id-subst d x x₁) (Id-subst d' x₂ x₃) rewrite whrDetTerm d d' = PE.refl
whrDetTerm (Id-subst d x x₁) (Id-ℕ-subst d' x₂) = ⊥-elim (whnfRedTerm d ℕₙ)
whrDetTerm (Id-subst d x x₁) (Id-ℕ-0-subst d') = ⊥-elim (whnfRedTerm d ℕₙ)
whrDetTerm (Id-subst d x x₁) (Id-ℕ-S-subst x₂ d') = ⊥-elim (whnfRedTerm d ℕₙ)
whrDetTerm (Id-subst d x x₁) (Id-U-subst d' x₂) = ⊥-elim (whnfRedTerm d Uₙ)
whrDetTerm (Id-subst d x x₁) (Id-U-ℕ-subst d') = ⊥-elim (whnfRedTerm d Uₙ)
whrDetTerm (Id-subst d x x₁) (Id-U-Π-subst x₂ x₃ d') = ⊥-elim (whnfRedTerm d Uₙ)
whrDetTerm (Id-subst d x x₁) (Id-Π _ _ x₂ x₃ x₄ x₅) = ⊥-elim (whnfRedTerm d Πₙ)
whrDetTerm (Id-subst d x x₁) (Id-ℕ-00 x₂) = ⊥-elim (whnfRedTerm d ℕₙ)
whrDetTerm (Id-subst d x x₁) (Id-ℕ-SS x₂ x₃) = ⊥-elim (whnfRedTerm d ℕₙ)
whrDetTerm (Id-subst d x x₁) (Id-U-ΠΠ x₂ x₃ x₄ x₅) = ⊥-elim (whnfRedTerm d Uₙ)
whrDetTerm (Id-subst d x x₁) (Id-U-ℕℕ x₂) = ⊥-elim (whnfRedTerm d Uₙ)
whrDetTerm (Id-subst d x x₁) (Id-SProp x₂ x₃) = ⊥-elim (whnfRedTerm d Uₙ)
whrDetTerm (Id-subst d x x₁) (Id-ℕ-0S x₂) = ⊥-elim (whnfRedTerm d ℕₙ)
whrDetTerm (Id-subst d x x₁) (Id-ℕ-S0 x₂) = ⊥-elim (whnfRedTerm d ℕₙ)
whrDetTerm (Id-subst d x x₁) (Id-U-ℕΠ x₂ x₃) = ⊥-elim (whnfRedTerm d Uₙ)
whrDetTerm (Id-subst d x x₁) (Id-U-Πℕ x₂ x₃) = ⊥-elim (whnfRedTerm d Uₙ)
whrDetTerm (Id-subst d x x₁) (Id-U-ΠΠ!% x₂ x₃ x₄ x₅ x₆) = ⊥-elim (whnfRedTerm d Uₙ)
whrDetTerm (Id-ℕ-subst d x) (Id-subst d' x₁ x₂) = ⊥-elim (whnfRedTerm d' ℕₙ)
whrDetTerm (Id-ℕ-subst d x) (Id-ℕ-subst d' x₁) rewrite whrDetTerm d d' = PE.refl
whrDetTerm (Id-ℕ-subst d x) (Id-ℕ-0-subst d') = ⊥-elim (whnfRedTerm d zeroₙ)
whrDetTerm (Id-ℕ-subst d x) (Id-ℕ-S-subst x₁ d') = ⊥-elim (whnfRedTerm d sucₙ)
whrDetTerm (Id-ℕ-subst d x) (Id-ℕ-00 x₁) = ⊥-elim (whnfRedTerm d zeroₙ)
whrDetTerm (Id-ℕ-subst d x) (Id-ℕ-SS x₁ x₂) = ⊥-elim (whnfRedTerm d sucₙ)
whrDetTerm (Id-ℕ-subst d x) (Id-ℕ-0S x₁) = ⊥-elim (whnfRedTerm d zeroₙ)
whrDetTerm (Id-ℕ-subst d x) (Id-ℕ-S0 x₁) = ⊥-elim (whnfRedTerm d sucₙ)
whrDetTerm (Id-ℕ-0-subst d) (Id-subst d' x x₁) = ⊥-elim (whnfRedTerm d' ℕₙ)
whrDetTerm (Id-ℕ-0-subst d) (Id-ℕ-subst d' x) = ⊥-elim (whnfRedTerm d' zeroₙ)
whrDetTerm (Id-ℕ-0-subst d) (Id-ℕ-0-subst d') rewrite whrDetTerm d d' = PE.refl
whrDetTerm (Id-ℕ-0-subst d) (Id-ℕ-00 x) = ⊥-elim (whnfRedTerm d zeroₙ)
whrDetTerm (Id-ℕ-0-subst d) (Id-ℕ-0S x) = ⊥-elim (whnfRedTerm d sucₙ)
whrDetTerm (Id-ℕ-S-subst x d) (Id-subst d' x₁ x₂) = ⊥-elim (whnfRedTerm d' ℕₙ)
whrDetTerm (Id-ℕ-S-subst x d) (Id-ℕ-subst d' x₁) = ⊥-elim (whnfRedTerm d' sucₙ)
whrDetTerm (Id-ℕ-S-subst x d) (Id-ℕ-S-subst x₁ d') rewrite whrDetTerm d d' = PE.refl
whrDetTerm (Id-ℕ-S-subst x d) (Id-ℕ-SS x₁ x₂) = ⊥-elim (whnfRedTerm d sucₙ)
whrDetTerm (Id-ℕ-S-subst x d) (Id-ℕ-S0 x₁) = ⊥-elim (whnfRedTerm d zeroₙ)
whrDetTerm (Id-U-subst d x) (Id-subst d' x₁ x₂) = ⊥-elim (whnfRedTerm d' Uₙ)
whrDetTerm (Id-U-subst d x) (Id-U-subst d' x₁) rewrite whrDetTerm d d' = PE.refl
whrDetTerm (Id-U-subst d x) (Id-U-ℕ-subst d') = ⊥-elim (whnfRedTerm d ℕₙ)
whrDetTerm (Id-U-subst d x) (Id-U-Π-subst x₁ x₂ d') = ⊥-elim (whnfRedTerm d Πₙ)
whrDetTerm (Id-U-subst d x) (Id-U-ΠΠ x₁ x₂ x₃ x₄) = ⊥-elim (whnfRedTerm d Πₙ)
whrDetTerm (Id-U-subst d x) (Id-U-ℕℕ x₁) = ⊥-elim (whnfRedTerm d ℕₙ)
whrDetTerm (Id-U-subst d x) (Id-U-ℕΠ x₁ x₂) = ⊥-elim (whnfRedTerm d ℕₙ)
whrDetTerm (Id-U-subst d x) (Id-U-Πℕ x₁ x₂) = ⊥-elim (whnfRedTerm d Πₙ)
whrDetTerm (Id-U-subst d x) (Id-U-ΠΠ!% x₁ x₂ x₃ x₄ x₅) = ⊥-elim (whnfRedTerm d Πₙ)
whrDetTerm (Id-U-ℕ-subst d) (Id-subst d' x x₁) = ⊥-elim (whnfRedTerm d' Uₙ)
whrDetTerm (Id-U-ℕ-subst d) (Id-U-subst d' x) = ⊥-elim (whnfRedTerm d' ℕₙ)
whrDetTerm (Id-U-ℕ-subst d) (Id-U-ℕ-subst d') rewrite whrDetTerm d d' = PE.refl
whrDetTerm (Id-U-ℕ-subst d) (Id-U-ℕℕ x) = ⊥-elim (whnfRedTerm d ℕₙ)
whrDetTerm (Id-U-ℕ-subst d) (Id-U-ℕΠ x x₁) = ⊥-elim (whnfRedTerm d Πₙ)
whrDetTerm (Id-U-Π-subst x x₁ d) (Id-subst d' x₂ x₃) = ⊥-elim (whnfRedTerm d' Uₙ)
whrDetTerm (Id-U-Π-subst x x₁ d) (Id-U-subst d' x₂) = ⊥-elim (whnfRedTerm d' Πₙ)
whrDetTerm (Id-U-Π-subst x x₁ d) (Id-U-Π-subst x₂ x₃ d') rewrite whrDetTerm d d' = PE.refl
whrDetTerm (Id-U-Π-subst x x₁ d) (Id-U-ΠΠ x₂ x₃ x₄ x₅) = ⊥-elim (whnfRedTerm d Πₙ)
whrDetTerm (Id-U-Π-subst x x₁ d) (Id-U-Πℕ x₂ x₃) = ⊥-elim (whnfRedTerm d ℕₙ)
whrDetTerm (Id-U-Π-subst x x₁ d) (Id-U-ΠΠ!% x₂ x₃ x₄ x₅ x₆) = ⊥-elim (whnfRedTerm d Πₙ)
whrDetTerm (Id-Π _ _ x x₁ x₂ x₃) (Id-subst d' x₄ x₅) = ⊥-elim (whnfRedTerm d' Πₙ)
whrDetTerm (Id-Π _ _ x x₁ x₂ x₃) (Id-Π _ _ x₄ x₅ x₆ x₇) = PE.refl
whrDetTerm (Id-ℕ-00 x) (Id-subst d' x₁ x₂) = ⊥-elim (whnfRedTerm d' ℕₙ)
whrDetTerm (Id-ℕ-00 x) (Id-ℕ-subst d' x₁) = ⊥-elim (whnfRedTerm d' zeroₙ)
whrDetTerm (Id-ℕ-00 x) (Id-ℕ-0-subst d') = ⊥-elim (whnfRedTerm d' zeroₙ)
whrDetTerm (Id-ℕ-00 x) (Id-ℕ-00 x₁) = PE.refl
whrDetTerm (Id-ℕ-SS x x₁) (Id-subst d' x₂ x₃) = ⊥-elim (whnfRedTerm d' ℕₙ)
whrDetTerm (Id-ℕ-SS x x₁) (Id-ℕ-subst d' x₂) = ⊥-elim (whnfRedTerm d' sucₙ)
whrDetTerm (Id-ℕ-SS x x₁) (Id-ℕ-S-subst x₂ d') = ⊥-elim (whnfRedTerm d' sucₙ)
whrDetTerm (Id-ℕ-SS x x₁) (Id-ℕ-SS x₂ x₃) = PE.refl
whrDetTerm (Id-U-ΠΠ x x₁ x₂ x₃) d' = whrDetTerm-aux2 PE.refl PE.refl d'
whrDetTerm (Id-U-ℕℕ x) (Id-subst d' x₁ x₂) = ⊥-elim (whnfRedTerm d' Uₙ)
whrDetTerm (Id-U-ℕℕ x) (Id-U-subst d' x₁) = ⊥-elim (whnfRedTerm d' ℕₙ)
whrDetTerm (Id-U-ℕℕ x) (Id-U-ℕ-subst d') = ⊥-elim (whnfRedTerm d' ℕₙ)
whrDetTerm (Id-U-ℕℕ x) (Id-U-ℕℕ x₁) = PE.refl
whrDetTerm (Id-SProp x x₁) (Id-subst d' x₂ x₃) = ⊥-elim (whnfRedTerm d' Uₙ)
whrDetTerm (Id-SProp x x₁) (Id-SProp x₂ x₃) = PE.refl
whrDetTerm (Id-ℕ-0S x) (Id-subst d' x₁ x₂) = ⊥-elim (whnfRedTerm d' ℕₙ)
whrDetTerm (Id-ℕ-0S x) (Id-ℕ-subst d' x₁) = ⊥-elim (whnfRedTerm d' zeroₙ)
whrDetTerm (Id-ℕ-0S x) (Id-ℕ-0-subst d') = ⊥-elim (whnfRedTerm d' sucₙ)
whrDetTerm (Id-ℕ-0S x) (Id-ℕ-0S x₁) = PE.refl
whrDetTerm (Id-ℕ-S0 x) (Id-subst d' x₁ x₂) = ⊥-elim (whnfRedTerm d' ℕₙ)
whrDetTerm (Id-ℕ-S0 x) (Id-ℕ-subst d' x₁) = ⊥-elim (whnfRedTerm d' sucₙ)
whrDetTerm (Id-ℕ-S0 x) (Id-ℕ-S-subst x₁ d') = ⊥-elim (whnfRedTerm d' zeroₙ)
whrDetTerm (Id-ℕ-S0 x) (Id-ℕ-S0 x₁) = PE.refl
whrDetTerm (Id-U-ℕΠ x x₁) (Id-subst d' x₂ x₃) = ⊥-elim (whnfRedTerm d' Uₙ)
whrDetTerm (Id-U-ℕΠ x x₁) (Id-U-subst d' x₂) = ⊥-elim (whnfRedTerm d' ℕₙ)
whrDetTerm (Id-U-ℕΠ x x₁) (Id-U-ℕ-subst d') = ⊥-elim (whnfRedTerm d' Πₙ)
whrDetTerm (Id-U-ℕΠ x x₁) (Id-U-ℕΠ x₂ x₃) = PE.refl
whrDetTerm (Id-U-Πℕ x x₁) (Id-subst d' x₂ x₃) = ⊥-elim (whnfRedTerm d' Uₙ)
whrDetTerm (Id-U-Πℕ x x₁) (Id-U-subst d' x₂) = ⊥-elim (whnfRedTerm d' Πₙ)
whrDetTerm (Id-U-Πℕ x x₁) (Id-U-Π-subst x₂ x₃ d') = ⊥-elim (whnfRedTerm d' ℕₙ)
whrDetTerm (Id-U-Πℕ x x₁) (Id-U-Πℕ x₂ x₃) = PE.refl
whrDetTerm (Id-U-ΠΠ!% eq A B A' B') (Id-subst d' x x₁) = ⊥-elim (whnfRedTerm d' Uₙ)
whrDetTerm (Id-U-ΠΠ!% eq A B A' B') (Id-U-subst d' x) = ⊥-elim (whnfRedTerm d' Πₙ)
whrDetTerm (Id-U-ΠΠ!% eq A B A' B') (Id-U-Π-subst x x₁ d') = ⊥-elim (whnfRedTerm d' Πₙ)
whrDetTerm (Id-U-ΠΠ!% eq A B A' B') (Id-U-ΠΠ x x₁ x₂ x₃) = ⊥-elim (eq PE.refl)
whrDetTerm (Id-U-ΠΠ!% eq A B A' B') (Id-U-ΠΠ!% x x₁ x₂ x₃ x₄) = PE.refl
whrDetTerm (cast-subst d x x₁ x₂) (cast-subst d' x₃ x₄ x₅) rewrite whrDetTerm d d' = PE.refl
whrDetTerm (cast-subst d x x₁ x₂) (cast-ℕ-subst d' x₃ x₄) = ⊥-elim (whnfRedTerm d ℕₙ)
whrDetTerm (cast-subst d x x₁ x₂) (cast-Π-subst x₃ x₄ d' x₅ x₆) = ⊥-elim (whnfRedTerm d Πₙ)
whrDetTerm (cast-subst d x x₁ x₂) (cast-Π x₃ x₄ x₅ x₆ x₇ x₈) = ⊥-elim (whnfRedTerm d Πₙ)
whrDetTerm (cast-subst d x x₁ x₂) (cast-ℕ-0 x₃) = ⊥-elim (whnfRedTerm d ℕₙ)
whrDetTerm (cast-subst d x x₁ x₂) (cast-ℕ-S x₃ x₄) = ⊥-elim (whnfRedTerm d ℕₙ)
whrDetTerm (cast-ℕ-subst d x x₁) (cast-subst d' x₂ x₃ x₄) = ⊥-elim (whnfRedTerm d' ℕₙ)
whrDetTerm (cast-ℕ-subst d x x₁) (cast-ℕ-subst d' x₂ x₃) rewrite whrDetTerm d d' = PE.refl
whrDetTerm (cast-ℕ-subst d x x₁) (cast-ℕ-0 x₂) = ⊥-elim (whnfRedTerm d ℕₙ)
whrDetTerm (cast-ℕ-subst d x x₁) (cast-ℕ-S x₂ x₃) = ⊥-elim (whnfRedTerm d ℕₙ)
whrDetTerm (cast-Π-subst x x₁ d x₂ x₃) (cast-subst d' x₄ x₅ x₆) = ⊥-elim (whnfRedTerm d' Πₙ)
whrDetTerm (cast-Π-subst x x₁ d x₂ x₃) (cast-Π-subst x₄ x₅ d' x₆ x₇) rewrite whrDetTerm d d' = PE.refl
whrDetTerm (cast-Π-subst x x₁ d x₂ x₃) (cast-Π x₄ x₅ x₆ x₇ x₈ x₉) = ⊥-elim (whnfRedTerm d Πₙ)
whrDetTerm (cast-Π x x₁ x₂ x₃ x₄ x₅) d' = whrDetTerm-aux1 (PE.refl) d'
whrDetTerm (cast-ℕ-0 x) (cast-subst d' x₁ x₂ x₃) = ⊥-elim (whnfRedTerm d' ℕₙ)
whrDetTerm (cast-ℕ-0 x) (cast-ℕ-subst d' x₁ x₂) = ⊥-elim (whnfRedTerm d' ℕₙ)
whrDetTerm (cast-ℕ-0 x) (cast-ℕ-0 x₁) = PE.refl
whrDetTerm (cast-ℕ-S x x₁) (cast-subst d' x₂ x₃ x₄) = ⊥-elim (whnfRedTerm d' ℕₙ)
whrDetTerm (cast-ℕ-S x x₁) (cast-ℕ-subst d' x₂ x₃) = ⊥-elim (whnfRedTerm d' ℕₙ)
whrDetTerm (cast-ℕ-S x x₁) (cast-ℕ-S x₂ x₃) = PE.refl
whrDetTerm (cast-ℕ-cong x x₁) (cast-subst d' x₂ x₃ x₄) = ⊥-elim (whnfRedTerm d' ℕₙ)
whrDetTerm (cast-ℕ-cong x x₁) (cast-ℕ-subst d' x₂ x₃) = ⊥-elim (whnfRedTerm d' ℕₙ)
whrDetTerm (cast-ℕ-cong x x₁) (cast-ℕ-cong x₂ x₃) rewrite whrDetTerm x₁ x₃ = PE.refl --
whrDetTerm (cast-subst d x x₁ x₂) (cast-ℕ-cong x₃ d′) = ⊥-elim (whnfRedTerm d ℕₙ)
whrDetTerm (cast-ℕ-subst d x x₁) (cast-ℕ-cong x₂ d′) = ⊥-elim (whnfRedTerm d ℕₙ)
whrDetTerm (cast-ℕ-0 x) (cast-ℕ-cong x₁ d′) = ⊥-elim (whnfRedTerm d′ zeroₙ)
whrDetTerm (cast-ℕ-S x x₁) (cast-ℕ-cong x₂ d′) = ⊥-elim (whnfRedTerm d′ sucₙ)
whrDetTerm (cast-ℕ-cong x d) (cast-ℕ-0 x₁) = ⊥-elim (whnfRedTerm d zeroₙ)
whrDetTerm (cast-ℕ-cong x d) (cast-ℕ-S x₁ x₂) = ⊥-elim (whnfRedTerm d sucₙ)

{-# CATCHALL #-}
whrDetTerm d (conv d′ x₁) = whrDetTerm d d′

whrDet (univ x) (univ x₁) = whrDetTerm x x₁

whrDet↘Term : ∀{Γ t u A l u′} (d : Γ ⊢ t ↘ u ∷ A ^ l) (d′ : Γ ⊢ t ⇒* u′ ∷ A ^ l)
  → Γ ⊢ u′ ⇒* u ∷ A ^ l
whrDet↘Term (proj₁ , proj₂) (id x) = proj₁
whrDet↘Term (id x , proj₂) (x₁ ⇨ d′) = ⊥-elim (whnfRedTerm x₁ proj₂)
whrDet↘Term (x ⇨ proj₁ , proj₂) (x₁ ⇨ d′) =
  whrDet↘Term (PE.subst (λ x₂ → _ ⊢ x₂ ↘ _ ∷ _ ^ _) (whrDetTerm x x₁) (proj₁ , proj₂)) d′

whrDet*Term : ∀{Γ t u A A' l u′ } (d : Γ ⊢ t ↘ u ∷ A ^ l) (d′ : Γ ⊢ t ↘ u′ ∷ A' ^ l) → u PE.≡ u′
whrDet*Term (id x , proj₂) (id x₁ , proj₄) = PE.refl
whrDet*Term (id x , proj₂) (x₁ ⇨ proj₃ , proj₄) = ⊥-elim (whnfRedTerm x₁ proj₂)
whrDet*Term (x ⇨ proj₁ , proj₂) (id x₁ , proj₄) = ⊥-elim (whnfRedTerm x proj₄)
whrDet*Term (x ⇨ proj₁ , proj₂) (x₁ ⇨ proj₃ , proj₄) =
  whrDet*Term (proj₁ , proj₂) (PE.subst (λ x₂ → _ ⊢ x₂ ↘ _ ∷ _ ^ _)
                                    (whrDetTerm x₁ x) (proj₃ , proj₄))

whrDet* : ∀{Γ A B B′ r r'} (d : Γ ⊢ A ↘ B ^ r) (d′ : Γ ⊢ A ↘ B′ ^ r') → B PE.≡ B′
whrDet* (id x , proj₂) (id x₁ , proj₄) = PE.refl
whrDet* (id x , proj₂) (x₁ ⇨ proj₃ , proj₄) = ⊥-elim (whnfRed x₁ proj₂)
whrDet* (x ⇨ proj₁ , proj₂) (id x₁ , proj₄) = ⊥-elim (whnfRed x proj₄)
whrDet* (A⇒A′ ⇨ A′⇒*B , whnfB) (A⇒A″ ⇨ A″⇒*B′ , whnfB′) =
  whrDet* (A′⇒*B , whnfB) (PE.subst (λ x → _ ⊢ x ↘ _ ^ _ )
                                     (whrDet A⇒A″ A⇒A′)
                                     (A″⇒*B′ , whnfB′))

-- Identity of syntactic reduction

idRed:*: : ∀ {Γ A r} → Γ ⊢ A ^ r → Γ ⊢ A :⇒*: A ^ r
idRed:*: A = [[ A , A , id A ]]

idRedTerm:*: : ∀ {Γ A l t} → Γ ⊢ t ∷ A ^ [ ! , l ] → Γ ⊢ t :⇒*: t ∷ A ^ l
idRedTerm:*: t = [[ t , t , id t ]]

-- U cannot be a term

UnotInA : ∀ {A Γ r r'} → Γ ⊢ (Univ r ¹) ∷ A ^ r' → ⊥
UnotInA (conv U∷U x) = UnotInA U∷U

UnotInA[t] : ∀ {A B t a Γ r r' r'' r'''}
         → t [ a ] PE.≡ (Univ r ¹)
         → Γ ⊢ a ∷ A ^ r'
         → Γ ∙ A ^ r'' ⊢ t ∷ B ^ r'''
         → ⊥
UnotInA[t] () x₁ (univ 0<1 x₂)
UnotInA[t] () x₁ (ℕⱼ x₂)
UnotInA[t] () x₁ (Emptyⱼ x₂)
UnotInA[t] () x₁ (Πⱼ _ ▹ _ ▹ x₂ ▹ x₃)
UnotInA[t] x₁ x₂ (var x₃ here) rewrite x₁ = UnotInA x₂
UnotInA[t] () x₂ (var x₃ (there x₄))
UnotInA[t] () x₁ (lamⱼ _ _ x₂ x₃)
UnotInA[t] () x₁ (x₂ ∘ⱼ x₃)
UnotInA[t] () x₁ (zeroⱼ x₂)
UnotInA[t] () x₁ (sucⱼ x₂)
UnotInA[t] () x₁ (natrecⱼ x₂ x₃ x₄ x₅)
UnotInA[t] () x₁ (Emptyrecⱼ x₂ x₃)
UnotInA[t] x x₁ (conv x₂ x₃) = UnotInA[t] x x₁ x₂

redU*Term′ : ∀ {A B U′ l Γ r} → U′ PE.≡ (Univ r ¹) → Γ ⊢ A ⇒ U′ ∷ B ^ l → ⊥
redU*Term′ U′≡U (conv A⇒U x) = redU*Term′ U′≡U A⇒U
redU*Term′ () (app-subst A⇒U x)
redU*Term′ U′≡U (β-red _ _ x x₁ x₂) = UnotInA[t] U′≡U x₂ x₁
redU*Term′ () (natrec-subst x x₁ x₂ A⇒U)
redU*Term′ U′≡U (natrec-zero x x₁ x₂) rewrite U′≡U = UnotInA x₁
redU*Term′ () (natrec-suc x x₁ x₂ x₃)

redU*Term : ∀ {A B l Γ r} → Γ ⊢ A ⇒* (Univ r ¹) ∷ B ^ l → ⊥
redU*Term (id x) = UnotInA x
redU*Term (x ⇨ A⇒*U) = redU*Term A⇒*U

-- Nothing reduces to U

redU : ∀ {A Γ r l } → Γ ⊢ A ⇒ (Univ r ¹) ^ [ ! , l ] → ⊥
redU (univ x) = redU*Term′ PE.refl x

redU* : ∀ {A Γ r l } → Γ ⊢ A ⇒* (Univ r ¹) ^ [ ! , l ] → A PE.≡ (Univ r ¹)
redU* (id x) = PE.refl
redU* (x ⇨ A⇒*U) rewrite redU* A⇒*U = ⊥-elim (redU x)

-- convertibility for irrelevant terms implies typing

typeInversion : ∀ {t u A l Γ} → Γ ⊢ t ≡ u ∷ A ^ [ % , l ] → Γ ⊢ t ∷ A ^ [ % , l ]
typeInversion (conv X x) = let d = typeInversion X in conv d x
typeInversion (proof-irrelevance x x₁) = x

-- general version of reflexivity, symmetry and transitivity

genRefl : ∀ {A Γ t r l } → Γ ⊢ t ∷ A ^ [ r , l ] → Γ ⊢ t ≡ t ∷ A ^ [ r , l ]
genRefl {r = !} d = refl d
genRefl {r = %} d = proof-irrelevance d d

-- Judgmental instance of the equality relation

genSym : ∀ {k l A Γ r lA } → Γ ⊢ k ≡ l ∷ A ^ [ r , lA ] → Γ ⊢ l ≡ k ∷ A ^ [ r , lA ]
genSym {r = !} = sym
genSym {r = %} (proof-irrelevance x x₁) = proof-irrelevance x₁ x
genSym {r = %} (conv x x₁) = conv (genSym x) x₁

genTrans : ∀ {k l m A r Γ lA } → Γ ⊢ k ≡ l ∷ A ^ [ r , lA ] → Γ ⊢ l ≡ m ∷ A ^ [ r , lA ] → Γ ⊢ k ≡ m ∷ A ^ [ r , lA ]
genTrans {r = !} = trans
genTrans {r = %} (conv X x) (conv Y x₁) = conv (genTrans X (conv Y (trans x₁ (sym x)))) x
genTrans {r = %} (conv X x) (proof-irrelevance x₁ x₂) = proof-irrelevance (conv (typeInversion X) x) x₂
genTrans {r = %} (proof-irrelevance x x₁) (conv Y x₂) = proof-irrelevance x (conv (typeInversion (genSym Y)) x₂)
genTrans {r = %} (proof-irrelevance x x₁) (proof-irrelevance x₂ x₃) = proof-irrelevance x x₃

genVar : ∀ {x A Γ r l } → Γ ⊢ var x ∷ A ^ [ r , l ] → Γ ⊢ var x ≡ var x ∷ A ^ [ r , l ]
genVar {r = !} = refl
genVar {r = %} d = proof-irrelevance d d

toLevelInj : ∀ {l₁ l₁′ : TypeLevel} {l<₁ : l₁′ <∞ l₁} {l₂ l₂′ : TypeLevel} {l<₂ : l₂′ <∞ l₂} →
               toLevel l₁′ PE.≡ toLevel l₂′ → l₁′ PE.≡ l₂′
toLevelInj {.(ι ¹)} {.(ι ⁰)} {emb<} {.(ι ¹)} {.(ι ⁰)} {emb<} e = PE.refl
toLevelInj {.∞} {.(ι ¹)} {∞<} {.(ι ¹)} {.(ι ⁰)} {emb<} ()
toLevelInj {.∞} {.(ι ¹)} {∞<} {.∞} {.(ι ¹)} {∞<} e = PE.refl

redSProp′ : ∀ {Γ A B l}
           (D : Γ ⊢ A ⇒* B ∷ SProp l ^ next l )
         → Γ ⊢ A ⇒* B ^ [ % , ι l ]
redSProp′ (id x) = id (univ x)
redSProp′ (x ⇨ D) = univ x ⇨ redSProp′ D

redSProp : ∀ {Γ A B l}
           (D : Γ ⊢ A :⇒*: B ∷ SProp l ^ next l )
         → Γ ⊢ A :⇒*: B ^ [ % , ι l ]
redSProp [[ ⊢t , ⊢u , d ]] = [[ (univ ⊢t) , (univ ⊢u) , redSProp′ d ]]

un-univ : ∀ {A r Γ l} → Γ ⊢ A ^ [ r , ι l ] → Γ ⊢ A ∷ Univ r l ^ [ ! , next l ]
un-univ (univ x) = x

un-univ≡ : ∀ {A B r Γ l} → Γ ⊢ A ≡ B ^ [ r , ι l ] → Γ ⊢ A ≡ B ∷ Univ r l ^ [ ! , next l ]
un-univ≡ (univ x) = x
un-univ≡ (refl x) = refl (un-univ x)
un-univ≡ (sym X) = sym (un-univ≡ X)
un-univ≡ (trans X Y) = trans (un-univ≡ X) (un-univ≡ Y)

univ-gen : ∀ {r Γ l} → (⊢Γ : ⊢ Γ) → Γ ⊢ Univ r l ^ [ ! , next l ]
univ-gen {l = ⁰} ⊢Γ = univ (univ 0<1 ⊢Γ )
univ-gen {l = ¹} ⊢Γ = Uⱼ ⊢Γ

un-univ⇒ : ∀ {l Γ A B r} → Γ ⊢ A ⇒ B ^ [ r , ι l ] → Γ ⊢ A ⇒ B ∷ Univ r l ^ next l
un-univ⇒ (univ x) = x

univ⇒* : ∀ {l Γ A B r} → Γ ⊢ A ⇒* B ∷ Univ r l ^ next l → Γ ⊢ A ⇒* B ^ [ r , ι l ]
univ⇒* (id x) = id (univ x)
univ⇒* (x ⇨ D) = univ x ⇨ univ⇒* D

un-univ⇒* : ∀ {l Γ A B r} → Γ ⊢ A ⇒* B ^ [ r , ι l ] → Γ ⊢ A ⇒* B ∷ Univ r l ^ next l
un-univ⇒* (id x) = id (un-univ x)
un-univ⇒* (x ⇨ D) = un-univ⇒ x ⇨ un-univ⇒* D

univ:⇒*: : ∀ {l Γ A B r} →  Γ ⊢ A :⇒*: B ∷ Univ r l ^ next l → Γ ⊢ A :⇒*: B ^ [ r , ι l ]
univ:⇒*: [[ ⊢A , ⊢B , D ]] = [[ (univ ⊢A) , (univ ⊢B) , (univ⇒* D) ]]

un-univ:⇒*: : ∀ {l Γ A B r} → Γ ⊢ A :⇒*: B ^ [ r , ι l ] → Γ ⊢ A :⇒*: B ∷ Univ r l ^ next l
un-univ:⇒*: [[ ⊢A , ⊢B , D ]] = [[ (un-univ ⊢A) , (un-univ ⊢B) , (un-univ⇒* D) ]]

IdRed*Term′ : ∀ {Γ A B t u l}
         (⊢t : Γ ⊢ t ∷ A ^ [ ! , ι l ])
         (⊢u : Γ ⊢ u ∷ A ^ [ ! , ι l ])
         (D : Γ ⊢ A ⇒* B ^ [ ! , ι l ])
       → Γ ⊢ Id A t u ⇒* Id B t u ∷ SProp l ^ next l
IdRed*Term′ ⊢t ⊢u (id (univ ⊢A)) = id (Idⱼ ⊢A ⊢t ⊢u)
IdRed*Term′ ⊢t ⊢u (univ d ⇨ D) = Id-subst d ⊢t ⊢u ⇨ IdRed*Term′ (conv ⊢t (subset (univ d))) (conv ⊢u (subset (univ d))) D

IdRed*Term : ∀ {Γ A B t u l}
          (⊢t : Γ ⊢ t ∷ A ^ [ ! , ι l ])
          (⊢u : Γ ⊢ u ∷ A ^ [ ! , ι l ])
          (D : Γ ⊢ A :⇒*: B ^ [ ! , ι l ])
        → Γ ⊢ Id A t u :⇒*: Id B t u ∷ SProp l ^ next l
IdRed*Term {Γ} {A} {B} ⊢t ⊢u [[ univ ⊢A , univ ⊢B , D ]] =
  [[ Idⱼ ⊢A ⊢t ⊢u , Idⱼ ⊢B (conv ⊢t (subset* D)) (conv ⊢u (subset* D)) ,
     IdRed*Term′ ⊢t ⊢u D ]]

IdRed* : ∀ {Γ A B t u l}
         (⊢t : Γ ⊢ t ∷ A ^ [ ! , ι l ])
         (⊢u : Γ ⊢ u ∷ A ^ [ ! , ι l ])
         (D : Γ ⊢ A ⇒* B ^ [ ! , ι l ])
       → Γ ⊢ Id A t u ⇒* Id B t u ^ [ % , ι l ]
IdRed* ⊢t ⊢u (id ⊢A) = id (univ (Idⱼ (un-univ ⊢A) ⊢t ⊢u))
IdRed* ⊢t ⊢u (d ⇨ D) = univ (Id-subst (un-univ⇒ d) ⊢t ⊢u) ⇨ IdRed* (conv ⊢t (subset d)) (conv ⊢u (subset d)) D

CastRed*Term′ : ∀ {Γ A B X e t}
         (⊢X : Γ ⊢ X ^ [ ! , ι ⁰ ])
         (⊢e : Γ ⊢ e ∷ Id (U ⁰) A X ^ [ % , next ⁰ ])
         (⊢t : Γ ⊢ t ∷ A ^ [ ! , ι ⁰ ])
         (D : Γ ⊢ A ⇒* B ^ [ ! , ι ⁰ ])
       → Γ ⊢ cast ⁰ A X e t ⇒* cast ⁰ B X e t ∷ X ^ ι ⁰
CastRed*Term′ (univ ⊢X) ⊢e ⊢t  (id (univ ⊢A)) = id (castⱼ ⊢A ⊢X ⊢e ⊢t)
CastRed*Term′ (univ ⊢X) ⊢e ⊢t  (univ d ⇨ D) = cast-subst d ⊢X ⊢e ⊢t ⇨
              CastRed*Term′ (univ ⊢X) (conv ⊢e (univ (Id-cong (refl (univ 0<1 (wfTerm ⊢t))) (subsetTerm d) (refl ⊢X)) )) (conv ⊢t (subset (univ d))) D

CastRed*Term : ∀ {Γ A B X t e}
         (⊢X : Γ ⊢ X ^ [ ! , ι ⁰ ])
         (⊢e : Γ ⊢ e ∷ Id (U ⁰) A X ^ [ % , next ⁰ ])
         (⊢t : Γ ⊢ t ∷ A ^ [ ! , ι ⁰ ])
         (D : Γ ⊢ A :⇒*: B ∷ U ⁰ ^ next ⁰)
       → Γ ⊢ cast ⁰ A X e t :⇒*: cast ⁰ B X e t ∷ X ^ ι ⁰
CastRed*Term {Γ} {A} {B} (univ ⊢X) ⊢e ⊢t [[ ⊢A , ⊢B , D ]] =
  [[ castⱼ ⊢A ⊢X ⊢e ⊢t , castⱼ ⊢B ⊢X (conv ⊢e (univ (Id-cong (refl (univ 0<1 (wfTerm ⊢t))) (subset*Term D) (refl ⊢X)) )) (conv ⊢t (univ (subset*Term D))) ,
     CastRed*Term′ (univ ⊢X) ⊢e ⊢t (univ* D) ]]

CastRed*Termℕ′ : ∀ {Γ A B e t}
         (⊢e : Γ ⊢ e ∷ Id (U ⁰) ℕ A ^ [ % , next ⁰ ])
         (⊢t : Γ ⊢ t ∷ ℕ ^ [ ! , ι ⁰ ])
         (D : Γ ⊢ A ⇒* B ^ [ ! , ι ⁰ ])
       → Γ ⊢ cast ⁰ ℕ A e t ⇒* cast ⁰ ℕ B e t ∷ A ^ ι ⁰
CastRed*Termℕ′ ⊢e ⊢t  (id (univ ⊢A)) = id (castⱼ (ℕⱼ (wfTerm ⊢A)) ⊢A ⊢e ⊢t)
CastRed*Termℕ′ ⊢e ⊢t  (univ d ⇨ D) = cast-ℕ-subst d ⊢e ⊢t ⇨
                                     conv* (CastRed*Termℕ′ (conv ⊢e (univ (Id-cong (refl (univ 0<1 (wfTerm ⊢e))) (refl (ℕⱼ (wfTerm ⊢e))) (subsetTerm d))) ) ⊢t D)
                                           (sym (subset (univ d)))

CastRed*Termℕ : ∀ {Γ A B e t}
         (⊢e : Γ ⊢ e ∷ Id (U ⁰) ℕ A ^ [ % , next ⁰ ])
         (⊢t : Γ ⊢ t ∷ ℕ ^ [ ! , ι ⁰ ])
         (D : Γ ⊢ A :⇒*: B ^ [ ! , ι ⁰ ])
       → Γ ⊢ cast ⁰ ℕ A e t :⇒*: cast ⁰ ℕ B e t ∷ A ^ ι ⁰
CastRed*Termℕ ⊢e ⊢t  [[ ⊢A , ⊢B , D ]] =
  [[ castⱼ (ℕⱼ (wfTerm ⊢e)) (un-univ ⊢A) ⊢e ⊢t ,
     conv (castⱼ (ℕⱼ (wfTerm ⊢e)) (un-univ ⊢B) (conv ⊢e (univ (Id-cong (refl (univ 0<1 (wfTerm ⊢e))) (refl (ℕⱼ (wfTerm ⊢e))) (subset*Term (un-univ⇒* D))))) ⊢t) (sym (subset* D)) ,
       CastRed*Termℕ′ ⊢e ⊢t D ]]

CastRed*Termℕℕ′ : ∀ {Γ e t u}
         (⊢e : Γ ⊢ e ∷ Id (U ⁰) ℕ ℕ ^ [ % , next ⁰ ])
         (⊢t : Γ ⊢ t ⇒* u ∷ ℕ ^ ι ⁰ )
       → Γ ⊢ cast ⁰ ℕ ℕ e t ⇒* cast ⁰ ℕ ℕ e u ∷ ℕ ^ ι ⁰
CastRed*Termℕℕ′ ⊢e (id ⊢t) = id (castⱼ (ℕⱼ (wfTerm ⊢e)) (ℕⱼ (wfTerm ⊢e)) ⊢e ⊢t)
CastRed*Termℕℕ′ ⊢e (d ⇨ D) = cast-ℕ-cong ⊢e d ⇨ CastRed*Termℕℕ′ ⊢e D

CastRed*Termℕℕ : ∀ {Γ e t u}
         (⊢e : Γ ⊢ e ∷ Id (U ⁰) ℕ ℕ ^ [ % , next ⁰ ])
         (⊢t : Γ ⊢ t :⇒*: u ∷ ℕ ^ ι ⁰ )
       → Γ ⊢ cast ⁰ ℕ ℕ e t :⇒*: cast ⁰ ℕ ℕ e u ∷ ℕ ^ ι ⁰
CastRed*Termℕℕ ⊢e [[ ⊢t , ⊢u , D ]] =
  [[ castⱼ (ℕⱼ (wfTerm ⊢e)) (ℕⱼ (wfTerm ⊢e)) ⊢e ⊢t ,
     castⱼ (ℕⱼ (wfTerm ⊢e)) (ℕⱼ (wfTerm ⊢e)) ⊢e ⊢u ,
       CastRed*Termℕℕ′ ⊢e D ]]

CastRed*Termℕsuc : ∀ {Γ e n}
         (⊢e : Γ ⊢ e ∷ Id (U ⁰) ℕ ℕ ^ [ % , next ⁰ ])
         (⊢n : Γ ⊢ n ∷ ℕ ^ [ ! , ι ⁰ ])
       → Γ ⊢ cast ⁰ ℕ ℕ e (suc n) :⇒*: suc (cast ⁰ ℕ ℕ e n) ∷ ℕ ^ ι ⁰
CastRed*Termℕsuc ⊢e ⊢n =
  [[ castⱼ (ℕⱼ (wfTerm ⊢e)) (ℕⱼ (wfTerm ⊢e)) ⊢e (sucⱼ ⊢n) ,
     sucⱼ (castⱼ (ℕⱼ (wfTerm ⊢e)) (ℕⱼ (wfTerm ⊢e)) ⊢e ⊢n) ,
       cast-ℕ-S ⊢e ⊢n ⇨ id (sucⱼ (castⱼ (ℕⱼ (wfTerm ⊢e)) (ℕⱼ (wfTerm ⊢e)) ⊢e ⊢n)) ]]

CastRed*Termℕzero : ∀ {Γ e}
         (⊢e : Γ ⊢ e ∷ Id (U ⁰) ℕ ℕ ^ [ % , next ⁰ ])
       → Γ ⊢ cast ⁰ ℕ ℕ e zero :⇒*: zero ∷ ℕ ^ ι ⁰
CastRed*Termℕzero ⊢e =
  [[ castⱼ (ℕⱼ (wfTerm ⊢e)) (ℕⱼ (wfTerm ⊢e)) ⊢e (zeroⱼ (wfTerm ⊢e)) ,
     zeroⱼ (wfTerm ⊢e) ,
       cast-ℕ-0 ⊢e ⇨ id (zeroⱼ (wfTerm ⊢e)) ]]

CastRed*TermΠ′ : ∀ {Γ F rF G A B e t}
         (⊢F : Γ ⊢ F ∷ (Univ rF ⁰) ^ [ ! , next ⁰ ])
         (⊢G : Γ ∙ F ^ [ rF , ι ⁰ ] ⊢ G ∷ U ⁰ ^ [ ! , next ⁰ ])
         (⊢e : Γ ⊢ e ∷ Id (U ⁰) (Π F ^ rF ° ⁰ ▹ G ° ⁰ ° ⁰) A ^ [ % , next ⁰ ])
         (⊢t : Γ ⊢ t ∷ (Π F ^ rF ° ⁰ ▹ G ° ⁰ ° ⁰) ^ [ ! , ι ⁰ ])
         (D : Γ ⊢ A ⇒* B ^ [ ! , ι ⁰ ])
       → Γ ⊢ cast ⁰ (Π F ^ rF ° ⁰ ▹ G ° ⁰ ° ⁰) A e t ⇒* cast ⁰ (Π F ^ rF ° ⁰ ▹ G ° ⁰ ° ⁰) B e t ∷ A ^ ι ⁰
CastRed*TermΠ′ ⊢F ⊢G ⊢e ⊢t (id (univ ⊢A)) = id (castⱼ (Πⱼ ≡is≤ PE.refl ▹ ≡is≤ PE.refl ▹ ⊢F ▹ ⊢G) ⊢A ⊢e ⊢t)
CastRed*TermΠ′ ⊢F ⊢G ⊢e ⊢t (univ d ⇨ D) = cast-Π-subst ⊢F ⊢G d ⊢e ⊢t ⇨
                                     conv* (CastRed*TermΠ′ ⊢F ⊢G (conv ⊢e (univ (Id-cong (refl (univ 0<1 (wfTerm ⊢e))) (refl (Πⱼ ≡is≤ PE.refl ▹ ≡is≤ PE.refl ▹ ⊢F ▹ ⊢G)) (subsetTerm d))) ) ⊢t D)
                                           (sym (subset (univ d)))

CastRed*TermΠ : ∀ {Γ F rF G A B e t}
         (⊢F : Γ ⊢ F ∷ (Univ rF ⁰) ^ [ ! , next ⁰ ])
         (⊢G : Γ ∙ F ^ [ rF , ι ⁰ ] ⊢ G ∷ U ⁰ ^ [ ! , next ⁰ ])
         (⊢e : Γ ⊢ e ∷ Id (U ⁰) (Π F ^ rF ° ⁰ ▹ G ° ⁰ ° ⁰) A ^ [ % , next ⁰ ])
         (⊢t : Γ ⊢ t ∷ (Π F ^ rF ° ⁰ ▹ G ° ⁰ ° ⁰) ^ [ ! , ι ⁰ ])
         (D : Γ ⊢ A :⇒*: B ^ [ ! , ι ⁰ ])
       → Γ ⊢ cast ⁰ (Π F ^ rF ° ⁰ ▹ G ° ⁰ ° ⁰) A e t :⇒*: cast ⁰ (Π F ^ rF ° ⁰ ▹ G ° ⁰ ° ⁰) B e t ∷ A ^ ι ⁰
CastRed*TermΠ ⊢F ⊢G ⊢e ⊢t  [[ ⊢A , ⊢B , D ]] =
  let [Π] = Πⱼ ≡is≤ PE.refl ▹ ≡is≤ PE.refl ▹ ⊢F ▹ ⊢G
  in [[ castⱼ [Π] (un-univ ⊢A) ⊢e ⊢t ,
        conv (castⱼ [Π] (un-univ ⊢B) (conv ⊢e (univ (Id-cong (refl (univ 0<1 (wfTerm ⊢e))) (refl [Π]) (subset*Term (un-univ⇒* D))))) ⊢t) (sym (subset* D)) ,
          CastRed*TermΠ′ ⊢F ⊢G ⊢e ⊢t D ]]

IdURed*Term′ : ∀ {Γ t t′ u}
               (⊢t : Γ ⊢ t ∷ U ⁰ ^ [ ! , ι ¹ ])
               (⊢t′ : Γ ⊢ t′ ∷ U ⁰ ^ [ ! , ι ¹ ])
               (d : Γ ⊢ t ⇒* t′ ∷ U ⁰ ^ ι ¹)
               (⊢u : Γ ⊢ u ∷ U ⁰ ^ [ ! , ι ¹ ])
             → Γ ⊢ Id (U ⁰) t u ⇒* Id (U ⁰) t′ u ∷ SProp ¹ ^ ∞
IdURed*Term′ ⊢t ⊢t′ (id x) ⊢u = id (Idⱼ (univ 0<1 (wfTerm ⊢t)) ⊢t ⊢u)
IdURed*Term′ ⊢t ⊢t′ (x ⇨ d) ⊢u = _⇨_ (Id-U-subst x ⊢u) (IdURed*Term′ (redFirst*Term d) ⊢t′ d ⊢u)

IdURed*Term : ∀ {Γ t t′ u}
               (d : Γ ⊢ t :⇒*: t′ ∷ U ⁰ ^ ι ¹)
               (⊢u : Γ ⊢ u ∷ U ⁰ ^ [ ! , ι ¹ ])
             → Γ ⊢ Id (U ⁰) t u :⇒*: Id (U ⁰) t′ u ∷ SProp ¹ ^ ∞
IdURed*Term [[ ⊢t , ⊢t′ , d ]] ⊢u = [[ Idⱼ (univ 0<1 (wfTerm ⊢u)) ⊢t ⊢u , Idⱼ (univ 0<1 (wfTerm ⊢u)) ⊢t′ ⊢u  , IdURed*Term′ ⊢t ⊢t′ d ⊢u  ]]

IdUΠRed*Term′ : ∀ {Γ F rF G t t′}
               (⊢F : Γ ⊢ F ∷ Univ rF ⁰ ^ [ ! , ι ¹ ])
               (⊢G : Γ ∙ F ^ [ rF , ι ⁰ ] ⊢ G ∷ U ⁰ ^ [ ! , ι ¹ ])
               (⊢t : Γ ⊢ t ∷ U ⁰ ^ [ ! , ι ¹ ])
               (⊢t′ : Γ ⊢ t′ ∷ U ⁰ ^ [ ! , ι ¹ ])
               (d : Γ ⊢ t ⇒* t′ ∷ U ⁰ ^ ι ¹)
             → Γ ⊢ Id (U ⁰) (Π F ^ rF ° ⁰ ▹ G ° ⁰ ° ⁰) t ⇒* Id (U ⁰) (Π F ^ rF ° ⁰ ▹ G ° ⁰ ° ⁰) t′ ∷ SProp ¹ ^ ∞
IdUΠRed*Term′ ⊢F ⊢G ⊢t ⊢t′ (id x) = id (Idⱼ (univ 0<1 (wfTerm ⊢t)) (Πⱼ ≡is≤ PE.refl ▹ ≡is≤ PE.refl ▹ ⊢F ▹ ⊢G) ⊢t)
IdUΠRed*Term′ ⊢F ⊢G ⊢t ⊢t′ (x ⇨ d) = _⇨_ (Id-U-Π-subst ⊢F ⊢G x) (IdUΠRed*Term′ ⊢F ⊢G (redFirst*Term d) ⊢t′ d)

IdUΠRed*Term : ∀ {Γ F rF G t t′}
               (⊢F : Γ ⊢ F ∷ Univ rF ⁰ ^ [ ! , ι ¹ ])
               (⊢G : Γ ∙ F ^ [ rF , ι ⁰ ] ⊢ G ∷ U ⁰ ^ [ ! , ι ¹ ])
               (d : Γ ⊢ t :⇒*: t′ ∷ U ⁰ ^ ι ¹)
             → Γ ⊢ Id (U ⁰) (Π F ^ rF ° ⁰ ▹ G ° ⁰ ° ⁰) t :⇒*: Id (U ⁰) (Π F ^ rF ° ⁰ ▹ G ° ⁰ ° ⁰) t′ ∷ SProp ¹ ^ ∞
IdUΠRed*Term ⊢F ⊢G [[ ⊢t , ⊢t′ , d ]] = [[ Idⱼ (univ 0<1 (wfTerm ⊢t)) (Πⱼ ≡is≤ PE.refl ▹ ≡is≤ PE.refl ▹ ⊢F ▹ ⊢G) ⊢t ,
                                           Idⱼ (univ 0<1 (wfTerm ⊢t)) (Πⱼ ≡is≤ PE.refl ▹ ≡is≤ PE.refl ▹ ⊢F ▹ ⊢G) ⊢t′ ,
                                           IdUΠRed*Term′ ⊢F ⊢G ⊢t ⊢t′ d ]]

IdℕRed*Term′ : ∀ {Γ t t′ u}
               (⊢t : Γ ⊢ t ∷ ℕ ^ [ ! , ι ⁰ ])
               (⊢t′ : Γ ⊢ t′ ∷ ℕ ^ [ ! , ι ⁰ ])
               (d : Γ ⊢ t ⇒* t′ ∷ ℕ ^ ι ⁰)
               (⊢u : Γ ⊢ u ∷ ℕ ^ [ ! , ι ⁰ ])
             → Γ ⊢ Id ℕ t u ⇒* Id ℕ t′ u ∷ SProp ⁰ ^ next ⁰
IdℕRed*Term′ ⊢t ⊢t′ (id x) ⊢u = id (Idⱼ (ℕⱼ (wfTerm ⊢u)) ⊢t ⊢u)
IdℕRed*Term′ ⊢t ⊢t′ (x ⇨ d) ⊢u = _⇨_ (Id-ℕ-subst x ⊢u) (IdℕRed*Term′ (redFirst*Term d) ⊢t′ d ⊢u)

Idℕ0Red*Term′ : ∀ {Γ t t′}
                (⊢t : Γ ⊢ t ∷ ℕ ^ [ ! , ι ⁰ ])
                (⊢t′ : Γ ⊢ t′ ∷ ℕ ^ [ ! , ι ⁰ ])
                (d : Γ ⊢ t ⇒* t′ ∷ ℕ ^ ι ⁰)
              → Γ ⊢ Id ℕ zero t ⇒* Id ℕ zero t′ ∷ SProp ⁰ ^ next ⁰
Idℕ0Red*Term′ ⊢t ⊢t′ (id x) = id (Idⱼ (ℕⱼ (wfTerm ⊢t)) (zeroⱼ (wfTerm ⊢t)) ⊢t)
Idℕ0Red*Term′ ⊢t ⊢t′ (x ⇨ d) = Id-ℕ-0-subst x ⇨ Idℕ0Red*Term′ (redFirst*Term d) ⊢t′ d

IdℕSRed*Term′ : ∀ {Γ t u u′}
                (⊢t : Γ ⊢ t ∷ ℕ ^ [ ! , ι ⁰ ])
                (⊢u : Γ ⊢ u ∷ ℕ ^ [ ! , ι ⁰ ])
                (⊢u′ : Γ ⊢ u′ ∷ ℕ ^ [ ! , ι ⁰ ])
                (d : Γ ⊢ u ⇒* u′ ∷ ℕ ^ ι ⁰)
              → Γ ⊢ Id ℕ (suc t) u ⇒* Id ℕ (suc t) u′ ∷ SProp ⁰ ^ next ⁰
IdℕSRed*Term′ ⊢t ⊢u ⊢u′ (id x) = id (Idⱼ (ℕⱼ (wfTerm ⊢t)) (sucⱼ ⊢t) ⊢u)
IdℕSRed*Term′ ⊢t ⊢u ⊢u′ (x ⇨ d) = Id-ℕ-S-subst ⊢t x ⇨ IdℕSRed*Term′ ⊢t (redFirst*Term d) ⊢u′ d

IdUℕRed*Term′ : ∀ {Γ t t′}
               (⊢t : Γ ⊢ t ∷ U ⁰ ^ [ ! , ι ¹ ])
               (⊢t′ : Γ ⊢ t′ ∷ U ⁰ ^ [ ! , ι ¹ ])
               (d : Γ ⊢ t ⇒* t′ ∷ U ⁰ ^ ι ¹)
             → Γ ⊢ Id (U ⁰) ℕ t ⇒* Id (U ⁰) ℕ t′ ∷ SProp ¹ ^ ∞
IdUℕRed*Term′ ⊢t ⊢t′ (id x) = id (Idⱼ (univ 0<1 (wfTerm ⊢t)) (ℕⱼ (wfTerm ⊢t) ) ⊢t)
IdUℕRed*Term′ ⊢t ⊢t′ (x ⇨ d) =  _⇨_ (Id-U-ℕ-subst x) (IdUℕRed*Term′ (redFirst*Term d) ⊢t′ d)

IdUℕRed*Term : ∀ {Γ t t′}
               (d : Γ ⊢ t :⇒*: t′ ∷ U ⁰ ^ ι ¹)
             → Γ ⊢ Id (U ⁰) ℕ t :⇒*: Id (U ⁰) ℕ t′ ∷ SProp ¹ ^ ∞
IdUℕRed*Term [[ ⊢t , ⊢t′ , d ]] = [[ Idⱼ (univ 0<1 (wfTerm ⊢t)) (ℕⱼ (wfTerm ⊢t) ) ⊢t ,
                                     Idⱼ (univ 0<1 (wfTerm ⊢t)) (ℕⱼ (wfTerm ⊢t) ) ⊢t′ ,
                                     IdUℕRed*Term′ ⊢t ⊢t′ d ]]

appRed* : ∀ {Γ 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
appRed* ⊢a (id x) = id (x ∘ⱼ ⊢a)
appRed* ⊢a (x ⇨ D) = app-subst x ⊢a ⇨ appRed* ⊢a D

castΠRed* : ∀ {Γ F rF G A B e t}
         (⊢F : Γ ⊢ F ^ [ rF , ι ⁰ ])
         (⊢G : Γ ∙ F ^ [ rF , ι ⁰ ] ⊢ G ^ [ ! , ι ⁰ ])
         (⊢e : Γ ⊢ e ∷ Id (U ⁰) (Π F ^ rF ° ⁰ ▹ G ° ⁰ ° ⁰) A ^ [ % , next ⁰ ])
         (⊢t : Γ ⊢ t ∷ Π F ^ rF ° ⁰ ▹ G ° ⁰  ° ⁰ ^ [ ! , ι ⁰ ])
         (D : Γ ⊢ A ⇒* B ^ [ ! , ι ⁰ ])
       → Γ ⊢ cast ⁰ (Π F ^ rF ° ⁰ ▹ G ° ⁰ ° ⁰) A e t ⇒* cast ⁰ (Π F ^ rF ° ⁰ ▹ G ° ⁰ ° ⁰) B e t ∷ A ^ ι ⁰
castΠRed* ⊢F ⊢G ⊢e ⊢t (id (univ ⊢A)) = id (castⱼ (Πⱼ ≡is≤ PE.refl ▹ ≡is≤ PE.refl ▹ un-univ ⊢F ▹ un-univ ⊢G) ⊢A ⊢e ⊢t)
castΠRed* ⊢F ⊢G ⊢e ⊢t ((univ d) ⇨ D) = cast-Π-subst (un-univ ⊢F) (un-univ ⊢G) d ⊢e ⊢t ⇨ conv* (castΠRed* ⊢F ⊢G (conv ⊢e (univ (Id-cong (refl (univ 0<1 (wf ⊢F))) (refl (Πⱼ ≡is≤ PE.refl ▹ ≡is≤ PE.refl ▹ un-univ ⊢F ▹ un-univ ⊢G)) (subsetTerm d)))) ⊢t D) (sym (subset (univ d)))

notredUterm* : ∀ {Γ r l l' A B} → Γ ⊢ Univ r l ⇒ A ∷ B ^ l' → ⊥
notredUterm* (conv D x) = notredUterm* D

notredU* : ∀ {Γ r l l' A} → Γ ⊢ Univ r l ⇒ A ^ [ ! , l' ] → ⊥
notredU* (univ x) = notredUterm* x

redU*gen : ∀ {Γ r l r' l' l''} → Γ ⊢ Univ r l ⇒* Univ r' l' ^ [ ! , l'' ] → Univ r l PE.≡ Univ r' l'
redU*gen (id x) = PE.refl
redU*gen (univ (conv x x₁) ⇨ D) = ⊥-elim (notredUterm* x)

-- Typing of Idsym

Idsymⱼ : ∀ {Γ A l x y e}
       → Γ ⊢ A ∷ U l ^ [ ! , next l ]
       → Γ ⊢ x ∷ A ^ [ ! , ι l ]
       → Γ ⊢ y ∷ A ^ [ ! , ι l ]
       → Γ ⊢ e ∷ Id A x y ^ [ % , ι l ]
       → Γ ⊢ Idsym A x y e ∷ Id A y x ^ [ % , ι l ]
Idsymⱼ {Γ} {A} {l} {x} {y} {e} ⊢A ⊢x ⊢y ⊢e =
  let
    ⊢Γ = wfTerm ⊢A
    ⊢A = univ ⊢A
    ⊢P : Γ ∙ A ^ [ ! , ι l ] ⊢ Id (wk1 A) (var 0) (wk1 x) ^ [ % , ι l ]
    ⊢P = univ (Idⱼ (Twk.wkTerm (Twk.step Twk.id) (⊢Γ ∙ ⊢A) (un-univ ⊢A))
      (var (⊢Γ ∙ ⊢A) here)
      (Twk.wkTerm (Twk.step Twk.id) (⊢Γ ∙ ⊢A) ⊢x))
    ⊢refl : Γ ⊢ Idrefl A x ∷ Id (wk1 A) (var 0) (wk1 x) [ x ] ^ [ % , ι l ]
    ⊢refl = PE.subst₂ (λ X Y → Γ ⊢ Idrefl A x ∷ Id X x Y ^ [ % , ι l ])
      (PE.sym (wk1-singleSubst A x)) (PE.sym (wk1-singleSubst x x))
      (Idreflⱼ ⊢x)
  in PE.subst₂ (λ X Y → Γ ⊢ Idsym A x y e ∷ Id X y Y ^ [ % , ι l ])
    (wk1-singleSubst A y) (wk1-singleSubst x y)
    (transpⱼ ⊢A ⊢P ⊢x ⊢refl ⊢y ⊢e)

▹▹ⱼ_▹_▹_▹_ : ∀ {Γ F rF lF G lG r l}
             → lF ≤ l
             → lG ≤ l
             → Γ ⊢ F ∷ (Univ rF lF) ^ [ ! , next lF ]
             → Γ ⊢ G ∷ (Univ r lG) ^ [ ! , next lG ]
             → Γ ⊢ F ^ rF ° lF ▹▹ G ° lG ° l ∷ (Univ r l) ^ [ ! , next l ]
▹▹ⱼ lF≤ ▹ lG≤ ▹ F ▹ G = Πⱼ lF≤ ▹ lG≤ ▹ F ▹ un-univ (Twk.wk (Twk.step Twk.id) ((wf (univ F)) ∙ (univ F)) (univ G))

××ⱼ_▹_ : ∀ {Γ F G l}
        → Γ ⊢ F ∷ SProp l ^ [ ! , next l ]
        → Γ ⊢ G ∷ SProp l ^ [ ! , next l ]
        → Γ ⊢ F ×× G ∷ SProp l ^ [ ! , next l ]
××ⱼ F ▹ G = ∃ⱼ F ▹ un-univ (Twk.wk (Twk.step Twk.id) ((wf (univ F)) ∙ (univ F)) (univ G))


------------------------------------------------------------------------
-- Soundness of normalization w.r.t. to declarative kinding of Fω with
-- interval kinds
------------------------------------------------------------------------

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

module FOmegaInt.Kinding.Declarative.Normalization where

open import Data.Fin using (zero)
open import Data.Fin.Substitution
open import Data.Product using (_,_; proj₂; _×_)
open import Data.Vec using ([])
open import Relation.Binary.PropositionalEquality hiding ([_])

open import FOmegaInt.Syntax
open import FOmegaInt.Syntax.HereditarySubstitution
open import FOmegaInt.Syntax.Normalization
open import FOmegaInt.Typing
open import FOmegaInt.Typing.Validity

open Syntax
open TermCtx
open Substitution hiding (subst)
open ContextConversions
open Typing
open TypedSubstitution

------------------------------------------------------------------------
-- Soundness of hereditary substitutions

-- NOTE. The following are corollaries of the corresponding soundness
-- lemmas using untyped β-reduction and the subject reduction property
-- for kinding (see the Syntax.HereditarySubstitution and
-- Typing.Validity modules for details).

-- Soundness of hereditary substitution: the results of ordinary and
-- hereditary substitutions in well-formed kinds resp. well-kinded
-- types are equal (w.r.t. type resp. kind equality).

kd-⌞⌟-[]-≅ : ∀ {n} {Γ : Ctx n} {j k a} →
             kd ⌞ j ⌟Kd ∷ Γ ⊢ ⌞ k ⌟Kd kd → Γ ⊢Tp ⌞ a ⌟ ∈ ⌞ j ⌟Kd →
             Γ ⊢ ⌞ k ⌟Kd Kind[ ⌞ a ⌟ ] ≅ ⌞ k Kind[ a ∈ ⌊ j ⌋ ] ⌟Kd
kd-⌞⌟-[]-≅ {k = k} ⌞k⌟-kd ⌞a⌟∈⌞j⌟ =
  kd-→β*-≅ (kd-[] ⌞k⌟-kd (∈-tp ⌞a⌟∈⌞j⌟)) (⌞⌟Kd-/⟨⟩-β k)

Tp∈-⌞⌟-[]-≃ : ∀ {n} {Γ : Ctx n} {j a k b} →
              kd ⌞ j ⌟Kd ∷ Γ ⊢Tp ⌞ a ⌟ ∈ ⌞ k ⌟Kd → Γ ⊢Tp ⌞ b ⌟ ∈ ⌞ j ⌟Kd →
              Γ ⊢ ⌞ a ⌟ [ ⌞ b ⌟ ] ≃ ⌞ a [ b ∈ ⌊ j ⌋ ] ⌟ ∈ ⌞ k ⌟Kd Kind[ ⌞ b ⌟ ]
Tp∈-⌞⌟-[]-≃ {a = a} ⌞a⌟∈⌞k⌟ ⌞b⌟∈⌞j⌟ =
  Tp∈-→β*-≃ (Tp∈-[] ⌞a⌟∈⌞k⌟ (∈-tp ⌞b⌟∈⌞j⌟)) (⌞⌟-/⟨⟩-β a)

-- Soundness of potentially reducing application: ordinary and
-- potentially reducing application of well-kinded types are equal
-- (w.r.t. type equality).
Tp∈-⌞⌟-·-≃ : ∀ {n} {Γ : Ctx n} {a b j k} →
             Γ ⊢Tp ⌞ a ⌟ ∈ Π j k → Γ ⊢Tp ⌞ b ⌟ ∈ j →
             Γ ⊢ ⌞ a ⌟ · ⌞ b ⌟ ≃ ⌞ a ↓⌜·⌝ b ⌟ ∈ k Kind[ ⌞ b ⌟ ]
Tp∈-⌞⌟-·-≃ {_} {_} {a} {b} {j} {k} ⌞a⌟∈Πjk ⌞b⌟∈j =
  Tp∈-→β*-≃ (∈-Π-e ⌞a⌟∈Πjk ⌞b⌟∈j) (⌞⌟-↓⌜·⌝-β a b)

------------------------------------------------------------------------
-- Soundness of η-expansion.

module TrackSimpleKindsDeclarativeEtaExp where
  open RenamingCommutes
  open SimpHSubstLemmas
  private
    module V   = VarSubst
    module TK  = TrackSimpleKindsEtaExp

  -- NOTE. The definition of the function Tp∈-⌞⌟-≃-η below is
  -- structurally recursive in the *shape* parameter k, but *not* in
  -- the kind j because we need to weaken the domain j₁ of the
  -- dependent kind (j = Π j₁ j₂) in the arrow case.  The additional
  -- hypothesis ⌊ j ⌋≡ k ensures that k is indeed the shape of the
  -- kind j.

  -- Well-kinded neutrals are equal to to their η-expansions.
  Tp∈-⌞⌟-≃-η : ∀ {n} {Γ : Ctx n} {x as j k} (hyp : ⌊ j ⌋≡ k) →
               Γ ⊢ ⌞ j ⌟Kd kd → Γ ⊢Tp ⌞ var x ∙ as ⌟ ∈ ⌞ j ⌟Kd →
               Γ ⊢ ⌞ var x ∙ as ⌟ ≃ ⌞ TK.η-exp j hyp (var x ∙ as) ⌟ ∈ ⌞ j ⌟Kd
  Tp∈-⌞⌟-≃-η is-★ ⌞b₂⋯c₂⌟-kd ⌞x∙as⌟∈⌞b₁⋯c₁⌟ = ≃-refl ⌞x∙as⌟∈⌞b₁⋯c₁⌟
  Tp∈-⌞⌟-≃-η {_} {Γ} {x} {as} (is-⇒ {j₁} {j₂} ⌊j₁⌋≡k₁ ⌊j₂⌋≡k₂)
             (kd-Π ⌞j₁⌟-kd ⌞j₂⌟-kd) ⌞x∙as⌟∈⌞Πj₁j₂⌟ =
    begin
      ⌞ var x ∙ as ⌟
    ≃⟨ ≃-sym (≃-η ⌞x∙as⌟∈⌞Πj₁j₂⌟) ⟩
      Λ ⌞ j₁ ⌟Kd (weaken ⌞ var x ∙ as ⌟ · var zero)
    ≃⟨ ≃-λ′ (≅-refl ⌞j₁⌟-kd) (begin
        weaken ⌞ var x ∙ as ⌟ · var zero
      ≃⟨ ⌞x∙as⌟·z≃⌞x∙as⌟·⌞η-z⌟∈⌞j₂⌟ ⟩
        weaken ⌞ var x ∙ as ⌟ ·
          ⌞ TK.η-exp (weakenKind′ _) (⌊⌋≡-weaken ⌊j₁⌋≡k₁) (var∙ zero) ⌟
      ≡⟨ ⌞x∙as⌟·⌞η-z⌟≡⌞x∙as⌜·⌝η-z⌟ ⟩
        ⌞ weakenElim (var x ∙ as) ⌜·⌝
          TK.η-exp (weakenKind′ _) (⌊⌋≡-weaken ⌊j₁⌋≡k₁) (var∙ zero) ⌟
      ≃⟨ Tp∈-⌞⌟-≃-η ⌊j₂⌋≡k₂ ⌞j₂⌟-kd
                    (subst (_ ⊢Tp_∈ _) ⌞x∙as⌟·⌞η-z⌟≡⌞x∙as⌜·⌝η-z⌟
                           ⌞x∙as⌟·⌞η-z⌟∈⌞j₂⌟) ⟩
        ⌞ TK.η-exp j₂ ⌊j₂⌋≡k₂ _ ⌟
      ∎) ⟩
      ⌞ TK.η-exp (Π j₁ j₂) (is-⇒ ⌊j₁⌋≡k₁ ⌊j₂⌋≡k₂) (var x ∙ as) ⌟
    ∎
    where
      ⌞j₁⌟-wf     = wf-kd ⌞j₁⌟-kd
      ⌞j₁⌟′-kd    = kd-weaken ⌞j₁⌟-wf ⌞j₁⌟-kd
      ⌞j₁⌟′≡⌞j₁′⌟ = sym (⌞⌟Kd-/Var j₁)
      ⌞j₁′⌟-kd    = subst (kd ⌞ j₁ ⌟Kd ∷ _ ⊢_kd) ⌞j₁⌟′≡⌞j₁′⌟ ⌞j₁⌟′-kd
      ⌞j₁⌟∷Γ-ctx  = ⌞j₁⌟-wf ∷ Tp∈-ctx ⌞x∙as⌟∈⌞Πj₁j₂⌟

      ⌞x∙as⌟′∈⌞Πj₁j₂′⌟ = subst (kd ⌞ j₁ ⌟Kd ∷ Γ ⊢Tp weaken ⌞ var x ∙ as ⌟ ∈_)
                               (sym (⌞⌟Kd-/Var (Π j₁ j₂)))
                               (Tp∈-weaken ⌞j₁⌟-wf ⌞x∙as⌟∈⌞Πj₁j₂⌟)

      z∈⌞j₁⌟      = ∈-var zero ⌞j₁⌟∷Γ-ctx (cong kd ⌞j₁⌟′≡⌞j₁′⌟ )
      z≃η-z∈⌞j₁⌟  = Tp∈-⌞⌟-≃-η (⌊⌋≡-weaken ⌊j₁⌋≡k₁) ⌞j₁′⌟-kd z∈⌞j₁⌟
      ⌞j₂′⌟[z]≡⌞j₂⌟ =
        begin
          ⌞ j₂ Kind′/Var V.wk V.↑ ⌟Kd Kind[ var zero ]
        ≡⟨ cong (_Kind[ var zero ]) (⌞⌟Kd-/Var j₂) ⟩
          (⌞ j₂ ⌟Kd Kind/Var V.wk V.↑) Kind[ var zero ]
        ≡⟨ Kind-wk↑-sub-zero-vanishes ⌞ j₂ ⌟Kd ⟩
          ⌞ j₂ ⌟Kd
        ∎
        where open ≡-Reasoning

      ⌞x∙as⌟·z≃⌞x∙as⌟·⌞η-z⌟∈⌞j₂⌟ =
        subst (_ ⊢ _ ≃ _ ∈_) ⌞j₂′⌟[z]≡⌞j₂⌟
              (≃-· (≃-refl (⌞x∙as⌟′∈⌞Πj₁j₂′⌟)) z≃η-z∈⌞j₁⌟)
      ⌞x∙as⌟·⌞η-z⌟∈⌞j₂⌟ = proj₂ (≃-valid ⌞x∙as⌟·z≃⌞x∙as⌟·⌞η-z⌟∈⌞j₂⌟)
      ⌞x∙as⌟·⌞η-z⌟≡⌞x∙as⌜·⌝η-z⌟ =
        begin
          weaken ⌞ var x ∙ as ⌟ ·
            ⌞ TK.η-exp (weakenKind′ _) (⌊⌋≡-weaken ⌊j₁⌋≡k₁) (var∙ zero) ⌟
        ≡⟨ cong (_· _) (sym (⌞⌟-/Var (var x ∙ as)))  ⟩
          ⌞ weakenElim (var x ∙ as) ⌟ ·
            ⌞ TK.η-exp (weakenKind′ _) (⌊⌋≡-weaken ⌊j₁⌋≡k₁) (var∙ zero) ⌟
        ≡⟨ sym (⌞⌟-· (weakenElim (var x ∙ as)) _) ⟩
          ⌞ weakenElim (var x ∙ as) ⌜·⌝
            TK.η-exp (weakenKind′ _) (⌊⌋≡-weaken ⌊j₁⌋≡k₁) (var∙ zero) ⌟
        ∎
        where open ≡-Reasoning

      open ≃-Reasoning

private module TK  = TrackSimpleKindsDeclarativeEtaExp

-- Soundness of η-expansion of neutrals: well-kinded neutral types are
-- equal to their η-expansions (w.r.t. to type equality).
Tp∈-⌞⌟-≃-η : ∀ {n} {Γ : Ctx n} {x as k} →
             Γ ⊢Tp ⌞ var x ∙ as ⌟ ∈ ⌞ k ⌟Kd →
             Γ ⊢ ⌞ var x ∙ as ⌟ ≃ ⌞ η-exp k (var x ∙ as) ⌟ ∈ ⌞ k ⌟Kd
Tp∈-⌞⌟-≃-η ⌞x∙as⌟∈⌞k⌟ =
  TK.Tp∈-⌞⌟-≃-η (⌊⌋-⌊⌋≡ _) (Tp∈-valid ⌞x∙as⌟∈⌞k⌟) ⌞x∙as⌟∈⌞k⌟

------------------------------------------------------------------------
-- Soundness of normalization

mutual

  -- Soundness of normalization: well-formed kinds and well-kinded
  -- types are equal to their normal forms (w.r.t. to kind resp. type
  -- equality).

  Tp∈-≃-⌞⌟-nf : ∀ {n} {Γ : Ctx n} {a k} →
                Γ ⊢Tp a ∈ k → Γ ⊢ a ≃ ⌞ nf (nfCtx Γ) a ⌟ ∈ k
  Tp∈-≃-⌞⌟-nf {_} {Γ} (∈-var {k} x Γ-ctx Γ[x]≡kd-k)
    with ElimCtx.lookup (nfCtx Γ) x | nfCtx-lookup-kd x Γ Γ[x]≡kd-k
  ... | kd ._ | refl =
    ≃-⇑ (Tp∈-⌞⌟-≃-η (∈-⇑ (∈-var x Γ-ctx Γ[x]≡kd-k) (≅⇒<∷ k≅⌞nf-k⌟)))
        (≅⇒<∷ (≅-sym k≅⌞nf-k⌟))
    where
      open ≡-Reasoning
      open CtxEqOps using (lookup-≃-kd)

      Γ≃⌞nf-Γ⌟         = ctx-≃-⌞⌟-nf Γ-ctx
      ⌞nf-Γ⌟[x]≡kd-⌞k⌟ = begin
          lookup ⌞ nfCtx Γ ⌟Ctx x
        ≡⟨ ⌞⌟Asc-lookup (nfCtx Γ) x ⟩
          ⌞ ElimCtx.lookup (nfCtx Γ) x ⌟Asc
        ≡⟨ cong ⌞_⌟Asc (nfCtx-lookup-kd x Γ Γ[x]≡kd-k) ⟩
          kd ⌞ nfKind (nfCtx Γ) k ⌟Kd
        ∎

      k≅⌞nf-k⌟ : Γ ⊢ k ≅ ⌞ nfKind (nfCtx Γ) k ⌟Kd
      k≅⌞nf-k⌟ = lookup-≃-kd x Γ≃⌞nf-Γ⌟ Γ[x]≡kd-k ⌞nf-Γ⌟[x]≡kd-⌞k⌟
  Tp∈-≃-⌞⌟-nf (∈-⊥-f Γ-ctx) = ≃-refl (∈-⊥-f Γ-ctx)
  Tp∈-≃-⌞⌟-nf (∈-⊤-f Γ-ctx) = ≃-refl (∈-⊤-f Γ-ctx)
  Tp∈-≃-⌞⌟-nf (∈-∀-f k-kd a∈*) = ≃-∀ (kd-≅-⌞⌟-nf k-kd) (Tp∈-≃-⌞⌟-nf a∈*)
  Tp∈-≃-⌞⌟-nf (∈-→-f a∈* b∈*)  = ≃-→ (Tp∈-≃-⌞⌟-nf a∈*) (Tp∈-≃-⌞⌟-nf b∈*)
  Tp∈-≃-⌞⌟-nf (∈-Π-i j-kd a∈k) = ≃-λ′ (kd-≅-⌞⌟-nf j-kd) (Tp∈-≃-⌞⌟-nf a∈k)
  Tp∈-≃-⌞⌟-nf {_} {Γ} (∈-Π-e {a} {b} {j} {k} a∈Πjk b∈j) with Tp∈-valid a∈Πjk
  ... | (kd-Π j-kd k-kd) =
    begin
      a · b
    ≃⟨ ≃-· a≃⌞nf-a⌟∈Πjk b≃⌞nf-b⌟∈j ⟩
      ⌞ nf (nfCtx Γ) a ⌟ · ⌞ nf (nfCtx Γ) b ⌟
    ≃⟨ ≃-⇑ (Tp∈-⌞⌟-·-≃ {a = nf (nfCtx Γ) a} {nf (nfCtx Γ) b}
                       ⌞nf-a⌟∈Πjk ⌞nf-b⌟∈j)
           (≅⇒<∷ (≅-sym (kd-[≃] k-kd b≃⌞nf-b⌟∈j))) ⟩
      ⌞ nf (nfCtx Γ) a ↓⌜·⌝ nf (nfCtx Γ) b ⌟
    ∎
    where
      open ≃-Reasoning

      a≃⌞nf-a⌟∈Πjk = Tp∈-≃-⌞⌟-nf a∈Πjk
      ⌞nf-a⌟∈Πjk   = proj₂ (≃-valid a≃⌞nf-a⌟∈Πjk)

      b≃⌞nf-b⌟∈j = Tp∈-≃-⌞⌟-nf b∈j
      ⌞nf-b⌟∈j   = proj₂ (≃-valid b≃⌞nf-b⌟∈j)
  Tp∈-≃-⌞⌟-nf (∈-s-i a∈b⋯c)  = ≃-s-i (Tp∈-≃-⌞⌟-nf a∈b⋯c)
  Tp∈-≃-⌞⌟-nf (∈-⇑ a∈j j<∷k) = ≃-⇑ (Tp∈-≃-⌞⌟-nf a∈j) j<∷k

  kd-≅-⌞⌟-nf : ∀ {n} {Γ : Ctx n} {k} →
               Γ ⊢ k kd → Γ ⊢ k ≅ ⌞ nfKind (nfCtx Γ) k ⌟Kd
  kd-≅-⌞⌟-nf (kd-⋯ a∈* b∈*)   = ≅-⋯ (Tp∈-≃-⌞⌟-nf a∈* ) (Tp∈-≃-⌞⌟-nf b∈*)
  kd-≅-⌞⌟-nf (kd-Π j-kd k-kd) = ≅-Π (kd-≅-⌞⌟-nf j-kd) (kd-≅-⌞⌟-nf k-kd)

  -- Well-formed ascriptions and contexts are equal to their normal
  -- forms.

  wf-≃-⌞⌟-nf : ∀ {n} {Γ : Ctx n} {a} →
               Γ ⊢ a wf → Γ ⊢ a ≃ ⌞ nfAsc (nfCtx Γ) a ⌟Asc wf
  wf-≃-⌞⌟-nf (wf-kd k-kd) = ≃wf-≅ (kd-≅-⌞⌟-nf k-kd)
  wf-≃-⌞⌟-nf (wf-tp a∈*)  = ≃wf-≃ (Tp∈-≃-⌞⌟-nf a∈*)

  ctx-≃-⌞⌟-nf : ∀ {n} {Γ : Ctx n} → Γ ctx → Γ ≃ ⌞ nfCtx Γ ⌟Ctx ctx
  ctx-≃-⌞⌟-nf []             = ≃-[]
  ctx-≃-⌞⌟-nf (a-wf ∷ Γ-ctx) = ≃-∷ (wf-≃-⌞⌟-nf a-wf) (ctx-≃-⌞⌟-nf Γ-ctx)

-- Some corollaries.

-- The domain and co-domain of universal types are equal to their
-- normal forms.
Tp∈-∀-≃-⌞⌟-nf : ∀ {n} {Γ : Ctx n} {k a} → Γ ⊢Tp Π k a ∈ * →
                Γ ⊢ k ≅ ⌞ nfKind (nfCtx Γ) k ⌟Kd ×
                  kd k ∷ Γ ⊢ a ≃ ⌞ nf (nfCtx (kd k ∷ Γ)) a ⌟ ∈ *
Tp∈-∀-≃-⌞⌟-nf ∀ka∈* with Tp∈-∀-inv ∀ka∈*
... | k-kd , a∈* = kd-≅-⌞⌟-nf k-kd , Tp∈-≃-⌞⌟-nf a∈*

-- The domain and co-domain of arrow types are equal to their normal
-- forms.
Tp∈-→-≃-⌞⌟-nf : ∀ {n} {Γ : Ctx n} {a b} → Γ ⊢Tp a ⇒ b ∈ * →
                Γ ⊢ a ≃ ⌞ nf (nfCtx Γ) a ⌟ ∈ * × Γ ⊢ b ≃ ⌞ nf (nfCtx Γ) b ⌟ ∈ *
Tp∈-→-≃-⌞⌟-nf a⇒b∈* with Tp∈-→-inv a⇒b∈*
... | a∈* , b∈* = Tp∈-≃-⌞⌟-nf a∈* , Tp∈-≃-⌞⌟-nf b∈*


{-# OPTIONS --safe --without-K #-}
open import Generics.Prelude
open import Generics.Telescope
open import Generics.Desc
open import Agda.Builtin.Reflection

module Generics.Helpers
         P I
         {levelArgRel : Level → Level}
         (ArgRel      : ∀ {a} → Set a → Set (levelArgRel a))
         {levelArgIrr : Level → Level}
         (ArgIrr      : ∀ {a} → Set a → Set (levelArgIrr a))
         (Ind         : ∀ {V} (C : ConDesc P V I) → Setω)
         where

  data ConHelper p {V} : ConDesc P V I → Setω where
    instance var    : ∀ {f} → ConHelper p (var f)
             pi-irr : ∀ {ℓ n v q}
                      {S : ⟦ P , V ⟧xtel → Set ℓ}
                      (let ai = n , arg-info v (modality irrelevant q))
                      {C : ConDesc P (V ⊢< ai > S) I}
                    → ⦃ ∀ {v} → ArgIrr (S (p , v)) ⦄
                    → ⦃ ConHelper p C              ⦄
                    → ConHelper p (π ai S C)
             pi-rel : ∀ {ℓ n v q}
                      {S : ⟦ P , V ⟧xtel → Set ℓ}
                      (let ai = n , arg-info v (modality relevant q))
                      {C : ConDesc P (V ⊢< ai > S) I}
                    → ⦃ ∀ {v} → ArgRel (S (p , v)) ⦄
                    → ⦃ ConHelper p C              ⦄
                    → ConHelper p (π ai S C)
             prod   : {A B : ConDesc P V I}
                    → ⦃ Ind A         ⦄
                    → ⦃ ConHelper p B ⦄
                    → ConHelper p (A ⊗ B)

  data Helpers p : {n : ℕ} → DataDesc P I n → Setω where
    instance nil  : Helpers p []
             cons : ∀ {n} {C : ConDesc  P ε I}
                          {D : DataDesc P I n}
                  → ⦃ ConHelper p C ⦄
                  → ⦃ Helpers p D   ⦄
                  → Helpers p (C ∷ D)

  lookupHelper : ∀ {n} {D : DataDesc P I n} {p}
                 (HD : Helpers p D) (k : Fin n)
               → ConHelper p (lookupCon D k)
  lookupHelper (cons ⦃ HC ⦄ ⦃ HD ⦄) zero    = HC
  lookupHelper (cons ⦃ HC ⦄ ⦃ HD ⦄) (suc k) = lookupHelper HD k


open import Oscar.Prelude
open import Oscar.Class
open import Oscar.Class.Surjection
open import Oscar.Class.Smap
open import Oscar.Class.Transitivity

module Oscar.Class.Surjtranscommutativity where

module Surjtranscommutativity
  {𝔬₁} {𝔒₁ : Ø 𝔬₁}
  {𝔯₁} (_∼₁_ : 𝔒₁ → 𝔒₁ → Ø 𝔯₁)
  {𝔬₂} {𝔒₂ : Ø 𝔬₂}
  {𝔯₂} (_∼₂_ : 𝔒₂ → 𝔒₂ → Ø 𝔯₂)
  {ℓ₂} (_∼̇₂_ : ∀ {x y} → x ∼₂ y → x ∼₂ y → Ø ℓ₂) (let infix 4 _∼̇₂_ ; _∼̇₂_ = _∼̇₂_)
  {surjection : Surjection.type 𝔒₁ 𝔒₂}
  (smap : Smap.type _∼₁_ _∼₂_ surjection surjection)
  (transitivity₁ : Transitivity.type _∼₁_)
  (let infixr 9 _∙₁_
       _∙₁_ : FlipTransitivity.type _∼₁_
       _∙₁_ g f = transitivity₁ f g)
  (transitivity₂ : Transitivity.type _∼₂_)
  (let infixr 9 _∙₂_
       _∙₂_ : FlipTransitivity.type _∼₂_
       _∙₂_ g f = transitivity₂ f g)
  = ℭLASS (_∼₁_ ,, _∼₂_ ,, (λ {x y} → _∼̇₂_ {x} {y}) ,, surjection ,, (λ {x y} → smap {x} {y}) ,, (λ {x y z} → transitivity₁ {x} {y} {z}) ,, (λ {x y z} → transitivity₂ {x} {y} {z})) (∀ {x y z} (f : x ∼₁ y) (g : y ∼₁ z) → smap (g ∙₁ f) ∼̇₂ smap g ∙₂ smap f)

module Surjtranscommutativity!
  {𝔬₁} {𝔒₁ : Ø 𝔬₁}
  {𝔯₁} (_∼₁_ : 𝔒₁ → 𝔒₁ → Ø 𝔯₁)
  {𝔬₂} {𝔒₂ : Ø 𝔬₂}
  {𝔯₂} (_∼₂_ : 𝔒₂ → 𝔒₂ → Ø 𝔯₂)
  {ℓ₂} (_∼̇₂_ : ∀ {x y} → x ∼₂ y → x ∼₂ y → Ø ℓ₂) (let infix 4 _∼̇₂_ ; _∼̇₂_ = _∼̇₂_)
  ⦃ I1 : Surjection.class 𝔒₁ 𝔒₂ ⦄
  ⦃ I2 : Smap!.class _∼₁_ _∼₂_ ⦄
  ⦃ I3 : Transitivity.class _∼₁_ ⦄
  ⦃ I4 : Transitivity.class _∼₂_ ⦄
  = Surjtranscommutativity (_∼₁_) (_∼₂_) (λ {x y} → _∼̇₂_ {x} {y}) smap transitivity transitivity

module _
  {𝔬₁} {𝔒₁ : Ø 𝔬₁}
  {𝔯₁} {_∼₁_ : 𝔒₁ → 𝔒₁ → Ø 𝔯₁}
  {𝔬₂} {𝔒₂ : Ø 𝔬₂}
  {𝔯₂} {_∼₂_ : 𝔒₂ → 𝔒₂ → Ø 𝔯₂}
  {ℓ₂} {_∼̇₂_ : ∀ {x y} → x ∼₂ y → x ∼₂ y → Ø ℓ₂}
  {surjection : Surjection.type 𝔒₁ 𝔒₂}
  {smap : Smap.type _∼₁_ _∼₂_ surjection surjection}
  {transitivity₁ : Transitivity.type _∼₁_}
  {transitivity₂ : Transitivity.type _∼₂_}
  where
  surjtranscommutativity = Surjtranscommutativity.method _∼₁_ _∼₂_ _∼̇₂_ smap transitivity₁ transitivity₂
  ⟪∙⟫-surjtranscommutativity-syntax = surjtranscommutativity
  syntax ⟪∙⟫-surjtranscommutativity-syntax f g = g ⟪∙⟫ f

module _
  {𝔬₁} {𝔒₁ : Ø 𝔬₁}
  {𝔯₁} {_∼₁_ : 𝔒₁ → 𝔒₁ → Ø 𝔯₁}
  {𝔬₂} {𝔒₂ : Ø 𝔬₂}
  {𝔯₂} {_∼₂_ : 𝔒₂ → 𝔒₂ → Ø 𝔯₂}
  {ℓ₂} {_∼̇₂_ : ∀ {x y} → x ∼₂ y → x ∼₂ y → Ø ℓ₂}
  ⦃ _ : Surjection.class 𝔒₁ 𝔒₂ ⦄
  ⦃ _ : Smap!.class _∼₁_ _∼₂_ ⦄
  ⦃ _ : Transitivity.class _∼₁_ ⦄
  ⦃ _ : Transitivity.class _∼₂_ ⦄
  where
  surjtranscommutativity! = Surjtranscommutativity!.method _∼₁_ _∼₂_ _∼̇₂_ ⦃ ! ⦄ ⦃ ! ⦄ ⦃ ! ⦄ ⦃ ! ⦄
  ⟪∙⟫!-surjtranscommutativity-syntax = surjtranscommutativity!
  syntax ⟪∙⟫!-surjtranscommutativity-syntax f g = g ⟪∙⟫! f

module _
  {𝔬₁} {𝔒₁ : Ø 𝔬₁}
  {𝔯₁} {_∼₁_ : 𝔒₁ → 𝔒₁ → Ø 𝔯₁}
  {𝔬₂} {𝔒₂ : Ø 𝔬₂}
  {𝔯₂} {_∼₂_ : 𝔒₂ → 𝔒₂ → Ø 𝔯₂}
  {ℓ₂} (_∼̇₂_ : ∀ {x y} → x ∼₂ y → x ∼₂ y → Ø ℓ₂)
  {surjection : Surjection.type 𝔒₁ 𝔒₂}
  {smap : Smap.type _∼₁_ _∼₂_ surjection surjection}
  {transitivity₁ : Transitivity.type _∼₁_}
  {transitivity₂ : Transitivity.type _∼₂_}
  where
  surjtranscommutativity[_] = Surjtranscommutativity.method _∼₁_ _∼₂_ _∼̇₂_ smap transitivity₁ transitivity₂
  ⟪∙⟫-surjtranscommutativity[]-syntax = surjtranscommutativity[_]
  syntax ⟪∙⟫-surjtranscommutativity[]-syntax t f g = g ⟪∙⟫[ t ] f

module _
  {𝔬₁} {𝔒₁ : Ø 𝔬₁}
  {𝔯₁} {_∼₁_ : 𝔒₁ → 𝔒₁ → Ø 𝔯₁}
  {𝔬₂} {𝔒₂ : Ø 𝔬₂}
  {𝔯₂} {_∼₂_ : 𝔒₂ → 𝔒₂ → Ø 𝔯₂}
  {ℓ₂} (_∼̇₂_ : ∀ {x y} → x ∼₂ y → x ∼₂ y → Ø ℓ₂)
  ⦃ _ : Surjection.class 𝔒₁ 𝔒₂ ⦄
  ⦃ _ : Smap!.class _∼₁_ _∼₂_ ⦄
  ⦃ _ : Transitivity.class _∼₁_ ⦄
  ⦃ _ : Transitivity.class _∼₂_ ⦄
  where
  surjtranscommutativity![_] = Surjtranscommutativity!.method _∼₁_ _∼₂_ _∼̇₂_ ⦃ ! ⦄ ⦃ ! ⦄ ⦃ ! ⦄ ⦃ ! ⦄
  ⟪∙⟫!-surjtranscommutativity[]-syntax = surjtranscommutativity![_]
  syntax ⟪∙⟫!-surjtranscommutativity[]-syntax t f g = g ⟪∙⟫![ t ] f


{-# OPTIONS --experimental-irrelevance #-}

-- Andreas, 2015-05-18  Irrelevant module parameters
-- should not be resurrected in module body.

postulate
  A : Set

module M .(a : A) where

  bad : (..(_ : A) -> Set) -> Set
  bad f = f a
    -- SHOULD FAIL: variable a is declared irrelevant,
    -- so it cannot be used here.

-- This fails of course:
-- fail : .(a : A) -> (..(_ : A) -> Set) -> Set
-- fail a f = f a


open import Prelude
open import Data.List.Properties
open import Data.List.Any hiding (map)
open import Data.List.All as All hiding (map; lookup)
open import Data.Vec
open import Extensions.Vec

module Implicits.Resolution.Deterministic.Semantics where

open import Implicits.Syntax
open import Implicits.Resolution.Deterministic.Resolution
open import Implicits.Substitutions
open import Implicits.Substitutions.Lemmas
open import Implicits.Semantics
open import Implicits.Semantics.Lemmas
open import Extensions.ListFirst

open import SystemF.Everything as F using ()

module DerivationSemantics where

  ⟦_,_⟧r : ∀ {ν n} {K : Ktx ν n} {a} → (proj₂ K) ⊢ᵣ a → K# K →
           ∃ λ t → ⟦ proj₁ K ⟧ctx→ F.⊢ t ∈ ⟦ a ⟧tp→
  ⟦_,_⟧r {K = K} (r-simp {ρ = r} r∈Δ r↓τ) m with ∈⟶index (All.lookup m (proj₁ $ first⟶∈ r∈Δ))
  ⟦_,_⟧r {K = K} (r-simp {ρ = r} r∈Δ r↓τ) m | i , lookup-i≡r =
    ⟦ subst (λ u → _ F.⊢ F.var i ∈ u) eq (F.var i) , r↓τ , m ⟧r↓
    where
      eq = begin
        lookup i ⟦ proj₁ K ⟧ctx→
          ≡⟨ sym $ lookup-⟦⟧ctx→ (proj₁ K) i ⟩
        ⟦ lookup i (proj₁ K) ⟧tp→
            ≡⟨ cong ⟦_⟧tp→ lookup-i≡r ⟩
        ⟦ r ⟧tp→ ∎

      ⟦_,_,_⟧r↓ : ∀ {ν n} {K : Ktx ν n} {a ta τ} →
                ⟦ proj₁ K ⟧ctx→ F.⊢ ta ∈ ⟦ a ⟧tp→ → (proj₂ K) ⊢ a ↓ τ → K# K →
                ∃ λ tτ → ⟦ proj₁ K ⟧ctx→ F.⊢ tτ ∈ ⟦ simpl τ ⟧tp→
      ⟦ ⊢ta , i-simp τ , m ⟧r↓ = , ⊢ta
      ⟦ ⊢ta , i-iabs {ρ₁ = a} ⊢ᵣa b↓τ , m ⟧r↓ =
        , (proj₂ ⟦ ⊢ta F.· (proj₂ ⟦ ⊢ᵣa , m ⟧r) , b↓τ , m ⟧r↓)
      ⟦ ⊢ta , i-tabs {ρ = a} b p , m ⟧r↓ =
        ⟦ subst (λ u → _ F.⊢ _ ∈ u) (sym $ ⟦a/sub⟧tp→ a b) (⊢ta F.[ ⟦ b ⟧tp→ ]) , p , m ⟧r↓

  ⟦ r-iabs a {ρ₂ = b} ⊢b , m ⟧r = , F.λ' ⟦ a ⟧tp→ (proj₂ ⟦ ⊢b , #ivar a m ⟧r)

  ⟦_,_⟧r {K = K} (r-tabs {ρ = r} p) m with ⟦ p , #tvar m ⟧r
  ⟦_,_⟧r {K = K} (r-tabs {ρ = r} p) m | _ , x =
    , F.Λ (subst (λ u → u F.⊢ _ ∈ ⟦ r ⟧tp→) (⟦weaken⟧ctx→ (proj₁ K)) x)

open Semantics _⊢ᵣ_ DerivationSemantics.⟦_,_⟧r public


{- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9.

   Copyright (c) 2020, 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}
open import LibraBFT.Prelude
open import LibraBFT.Lemmas
open import LibraBFT.Base.Types
open import LibraBFT.Impl.Base.Types
open import LibraBFT.Abstract.Types.EpochConfig UID NodeId
open        WithAbsVote

module LibraBFT.Concrete.Obligations.PreferredRound
  (𝓔 : EpochConfig)
  (𝓥 : VoteEvidence 𝓔)
  where
 open import LibraBFT.Abstract.Abstract UID _≟UID_ NodeId 𝓔 𝓥
 open import LibraBFT.Concrete.Intermediate               𝓔 𝓥

 ---------------------
 -- * PreferredRound * --
 ---------------------

 module _ {ℓ}(𝓢 : IntermediateSystemState ℓ) where
  open IntermediateSystemState 𝓢

 -- The PreferredRound rule is a little more involved to be expressed in terms
 -- of /HasBeenSent/: it needs two additional pieces which are introduced
 -- next.

 -- Cand-3-chain v carries the information for estabilishing
 -- that v.proposed will be part of a 3-chain if a QC containing v is formed.
 -- The difficulty is that we can't easily access the "grandparent" of a vote.
 -- Instead, we must explicitly state that it exists.
 --
 --                                candidate 3-chain
 --       +------------------------------------------------------+
 --       |                                                      |
 --       |       2-chain                                        |
 --       +----------------------------------+
 --  ⋯ <- v.grandparent <- q₁ <- v.parent <- q <- v.proposed  <- v
 --                                          ̭
 --                                          |
 --                                     The 'qc' defined below is an
 --                                     abstract view of q, above.
  record voteExtends (v : Vote) : Set where
    constructor mkVE
    field
      veBlock   : Block
      veId      : vBlockUID v ≡ bId    veBlock
      veRounds≡ : vRound    v ≡ bRound veBlock
  open voteExtends

  record Cand-3-chain-vote (v : Vote) : Set where
    field
      votesForB : voteExtends v
      qc        : QC
      qc←b      : Q qc ← B (veBlock votesForB)
      rc        : RecordChain (Q qc)
      n         : ℕ
      is-2chain : 𝕂-chain Contig (2 + n) rc
  open Cand-3-chain-vote public

  -- Returns the round of the head of the candidate 3-chain. In the diagram
  -- explaining Cand-3-chain-vote, this would be v.grandparent.round.
  Cand-3-chain-head-round : ∀{v} → Cand-3-chain-vote v → Round
  Cand-3-chain-head-round c3cand =
    getRound (kchainBlock (suc zero) (is-2chain c3cand))

  -- The preferred round rule states a fact about the /previous round/
  -- of a vote; that is, the round of the parent of the block
  -- being voted for; the implementation will have to
  -- show it can construct this parent.
  data VoteParentData-BlockExt : Record → Set where
    vpParent≡I : VoteParentData-BlockExt I
    vpParent≡Q : ∀{b q} → B b ← Q q → VoteParentData-BlockExt (Q q)

  -- TODO-2: it may be cleaner to specify this as a RC 2 vpParent vpQC,
  -- and we should consider it once we address the issue in
  -- Abstract.RecordChain (below the definition of transp-𝕂-chain)

  record VoteParentData (v : Vote) : Set where
    field
      vpExt        : voteExtends v
      vpParent     : Record
      vpExt'       : vpParent ← B (veBlock vpExt)
      vpMaybeBlock : VoteParentData-BlockExt vpParent
  open VoteParentData public

  -- The setup for PreferredRoundRule is like thta for VotesOnce.
  -- Given two votes by an honest author α:
  Type : Set ℓ
  Type = ∀{α v v'}
       → Meta-Honest-Member α
       → vMember v  ≡ α → HasBeenSent v
       → vMember v' ≡ α → HasBeenSent v'
       -- If v is a vote on a candidate 3-chain, that is, is a vote on a block
       -- that extends a 2-chain,
       → (c2 : Cand-3-chain-vote v)
       -- and the round of v is lower than that of v',
       → vRound v < vRound v'
       ------------------------------
       -- then α obeyed the preferred round rule:
       → Σ (VoteParentData v')
           (λ vp → Cand-3-chain-head-round c2 ≤ round (vpParent vp))

  private
   make-cand-3-chain : ∀{n α q}{rc : RecordChain (Q q)}
                     → (c3 : 𝕂-chain Contig (3 + n) rc)
                     → (v  : α ∈QC q)
                     → Cand-3-chain-vote (∈QC-Vote q v)
   make-cand-3-chain {q = q} (s-chain {suc (suc n)} {rc = rc} {b = b} ext₀@(Q←B h0 refl) _ ext₁@(B←Q h1 refl) c2) v
     with c2
   ...| (s-chain {q = q₀} _ _ _ (s-chain _ _ _ c))
       = record { votesForB = mkVE b (All-lookup (qVotes-C2 q) (Any-lookup-correct v))
                                      (trans (All-lookup (qVotes-C3 q) (Any-lookup-correct v)) h1)
                ; qc = q₀
                ; qc←b = ext₀
                ; rc = rc
                ; n  = n
                ; is-2chain = c2
                }

   -- It is important that the make-cand-3-chain lemma doesn't change the head of
   -- the 3-chain/cand-2-chain.
   make-cand-3-chain-lemma
     : ∀{n α q}{rc : RecordChain (Q q)}
     → (c3 : 𝕂-chain Contig (3 + n) rc)
     → (v  : α ∈QC q)
     → NonInjective-≡ bId ⊎ kchainBlock (suc zero) (is-2chain (make-cand-3-chain c3 v)) ≡ kchainBlock (suc (suc zero)) c3
   make-cand-3-chain-lemma {q = q} c3@(s-chain {suc (suc n)} {rc = rc} {b = b} ext₀@(Q←B h0 refl) _ ext₁@(B←Q h1 refl) c2) v
     with (veBlock (Cand-3-chain-vote.votesForB (make-cand-3-chain c3 v))) ≟Block b
   ...| no neq = inj₁ ((veBlock (Cand-3-chain-vote.votesForB (make-cand-3-chain c3 v)) , b)
                      , neq
                      , trans (sym (veId (votesForB (make-cand-3-chain c3 v))))
                              (All-lookup (qVotes-C2 q) (∈QC-Vote-correct q v)))
   ...| yes b≡
     with c2
   ...| (s-chain {q = q₀} _ _ _ (s-chain _ _ _ c)) rewrite b≡ = inj₂ refl

   vdParent-prevRound-lemma
      : ∀{α q}(rc : RecordChain (Q q))(va : α ∈QC q)
      → (vp : VoteParentData (∈QC-Vote q va))
      → NonInjective-≡ bId ⊎ (round (vpParent vp) ≡ prevRound rc)
   vdParent-prevRound-lemma {q = q} (step {r = B b} (step rc y) x@(B←Q refl refl)) va vp
     with b ≟Block (veBlock (vpExt vp))
   ...| no imp = inj₁ ( (b , veBlock (vpExt vp))
                      , (imp , id-B∨Q-inj (cong id-B∨Q (trans (sym (All-lookup (qVotes-C2 q) (∈QC-Vote-correct q va)))
                                                               (veId (vpExt vp))))))
   ...| yes refl
     with ←-inj y (vpExt' vp)
   ...| bSameId'
     with y | vpExt' vp
   ...| I←B y0 y1   | I←B e0 e1   = inj₂ refl
   ...| Q←B y0 refl | Q←B e0 refl
     with vpMaybeBlock vp
   ...| vpParent≡Q {b = bP} bP←qP
     with rc
   ...| step {r = B b'} rc' b←q
     with b' ≟Block bP
   ...| no  imp = inj₁ ((b' , bP) , imp , id-B∨Q-inj (lemmaS1-2 (eq-Q refl) b←q bP←qP))
   ...| yes refl
     with bP←qP | b←q
   ...| B←Q refl refl | B←Q refl refl = inj₂ refl

  -- Finally, we can prove the preferred round rule from the global version;
  proof : Type → PreferredRoundRule InSys
  proof glob-inv α hα {q} {q'} q∈sys q'∈sys c3 va rc' va' hyp
    with ∈QC⇒HasBeenSent q∈sys  hα va
       | ∈QC⇒HasBeenSent q'∈sys hα va'
  ...| sent-cv | sent-cv'
    with make-cand-3-chain c3  va | inspect
        (make-cand-3-chain c3) va
  ...| cand | [ R ]
    with glob-inv hα
           (sym (∈QC-Member q  va )) sent-cv
           (sym (∈QC-Member q' va')) sent-cv'
           cand hyp
  ...| va'Par , res
    with vdParent-prevRound-lemma rc' va' va'Par
  ...| inj₁ hb    = inj₁ hb
  ...| inj₂ final
    with make-cand-3-chain-lemma c3 va
  ...| inj₁ hb = inj₁ hb
  ...| inj₂ xx = inj₂ (subst₂ _≤_
          (cong bRound (trans (cong (kchainBlock (suc zero) ∘ is-2chain) (sym R)) xx))
          final
          res)


-- Andreas, 2012-01-12
module Common.Irrelevance where

open import Common.Level

record Squash {a}(A : Set a) : Set a where
  constructor squash
  field
    .unsquash : A
open Squash public