{-# OPTIONS --safe #-}

open import Definition.Typed.EqualityRelation

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

open import Definition.Untyped
open import Definition.Untyped.Properties
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Typed.Weakening renaming (wk to TWwk)
open import Definition.LogicalRelation
open import Definition.LogicalRelation.Properties.Escape
open import Definition.LogicalRelation.ShapeView
open import Definition.LogicalRelation.Irrelevance
open import Definition.LogicalRelation.Properties.Conversion

open import Tools.Product
open import Tools.Empty
import Tools.PropositionalEquality as PE

import Data.Nat as Nat

mutual
  -- Helper function for transitivity of type equality using shape views.
  transEqT : ∀ {Γ A B C r l l′ l″}
             {[A] : Γ ⊩⟨ l ⟩ A ^ r} {[B] : Γ ⊩⟨ l′ ⟩ B ^ r} {[C] : Γ ⊩⟨ l″ ⟩ C ^ r}
           → ShapeView₃ Γ l l′ l″ A B C r r r [A] [B] [C]
           → Γ ⊩⟨ l ⟩  A ≡ B ^ r / [A]
           → Γ ⊩⟨ l′ ⟩ B ≡ C ^ r / [B]
           → Γ ⊩⟨ l ⟩  A ≡ C ^ r / [A]
  transEqT (Uᵥ UA UB UC) A≡B B≡C =
    let
      U≡U : Univ (LogRel._⊩¹U_^_.r UA) (LogRel._⊩¹U_^_.l′ UA) PE.≡ Univ (LogRel._⊩¹U_^_.r UB) (LogRel._⊩¹U_^_.l′ UB)
      U≡U = whrDet* (A≡B , Uₙ) ((_⊢_:⇒*:_^_.D (LogRel._⊩¹U_^_.d UB)) , Uₙ)
      r≡r , l≡l = Univ-PE-injectivity U≡U
    in
    PE.subst₂ (λ X Y → _ ⊢ _ ⇒* Univ X Y ^ [ ! , _ ]) (PE.sym r≡r) (PE.sym l≡l) B≡C
  transEqT (ℕᵥ D D′ D″) A≡B B≡C = B≡C
  transEqT (Emptyᵥ D D′ D″) A≡B B≡C = B≡C
  transEqT (ne (ne K [[ ⊢A , ⊢B , D ]] neK K≡K) (ne K₁ D₁ neK₁ _)
               (ne K₂ D₂ neK₂ _))
           (ne₌ M D′ neM K≡M) (ne₌ M₁ D″ neM₁ K≡M₁)
           rewrite whrDet* (red D₁ , ne neK₁) (red D′ , ne neM)
                 | whrDet* (red D₂ , ne neK₂) (red D″ , ne neM₁) =
    ne₌ M₁ D″ neM₁
        (~-trans K≡M K≡M₁)
  transEqT {Γ}  {r = [ r , ι lΠ ]} {l = l} {l′ = l′} {l″ = l″}
           (Πᵥ (Πᵣ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
               (Πᵣ rF₁ lF₁ lG₁ _ _ F₁ G₁ D₁ ⊢F₁ ⊢G₁ A≡A₁ [F]₁ [G]₁ G-ext₁)
               (Πᵣ rF₂ lF₂ lG₂ _ _ F₂ G₂ D₂ ⊢F₂ ⊢G₂ A≡A₂ [F]₂ [G]₂ G-ext₂))
           (Π₌ F′ G′ D′ A≡B [F≡F′] [G≡G′])
           (Π₌ F″ G″ D″ A≡B₁ [F≡F′]₁ [G≡G′]₁) =
    let ΠF₁G₁≡ΠF′G′    = whrDet* (red D₁ , Πₙ) (D′  , Πₙ)
        F₁≡F′ , rF₁≡rF′ , lF₁≡lF′ , G₁≡G′ , lG₁≡lG′ , _ = Π-PE-injectivity ΠF₁G₁≡ΠF′G′
        F₂≡F″ , rF₂≡rF′ , lF₂≡lF′ , G₂≡G″ , lG₂≡lG″  , _ = Π-PE-injectivity (whrDet* (red D₂ , Πₙ) (D″ , Πₙ))
        substLift {Δ} {l} {a} {r} ρ x = Δ ⊩⟨ l ⟩ wk (lift ρ) x [ a ] ^ r
        [F′] : ∀ {ρ Δ} [ρ] ⊢Δ → Δ ⊩⟨ l′ ⟩ wk ρ F′ ^ [ rF₁ , ι lF₁ ]
        [F′] {ρ} [ρ] ⊢Δ = PE.subst (λ x → _ ⊩⟨ _ ⟩ wk ρ x ^ _) F₁≡F′ ([F]₁ [ρ] ⊢Δ)
        [F″] : ∀ {ρ} {Δ} [ρ] ⊢Δ → Δ ⊩⟨ l″ ⟩ wk ρ F″ ^ [ rF₂ , ι lF₂ ]
        [F″] {ρ} [ρ] ⊢Δ = PE.subst (λ x → _ ⊩⟨ _ ⟩ wk ρ x ^ _) F₂≡F″ ([F]₂ [ρ] ⊢Δ)
        [F′≡F″] : ∀ {ρ} {Δ} [ρ] ⊢Δ → Δ ⊩⟨ l′ ⟩ wk ρ F′ ≡ wk ρ F″ ^ [ rF₁ , ι lF₁ ] / [F′] [ρ] ⊢Δ
        [F′≡F″] {ρ} [ρ] ⊢Δ = irrelevanceEq′ (PE.cong (wk ρ) F₁≡F′) PE.refl PE.refl
                                      ([F]₁ [ρ] ⊢Δ) ([F′] [ρ] ⊢Δ) ([F≡F′]₁ [ρ] ⊢Δ)
        [G′] : ∀ {ρ Δ a} [ρ] ⊢Δ
             → Δ ⊩⟨ l′ ⟩ a ∷ wk ρ F′ ^ [ rF₁ , ι lF₁ ] / [F′] [ρ] ⊢Δ
             → Δ ⊩⟨ l′ ⟩ wk (lift ρ) G′ [ a ] ^ [ r , ι lG₁ ]
        [G′] {ρ} [ρ] ⊢Δ [a] =
             let [a′] = irrelevanceTerm′ (PE.cong (wk ρ) (PE.sym F₁≡F′)) PE.refl PE.refl
                                      ([F′] [ρ] ⊢Δ) ([F]₁ [ρ] ⊢Δ) [a]
             in  PE.subst (substLift ρ) G₁≡G′ ([G]₁ [ρ] ⊢Δ [a′])
        [G″] : ∀ {ρ Δ a} [ρ] ⊢Δ
             → Δ ⊩⟨ l″ ⟩ a ∷ wk ρ F″ ^ [ rF₂ , ι lF₂ ] / [F″] [ρ] ⊢Δ
             → Δ ⊩⟨ l″ ⟩ wk (lift ρ) G″ [ a ] ^ [ r , ι lG₂ ]
        [G″] {ρ} [ρ] ⊢Δ [a] =
          let [a″] = irrelevanceTerm′ (PE.cong (wk ρ) (PE.sym F₂≡F″)) PE.refl PE.refl
                                      ([F″] [ρ] ⊢Δ) ([F]₂ [ρ] ⊢Δ) [a]
          in  PE.subst (substLift ρ) G₂≡G″ ([G]₂ [ρ] ⊢Δ [a″])
        [G′≡G″] : ∀ {ρ Δ a} [ρ] ⊢Δ
                  ([a] : Δ ⊩⟨ l′ ⟩ a ∷ wk ρ F′ ^ [ rF₁ , ι lF₁ ] / [F′] [ρ] ⊢Δ)
                → Δ ⊩⟨ l′ ⟩ wk (lift ρ) G′  [ a ]
                          ≡ wk (lift ρ) G″ [ a ] ^ [ r , ι lG₁ ] / [G′] [ρ] ⊢Δ [a]
        [G′≡G″] {ρ} [ρ] ⊢Δ [a′] =
          let [a]₁ = irrelevanceTerm′ (PE.cong (wk ρ) (PE.sym F₁≡F′)) PE.refl PE.refl
                                      ([F′] [ρ] ⊢Δ) ([F]₁ [ρ] ⊢Δ) [a′]
          in  irrelevanceEq′ (PE.cong (λ x → wk (lift ρ) x [ _ ]) G₁≡G′) PE.refl PE.refl
                             ([G]₁ [ρ] ⊢Δ [a]₁) ([G′] [ρ] ⊢Δ [a′])
                             ([G≡G′]₁ [ρ] ⊢Δ [a]₁)
                             -- Γ ⊢ .C ⇒* Π F″ ^ rF ▹ G″ ^ r
    in  Π₌ F″ G″ (PE.subst₃ _ rF₁≡rF′ lF₁≡lF′ lG₁≡lG′ D″) (PE.subst₃ _ rF₁≡rF′ lF₁≡lF′ lG₁≡lG′ (≅-trans A≡B (PE.subst (λ x → Γ ⊢ x ≅ Π F″ ^ rF₁ ° lF₁ ▹ G″ ° lG₁ ° lΠ ^ [ r , ι lΠ ]) ΠF₁G₁≡ΠF′G′ A≡B₁)))
           (λ ρ ⊢Δ → transEq′ PE.refl PE.refl (PE.sym rF₁≡rF′) (PE.sym rF₂≡rF′) (PE.cong ι (PE.sym lF₁≡lF′)) (PE.cong ι (PE.sym lF₂≡lF′))
           ([F] ρ ⊢Δ) ([F′] ρ ⊢Δ) ([F″] ρ ⊢Δ)
           ([F≡F′] ρ ⊢Δ) ([F′≡F″] ρ ⊢Δ))
           (λ ρ ⊢Δ [a] →
              let [a′] = convTerm₁′ (PE.sym rF₁≡rF′) (PE.cong ι (PE.sym lF₁≡lF′)) ([F] ρ ⊢Δ) ([F′] ρ ⊢Δ) ([F≡F′] ρ ⊢Δ) [a]
                  [a″] = convTerm₁′ (PE.sym rF₂≡rF′) (PE.cong ι (PE.sym lF₂≡lF′)) ([F′] ρ ⊢Δ) ([F″] ρ ⊢Δ) ([F′≡F″] ρ ⊢Δ) [a′]
              in transEq′ PE.refl PE.refl PE.refl PE.refl (PE.cong ι (PE.sym lG₁≡lG′)) (PE.cong ι (PE.sym lG₂≡lG″))
                          ([G] ρ ⊢Δ [a]) ([G′] ρ ⊢Δ [a′]) ([G″] ρ ⊢Δ [a″])
                          ([G≡G′] ρ ⊢Δ [a]) ([G′≡G″] ρ ⊢Δ [a′]))
  transEqT {Γ}  {r = r} {l = l} {l′ = l′} {l″ = l″}
           (∃ᵥ (∃ᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
               (∃ᵣ F₁ G₁ D₁ ⊢F₁ ⊢G₁ A≡A₁ [F]₁ [G]₁ G-ext₁)
               (∃ᵣ F₂ G₂ D₂ ⊢F₂ ⊢G₂ A≡A₂ [F]₂ [G]₂ G-ext₂))
           (∃₌ F′ G′ D′ A≡B [F≡F′] [G≡G′])
           (∃₌ F″ G″ D″ A≡B₁ [F≡F′]₁ [G≡G′]₁) =
    let ∃F₁G₁≡∃F′G′    = whrDet* (red D₁ , ∃ₙ) (D′  , ∃ₙ)
        F₁≡F′ ,  G₁≡G′ = ∃-PE-injectivity ∃F₁G₁≡∃F′G′
        F₂≡F″ ,  G₂≡G″  = ∃-PE-injectivity (whrDet* (red D₂ , ∃ₙ) (D″ , ∃ₙ))
        substLift {Δ} {l} {a} {r} ρ x = Δ ⊩⟨ l ⟩ wk (lift ρ) x [ a ] ^ r
        lr = TypeInfo.l r
        [F′] : ∀ {ρ Δ} [ρ] ⊢Δ → Δ ⊩⟨ l′ ⟩ wk ρ F′ ^ [ % , lr ]
        [F′] {ρ} [ρ] ⊢Δ = PE.subst (λ x → _ ⊩⟨ _ ⟩ wk ρ x ^ _) F₁≡F′ ([F]₁ [ρ] ⊢Δ)
        [F″] : ∀ {ρ} {Δ} [ρ] ⊢Δ → Δ ⊩⟨ l″ ⟩ wk ρ F″ ^ [ % , lr ]
        [F″] {ρ} [ρ] ⊢Δ = PE.subst (λ x → _ ⊩⟨ _ ⟩ wk ρ x ^ _) F₂≡F″ ([F]₂ [ρ] ⊢Δ)
        [F′≡F″] : ∀ {ρ} {Δ} [ρ] ⊢Δ → Δ ⊩⟨ l′ ⟩ wk ρ F′ ≡ wk ρ F″ ^ [ % , lr ] / [F′] [ρ] ⊢Δ
        [F′≡F″] {ρ} [ρ] ⊢Δ = irrelevanceEq′ (PE.cong (wk ρ) F₁≡F′) PE.refl PE.refl
                                      ([F]₁ [ρ] ⊢Δ) ([F′] [ρ] ⊢Δ) ([F≡F′]₁ [ρ] ⊢Δ)
        [G′] : ∀ {ρ Δ a} [ρ] ⊢Δ
             → Δ ⊩⟨ l′ ⟩ a ∷ wk ρ F′ ^ [ % , lr ] / [F′] [ρ] ⊢Δ
             → Δ ⊩⟨ l′ ⟩ wk (lift ρ) G′ [ a ] ^ r
        [G′] {ρ} [ρ] ⊢Δ [a] =
          let [a′] = irrelevanceTerm′ (PE.cong (wk ρ) (PE.sym F₁≡F′)) PE.refl PE.refl
                                      ([F′] [ρ] ⊢Δ) ([F]₁ [ρ] ⊢Δ) [a]
          in  PE.subst (substLift ρ) G₁≡G′ ([G]₁ [ρ] ⊢Δ [a′])
        [G″] : ∀ {ρ Δ a} [ρ] ⊢Δ
             → Δ ⊩⟨ l″ ⟩ a ∷ wk ρ F″ ^ [ % , lr ] / [F″] [ρ] ⊢Δ
             → Δ ⊩⟨ l″ ⟩ wk (lift ρ) G″ [ a ] ^ r
        [G″] {ρ} [ρ] ⊢Δ [a] =
          let [a″] = irrelevanceTerm′ (PE.cong (wk ρ) (PE.sym F₂≡F″)) PE.refl PE.refl
                                      ([F″] [ρ] ⊢Δ) ([F]₂ [ρ] ⊢Δ) [a]
          in  PE.subst (substLift ρ) G₂≡G″ ([G]₂ [ρ] ⊢Δ [a″])
        [G′≡G″] : ∀ {ρ Δ a} [ρ] ⊢Δ
                  ([a] : Δ ⊩⟨ l′ ⟩ a ∷ wk ρ F′ ^ [ % , lr ] / [F′] [ρ] ⊢Δ)
                → Δ ⊩⟨ l′ ⟩ wk (lift ρ) G′  [ a ]
                          ≡ wk (lift ρ) G″ [ a ] ^ r / [G′] [ρ] ⊢Δ [a]
        [G′≡G″] {ρ} [ρ] ⊢Δ [a′] =
          let [a]₁ = irrelevanceTerm′ (PE.cong (wk ρ) (PE.sym F₁≡F′)) PE.refl PE.refl
                                      ([F′] [ρ] ⊢Δ) ([F]₁ [ρ] ⊢Δ) [a′]
          in  irrelevanceEq′ (PE.cong (λ x → wk (lift ρ) x [ _ ]) G₁≡G′) PE.refl PE.refl
                             ([G]₁ [ρ] ⊢Δ [a]₁) ([G′] [ρ] ⊢Δ [a′])
                             ([G≡G′]₁ [ρ] ⊢Δ [a]₁)
                             -- Γ ⊢ .C ⇒* ∃ F″ ^ rF ▹ G″ ^ r
    in  ∃₌ F″ G″ D″ (≅-trans A≡B (PE.subst (λ x → Γ ⊢ x ≅ ∃ F″ ▹ G″ ^ [ % , lr ]) ∃F₁G₁≡∃F′G′ A≡B₁))
           (λ ρ ⊢Δ → transEq′ PE.refl PE.refl PE.refl PE.refl PE.refl PE.refl
           ([F] ρ ⊢Δ) ([F′] ρ ⊢Δ) ([F″] ρ ⊢Δ)
           ([F≡F′] ρ ⊢Δ) ([F′≡F″] ρ ⊢Δ))
           (λ ρ ⊢Δ [a] →
              let [a′] = convTerm₁′ PE.refl PE.refl ([F] ρ ⊢Δ) ([F′] ρ ⊢Δ) ([F≡F′] ρ ⊢Δ) [a]
                  [a″] = convTerm₁′ PE.refl PE.refl ([F′] ρ ⊢Δ) ([F″] ρ ⊢Δ) ([F′≡F″] ρ ⊢Δ) [a′]
              in  transEq ([G] ρ ⊢Δ [a]) ([G′] ρ ⊢Δ [a′]) ([G″] ρ ⊢Δ [a″])
                          ([G≡G′] ρ ⊢Δ [a]) ([G′≡G″] ρ ⊢Δ [a′]))
  transEqT (emb⁰¹¹ S) A≡B B≡C = transEqT S A≡B B≡C
  transEqT (emb¹⁰¹ S) A≡B B≡C = transEqT S A≡B B≡C
  transEqT (emb¹¹⁰ S) A≡B B≡C = transEqT S A≡B B≡C
  transEqT (emb¹∞∞ S) A≡B B≡C = transEqT S A≡B B≡C
  transEqT (emb∞¹∞ S) A≡B B≡C = transEqT S A≡B B≡C
  transEqT (emb∞∞¹ S) A≡B B≡C = transEqT S A≡B B≡C

  -- Transitivty of type equality.
  transEq : ∀ {Γ A B C r l l′ l″}
            ([A] : Γ ⊩⟨ l ⟩ A ^ r) ([B] : Γ ⊩⟨ l′ ⟩ B ^ r) ([C] : Γ ⊩⟨ l″ ⟩ C ^ r)
          → Γ ⊩⟨ l ⟩  A ≡ B ^ r / [A]
          → Γ ⊩⟨ l′ ⟩ B ≡ C ^ r / [B]
          → Γ ⊩⟨ l ⟩  A ≡ C ^ r / [A]
  transEq [A] [B] [C] A≡B B≡C =
    transEqT (combine (goodCases [A] [B] A≡B) (goodCases [B] [C] B≡C)) A≡B B≡C

  -- Transitivity of type equality with some propositonally equal types.
  transEq′ : ∀ {Γ A B B′ C C′ r r' r'' ll ll' ll'' l l′ l″} → B PE.≡ B′ → C PE.≡ C′ → r PE.≡ r' → r' PE.≡ r'' → ll PE.≡ ll' → ll' PE.≡ ll''
           → ([A] : Γ ⊩⟨ l ⟩ A ^ [ r , ll ]) ([B] : Γ ⊩⟨ l′ ⟩ B ^ [ r' , ll' ]) ([C] : Γ ⊩⟨ l″ ⟩ C ^ [ r'' , ll'' ])
           → Γ ⊩⟨ l ⟩  A ≡ B′ ^ [ r , ll ] / [A]
           → Γ ⊩⟨ l′ ⟩ B ≡ C′ ^ [ r' , ll' ] / [B]
           → Γ ⊩⟨ l ⟩  A ≡ C  ^ [ r , ll ] / [A]
  transEq′ PE.refl PE.refl PE.refl PE.refl PE.refl PE.refl [A] [B] [C] A≡B B≡C = transEq [A] [B] [C] A≡B B≡C

transEqTermNe : ∀ {Γ n n′ n″ A r}
              → Γ ⊩neNf n  ≡ n′  ∷ A ^ r
              → Γ ⊩neNf n′ ≡ n″ ∷ A ^ r
              → Γ ⊩neNf n  ≡ n″ ∷ A ^ r
transEqTermNe (neNfₜ₌ neK neM k≡m) (neNfₜ₌ neK₁ neM₁ k≡m₁) =
  neNfₜ₌ neK neM₁ (~-trans k≡m k≡m₁)

mutual
  transEqTermℕ : ∀ {Γ n n′ n″}
               → Γ ⊩ℕ n  ≡ n′  ∷ℕ
               → Γ ⊩ℕ n′ ≡ n″ ∷ℕ
               → Γ ⊩ℕ n  ≡ n″ ∷ℕ
  transEqTermℕ (ℕₜ₌ k k′ d d′ t≡u prop)
               (ℕₜ₌ k₁ k″ d₁ d″ t≡u₁ prop₁) =
    let k₁Whnf = naturalWhnf (proj₁ (split prop₁))
        k′Whnf = naturalWhnf (proj₂ (split prop))
        k₁≡k′ = whrDet*Term (redₜ d₁ , k₁Whnf) (redₜ d′ , k′Whnf)
        prop′ = PE.subst (λ x → [Natural]-prop _ x _) k₁≡k′ prop₁
    in  ℕₜ₌ k k″ d d″ (≅ₜ-trans t≡u (PE.subst (λ x → _ ⊢ x ≅ _ ∷ _ ^ _) k₁≡k′ t≡u₁))
            (transNatural-prop prop prop′)

  transNatural-prop : ∀ {Γ k k′ k″}
                    → [Natural]-prop Γ k k′
                    → [Natural]-prop Γ k′ k″
                    → [Natural]-prop Γ k k″
  transNatural-prop (sucᵣ x) (sucᵣ x₁) = sucᵣ (transEqTermℕ x x₁)
  transNatural-prop (sucᵣ x) (ne (neNfₜ₌ () neM k≡m))
  transNatural-prop zeroᵣ prop₁ = prop₁
  transNatural-prop prop zeroᵣ = prop
  transNatural-prop (ne (neNfₜ₌ neK () k≡m)) (sucᵣ x₃)
  transNatural-prop (ne [k≡k′]) (ne [k′≡k″]) =
    ne (transEqTermNe [k≡k′] [k′≡k″])

-- Empty
transEmpty-prop : ∀ {Γ k k′ k″ l}
  → [Empty]-prop Γ k k′ l
  → [Empty]-prop Γ k′ k″ l
  → [Empty]-prop Γ k k″ l
transEmpty-prop (ne a b) (ne c d) = ne a d

transEqTermEmpty : ∀ {Γ n n′ n″ l}
  → Γ ⊩Empty n  ≡ n′ ∷Empty^ l
  → Γ ⊩Empty n′ ≡ n″ ∷Empty^ l
  → Γ ⊩Empty n  ≡ n″ ∷Empty^ l
transEqTermEmpty (Emptyₜ₌ (ne a b)) (Emptyₜ₌ (ne c d)) = Emptyₜ₌ (ne a d)

-- Transitivity of term equality.
transEqTerm⁰ : ∀ {Γ A t u v r}
               ([A] : Γ ⊩⟨ ι ⁰ ⟩ A ^ r)
             → Γ ⊩⟨ ι ⁰ ⟩ t ≡ u ∷ A ^ r / [A]
             → Γ ⊩⟨ ι ⁰ ⟩ u ≡ v ∷ A ^ r / [A]
             → Γ ⊩⟨ ι ⁰ ⟩ t ≡ v ∷ A ^ r / [A]
transEqTerm⁰ (ℕᵣ D) [t≡u] [u≡v] = transEqTermℕ [t≡u] [u≡v]
transEqTerm⁰ (Emptyᵣ D) [t≡u] [u≡v] = transEqTermEmpty [t≡u] [u≡v]
transEqTerm⁰ {r = [ ! , l ]} (ne′ K D neK K≡K) (neₜ₌ k m d d′ (neNfₜ₌ neK₁ neM k≡m))
                              (neₜ₌ k₁ m₁ d₁ d″ (neNfₜ₌ neK₂ neM₁ k≡m₁)) =
  let k₁≡m = whrDet*Term (redₜ d₁ , ne neK₂) (redₜ d′ , ne neM)
  in  neₜ₌ k m₁ d d″
           (neNfₜ₌ neK₁ neM₁
                   (~-trans k≡m (PE.subst (λ x → _ ⊢ x ~ _ ∷ _ ^ _) k₁≡m k≡m₁)))
transEqTerm⁰ {r = [ % , l ]} (ne′ K D neK K≡K) (neₜ₌ d d′)
                              (neₜ₌ d₁ d″) = neₜ₌ d d″
transEqTerm⁰ {r = [ ! , l ]} (Πᵣ′ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
            (Πₜ₌ f g d d′ funcF funcG f≡g [f] [g] [f≡g])
            (Πₜ₌ f₁ g₁ d₁ d₁′ funcF₁ funcG₁ f≡g₁ [f]₁ [g]₁ [f≡g]₁)
            rewrite whrDet*Term (redₜ d′ , functionWhnf funcG)
                            (redₜ d₁ , functionWhnf funcF₁) =
  Πₜ₌ f g₁ d d₁′ funcF funcG₁ (≅ₜ-trans f≡g f≡g₁) [f] [g]₁
      (λ ρ ⊢Δ [a] → transEqTerm⁰ ([G] ρ ⊢Δ [a])
                                ([f≡g] ρ ⊢Δ [a])
                                ([f≡g]₁ ρ ⊢Δ [a]))
transEqTerm⁰ {r = [ % , l ]} (Πᵣ′ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
            (d , d′)
            (d₁ , d₁′) = d , d₁′
transEqTerm⁰ {r = [ % , l ]} (∃ᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
            (d , d′)
            (d₁ , d₁′) = d , d₁′

transEqTerm¹ : ∀ {Γ A t u v r}
               ([A] : Γ ⊩⟨ ι ¹ ⟩ A ^ r)
             → Γ ⊩⟨ ι ¹ ⟩ t ≡ u ∷ A ^ r / [A]
             → Γ ⊩⟨ ι ¹ ⟩ u ≡ v ∷ A ^ r / [A]
             → Γ ⊩⟨ ι ¹ ⟩ t ≡ v ∷ A ^ r / [A]
transEqTerm¹ {Γ} {A} {t} {u} {v} {r} (Uᵣ (Uᵣ rU ⁰ l< eq d)) (Uₜ₌ [t] [u] A≡B [t≡u])
  (Uₜ₌ [u]′ [v] B′≡C [u≡v]) =
  let
    ti = LogRel._⊩¹U_∷_^_/_.[t]
    ⊢Γ = wf (_⊢_:⇒*:_^_.⊢A d)
    B≡B′ = whrDet*Term (_⊢_:⇒*:_∷_^_.d (LogRel._⊩¹U_∷_^_/_.d [u]) , typeWhnf (LogRel._⊩¹U_∷_^_/_.typeK [u]))
      (_⊢_:⇒*:_∷_^_.d (LogRel._⊩¹U_∷_^_/_.d [u]′) , typeWhnf (LogRel._⊩¹U_∷_^_/_.typeK [u]′))
    A≡C = ≅ₜ-trans (PE.subst (λ X → EqRelSet._⊢_≅_∷_^_ eqrel Γ (LogRel._⊩¹U_∷_^_/_.K [t]) X (Univ rU ⁰) ([ ! , ι ¹ ])) B≡B′ A≡B) B′≡C
    [t≡v] = λ {ρ} {Δ} ([ρ] : ρ ∷ Δ ⊆ Γ) ⊢Δ →
      transEq (ti [t] [ρ] ⊢Δ) (ti [u] [ρ] ⊢Δ) (ti [v] [ρ] ⊢Δ) ([t≡u] [ρ] ⊢Δ)
        (irrelevanceEq (ti [u]′ [ρ] ⊢Δ) (ti [u] [ρ] ⊢Δ) ([u≡v] [ρ] ⊢Δ))
  in
  Uₜ₌ [t] [v] A≡C [t≡v]
transEqTerm¹ (ℕᵣ D) [t≡u] [u≡v] = transEqTermℕ [t≡u] [u≡v]
transEqTerm¹ (Emptyᵣ D) [t≡u] [u≡v] = transEqTermEmpty [t≡u] [u≡v]
transEqTerm¹ {r = [ ! , l ]} (ne′ K D neK K≡K) (neₜ₌ k m d d′ (neNfₜ₌ neK₁ neM k≡m))
                              (neₜ₌ k₁ m₁ d₁ d″ (neNfₜ₌ neK₂ neM₁ k≡m₁)) =
  let k₁≡m = whrDet*Term (redₜ d₁ , ne neK₂) (redₜ d′ , ne neM)
  in  neₜ₌ k m₁ d d″
           (neNfₜ₌ neK₁ neM₁
                   (~-trans k≡m (PE.subst (λ x → _ ⊢ x ~ _ ∷ _ ^ _) k₁≡m k≡m₁)))
transEqTerm¹ {r = [ % , l ]} (ne′ K D neK K≡K) (neₜ₌ d d′)
                              (neₜ₌ d₁ d″) = neₜ₌ d d″
transEqTerm¹ {r = [ ! , l ]} (Πᵣ′ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
            (Πₜ₌ f g d d′ funcF funcG f≡g [f] [g] [f≡g])
            (Πₜ₌ f₁ g₁ d₁ d₁′ funcF₁ funcG₁ f≡g₁ [f]₁ [g]₁ [f≡g]₁)
            rewrite whrDet*Term (redₜ d′ , functionWhnf funcG)
                            (redₜ d₁ , functionWhnf funcF₁) =
  Πₜ₌ f g₁ d d₁′ funcF funcG₁ (≅ₜ-trans f≡g f≡g₁) [f] [g]₁
      (λ ρ ⊢Δ [a] → transEqTerm¹ ([G] ρ ⊢Δ [a])
                                ([f≡g] ρ ⊢Δ [a])
                                ([f≡g]₁ ρ ⊢Δ [a]))
transEqTerm¹ {r = [ % , l ]} (Πᵣ′ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
            (d , d′)
            (d₁ , d₁′) = d , d₁′
transEqTerm¹ {r = [ % , l ]} (∃ᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
            (d , d′)
            (d₁ , d₁′) = d , d₁′
transEqTerm¹ (emb l< [A]) [t≡u] [u≡v] = transEqTerm⁰ [A] [t≡u] [u≡v]

transEqTerm∞ : ∀ {Γ A t u v r}
               ([A] : Γ ⊩⟨ ∞ ⟩ A ^ r)
             → Γ ⊩⟨ ∞ ⟩ t ≡ u ∷ A ^ r / [A]
             → Γ ⊩⟨ ∞ ⟩ u ≡ v ∷ A ^ r / [A]
             → Γ ⊩⟨ ∞ ⟩ t ≡ v ∷ A ^ r / [A]
transEqTerm∞ {Γ} {A} {t} {u} {v} {r} (Uᵣ (Uᵣ rU ⁰ l< eq d)) (Uₜ₌ [t] [u] A≡B [t≡u])
  (Uₜ₌ [u]′ [v] B′≡C [u≡v]) =
  let
    ti = LogRel._⊩¹U_∷_^_/_.[t]
    ⊢Γ = wf (_⊢_:⇒*:_^_.⊢A d)
    B≡B′ = whrDet*Term (_⊢_:⇒*:_∷_^_.d (LogRel._⊩¹U_∷_^_/_.d [u]) , typeWhnf (LogRel._⊩¹U_∷_^_/_.typeK [u]))
      (_⊢_:⇒*:_∷_^_.d (LogRel._⊩¹U_∷_^_/_.d [u]′) , typeWhnf (LogRel._⊩¹U_∷_^_/_.typeK [u]′))
    A≡C = ≅ₜ-trans (PE.subst (λ X → EqRelSet._⊢_≅_∷_^_ eqrel Γ (LogRel._⊩¹U_∷_^_/_.K [t]) X (Univ rU ⁰) ([ ! , ι ¹ ])) B≡B′ A≡B) B′≡C
    [t≡v] = λ {ρ} {Δ} ([ρ] : ρ ∷ Δ ⊆ Γ) ⊢Δ →
      transEq (ti [t] [ρ] ⊢Δ) (ti [u] [ρ] ⊢Δ) (ti [v] [ρ] ⊢Δ) ([t≡u] [ρ] ⊢Δ)
        (irrelevanceEq (ti [u]′ [ρ] ⊢Δ) (ti [u] [ρ] ⊢Δ) ([u≡v] [ρ] ⊢Δ))
  in
  Uₜ₌ [t] [v] A≡C [t≡v]
transEqTerm∞ {Γ} {A} {t} {u} {v} {r} (Uᵣ (Uᵣ rU ¹ l< eq d)) (Uₜ₌ [t] [u] A≡B [t≡u])
  (Uₜ₌ [u]′ [v] B′≡C [u≡v]) =
  let
    ti = LogRel._⊩¹U_∷_^_/_.[t]
    ⊢Γ = wf (_⊢_:⇒*:_^_.⊢A d)
    B≡B′ = whrDet*Term (_⊢_:⇒*:_∷_^_.d (LogRel._⊩¹U_∷_^_/_.d [u]) , typeWhnf (LogRel._⊩¹U_∷_^_/_.typeK [u]))
      (_⊢_:⇒*:_∷_^_.d (LogRel._⊩¹U_∷_^_/_.d [u]′) , typeWhnf (LogRel._⊩¹U_∷_^_/_.typeK [u]′))
    A≡C = ≅ₜ-trans (PE.subst (λ X → EqRelSet._⊢_≅_∷_^_ eqrel Γ (LogRel._⊩¹U_∷_^_/_.K [t]) X (Univ rU ¹) ([ ! , ∞ ])) B≡B′ A≡B) B′≡C
    [t≡v] = λ {ρ} {Δ} ([ρ] : ρ ∷ Δ ⊆ Γ) ⊢Δ →
      transEq (ti [t] [ρ] ⊢Δ) (ti [u] [ρ] ⊢Δ) (ti [v] [ρ] ⊢Δ) ([t≡u] [ρ] ⊢Δ)
        (irrelevanceEq (ti [u]′ [ρ] ⊢Δ) (ti [u] [ρ] ⊢Δ) ([u≡v] [ρ] ⊢Δ))
  in
  Uₜ₌ [t] [v] A≡C [t≡v]
transEqTerm∞ (ℕᵣ D) [t≡u] [u≡v] = transEqTermℕ [t≡u] [u≡v]
transEqTerm∞ (Emptyᵣ D) [t≡u] [u≡v] = transEqTermEmpty [t≡u] [u≡v]
transEqTerm∞ {r = [ ! , l ]} (ne′ K D neK K≡K) (neₜ₌ k m d d′ (neNfₜ₌ neK₁ neM k≡m))
                              (neₜ₌ k₁ m₁ d₁ d″ (neNfₜ₌ neK₂ neM₁ k≡m₁)) =
  let k₁≡m = whrDet*Term (redₜ d₁ , ne neK₂) (redₜ d′ , ne neM)
  in  neₜ₌ k m₁ d d″
           (neNfₜ₌ neK₁ neM₁
                   (~-trans k≡m (PE.subst (λ x → _ ⊢ x ~ _ ∷ _ ^ _) k₁≡m k≡m₁)))
transEqTerm∞ {r = [ % , l ]} (ne′ K D neK K≡K) (neₜ₌ d d′)
                              (neₜ₌ d₁ d″) = neₜ₌ d d″
transEqTerm∞ {r = [ ! , l ]} (Πᵣ′ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
            (Πₜ₌ f g d d′ funcF funcG f≡g [f] [g] [f≡g])
            (Πₜ₌ f₁ g₁ d₁ d₁′ funcF₁ funcG₁ f≡g₁ [f]₁ [g]₁ [f≡g]₁)
            rewrite whrDet*Term (redₜ d′ , functionWhnf funcG)
                            (redₜ d₁ , functionWhnf funcF₁) =
  Πₜ₌ f g₁ d d₁′ funcF funcG₁ (≅ₜ-trans f≡g f≡g₁) [f] [g]₁
      (λ ρ ⊢Δ [a] → transEqTerm∞ ([G] ρ ⊢Δ [a])
                                ([f≡g] ρ ⊢Δ [a])
                                ([f≡g]₁ ρ ⊢Δ [a]))
transEqTerm∞ {r = [ % , l ]} (Πᵣ′ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
            (d , d′)
            (d₁ , d₁′) = d , d₁′
transEqTerm∞ {r = [ % , l ]} (∃ᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
            (d , d′)
            (d₁ , d₁′) = d , d₁′
transEqTerm∞ (emb {l′ = ι ¹} l< [A]) [t≡u] [u≡v] = transEqTerm¹ [A] [t≡u] [u≡v]

transEqTerm : ∀ {l Γ A t u v r}
              ([A] : Γ ⊩⟨ l ⟩ A ^ r)
            → Γ ⊩⟨ l ⟩ t ≡ u ∷ A ^ r / [A]
            → Γ ⊩⟨ l ⟩ u ≡ v ∷ A ^ r / [A]
            → Γ ⊩⟨ l ⟩ t ≡ v ∷ A ^ r / [A]
transEqTerm {l = ι ⁰} = transEqTerm⁰
transEqTerm {l = ι ¹} = transEqTerm¹
transEqTerm {l = ∞} = transEqTerm∞


------------------------------------------------------------------------
-- The Agda standard library
--
-- The Cowriter type and some operations
------------------------------------------------------------------------

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

-- Disabled to prevent warnings from BoundedVec
{-# OPTIONS --warn=noUserWarning #-}

module Codata.Cowriter where

open import Size
open import Level as L using (Level)
open import Codata.Thunk using (Thunk; force)
open import Codata.Conat
open import Codata.Delay using (Delay; later; now)
open import Codata.Stream as Stream using (Stream; _∷_)
open import Data.Unit
open import Data.List.Base using (List; []; _∷_)
open import Data.List.NonEmpty using (List⁺; _∷_)
open import Data.Nat.Base as Nat using (ℕ; zero; suc)
open import Data.Product as Prod using (_×_; _,_)
open import Data.Sum.Base as Sum using (_⊎_; inj₁; inj₂)
open import Data.Vec.Base using (Vec; []; _∷_)
open import Data.Vec.Bounded as Vec≤ using (Vec≤; _,_)
open import Function

private
  variable
    a b w x : Level
    A : Set a
    B : Set b
    W : Set w
    X : Set x

------------------------------------------------------------------------
-- Definition

data Cowriter (W : Set w) (A : Set a) (i : Size) : Set (a L.⊔ w) where
  [_] : A → Cowriter W A i
  _∷_ : W → Thunk (Cowriter W A) i → Cowriter W A i

------------------------------------------------------------------------
-- Relationship to Delay.

fromDelay : ∀ {i} → Delay A i → Cowriter ⊤ A i
fromDelay (now a)    = [ a ]
fromDelay (later da) = _ ∷ λ where .force → fromDelay (da .force)

toDelay : ∀ {i} → Cowriter W A i → Delay A i
toDelay [ a ]    = now a
toDelay (_ ∷ ca) = later λ where .force → toDelay (ca .force)

------------------------------------------------------------------------
-- Basic functions.

fromStream : ∀ {i} → Stream W i → Cowriter W A i
fromStream (w ∷ ws) = w ∷ λ where .force → fromStream (ws .force)

repeat : W → Cowriter W A ∞
repeat = fromStream ∘′ Stream.repeat

length : ∀ {i} → Cowriter W A i → Conat i
length [ _ ]    = zero
length (w ∷ cw) = suc λ where .force → length (cw .force)

splitAt : ∀ (n : ℕ) → Cowriter W A ∞ → (Vec W n × Cowriter W A ∞) ⊎ (Vec≤ W n × A)
splitAt zero    cw       = inj₁ ([] , cw)
splitAt (suc n) [ a ]    = inj₂ (Vec≤.[] , a)
splitAt (suc n) (w ∷ cw) = Sum.map (Prod.map₁ (w ∷_)) (Prod.map₁ (w Vec≤.∷_))
                         $ splitAt n (cw .force)

take : ∀ (n : ℕ) → Cowriter W A ∞ → Vec W n ⊎ (Vec≤ W n × A)
take n = Sum.map₁ Prod.proj₁ ∘′ splitAt n

infixr 5 _++_ _⁺++_
_++_ : ∀ {i} → List W → Cowriter W A i → Cowriter W A i
[]       ++ ca = ca
(w ∷ ws) ++ ca = w ∷ λ where .force → ws ++ ca

_⁺++_ : ∀ {i} → List⁺ W → Thunk (Cowriter W A) i → Cowriter W A i
(w ∷ ws) ⁺++ ca = w ∷ λ where .force → ws ++ ca .force

concat : ∀ {i} → Cowriter (List⁺ W) A i → Cowriter W A i
concat [ a ]    = [ a ]
concat (w ∷ ca) = w ⁺++ λ where .force → concat (ca .force)

------------------------------------------------------------------------
-- Functor, Applicative and Monad

map : ∀ {i} → (W → X) → (A → B) → Cowriter W A i → Cowriter X B i
map f g [ a ]    = [ g a ]
map f g (w ∷ cw) = f w ∷ λ where .force → map f g (cw .force)

map₁ : ∀ {i} → (W → X) → Cowriter W A i → Cowriter X A i
map₁ f = map f id

map₂ : ∀ {i} → (A → X) → Cowriter W A i → Cowriter W X i
map₂ = map id

ap : ∀ {i} → Cowriter W (A → X) i → Cowriter W A i → Cowriter W X i
ap [ f ]    ca = map₂ f ca
ap (w ∷ cf) ca = w ∷ λ where .force → ap (cf .force) ca

_>>=_ : ∀ {i} → Cowriter W A i → (A → Cowriter W X i) → Cowriter W X i
[ a ]    >>= f = f a
(w ∷ ca) >>= f = w ∷ λ where .force → ca .force >>= f

------------------------------------------------------------------------
-- Construction.

unfold : ∀ {i} → (X → (W × X) ⊎ A) → X → Cowriter W A i
unfold next seed with next seed
... | inj₁ (w , seed') = w ∷ λ where .force → unfold next seed'
... | inj₂ a           = [ a ]

------------------------------------------------------------------------
-- DEPRECATED NAMES
------------------------------------------------------------------------
-- Please use the new names as continuing support for the old names is
-- not guaranteed.

-- Version 1.3

open import Data.BoundedVec as BVec using (BoundedVec)

splitAt′ : ∀ (n : ℕ) → Cowriter W A ∞ → (Vec W n × Cowriter W A ∞) ⊎ (BoundedVec W n × A)
splitAt′ zero    cw       = inj₁ ([] , cw)
splitAt′ (suc n) [ a ]    = inj₂ (BVec.[] , a)
splitAt′ (suc n) (w ∷ cw) = Sum.map (Prod.map₁ (w ∷_)) (Prod.map₁ (w BVec.∷_))
                         $ splitAt′ n (cw .force)
{-# WARNING_ON_USAGE splitAt′
"Warning: splitAt′ (and Data.BoundedVec) was deprecated in v1.3.
Please use splitAt (and Data.Vec.Bounded) instead."
#-}

take′ : ∀ (n : ℕ) → Cowriter W A ∞ → Vec W n ⊎ (BoundedVec W n × A)
take′ n = Sum.map₁ Prod.proj₁ ∘′ splitAt′ n
{-# WARNING_ON_USAGE take′
"Warning: take′ (and Data.BoundedVec) was deprecated in v1.3.
Please use take (and Data.Vec.Bounded) instead."
#-}


module localInstances where

open import Agda.Builtin.Nat renaming (Nat to ℕ)
open import Agda.Builtin.Bool
open import Common.String
open import Common.List

record Eq (A : Set) : Set where
  field eq : A → A → Bool

strlen : String → ℕ
strlen s = length (stringToList s)

if_then_else_ : {A : Set} → Bool → A → A → A
if true  then x else y = x
if false then x else y = y

open Eq {{...}}

instance
  eqℕ : Eq ℕ
  eqℕ = record { eq = λ x x' → x == x' }

eqString₁ : String → String → Bool
eqString₁ s₁ s₂ = strEq s₁ s₂

eqString₂ : String → String → Bool
eqString₂ s₁ s₂ = eq (strlen s₁) (strlen s₂)

testWhere : Bool → Bool
testWhere lengthEq = if eq "abcd" "dcba" then false else true
  where
    instance
      eqLocal : Eq String
      eqLocal = record { eq = if lengthEq then eqString₂ else eqString₁ }

testLet : Bool → Bool
testLet lengthEq =
  let instance
        eqLocal : Eq String
        eqLocal = record { eq = if lengthEq then eqString₂ else eqString₁ }
  in if eq "abcd" "dcba" then false else true

test1 : Bool
test1 = testWhere true

test2 : Bool
test2 = testLet true


import Issue2447.Operator-error


{-# OPTIONS --safe #-}

open import Definition.Typed.EqualityRelation

module Definition.LogicalRelation.Irrelevance {{eqrel : EqRelSet}} where
open EqRelSet {{...}}

open import Tools.Empty using (⊥; ⊥-elim)

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.LogicalRelation
open import Definition.LogicalRelation.ShapeView

open import Tools.Product
import Tools.PropositionalEquality as PE

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

-- Irrelevance for propositionally equal types
irrelevance′ : ∀ {A A′ Γ r l}
             → A PE.≡ A′
             → Γ ⊩⟨ l ⟩ A ^ r
             → Γ ⊩⟨ l ⟩ A′ ^ r
irrelevance′ PE.refl [A] = [A]

irrelevance′′ : ∀ {A A′ Γ r r' ll ll' l}
             → A PE.≡ A′
             → r PE.≡ r'
             → ll PE.≡ ll'
             → Γ ⊩⟨ l ⟩ A ^ [ r , ll ]
             → Γ ⊩⟨ l ⟩ A′ ^ [ r' , ll' ]
irrelevance′′ PE.refl PE.refl PE.refl [A] = [A]

-- Irrelevance for propositionally equal types and contexts
irrelevanceΓ′ : ∀ {l A A′ r Γ Γ′}
              → Γ PE.≡ Γ′
              → A PE.≡ A′
              → Γ  ⊩⟨ l ⟩ A ^ r
              → Γ′ ⊩⟨ l ⟩ A′ ^ r
irrelevanceΓ′ PE.refl PE.refl [A] = [A]

-- helper function to deal with relevance

reduction-irrelevant-Univ : ∀ {Γ A t l l' ll ll' l< l<' r r' el el' D D'}
        (e : r PE.≡ r') →
        Γ ⊩⟨ l ⟩ t ∷ A ^ [ ! , next ll ] / Uᵣ (Uᵣ r ll l< el D) →
        Γ ⊩⟨ l' ⟩ t ∷ A ^ [ ! , next ll ] / Uᵣ (Uᵣ r' ll' l<' el' D')
reduction-irrelevant-Univ {Γ} {A} {t} {ι ¹} {ι ¹} {⁰} {⁰} PE.refl (Uₜ K d typeK K≡K [t]) = Uₜ K d typeK K≡K [t]
reduction-irrelevant-Univ {Γ} {A} {t} {∞} {∞} {¹} {¹} PE.refl (Uₜ K d typeK K≡K [t]) = Uₜ K d typeK K≡K [t]

reduction-irrelevant-Univ= : ∀ {Γ A t u l l' ll ll' l< l<' r r' el el' D D'}
        (e : r PE.≡ r') →
        Γ ⊩⟨ l ⟩ t ≡ u ∷ A ^ [ ! , next ll ] / Uᵣ (Uᵣ r ll l< el D) →
        Γ ⊩⟨ l' ⟩ t ≡ u ∷ A ^ [ ! , next ll ] / Uᵣ (Uᵣ r' ll' l<' el' D')
reduction-irrelevant-Univ= {l = ι ¹} {ι ¹} {⁰} {⁰} PE.refl (Uₜ₌ [t] [u] A≡B [t≡u]) = Uₜ₌ (reduction-irrelevant-Univ PE.refl [t]) (reduction-irrelevant-Univ PE.refl [u]) A≡B [t≡u]
reduction-irrelevant-Univ= {l = ∞} {∞} {¹} {¹} {l<} {l<'} PE.refl (Uₜ₌ [t] [u] A≡B [t≡u]) = Uₜ₌ (reduction-irrelevant-Univ PE.refl [t]) (reduction-irrelevant-Univ PE.refl [u]) A≡B [t≡u]

-- NB: for Pi cases it seems like it would be cleaner to do
-- irrelevanceFoo (Pi ...) rewrite whrDet* ...
-- instead of messing with PE.subst and irrelevanceEq′ etc
-- however for some reason the termination checker doesn't accept it

mutual
  -- Irrelevance for type equality
  irrelevanceEq : ∀ {Γ A B r l l′} (p : Γ ⊩⟨ l ⟩ A ^ r) (q : Γ ⊩⟨ l′ ⟩ A ^ r)
                → Γ ⊩⟨ l ⟩ A ≡ B ^ r / p → Γ ⊩⟨ l′ ⟩ A ≡ B ^ r / q
  irrelevanceEq p q A≡B = irrelevanceEqT (goodCasesRefl p q) A≡B

  -- Irrelevance for type equality with propositionally equal first types
  irrelevanceEq′ : ∀ {Γ A A′ B r r' l l′ ll ll'} (eq : A PE.≡ A′) (eqr : r PE.≡ r') (eql : ll PE.≡ ll')
                   (p : Γ ⊩⟨ l ⟩ A ^ [ r , ll ]) (q : Γ ⊩⟨ l′ ⟩ A′ ^ [ r' , ll' ])
                 → Γ ⊩⟨ l ⟩ A ≡ B ^ [ r , ll ] / p → Γ ⊩⟨ l′ ⟩ A′ ≡ B ^ [ r' , ll' ] / q
  irrelevanceEq′ PE.refl PE.refl PE.refl p q A≡B = irrelevanceEq p q A≡B

  -- Irrelevance for type equality with propositionally equal types
  irrelevanceEq″ : ∀ {Γ A A′ B B′ r r' ll ll' l l′} (eqA : A PE.≡ A′) (eqB : B PE.≡ B′) (eqr : r PE.≡ r') (eql : ll PE.≡ ll')
                    (p : Γ ⊩⟨ l ⟩ A ^ [ r , ll ]) (q : Γ ⊩⟨ l′ ⟩ A′ ^ [ r' , ll' ])
                  → Γ ⊩⟨ l ⟩ A ≡ B ^ [ r , ll ] / p → Γ ⊩⟨ l′ ⟩ A′ ≡ B′ ^ [ r' , ll' ] / q
  irrelevanceEq″ PE.refl PE.refl PE.refl PE.refl p q A≡B = irrelevanceEq p q A≡B

  -- Irrelevance for type equality with propositionally equal second types
  irrelevanceEqR′ : ∀ {Γ A B B′ r l} (eqB : B PE.≡ B′) (p : Γ ⊩⟨ l ⟩ A ^ r)
                  → Γ ⊩⟨ l ⟩ A ≡ B ^ r / p → Γ ⊩⟨ l ⟩ A ≡ B′ ^ r / p
  irrelevanceEqR′ PE.refl p A≡B = A≡B

  -- Irrelevance for type equality with propositionally equal types and
  -- a lifting of propositionally equal types
  irrelevanceEqLift″ : ∀ {Γ A A′ B B′ C C′ rC r l l′}
                        (eqA : A PE.≡ A′) (eqB : B PE.≡ B′) (eqC : C PE.≡ C′)
                        (p : Γ ∙ C ^ rC ⊩⟨ l ⟩ A ^ r) (q : Γ ∙ C′ ^ rC ⊩⟨ l′ ⟩ A′ ^ r)
                      → Γ ∙ C ^ rC ⊩⟨ l ⟩ A ≡ B ^ r / p → Γ ∙ C′ ^ rC ⊩⟨ l′ ⟩ A′ ≡ B′ ^ r / q
  irrelevanceEqLift″ PE.refl PE.refl PE.refl p q A≡B = irrelevanceEq p q A≡B

  -- Helper for irrelevance of type equality using shape view
  irrelevanceEqT : ∀ {Γ A B r l l′} {p : Γ ⊩⟨ l ⟩ A ^ r} {q : Γ ⊩⟨ l′ ⟩ A ^ r}
                       → ShapeView Γ l l′ A A r r p q
                       → Γ ⊩⟨ l ⟩ A ≡ B ^ r / p → Γ ⊩⟨ l′ ⟩ A ≡ B ^ r / q
  irrelevanceEqT (ℕᵥ D D′) A≡B = A≡B
  irrelevanceEqT (Emptyᵥ D D′) A≡B = A≡B
  irrelevanceEqT (ne (ne K D neK _) (ne K₁ D₁ neK₁ K≡K₁)) (ne₌ M D′ neM K≡M)
                 rewrite whrDet* (red D , ne neK) (red D₁ , ne neK₁) =
    ne₌ M D′ neM K≡M
  irrelevanceEqT {Γ} {r = r} (Πᵥ (Πᵣ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
                         (Πᵣ rF₁ lF₁ lG₁ _ _ F₁ G₁ D₁ ⊢F₁ ⊢G₁ A≡A₁ [F]₁ [G]₁ G-ext₁))
                 (Π₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) =
    let ΠFG≡ΠF₁G₁   = whrDet* (red D , Πₙ) (red D₁ , Πₙ)
        F≡F₁ , rF≡rF₁ , lF≡lF₁ , G≡G₁ , lG≡lG₁ , lΠ≡lΠ₁ = Π-PE-injectivity ΠFG≡ΠF₁G₁
    in  Π₌ F′ G′ (PE.subst₃ _ rF≡rF₁ lF≡lF₁ lG≡lG₁ D′)
        (PE.subst5 (λ x rx lx lx' lx'' → Γ ⊢ x ≅ Π F′ ^ rx ° lx ▹ G′ ° lx' ° lx'' ^ r) ΠFG≡ΠF₁G₁ rF≡rF₁ lF≡lF₁ lG≡lG₁ lΠ≡lΠ₁ A≡B)
           (λ {ρ} [ρ] ⊢Δ → irrelevanceEq′ (PE.cong (wk ρ) F≡F₁) rF≡rF₁ (PE.cong ι lF≡lF₁) ([F] [ρ] ⊢Δ)
                                          ([F]₁ [ρ] ⊢Δ)
                                          ([F≡F′] [ρ] ⊢Δ))
           (λ {ρ} [ρ] ⊢Δ [a]₁ →
              let [a] = irrelevanceTerm′ (PE.cong (wk ρ) (PE.sym F≡F₁)) (PE.sym rF≡rF₁) (PE.cong ι (PE.sym lF≡lF₁))
                                         ([F]₁ [ρ] ⊢Δ)
                                         ([F] [ρ] ⊢Δ)
                                         [a]₁
              in  irrelevanceEq′ (PE.cong (λ y → wk (lift ρ) y [ _ ]) G≡G₁) PE.refl (PE.cong ι lG≡lG₁)
                                 ([G] [ρ] ⊢Δ [a]) ([G]₁ [ρ] ⊢Δ [a]₁) ([G≡G′] [ρ] ⊢Δ [a]))
  irrelevanceEqT {Γ} {r = r} (∃ᵥ (∃ᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
                         (∃ᵣ F₁ G₁ D₁ ⊢F₁ ⊢G₁ A≡A₁ [F]₁ [G]₁ G-ext₁))
                 (∃₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) =
    let ∃FG≡∃F₁G₁   = whrDet* (red D , ∃ₙ) (red D₁ , ∃ₙ)
        F≡F₁ , G≡G₁ = ∃-PE-injectivity ∃FG≡∃F₁G₁
    in  ∃₌ F′ G′ D′
    (PE.subst (λ x → Γ ⊢ x ≅ ∃ F′ ▹ G′ ^ r) ∃FG≡∃F₁G₁ A≡B)
           (λ {ρ} [ρ] ⊢Δ → irrelevanceEq′ (PE.cong (wk ρ) F≡F₁) PE.refl PE.refl ([F] [ρ] ⊢Δ)
                                          ([F]₁ [ρ] ⊢Δ)
                                          ([F≡F′] [ρ] ⊢Δ))
           (λ {ρ} [ρ] ⊢Δ [a]₁ →
              let [a] = irrelevanceTerm′ (PE.cong (wk ρ) (PE.sym F≡F₁)) (PE.refl) (PE.refl)
                                         ([F]₁ [ρ] ⊢Δ)
                                         ([F] [ρ] ⊢Δ)
                                         [a]₁
              in  irrelevanceEq′ (PE.cong (λ y → wk (lift ρ) y [ _ ]) G≡G₁) PE.refl PE.refl
                                 ([G] [ρ] ⊢Δ [a]) ([G]₁ [ρ] ⊢Δ [a]₁) ([G≡G′] [ρ] ⊢Δ [a]))
  irrelevanceEqT (Uᵥ (Uᵣ _ _ _ PE.refl D) (Uᵣ _ _ _ e D')) A≡B = let U≡U  = whrDet* (red D , Uₙ) (red D' , Uₙ) in
                                                                let r≡r , l≡l = Univ-PE-injectivity U≡U in
                                                                 PE.subst _ l≡l (PE.subst _ r≡r A≡B)
  irrelevanceEqT (emb⁰¹ x) A≡B = irrelevanceEqT x A≡B
  irrelevanceEqT (emb¹⁰ x) A≡B = irrelevanceEqT x A≡B
  irrelevanceEqT (emb¹∞ x) A≡B = irrelevanceEqT x A≡B
  irrelevanceEqT (emb∞¹ x) A≡B = irrelevanceEqT x A≡B

  irrelevance-level : ∀ {A Γ r l l'}
                    → l <∞ l'
                    → Γ ⊩⟨ l ⟩ A ^ r
                    → Γ ⊩⟨ l' ⟩ A ^ r
  irrelevance-level l< (ℕᵣ x) = ℕᵣ x
  irrelevance-level l< (Emptyᵣ x) = Emptyᵣ x
  irrelevance-level l< (ne x) = ne x
  irrelevance-level l< (Πᵣ′ rF lF lG lF≤ lG≤ F G D ⊢F ⊢G A≡A [F] [G] G-ext) = Πᵣ′ rF lF lG lF≤ lG≤ F G D ⊢F ⊢G A≡A (λ x ⊢Δ → irrelevance-level l< ([F] x ⊢Δ ))
                                                                          (λ [ρ] ⊢Δ x → irrelevance-level l< ([G] [ρ] ⊢Δ
                                                                             (irrelevanceTerm (irrelevance-level l< ([F] [ρ] ⊢Δ)) ([F] [ρ] ⊢Δ) x)))
                                                                           λ [ρ] ⊢Δ [a] [b] x →
                                                                           irrelevanceEq
                                                                                ([G] [ρ] ⊢Δ (irrelevanceTerm (irrelevance-level l< ([F] [ρ] ⊢Δ)) ([F] [ρ] ⊢Δ) [a]))
                                                                                (irrelevance-level l< ([G] [ρ] ⊢Δ (irrelevanceTerm (irrelevance-level l< ([F] [ρ] ⊢Δ)) ([F] [ρ] ⊢Δ) [a])))
                                                                                (G-ext [ρ] ⊢Δ (irrelevanceTerm (irrelevance-level l< ([F] [ρ] ⊢Δ)) ([F] [ρ] ⊢Δ) [a])
                                                                                (irrelevanceTerm (irrelevance-level l< ([F] [ρ] ⊢Δ)) ([F] [ρ] ⊢Δ) [b])
                                                                                (irrelevanceEqTerm (irrelevance-level l< ([F] [ρ] ⊢Δ )) ([F] [ρ] ⊢Δ) x))
  irrelevance-level l< (∃ᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext) = ∃ᵣ′ F G D ⊢F ⊢G A≡A (λ x ⊢Δ → irrelevance-level l< ([F] x ⊢Δ ))
                                                                          (λ [ρ] ⊢Δ x → irrelevance-level l< ([G] [ρ] ⊢Δ
                                                                             (irrelevanceTerm (irrelevance-level l< ([F] [ρ] ⊢Δ)) ([F] [ρ] ⊢Δ) x)))
                                                                           λ [ρ] ⊢Δ [a] [b] x →
                                                                           irrelevanceEq
                                                                                ([G] [ρ] ⊢Δ (irrelevanceTerm (irrelevance-level l< ([F] [ρ] ⊢Δ)) ([F] [ρ] ⊢Δ) [a]))
                                                                                (irrelevance-level l< ([G] [ρ] ⊢Δ (irrelevanceTerm (irrelevance-level l< ([F] [ρ] ⊢Δ)) ([F] [ρ] ⊢Δ) [a])))
                                                                                (G-ext [ρ] ⊢Δ (irrelevanceTerm (irrelevance-level l< ([F] [ρ] ⊢Δ)) ([F] [ρ] ⊢Δ) [a])
                                                                                (irrelevanceTerm (irrelevance-level l< ([F] [ρ] ⊢Δ)) ([F] [ρ] ⊢Δ) [b])
                                                                                (irrelevanceEqTerm (irrelevance-level l< ([F] [ρ] ⊢Δ )) ([F] [ρ] ⊢Δ) x))
  irrelevance-level {r = [ .! , ll ]} ∞< (Uᵣ (Uᵣ r .⁰ emb< eq d)) = emb ∞< (Uᵣ (Uᵣ r _ emb< eq d))
  irrelevance-level ∞< (emb emb< [A]) = emb ∞< (emb emb< [A])

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

  -- Irrelevance for terms
  irrelevanceTerm : ∀ {Γ A t r l l′} (p : Γ ⊩⟨ l ⟩ A ^ r) (q : Γ ⊩⟨ l′ ⟩ A ^ r)
                  → Γ ⊩⟨ l ⟩ t ∷ A ^ r / p → Γ ⊩⟨ l′ ⟩ t ∷ A ^ r / q
  irrelevanceTerm p q t = irrelevanceTermT (goodCasesRefl p q) t

  -- Irrelevance for terms with propositionally equal types
  irrelevanceTerm′ : ∀ {Γ A A′ t r r' l l′ ll ll'} (eq : A PE.≡ A′) (req : r PE.≡ r') (leq : ll PE.≡ ll')
                     (p : Γ ⊩⟨ l ⟩ A ^ [ r , ll ]) (q : Γ ⊩⟨ l′ ⟩ A′ ^ [ r' , ll' ])
                   → Γ ⊩⟨ l ⟩ t ∷ A ^ [ r , ll ] / p → Γ ⊩⟨ l′ ⟩ t ∷ A′ ^ [ r' , ll' ] / q
  irrelevanceTerm′ PE.refl PE.refl PE.refl p q t = irrelevanceTerm p q t

  -- Irrelevance for terms with propositionally equal types and terms
  irrelevanceTerm″ : ∀ {Γ A A′ t t′ r r' ll ll' l l′}
                      (eqA : A PE.≡ A′) (req : r PE.≡ r') (leq : ll PE.≡ ll') (eqt : t PE.≡ t′)
                      (p : Γ ⊩⟨ l ⟩ A ^ [ r , ll ]) (q : Γ ⊩⟨ l′ ⟩ A′ ^ [ r' , ll' ])
                    → Γ ⊩⟨ l ⟩ t ∷ A ^ [ r , ll ] / p → Γ ⊩⟨ l′ ⟩ t′ ∷ A′ ^ [ r' , ll' ] / q
  irrelevanceTerm″ PE.refl PE.refl PE.refl PE.refl p q t = irrelevanceTerm p q t

  -- Irrelevance for terms with propositionally equal types, terms and contexts
  irrelevanceTermΓ″ : ∀ {l l′ A A′ t t′ r Γ Γ′}
                     → Γ PE.≡ Γ′
                     → A PE.≡ A′
                     → t PE.≡ t′
                     → ([A]  : Γ  ⊩⟨ l  ⟩ A ^ r)
                       ([A′] : Γ′ ⊩⟨ l′ ⟩ A′ ^ r)
                     → Γ  ⊩⟨ l  ⟩ t ∷ A ^ r / [A]
                     → Γ′ ⊩⟨ l′ ⟩ t′ ∷ A′ ^ r / [A′]
  irrelevanceTermΓ″ PE.refl PE.refl PE.refl [A] [A′] [t] = irrelevanceTerm [A] [A′] [t]

  -- Helper for irrelevance of terms using shape view
  irrelevanceTermT : ∀ {Γ A t r l l′} {p : Γ ⊩⟨ l ⟩ A ^ r} {q : Γ ⊩⟨ l′ ⟩ A ^ r}
                         → ShapeView Γ l l′ A A r r p q
                         → Γ ⊩⟨ l ⟩ t ∷ A ^ r / p → Γ ⊩⟨ l′ ⟩ t ∷ A ^ r / q
  irrelevanceTermT (ℕᵥ D D′) t = t
  irrelevanceTermT (Emptyᵥ D D′) t = t
  irrelevanceTermT { r = [ ! , ll ]  } (ne (ne K D neK K≡K) (ne K₁ D₁ neK₁ K≡K₁)) (neₜ k d nf)
                   with whrDet* (red D₁ , ne neK₁) (red D , ne neK)
  irrelevanceTermT {r = [ ! , ll ]} (ne (ne K D neK K≡K) (ne .K D₁ neK₁ K≡K₁)) (neₜ k d nf)
    | PE.refl = neₜ k d nf
  irrelevanceTermT { r = [ % , ll ] } (ne (ne K D neK K≡K) (ne K₁ D₁ neK₁ K≡K₁)) (neₜ d)
                   with whrDet* (red D₁ , ne neK₁) (red D , ne neK)
  irrelevanceTermT {r = [ % , ll ]} (ne (ne K D neK K≡K) (ne .K D₁ neK₁ K≡K₁)) (neₜ d)
    | PE.refl = neₜ d
  irrelevanceTermT {Γ} {t = t} {r = [ ! , ll ]} (Πᵥ (Πᵣ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
                                   (Πᵣ rF₁ lF₁ lG₁ _ _ F₁ G₁ D₁ ⊢F₁ ⊢G₁ A≡A₁ [F]₁ [G]₁ G-ext₁))
                   (Πₜ f d funcF f≡f [f] [f]₁) =
    let ΠFG≡ΠF₁G₁   = whrDet* (red D , Πₙ) (red D₁ , Πₙ)
        F≡F₁ , rF≡rF₁ , lF≡lF₁ , G≡G₁ , lG≡lG₁ , lΠ≡lΠ₁ = Π-PE-injectivity ΠFG≡ΠF₁G₁
    in  Πₜ f (PE.subst (λ x → Γ ⊢ t :⇒*: f ∷ x ^ ll) ΠFG≡ΠF₁G₁ d) funcF
           (PE.subst (λ x → Γ ⊢ f ≅ f ∷ x ^ [ ! , ll ]) ΠFG≡ΠF₁G₁ f≡f)
           (λ {ρ} [ρ] ⊢Δ [a]₁ [b]₁ [a≡b]₁ →
              let [a]   = irrelevanceTerm′ (PE.cong (wk ρ) (PE.sym F≡F₁)) (PE.sym rF≡rF₁) (PE.cong ι (PE.sym lF≡lF₁))
                                           ([F]₁ [ρ] ⊢Δ)
                                           ([F] [ρ] ⊢Δ)
                                           [a]₁
                  [b]   = irrelevanceTerm′ (PE.cong (wk ρ) (PE.sym F≡F₁)) (PE.sym rF≡rF₁) (PE.cong ι (PE.sym lF≡lF₁))
                                           ([F]₁ [ρ] ⊢Δ)
                                           ([F] [ρ] ⊢Δ)
                                           [b]₁
                  [a≡b] = irrelevanceEqTerm′ (PE.cong (wk ρ) (PE.sym F≡F₁)) (PE.sym rF≡rF₁) (PE.cong ι (PE.sym lF≡lF₁))
                                             ([F]₁ [ρ] ⊢Δ)
                                             ([F] [ρ] ⊢Δ)
                                             [a≡b]₁
              in  irrelevanceEqTerm′ (PE.cong (λ G → wk (lift ρ) G [ _ ]) G≡G₁) PE.refl (PE.cong ι lG≡lG₁)
                                     ([G] [ρ] ⊢Δ [a]) ([G]₁ [ρ] ⊢Δ [a]₁)
                                     ([f] [ρ] ⊢Δ [a] [b] [a≡b]))
          (λ {ρ} [ρ] ⊢Δ [a]₁ →
             let [a] = irrelevanceTerm′ (PE.cong (wk ρ) (PE.sym F≡F₁)) (PE.sym rF≡rF₁) (PE.cong ι (PE.sym lF≡lF₁))
                                        ([F]₁ [ρ] ⊢Δ)
                                        ([F] [ρ] ⊢Δ)
                                        [a]₁
             in  irrelevanceTerm′ (PE.cong (λ G → wk (lift ρ) G [ _ ]) G≡G₁) PE.refl (PE.cong ι lG≡lG₁)
                                  ([G] [ρ] ⊢Δ [a]) ([G]₁ [ρ] ⊢Δ [a]₁) ([f]₁ [ρ] ⊢Δ [a]))
  irrelevanceTermT {Γ} {t = t} {r = [ % , ll ]} (Πᵥ (Πᵣ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
                                   (Πᵣ rF₁ lF₁ lG₁ _ _ F₁ G₁ D₁ ⊢F₁ ⊢G₁ A≡A₁ [F]₁ [G]₁ G-ext₁))
                  d = let ΠFG≡ΠF₁G₁   = whrDet* (red D , Πₙ) (red D₁ , Πₙ)
                       in PE.subst (λ x → Γ ⊢ t ∷ x ^ [ % , ll ]) ΠFG≡ΠF₁G₁ d
  irrelevanceTermT {Γ} {t = t} {r = [ % , ll ]} (∃ᵥ (∃ᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
                                   (∃ᵣ  F₁ G₁ D₁ ⊢F₁ ⊢G₁ A≡A₁ [F]₁ [G]₁ G-ext₁))
                   d = let ∃FG≡∃F₁G₁   = whrDet* (red D , ∃ₙ) (red D₁ , ∃ₙ)
                       in PE.subst (λ x → Γ ⊢ t ∷ x ^ [ % , ll ]) ∃FG≡∃F₁G₁ d
  irrelevanceTermT (Uᵥ (Uᵣ r ll l< PE.refl D) (Uᵣ r' ll' l<' _ D')) t =
    let U≡U   = whrDet* (red D , Uₙ) (red D' , Uₙ)
        r≡r , l≡l = Univ-PE-injectivity U≡U
    in reduction-irrelevant-Univ r≡r t
  irrelevanceTermT (emb⁰¹ x) t = irrelevanceTermT x t
  irrelevanceTermT (emb¹⁰ x) t = irrelevanceTermT x t
  irrelevanceTermT (emb¹∞ x) t = irrelevanceTermT x t
  irrelevanceTermT (emb∞¹ x) t = irrelevanceTermT x t

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

  -- Irrelevance for term equality
  irrelevanceEqTerm : ∀ {Γ A t u r l l′} (p : Γ ⊩⟨ l ⟩ A ^ r) (q : Γ ⊩⟨ l′ ⟩ A ^ r)
                    → Γ ⊩⟨ l ⟩ t ≡ u ∷ A ^ r / p → Γ ⊩⟨ l′ ⟩ t ≡ u ∷ A ^ r / q
  irrelevanceEqTerm p q t≡u = irrelevanceEqTermT (goodCasesRefl p q) t≡u

  -- Irrelevance for term equality with propositionally equal types
  irrelevanceEqTerm′ : ∀ {Γ A A′ t u r r' l l′ ll ll'} (eq : A PE.≡ A′) (req : r PE.≡ r') (leq : ll PE.≡ ll')
                       (p : Γ ⊩⟨ l ⟩ A ^ [ r , ll ]) (q : Γ ⊩⟨ l′ ⟩ A′ ^ [ r' , ll' ])
                     → Γ ⊩⟨ l ⟩ t ≡ u ∷ A ^ [ r , ll ] / p → Γ ⊩⟨ l′ ⟩ t ≡ u ∷ A′ ^ [ r' , ll' ] / q
  irrelevanceEqTerm′ PE.refl PE.refl PE.refl p q t≡u = irrelevanceEqTerm p q t≡u

  -- Irrelevance for term equality with propositionally equal types and terms
  irrelevanceEqTerm″ : ∀ {Γ A A′ t t′ u u′ r r' ll ll' l l′} (req : r PE.≡ r') (leq : ll PE.≡ ll')
                        (eqt : t PE.≡ t′) (equ : u PE.≡ u′) (eqA : A PE.≡ A′)
                        (p : Γ ⊩⟨ l ⟩ A ^ [ r , ll ]) (q : Γ ⊩⟨ l′ ⟩ A′ ^ [ r' , ll' ])
                      → Γ ⊩⟨ l ⟩ t ≡ u ∷ A ^ [ r , ll ] / p → Γ ⊩⟨ l′ ⟩ t′ ≡ u′ ∷ A′ ^ [ r' , ll' ] / q
  irrelevanceEqTerm″ PE.refl PE.refl PE.refl PE.refl PE.refl p q t≡u = irrelevanceEqTerm p q t≡u

  -- Helper for irrelevance of term equality using shape view
  irrelevanceEqTermT : ∀ {Γ A t u r} {l l′} {p : Γ ⊩⟨ l ⟩ A ^ r} {q : Γ ⊩⟨ l′ ⟩ A ^ r}
                           → ShapeView Γ l l′ A A r r p q
                           → Γ ⊩⟨ l ⟩ t ≡ u ∷ A ^ r / p → Γ ⊩⟨ l′ ⟩ t ≡ u ∷ A ^ r / q
  irrelevanceEqTermT (ℕᵥ D D′) t≡u = t≡u
  irrelevanceEqTermT (Emptyᵥ D D′) t≡u = t≡u
  irrelevanceEqTermT { r = [ ! , ll ] } (ne (ne K D neK K≡K) (ne K₁ D₁ neK₁ K≡K₁)) (neₜ₌ k m d d′ nf)
                     with whrDet* (red D₁ , ne neK₁) (red D , ne neK)
  irrelevanceEqTermT (ne (ne K D neK K≡K) (ne .K D₁ neK₁ K≡K₁)) (neₜ₌ k m d d′ nf)
    | PE.refl = neₜ₌ k m d d′ nf
  irrelevanceEqTermT { r = [ % , ll ] } (ne (ne K D neK K≡K) (ne K₁ D₁ neK₁ K≡K₁)) (neₜ₌ d d′)
                     with whrDet* (red D₁ , ne neK₁) (red D , ne neK)
  irrelevanceEqTermT (ne (ne K D neK K≡K) (ne .K D₁ neK₁ K≡K₁)) (neₜ₌ d d′)
    | PE.refl = neₜ₌ d d′
  irrelevanceEqTermT {Γ} {t = t} {u = u} {r = [ ! , ll ]}
                     (Πᵥ (Πᵣ rF lF lG lF≤ lG≤ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
                         (Πᵣ rF₁ lF₁ lG₁ lF₁≤ lG₁≤ F₁ G₁ D₁ ⊢F₁ ⊢G₁ A≡A₁ [F]₁ [G]₁ G-ext₁))
                     (Πₜ₌ f g d d′ funcF funcG f≡g [f] [g] [f≡g]) =
    let ΠFG≡ΠF₁G₁   = whrDet* (red D , Πₙ) (red D₁ , Πₙ)
        F≡F₁ , rF≡rF₁ , lF≡lF₁ , G≡G₁ , lG≡lG₁ , lΠ≡lΠ₁ = Π-PE-injectivity ΠFG≡ΠF₁G₁
        [A]         = Πᵣ′ rF lF lG lF≤ lG≤ F G D ⊢F ⊢G A≡A [F] [G] G-ext
        [A]₁        = Πᵣ′ rF₁ lF₁ lG₁ lF₁≤ lG₁≤ F₁ G₁ D₁ ⊢F₁ ⊢G₁ A≡A₁ [F]₁ [G]₁ G-ext₁
    in  Πₜ₌ f g (PE.subst (λ x → Γ ⊢ t :⇒*: f ∷ x ^ ll) ΠFG≡ΠF₁G₁ d)
            (PE.subst (λ x → Γ ⊢ u :⇒*: g ∷ x ^ ll) ΠFG≡ΠF₁G₁ d′) funcF funcG
            (PE.subst (λ x → Γ ⊢ f ≅ g ∷ x ^ [ ! , ll ]) ΠFG≡ΠF₁G₁ f≡g)
            (irrelevanceTerm [A] [A]₁ [f]) (irrelevanceTerm [A] [A]₁ [g])
            (λ {ρ} [ρ] ⊢Δ [a]₁ →
               let [a] = irrelevanceTerm′ (PE.cong (wk ρ) (PE.sym F≡F₁)) (PE.sym rF≡rF₁) (PE.cong ι (PE.sym lF≡lF₁))
                                          ([F]₁ [ρ] ⊢Δ)
                                          ([F] [ρ] ⊢Δ)
                                          [a]₁
               in  irrelevanceEqTerm′ (PE.cong (λ G → wk (lift ρ) G [ _ ]) G≡G₁) PE.refl (PE.cong ι lG≡lG₁)
                                     ([G] [ρ] ⊢Δ [a]) ([G]₁ [ρ] ⊢Δ [a]₁) ([f≡g] [ρ] ⊢Δ [a]))
  irrelevanceEqTermT {Γ} {t = t} {u = u} {r = [ % , ll ]}
                     (Πᵥ (Πᵣ rF lF lG _ _ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
                         (Πᵣ rF₁ lF₁ lG₁ _ _ F₁ G₁ D₁ ⊢F₁ ⊢G₁ A≡A₁ [F]₁ [G]₁ G-ext₁))
                     (d , d′) = let ΠFG≡ΠF₁G₁   = whrDet* (red D , Πₙ) (red D₁ , Πₙ) in
                                (PE.subst (λ x → Γ ⊢ t ∷ x ^ [ % , ll ]) ΠFG≡ΠF₁G₁ d , PE.subst (λ x → Γ ⊢ u ∷ x ^ [ % , ll ]) ΠFG≡ΠF₁G₁ d′)
  irrelevanceEqTermT {Γ} {t = t} {u = u} {r = [ % , ll ]}
                     (∃ᵥ (∃ᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
                         (∃ᵣ F₁ G₁ D₁ ⊢F₁ ⊢G₁ A≡A₁ [F]₁ [G]₁ G-ext₁))
                     (d , d′) = let ∃FG≡∃F₁G₁   = whrDet* (red D , ∃ₙ) (red D₁ , ∃ₙ) in
                                (PE.subst (λ x → Γ ⊢ t ∷ x ^ [ % , ll ]) ∃FG≡∃F₁G₁ d , PE.subst (λ x → Γ ⊢ u ∷ x ^ [ % , ll ]) ∃FG≡∃F₁G₁ d′)
  irrelevanceEqTermT (Uᵥ (Uᵣ r ll l< PE.refl D) (Uᵣ r' ll' l<' _ D')) t =
    let U≡U   = whrDet* (red D , Uₙ) (red D' , Uₙ)
        r≡r , l≡l = Univ-PE-injectivity U≡U
    in reduction-irrelevant-Univ= r≡r t
  irrelevanceEqTermT (emb⁰¹ x) t≡u = irrelevanceEqTermT x t≡u
  irrelevanceEqTermT (emb¹⁰ x) t≡u = irrelevanceEqTermT x t≡u
  irrelevanceEqTermT (emb¹∞ x) t≡u = irrelevanceEqTermT x t≡u
  irrelevanceEqTermT (emb∞¹ x) t≡u = irrelevanceEqTermT x t≡u

irrelevance-≤ : ∀ {A Γ r l l'}
                  → l ≤ l'
                  → Γ ⊩⟨ ι l ⟩ A ^ r
                  → Γ ⊩⟨ ι l' ⟩ A ^ r
irrelevance-≤ (<is≤ 0<1) [A] = irrelevance-level emb< [A]
irrelevance-≤ (≡is≤ PE.refl) [A] = [A]


module ReCaseSplit where

data Bool : Set where
  true : Bool
  false : Bool
  maybe : Bool

_func : Bool -> Bool
maybe func = ?
false func  = false
(true) func  = true

func2 : Bool -> Bool
func2 = λ{false → false ; (true) → true}

open import IO.Primitive

func3 : IO Bool
func3 = return false

func4 : IO Bool
func4 = do
  false <- func3
    where true -> return true
  return false

module SubModule where

 func5 : Bool -> Bool
 func5 maybe = ?
 func5 false = false
 func5 true =  func6 true
    where func6 : Bool -> Bool
          func6 maybe = ?
          func6 false = false
          func6 true = true


open import Agda.Builtin.Reflection
open import Agda.Builtin.Nat
open import Agda.Builtin.Unit
open import Agda.Builtin.List
open import Agda.Builtin.Equality

magic : Nat
magic = 666

macro
  by-magic : Term → TC ⊤
  by-magic hole = unify hole (def (quote magic) [])

  meta-magic : Term → TC ⊤
  meta-magic hole = unify hole (def (quote by-magic) [])

test : Nat
test = meta-magic

check : test ≡ 666
check = refl


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

open import lib.Base
open import lib.PathGroupoid
open import lib.Relation

module lib.NType where

module _ {i} where

  {- Definition of contractible types and truncation levels -}

  -- We define `has-level' as a record, so that it does not unfold when
  -- applied to (S n), in order for instance arguments to work correctly
  -- (idea by Dan Licata)
  record has-level (n : ℕ₋₂) (A : Type i) : Type i

  has-level-aux : ℕ₋₂ → (Type i → Type i)
  has-level-aux ⟨-2⟩ A = Σ A (λ x → ((y : A) → x == y))
  has-level-aux (S n) A = (x y : A) → has-level n (x == y)

  record has-level n A where
    -- Agda notices that the record is recursive, so we need to specify that we want eta-equality
    inductive
    eta-equality
    constructor has-level-in
    field
      has-level-apply : has-level-aux n A
  open has-level public

  instance
    has-level-apply-instance : {A : Type i} {n : ℕ₋₂} {x y : A} {{p : has-level (S n) A}} → has-level n (x == y)
    has-level-apply-instance {x = x} {y} {{p}} = has-level-apply p x y

  is-contr = has-level -2
  is-prop = has-level -1
  is-set  = has-level 0

  contr-center : {A : Type i} (p : is-contr A) → A
  contr-center p = fst (has-level-apply p)

  contr-path : {A : Type i} (p : is-contr A) (y : A) → contr-center p == y
  contr-path p y = snd (has-level-apply p) y

  prop-path : {A : Type i} (p : is-prop A) (x y : A) → x == y
  prop-path p x y = contr-center (has-level-apply p x y)

  {- To be a mere proposition, it is sufficient that all points are equal -}

  has-all-paths : Type i → Type i
  has-all-paths A = (x y : A) → x == y

  abstract
    all-paths-is-prop : {A : Type i} → (has-all-paths A → is-prop A)
    all-paths-is-prop {A} c = has-level-in (λ x y → has-level-in (c x y , canon-path)) where

      canon-path : {x y : A} (p : x == y) → c x y == p
      canon-path {.y} {y} idp =
        c y y               =⟨ lemma (! (c y y)) ⟩
        (! (c y y)) ∙ c y y =⟨ !-inv-l (c y y) ⟩
        idp =∎  where

        lemma : {x y : A} (p : x == y) → c x y == p ∙ c y y
        lemma idp = idp

  {- Truncation levels are cumulative -}
  raise-level : {A : Type i} (n : ℕ₋₂)
    → (has-level n A → has-level (S n) A)
  raise-level ⟨-2⟩ q =
    all-paths-is-prop (λ x y → ! (contr-path q x) ∙ contr-path q y)
  raise-level (S n) q =
    has-level-in (λ x y → raise-level n (has-level-apply q x y))

  {- Having decidable equality is stronger that being a set -}

  has-dec-onesided-eq : {A : Type i} → A → Type i
  has-dec-onesided-eq x = ∀ y → Dec (x == y)

  has-dec-eq : Type i → Type i
  has-dec-eq A = (x : A) → has-dec-onesided-eq x

  abstract
    -- XXX naming
    dec-onesided-eq-is-prop : {A : Type i} (x : A)
      → has-dec-onesided-eq x → (∀ y → is-prop (x == y))
    dec-onesided-eq-is-prop {A} x d y = all-paths-is-prop UIP where

      T : {y : A} → x == y → Type i
      T {y} p with d x | d y
      T {y} p | inr _  | _      = Lift ⊥
      T {y} p | inl _  | inr _  = Lift ⊥
      T {y} p | inl dx | inl dy = ! dx ∙ dy == p

      lemma : {y : A} → (p : x == y) → T p
      lemma idp with d x
      lemma idp | inl r  = !-inv-l r
      lemma idp | inr r⊥ = lift (r⊥ idp)

      UIP : {y : A} (p q : x == y) → p == q
      UIP idp q with d x | lemma q
      UIP idp q | inl r  | s = ! (!-inv-l r) ∙' s
      UIP idp q | inr r⊥ | _ = Empty-elim (r⊥ idp)

    dec-eq-is-set : {A : Type i} → has-dec-eq A → is-set A
    dec-eq-is-set d = has-level-in (λ x y → dec-onesided-eq-is-prop x (d x) y)

  {- Relationships between levels -}

  module _ {A : Type i} where
    abstract
      contr-has-all-paths : {{_ : is-contr A}} → has-all-paths A
      contr-has-all-paths {{c}} x y = ! (contr-path c x) ∙ contr-path c y

      prop-has-all-paths : {{_ : is-prop A}} → has-all-paths A
      prop-has-all-paths {{c}} x y = prop-path c x y

      inhab-prop-is-contr : A → {{_ : is-prop A}} → is-contr A
      inhab-prop-is-contr x₀ {{p}} = has-level-in (x₀ , λ y → prop-path p x₀ y)

      inhab-to-contr-is-prop : (A → is-contr A) → is-prop A
      inhab-to-contr-is-prop c = all-paths-is-prop $
        λ x y → ! (contr-path (c x) x) ∙ contr-path (c x) y

      inhab-to-prop-is-prop : (A → is-prop A) → is-prop A
      inhab-to-prop-is-prop c = has-level-in (λ x y → has-level-apply (c x) x y)

      contr-has-level : {n : ℕ₋₂} → (is-contr A → has-level n A)
      contr-has-level {n = ⟨-2⟩} p = p
      contr-has-level {n = S n} p = raise-level n (contr-has-level p)

      prop-has-level-S : {n : ℕ₋₂} → (is-prop A → has-level (S n) A)
      prop-has-level-S {n = ⟨-2⟩} p = p
      prop-has-level-S {n = S n} p = raise-level (S n) (prop-has-level-S p)

      set-has-level-SS : {n : ℕ₋₂} → (is-set A → has-level (S (S n)) A)
      set-has-level-SS {n = ⟨-2⟩} p = p
      set-has-level-SS {n = S n} p = raise-level (S (S n)) (set-has-level-SS p)

      contr-is-prop : is-contr A → is-prop A
      contr-is-prop = contr-has-level

      contr-is-set : is-contr A → is-set A
      contr-is-set = contr-has-level

      prop-is-set : is-prop A → is-set A
      prop-is-set = prop-has-level-S

      =-preserves-contr : {x y : A} → is-contr A → is-contr (x == y)
      =-preserves-contr p = has-level-in (contr-has-all-paths {{p}} _ _ , unique-path) where
          unique-path : {u v : A} (q : u == v)
            → contr-has-all-paths {{p}} u v == q
          unique-path idp = !-inv-l (contr-path p _)

    {- If [A] has level [n], then so does [x == y] for [x y : A] -}
    instance
      =-preserves-level : {n : ℕ₋₂} {x y : A}
        → has-level n A → has-level n (x == y)
      =-preserves-level {⟨-2⟩} = =-preserves-contr
      =-preserves-level {S n} {x} {y} p = raise-level n (has-level-apply p x y)

    {- The type of paths from a fixed point is contractible -}
    instance
      pathfrom-is-contr : (x : A) → is-contr (Σ A (λ t → x == t))
      pathfrom-is-contr x = has-level-in ((x , idp) , pathfrom-unique-path) where
        pathfrom-unique-path : {u : A} (pp : Σ A (λ t → u == t)) → (u , idp) == pp
        pathfrom-unique-path (u , idp) = idp

    {- The type of paths to a fixed point is contractible -}
    instance
      pathto-is-contr : (x : A) → is-contr (Σ A (λ t → t == x))
      pathto-is-contr x = has-level-in ((x , idp) , pathto-unique-path) where
        pathto-unique-path : {u : A} (pp : Σ A (λ t → t == u)) → (u , idp) == pp
        pathto-unique-path (u , idp) = idp

    {-
    If [B] is a fibration over a contractible type [A], then any point in any
    fiber of [B] gives a section
    -}
    contr-has-section : ∀ {j} {A : Type i} {B : A → Type j}
      → (is-contr A → (x : A) → (u : B x) → Π A B)
    contr-has-section {B = B} p x₀ y₀ t = transport B (! (contr-path p x₀) ∙ contr-path p t) y₀

{- Subtypes -}

-- TODO: replace them by records, with the second field an instance field

module _ {i} (A : Type i) where
  SubtypeProp : ∀ j → Type (lmax i (lsucc j))
  SubtypeProp j = Σ (A → Type j) (λ P → ∀ a → is-prop (P a))

module SubtypeProp {i j} {A : Type i} (P : SubtypeProp A j) where
  prop = fst P
  level = snd P

module _ {i j} {A : Type i} (P : SubtypeProp A j) where
  private
    module P = SubtypeProp P

  Subtype : Type (lmax i j)
  Subtype = Σ A P.prop


-- {-# OPTIONS --show-implicit --show-irrelevant #-}
module Data.QuadTree.FoldableProofs.FoldableProof where

open import Haskell.Prelude renaming (zero to Z; suc to S)
open import Data.Logic
open import Data.QuadTree.Implementation.Definition
open import Data.QuadTree.Implementation.ValidTypes
open import Data.QuadTree.Implementation.QuadrantLenses
open import Data.QuadTree.Implementation.SafeFunctions
open import Data.QuadTree.Implementation.PropDepthRelation
open import Data.QuadTree.Implementation.Foldable

-- All proofs for Foldables

-- foldr f z t = appEndo (foldMap (Endo . f) t ) z
-- foldl f z t = appEndo (getDual (foldMap (Dual . Endo . flip f) t)) z
-- fold = foldMap id
-- length = getSum . foldMap (Sum . const 1)
-- I didn't change the default implementations of foldl/foldr/fold/length, so these laws should all hold

-- However, I will proof that the length of the quadtree is equal to width * height.
-- lengthₑ quadtreeFoldable vqt ≡ size vqt

size : {t : Set} {{eqT : Eq t}} {dep : Nat} -> (vqt : VQuadTree t {dep}) -> Nat
size (CVQuadTree (Wrapper (w , h) x₁)) = w * h

lengthₙ : {t : Set → Set} ⦃ r : Foldable t ⦄ {a : Set} → t a → Nat
lengthₙ {{r}} = foldMap {{r}} {{ MonoidSum }} (const 1)

length-replicateₙ : {t : Set} (n : Nat) (v : t) -> lengthₙ (replicateₙ n v) ≡ n
length-replicateₙ {t} Z v = refl
length-replicateₙ {t} (S n) v =
    begin
        lengthₙ (replicateₙ (S n) v)
    =⟨⟩
        S (lengthₙ (replicateₙ n v))
    =⟨ cong S (length-replicateₙ n v ) ⟩
        S n
    end

length-concat-sub : {t : Set} -> (list : List t) (lists : List (List t)) -> lengthₙ (list ++ concat lists) ≡ lengthₙ list + lengthₙ (concat lists)
length-concat-sub {t} [] lists = refl
length-concat-sub {t} (x ∷ xs) lists =
    begin
        lengthₙ ((x ∷ xs) ++ concat lists)
    =⟨⟩
        S (lengthₙ (xs ++ concat lists))
    =⟨ cong S (length-concat-sub xs lists) ⟩
        lengthₙ (x ∷ xs) + lengthₙ (concat lists)
    end

length-concat : {t : Set} -> (lists : List (List t)) -> lengthₙ (concat lists) ≡ sum (map lengthₙ lists)
length-concat {t} [] = refl
length-concat {t} (list ∷ lists) =
    begin
        lengthₙ (concat (list ∷ lists))
    =⟨⟩
        lengthₙ (list ++ concat lists)
    =⟨ length-concat-sub list lists ⟩
        lengthₙ list + lengthₙ (concat lists)
    =⟨ cong (λ q -> lengthₙ list + q) (length-concat lists) ⟩
        lengthₙ list + sum (map lengthₙ lists)
    =⟨⟩
        sum (map lengthₙ (list ∷ lists))
    end

concat-nothing : {t : Set} -> (list : List t) -> list ++ [] ≡ list
concat-nothing [] = refl
concat-nothing (x ∷ list) = cong (λ z → x ∷ z) (concat-nothing list)

diff-n-zero : (n : Nat) -> diff n Z ≡ n
diff-n-zero Z = refl
diff-n-zero (S n) = refl

map-concat : {s t : Set} -> (a b : List s)
    -> (f : s -> t)
    -> map f (a ++ b) ≡ map f a ++ map f b
map-concat [] b f = refl
map-concat (a ∷ as) b f = cong (λ z → f a ∷ z) (map-concat as b f)

map-concat4 : {s t : Set} -> (a b c d : List s)
    -> (f : s -> t)
    -> map f (a ++ b ++ c ++ d) ≡ map f a ++ map f b ++ map f c ++ map f d
map-concat4 a b c d f =
    begin
        map f (a ++ b ++ c ++ d)
    =⟨ map-concat a (b ++ c ++ d) f ⟩
        map f a ++ map f (b ++ c ++ d)
    =⟨ cong (λ q -> map f a ++ q) (map-concat b (c ++ d) f) ⟩
        map f a ++ map f b ++ map f (c ++ d)
    =⟨ cong (λ q -> map f a ++ map f b ++ q) (map-concat c d f) ⟩
        map f a ++ map f b ++ map f c ++ map f d
    end

sum-concat : (a b : List Nat) -> sum (a ++ b) ≡ sum a + sum b
sum-concat [] b = refl
sum-concat (a ∷ as) b =
    begin
        a + sum (as ++ b)
    =⟨ cong (λ q -> a + q) (sum-concat as b) ⟩
        a + (sum as + sum b)
    =⟨ sym $ add-assoc a (sum as) (sum b) ⟩
        sum (a ∷ as) + sum b
    end

sum-concat4 : (a b c d : List Nat) -> sum (a ++ b ++ c ++ d) ≡ sum a + sum b + sum c + sum d
sum-concat4 a b c d =
    begin
        sum (a ++ b ++ c ++ d)
    =⟨ sum-concat a (b ++ c ++ d) ⟩
        sum a + sum (b ++ c ++ d)
    =⟨ cong (λ q -> sum a + q) (sum-concat b (c ++ d)) ⟩
        sum a + (sum b + sum (c ++ d))
    =⟨ cong (λ q -> sum a + (sum b + q)) (sum-concat c d) ⟩
        sum a + (sum b + (sum c + sum d))
    =⟨ sym $ add-assoc (sum a) (sum b) (sum c + sum d) ⟩
        (sum a + sum b) + (sum c + sum d)
    =⟨ sym $ add-assoc (sum a + sum b) (sum c) (sum d) ⟩
        sum a + sum b + sum c + sum d
    end

nat-distributive : (a b c : Nat) -> (a * c) + (b * c) ≡ (a + b) * c
nat-distributive Z b c = refl
nat-distributive (S a) b c =
    begin
        (S a * c) + (b * c)
    =⟨ add-assoc c (a * c) (b * c) ⟩
        c + ((a * c) + b * c)
    =⟨ cong (_+_ c) (nat-distributive a b c) ⟩
        c + ((a + b) * c)
    =⟨⟩
        (S a + b) * c
    end

add-diff : (a b : Nat) -> IsTrue (a <= b) -> a + diff b a ≡ b
add-diff Z Z ab = refl
add-diff Z (S b) ab = refl
add-diff (S a) (S b) ab = cong S (add-diff a b ab)

line-split-left : (x1 xm x2 y : Nat) -> IsTrue (x1 <= xm) -> IsTrue (xm <= x2) -> IsTrue (x1 <= x2)
    -> diff xm x1 * y + diff x2 xm * y ≡ diff x2 x1 * y
line-split-left Z Z Z y x1m xm2 x12 = refl
line-split-left Z Z (S x2) y x1m xm2 x12 = refl
line-split-left Z (S xm) (S x2) y x1m xm2 x12 =
    begin
        (S xm) * y + diff (S x2) (S xm) * y
    =⟨ nat-distributive (S xm) (diff (S x2) (S xm)) y ⟩
        ((S xm) + diff (S x2) (S xm)) * y
    =⟨ cong (λ z → y + (z * y)) (add-diff xm x2 xm2) ⟩
        (S x2) * y
    end
line-split-left (S x1) (S xm) (S x2) y x1m xm2 x12 = line-split-left x1 xm x2 y x1m xm2 x12

line-split-right : (x1 xm x2 y : Nat) -> IsTrue (x1 <= xm) -> IsTrue (xm <= x2) -> IsTrue (x1 <= x2)
    -> y * diff xm x1 + y * diff x2 xm ≡ y * diff x2 x1
line-split-right x1 xm x2 y x1m xm2 x12 =
    begin
        y * diff xm x1 + y * diff x2 xm
    =⟨ cong2 _+_ (mul-comm y (diff xm x1)) (mul-comm y (diff x2 xm)) ⟩
        diff xm x1 * y + diff x2 xm * y
    =⟨ line-split-left x1 xm x2 y x1m xm2 x12 ⟩
        diff x2 x1 * y
    =⟨ mul-comm (diff x2 x1) y ⟩
        y * diff x2 x1
    end

square-split : (x1 y1 xm ym x2 y2 : Nat) -> IsTrue (x1 <= xm) -> IsTrue (xm <= x2) -> IsTrue (y1 <= ym) -> IsTrue (ym <= y2)
    -> diff xm x1 * diff ym y1 + diff x2 xm * diff ym y1 + diff xm x1 * diff y2 ym + diff x2 xm * diff y2 ym ≡ diff x2 x1 * diff y2 y1
square-split x1 y1 xm ym x2 y2 x1m xm2 y1m ym2 =
    begin
        diff xm x1 * diff ym y1 + diff x2 xm * diff ym y1 + diff xm x1 * diff y2 ym + diff x2 xm * diff y2 ym
    =⟨ add-assoc ((diff xm x1 * diff ym y1) + (diff x2 xm * diff ym y1)) (diff xm x1 * diff y2 ym) (diff x2 xm * diff y2 ym) ⟩
        (diff xm x1 * diff ym y1 + diff x2 xm * diff ym y1) + (diff xm x1 * diff y2 ym + diff x2 xm * diff y2 ym)
    =⟨ cong2 _+_
        (line-split-left x1 xm x2 (diff ym y1) x1m xm2 (lteTransitive x1 xm x2 x1m xm2))
        (line-split-left x1 xm x2 (diff y2 ym) x1m xm2 (lteTransitive x1 xm x2 x1m xm2)) ⟩
        (diff x2 x1 * diff ym y1) + (diff x2 x1 * diff y2 ym)
    =⟨ line-split-right y1 ym y2 (diff x2 x1) y1m ym2 (lteTransitive y1 ym y2 y1m ym2) ⟩
        diff x2 x1 * diff y2 y1
    end

min-comb : (a b c : Nat) -> IsTrue (a <= b) -> IsTrue (a <= c) -> IsTrue (a <= min b c)
min-comb a b c ab ac = useEq (sym $
    begin
        a <= min b c
    =⟨ sym $ propFnIf {c = c < b} (_<=_ a) ⟩
        (if _ then a <= c else a <= b)
    =⟨ cong2 (if_then_else_ _) (isTrueToEquiv ac) (isTrueToEquiv ab)  ⟩
        (if _ then true else true)
    =⟨ propIfBranchesSame true ⟩
        true
    end) IsTrue.itsTrue

min-rel-1 : (x1 mid x2 : Nat) -> IsTrue (x1 <= x2) -> IsTrue (x1 <= min x2 (mid + x1))
min-rel-1 x1 mid x2 x12 = min-comb x1 x2 (mid + x1) x12 (lteSumOne x1 x1 mid (lteSelf x1))

min-rel-2 : (a b : Nat) -> IsTrue (min a b <= a)
min-rel-2 a b = useEq (sym $
    begin
        min a b <= a
    =⟨ sym (propFnIf (λ z → (z <= a))) ⟩
        (if b < a then b <= a else a <= a)
    =⟨ ifTrueMap {c = b < a} (λ c -> isTrueToEquiv (orFst c)) ⟩
        (if b < a then true else a <= a)
    =⟨ cong (if_then_else_ (b < a) true) (isTrueToEquiv (lteSelf a)) ⟩
        (if b < a then true else true)
    =⟨ propIfBranchesSame true ⟩
        true
    end) IsTrue.itsTrue

length-tilesQd : {t : Set} {{eqT : Eq t}} {dep : Nat} -> (vqd : VQuadrant t {dep})
    -> (x1 y1 x2 y2 : Nat) -> IsTrue (x1 <= x2) -> IsTrue (y1 <= y2)
    -> sum (map lengthₙ (map expand (tilesQd dep vqd (RegionC (x1 , y1) (x2 , y2))))) ≡ diff x2 x1 * diff y2 y1
length-tilesQd {t} {dep = dep} (CVQuadrant (Leaf v) {p}) x1 y1 x2 y2 _ _ =
    begin
        sum (map lengthₙ (map expand (tilesQd dep (CVQuadrant (Leaf v) {p}) (RegionC (x1 , y1) (x2 , y2)))))
    =⟨⟩
        lengthₙ (replicateₙ (diff x2 x1 * diff y2 y1) v) + 0
    =⟨ add-comm _ 0 ⟩
        lengthₙ (replicateₙ (diff x2 x1 * diff y2 y1) v)
    =⟨ length-replicateₙ (diff x2 x1 * diff y2 y1) v ⟩
        diff x2 x1 * diff y2 y1
    end
length-tilesQd {dep = S dep} (CVQuadrant (Node a b c d) {p}) x1 y1 x2 y2 xp yp =
    begin
        sum (map lengthₙ (map expand (tilesQd (S dep) (CVQuadrant (Node a b c d) {p}) (RegionC (x1 , y1) (x2 , y2)))))
    =⟨⟩
        sum (map lengthₙ (map expand (ca ++ cb ++ cc ++ cd)))
    =⟨ cong (λ q -> sum (map lengthₙ q)) (map-concat4 ca cb cc cd expand) ⟩
        sum (map lengthₙ (map expand ca  ++ map expand cb ++ map expand cc ++ map expand cd))
    =⟨ cong sum (map-concat4 (map expand ca) (map expand cb) (map expand cc) (map expand cd) lengthₙ) ⟩
        sum (map lengthₙ (map expand ca) ++ map lengthₙ (map expand cb) ++ map lengthₙ (map expand cc) ++ map lengthₙ (map expand cd))
    =⟨ sum-concat4 (map lengthₙ (map expand ca)) (map lengthₙ (map expand cb)) (map lengthₙ (map expand cc)) (map lengthₙ (map expand cd)) ⟩
        sum (map lengthₙ (map expand ca)) + sum (map lengthₙ (map expand cb)) + sum (map lengthₙ (map expand cc)) + sum (map lengthₙ (map expand cd))
    =⟨ cong4 (λ a b c d -> a + b + c + d)
        (length-tilesQd (CVQuadrant a) x1 y1 (min x2 (mid + x1)) (min y2 (mid + y1)) (min-rel-1 x1 mid x2 xp) (min-rel-1 y1 mid y2 yp))
        (length-tilesQd (CVQuadrant b) (min x2 (mid + x1)) y1 x2 (min y2 (mid + y1)) (min-rel-2 x2 (mid + x1)) (min-rel-1 y1 mid y2 yp))
        (length-tilesQd (CVQuadrant c) x1 (min y2 (mid + y1)) (min x2 (mid + x1)) y2 (min-rel-1 x1 mid x2 xp) (min-rel-2 y2 (mid + y1)))
        (length-tilesQd (CVQuadrant d) (min x2 (mid + x1)) (min y2 (mid + y1)) x2 y2 (min-rel-2 x2 (mid + x1)) (min-rel-2 y2 (mid + y1))) ⟩
          diff (min x2 (mid + x1)) x1 * diff (min y2 (mid + y1)) y1
        + diff x2 (min x2 (mid + x1)) * diff (min y2 (mid + y1)) y1
        + diff (min x2 (mid + x1)) x1 * diff y2 (min y2 (mid + y1))
        + diff x2 (min x2 (mid + x1)) * diff y2 (min y2 (mid + y1))
    =⟨ square-split x1 y1 (min x2 (mid + x1)) (min y2 (mid + y1)) x2 y2 (min-rel-1 x1 mid x2 xp) (min-rel-2 x2 (mid + x1)) (min-rel-1 y1 mid y2 yp) (min-rel-2 y2 (mid + y1)) ⟩
        diff x2 x1 * diff y2 y1
    end where
        mid = pow 2 dep
        ca = tilesQd dep (CVQuadrant a) (RegionC (x1 , y1) (min x2 (mid + x1) , min y2 (mid + y1)) )
        cb = tilesQd dep (CVQuadrant b) (RegionC (min x2 (mid + x1) , y1) (x2 , min y2 (mid + y1)) )
        cc = tilesQd dep (CVQuadrant c) (RegionC (x1 , min y2 (mid + y1)) (min x2 (mid + x1) , y2) )
        cd = tilesQd dep (CVQuadrant d) (RegionC (min x2 (mid + x1) , min y2 (mid + y1)) (x2 , y2) )

proof-length : {t : Set} {{eqT : Eq t}} {dep : Nat} -> (vqt : VQuadTree t {dep}) -> lengthₑ (quadtreeFoldable dep) vqt ≡ size vqt
proof-length {t} ⦃ eqT ⦄ {dep} vqt@(CVQuadTree (Wrapper (w , h) qd) {p1} {p2}) =
    begin
        lengthₑ (quadtreeFoldable dep) vqt
    =⟨⟩
        lengthₙ (concat (map expand (tilesQd dep (CVQuadrant qd {p1}) (RegionC (0 , 0) (w , h)))))
    =⟨ length-concat (map expand (tilesQd dep (CVQuadrant qd {p1}) (RegionC (0 , 0) (w , h)))) ⟩
        sum (map lengthₙ (map expand (tilesQd dep (CVQuadrant qd {p1}) (RegionC (0 , 0) (w , h)))))
    =⟨ length-tilesQd {dep = dep} (CVQuadrant qd {p1}) 0 0 w h (zeroLteAny w) (zeroLteAny h) ⟩
        w * h
    end


------------------------------------------------------------------------
-- Programs used to define and specify breadth-first manipulations of
-- trees
------------------------------------------------------------------------

module BreadthFirst.Programs where

open import Codata.Musical.Notation
open import Codata.Musical.Colist hiding ([_])
open import Data.List.NonEmpty using (List⁺; [_]; _⁺++⁺_)
open import Data.Product

open import BreadthFirst.Universe
open import Stream hiding (zipWith)
open import Tree

infixr 5 _≺_ _∷_
infixr 4 _,_
infix  3 ↓_

mutual

  -- The term WHNF is a bit of a misnomer here; only recursive
  -- /coinductive/ arguments are suspended (in the form of programs).

  data ElW : U → Set₁ where
    leaf : ∀ {a} → ElW (tree a)
    node : ∀ {a}
           (l : ∞ (ElP (tree a))) (x : ElW a) (r : ∞ (ElP (tree a))) →
           ElW (tree a)
    _≺_  : ∀ {a} (x : ElW a) (xs : ∞ (ElP (stream a))) → ElW (stream a)
    []   : ∀ {a} → ElW (colist a)
    _∷_  : ∀ {a} (x : ElW a) (xs : ∞ (ElP (colist a))) → ElW (colist a)
    _,_  : ∀ {a b} (x : ElW a) (y : ElW b) → ElW (a ⊗ b)
    ⌈_⌉  : ∀ {A} (x : A) → ElW ⌈ A ⌉

  -- Note that higher-order functions are not handled well (see
  -- longZipWith): the arguments cannot be programs, since this would
  -- make the type negative.

  -- The tree arguments to lab and flatten used to be tree programs,
  -- but a number of lemmas could be removed when they were turned
  -- into "actual" trees.

  data ElP : U → Set₁ where
    ↓_          : ∀ {a} (w : ElW a) → ElP a
    fst         : ∀ {a b} (p : ElP (a ⊗ b)) → ElP a
    snd         : ∀ {a b} (p : ElP (a ⊗ b)) → ElP b
    lab         : ∀ {A B}
                  (t : Tree A) (lss : ElP (stream ⌈ Stream B ⌉)) →
                  ElP (tree ⌈ B ⌉ ⊗ stream ⌈ Stream B ⌉)
    longZipWith : ∀ {A} (f : A → A → A) (xs ys : ElP (colist ⌈ A ⌉)) →
                  ElP (colist ⌈ A ⌉)
    flatten     : ∀ {A} (t : Tree A) → ElP (colist ⌈ List⁺ A ⌉)

infixl 9 _·_ _⊛_

_·_ : ∀ {A B} → (A → B) → ElW ⌈ A ⌉ → ElW ⌈ B ⌉
f · ⌈ x ⌉ = ⌈ f x ⌉

_⊛_ : ∀ {A B} → ElW ⌈ (A → B) ⌉ → ElW ⌈ A ⌉ → ElW ⌈ B ⌉
⌈ f ⌉ ⊛ x = f · x

fstW : ∀ {a b} → ElW (a ⊗ b) → ElW a
fstW (x , y) = x

sndW : ∀ {a b} → ElW (a ⊗ b) → ElW b
sndW (x , y) = y

-- Uses the n-th stream to label the n-th level in the tree. Returns
-- the remaining stream elements (for every level).

labW : ∀ {A B} → Tree A → ElW (stream ⌈ Stream B ⌉) →
       ElW (tree ⌈ B ⌉ ⊗ stream ⌈ Stream B ⌉)
labW leaf         bss                = (leaf , bss)
labW (node l _ r) (⌈ b ≺ bs ⌉ ≺ bss) =
  (node (♯ fst x) ⌈ b ⌉ (♯ fst y) , ⌈ ♭ bs ⌉ ≺ ♯ snd y)
  where
  x = lab (♭ l) (♭ bss)
  y = lab (♭ r) (snd x)

longZipWithW : ∀ {A} → (A → A → A) →
               (xs ys : ElW (colist ⌈ A ⌉)) → ElW (colist ⌈ A ⌉)
longZipWithW f (x ∷ xs) (y ∷ ys) = f · x ⊛ y ∷ ♯ longZipWith f (♭ xs) (♭ ys)
longZipWithW f xs       []       = xs
longZipWithW f []       ys       = ys

flattenW : ∀ {A} → Tree A → ElW (colist ⌈ List⁺ A ⌉)
flattenW leaf         = []
flattenW (node l x r) =
  ⌈ [ x ] ⌉ ∷ ♯ longZipWith _⁺++⁺_ (flatten (♭ l)) (flatten (♭ r))

whnf : ∀ {a} → ElP a → ElW a
whnf (↓ w)                 = w
whnf (fst p)               = fstW (whnf p)
whnf (snd p)               = sndW (whnf p)
whnf (lab t bss)           = labW t (whnf bss)
whnf (longZipWith f xs ys) = longZipWithW f (whnf xs) (whnf ys)
whnf (flatten t)           = flattenW t

mutual

  ⟦_⟧W : ∀ {a} → ElW a → El a
  ⟦ leaf         ⟧W = leaf
  ⟦ (node l x r) ⟧W = node (♯ ⟦ ♭ l ⟧) ⟦ x ⟧W (♯ ⟦ ♭ r ⟧)
  ⟦ (x ≺ xs)     ⟧W = ⟦ x ⟧W ≺ ♯ ⟦ ♭ xs ⟧
  ⟦ []           ⟧W = []
  ⟦ (x ∷ xs)     ⟧W = ⟦ x ⟧W ∷ ♯ ⟦ ♭ xs ⟧
  ⟦ (x , y)      ⟧W = (⟦ x ⟧W , ⟦ y ⟧W)
  ⟦ ⌈ x ⌉        ⟧W = x

  ⟦_⟧ : ∀ {a} → ElP a → El a
  ⟦ p ⟧ = ⟦ whnf p ⟧W


open import Categories
open import Monads
open import Level
import Monads.CatofAdj

module Monads.CatofAdj.TermAdjHom
  {c d}
  {C : Cat {c}{d}}
  (M : Monad C)
  (A : Cat.Obj (Monads.CatofAdj.CatofAdj M {c ⊔ d}{c ⊔ d})) where

open import Library

open import Functors
open import Adjunctions
open import Monads.EM M
open Monads.CatofAdj M
open import Monads.CatofAdj.TermAdjObj M

open Cat
open Fun
open Adj
open Monad

open ObjAdj

K' : Fun (D A) (D EMObj)
K' = record {
    OMap  = λ X → record {
      acar  = OMap (R (adj A)) X;
      astr  = λ Z f → subst (λ Z → Hom C Z (OMap (R (adj A)) X))
                            (fcong Z (cong OMap (law A)))
                            (HMap (R (adj A)) (right (adj A) f));
      alaw1 = λ {Z} {f} → alaw1lem
         (TFun M)
         (L (adj A))
         (R (adj A))
         (law A)
         (η M)
         (right (adj A))
         (left (adj A))
         (ηlaw A)
         (natleft (adj A) (iden C) (right (adj A) f) (iden (D A)))
         (lawb (adj A) f);
      alaw2 = λ {Z} {W} {k} {f} → alaw2lem
         (TFun M)
         (L (adj A))
         (R (adj A))
         (law A)
         (right (adj A))
         (bind M)
         (natright (adj A))
         (bindlaw A {_}{_}{k})};
    HMap  = λ {X} {Y} f → record {
      amor = HMap (R (adj A)) f;
      ahom = λ {Z} {g} → ahomlem
         (TFun M)
         (L (adj A))
         (R (adj A))
         (law A)
         (right (adj A))
         (natright (adj A))};
    fid   = AlgMorphEq (fid (R (adj A)));
    fcomp = AlgMorphEq (fcomp (R (adj A)))}

Llaw' : K' ○ L (adj A) ≅ L (adj EMObj)
Llaw' = FunctorEq
  _
  _
  (ext (λ X → AlgEq
    (fcong X (cong OMap (law A)))
    ((ext λ Z → dext (λ {f} {f'} p → Llawlem
      (TFun M)
      (L (adj A))
      (R (adj A))
      (law A)
      (right (adj A))
      (bind M)
      (bindlaw A)
      p)))))
  (iext λ X → iext λ Y → ext λ f → AlgMorphEq'
    (AlgEq
      (fcong X (cong OMap (law A)))
      ((ext λ Z → dext (λ {f₁} {f'} p → Llawlem
        (TFun M)
        (L (adj A))
        (R (adj A))
        (law A)
        (right (adj A))
        (bind M)
        (bindlaw A)
        p))))
    (AlgEq
      (fcong Y (cong OMap (law A)))
      ((ext λ Z → dext (λ {f₁} {f'} p → Llawlem
        (TFun M)
        (L (adj A))
        (R (adj A))
        (law A)
        (right (adj A))
        (bind M)
        (bindlaw A)
        p))))
    (dcong
      (refl {x = f})
      (ext (λ _ → cong₂
        (Hom C)
        (fcong X (cong OMap (law A)))
        (fcong Y (cong OMap (law A)))))
      (dicong
        (refl {x = Y})
        (ext (λ z → cong
          (λ F → Hom C X z → Hom C (F X) (F z))
          (cong OMap (law A))))
        (dicong
          (refl {x = X})
          (ext (λ z → cong
            (λ F → ∀ {y} → Hom C z y → Hom C (F z) (F y))
            (cong OMap (law A))))
          (cong HMap (law A))))))

Rlaw' : R (adj A) ≅ R (adj EMObj) ○ K'
Rlaw' = FunctorEq _ _ refl refl

rightlaw' : {X : Obj C} {Y : Obj (D A)} {f : Hom C X (OMap (R (adj A)) Y)} →
            HMap K' (right (adj A) f)
            ≅
            right (adj EMObj)
                  {X}
                  {OMap K' Y}
                  (subst (Hom C X) (fcong Y (cong OMap Rlaw')) f)
rightlaw' {X = X}{Y = Y}{f = f} = AlgMorphEq'
  (AlgEq (fcong X (cong OMap (law A)))
         (ext λ Z → dext (λ p → Llawlem (TFun M)
           (L (adj A))
           (R (adj A))
           (law A)
           (right (adj A))
           (bind M)
           (bindlaw A) p )))
  refl
  (trans (cong  (λ (f₁ : Hom C X (OMap (R (adj A)) Y)) →
           HMap (R (adj A)) (right (adj A) f₁)) (sym (stripsubst (Hom C X) f (fcong Y (cong OMap Rlaw')))) ) (sym (stripsubst (λ Z → Hom C Z (OMap (R (adj A)) Y)) ( ((HMap (R (adj A))
 (right (adj A)
   (subst (Hom C X) (fcong Y (cong (λ r → OMap r) Rlaw')) f))))) (fcong X (cong OMap (law A))))))

EMHom : Hom CatofAdj A EMObj
EMHom = record {
  K        = K';
  Llaw     = Llaw';
  Rlaw     = Rlaw';
  rightlaw = rightlaw'}


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

   Copyright (c) 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.Base.PKCS
open import LibraBFT.Base.Types
import      LibraBFT.Yasm.Base as LYB

-- This module provides a single import for all Yasm modules

module LibraBFT.Yasm.Yasm
   (ℓ-EC        : Level)
   (EpochConfig : Set ℓ-EC)
   (epochId     : EpochConfig → EpochId)
   (authorsN    : EpochConfig → ℕ)
   (parms       : LYB.SystemParameters ℓ-EC EpochConfig epochId authorsN)
   (senderPKOK  : (ec : EpochConfig) → PK → LYB.SystemParameters.PeerId parms → Set)
  where
 open LYB.SystemParameters parms
 open import LibraBFT.Yasm.AvailableEpochs PeerId ℓ-EC EpochConfig epochId authorsN
             using (AvailableEpochs) renaming (lookup' to EC-lookup; lookup'' to EC-lookup') public
 open import LibraBFT.Yasm.Base       ℓ-EC EpochConfig epochId authorsN                      public
 open import LibraBFT.Yasm.System     ℓ-EC EpochConfig epochId authorsN parms                public
 open import LibraBFT.Yasm.Properties ℓ-EC EpochConfig epochId authorsN parms senderPKOK     public
 open import Util.FunctionOverride    PeerId _≟PeerId_                                       public


module _ (A : Set) where

{-# POLARITY A #-}


module EquationalTheory where

open import Library
open import Syntax
open import RenamingAndSubstitution

-- Single collapsing substitution.

sub1 : ∀{Γ σ τ} → Tm Γ σ → Tm (Γ , σ) τ → Tm Γ τ
sub1 {Γ}{σ}{τ} u t = sub (subId , u) t

-- Typed β-η-equality.

data _≡βη_ {Γ : Cxt} : ∀{σ} → Tm Γ σ → Tm Γ σ → Set where

  -- Axioms.

  beta≡  : ∀{σ τ} {t : Tm (Γ , σ) τ} {u : Tm Γ σ} →

           --------------------------
           app (abs t) u ≡βη sub1 u t

  eta≡   : ∀{σ τ} (t : Tm Γ (σ ⇒ τ)) →

           -------------------------------------
           abs (app (weak _ t) (var zero)) ≡βη t

  -- Congruence rules.

  var≡   : ∀{σ} (x : Var Γ σ) →

           ---------------
           var x ≡βη var x

  abs≡   : ∀{σ τ}{t t' : Tm (Γ , σ) τ} →

           t ≡βη t' →
           ----------------
           abs t ≡βη abs t'

  app≡   : ∀{σ τ}{t t' : Tm Γ (σ ⇒ τ)}{u u' : Tm Γ σ} →

          t ≡βη t' → u ≡βη u' →
          ---------------------
          app t u ≡βη app t' u'

  -- Equivalence rules.

  refl≡  : ∀{a} (t {t'} : Tm Γ a) →

           t ≡ t' →
           -------
           t ≡βη t'

  sym≡   : ∀{a}{t t' : Tm Γ a}

           (t'≡t : t' ≡βη t) →
           -----------------
           t ≡βη t'

  trans≡ : ∀{a}{t₁ t₂ t₃ : Tm Γ a}

           (t₁≡t₂ : t₁ ≡βη t₂) (t₂≡t₃ : t₂ ≡βη t₃) →
           ----------------------------------
           t₁ ≡βη t₃

-- A calculation on renamings needed for renaming of eta≡.

ren-eta≡ : ∀ {Γ Δ a b} (t : Tm Γ (a ⇒ b)) (ρ : Ren Δ Γ) →
        ren (wkr ρ , zero) (ren (wkr renId) t) ≡ ren (wkr {σ = a} renId) (ren ρ t)
ren-eta≡ t ρ = begin
  ren (wkr ρ , zero) (ren (wkr renId) t)     ≡⟨ sym (rencomp _ _ _) ⟩
  ren (renComp (wkr ρ , zero) (wkr renId)) t ≡⟨ cong (λ ρ₁ → ren ρ₁ t) (lemrr _ _ _) ⟩
  ren (renComp (wkr ρ) renId) t              ≡⟨ cong (λ ρ₁ → ren ρ₁ t) (ridr _) ⟩
  ren (wkr ρ) t                              ≡⟨ cong (λ ρ₁ → ren ρ₁ t) (cong wkr (sym (lidr _))) ⟩
  ren (wkr (renComp renId ρ)) t              ≡⟨ cong (λ ρ₁ → ren ρ₁ t) (sym (wkrcomp _ _)) ⟩
  ren (renComp (wkr renId) ρ) t              ≡⟨ rencomp _ _ _ ⟩
  ren (wkr renId) (ren ρ t)                  ∎ where open ≡-Reasoning

-- Definitional equality is closed under renaming.

ren≡βη : ∀{Γ a} {t : Tm Γ a}{t' : Tm Γ a} → t ≡βη t' → ∀{Δ}(ρ : Ren Δ Γ) →
        ren ρ t ≡βη ren ρ t'

ren≡βη (beta≡ {t = t}{u = u}) ρ = trans≡ beta≡ $ refl≡ _ $
  trans (subren (subId , ren ρ u) (liftr ρ) t)
        (trans (cong (λ xs → sub xs t)
                     (cong₂ Sub._,_
                            (trans (lemsr subId (ren ρ u) ρ)
                            (trans (sidl (ren2sub ρ)) (sym $ sidr (ren2sub ρ))))
                            (ren2subren ρ u)))
               (sym $ rensub ρ (subId , u) t))
  -- TODO: factor out reasoning about renamings and substitutions

ren≡βη (eta≡ {a} t) ρ rewrite ren-eta≡ t ρ = eta≡ (ren ρ t)

-- OLD:
-- ren≡βη (eta≡ t) ρ = trans≡
--   (abs≡ (app≡ (refl≡ _
--     (trans (sym $ rencomp (liftr ρ) (wkr renId) t)
--            (trans (cong (λ xs → ren xs t)
--                         (trans (lemrr (wkr ρ) zero renId)
--                                (trans (ridr (wkr ρ))
--                                       (trans (cong wkr (sym (lidr ρ)))
--                                              (sym (wkrcomp renId ρ))))))
--                   (rencomp (wkr renId) ρ t))))
--     (refl≡ _)))
--   (eta≡ _)

ren≡βη (var≡ x)       ρ = var≡ (lookr ρ x)
ren≡βη (abs≡ p)       ρ = abs≡ (ren≡βη p (liftr ρ))
ren≡βη (app≡ p q)     ρ = app≡ (ren≡βη p ρ) (ren≡βη q ρ)

ren≡βη (refl≡ _ refl) ρ = refl≡ _ refl
ren≡βη (sym≡ p)       ρ = sym≡ (ren≡βη p ρ)
ren≡βη (trans≡ p q)   ρ = trans≡ (ren≡βη p ρ) (ren≡βη q ρ)


{-# OPTIONS --copatterns #-}
-- Andreas, 2013-11-05  Coverage checker needs clauses to reduce type!
-- {-# OPTIONS -v tc.cover:20 #-}

module Issue937a where

open import Common.Prelude
open import Common.Equality
open import Common.Product

T : (b : Bool) → Set
T true = Nat
T false = Bool → Nat

test : Σ Bool T
proj₁ test = false
proj₂ test true  = zero
proj₂ test false = suc zero -- Error: unreachable clause

module _ {_ : Set} where

  bla : Σ Bool T
  proj₁ bla = false
  proj₂ bla true  = zero
  proj₂ bla false = suc zero -- Error: unreachable clause

-- should coverage check


module Oscar.Class.Associativity where

open import Oscar.Class.Preservativity
open import Oscar.Function
open import Oscar.Level
open import Oscar.Relation

record Associativity
  {𝔞} {𝔄 : Set 𝔞} {𝔰} {_►_ : 𝔄 → 𝔄 → Set 𝔰}
    (_◅_ : ∀ {m n} → m ► n → ∀ {l} → m ⟨ l ►_ ⟩→ n)
  {ℓ}
    (_≤_ : ∀ {m n} → m ► n → m ► n → Set ℓ)
  : Set (𝔞 ⊔ 𝔰 ⊔ ℓ) where
  field
    associativity : ∀ {k l} (f : k ► l) {m} (g : l ► m) {n} (h : m ► n) → (h ◅ (g ◅ f)) ≤ ((h ◅ g) ◅ f)

  instance `preservativity : ∀ {l} {m} {n} {w : m ► n} → Preservativity (λ ⋆ → _◅_ ⋆) (λ ⋆ → _◅_ ⋆) _≤_ (m ⟨ l ►_ ⟩→ n ∋ w ◅_) id (m ⟨ l ►_ ⟩→ n ∋ w ◅_)
  Preservativity.preservativity `preservativity g f = associativity f g _
--    ⦃ `preservativity ⦄ : ∀ {l} {m} {n} {w : m ► n} → Preservativity (λ ⋆ → _◅_ ⋆) (λ ⋆ → _◅_ ⋆) _≤_ (m ⟨ l ►_ ⟩→ n ∋ w ◅_) id (m ⟨ l ►_ ⟩→ n ∋ w ◅_)

open Associativity ⦃ … ⦄ public

module _ where

  private

    postulate
      A : Set
      _⇒_ : A → A → Set
      _∙_ : ∀ {m n} → m ⇒ n → ∀ {l} → m ⟨ l ⇒_ ⟩→ n
      _≋_ : ∀ {m n} → m ⇒ n → m ⇒ n → Set
      instance _ : Associativity _∙_ _≋_

    test-associativity₁ : ∀ {k l} (f : k ⇒ l) {m} (g : l ⇒ m) {n} (h : m ⇒ n) → (h ∙ (g ∙ f)) ≋ ((h ∙ g) ∙ f)
    test-associativity₁ = associativity {_◅_ = _∙_}

    test-associativity₂ : ∀ {k l} (f : k ⇒ l) {m} (g : l ⇒ m) {n} (h : m ⇒ n) → (h ∙ (g ∙ f)) ≋ ((h ∙ g) ∙ f)
    test-associativity₂ = associativity {_≤_ = _≋_}

-- Associativity : ∀
--   {𝔞} {𝔄 : Set 𝔞} {𝔰} {_►_ : 𝔄 → 𝔄 → Set 𝔰}
--     (_◅_ : ∀ {m n} → m ► n → ∀ {l} → m ⟨ l ►_ ⟩→ n)
--   {ℓ}
--     (_≤_ : ∀ {m n} → m ► n → m ► n → Set ℓ)
--   → Set (𝔞 ⊔ 𝔰 ⊔ ℓ)
-- Associativity {_►_ = _►_} _◅_ _≤_ =
--   ∀ {l} {m} {n} {w : m ► n} → Preservativity (λ ⋆ → _◅_ ⋆) (λ ⋆ → _◅_ ⋆) _≤_ (m ⟨ l ►_ ⟩→ n ∋ w ◅_) id (m ⟨ l ►_ ⟩→ n ∋ w ◅_)

-- -- record Associativity
-- --   {𝔞} {𝔄 : Set 𝔞} {𝔰} {_►_ : 𝔄 → 𝔄 → Set 𝔰}
-- --     (_◅_ : ∀ {m n} → m ► n → ∀ {l} → m ⟨ l ►_ ⟩→ n)
-- --   {𝔱} {▸ : 𝔄 → Set 𝔱}
-- --     (_◃_ : ∀ {m n} → m ► n → m ⟨ ▸ ⟩→ n)
-- --   {ℓ}
-- --     (_≤_ : ∀ {n} → ▸ n → ▸ n → Set ℓ)
-- --   : Set (𝔞 ⊔ 𝔰 ⊔ 𝔱 ⊔ ℓ) where
-- --   field
-- --     associativity : ∀ {l} (f : ▸ l) {m} (g : l ► m) {n} (h : m ► n) → (h ◃ (g ◃ f)) ≤ ((h ◅ g) ◃ f)

-- -- open Associativity ⦃ … ⦄ public

-- -- -- record Associativity
-- -- --   {𝔞} {𝔄 : Set 𝔞} {𝔰} {_►_ : 𝔄 → 𝔄 → Set 𝔰}
-- -- --     (_▻_ : ∀ {l m n} → l ► m → m ⟨ _► n ⟩→ l)
-- -- --   {ℓ}
-- -- --     (_≤_ : ∀ {m n} → m ► n → m ► n → Set ℓ)
-- -- --   : Set (𝔞 ⊔ 𝔰 ⊔ ℓ) where
-- -- --   field
-- -- --     ⦃ `preservativity ⦄ : ∀ l m n w → Preservativity (_▻_ {l = l} {m = m} {n = n}) (_▻_ {l = l}) _≤_ (w ▻_) id (w ▻_)
-- -- -- --    ⦃ `preservativity ⦄ : ∀ n l w → Preservativity (λ ⋆ → _◅_ {n = n} ⋆) (λ ⋆ → _◅_ {l = l} ⋆) _≤_ (_◅ w) id (w ◅_)

-- -- -- -- record Associativity
-- -- -- --   {𝔞} {𝔄 : Set 𝔞} {𝔰} {_►_ : 𝔄 → 𝔄 → Set 𝔰}
-- -- -- --     (_◅_ : ∀ {l m n} → m ► n → m ⟨ l ►_ ⟩→ n)
-- -- -- --   {ℓ}
-- -- -- --     (_≤_ : ∀ {m n} → m ► n → m ► n → Set ℓ)
-- -- -- --   : Set (𝔞 ⊔ 𝔰 ⊔ ℓ) where
-- -- -- --   field
-- -- -- --     ⦃ `preservativity ⦄ : ∀ l n w → Preservativity (flip (_◅_ {l = l} {n = n})) (flip _◅_) _≤_ (w ◅_) id (_◅ w)
-- -- -- -- --    ⦃ `preservativity ⦄ : ∀ n l w → Preservativity (λ ⋆ → _◅_ {n = n} ⋆) (λ ⋆ → _◅_ {l = l} ⋆) _≤_ (_◅ w) id (w ◅_)

-- -- -- -- -- record Associativity
-- -- -- -- --   {𝔞} {𝔄 : Set 𝔞} {𝔰} {_►_ : 𝔄 → 𝔄 → Set 𝔰}
-- -- -- -- --     (_◅_ : ∀ {m n} → m ► n → ∀ {l} → m ⟨ l ►_ ⟩→ n)
-- -- -- -- --   {ℓ}
-- -- -- -- --     (_≤_ : ∀ {m n} → m ► n → m ► n → Set ℓ)
-- -- -- -- --   : Set (𝔞 ⊔ 𝔰 ⊔ ℓ) where
-- -- -- -- --   field
-- -- -- -- --     ⦃ `preservativity ⦄ : ∀ n l w → Preservativity (λ ⋆ → _◅_ {n = n} ⋆) (λ ⋆ → _◅_ ⋆ {l = l}) _≤_ (_◅ w) id (w ◅_)

-- -- -- -- -- --    associativity : ∀ {k l} (f : k ► l) {m} (g : l ► m) {n} (h : m ► n) → (h ◅ (g ◅ f)) ≤ ((h ◅ g) ◅ f)

-- -- -- -- -- -- record Associativity
-- -- -- -- -- --   {a} {A : Set a} {b} {B : A → Set b} {c} {C : (x : A) → B x → Set c}
-- -- -- -- -- --     (_◅_ : ∀ {m n} → m ► n → ∀ {l} → m ⟨ l ►_ ⟩→ n)
-- -- -- -- -- --   {ℓ}
-- -- -- -- -- --     (_≤_ : ∀ {m n} → m ► n → m ► n → Set ℓ)
-- -- -- -- -- --   : Set (𝔞 ⊔ 𝔰 ⊔ ℓ) where
-- -- -- -- -- --   field
-- -- -- -- -- --     ⦃ `preservativity ⦄ : Preservativity
-- -- -- -- -- --     associativity : ∀ {k l} (f : k ► l) {m} (g : l ► m) {n} (h : m ► n) → (h ◅ (g ◅ f)) ≤ ((h ◅ g) ◅ f)

-- -- -- -- -- -- open Associativity ⦃ … ⦄ public

-- -- -- -- -- -- -- record Associativity
-- -- -- -- -- -- --   {𝔞} {𝔄 : Set 𝔞} {𝔰} {_►_ : 𝔄 → 𝔄 → Set 𝔰}
-- -- -- -- -- -- --     (_◅_ : ∀ {m n} → m ► n → ∀ {l} → m ⟨ l ►_ ⟩→ n)
-- -- -- -- -- -- --   {ℓ}
-- -- -- -- -- -- --     (_≤_ : ∀ {m n} → m ► n → m ► n → Set ℓ)
-- -- -- -- -- -- --   : Set (𝔞 ⊔ 𝔰 ⊔ ℓ) where
-- -- -- -- -- -- --   field
-- -- -- -- -- -- --     associativity : ∀ {k l} (f : k ► l) {m} (g : l ► m) {n} (h : m ► n) → (h ◅ (g ◅ f)) ≤ ((h ◅ g) ◅ f)

-- -- -- -- -- -- -- open Associativity ⦃ … ⦄ public

-- -- -- -- -- -- -- -- record Associativity
-- -- -- -- -- -- -- --   {𝔞} {𝔄 : Set 𝔞} {𝔰} {_►_ : 𝔄 → 𝔄 → Set 𝔰}
-- -- -- -- -- -- -- --     (_◅_ : ∀ {m n} → m ► n → ∀ {l} → m ⟨ l ►_ ⟩→ n)
-- -- -- -- -- -- -- --   {𝔱} {▸ : 𝔄 → Set 𝔱}
-- -- -- -- -- -- -- --     (_◃_ : ∀ {m n} → m ► n → m ⟨ ▸ ⟩→ n)
-- -- -- -- -- -- -- --   {ℓ}
-- -- -- -- -- -- -- --     (_≤_ : ∀ {n} → ▸ n → ▸ n → Set ℓ)
-- -- -- -- -- -- -- --   : Set (𝔞 ⊔ 𝔰 ⊔ 𝔱 ⊔ ℓ) where
-- -- -- -- -- -- -- --   field
-- -- -- -- -- -- -- --     associativity : ∀ {l} (f : ▸ l) {m} (g : l ► m) {n} (h : m ► n) → (h ◃ (g ◃ f)) ≤ ((h ◅ g) ◃ f)

-- -- -- -- -- -- -- -- open Associativity ⦃ … ⦄ public

-- -- -- -- -- -- -- -- association : ∀
-- -- -- -- -- -- -- --   {𝔞} {𝔄 : Set 𝔞} {𝔰} {_►_ : 𝔄 → 𝔄 → Set 𝔰}
-- -- -- -- -- -- -- --     (_◅_ : ∀ {m n} → m ► n → ∀ {l} → m ⟨ l ►_ ⟩→ n)
-- -- -- -- -- -- -- --   {𝔱} {▸ : 𝔄 → Set 𝔱}
-- -- -- -- -- -- -- --     {_◃_ : ∀ {m n} → m ► n → m ⟨ ▸ ⟩→ n}
-- -- -- -- -- -- -- --   {ℓ}
-- -- -- -- -- -- -- --     (_≤_ : ∀ {n} → ▸ n → ▸ n → Set ℓ)
-- -- -- -- -- -- -- --   ⦃ _ : Associativity _◅_ _◃_ _≤_ ⦄
-- -- -- -- -- -- -- --   → ∀ {l} (f : ▸ l) {m} (g : l ► m) {n} (h : m ► n) → (h ◃ (g ◃ f)) ≤ ((h ◅ g) ◃ f)
-- -- -- -- -- -- -- -- association _◅_ _≤_ = associativity {_◅_ = _◅_} {_≤_ = _≤_}


-- 2010-10-04
-- termination checker no longer counts stripping off a record constructor
-- as decrease
-- 2019-10-18
-- It does if it's an inductive non-eta record.
module Issue334b where

data Unit : Set where
  unit : Unit

record E : Set where
  inductive
  constructor mkE
  field
    fromE : E
    spam  : Unit

f : E -> Set
f (mkE e unit) = f e

f' : E -> Set
f' (mkE e u) = f e


open import Agda.Builtin.Nat
open import Agda.Builtin.Unit
open import Agda.Builtin.Reflection renaming (bindTC to _>>=_)
open import Agda.Builtin.List
open import Agda.Builtin.Sigma
open import Agda.Builtin.Equality

infix  0 case_of_
case_of_ : ∀ {a b}{A : Set a}{B : Set b} → A → (A → B) → B
case x of f = f x

map : ∀ {a b}{A : Set a}{B : Set b} → (A → B) → List A → List B
map f [] = []
map f (x ∷ xs) = f x ∷ map f xs

reverse : ∀ {a}{A : Set a} → List A → List A
reverse {A = A} xs = reverseAcc xs []
  where
    reverseAcc : List A → List A → List A
    reverseAcc [] a = a
    reverseAcc (x ∷ xs) a = reverseAcc xs (x ∷ a)

data Maybe (X : Set) : Set where
  nothing : Maybe X
  just : X → Maybe X

data Fin : Nat → Set where
  zero : ∀ {n} → Fin (suc n)
  suc  : ∀ {n} → Fin n → Fin (suc n)

record RVec {a} (X : Set a) (n : Nat) : Set a where
  constructor vec
  field sel : Fin n → X

test-rvec : Nat → RVec Nat 5
test-rvec x = vec λ _ → x

get-len : Definition → TC Term
get-len (function (clause _ _ (con (quote vec)
                                  (_ ∷ _ ∷ (arg _ a) ∷ _)) ∷ [])) = quoteTC a
get-len _ = quoteTC "ERROR"

macro
  def-reg : Name → Term → TC ⊤
  def-reg n hole = do
    d ← getDefinition n
    l ← get-len d
    unify hole l

  def-recons : Name → Term → TC ⊤
  def-recons n hole = do
    d ← withReconstructed (getDefinition n)
    l ← get-len d
    unify hole l

  -- normaliseR perserves reconstructed expressions.
  def-normR : Name → Term → TC ⊤
  def-normR n hole = do
    (function (clause tel ps t ∷ [])) ←
      withReconstructed (getDefinition n)
      where _ → quoteTC "ERROR" >>= unify hole
    let ctx = map snd tel
    t ← inContext (reverse ctx)
        (withReconstructed (normalise t))
    let d = function (clause tel ps t ∷ [])
    get-len d >>= unify hole

  -- normaliseR perserves reconstructed expressions.
  def-redR : Name → Term → TC ⊤
  def-redR n hole = do
    (function (clause tel ps t ∷ [])) ←
      withReconstructed (getDefinition n)
      where _ → quoteTC "ERROR" >>= unify hole
    let ctx = map snd tel
    t ← inContext (reverse ctx) (withReconstructed (reduce t))
    let d = function (clause tel ps t ∷ [])
    get-len d >>= unify hole

test₁ : unknown ≡ def-reg test-rvec
test₁ = refl

test₂ : (lit (nat 5)) ≡ def-recons test-rvec
test₂ = refl

test₃ : (lit (nat 5)) ≡ def-normR test-rvec
test₃ = refl

test₄ : (lit (nat 5)) ≡ def-redR test-rvec
test₄ = refl

pictx : Term → List (Arg Type)
pictx (pi a (abs s x)) = a ∷ pictx x
pictx _ = []

macro
  get-ctx : Name → Term → TC ⊤
  get-ctx n hole = do
    t ← getType n
    let c = pictx t
    c ← withReconstructed
        (inContext (reverse c) getContext)
    quoteTC c >>= unify hole

bar : (A : Set) (eq : [] {A = A} ≡ []) (x : Nat) → ⊤
bar _ _ _ = tt

-- if getContext were to work incorrectly, this function wouldn't typecheck
test₅ : List (Arg Type)
test₅ = get-ctx bar

data NotAVec (X : Set) (y : Nat) : Set where
  mk : NotAVec X y

f : ∀ {n} → NotAVec Nat n → NotAVec Nat (suc n)
f mk = mk

macro
  chk-type : Term → TC ⊤
  chk-type hole = do
    T ← quoteTC (NotAVec Nat 5)
    t ← quoteTC (mk {X = Nat} {y = 5})
    (con _ (_ ∷ arg _ t ∷ [])) ← withReconstructed (checkType t T)
      where _ → quoteTC "ERROR" >>= unify hole
    quoteTC t >>= unify hole

-- checkType would leave unknown's without the call to withReconstructed
test₆ : chk-type ≡ lit (nat 5)
test₆ = refl

q : [] {A = Nat} ≡ [] {A = Nat}
q = refl

macro
  inf-type : Term → TC ⊤
  inf-type hole = do
    (function (clause _ _ b ∷ [])) ← withReconstructed (getDefinition (quote q))
      where _ → quoteTC "ERROR" >>= unify hole
    (def _ (l ∷ L ∷ e₁ ∷ e₂ ∷ [])) ← withReconstructed  (inferType b)
      where _ → quoteTC "ERROR" >>= unify hole
    (arg _ (con _ (_ ∷ (arg _ N) ∷ []))) ← returnTC e₁
      where _ → quoteTC "ERROR" >>= unify hole
    quoteTC N >>= unify hole

-- inferType would not reconstruct the arguments within the type
-- without the call to withReconstructed
test₇ : inf-type ≡ def (quote Nat) []
test₇ = refl


module datatypes-safe where

open import bool public
open import integer public
open import list public
open import level public
open import maybe public
open import nat public
open import nat-division public
open import product public
open import sum public
open import tree public
open import trie public
open import unit public
open import vector public


{-

Descriptor language for easily defining relational structures

-}
{-# OPTIONS --cubical --no-import-sorts --no-exact-split --safe #-}
module Cubical.Structures.Relational.Macro where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Structure
open import Cubical.Foundations.RelationalStructure

open import Cubical.Structures.Relational.Constant
open import Cubical.Structures.Relational.Product
open import Cubical.Structures.Relational.Maybe
open import Cubical.Structures.Relational.Parameterized
open import Cubical.Structures.Relational.Pointed
open import Cubical.Structures.Relational.UnaryOp

open import Cubical.Structures.Macro

data RelDesc (ℓ : Level) : Typeω where
  -- constant structure: X ↦ A
  constant : ∀ {ℓ'} → hSet ℓ' → RelDesc ℓ
  -- pointed structure: X ↦ X
  var : RelDesc ℓ
  -- join of structures S,T : X ↦ (S X × T X)
  _,_ : RelDesc ℓ  → RelDesc ℓ  → RelDesc ℓ
  -- structure S parameterized by constant A : X ↦ (A → S X)
  param : ∀ {ℓ'} → (A : Type ℓ') → RelDesc ℓ  → RelDesc ℓ
  -- structure S parameterized by variable argument: X ↦ (X → S X)
  recvar : RelDesc ℓ  → RelDesc ℓ
  -- Maybe on a structure S: X ↦ Maybe (S X)
  maybe : RelDesc ℓ → RelDesc ℓ

infixr 4 _,_

{- Universe level calculations -}

relDesc→Desc : ∀ {ℓ} → RelDesc ℓ → Desc ℓ
relDesc→Desc (constant A) = constant (A .fst)
relDesc→Desc var = var
relDesc→Desc (d₀ , d₁) = relDesc→Desc d₀ , relDesc→Desc d₁
relDesc→Desc (param A d) = param A (relDesc→Desc d)
relDesc→Desc (recvar d) = recvar (relDesc→Desc d)
relDesc→Desc (maybe d) = maybe (relDesc→Desc d)

relMacroStrLevel : ∀ {ℓ} → RelDesc ℓ → Level
relMacroStrLevel d = macroStrLevel (relDesc→Desc d)

relMacroRelLevel : ∀ {ℓ} → RelDesc ℓ → Level
relMacroRelLevel d = macroEquivLevel (relDesc→Desc d)

RelMacroStructure : ∀ {ℓ} → (d : RelDesc ℓ) → Type ℓ → Type (relMacroStrLevel d)
RelMacroStructure d = MacroStructure (relDesc→Desc d)

preservesSetsRelMacro : ∀ {ℓ} → (d : RelDesc ℓ)
  {X : Type ℓ} → isSet X → isSet (RelMacroStructure d X)
preservesSetsRelMacro (constant A) = preservesSetsConstant A
preservesSetsRelMacro var = preservesSetsPointed
preservesSetsRelMacro (d₀ , d₁) =
  preservesSetsProduct (preservesSetsRelMacro d₀) (preservesSetsRelMacro d₁)
preservesSetsRelMacro (param A d) =
  preservesSetsParam A (λ _ → preservesSetsRelMacro d)
preservesSetsRelMacro (recvar d) =
  preservesSetsUnaryFun (preservesSetsRelMacro d)
preservesSetsRelMacro (maybe d) =
  preservesSetsMaybe (preservesSetsRelMacro d)

-- Notion of structured relation defined by a descriptor
RelMacroRelStr : ∀ {ℓ} → (d : RelDesc ℓ) → StrRel {ℓ} (RelMacroStructure d) (relMacroRelLevel d)
RelMacroRelStr (constant A) = ConstantRelStr A
RelMacroRelStr var = PointedRelStr
RelMacroRelStr (d₀ , d₁) = ProductRelStr (RelMacroRelStr d₀) (RelMacroRelStr d₁)
RelMacroRelStr (param A d) = ParamRelStr A (λ _ → RelMacroRelStr d)
RelMacroRelStr (recvar d) = UnaryFunRelStr (RelMacroRelStr d)
RelMacroRelStr (maybe d) = MaybeRelStr (RelMacroRelStr d)

-- Proof that structure induced by descriptor is suitable
relMacroSuitableRel : ∀ {ℓ} → (d : RelDesc ℓ) → SuitableStrRel _ (RelMacroRelStr d)
relMacroSuitableRel (constant A) = constantSuitableRel A
relMacroSuitableRel var = pointedSuitableRel
relMacroSuitableRel (d₀ , d₁) = productSuitableRel (relMacroSuitableRel d₀) (relMacroSuitableRel d₁)
relMacroSuitableRel (param A d) = paramSuitableRel A (λ _ → relMacroSuitableRel d)
relMacroSuitableRel (recvar d) = unaryFunSuitableRel (preservesSetsRelMacro d) (relMacroSuitableRel d)
relMacroSuitableRel (maybe d) = maybeSuitableRel (relMacroSuitableRel d)

-- Proof that structured relations and equivalences agree
relMacroMatchesEquiv : ∀ {ℓ} → (d : RelDesc ℓ)
  → StrRelMatchesEquiv (RelMacroRelStr d) (MacroEquivStr (relDesc→Desc d))
relMacroMatchesEquiv (constant A) = constantRelMatchesEquiv A
relMacroMatchesEquiv var = pointedRelMatchesEquiv
relMacroMatchesEquiv (d₁ , d₂) =
  productRelMatchesEquiv
    (RelMacroRelStr d₁) (RelMacroRelStr d₂)
    (relMacroMatchesEquiv d₁) (relMacroMatchesEquiv d₂)
relMacroMatchesEquiv (param A d) =
  paramRelMatchesEquiv A (λ _ → RelMacroRelStr d) (λ _ → relMacroMatchesEquiv d)
relMacroMatchesEquiv (recvar d) =
  unaryFunRelMatchesEquiv (RelMacroRelStr d) (relMacroMatchesEquiv d)
relMacroMatchesEquiv (maybe d) =
  maybeRelMatchesEquiv (RelMacroRelStr d) (relMacroMatchesEquiv d)

-- Module for easy importing
module RelMacro ℓ (d : RelDesc ℓ) where
  relation = RelMacroRelStr d
  suitable = relMacroSuitableRel d
  matches = relMacroMatchesEquiv d
  open Macro ℓ (relDesc→Desc d) public