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

-- Composition of pseudofunctors

module Categories.Pseudofunctor.Composition where

open import Data.Product using (_,_)

open import Categories.Bicategory using (Bicategory)
import Categories.Bicategory.Extras as BicategoryExt
open import Categories.Category using (Category)
open import Categories.Category.Instance.One using (shift)
open import Categories.Category.Product using (_⁂_)
open import Categories.Functor using (Functor; _∘F_)
import Categories.Morphism.Reasoning as MorphismReasoning
open import Categories.NaturalTransformation using (NaturalTransformation)
open import Categories.NaturalTransformation.NaturalIsomorphism
  using (NaturalIsomorphism; _≃_; niHelper; _ⓘˡ_; _ⓘʳ_)
open import Categories.Pseudofunctor using (Pseudofunctor)

open Category using (module HomReasoning)
open NaturalIsomorphism using (F⇒G; F⇐G)

infixr 9 _∘P_

-- Composition of pseudofunctors

_∘P_ : ∀ {o ℓ e t o′ ℓ′ e′ t′ o″ ℓ″ e″ t″}
         {C : Bicategory o ℓ e t} {D : Bicategory o′ ℓ′ e′ t′}
         {E : Bicategory o″ ℓ″ e″ t″} →
       Pseudofunctor D E → Pseudofunctor C D → Pseudofunctor C E
_∘P_ {o″ = o″} {ℓ″ = ℓ″} {e″ = e″} {C = C} {D = D} {E = E} F G = record
  { P₀             = λ x → F₀ (G₀ x)
  ; P₁             = F₁ ∘F G₁
  ; P-identity     = P-identity
  ; P-homomorphism = P-homomorphism
  ; unitaryˡ       = unitaryˡ
  ; unitaryʳ       = unitaryʳ
  ; assoc          = assoc
  }
  where
    module C  = BicategoryExt C
    module D  = BicategoryExt D
    module E  = BicategoryExt E
    module F  = Pseudofunctor F
    module G  = Pseudofunctor G
    open E
    open F using () renaming (P₀ to F₀; P₁ to F₁)
    open G using () renaming (P₀ to G₀; P₁ to G₁)
    module F₁G₁ {x} {y} = Functor (F₁ {G₀ x} {G₀ y} ∘F G₁ {x} {y})
    open NaturalIsomorphism

    F∘G-id = λ {x} → F₁ ⓘˡ G.P-identity {x}
    F-id   = λ {x} → F.P-identity {G₀ x}

    P-identity : ∀ {x} → E.id ∘F shift o″ ℓ″ e″ ≃ (F₁ ∘F G₁) ∘F (C.id {x})
    P-identity {x} = niHelper (record
      { η       = λ _ → ⇒.η F∘G-id _ ∘ᵥ ⇒.η F-id _
      ; η⁻¹     = λ _ → ⇐.η F-id _ ∘ᵥ ⇐.η F∘G-id _
      ; commute = λ _ → glue (⇒.commute F∘G-id _) (⇒.commute F-id _)
      ; iso     = λ _ → record
        { isoˡ = begin
            (⇐.η F-id _ ∘ᵥ ⇐.η F∘G-id _) ∘ᵥ ⇒.η F∘G-id _ ∘ᵥ ⇒.η F-id _
          ≈⟨ cancelInner (iso.isoˡ F∘G-id _) ⟩
            ⇐.η F-id _ ∘ᵥ ⇒.η F-id _
          ≈⟨ iso.isoˡ F-id _ ⟩
            id₂
          ∎
        ; isoʳ = begin
            (⇒.η F∘G-id _ ∘ᵥ ⇒.η F-id _) ∘ᵥ ⇐.η F-id _ ∘ᵥ ⇐.η F∘G-id _
          ≈⟨ cancelInner (iso.isoʳ F-id _) ⟩
            ⇒.η F∘G-id _ ∘ᵥ ⇐.η F∘G-id _
          ≈⟨ iso.isoʳ F∘G-id _ ⟩
            id₂
          ∎
        }
      })
      where
        FGx = F₀ (G₀ x)
        open HomReasoning (hom FGx FGx)
        open MorphismReasoning (hom FGx FGx)

    F∘G-h = λ {x y z} → F₁ ⓘˡ G.P-homomorphism {x} {y} {z}
    F-h∘G = λ {x y z} → F.P-homomorphism {G₀ x} {G₀ y} {G₀ z} ⓘʳ (G₁ ⁂ G₁)

    P-homomorphism : ∀ {x y z} →
                     E.⊚ ∘F (F₁ ∘F G₁ ⁂ F₁ ∘F G₁) ≃
                       (F₁ ∘F G₁) ∘F C.⊚ {x} {y} {z}
    P-homomorphism {x} {y} {z} = niHelper (record
      { η       = λ f,g → ⇒.η F∘G-h f,g ∘ᵥ ⇒.η F-h∘G f,g
      ; η⁻¹     = λ f,g → ⇐.η F-h∘G f,g ∘ᵥ ⇐.η F∘G-h f,g
      ; commute = λ α,β → glue (⇒.commute F∘G-h α,β) (⇒.commute F-h∘G α,β)
      ; iso     = λ f,g → record
        { isoˡ = cancelInner (iso.isoˡ F∘G-h f,g) ○ iso.isoˡ F-h∘G f,g
        ; isoʳ = cancelInner (iso.isoʳ F-h∘G f,g) ○ iso.isoʳ F∘G-h f,g
        }
      })
      where
        FGx = F₀ (G₀ x)
        FGz = F₀ (G₀ z)
        open HomReasoning (hom FGx FGz)
        open MorphismReasoning (hom FGx FGz)

    Pid  = λ {A} → NaturalTransformation.η (F⇒G (P-identity {A})) _
    Phom = λ {x} {y} {z} f,g →
           NaturalTransformation.η (F⇒G (P-homomorphism {x} {y} {z})) f,g
    λ⇒   = unitorˡ.from
    ρ⇒   = unitorʳ.from
    α⇒   = associator.from

    unitaryˡ : ∀ {x y} {f : x C.⇒₁ y} →
               let open ComHom in
               [ id₁ ⊚₀ F₁G₁.₀ f ⇒ F₁G₁.₀ f ]⟨
                 Pid ⊚₁ id₂             ⇒⟨ F₁G₁.₀ C.id₁ ⊚₀ F₁G₁.₀ f ⟩
                 Phom (C.id₁ , f)       ⇒⟨ F₁G₁.₀ (C.id₁ C.⊚₀ f) ⟩
                 F₁G₁.₁ C.unitorˡ.from
               ≈ E.unitorˡ.from
               ⟩
    unitaryˡ {x} {y} {f} = begin
        F₁G₁.₁ C.unitorˡ.from ∘ᵥ Phom (C.id₁ , f) ∘ᵥ Pid ⊚₁ id₂
      ≡⟨⟩
        F₁.₁ (G₁.₁ C.unitorˡ.from) ∘ᵥ
        (⇒.η F∘G-h (C.id₁ , f) ∘ᵥ ⇒.η F-h∘G (C.id₁ , f)) ∘ᵥ
        (⇒.η F∘G-id _ ∘ᵥ ⇒.η F-id _) ⊚₁ id₂
      ≈˘⟨ refl⟩∘⟨ refl⟩∘⟨ E.∘ᵥ-distr-◁ ⟩
        F₁.₁ (G₁.₁ C.unitorˡ.from) ∘ᵥ
        (⇒.η F∘G-h (C.id₁ , f) ∘ᵥ ⇒.η F-h∘G (C.id₁ , f)) ∘ᵥ
        ⇒.η F∘G-id _ ⊚₁ id₂ ∘ᵥ ⇒.η F-id _ ⊚₁ id₂
      ≈˘⟨ refl⟩∘⟨ refl⟩∘⟨ E.⊚.F-resp-≈ (hom.Equiv.refl , F₁.identity) ⟩∘⟨refl ⟩
        F₁.₁ (G₁.₁ C.unitorˡ.from) ∘ᵥ
        (⇒.η F∘G-h (C.id₁ , f) ∘ᵥ ⇒.η F-h∘G (C.id₁ , f)) ∘ᵥ
        ⇒.η F∘G-id _ ⊚₁ F₁.₁ D.id₂ ∘ᵥ ⇒.η F-id _ ⊚₁ id₂
      ≈⟨ refl⟩∘⟨ extend² (F.Hom.commute (G.unitˡ.η _ , D.id₂)) ⟩
        F₁.₁ (G₁.₁ C.unitorˡ.from) ∘ᵥ
        (⇒.η F∘G-h (C.id₁ , f) ∘ᵥ F₁.₁ (G.unitˡ.η _ D.⊚₁ D.id₂)) ∘ᵥ
        F.Hom.η (D.id₁ , G₁.₀ f) ∘ᵥ ⇒.η F-id _ ⊚₁ id₂
      ≈˘⟨ pushˡ (F₁.homomorphism ○ hom.∘-resp-≈ʳ F₁.homomorphism) ⟩
        F₁.₁ (G₁.₁ C.unitorˡ.from D.∘ᵥ
              G.Hom.η (C.id₁ , f) D.∘ᵥ G.unitˡ.η _ D.⊚₁ D.id₂) ∘ᵥ
        F.Hom.η (D.id₁ , G₁.₀ f) ∘ᵥ ⇒.η F-id _ ⊚₁ id₂
      ≈⟨ F₁.F-resp-≈ G.unitaryˡ ⟩∘⟨refl ⟩
        F₁.₁ (D.unitorˡ.from) ∘ᵥ
        F.Hom.η (D.id₁ , G₁.₀ f) ∘ᵥ ⇒.η F-id _ ⊚₁ id₂
      ≈⟨ F.unitaryˡ ⟩
        E.unitorˡ.from
      ∎
      where
        FGx = F₀ (G₀ x)
        FGy = F₀ (G₀ y)
        open HomReasoning (hom FGx FGy)
        open MorphismReasoning (hom FGx FGy)

    unitaryʳ : ∀ {x y} {f : x C.⇒₁ y} →
               let open ComHom in
               [ F₁G₁.₀ f ⊚₀ id₁ ⇒ F₁G₁.₀ f ]⟨
                 id₂ ⊚₁ Pid             ⇒⟨ F₁G₁.₀ f ⊚₀ F₁G₁.₀ C.id₁ ⟩
                 Phom (f , C.id₁)       ⇒⟨ F₁G₁.₀ (f C.⊚₀ C.id₁) ⟩
                 F₁G₁.₁ C.unitorʳ.from
               ≈ E.unitorʳ.from
               ⟩
    unitaryʳ {x} {y} {f} = begin
        F₁G₁.₁ C.unitorʳ.from ∘ᵥ Phom (f , C.id₁) ∘ᵥ id₂ ⊚₁ Pid
      ≡⟨⟩
        F₁.₁ (G₁.₁ C.unitorʳ.from) ∘ᵥ
        (⇒.η F∘G-h (f , C.id₁) ∘ᵥ ⇒.η F-h∘G (f , C.id₁)) ∘ᵥ
        id₂ ⊚₁ (⇒.η F∘G-id _ ∘ᵥ ⇒.η F-id _)
      ≈˘⟨ refl⟩∘⟨ refl⟩∘⟨ E.∘ᵥ-distr-▷ ⟩
        F₁.₁ (G₁.₁ C.unitorʳ.from) ∘ᵥ
        (⇒.η F∘G-h (f , C.id₁) ∘ᵥ ⇒.η F-h∘G (f , C.id₁)) ∘ᵥ
        id₂ ⊚₁ ⇒.η F∘G-id _ ∘ᵥ id₂ ⊚₁ ⇒.η F-id _
      ≈˘⟨ refl⟩∘⟨ refl⟩∘⟨ E.⊚.F-resp-≈ (F₁.identity , hom.Equiv.refl) ⟩∘⟨refl ⟩
        F₁.₁ (G₁.₁ C.unitorʳ.from) ∘ᵥ
        (⇒.η F∘G-h (f , C.id₁) ∘ᵥ ⇒.η F-h∘G (f , C.id₁)) ∘ᵥ
        F₁.₁ D.id₂ ⊚₁ ⇒.η F∘G-id _ ∘ᵥ id₂ ⊚₁ ⇒.η F-id _
      ≈⟨ refl⟩∘⟨ extend² (F.Hom.commute (D.id₂ , G.unitˡ.η _)) ⟩
        F₁.₁ (G₁.₁ C.unitorʳ.from) ∘ᵥ
        (⇒.η F∘G-h (f , C.id₁) ∘ᵥ F₁.₁ (D.id₂ D.⊚₁ G.unitˡ.η _)) ∘ᵥ
        F.Hom.η (G₁.₀ f , D.id₁) ∘ᵥ id₂ ⊚₁ ⇒.η F-id _
      ≈˘⟨ pushˡ (F₁.homomorphism ○ hom.∘-resp-≈ʳ F₁.homomorphism) ⟩
        F₁.₁ (G₁.₁ C.unitorʳ.from D.∘ᵥ
              G.Hom.η (f , C.id₁) D.∘ᵥ D.id₂ D.⊚₁ G.unitˡ.η _) ∘ᵥ
        F.Hom.η (G₁.₀ f , D.id₁) ∘ᵥ id₂ ⊚₁ ⇒.η F-id _
      ≈⟨ F₁.F-resp-≈ G.unitaryʳ ⟩∘⟨refl ⟩
        F₁.₁ (D.unitorʳ.from) ∘ᵥ
        F.Hom.η (G₁.₀ f , D.id₁) ∘ᵥ id₂ ⊚₁ ⇒.η F-id _
      ≈⟨ F.unitaryʳ ⟩
        E.unitorʳ.from
      ∎
      where
        FGx = F₀ (G₀ x)
        FGy = F₀ (G₀ y)
        open HomReasoning (hom FGx FGy)
        open MorphismReasoning (hom FGx FGy)

    assoc : ∀ {x y z w} {f : x C.⇒₁ y} {g : y C.⇒₁ z} {h : z C.⇒₁ w} →
            let open ComHom in
            [ (F₁G₁.₀ h ⊚₀ F₁G₁.₀ g) ⊚₀ F₁G₁.₀ f ⇒ F₁G₁.₀ (h C.⊚₀ (g C.⊚₀ f)) ]⟨
              Phom (h , g) ⊚₁ id₂     ⇒⟨ F₁G₁.₀ (h C.⊚₀ g) ⊚₀ F₁G₁.₀ f ⟩
              Phom (_ , f)            ⇒⟨ F₁G₁.₀ ((h C.⊚₀ g) C.⊚₀ f) ⟩
              F₁G₁.₁ C.associator.from
            ≈ E.associator.from       ⇒⟨ F₁G₁.₀ h ⊚₀ (F₁G₁.₀ g ⊚₀ F₁G₁.₀ f) ⟩
              id₂ ⊚₁ Phom (g , f)     ⇒⟨ F₁G₁.₀ h ⊚₀ F₁G₁.₀ (g C.⊚₀ f) ⟩
              Phom (h , _)
            ⟩
    assoc {x} {_} {_} {w} {f} {g} {h} = begin
        F₁G₁.₁ C.associator.from ∘ᵥ Phom (_ , f) ∘ᵥ Phom (h , g) ⊚₁ id₂
      ≡⟨⟩
        F₁.₁ (G₁.₁ C.associator.from) ∘ᵥ
        (⇒.η F∘G-h (_ , f) ∘ᵥ ⇒.η F-h∘G (_ , f)) ∘ᵥ
        (⇒.η F∘G-h (h , g) ∘ᵥ ⇒.η F-h∘G (h , g)) ⊚₁ id₂
      ≈˘⟨ refl⟩∘⟨ refl⟩∘⟨ E.∘ᵥ-distr-◁ ⟩
        F₁.₁ (G₁.₁ C.associator.from) ∘ᵥ
        (⇒.η F∘G-h (_ , f) ∘ᵥ ⇒.η F-h∘G (_ , f)) ∘ᵥ
        ⇒.η F∘G-h (h , g) ⊚₁ id₂ ∘ᵥ ⇒.η F-h∘G (h , g) ⊚₁ id₂
      ≈˘⟨ refl⟩∘⟨ refl⟩∘⟨ E.⊚.F-resp-≈ (hom.Equiv.refl , F₁.identity) ⟩∘⟨refl ⟩
        F₁.₁ (G₁.₁ C.associator.from) ∘ᵥ
        (⇒.η F∘G-h (_ , f) ∘ᵥ ⇒.η F-h∘G (_ , f)) ∘ᵥ
        ⇒.η F∘G-h (h , g) ⊚₁ F₁.₁ D.id₂ ∘ᵥ ⇒.η F-h∘G (h , g) ⊚₁ id₂
      ≈⟨ refl⟩∘⟨ extend² (F.Hom.commute (G.Hom.η (h , g) , D.id₂)) ⟩
        F₁.₁ (G₁.₁ C.associator.from) ∘ᵥ
        (⇒.η F∘G-h (_ , f) ∘ᵥ F₁.₁ (G.Hom.η (h , g) D.⊚₁ D.id₂)) ∘ᵥ
        F.Hom.η (_ , G₁.₀ f) ∘ᵥ ⇒.η F-h∘G (h , g) ⊚₁ id₂
      ≈˘⟨ pushˡ (F₁.homomorphism ○ hom.∘-resp-≈ʳ F₁.homomorphism) ⟩
        F₁.₁ (G₁.₁ C.associator.from D.∘ᵥ
              G.Hom.η (_ , f) D.∘ᵥ G.Hom.η (h , g) D.⊚₁ D.id₂) ∘ᵥ
        F.Hom.η (_ , G₁.₀ f) ∘ᵥ ⇒.η F-h∘G (h , g) ⊚₁ id₂
      ≈⟨ F₁.F-resp-≈ G.assoc ⟩∘⟨refl ⟩
        F₁.₁ (G.Hom.η (h , _) D.∘ᵥ D.id₂ D.⊚₁ G.Hom.η (g , f) D.∘ᵥ
              D.associator.from) ∘ᵥ
        F.Hom.η (_ , G₁.₀ f) ∘ᵥ ⇒.η F-h∘G (h , g) ⊚₁ id₂
      ≈⟨ (F₁.homomorphism ○ pushʳ F₁.homomorphism) ⟩∘⟨refl ⟩
        ((⇒.η F∘G-h (h , _) ∘ᵥ F₁.₁ (D.id₂ D.⊚₁ G.Hom.η (g , f))) ∘ᵥ
         F₁.₁ D.associator.from) ∘ᵥ
        F.Hom.η (_ , G₁.₀ f) ∘ᵥ ⇒.η F-h∘G (h , g) ⊚₁ id₂
      ≈⟨ pullʳ F.assoc ⟩
        (⇒.η F∘G-h (h , _) ∘ᵥ F₁.₁ (D.id₂ D.⊚₁ G.Hom.η (g , f))) ∘ᵥ
        F.Hom.η (G₁.₀ h , _) ∘ᵥ id₂ ⊚₁ ⇒.η F-h∘G (g , f) ∘ᵥ
        E.associator.from
      ≈˘⟨ extend² (F.Hom.commute (D.id₂ , G.Hom.η (g , f))) ⟩
        (⇒.η F∘G-h (h , _) ∘ᵥ ⇒.η F-h∘G (h , _)) ∘ᵥ
        F₁.₁ D.id₂ ⊚₁ ⇒.η F∘G-h (g , f) ∘ᵥ id₂ ⊚₁ ⇒.η F-h∘G (g , f) ∘ᵥ
        E.associator.from
      ≈⟨ refl⟩∘⟨ pullˡ (E.⊚.F-resp-≈ (F₁.identity , hom.Equiv.refl) ⟩∘⟨refl) ⟩
        (⇒.η F∘G-h (h , _) ∘ᵥ ⇒.η F-h∘G (h , _)) ∘ᵥ
        (id₂ ⊚₁ ⇒.η F∘G-h (g , f) ∘ᵥ id₂ ⊚₁ ⇒.η F-h∘G (g , f)) ∘ᵥ
        E.associator.from
      ≈⟨ refl⟩∘⟨ E.∘ᵥ-distr-▷ ⟩∘⟨refl ⟩
        (⇒.η F∘G-h (h , _) ∘ᵥ ⇒.η F-h∘G (h , _)) ∘ᵥ
        id₂ ⊚₁ (⇒.η F∘G-h (g , f) ∘ᵥ ⇒.η F-h∘G (g , f)) ∘ᵥ
        E.associator.from
      ≡⟨⟩
        Phom (h , _) ∘ᵥ id₂ ⊚₁ Phom (g , f) ∘ᵥ E.associator.from
      ∎
      where
        FGx = F₀ (G₀ x)
        FGw = F₀ (G₀ w)
        open HomReasoning (hom FGx FGw)
        open MorphismReasoning (hom FGx FGw)


--{-# OPTIONS --verbose 10 #-}
open import ExtractSac as ES using ()
open import Extract (ES.kompile-fun)

open import Data.Nat as N using (ℕ; zero; suc; _≤_; _≥_; _<_; s≤s; z≤n)
import      Data.Nat.DivMod as N
open import Data.Nat.Properties as N
open import Data.List as L using (List; []; _∷_)
open import Data.Vec as V using (Vec; []; _∷_)
import      Data.Vec.Properties as V
open import Data.Fin as F using (Fin; zero; suc; #_)
import      Data.Fin.Properties as F
open import Data.Product as Prod using (Σ; _,_; curry; uncurry) renaming (_×_ to _⊗_)

open import Relation.Binary.PropositionalEquality

open import Reflection

open import Structures
open import Function
open import ReflHelper

open import Array.Base
open import Array.Properties

open import APL2

open import Agda.Builtin.Float

-- Verbose facts about transitivity of <, ≤, and ≡
a≤b⇒b≡c⇒a≤c : ∀ {a b c} → a ≤ b → b ≡ c → a ≤ c
a≤b⇒b≡c⇒a≤c a≤b refl = a≤b

a≤b⇒a≡c⇒b≡d⇒c≤d : ∀ {a b c d} → a ≤ b → a ≡ c → b ≡ d → c ≤ d
a≤b⇒a≡c⇒b≡d⇒c≤d a≤b refl refl = a≤b

a<b⇒0<b : ∀ {a b} → a < b → zero < b
a<b⇒0<b {a} a<b = ≤-trans (s≤s z≤n) a<b

a<b⇒c≤a⇒c<b : ∀ {a b c} → a < b → c ≤ a → c < b
a<b⇒c≤a⇒c<b a<b z≤n = a<b⇒0<b a<b
a<b⇒c≤a⇒c<b (s≤s a<b) (s≤s c≤a) = s≤s (a<b⇒c≤a⇒c<b a<b c≤a)

a≤b⇒c≤a⇒c≤b : ∀ {a b c} → a ≤ b → c ≤ a → c ≤ b
a≤b⇒c≤a⇒c≤b {a} {b} {c} a≤b c≤a = ≤-trans c≤a a≤b

A<B⇒B≤C⇒A≤C : ∀ {n}{ix s s₁ : Ar ℕ 1 (n ∷ [])}
             → ix <a s → s₁ ≥a s → s₁ ≥a ix
A<B⇒B≤C⇒A≤C {ix = imap x} {imap x₁} {imap x₂} ix<s ix≤s₁ iv = ≤-trans (<⇒≤ $ ix<s iv) (ix≤s₁ iv)

A≥B⇒A≡C⇒C≥B : ∀ {d s}{A B C : Ar ℕ d s}
             → A ≥a B → A =a C → C ≥a B
A≥B⇒A≡C⇒C≥B {A = imap x} {imap x₁} {imap x₂} A≥B A≡C iv rewrite (sym $ A≡C iv) = A≥B iv

-- Something that could go in Stdlib.

a≤a*b : ∀ {a b} → a ≤ a N.* suc b
a≤a*b {a} {b = zero} rewrite (*-identityʳ a) = ≤-refl
a≤a*b {a} {b = suc b} = ≤-trans a≤a*b (*-monoʳ-≤ a (≤-step ≤-refl))

a-s[b]+1≡a-b : ∀ {a b} → b < a →  a N.∸ suc b N.+ 1 ≡ a N.∸ b
a-s[b]+1≡a-b {a} {b} pf = begin
                     a N.∸ suc (b) N.+ 1  ≡⟨ sym $ N.+-∸-comm 1 pf ⟩
                     a N.+ 1 N.∸ suc b    ≡⟨ cong₂ N._∸_ (N.+-comm a 1) (refl {x = suc b}) ⟩
                     a N.∸ b
                   ∎
                   where open ≡-Reasoning

conv-ix-inb : ∀ {n}{ix s s₁ : Ar ℕ 1 (n ∷ [])}
            → (ix<s : ix <a s)
            → (s₁≥s : s₁ ≥a s)
            → (s₁ - ix) {≥ = A<B⇒B≤C⇒A≤C {s₁ = s₁} ix<s s₁≥s}
               ≥a ((s₁ - s) {≥ = s₁≥s} + ( 1))
conv-ix-inb {ix = imap ix} {imap s} {imap s₁} ix<s s₁≥s iv =
       let
         s₁-[1+ix]≥s₁-s = ∸-monoʳ-≤ (s₁ iv) (ix<s iv)
         s₁-[1+ix]+1≥s₁-s+1 = +-monoˡ-≤ 1 s₁-[1+ix]≥s₁-s
       in a≤b⇒b≡c⇒a≤c s₁-[1+ix]+1≥s₁-s+1 (a-s[b]+1≡a-b {a = s₁ iv} {b = ix iv} (≤-trans (ix<s iv) (s₁≥s iv)))

undo-lkptab : ∀ {n s₁}{ix : Ar ℕ 1 (n ∷ [])} (iv : Ix 1 (n ∷ [])) →
      V.lookup s₁ (ix-lookup iv zero) N.∸ sel ix iv ≡
      V.lookup (V.tabulate (λ i → V.lookup s₁ i N.∸ sel ix (i ∷ [])))
      (ix-lookup iv zero)
undo-lkptab {s₁ = s₁}{ix} (i ∷ []) = sym (V.lookup∘tabulate _ i)

-- conv ← {a←⍵ ⋄ w←⍺ ⋄ ⊃+/,w×{(1+(⍴a)-⍴w)↑⍵↓a}¨⍳⍴w}
infixr 20 _conv_
_conv_ : ∀ {n wₛ aₛ}
      → Ar Float n wₛ
      → Ar Float n aₛ
      → {≥ : ▴ aₛ ≥a ▴ wₛ}
      → Ar Float n $ ▾ ((aₛ - wₛ){≥} + 1)
_conv_ {n = n} {wₛ = s} {aₛ = s₁} w a {s₁≥s} = let
               sr = (s₁ - s) {≥ = s₁≥s} + 1
               idxs = ι ρ w

               rots ix ix<s = let
                  ~ix≥ρa = A<B⇒B≤C⇒A≤C ix<s s₁≥s
                  ix↓a = (ix ↓ a) {pf = ~ix≥ρa}
                  ~ix-inb = conv-ix-inb {s₁ = s→a s₁} ix<s s₁≥s
                  ~ρix↓a≥sr = A≥B⇒A≡C⇒C≥B ~ix-inb (undo-lkptab {s₁ = s₁}{ix = ix})
                  in
                  (sr ↑ ix↓a) {pf = ~ρix↓a≥sr }

               r = (uncurry rots) ̈ idxs
               mul = w ̈⟨ _×ᵣ_ ⟩ (subst-ar (a→s∘s→a s) r)
               res = reduce-1d _+ᵣ_ (cst 0.0) (, mul)
              in res

--kconv : Prog
kconv = kompile _conv_ (quote _≥a_ ∷ quote reduce-1d ∷ quote _↑_ ∷ quote _↓_ ∷ []) [] -- (quote reduce-1d ∷ [])
--kconvr = frefl _conv_ (quote _≥a_ ∷ quote reduce-1d ∷ quote _↑_ ∷ quote _↓_ ∷ [])

--kconvr = frefl _conv_ (quote _≥a_ ∷ quote reduce-1d ∷ [])

--ktake : Term
--ktake = frefl _↑_ (quote _≥a_ ∷ quote reduce-1d ∷ [])

test-lw : ℕ → ℕ
test-lw n = case n of λ where
  1 → n N.+ 5
  _ → n N.+ 6

--ktest-lw = frefl test-lw []

n≤sn-i : ∀ {i n} → i N.≤ 1 → n N.≤ suc n N.∸ i
n≤sn-i z≤n       = <⇒≤ N.≤-refl
n≤sn-i (s≤s z≤n) = N.≤-refl

--test-take : ∀ {n} → Ix 1 V.[ 2 ] → Ar ℕ 1 V.[ 1 N.+ n ] → Ar ℕ 1 V.[ n ]
--test-take {n} ix@(i ∷ []) a =
--                 let ixₐ , ix<[2] = ix→a ix
--                     r' = (ixₐ   ↓ a)   {λ where jv@(zero ∷ []) → N.≤-trans (≤-pred $ ix<[2] jv) (s≤s z≤n)}
--                     r  = (cst n ↑ r')  {λ where jv@(zero ∷ []) → n≤sn-i (≤-pred $ F.toℕ<n i) }
--                 in r

test-take : ∀ {n} → Ix 1 V.[ 2 ] → Ar ℕ 1 V.[ 1 N.+ n ] → Ar ℕ 1 V.[ n ]
test-take {n} ix@(i ∷ []) a = r
  where
    ixₐ    = Prod.proj₁ $ ix→a ix
    ix<[2] = Prod.proj₂ $ ix→a ix
    r' = (ixₐ   ↓ a)   {λ where jv@(zero ∷ []) → N.≤-trans (≤-pred $ ix<[2] jv) (s≤s z≤n)}
    r  = (cst n ↑ r')  {λ where jv@(zero ∷ []) → n≤sn-i (≤-pred $ F.toℕ<n i) }

-- XXX These guys cause an impossible state.
--ktestr = frefl test-take []

--ktest : Prog
--ktest = kompile test-take (quote _≥a_ ∷ quote reduce-1d ∷ quote N._≟_ ∷ quote prod ∷ quote _↑_ ∷ quote _↓_ ∷ []) []

-- multiconv←{(a ws bs)←⍵⋄bs{⍺+⍵ conv a}⍤(0,(⍴⍴a))⊢ws}
multiconv : ∀ {n m s sw so} → (a : Ar Float n s)
          →  (ws : Ar (Ar Float n sw) m so)
          →  (bs : Ar Float m so)
          →  {≥ : ▴ s ≥a ▴ sw}
          →  Ar (Ar Float n $ ▾ ((s - sw){≥} + 1)) m so
multiconv a ws bs {≥} = bs ̈⟨ (λ α ω → α +ᵣ (ω conv a){≥}) ⟩ ws

--kmconv = kompile multiconv (quote _≥a_ ∷ quote reduce-1d ∷ quote _↑_ ∷ quote _↓_ ∷ []) [] -- (quote reduce-1d ∷ [])

{-

takeN : ∀ {n s}
      → (sh : Ar ℕ 1 (n ∷ []))
      → (a : Ar ℕ n s)
      → {pf : s→a s ≥a sh}
      → Ar ℕ n $ a→s sh
takeN sh a {pf} = (sh ↑ a){pf}

module _ where
  open import Relation.Nullary

  dec-test : ∀ {n} → (sh : Ar ℕ 1 V.[ n ]) → Ar ℕ n (▾ sh)
  dec-test a with (prod $ a→s a) N.≟ 0
  ... | yes p = mkempty _ p
  ... | no ¬p = cst 2

  open import Level as L
  bf : Names
  bf = (quote _≥a_ ∷ quote reduce-1d ∷ quote N._≟_ ∷ quote prod ∷ [])

  kdec-test = kompile dec-test bf ([])
  kdec-testR = frefl dec-test bf
  --kdec-testR2 = frefln dec-test bf ("Example-04._.with-350" ∷ [])

  ktakeN : Prog
  ktakeN = kompile takeN bf []

  ktakeNR = frefl takeN bf
  --ktakeNRW = ftyn takeN bf ("APL2.with-1366" ∷ [])

-}

{- --This moved into bug-nat-level--

poop : ∀ {d s} → Ar ℕ d s → Ix 1 V.[ prod s ] → ℕ
poop a ix = sel a (off→idx _ ix)

n≤sn-i : ∀ {i n} → i ≤ 1 → n ≤ suc n N.∸ i
n≤sn-i z≤n       = <⇒≤ ≤-refl
n≤sn-i (s≤s z≤n) = ≤-refl

test-take : ∀ {n} → Ix 1 V.[ 2 ] → Ar ℕ 1 V.[ 1 N.+ n ] → Ar ℕ 1 V.[ n ]
test-take {n} ix@(i ∷ []) a =
                 let ixₐ , ix<[2] = ix→a ix
                     r' = (ixₐ ↓ a){λ where jv@(zero ∷ []) → ≤-trans (≤-pred $ ix<[2] jv) (s≤s z≤n)}
                     r  = (cst n ↑ r'){ λ where jv@(zero ∷ []) → n≤sn-i (≤-pred $ F.toℕ<n i) }
                 in r

ktest = kompile test-take [] []

-}


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

{- Here, truncations with propositional computational behaviour are defined.
   This lack of a definitional β-rule enabled us to talk about this notion
   inside type theory without truncations, albeit complicating setup and proofs.

   After definition and basic accessories concerning universal properties,
   recursion and elimination, we prove that truncation is functorial.
   With this, we turn our attention to the problem of uniqueness of truncation,
   i.e. the type of truncations of a given type being propositional. -}
module Universe.Trunc.Basics where

open import lib.Basics
open import lib.NType2
open import lib.Equivalences2
open import lib.types.Unit
open import lib.types.Nat hiding (_+_)
open import lib.types.Pi
open import lib.types.Sigma
open import lib.types.Paths

open import Universe.Utility.General
open import Universe.Utility.TruncUniverse
open import Universe.Trunc.Universal

-- *** Definition 6.4 ***
record trunc-ty {i} (n : ℕ₋₂) (A : Type i)
                (j : ULevel) : Type (lsucc (i ⊔ j)) where
  constructor ty-cons
  field
    type : n -Type i
    cons : A → ⟦ type ⟧
    univ : univ-Type type cons j

module _ {i} {n : ℕ₋₂} {A : Type i} where
  trunc-ty-lower : ∀ {j₀} (j₁ : ULevel) → trunc-ty n A (j₀ ⊔ j₁) → trunc-ty n A j₀
  trunc-ty-lower {j₀} j₁ (ty-cons t c u) = ty-cons t c (univ-lower t c (j₀ ⊔ j₁) u)

{- Since Agda does not support specifying ordering relations on universe levels,
   we encounter an awkward dependency inversion: the index k needs to be
   specified in the module arguments, since the truncation type depends on it,
   even though we would rather have it at each individual definition.
   This shortcoming will be the source of many explicitely specified levels. -}
module trunc-props {i} {n : ℕ₋₂} {A : Type i} {j k} (tr : trunc-ty n A (i ⊔ j ⊔ k)) where
  open trunc-ty tr

  up : (U : n -Type k) → (⟦ type ⟧ → ⟦ U ⟧) ≃ (A → ⟦ U ⟧)
  up U = ((λ f → f ∘ cons) , univ-lower type cons (i ⊔ j ⊔ k) univ U)

  dup : (U : ⟦ type ⟧ → n -Type k) → ((ta : ⟦ type ⟧) → ⟦ U ta ⟧) ≃ ((a : A) → ⟦ U (cons a) ⟧)
  dup U = ((λ f → f ∘ cons) , with-univ.duniv type cons (univ-lower type cons (i ⊔ j ⊔ k) univ) U)

  abstract
    rec : (U : n -Type k) → (A → ⟦ U ⟧) → ⟦ type ⟧ → ⟦ U ⟧
    rec U = <– (up U)

    elim : (U : ⟦ type ⟧ → n -Type k) → ((a : A) → ⟦ U (cons a) ⟧) → (ta : ⟦ type ⟧) → ⟦ U ta ⟧
    elim U = <– (dup U)

    rec-β : {U : n -Type k} {f : A → ⟦ U ⟧} (a : A) → rec U f (cons a) == f a
    rec-β {U} {f} a = app= (<–-inv-r (up U) f) a

    elim-β : {U : ⟦ type ⟧ → n -Type k} {f : (a : A) → ⟦ U (cons a) ⟧} (a : A) → elim U f (cons a) == f a
    elim-β {U} {f} a = app= (<–-inv-r (dup U) f) a

{- Truncation acts as a functor.
   While tedious, we state all lemmata in their most general form.
   Instead of assuming an n-truncation operator, we individually assume
   a truncation for each type we need. While seeming overly convoluted
   at first, this generality will actually pay off with an unconventional
   use of fmap-equiv in showing that trunc-ty is propositional. -}
module trunc-functor {n : ℕ₋₂} where
  open trunc-ty
  open trunc-props

  -- The functorial action of truncation (truncation preserves maps).
  module _ {ia ib j} where
    module fmap {A : Type ia} {B : Type ib}
                (TrA : trunc-ty n A (ia ⊔ ib ⊔ j))
                (TrB : trunc-ty n B (ia ⊔ ib ⊔ j))
                (f : A → B) where
      map : ⟦ type TrA ⟧ → ⟦ type TrB ⟧
      map = rec {j = ia ⊔ ib ⊔ j} TrA (type TrB) (cons TrB ∘ f)

      β : (a : A) → map (cons TrA a) == cons TrB (f a)
      β = rec-β TrA {type TrB}

  -- The functorial action preserves the identity.
  module _ {i j} {A : Type i} (TrA : trunc-ty n A (i ⊔ j)) where
    private
      module I  = fmap {j = i ⊔ j} TrA TrA (idf _)

    fmap-fuse-id : (ta : ⟦ type TrA ⟧) → I.map ta == ta
    fmap-fuse-id = elim {j = i ⊔ j} TrA (λ ta → Path-≤ (type TrA) (I.map ta) ta) I.β

  -- The functorial action preserves composition.
  module _ {ia ib ic j} where
    private
      l : ULevel
      l = ia ⊔ ib ⊔ ic ⊔ j

    module _ {A : Type ia} {B : Type ib} {C : Type ic}
             (TrA : trunc-ty n A l)
             (TrB : trunc-ty n B l)
             (TrC : trunc-ty n C l)
             (f : A → B) (g : B → C) where
      private
        module F  = fmap {j = l} TrA TrB f
        module G  = fmap {j = l} TrB TrC g
        module GF = fmap {j = l} TrA TrC (g ∘ f)

      open trunc-props

      fmap-fuse-∘ : (ta : ⟦ type TrA ⟧) → GF.map ta == G.map (F.map ta)
      fmap-fuse-∘ = elim {j = l} TrA (λ ta →
                      Path-≤ (type TrC) (GF.map ta) (G.map (F.map ta))) $ λ a →
        GF.map (cons TrA a)        =⟨ GF.β a ⟩
        cons TrC (g (f a))         =⟨ ! (G.β (f a)) ⟩
        G.map (cons TrB (f a))     =⟨ ap G.map (! (F.β a)) ⟩
        G.map (F.map (cons TrA a)) ∎

  {- Corollary: truncation preserves equivalences.
     The below general form produces a unexpected benefit: the underlying
     type of a truncation is unique up to constructor-preserving equivalence. -}
  module _ where
    private
      module _ {ia ib j} where
        private
          l : ULevel
          l = ia ⊔ ib ⊔ j

        module half {A : Type ia} {B : Type ib}
                    (TrA : trunc-ty n A l)
                    (TrB : trunc-ty n B l)
                    (e : A ≃ B) where
          module F  = fmap {j = l} TrA TrB (–> e)
          module G  = fmap {j = l} TrB TrA (<– e)
          module BB = fmap {j = l} TrB TrB

          f-g : (tb : ⟦ type TrB ⟧) → F.map (G.map tb) == tb
          f-g tb =
              F.map (G.map tb)
            =⟨ ! (fmap-fuse-∘ {j = l} TrB TrA TrB (<– e) (–> e) tb) ⟩
              BB.map (–> e ∘ <– e) tb
            =⟨ app= (ap BB.map (λ= (<–-inv-r e))) tb ⟩
              BB.map (idf _) tb
            =⟨ fmap-fuse-id {j = l} TrB tb ⟩
              tb
            ∎

    module _ {ia ib j} where
      module _ {A : Type ia} {B : Type ib}
               (TrA : trunc-ty n A (ia ⊔ ib ⊔ j))
               (TrB : trunc-ty n B (ia ⊔ ib ⊔ j))
               (e : A ≃ B) where
        private
          module H = half {j = j} TrA TrB e
          module K = half {j = j} TrB TrA (e ⁻¹)

        fmap-equiv : ⟦ type TrA ≃-≤ type TrB ⟧
        fmap-equiv = equiv H.F.map K.F.map H.f-g K.f-g

{- The type of n-truncations of A is propositional:
   truncations are unique if existent. -}
module _ {i} {n : ℕ₋₂} {A : Type i} where
  open trunc-ty
  open trunc-functor

  {- For the purpose of this module, it will be easier
     for us to regard trunc-ty as a left-associatived Σ-type.
     In this way, we may examine the equality on the first component
     while disregarding the second one, which is a proposition. -}
  private
    e : ∀ {j} → trunc-ty n A j ≃ Σ (Σ _ _) _
    e = equiv (λ {(ty-cons t c u) → ((t , c) , u)})
              (λ {((t , c) , u) → ty-cons t c u})
              (λ _ → idp) (λ _ → idp)

    {- First, let us structurally decompose the combined equality
      over the type and cons record fields of trunc-ty.
      Note that this kind of lemma would be superfluous in
      a proof assistant fully supporting univalent foundations. -}
    path : (U V : Σ (n -Type i) (λ ty → A → ⟦ ty ⟧))
         → (U == V) ≃ Σ (⟦ fst U ⟧ ≃ ⟦ fst V ⟧) (λ e → –> e ∘ snd U == snd V)
    path ((X , u) , f) ((Y , v) , g) = equiv-Σ eq₁ (_⁻¹ ∘ eq₂)
                                     ∘e =Σ-eqv _ _ ⁻¹ where
      eq₁ : ((X , u) == (Y , v)) ≃ (X ≃ Y)
      eq₁ =
        (X , u) == (Y , v)                   ≃⟨ =Σ-eqv _ _ ⁻¹ ⟩
        Σ (X == Y) (λ p → u == v [ _ ↓ p ])  ≃⟨ Σ₂-contr h ⟩
        X == Y                               ≃⟨ ua-equiv ⁻¹ ⟩
        X ≃ Y                                ≃∎ where

        h : (p : X == Y) → is-contr (u == v [ _ ↓ p ])
        h _ = =-[-↓-]-level (λ _ → has-level-is-prop)

      eq₂ : (e : X ≃ Y) → (–> e ∘ f == g) ≃ (f == g [ _ ↓ <– eq₁ e ])
      eq₂ = λ e →
        –> e ∘ f == g                    ≃⟨ app=-equiv ⟩
        (∀ a → –> e (f a) == g a)        ≃⟨ equiv-Π-r (λ a → ↓-idf-ua-equiv e) ⟩
        (∀ a → f a == g a [ _ ↓ ua e ])  ≃⟨ ↓-cst→app-equiv ⟩
        (f == g [ _ ↓ ua e ])            ≃⟨ ↓-cst2-equiv _ _ ⟩
        (f == g [ _ ↓ <– eq₁ e ])        ≃∎

  module _ {j} where
    {- Important special case of the general form of fmap-equiv:
       the underlying type of a truncation is unique
       up to constructor-preserving equivalence. -}
    module unique (Tr₁ : trunc-ty n A (i ⊔ j))
                  (Tr₂ : trunc-ty n A (i ⊔ j)) where
      type-equiv : ⟦ type Tr₁ ≃-≤ type Tr₂ ⟧
      type-equiv = fmap-equiv {j = j} Tr₁ Tr₂ (ide _)

      cons-path : –> type-equiv ∘ cons Tr₁ == cons Tr₂
      cons-path = λ= (fmap.β {j = j} Tr₁ Tr₂ (idf _))

      type-cons-path : Path {A = Σ (n -Type i) (λ ty → A → ⟦ ty ⟧)}
                            (fst (–> e Tr₁)) (fst (–> e Tr₂))
      type-cons-path = <– (path _ _) (type-equiv , cons-path)

    -- *** Lemma 6.7 ***
    -- We are now ready to prove propositionality of trunc-ty.
    trunc-ty-prop : is-prop (trunc-ty n A _)
    trunc-ty-prop = all-paths-is-prop $ λ Tr₀ Tr₁ → <– (equiv-ap e _ _) (pair=
      (unique.type-cons-path Tr₀ Tr₁)
      (prop-has-all-paths-↓ (Π-level (λ _ → is-equiv-is-prop _))))

    trunc-inhab-contr : trunc-ty n A _ → is-contr (trunc-ty n A _)
    trunc-inhab-contr Tr = (Tr , prop-has-all-paths trunc-ty-prop _)


------------------------------------------------------------------------
-- Support for sized types
------------------------------------------------------------------------

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

module Prelude.Size where

open import Prelude

-- Size primitives.

open import Agda.Builtin.Size public
  using (Size; ∞)
  renaming (Size<_ to Size<; SizeUniv to Size-universe; ↑_ to ssuc)

-- If S is a type in the size universe, then S in-type is a type in
-- Type.

record _in-type (S : Size-universe) : Type where
  field
    size : S

open _in-type public


{-# OPTIONS --cubical #-}

module Multidimensional.Data.NNat.Properties where

open import Cubical.Core.Glue

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Isomorphism

open import Cubical.Data.Nat
open import Cubical.Data.Prod
open import Cubical.Data.Empty

open import Cubical.Relation.Nullary

open import Multidimensional.Data.Extra.Nat
open import Multidimensional.Data.Dir
open import Multidimensional.Data.DirNum
open import Multidimensional.Data.NNat.Base

-- N→ℕsucN : (r : ℕ) (x : N r) → N→ℕ r (sucN x) ≡ suc (N→ℕ r x)
-- N→ℕsucN zero (bn tt) = refl
-- N→ℕsucN zero (xr tt x) =
--     suc (N→ℕ zero (sucN x))
--   ≡⟨ cong suc (N→ℕsucN zero x) ⟩
--     suc (suc (N→ℕ zero x))
--   ∎
-- N→ℕsucN (suc r) (bn (↓ , d)) = refl
-- N→ℕsucN (suc r) (bn (↑ , d)) with max? d
-- ... | no d≠max =
--           doubleℕ (DirNum→ℕ (next d))
--         ≡⟨ cong doubleℕ (next≡suc r d d≠max)  ⟩
--           doubleℕ (suc (DirNum→ℕ d))
--         ∎
-- ... | yes d≡max = -- this can probably be shortened by not reducing down to zero
--           sucn (doubleℕ (DirNum→ℕ (zero-n r)))
--             (doublesℕ r (suc (suc (doubleℕ (doubleℕ (DirNum→ℕ (zero-n r)))))))
--         ≡⟨ cong (λ x → sucn (doubleℕ x) (doublesℕ r (suc (suc (doubleℕ (doubleℕ x)))))) (zero-n→0 {r}) ⟩
--           sucn (doubleℕ zero) (doublesℕ r (suc (suc (doubleℕ (doubleℕ zero)))))
--         ≡⟨ refl ⟩
--           doublesℕ (suc r) (suc zero) -- 2^(r+1)
--         ≡⟨ sym (doubleDoubles r 1) ⟩
--           doubleℕ (doublesℕ r (suc zero)) --2*2^r
--         ≡⟨ sym (sucPred (doubleℕ (doublesℕ r (suc zero))) (doubleDoublesOne≠0 r)) ⟩
--           suc (predℕ (doubleℕ (doublesℕ r (suc zero))))
--         ≡⟨ cong suc (sym (sucPred (predℕ (doubleℕ (doublesℕ r (suc zero)))) (predDoubleDoublesOne≠0 r))) ⟩
--           suc (suc (predℕ (predℕ (doubleℕ (doublesℕ r (suc zero))))))
--         ≡⟨ cong (λ x → suc (suc x)) (sym (doublePred (doublesℕ r (suc zero)))) ⟩
--           suc (suc (doubleℕ (predℕ (doublesℕ r (suc zero)))))
--         ≡⟨ cong (λ x → suc (suc (doubleℕ x))) (sym (maxr≡pred2ʳ r d d≡max)) ⟩
--           suc (suc (doubleℕ (DirNum→ℕ d))) -- 2*(2^r - 1) + 2 = 2^(r+1) - 2 + 2 = 2^(r+1)
--         ∎
-- N→ℕsucN (suc r) (xr (↓ , d) x) = refl
-- N→ℕsucN (suc r) (xr (↑ , d) x) with max? d
-- ... | no d≠max =
--           sucn (doubleℕ (DirNum→ℕ (next d)))
--            (doublesℕ r (doubleℕ (N→ℕ (suc r) x)))
--         ≡⟨ cong (λ y → sucn (doubleℕ y) (doublesℕ r (doubleℕ (N→ℕ (suc r) x)))) (next≡suc r d d≠max) ⟩
--           sucn (doubleℕ (suc (DirNum→ℕ d)))
--            (doublesℕ r (doubleℕ (N→ℕ (suc r) x)))
--         ≡⟨ refl ⟩
--           suc
--            (suc
--             (iter (doubleℕ (DirNum→ℕ d)) suc
--             (doublesℕ r (doubleℕ (N→ℕ (suc r) x)))))
--         ∎
-- ... | yes d≡max =
--         sucn (doubleℕ (DirNum→ℕ (zero-n r)))
--         (doublesℕ r (doubleℕ (N→ℕ (suc r) (sucN x))))
--       ≡⟨ cong (λ z → sucn (doubleℕ z) (doublesℕ r (doubleℕ (N→ℕ (suc r) (sucN x))))) (zero-n≡0 {r}) ⟩
--         sucn (doubleℕ zero)
--         (doublesℕ r (doubleℕ (N→ℕ (suc r) (sucN x))))
--       ≡⟨ refl ⟩
--         doublesℕ r (doubleℕ (N→ℕ (suc r) (sucN x)))
--       ≡⟨ cong (λ x → doublesℕ r (doubleℕ x)) (N→ℕsucN (suc r) x)  ⟩
--         doublesℕ r (doubleℕ (suc (N→ℕ (suc r) x)))
--       ≡⟨ refl ⟩
--         doublesℕ r (suc (suc (doubleℕ (N→ℕ (suc r) x)))) -- 2^r * (2x + 2) = 2^(r+1)x + 2^(r+1)
--       ≡⟨ doublesSucSuc r (doubleℕ (N→ℕ (suc r) x)) ⟩
--         sucn (doublesℕ (suc r) 1) -- _ + 2^(r+1)
--          (doublesℕ (suc r) (N→ℕ (suc r) x)) --  2^(r+1)x + 2^(r+1)
--       ≡⟨ H r (doublesℕ (suc r) (N→ℕ (suc r) x)) ⟩
--         suc
--          (suc
--           (sucn (doubleℕ (predℕ (doublesℕ r 1))) -- _ + 2(2^r - 1) + 2
--            (doublesℕ (suc r) (N→ℕ (suc r) x))))
--       ≡⟨ refl ⟩
--         suc
--          (suc
--           (sucn (doubleℕ (predℕ (doublesℕ r 1)))
--            (doublesℕ r (doubleℕ (N→ℕ (suc r) x)))))
--       ≡⟨ cong (λ z → suc (suc (sucn (doubleℕ z) (doublesℕ r (doubleℕ (N→ℕ (suc r) x)))))) (sym (max→ℕ r))  ⟩
--          suc
--          (suc
--           (sucn (doubleℕ (DirNum→ℕ (max-n r)))
--            (doublesℕ r (doubleℕ (N→ℕ (suc r) x)))))
--       ≡⟨ cong (λ z → suc (suc (sucn (doubleℕ (DirNum→ℕ z)) (doublesℕ r (doubleℕ (N→ℕ (suc r) x)))))) (sym (d≡max)) ⟩
--          suc
--          (suc
--           (sucn (doubleℕ (DirNum→ℕ d))
--            (doublesℕ r (doubleℕ (N→ℕ (suc r) x))))) -- (2^r*2x + (2*(2^r - 1))) + 2 = 2^(r+1)x + 2^(r+1)
--       ∎
--       where
--         H : (n m : ℕ) → sucn (doublesℕ (suc n) 1) m ≡ suc (suc (sucn (doubleℕ (predℕ (doublesℕ n 1))) m))
--         H zero m = refl
--         H (suc n) m =
--             sucn (doublesℕ n 4) m
--           ≡⟨ cong (λ z → sucn z m) (doublesSucSuc n 2) ⟩
--             sucn (sucn (doublesℕ (suc n) 1) (doublesℕ n 2)) m
--           ≡⟨ refl ⟩
--             sucn (sucn (doublesℕ n 2) (doublesℕ  n 2)) m
--           ≡⟨ {!!} ⟩
--             sucn (doubleℕ (doublesℕ n 2)) m
--           ≡⟨ {!!} ⟩ {!!}

-- ℕ→Nsuc : (r : ℕ) (n : ℕ) → ℕ→N r (suc n) ≡ sucN (ℕ→N r n)
-- ℕ→Nsuc r n = {!!}

-- ℕ→Nsucn : (r : ℕ) (n m : ℕ) → ℕ→N r (sucn n m) ≡ sucnN n (ℕ→N r m)
-- ℕ→Nsucn r n m = {!!}

-- NℕNlemma : (r : ℕ) (d : DirNum r) → ℕ→N r (DirNum→ℕ d) ≡ bn d
-- NℕNlemma zero tt = refl
-- NℕNlemma (suc r) (↓ , ds) =
--     ℕ→N (suc r) (doubleℕ (DirNum→ℕ ds))
--   ≡⟨ {!!} ⟩ {!!}
-- NℕNlemma (suc r) (↑ , ds) = {!!}

-- N→ℕ→N : (r : ℕ) → (x : N r) → ℕ→N r (N→ℕ r x) ≡ x
-- N→ℕ→N zero (bn tt) = refl
-- N→ℕ→N zero (xr tt x) = cong (xr tt) (N→ℕ→N zero x)
-- N→ℕ→N (suc r) (bn (↓ , ds)) =
--     ℕ→N (suc r) (doubleℕ (DirNum→ℕ ds))
--   ≡⟨ cong (λ x → ℕ→N (suc r) x) (double-lemma ds) ⟩
--     ℕ→N (suc r) (DirNum→ℕ {suc r} (↓ , ds))
--   ≡⟨ NℕNlemma (suc r) (↓ , ds) ⟩
--     bn (↓ , ds)
--   ∎
-- N→ℕ→N (suc r) (bn (↑ , ds)) =
--     sucN (ℕ→N (suc r) (doubleℕ (DirNum→ℕ ds)))
--   ≡⟨ cong (λ x → sucN (ℕ→N (suc r) x)) (double-lemma ds) ⟩
--     sucN (ℕ→N (suc r) (DirNum→ℕ {suc r} (↓ , ds)))
--   ≡⟨ cong sucN (NℕNlemma (suc r) (↓ , ds)) ⟩
--     sucN (bn (↓ , ds))
--   ≡⟨ refl ⟩
--     bn (↑ , ds)
--   ∎
-- N→ℕ→N (suc r) (xr (↓ , ds) x) =
--      ℕ→N (suc r)
--       (sucn (doubleℕ (DirNum→ℕ ds))
--        (doublesℕ r (doubleℕ (N→ℕ (suc r) x))))
--    ≡⟨ cong (λ z → ℕ→N (suc r) (sucn z (doublesℕ r (doubleℕ (N→ℕ (suc r) x))))) (double-lemma ds)  ⟩
--       ℕ→N (suc r)
--       (sucn (DirNum→ℕ {suc r} (↓ , ds))
--        (doublesℕ r (doubleℕ (N→ℕ (suc r) x))))
--    ≡⟨ refl ⟩
--      ℕ→N (suc r)
--       (sucn (DirNum→ℕ {suc r} (↓ , ds))
--        (doublesℕ (suc r) (N→ℕ (suc r) x)))
--    ≡⟨ ℕ→Nsucn (suc r) (DirNum→ℕ {suc r} (↓ , ds)) (doublesℕ (suc r) (N→ℕ (suc r) x)) ⟩
--      sucnN (DirNum→ℕ {suc r} (↓ , ds))
--       (ℕ→N (suc r) (doublesℕ (suc r) (N→ℕ (suc r) x)))
--    ≡⟨ cong (λ z → sucnN (DirNum→ℕ {suc r} (↓ , ds)) z) (H (suc r) (suc r) (N→ℕ (suc r) x)) ⟩
--      sucnN (DirNum→ℕ {suc r} (↓ , ds))
--       (doublesN (suc r) (suc r) (ℕ→N (suc r) (N→ℕ (suc r) x)))
--    ≡⟨ cong (λ z → sucnN (DirNum→ℕ {suc r} (↓ , ds)) (doublesN (suc r) (suc r) z)) (N→ℕ→N (suc r) x) ⟩
--      sucnN (DirNum→ℕ {suc r} (↓ , ds))
--       (doublesN (suc r) (suc r) x)
--    ≡⟨ G (suc r) (↓ , ds) x snotz ⟩
--      xr (↓ , ds) x ∎
--    where
--      H : (r m n : ℕ) → ℕ→N r (doublesℕ m n) ≡ doublesN r m (ℕ→N r n)
--      H r m n = {!!}
--      G : (r : ℕ) (d : DirNum r) (x : N r) → ¬ (r ≡ 0) → sucnN (DirNum→ℕ {r} d) (doublesN r r x) ≡ xr d x
--      G zero d x 0≠0 = ⊥-elim (0≠0 refl)
--      G (suc r) d (bn x) r≠0 = {!!}
--      G (suc r) d (xr x x₁) r≠0 = {!!}
-- N→ℕ→N (suc r) (xr (↑ , ds) x) with max? ds
-- ... | no ds≠max =
--           sucN
--           (ℕ→N (suc r)
--            (sucn (doubleℕ (DirNum→ℕ ds))
--             (doublesℕ r (doubleℕ (N→ℕ (suc r) x)))))
--         ≡⟨ sym (ℕ→Nsuc (suc r)
--                 (sucn (doubleℕ (DirNum→ℕ ds)) (doublesℕ r (doubleℕ (N→ℕ (suc r) x)))))
--          ⟩
--            ℕ→N (suc r)
--            (suc (sucn (doubleℕ (DirNum→ℕ ds)) (doublesℕ r (doubleℕ (N→ℕ (suc r) x)))))
--         ≡⟨ refl ⟩
--            ℕ→N (suc r)
--            (suc (sucn (doubleℕ (DirNum→ℕ ds)) (doublesℕ (suc r) (N→ℕ (suc r) x))))
--         ≡⟨ cong (λ z → ℕ→N (suc r) z)
--                 (sym (sucnsuc (doubleℕ (DirNum→ℕ ds)) (doublesℕ (suc r) (N→ℕ (suc r) x))))
--          ⟩
--            ℕ→N (suc r)
--            (sucn (doubleℕ (DirNum→ℕ ds)) (suc (doublesℕ (suc r) (N→ℕ (suc r) x))))
--          ≡⟨ ℕ→Nsucn (suc r) (doubleℕ (DirNum→ℕ ds)) (suc (doublesℕ (suc r) (N→ℕ (suc r) x))) ⟩
--            sucnN (doubleℕ (DirNum→ℕ ds)) (ℕ→N (suc r) (suc (doublesℕ (suc r) (N→ℕ (suc r) x))))
--          ≡⟨ cong (λ z → sucnN (doubleℕ (DirNum→ℕ ds)) z)
--                   (ℕ→Nsuc (suc r) (doublesℕ (suc r) (N→ℕ (suc r) x)))
--           ⟩
--            --   (2^(r+1)*x + 1) + 2*ds
--            -- = 2*(2^r*x + ds) + 1
--            -- = 2*(
--            sucnN (doubleℕ (DirNum→ℕ ds)) (sucN (ℕ→N (suc r) (doublesℕ (suc r) (N→ℕ (suc r) x))))
--          ≡⟨ {!!} ⟩ {!!}
-- ... | yes ds≡max = {!!}

-- ℕ→N→ℕ : (r : ℕ) → (n : ℕ) → N→ℕ r (ℕ→N r n) ≡ n
-- ℕ→N→ℕ zero zero = refl
-- ℕ→N→ℕ (suc r) zero =
--     doubleℕ (DirNum→ℕ (zero-n r))
--   ≡⟨ cong doubleℕ (zero-n≡0 {r}) ⟩
--     doubleℕ zero
--   ≡⟨ refl ⟩
--     zero
--   ∎
-- ℕ→N→ℕ zero (suc n) = cong suc (ℕ→N→ℕ zero n)
-- ℕ→N→ℕ (suc r) (suc n) =
--     N→ℕ (suc r) (sucN (ℕ→N (suc r) n))
--   ≡⟨ N→ℕsucN (suc r) (ℕ→N (suc r) n) ⟩
--     suc (N→ℕ (suc r) (ℕ→N (suc r) n))
--   ≡⟨ cong suc (ℕ→N→ℕ (suc r) n) ⟩
--     suc n
--   ∎

-- N≃ℕ : (r : ℕ) → N r ≃ ℕ
-- N≃ℕ r = isoToEquiv (iso (N→ℕ r) (ℕ→N r) (ℕ→N→ℕ r) (N→ℕ→N r))

-- N≡ℕ : (r : ℕ) → N r ≡ ℕ
-- N≡ℕ r = ua (N≃ℕ r)


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

open import Agda.Builtin.Cubical.Glue
open import Agda.Primitive
open import Agda.Primitive.Cubical

-- Glue must only be used in erased contexts when --erased-cubical is
-- active.

_ : SSet (lsuc lzero)
_ =
  (φ : I) (A : Set) (B : Partial φ Set)
  (f : PartialP φ (λ x → B x ≃ A)) →
  primGlue A B f


-- Andreas, 2014-05-02  Negative fixities allow now.

module _ where

infix -1 _+_
infix 0  _*_

postulate
  _+_ : Set1 → Set2 → Set1
  _*_ : Set2 → Set2 → Set2

test = Set + Set1 * Set1


-- Andreas, 2017-12-04, issue #2862, reported by m0davis
-- Regression in development version 2.5.4

-- Scope checker allowed definition in different module than signature

-- {-# OPTIONS -v scope.data.def:30 #-}

open import Agda.Builtin.Equality

data N : Set

module Z where
  data N where  -- should be rejected since signature lives in different module
    zero : N
  unitary-N : (x y : N) → x ≡ y
  unitary-N zero zero = refl

data N where
  zero : N
  suc : N → N

data ⊥ : Set where

one : N
one = suc zero

¬zero≡one : zero ≡ one → ⊥
¬zero≡one ()

zero≡one : zero ≡ one
zero≡one = Z.unitary-N zero one

boom : ⊥
boom = ¬zero≡one zero≡one


{-# OPTIONS --allow-unsolved-metas #-}
module Term where

open import OscarPrelude
open import VariableName
open import FunctionName
open import Arity
open import Vector

mutual

  data Term : Set
   where
    variable : VariableName → Term
    function : FunctionName → Terms → Term

  record Terms : Set
   where
    constructor ⟨_⟩
    inductive
    field
      {arity} : Arity
      terms : Vector Term arity

open Terms public

termVariable-inj : ∀ {𝑥₁ 𝑥₂} → Term.variable 𝑥₁ ≡ variable 𝑥₂ → 𝑥₁ ≡ 𝑥₂
termVariable-inj refl = refl

termFunction-inj₁ : ∀ {𝑓₁ 𝑓₂ τ₁s τ₂s} → Term.function 𝑓₁ τ₁s ≡ function 𝑓₂ τ₂s → 𝑓₁ ≡ 𝑓₂
termFunction-inj₁ refl = refl

termFunction-inj₂ : ∀ {𝑓₁ 𝑓₂ τ₁s τ₂s} → Term.function 𝑓₁ τ₁s ≡ function 𝑓₂ τ₂s → τ₁s ≡ τ₂s
termFunction-inj₂ refl = refl

terms-inj : ∀ {𝑎} → {τs₁ τs₂ : Vector Term 𝑎} → (τs₁≡τs₂ : (Terms.⟨_⟩ {𝑎} τs₁) ≡ ⟨ τs₂ ⟩) → τs₁ ≡ τs₂
terms-inj refl = refl

module _ where

  open import TermByFunctionNames

  mutual
    termToTermByFunctionNames : Term → Σ Nat TermByFunctionNames
    termToTermByFunctionNames (variable x) = _ , (variable x)
    termToTermByFunctionNames (function x x₁) = {!!}

    termsToVec : Terms → Σ Nat (λ arity → Σ (Vec (Σ Nat TermByFunctionNames) arity) λ τs → Σ Nat λ n → n ≡ sum (vecToList $ (fst <$> τs)))
    termsToVec (⟨_⟩ {arity = arity₁} ⟨ vector₁ ⟩) = {!!}

  iTermToTerm : Σ Nat TermByFunctionNames → Term
  iTermToTerm = {!!}

eq-term-round : ∀ τ → iTermToTerm (termToTermByFunctionNames τ) ≡ τ
eq-term-round = {!!}

eq-iterm-round : ∀ τ → termToTermByFunctionNames (iTermToTerm τ) ≡ τ
eq-iterm-round = {!!}

instance EqTerm : Eq Term
Eq._==_ EqTerm x y with termToTermByFunctionNames x | graphAt termToTermByFunctionNames x | termToTermByFunctionNames y | graphAt termToTermByFunctionNames y
Eq._==_ EqTerm x y | ix | ingraph eqx | iy | ingraph eqy with ix ≟ iy
Eq._==_ EqTerm x y | ix | ingraph eqx | .ix | ingraph eqy | yes refl = yes $ ((cong iTermToTerm eqy ⟨≡⟩ʳ cong iTermToTerm eqx) ⟨≡⟩ eq-term-round x) ʳ⟨≡⟩ eq-term-round y
Eq._==_ EqTerm x y | ix | ingraph eqx | iy | ingraph eqy | no neq = {!!}

instance EqTerms : Eq Terms
EqTerms = {!!}

{-
module _ {i : Size}
 where

  mutual

    EqTerm⇑ : (x y : Term) → Delay i ∘ Dec $ x ≡ y
    EqTerm⇑ (variable _) (variable _) = now (decEq₁ termVariable-inj $ _≟_ _ _)
    EqTerm⇑ (function 𝑓₁ τ₁s) (function 𝑓₂ τ₂s) =
      {-
      τ₁s≟τ₂s ← EqTerms⇑ τ₁s τ₂s -|
      (now $ decEq₂ termFunction-inj₁ termFunction-inj₂ (𝑓₁ ≟ 𝑓₂) τ₁s≟τ₂s)
      -}

      EqTerms⇑ τ₁s τ₂s >>= λ
      τ₁s≟τ₂s → now $ decEq₂ termFunction-inj₁ termFunction-inj₂ (𝑓₁ ≟ 𝑓₂) τ₁s≟τ₂s

    EqTerm⇑ (variable _)   (function _ _) = now $ no λ ()
    EqTerm⇑ (function _ _) (variable _)   = now $ no λ ()

    EqTerms⇑ : (x y : Terms) → Delay i ∘ Dec $ x ≡ y
    EqTerms⇑ (⟨_⟩ {𝑎₁} τ₁s) (⟨_⟩ {𝑎₂} τ₂s)
     with 𝑎₁ ≟ 𝑎₂
    … | no 𝑎₁≢𝑎₂ = now $ no λ {τ₁≡τ₂ → 𝑎₁≢𝑎₂ (cong arity τ₁≡τ₂)}
    … | yes refl =
      EqVectorTerm⇑ τ₁s τ₂s >>= λ
      { (yes refl) → now $ yes refl
      ; (no τ₁s≢τ₂s) → now $ no (λ ⟨τ₁s⟩≡⟨τ₂s⟩ → τ₁s≢τ₂s (terms-inj ⟨τ₁s⟩≡⟨τ₂s⟩)) }

    EqVectorTerm⇑ : ∀ {n} → (x y : Vector Term n) → Delay i ∘ Dec $ x ≡ y
    EqVectorTerm⇑ ⟨ [] ⟩ ⟨ [] ⟩ = now (yes refl)
    EqVectorTerm⇑ ⟨ τ₁ ∷ τ₁s ⟩ ⟨ τ₂ ∷ τ₂s ⟩ =
      EqTerm⇑ τ₁ τ₂ >>= λ
      { (yes refl) → EqVectorTerm⇑ ⟨ τ₁s ⟩ ⟨ τ₂s ⟩ >>= λ
                     { (yes refl) → now $ yes refl
                     ; (no τ₁s≢τ₂s) → now $ no λ τ₁₁s≡τ₁₂s → τ₁s≢τ₂s $ cong ⟨_⟩ ((vcons-inj-tail (cong vector τ₁₁s≡τ₁₂s))) }
      ; (no τ₁≢τ₂) → now $ no λ τ₁₁s≡τ₂₂s → τ₁≢τ₂ $ vcons-inj-head (cong vector τ₁₁s≡τ₂₂s) }

EqVectorTerm⇓ : ∀ {n} → (x y : Vector Term n) → EqVectorTerm⇑ x y ⇓
EqVectorTerm⇓ ⟨ [] ⟩ ⟨ [] ⟩ = _ , now⇓
EqVectorTerm⇓ ⟨ variable 𝑥₁ ∷ τ₁s ⟩ ⟨ variable 𝑥₂ ∷ τ₂s ⟩
 with 𝑥₁ ≟ 𝑥₂
… | yes refl with EqVectorTerm⇓ ⟨ τ₁s ⟩ ⟨ τ₂s ⟩
EqVectorTerm⇓ ⟨ variable 𝑥₁ ∷ τ₁s ⟩ ⟨ variable .𝑥₁ ∷ .τ₁s ⟩ | yes refl | (yes refl , snd₁) = _ , snd₁ >>=⇓ now⇓
EqVectorTerm⇓ ⟨ variable 𝑥₁ ∷ τ₁s ⟩ ⟨ variable .𝑥₁ ∷ τ₂s ⟩ | yes refl | (no x , snd₁) = _ , snd₁ >>=⇓ now⇓
EqVectorTerm⇓ ⟨ variable 𝑥₁ ∷ τ₁s ⟩ ⟨ variable 𝑥₂ ∷ τ₂s ⟩ | no 𝑥₁≢𝑥₂ = _ , now⇓
EqVectorTerm⇓ ⟨ variable x ∷ τ₁s ⟩ ⟨ function x₁ x₂ ∷ τ₂s ⟩ = _ , now⇓
EqVectorTerm⇓ ⟨ function x x₁ ∷ τ₁s ⟩ ⟨ variable x₂ ∷ τ₂s ⟩ = _ , now⇓
EqVectorTerm⇓ ⟨ function 𝑓₁ (⟨_⟩ {𝑎₁} τ₁s) ∷ τ₁₂s ⟩ ⟨ function 𝑓₂ (⟨_⟩ {𝑎₂} τ₂s) ∷ τ₂₂s ⟩
 with 𝑎₁ ≟ 𝑎₂ | 𝑓₁ ≟ 𝑓₂
… | no 𝑎₁≢𝑎₂ | no 𝑓₁≢𝑓₂  = _ , now⇓
… | no 𝑎₁≢𝑎₂ | yes refl  = _ , now⇓
… | yes refl | no 𝑓₁≢𝑓₂
 with EqVectorTerm⇓ τ₁s τ₂s
… | (no τ₁s≢τ₂s , τ⇓)  = _ , τ⇓ >>=⇓ now⇓ >>=⇓ now⇓ >>=⇓ now⇓
… | (yes refl , τ⇓)    = _ , τ⇓ >>=⇓ now⇓ >>=⇓ now⇓ >>=⇓ now⇓
EqVectorTerm⇓ ⟨ function 𝑓₁ (⟨_⟩ {𝑎₁} τ₁s) ∷ τ₁₂s ⟩ ⟨ function 𝑓₂ (⟨_⟩ {𝑎₂} τ₂s) ∷ τ₂₂s ⟩ | yes refl | yes refl
 with EqVectorTerm⇓ τ₁s τ₂s | EqVectorTerm⇓ ⟨ τ₁₂s ⟩ ⟨ τ₂₂s ⟩
… | (no τ₁s≢τ₂s , τ⇓) | (no τ₁₂s≢τ₂₂s , τs⇓) = _ , τ⇓ >>=⇓ now⇓ >>=⇓ now⇓ >>=⇓ now⇓
… | (yes refl , τ⇓)   | (no τ₁₂s≢τ₂₂s , τs⇓) = _ , τ⇓ >>=⇓ now⇓ >>=⇓ now⇓ >>=⇓ (τs⇓ >>=⇓ now⇓)
… | (no τ₁s≢τ₂s , τ⇓) | (yes refl , τs⇓) = _ , τ⇓ >>=⇓ now⇓ >>=⇓ now⇓ >>=⇓ now⇓
… | (yes refl , τ⇓)   | (yes refl , τs⇓) = _ , τ⇓ >>=⇓ now⇓ >>=⇓ now⇓ >>=⇓ (τs⇓ >>=⇓ now⇓)

EqTerms⇓ : (x y : Terms) → EqTerms⇑ x y ⇓
EqTerms⇓ (⟨_⟩ {𝑎₁} τ₁s) (⟨_⟩ {𝑎₂} τ₂s)
 with 𝑎₁ ≟ 𝑎₂
… | no 𝑎₁≢𝑎₂ = _ , now⇓
… | yes refl
 with EqVectorTerm⇓ τ₁s τ₂s
… | (yes refl , τ⇓) = _ , τ⇓ >>=⇓ now⇓
… | (no _ , τ⇓) = _ , τ⇓ >>=⇓ now⇓

EqTerm⇓ : (x y : Term) → EqTerm⇑ x y ⇓
EqTerm⇓ (variable x) (variable x₁) = _ , now⇓
EqTerm⇓ (function _ τ₁s) (function _ τ₂s)
 with EqTerms⇓ τ₁s τ₂s
… | (_ , τ⇓) = _ , τ⇓ >>=⇓ now⇓
EqTerm⇓ (variable x) (function x₁ x₂) = _ , now⇓
EqTerm⇓ (function x x₁) (variable x₂) = _ , now⇓

instance EqTerm : Eq Term
EqTerm = record { _==_ = λ x y → fst (EqTerm⇓ x y) }

instance EqTerms : Eq Terms
Eq._==_ EqTerms x y = fst (EqTerms⇓ x y)
-}

module _ where

  open import Membership

  instance MembershipTermTerms : Membership Term Terms
  Membership._∈_ MembershipTermTerms = _ᵗ∈ᵗˢ_ where
    data _ᵗ∈ᵗˢ_ (τ : Term) : Terms → Set
     where
      zero : τ ᵗ∈ᵗˢ ⟨ ⟨ τ ∷ [] ⟩ ⟩
      suc : ∀ {τs} → τ ᵗ∈ᵗˢ τs → τ ᵗ∈ᵗˢ ⟨ ⟨ τ ∷ vector (terms τs) ⟩ ⟩
  Membership._∉_ MembershipTermTerms x X = ¬ x ∈ X
  fst (Membership.xor-membership MembershipTermTerms) x₁ x₂ = x₂ x₁
  snd (Membership.xor-membership MembershipTermTerms) x₁ x₂ = x₁ x₂

  instance MembershipVariableNameTerm : Membership VariableName Term
  Membership._∈_ MembershipVariableNameTerm = _ᵛ∈ᵗ_ where
    data _ᵛ∈ᵗ_ (𝑥 : VariableName) : Term → Set
     where
      variable : 𝑥 ᵛ∈ᵗ variable 𝑥
      function : ∀ 𝑓 {τ : Term} {τs} → {_ : 𝑥 ∈ τ} → τ ∈ τs → 𝑥 ᵛ∈ᵗ function 𝑓 τs
  Membership._∉_ MembershipVariableNameTerm x X = ¬ x ∈ X
  fst (Membership.xor-membership MembershipVariableNameTerm) x₁ x₂ = x₂ x₁
  snd (Membership.xor-membership MembershipVariableNameTerm) x₁ x₂ = x₁ x₂

module _ where
  import UnifyTermL
  import UnifyMguCorrectL

  module L where
    open UnifyTermL (Maybe FunctionName) public
    open UnifyMguCorrectL (Maybe FunctionName) public

  mutual

    TermLtoTerm : ∃ L.Term → Term
    TermLtoTerm (fst₁ , UnifyTermL.i x) = {!!}
    TermLtoTerm (fst₁ , UnifyTermL.leaf nothing) = {!!}
    TermLtoTerm (fst₁ , UnifyTermL.leaf (just x)) = {!!}
    TermLtoTerm (fst₁ , (snd₁ UnifyTermL.fork snd₂)) = {!!}

    TermtoTermL : Term → ∃ L.Term
    TermtoTermL (variable x) = {!!} , (L.i {!!})
    TermtoTermL (function x ⟨ ⟨ [] ⟩ ⟩) = {!!} , L.leaf (just x) L.fork L.leaf nothing
    TermtoTermL (function x ⟨ ⟨ x₁ ∷ vector₁ ⟩ ⟩) = {!!} , {!!} L.fork {!!}


open import Everything

module Test.SurjidentityP where

module _
    {𝔬₁} {𝔒₁ : Ø 𝔬₁}
    {𝔯₁} (_∼₁_ : 𝔒₁ → 𝔒₁ → Ø 𝔯₁)
    {𝔬₂} {𝔒₂ : Ø 𝔬₂}
    {𝔯₂} (_∼₂_ : 𝔒₂ → 𝔒₂ → Ø 𝔯₂)
         (_∼₂2_ : 𝔒₂ → 𝔒₂ → Ø 𝔯₂)
    {𝔯₂'} (_∼₂'_ : 𝔒₂ → 𝔒₂ → Ø 𝔯₂')
    {ℓ₂} (_∼̇₂_ : ∀ {x y} → x ∼₂ y → x ∼₂ y → Ø ℓ₂)
         (_∼̇₂'_ : ∀ {x y} → x ∼₂' y → x ∼₂' y → Ø ℓ₂)
         (_∼̇₂2_ : ∀ {x y} → x ∼₂2 y → x ∼₂2 y → Ø ℓ₂)
    ⦃ _ : Surjection.class 𝔒₁ 𝔒₂ ⦄
    ⦃ _ : Smap!.class _∼₁_ _∼₂_                         ⦄
    ⦃ _ : Smap!.class _∼₁_ _∼₂'_                        ⦄
    ⦃ _ : Smap!.class _∼₁_ _∼₂2_                        ⦄
    ⦃ _ : Reflexivity.class _∼₁_                               ⦄
    ⦃ _ : Reflexivity.class _∼₂_                               ⦄
    ⦃ _ : Reflexivity.class _∼₂'_                                ⦄
    ⦃ _ : Reflexivity.class _∼₂2_                                ⦄
    ⦃ _ : Surjidentity!.class _∼₁_ _∼₂_ _∼̇₂_                        ⦄
    ⦃ _ : Surjidentity!.class _∼₁_ _∼₂'_ _∼̇₂'_                     ⦄
    ⦃ _ : Surjidentity!.class _∼₁_ _∼₂2_ _∼̇₂2_                     ⦄
    where

  test-surj : Surjidentity!.type _∼₁_ _∼₂_ _∼̇₂_
  test-surj = surjidentity

  test-surj[] : Surjidentity!.type _∼₁_ _∼₂_ _∼̇₂_
  test-surj[] = surjidentity[ _∼₁_ , _∼̇₂_ ]


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

   Copyright (c) 2020 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 Category.Functor
open import Data.Maybe
open import Function
open import Level
open import Relation.Binary.PropositionalEquality

module Optics.Functorial where

  Lens' : (F : Set → Set) → RawFunctor F → Set → Set → Set
  Lens' F _ S A = (A → F A) → S → F S

  data Lens (S A : Set) : Set₁ where
    lens : ((F : Set → Set)(rf : RawFunctor F) → Lens' F rf S A)
         → Lens S A

  private
    cf : {A : Set} → RawFunctor {Level.zero} (const A)
    cf = record { _<$>_ = λ x x₁ → x₁ }

    if : RawFunctor {Level.zero} id
    if = record { _<$>_ = λ x x₁ → x x₁ }

  -- We can make lenses relatively painlessly without requiring reflection
  -- by providing getter and setter functions
  mkLens' : ∀ {A B : Set}
          → (B → A)
          → (B → A → B)
          → Lens B A
  mkLens' {A} {B} get set =
    lens (λ F rf f b → Category.Functor.RawFunctor._<$>_
                         {F = F} rf
                         {A = A}
                         {B = B}
                         (set b)
                         (f (get b)))

  -- Getter:

  -- this is typed as ^\.
  _^∙_ : ∀{S A} → S → Lens S A → A
  _^∙_ {_} {A} s (lens p) = p (const A) cf id s

   -- Setter:

  set : ∀{S A} → Lens S A → A → S → S
  set (lens p) a s = p id if (const a) s

  infixr 4 _∙~_
  _∙~_ = set

  -- _|>_ is renamed to _&_ by Util.Prelude
  set? : ∀{S A} → Lens S (Maybe A) → A → S → S
  set? l a s = s |> l ∙~ just a

  infixr 4 _?~_
  _?~_ = set?

  -- Modifier:
  over : ∀{S A} → Lens S A → (A → A) → S → S
  over (lens p) f s = p id if f s

  infixr 4 _%~_
  _%~_ = over

  -- Composition
  infixr 30 _∙_
  _∙_ : ∀{S A B} → Lens S A → Lens A B → Lens S B
  (lens p) ∙ (lens q) = lens (λ F rf x x₁ → p F rf (q F rf x) x₁)

  -- Relation between the same field of two states This most general form allows us to specify a
  -- Lens S A, a function A → B, and a relation between two B's, and holds iff the relation holds
  -- between the values yielded by applying the Lens to two S's and then applying the function to
  -- the results; more specific variants are provided below
  _[_]L_f=_at_ : ∀ {ℓ} {S A B : Set} → S → (B → B → Set ℓ) → S → (A → B) → Lens S A → Set ℓ
  s₁ [ _~_ ]L s₂ f= f at l = f (s₁ ^∙ l) ~ f (s₂ ^∙ l)

  _[_]L_at_ : ∀ {ℓ} {S A} → S → (A → A → Set ℓ) → S → Lens S A → Set ℓ
  s₁ [ _~_ ]L s₂ at l = _[_]L_f=_at_ s₁ _~_ s₂ id l

  infix 4 _≡L_f=_at_
  _≡L_f=_at_ : ∀ {S A B : Set} → (s₁ s₂ : S) → (A → B) → Lens S A → Set
  s₁ ≡L s₂ f= f at l = _[_]L_f=_at_ s₁ _≡_ s₂ f l

  infix 4 _≡L_at_
  _≡L_at_ : ∀ {S A} → (s₁ s₂ : S) → Lens S A → Set
  s₁ ≡L s₂ at l = _[_]L_f=_at_ s₁ _≡_ s₂ id l


{- Name: Bowornmet (Ben) Hudson

-- new source language module. trying stuff out

-}

open import Preliminaries
open import Preorder-withmax

module Source2 where

  data Tp : Set where
    unit : Tp
    nat : Tp
    susp : Tp → Tp
    _->s_ : Tp → Tp → Tp
    _×s_ : Tp → Tp → Tp
    list : Tp → Tp
    bool : Tp

  Ctx = List Tp

  -- de Bruijn indices
  data _∈_ : Tp → Ctx → Set where
    i0 : ∀ {Γ τ} → τ ∈ τ :: Γ
    iS : ∀ {Γ τ τ1} → τ ∈ Γ → τ ∈ τ1 :: Γ

  data _|-_ : Ctx → Tp → Set where
    unit : ∀ {Γ} → Γ |- unit
    var : ∀ {Γ τ}
        → τ ∈ Γ
        → Γ |- τ
    z : ∀ {Γ} → Γ |- nat
    suc : ∀ {Γ}
        → (e : Γ |- nat)
        → Γ |- nat
    rec : ∀ {Γ τ} → Γ |- nat → Γ |- τ → (nat :: (susp τ :: Γ)) |- τ
        → Γ |- τ
    lam : ∀ {Γ τ ρ} → (ρ :: Γ) |- τ
        → Γ |- (ρ ->s τ)
    app : ∀ {Γ τ1 τ2}
        → Γ |- (τ2 ->s τ1) → Γ |- τ2
        → Γ |- τ1
    prod : ∀ {Γ τ1 τ2}
         → Γ |- τ1 → Γ |- τ2
         → Γ |- (τ1 ×s τ2)
    delay : ∀ {Γ τ}
          → Γ |- τ
          → Γ |- susp τ
    force : ∀ {Γ τ}
          → Γ |- susp τ
          → Γ |- τ
    split : ∀ {Γ τ τ1 τ2}
          → Γ |- (τ1 ×s τ2) → (τ1 :: (τ2 :: Γ)) |- τ
          → Γ |- τ
    nil : ∀ {Γ τ} → Γ |- list τ
    _::s_ : ∀ {Γ τ} → Γ |- τ → Γ |- list τ → Γ |- list τ
    listrec : ∀ {Γ τ τ'} → Γ |- list τ → Γ |- τ' → (τ :: (list τ :: (susp τ' :: Γ))) |- τ' → Γ |- τ'
    true : ∀ {Γ} → Γ |- bool
    false : ∀ {Γ} → Γ |- bool

  module RenSubst where

      -- renaming = variable for variable substitution
      --functional view:
      --avoids induction,
      --some associativity/unit properties for free
    module Ren where

      -- read: you can rename Γ' as Γ
      rctx : Ctx → Ctx → Set
      rctx Γ Γ' = ∀ {τ} → τ ∈ Γ' → τ ∈ Γ

      rename-var : ∀ {Γ Γ' τ} → rctx Γ Γ' → τ ∈ Γ' → τ ∈ Γ
      rename-var ρ a = ρ a

      idr : ∀ {Γ} → rctx Γ Γ
      idr x = x

      -- weakening with renaming
      p∙ : ∀ {Γ Γ' τ} → rctx Γ Γ' → rctx (τ :: Γ) Γ'
      p∙ ρ = λ x → iS (ρ x)

      p : ∀ {Γ τ} → rctx (τ :: Γ) Γ
      p = p∙ idr

      _∙rr_ : ∀ {A B C} → rctx A B → rctx B C → rctx A C
      ρ1 ∙rr ρ2 = ρ1 o ρ2

      -- free stuff
      rename-var-ident : ∀ {Γ τ} → (x : τ ∈ Γ) → rename-var idr x == x
      rename-var-ident _ = Refl

      rename-var-∙ : ∀ {A B C τ} → (r1 : rctx A B) (r2 : rctx B C) (x : τ ∈ C)
                  → rename-var r1 (rename-var r2 x) == rename-var (r1 ∙rr r2) x
      rename-var-∙ _ _ _ = Refl

      ∙rr-assoc : ∀ {A B C D} → (r1 : rctx A B) (r2 : rctx B C) (r3 : rctx C D) → _==_ {_} {rctx A D} (r1 ∙rr (r2 ∙rr r3)) ((r1 ∙rr r2) ∙rr r3)
      ∙rr-assoc r1 r2 r3 = Refl

      r-extend : ∀ {Γ Γ' τ} → rctx Γ Γ' → rctx (τ :: Γ) (τ :: Γ')
      r-extend ρ i0 = i0
      r-extend ρ (iS x) = iS (ρ x)

      ren : ∀ {Γ Γ' τ} → Γ' |- τ → rctx Γ Γ' → Γ |- τ
      ren unit ρ = unit
      ren (var x) ρ = var (ρ x)
      ren z ρ = z
      ren (suc e) ρ = suc (ren e ρ)
      ren (rec e e₁ e₂) ρ = rec (ren e ρ) (ren e₁ ρ) (ren e₂ (r-extend (r-extend ρ)))
      ren (lam e) ρ = lam (ren e (r-extend ρ))
      ren (app e e₁) ρ = app (ren e ρ) (ren e₁ ρ)
      ren (prod e1 e2) ρ = prod (ren e1 ρ) (ren e2 ρ)
      ren (delay e) ρ = delay (ren e ρ)
      ren (force e) ρ = force (ren e ρ)
      ren (split e e₁) ρ = split (ren e ρ) (ren e₁ (r-extend (r-extend ρ)))
      -- list stuff
      ren nil ρ = nil
      ren (x ::s xs) ρ = ren x ρ ::s ren xs ρ
      ren true ρ = true
      ren false ρ = false
      ren (listrec e e₁ e₂) ρ = listrec (ren e ρ) (ren e₁ ρ) (ren e₂ (r-extend (r-extend (r-extend ρ))))

      extend-ren-comp-lemma : ∀ {Γ Γ' Γ'' τ τ'} → (x : τ ∈ τ' :: Γ'') (ρ1 : rctx Γ Γ') (ρ2 : rctx Γ' Γ'')
                            → Id {_} {_} ((r-extend ρ1 ∙rr r-extend ρ2) x) (r-extend (ρ1 ∙rr ρ2) x)
      extend-ren-comp-lemma i0 ρ1 ρ2 = Refl
      extend-ren-comp-lemma (iS x) ρ1 ρ2 = Refl

      extend-ren-comp : ∀ {Γ Γ' Γ'' τ} → (ρ1 : rctx Γ Γ') → (ρ2 : rctx Γ' Γ'')
                      → Id {_} {rctx (τ :: Γ) (τ :: Γ'')} (r-extend ρ1 ∙rr r-extend ρ2) (r-extend (ρ1 ∙rr ρ2))
      extend-ren-comp ρ1 ρ2 = λ=i (λ τ → λ= (λ x → extend-ren-comp-lemma x ρ1 ρ2))

      ren-comp : ∀ {Γ Γ' Γ'' τ} → (ρ1 : rctx Γ Γ') → (ρ2 : rctx Γ' Γ'') → (e : Γ'' |- τ)
               → (ren (ren e ρ2) ρ1) == (ren e (ρ1 ∙rr ρ2))
      ren-comp ρ1 ρ2 unit = Refl
      ren-comp ρ1 ρ2 (var x) = ap var (rename-var-∙ ρ1 ρ2 x)
      ren-comp ρ1 ρ2 z = Refl
      ren-comp ρ1 ρ2 (suc e) = ap suc (ren-comp ρ1 ρ2 e)
      ren-comp ρ1 ρ2 (rec e e₁ e₂) = ap3 rec (ren-comp ρ1 ρ2 e) (ren-comp ρ1 ρ2 e₁)
                                         (ap (ren e₂) (ap r-extend (extend-ren-comp ρ1 ρ2) ∘
                                           extend-ren-comp (r-extend ρ1) (r-extend ρ2)) ∘
                                           ren-comp (r-extend (r-extend ρ1)) (r-extend (r-extend ρ2)) e₂)
      ren-comp ρ1 ρ2 (lam e) = ap lam ((ap (ren e) (extend-ren-comp ρ1 ρ2)) ∘ ren-comp (r-extend ρ1) (r-extend ρ2) e)
      ren-comp ρ1 ρ2 (app e e₁) = ap2 app (ren-comp ρ1 ρ2 e) (ren-comp ρ1 ρ2 e₁)
      ren-comp ρ1 ρ2 (prod e e₁) = ap2 prod (ren-comp ρ1 ρ2 e) (ren-comp ρ1 ρ2 e₁)
      ren-comp ρ1 ρ2 (delay e) = ap delay (ren-comp ρ1 ρ2 e)
      ren-comp ρ1 ρ2 (force e) = ap force (ren-comp ρ1 ρ2 e)
      ren-comp ρ1 ρ2 (split e e₁) = ap2 split (ren-comp ρ1 ρ2 e)
                                        (ap (ren e₁) (ap r-extend (extend-ren-comp ρ1 ρ2) ∘
                                        extend-ren-comp (r-extend ρ1) (r-extend ρ2)) ∘
                                        ren-comp (r-extend (r-extend ρ1)) (r-extend (r-extend ρ2)) e₁)
      ren-comp ρ1 ρ2 nil = Refl
      ren-comp ρ1 ρ2 (e ::s e₁) = ap2 _::s_ (ren-comp ρ1 ρ2 e) (ren-comp ρ1 ρ2 e₁)
      ren-comp ρ1 ρ2 (listrec e e₁ e₂) = ap3 listrec (ren-comp ρ1 ρ2 e) (ren-comp ρ1 ρ2 e₁)
                                           (ap (ren e₂) (ap r-extend (ap r-extend (extend-ren-comp ρ1 ρ2)) ∘
                                           (ap r-extend (extend-ren-comp (r-extend ρ1) (r-extend ρ2)) ∘
                                           extend-ren-comp (r-extend (r-extend ρ1)) (r-extend (r-extend ρ2)))) ∘
                                           ren-comp (r-extend (r-extend (r-extend ρ1)))
                                                    (r-extend (r-extend (r-extend ρ2))) e₂)
      ren-comp ρ1 ρ2 true = Refl
      ren-comp ρ1 ρ2 false = Refl

      -- weakening a context
      wkn : ∀ {Γ τ1 τ2} → Γ |- τ2 → (τ1 :: Γ) |- τ2
      wkn e = ren e iS

    open Ren

    sctx : Ctx → Ctx → Set
    sctx Γ Γ' = ∀ {τ} → τ ∈ Γ' → Γ |- τ

    --lem2 (addvar)
    s-extend : ∀ {Γ Γ' τ} → sctx Γ Γ' → sctx (τ :: Γ) (τ :: Γ')
    s-extend Θ i0 = var i0
    s-extend Θ (iS x) = wkn (Θ x)

    ids : ∀ {Γ} → sctx Γ Γ
    ids x = var x

      -- weakening with substitution
    q∙ : ∀ {Γ Γ' τ} → sctx Γ Γ' → sctx (τ :: Γ) Γ'
    q∙ Θ = λ x → wkn (Θ x)

    lem3' : ∀ {Γ Γ' τ} → sctx Γ Γ' → Γ |- τ → sctx Γ (τ :: Γ')
    lem3' Θ e i0 = e
    lem3' Θ e (iS i) = Θ i

      --lem3
    q : ∀ {Γ τ} → Γ |- τ → sctx Γ (τ :: Γ)
    q e = lem3' ids e

    -- subst-var
    svar : ∀ {Γ1 Γ2 τ} → sctx Γ1 Γ2 → τ ∈ Γ2 → Γ1 |- τ
    svar Θ i = q (Θ i) i0

    lem4' : ∀ {Γ Γ' τ1 τ2} → sctx Γ Γ' → Γ |- τ1 → Γ |- τ2 → sctx Γ (τ1 :: (τ2 :: Γ'))
    lem4' Θ a b = lem3' (lem3' Θ b) a

    lem4 : ∀ {Γ τ1 τ2} → Γ |- τ1 → Γ |- τ2 → sctx Γ (τ1 :: (τ2 :: Γ))
    lem4 e1 e2 = lem4' ids e1 e2

    subst : ∀ {Γ Γ' τ} → Γ' |- τ → sctx Γ Γ' → Γ |- τ
    subst unit Θ = unit
    subst (var x) Θ = Θ x
    subst z Θ = z
    subst (suc e) Θ = suc (subst e Θ)
    subst (rec e e₁ e₂) Θ = rec (subst e Θ) (subst e₁ Θ) (subst e₂ (s-extend (s-extend Θ)))
    subst (lam e) Θ = lam (subst e (s-extend Θ))
    subst (app e e₁) Θ = app (subst e Θ) (subst e₁ Θ)
    subst (prod e1 e2) Θ = prod (subst e1 Θ) (subst e2 Θ)
    subst (delay e) Θ = delay (subst e Θ)
    subst (force e) Θ = force (subst e Θ)
    subst (split e e₁) Θ = split (subst e Θ) (subst e₁ (s-extend (s-extend Θ)))
      -- list stuff
    subst nil Θ = nil
    subst (x ::s xs) Θ = subst x Θ ::s subst xs Θ
    subst true Θ = true
    subst false Θ = false
    subst (listrec e e₁ e₂) Θ = listrec (subst e Θ) (subst e₁ Θ) (subst e₂ (s-extend (s-extend (s-extend Θ))))

    subst1 : ∀ {Γ τ τ1} → Γ |- τ1 → (τ1 :: Γ) |- τ → Γ |- τ
    subst1 e e' = subst e' (q e)

    _rs_ : ∀ {A B C} → rctx A B → sctx B C → sctx A C
    _rs_ ρ Θ x = ren (subst (var x) Θ) ρ

    _ss_ : ∀ {A B C} → sctx A B → sctx B C → sctx A C
    _ss_ Θ1 Θ2 x = subst (subst (var x) Θ2) Θ1

    _sr_ : ∀ {A B C} → sctx A B → rctx B C → sctx A C
    _sr_ Θ ρ x = subst (ren (var x) ρ) Θ

    --free stuff
    svar-rs : ∀ {A B C τ} (ρ : rctx A B) (Θ : sctx B C) (x : τ ∈ C)
            → svar (ρ rs Θ) x == ren (svar Θ x) ρ
    svar-rs = λ ρ Θ x → Refl

    svar-ss : ∀ {A B C τ} (Θ1 : sctx A B) (Θ2 : sctx B C) (x : τ ∈ C)
            → svar (Θ1 ss Θ2) x == subst (svar Θ2 x) Θ1
    svar-ss = λ Θ1 Θ2 x → Refl

    svar-sr : ∀ {A B C τ} (Θ : sctx A B) (ρ : rctx B C) (x : τ ∈ C)
            → svar Θ (rename-var ρ x) == svar (Θ sr ρ) x
    svar-sr = λ Θ ρ x → Refl

    svar-id : ∀ {Γ τ} → (x : τ ∈ Γ) → var x == svar ids x
    svar-id = λ x → Refl

    rsr-assoc : ∀ {A B C D} → (ρ1 : rctx A B) (Θ : sctx B C) (ρ2 : rctx C D)
              → Id {_} {sctx A D} ((ρ1 rs Θ) sr ρ2) (ρ1 rs (Θ sr ρ2))
    rsr-assoc = λ ρ1 Θ ρ2 → Refl

    extend-id-once-lemma : ∀ {Γ τ τ'} → (x : τ ∈ τ' :: Γ) → _==_ {_} {τ' :: Γ |- τ}
                         (ids {τ' :: Γ} {τ} x) (s-extend {Γ} {Γ} {τ'} (ids {Γ}) {τ} x)
    extend-id-once-lemma i0 = Refl
    extend-id-once-lemma (iS x) = Refl

    extend-id-once : ∀ {Γ τ} → Id {_} {sctx (τ :: Γ) (τ :: Γ)} (ids {τ :: Γ}) (s-extend ids)
    extend-id-once = λ=i (λ τ → λ= (λ x → extend-id-once-lemma x))

    extend-id-twice : ∀ {Γ τ1 τ2} → Id {_} {sctx (τ1 :: τ2 :: Γ) (τ1 :: τ2 :: Γ)} (ids {τ1 :: τ2 :: Γ}) (s-extend (s-extend ids))
    extend-id-twice = ap s-extend extend-id-once ∘ extend-id-once

    subst-id : ∀ {Γ τ} (e : Γ |- τ) → e == subst e ids
    subst-id unit = Refl
    subst-id (var x) = svar-id x
    subst-id z = Refl
    subst-id (suc e) = ap suc (subst-id e)
    subst-id (rec e e₁ e₂) = ap3 rec (subst-id e) (subst-id e₁) (ap (subst e₂) extend-id-twice ∘ subst-id e₂)
    subst-id (lam e) = ap lam (ap (subst e) extend-id-once ∘ subst-id e)
    subst-id (app e e₁) = ap2 app (subst-id e) (subst-id e₁)
    subst-id (prod e e₁) = ap2 prod (subst-id e) (subst-id e₁)
    subst-id (delay e) = ap delay (subst-id e)
    subst-id (force e) = ap force (subst-id e)
    subst-id (split e e₁) = ap2 split (subst-id e) (ap (subst e₁) extend-id-twice ∘ subst-id e₁)
    subst-id nil = Refl
    subst-id (e ::s e₁) = ap2 _::s_ (subst-id e) (subst-id e₁)
    subst-id true = Refl
    subst-id false = Refl
    subst-id (listrec e e₁ e₂) = ap3 listrec (subst-id e) (subst-id e₁) (ap (subst e₂) (ap s-extend (ap s-extend extend-id-once) ∘ extend-id-twice) ∘ subst-id e₂)

    extend-rs-once-lemma : ∀ {A B C τ τ'} → (x : τ ∈ τ' :: B) (ρ : rctx C A) (Θ : sctx A B) → _==_ {_} {τ' :: C |- τ}
                         (_rs_ {τ' :: C} {τ' :: A} {τ' :: B} (r-extend {C} {A} {τ'} ρ)
                           (s-extend {A} {B} {τ'} Θ) {τ} x)
                           (s-extend {C} {B} {τ'} (_rs_ {C} {A} {B} ρ Θ) {τ} x)
    extend-rs-once-lemma i0 ρ Θ = Refl
    extend-rs-once-lemma (iS x) ρ Θ = ! (ren-comp iS ρ (Θ x)) ∘ ren-comp (r-extend ρ) iS (Θ x)

    extend-rs-once : ∀ {A B C τ} → (ρ : rctx C A) (Θ : sctx A B)
                   → Id {_} {sctx (τ :: C) (τ :: B)} (r-extend ρ rs s-extend Θ) (s-extend (ρ rs Θ))
    extend-rs-once ρ Θ = λ=i (λ τ → λ= (λ x → extend-rs-once-lemma x ρ Θ))

    extend-rs-twice : ∀ {A B C τ τ'} → (ρ : rctx C A) (Θ : sctx A B)
                    → Id {_} {sctx (τ :: τ' :: C) (τ :: τ' :: B)} ((r-extend (r-extend ρ)) rs (s-extend (s-extend Θ))) ((s-extend (s-extend (ρ rs Θ))))
    extend-rs-twice ρ Θ = ap s-extend (extend-rs-once ρ Θ) ∘ extend-rs-once (r-extend ρ) (s-extend Θ)

    subst-rs : ∀ {A B C τ} → (ρ : rctx C A) (Θ : sctx A B) (e : B |- τ)
             → ren (subst e Θ) ρ == subst e (ρ rs Θ)
    subst-rs ρ Θ unit = Refl
    subst-rs ρ Θ (var x) = svar-rs ρ Θ x
    subst-rs ρ Θ z = Refl
    subst-rs ρ Θ (suc e) = ap suc (subst-rs ρ Θ e)
    subst-rs ρ Θ (rec e e₁ e₂) = ap3 rec (subst-rs ρ Θ e) (subst-rs ρ Θ e₁)
                                   (ap (subst e₂) (extend-rs-twice ρ Θ) ∘
                                   subst-rs (r-extend (r-extend ρ)) (s-extend (s-extend Θ)) e₂)
    subst-rs ρ Θ (lam e) = ap lam (ap (subst e) (extend-rs-once ρ Θ) ∘ subst-rs (r-extend ρ) (s-extend Θ) e)
    subst-rs ρ Θ (app e e₁) = ap2 app (subst-rs ρ Θ e) (subst-rs ρ Θ e₁)
    subst-rs ρ Θ (prod e e₁) = ap2 prod (subst-rs ρ Θ e) (subst-rs ρ Θ e₁)
    subst-rs ρ Θ (delay e) = ap delay (subst-rs ρ Θ e)
    subst-rs ρ Θ (force e) = ap force (subst-rs ρ Θ e)
    subst-rs ρ Θ (split e e₁) = ap2 split (subst-rs ρ Θ e)
                                          (ap (subst e₁) (extend-rs-twice ρ Θ) ∘
                                          subst-rs (r-extend (r-extend ρ)) (s-extend (s-extend Θ)) e₁)
    subst-rs ρ Θ nil = Refl
    subst-rs ρ Θ (e ::s e₁) = ap2 _::s_ (subst-rs ρ Θ e) (subst-rs ρ Θ e₁)
    subst-rs ρ Θ true = Refl
    subst-rs ρ Θ false = Refl
    subst-rs ρ Θ (listrec e e₁ e₂) = ap3 listrec (subst-rs ρ Θ e) (subst-rs ρ Θ e₁)
                                         (ap (subst e₂) (ap s-extend (ap s-extend (extend-rs-once ρ Θ)) ∘
                                         extend-rs-twice (r-extend ρ) (s-extend Θ)) ∘
                                         subst-rs (r-extend (r-extend (r-extend ρ))) (s-extend (s-extend (s-extend Θ))) e₂)

    rs-comp : ∀ {Γ Γ' Γ'' τ} → (ρ : rctx Γ Γ') → (Θ : sctx Γ' Γ'') → (e : Γ'' |- τ)
            → (ren (subst e Θ) ρ) == subst e (ρ rs Θ)
    rs-comp ρ Θ unit = Refl
    rs-comp ρ Θ (var x) = svar-rs ρ Θ x
    rs-comp ρ Θ z = Refl
    rs-comp ρ Θ (suc e) = ap suc (rs-comp ρ Θ e)
    rs-comp ρ Θ (rec e e₁ e₂) = ap3 rec (rs-comp ρ Θ e) (rs-comp ρ Θ e₁)
                                (ap (subst e₂) (extend-rs-twice ρ Θ) ∘ rs-comp (r-extend (r-extend ρ)) (s-extend (s-extend Θ)) e₂)
    rs-comp ρ Θ (lam e) = ap lam (ap (subst e) (extend-rs-once ρ Θ) ∘ rs-comp (r-extend ρ) (s-extend Θ) e)
    rs-comp ρ Θ (app e e₁) = ap2 app (rs-comp ρ Θ e) (rs-comp ρ Θ e₁)
    rs-comp ρ Θ (prod e e₁) = ap2 prod (rs-comp ρ Θ e) (rs-comp ρ Θ e₁)
    rs-comp ρ Θ (delay e) = ap delay (rs-comp ρ Θ e)
    rs-comp ρ Θ (force e) = ap force (rs-comp ρ Θ e)
    rs-comp ρ Θ (split e e₁) = ap2 split (rs-comp ρ Θ e) (ap (subst e₁) (extend-rs-twice ρ Θ) ∘ rs-comp (r-extend (r-extend ρ)) (s-extend (s-extend Θ)) e₁)
    rs-comp ρ Θ nil = Refl
    rs-comp ρ Θ (e ::s e₁) = ap2 _::s_ (rs-comp ρ Θ e) (rs-comp ρ Θ e₁)
    rs-comp ρ Θ (listrec e e₁ e₂) = ap3 listrec (rs-comp ρ Θ e) (rs-comp ρ Θ e₁)
                                      (ap (subst e₂) (ap s-extend (ap s-extend (extend-rs-once ρ Θ)) ∘
                                      extend-rs-twice (r-extend ρ) (s-extend Θ)) ∘
                                      rs-comp (r-extend (r-extend (r-extend ρ)))
                                      (s-extend (s-extend (s-extend Θ))) e₂)
    rs-comp ρ Θ true = Refl
    rs-comp ρ Θ false = Refl

    extend-sr-once-lemma : ∀ {A B C τ τ'} → (Θ : sctx A B) (ρ : rctx B C) (x : τ ∈ τ' :: C)
                         → _==_ {_} {τ' :: A |- τ} (s-extend (_sr_ Θ ρ) x) (_sr_ (s-extend Θ) (r-extend ρ) x)
    extend-sr-once-lemma Θ ρ i0 = Refl
    extend-sr-once-lemma Θ ρ (iS x) = Refl

    extend-sr-once : ∀ {A B C τ} → (Θ : sctx A B) (ρ : rctx B C)
                   → Id {_} {sctx (τ :: A) (τ :: C)} (s-extend Θ sr r-extend ρ) (s-extend (Θ sr ρ))
    extend-sr-once Θ ρ = λ=i (λ τ → λ= (λ x → ! (extend-sr-once-lemma Θ ρ x)))

    extend-sr-twice : ∀ {A B C τ τ'} → (Θ : sctx A B) (ρ : rctx B C)
                   → Id {_} {sctx (τ' :: τ :: A) (τ' :: τ :: C)}
                     (s-extend (s-extend Θ) sr r-extend (r-extend ρ)) (s-extend (s-extend (Θ sr ρ)))
    extend-sr-twice Θ ρ = ap s-extend (extend-sr-once Θ ρ) ∘ extend-sr-once (s-extend Θ) (r-extend ρ)

    sr-comp : ∀ {Γ Γ' Γ'' τ} → (Θ : sctx Γ Γ') → (ρ : rctx Γ' Γ'') → (e : Γ'' |- τ)
            → (subst (ren e ρ) Θ) == subst e (Θ sr ρ)
    sr-comp Θ ρ unit = Refl
    sr-comp Θ ρ (var x) = svar-sr Θ ρ x
    sr-comp Θ ρ z = Refl
    sr-comp Θ ρ (suc e) = ap suc (sr-comp Θ ρ e)
    sr-comp Θ ρ (rec e e₁ e₂) = ap3 rec (sr-comp Θ ρ e) (sr-comp Θ ρ e₁)
                                        (ap (subst e₂) (ap s-extend (extend-sr-once Θ ρ) ∘
                                        extend-sr-once (s-extend Θ) (r-extend ρ)) ∘
                                        sr-comp (s-extend (s-extend Θ)) (r-extend (r-extend ρ)) e₂)
    sr-comp Θ ρ (lam e) = ap lam (ap (subst e) (extend-sr-once Θ ρ) ∘ sr-comp (s-extend Θ) (r-extend ρ) e)
    sr-comp Θ ρ (app e e₁) = ap2 app (sr-comp Θ ρ e) (sr-comp Θ ρ e₁)
    sr-comp Θ ρ (prod e e₁) = ap2 prod (sr-comp Θ ρ e) (sr-comp Θ ρ e₁)
    sr-comp Θ ρ (delay e) = ap delay (sr-comp Θ ρ e)
    sr-comp Θ ρ (force e) = ap force (sr-comp Θ ρ e)
    sr-comp Θ ρ (split e e₁) = ap2 split (sr-comp Θ ρ e) (ap (subst e₁) (ap s-extend (extend-sr-once Θ ρ) ∘
                                                         extend-sr-once (s-extend Θ) (r-extend ρ)) ∘
                                                         sr-comp (s-extend (s-extend Θ)) (r-extend (r-extend ρ)) e₁)
    sr-comp Θ ρ nil = Refl
    sr-comp Θ ρ (e ::s e₁) = ap2 _::s_ (sr-comp Θ ρ e) (sr-comp Θ ρ e₁)
    sr-comp Θ ρ (listrec e e₁ e₂) = ap3 listrec (sr-comp Θ ρ e) (sr-comp Θ ρ e₁)
                                                (ap (subst e₂) (ap s-extend (ap s-extend (extend-sr-once Θ ρ)) ∘
                                                extend-sr-twice (s-extend Θ) (r-extend ρ)) ∘
                                                   sr-comp (s-extend (s-extend (s-extend Θ)))
                                                   (r-extend (r-extend (r-extend ρ))) e₂)

    sr-comp Θ ρ true = Refl
    sr-comp Θ ρ false = Refl

    extend-ss-once-lemma : ∀ {A B C τ τ'} → (Θ1 : sctx A B) (Θ2 : sctx B C) (x : τ ∈ τ' :: C)
                         → _==_ {_} {τ' :: A |- τ} (s-extend (_ss_ Θ1 Θ2) x) (_ss_ (s-extend Θ1) (s-extend Θ2) x)
    extend-ss-once-lemma Θ1 Θ2 i0 = Refl
    extend-ss-once-lemma Θ1 Θ2 (iS x) = ! (sr-comp (s-extend Θ1) iS (Θ2 x)) ∘ rs-comp iS Θ1 (Θ2 x)

    extend-ss-once : ∀ {A B C τ} → (Θ1 : sctx A B) (Θ2 : sctx B C)
                → _==_ {_} {sctx (τ :: A) (τ :: C)} (s-extend (Θ1 ss Θ2))
                ((s-extend Θ1) ss
                (s-extend Θ2))
    extend-ss-once Θ1 Θ2 = λ=i (λ τ → λ= (λ x → extend-ss-once-lemma Θ1 Θ2 x))

    subst-ss : ∀ {A B C τ} → (Θ1 : sctx A B) (Θ2 : sctx B C) (e : C |- τ)
             → subst e (Θ1 ss Θ2) == subst (subst e Θ2) Θ1
    subst-ss Θ1 Θ2 unit = Refl
    subst-ss Θ1 Θ2 (var x) = svar-ss Θ1 Θ2 x
    subst-ss Θ1 Θ2 z = Refl
    subst-ss Θ1 Θ2 (suc e) = ap suc (subst-ss Θ1 Θ2 e)
    subst-ss Θ1 Θ2 (rec e e₁ e₂) = ap3 rec (subst-ss Θ1 Θ2 e) (subst-ss Θ1 Θ2 e₁)
                                   (subst-ss (s-extend (s-extend Θ1)) (s-extend (s-extend Θ2)) e₂ ∘
                                   ap (subst e₂) (extend-ss-once (s-extend Θ1) (s-extend Θ2) ∘
                                   ap s-extend (extend-ss-once Θ1 Θ2)))
    subst-ss Θ1 Θ2 (lam e) = ap lam (subst-ss (s-extend Θ1) (s-extend Θ2) e ∘ ap (subst e) (extend-ss-once Θ1 Θ2))
    subst-ss Θ1 Θ2 (app e e₁) = ap2 app (subst-ss Θ1 Θ2 e) (subst-ss Θ1 Θ2 e₁)
    subst-ss Θ1 Θ2 (prod e e₁) = ap2 prod (subst-ss Θ1 Θ2 e) (subst-ss Θ1 Θ2 e₁)
    subst-ss Θ1 Θ2 (delay e) = ap delay (subst-ss Θ1 Θ2 e)
    subst-ss Θ1 Θ2 (force e) = ap force (subst-ss Θ1 Θ2 e)
    subst-ss Θ1 Θ2 (split e e₁) = ap2 split (subst-ss Θ1 Θ2 e)
                                            (subst-ss (s-extend (s-extend Θ1)) (s-extend (s-extend Θ2)) e₁ ∘
                                            ap (subst e₁) (extend-ss-once (s-extend Θ1) (s-extend Θ2) ∘
                                            ap s-extend (extend-ss-once Θ1 Θ2)))
    subst-ss Θ1 Θ2 nil = Refl
    subst-ss Θ1 Θ2 (e ::s e₁) = ap2 _::s_ (subst-ss Θ1 Θ2 e) (subst-ss Θ1 Θ2 e₁)
    subst-ss Θ1 Θ2 true = Refl
    subst-ss Θ1 Θ2 false = Refl
    subst-ss Θ1 Θ2 (listrec e e₁ e₂) = ap3 listrec (subst-ss Θ1 Θ2 e) (subst-ss Θ1 Θ2 e₁)
                                       (subst-ss (s-extend (s-extend (s-extend Θ1))) (s-extend (s-extend (s-extend Θ2))) e₂ ∘
                                       ap (subst e₂) (extend-ss-once (s-extend (s-extend Θ1)) (s-extend (s-extend Θ2)) ∘
                                       ap s-extend (extend-ss-once (s-extend Θ1) (s-extend Θ2) ∘
                                       ap s-extend (extend-ss-once Θ1 Θ2))))

    throw : ∀ {Γ Γ' τ} → sctx Γ (τ :: Γ') → sctx Γ Γ'
    throw Θ x = Θ (iS x)

    fuse1 : ∀ {Γ Γ' τ τ'} (v : Γ |- τ') (Θ : sctx Γ Γ') (x : τ ∈ Γ') → (q v ss q∙ Θ) x == Θ x
    fuse1 v Θ x = subst (ren (Θ x) iS) (q v) =⟨ sr-comp (q v) iS (Θ x) ⟩
               subst (Θ x) (q v sr iS) =⟨ Refl ⟩
               subst (Θ x) ids =⟨ ! (subst-id (Θ x)) ⟩
               (Θ x ∎)

    subst-compose-lemma-lemma : ∀ {Γ Γ' τ τ'} (v : Γ |- τ') (Θ : sctx Γ Γ') (x : τ ∈ τ' :: Γ')
                              → _==_ {_} {Γ |- τ} (_ss_ (q v) (s-extend Θ) x) (lem3' Θ v x)
    subst-compose-lemma-lemma v Θ i0 = Refl
    subst-compose-lemma-lemma v Θ (iS x) = subst (wkn (subst (var x) Θ)) (lem3' ids v) =⟨ subst-ss (q v) (q∙ Θ) (var x) ⟩
                                           subst (var x) (q v ss q∙ Θ) =⟨ fuse1 v Θ x ⟩
                                           subst (var x) Θ =⟨ Refl ⟩
                                           Θ x ∎

    fuse2 : ∀ {Γ Γ' τ τ1 τ2} (v1 : Γ |- τ1) (v2 : Γ |- τ2) (Θ : sctx Γ Γ') (x : τ ∈ τ2 :: Γ')
        → (lem4 v1 v2 ss throw (s-extend (s-extend Θ))) x == (lem3' Θ v2) x
    fuse2 v1 v2 Θ x = subst (ren (s-extend Θ x) iS) (lem4 v1 v2) =⟨ sr-comp (lem4 v1 v2) iS (s-extend Θ x) ⟩
                      subst (s-extend Θ x) (lem4 v1 v2 sr iS) =⟨ Refl ⟩
                      subst (s-extend Θ x) (lem3' ids v2) =⟨ subst-compose-lemma-lemma v2 Θ x ⟩
                      (lem3' Θ v2 x ∎)

    subst-compose-lemma : ∀ {Γ Γ' τ} (v : Γ |- τ) (Θ : sctx Γ Γ')
                        → _==_ {_} {sctx Γ (τ :: Γ')} ((q v) ss (s-extend Θ)) (lem3' Θ v)
    subst-compose-lemma v Θ = λ=i (λ τ → λ= (λ x → subst-compose-lemma-lemma v Θ x))

    subst-compose : ∀ {Γ Γ' τ τ1} (Θ : sctx Γ Γ') (v : Γ |- τ) (e : (τ :: Γ' |- τ1) )
                  → subst (subst e (s-extend Θ)) (q v) == subst e (lem3' Θ v)
    subst-compose Θ v e = ap (subst e) (subst-compose-lemma v Θ) ∘ (! (subst-ss (q v) (s-extend Θ) e))

    subst-compose2-lemma-lemma : ∀ {Γ Γ' τ τ1 τ2 τ'} (v1 : Γ |- τ1) (v2 : Γ |- τ2) (e1 : τ1 :: τ2 :: Γ' |- τ) (Θ : sctx Γ Γ') (x : τ' ∈ τ1 :: τ2 :: Γ')
                               → _==_ {_} {_} ((lem4 v1 v2 ss s-extend (s-extend Θ)) x) (lem4' Θ v1 v2 x)
    subst-compose2-lemma-lemma v1 v2 e1 Θ i0 = Refl
    subst-compose2-lemma-lemma v1 v2 e1 Θ (iS x) = subst (wkn (s-extend Θ x)) (lem4 v1 v2) =⟨ Refl ⟩
                                                   subst (var x) (lem4 v1 v2 ss throw (s-extend (s-extend Θ))) =⟨ fuse2 v1 v2 Θ x ⟩
                                                   subst (var x) (lem3' Θ v2) =⟨ Refl ⟩
                                                   (lem3' Θ v2 x ∎)

    subst-compose2-lemma : ∀ {Γ Γ' τ τ1 τ2} (v1 : Γ |- τ1) (v2 : Γ |- τ2) (e1 : τ1 :: τ2 :: Γ' |- τ) (Θ : sctx Γ Γ')
                         → _==_ {_} {sctx Γ (τ1 :: τ2 :: Γ')} (lem4 v1 v2 ss s-extend (s-extend Θ)) (lem4' Θ v1 v2)
    subst-compose2-lemma v1 v2 e1 Θ = λ=i (λ τ → λ= (λ x → subst-compose2-lemma-lemma v1 v2 e1 Θ x))

    subst-compose2 : ∀ {Γ Γ' τ} (Θ : sctx Γ Γ') (n : Γ |- nat) (e1 : Γ' |- τ) (e2 : (nat :: (susp τ :: Γ')) |- τ)
                  →  subst (subst e2 (s-extend (s-extend Θ))) (lem4 n (delay (rec n (subst e1 Θ) (subst e2 (s-extend (s-extend Θ)))))) ==
                     subst e2 (lem4' Θ n (delay (rec n (subst e1 Θ) (subst e2 (s-extend (s-extend Θ))))))
    subst-compose2 Θ n e1 e2 = ap (subst e2) (subst-compose2-lemma n (delay (rec n (subst e1 Θ) (subst e2 (s-extend (s-extend Θ))))) e2 Θ) ∘
                               ! (subst-ss (lem4 n (delay (rec n (subst e1 Θ) (subst e2 (s-extend (s-extend Θ)))))) (s-extend (s-extend Θ)) e2)

    subst-compose3 : ∀ {Γ Γ' τ τ1 τ2} (Θ : sctx Γ Γ') (e1 : (τ1 :: (τ2 :: Γ')) |- τ) (v1 : Γ |- τ1) (v2 : Γ |- τ2)
                   → subst (subst e1 (s-extend (s-extend Θ))) (lem4 v1 v2) == subst e1 (lem4' Θ v1 v2)
    subst-compose3 Θ e1 v1 v2 = ap (subst e1) (subst-compose2-lemma v1 v2 e1 Θ) ∘
                                ! (subst-ss (lem4 v1 v2) (s-extend (s-extend Θ)) e1)

    subst-compose4 : ∀ {Γ Γ' τ} (Θ : sctx Γ Γ') (v' : Γ |- nat) (r : Γ |- susp τ) (e2 : (nat :: (susp τ :: Γ')) |- τ)
                   → subst (subst e2 (s-extend (s-extend Θ))) (lem4 v' r) == subst e2 (lem4' Θ v' r)
    subst-compose4 Θ v' r e2 = ap (subst e2) (subst-compose2-lemma v' r e2 Θ) ∘
                             ! (subst-ss (lem4 v' r) (s-extend (s-extend Θ)) e2)

  open RenSubst

  --closed values of the source language
  data val : ∀ {τ} → [] |- τ → Set where
    z-isval : val z
    suc-isval : (e : [] |- nat) → (val e)
              → val (suc e)
    pair-isval : ∀ {τ1 τ2} (e1 : [] |- τ1) → (e2 : [] |- τ2)
               → val e1 → val e2
               → val (prod e1 e2)
    lam-isval : ∀ {ρ τ} (e : (ρ :: []) |- τ)
              → val (lam e)
    unit-isval : val unit
    delay-isval : ∀ {τ} (e : [] |- τ) → val (delay e)
    nil-isval : ∀ {τ} → val (nil {_} {τ})
    cons-isval : ∀ {τ} (x : [] |- τ) → (xs : [] |- list τ)
               → val x → val xs
               → val (x ::s xs)
    true-isval : val true
    false-isval : val false

  data Cost : Set where
    0c : Cost
    1c : Cost
    _+c_ : Cost → Cost → Cost

  data Equals0c : Cost → Set where
    Eq0-0c : Equals0c 0c
    Eq0-+c : ∀ {c c'} → Equals0c c → Equals0c c' → Equals0c (c +c c')

  mutual
    -- define evals (e : source exp) (v : value) (c : nat)
    -- analogous to "e evaluates to v in c steps"
    -- figure 2 from ICFP paper
    data evals : {τ : Tp} → [] |- τ → [] |- τ → Cost → Set where
      pair-evals : ∀ {n1 n2}
                 → {τ1 τ2 : Tp} {e1 v1 : [] |- τ1} {e2 v2 : [] |- τ2}
                 → evals e1 v1 n1
                 → evals e2 v2 n2
                 → evals (prod e1 e2) (prod v1 v2) (n1 +c n2)
      lam-evals : ∀ {ρ τ} {e : (ρ :: []) |- τ}
                → evals (lam e) (lam e) 0c
      app-evals : ∀ {n0 n1 n}
               → {τ1 τ2 : Tp} {e0 : [] |- (τ1 ->s τ2)} {e0' : (τ1 :: []) |- τ2} {e1 v1 : [] |- τ1} {v : [] |- τ2}
               → evals e0 (lam e0') n0
               → evals e1 v1 n1
               → evals (subst e0' (q v1)) v n
               → evals (app e0 e1) v ((n0 +c n1) +c n)
      z-evals : evals z z 0c
      s-evals : ∀ {n}
              → {e v : [] |- nat}
              → evals e v n
              → evals (suc e) (suc v) n
      unit-evals : evals unit unit 0c
      rec-evals : ∀ {n1 n2}
                  → {τ : Tp} {e v : [] |- nat} {e0 v' : [] |- τ} {e1 : (nat :: (susp τ :: [])) |- τ}
                  → evals e v n1
                  → evals-rec-branch e0 e1 v v' n2
                  → evals (rec e e0 e1) v' (n1 +c (1c +c n2))
      delay-evals : {τ : Tp} {e : [] |- τ}
                  → evals (delay e) (delay e) 0c
      force-evals : ∀ {n1 n2}
                  → {τ : Tp} {e' v : [] |- τ} {e : [] |- susp τ}
                  → evals e (delay e') n1
                  → evals e' v n2
                  → evals (force e) v (n1 +c n2)
      split-evals : ∀ {n1 n2}
                  → {τ τ1 τ2 : Tp} {e0 : [] |- (τ1 ×s τ2)} {v1 : [] |- τ1} {v2 : [] |- τ2} {e1 : (τ1 :: (τ2 :: [])) |- τ} {v : [] |- τ}
                  → evals e0 (prod v1 v2) n1
                  → evals (subst e1 (lem4 v1 v2)) v n2
                  → evals (split e0 e1) v (n1 +c n2)
      nil-evals : ∀ {τ : Tp} → evals (nil {_} {τ}) (nil {_} {τ}) 0c
      cons-evals : ∀ {n1 n2}
                 → {τ : Tp} {x v : [] |- τ} {xs vs : [] |- list τ}
                 → evals x v n1
                 → evals xs vs n2
                 → evals (x ::s xs) (v ::s vs) (n1 +c n2)
      true-evals : evals true true 0c
      false-evals : evals false false 0c

    -- means evals (rec v e0 e1) v' n
    -- but helpful to have a separate type for this
    data evals-rec-branch {τ : Tp} (e0 : [] |- τ) (e1 : (nat :: (susp τ :: [])) |- τ) : (e : [] |- nat) (v : [] |- τ) → Cost → Set where
         evals-rec-z : ∀ {v n} → evals e0 v n → evals-rec-branch e0 e1 z v n
         evals-rec-s : ∀ {v v' n} → evals (subst e1 (lem4 v (delay (rec v e0 e1)))) v' n
                               → evals-rec-branch e0 e1 (suc v) v' n

  evals-val : {τ : Tp} {e : [] |- τ} {v : [] |- τ} {n : Cost} → evals e v n → val v
  evals-val (pair-evals D D₁) = pair-isval _ _ (evals-val D) (evals-val D₁)
  evals-val lam-evals = lam-isval _
  evals-val (app-evals D D₁ D₂) = evals-val D₂
  evals-val z-evals = z-isval
  evals-val (s-evals D) = suc-isval _ (evals-val D)
  evals-val unit-evals = unit-isval
  evals-val (rec-evals x (evals-rec-z D)) = evals-val D
  evals-val (rec-evals x (evals-rec-s D)) = evals-val D
  evals-val delay-evals = delay-isval _
  evals-val (force-evals D D₁) = evals-val D₁
  evals-val (split-evals D D₁) = evals-val D₁
  evals-val nil-evals = nil-isval
  evals-val (cons-evals D D₁) = cons-isval _ _ (evals-val D) (evals-val D₁)
  evals-val true-evals = true-isval
  evals-val false-evals = false-isval

  -- lemma 2 from ICFP paper
  val-evals-inversion : {τ : Tp} {v v' : [] |- τ} {n : Cost} → val v → evals v v' n → (v == v') × Equals0c n
  val-evals-inversion z-isval z-evals = Refl , Eq0-0c
  val-evals-inversion (suc-isval e ve) (s-evals D) = (ap suc (fst IH)) , snd IH where
    IH = val-evals-inversion ve D
  val-evals-inversion (pair-isval e1 e2 ve1 ve2) (pair-evals D D₁) = ap2 prod (fst IH1) (fst IH2) , Eq0-+c (snd IH1) (snd IH2) where
    IH1 = val-evals-inversion ve1 D
    IH2 = val-evals-inversion ve2 D₁
  val-evals-inversion (lam-isval e) lam-evals = Refl , Eq0-0c
  val-evals-inversion unit-isval unit-evals = Refl , Eq0-0c
  val-evals-inversion (delay-isval e) delay-evals = Refl , Eq0-0c
  val-evals-inversion nil-isval nil-evals = Refl , Eq0-0c
  val-evals-inversion (cons-isval x xs vx vxs) (cons-evals D D₁) = ap2 _::s_ (fst IH1) (fst IH2) , Eq0-+c (snd IH1) (snd IH2) where
    IH1 = val-evals-inversion vx D
    IH2 = val-evals-inversion vxs D₁
  val-evals-inversion true-isval true-evals = Refl , Eq0-0c
  val-evals-inversion false-isval false-evals = Refl , Eq0-0c


postulate
  A : Set
  P : A → Set

record ΣAP : Set where
  no-eta-equality
  field
    fst : A
    snd : P fst
open ΣAP

test : (x : ΣAP) → P (fst x)
test x = snd {!!}


module BuiltinSucWarning where

data Nat : Set where
  zero : Nat
  suc  : (n : Nat) → Nat

{-# BUILTIN NATURAL Nat #-}
{-# BUILTIN ZERO zero #-}
{-# BUILTIN SUC suc #-}

foo : Nat
foo = 13


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

module Categories.NaturalIsomorphism where

open import Level
open import Relation.Binary using (IsEquivalence)

open import Categories.Support.PropositionalEquality
open import Categories.Support.Equivalence
open import Categories.Category
open import Categories.Functor hiding (id) renaming (_∘_ to _∘F_; _≡_ to _≡F_; equiv to equivF)
open import Categories.NaturalTransformation.Core hiding (_≡_; equiv; setoid)
open import Categories.NaturalTransformation using (_∘ˡ_; _∘ʳ_)
import Categories.Morphisms as Morphisms
open import Categories.Functor.Properties using (module FunctorsAlways)

record NaturalIsomorphism {o ℓ e o′ ℓ′ e′}
                          {C : Category o ℓ e}
                          {D : Category o′ ℓ′ e′}
                          (F G : Functor C D) : Set (o ⊔ ℓ ⊔ e ⊔ o′ ⊔ ℓ′ ⊔ e′) where
  private module C = Category C
  private module D = Category D
  private module F = Functor F
  private module G = Functor G
  open F
  open G renaming (F₀ to G₀; F₁ to G₁)

  field
    F⇒G : NaturalTransformation F G
    F⇐G : NaturalTransformation G F

  module ⇒ = NaturalTransformation F⇒G
  module ⇐ = NaturalTransformation F⇐G

  open Morphisms D

  field
    .iso : ∀ X → Iso (⇒.η X) (⇐.η X)

equiv : ∀ {o ℓ e o′ ℓ′ e′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′} → IsEquivalence (NaturalIsomorphism {C = C} {D})
equiv {C = C} {D} = record
  { refl = record
    { F⇒G = id
    ; F⇐G = id
    ; iso = λ _ → record
      { isoˡ = D.identityˡ
      ; isoʳ = D.identityˡ
      }
    }
  ; sym = λ X → let module X Z = Morphisms.Iso (NaturalIsomorphism.iso X Z) in record
    { F⇒G = NaturalIsomorphism.F⇐G X
    ; F⇐G = NaturalIsomorphism.F⇒G X
    ; iso = λ Y → record
      { isoˡ = X.isoʳ Y
      ; isoʳ = X.isoˡ Y
      }
    }
  ; trans = trans′
  }
  where
  module C = Category C
  module D = Category D
  open D hiding (id)

  trans′ : {x y z : Functor C D} → NaturalIsomorphism x y → NaturalIsomorphism y z → NaturalIsomorphism x z
  trans′ X Y = record
    { F⇒G = F⇒G′
    ; F⇐G = F⇐G′
    ; iso = iso′
    }
    where
    F⇒G′ = NaturalIsomorphism.F⇒G Y ∘₁ NaturalIsomorphism.F⇒G X
    F⇐G′ = NaturalIsomorphism.F⇐G X ∘₁ NaturalIsomorphism.F⇐G Y

    .iso′ : (X : C.Obj) → _
    iso′ Z = record
      { isoˡ = isoˡ′
      ; isoʳ = isoʳ′
      }
      where
      open NaturalIsomorphism
      open NaturalTransformation
      module Y Z = Morphisms.Iso (iso Y Z)
      module X Z = Morphisms.Iso (iso X Z)

      isoˡ′ : (η (F⇐G X) Z ∘ η (F⇐G Y) Z) ∘ (η (F⇒G Y) Z ∘ η (F⇒G X) Z) ≡ D.id
      isoˡ′ = begin
                (η (F⇐G X) Z ∘ η (F⇐G Y) Z) ∘ (η (F⇒G Y) Z ∘ η (F⇒G X) Z)
              ↓⟨ D.assoc ⟩
                η (F⇐G X) Z ∘ (η (F⇐G Y) Z ∘ (η (F⇒G Y) Z ∘ η (F⇒G X) Z))
              ↑⟨ D.∘-resp-≡ʳ D.assoc ⟩
                η (F⇐G X) Z ∘ ((η (F⇐G Y) Z ∘ η (F⇒G Y) Z) ∘ η (F⇒G X) Z)
              ↓⟨ D.∘-resp-≡ʳ (D.∘-resp-≡ˡ (Y.isoˡ Z)) ⟩
                η (F⇐G X) Z ∘ (D.id ∘ η (F⇒G X) Z)
              ↓⟨ D.∘-resp-≡ʳ D.identityˡ ⟩
                η (F⇐G X) Z ∘ η (F⇒G X) Z
              ↓⟨ X.isoˡ Z ⟩
                D.id
              ∎
        where
        open D.HomReasoning

      isoʳ′ : (η (F⇒G Y) Z ∘ η (F⇒G X) Z) ∘ (η (F⇐G X) Z ∘ η (F⇐G Y) Z) ≡ D.id
      isoʳ′ = begin
                (η (F⇒G Y) Z ∘ η (F⇒G X) Z) ∘ (η (F⇐G X) Z ∘ η (F⇐G Y) Z)
              ↓⟨ D.assoc ⟩
                η (F⇒G Y) Z ∘ (η (F⇒G X) Z ∘ (η (F⇐G X) Z ∘ η (F⇐G Y) Z))
              ↑⟨ D.∘-resp-≡ʳ D.assoc ⟩
                η (F⇒G Y) Z ∘ ((η (F⇒G X) Z ∘ η (F⇐G X) Z) ∘ η (F⇐G Y) Z)
              ↓⟨ D.∘-resp-≡ʳ (D.∘-resp-≡ˡ (X.isoʳ Z)) ⟩
                η (F⇒G Y) Z ∘ (D.id ∘ η (F⇐G Y) Z)
              ↓⟨ D.∘-resp-≡ʳ D.identityˡ ⟩
                η (F⇒G Y) Z ∘ η (F⇐G Y) Z
              ↓⟨ Y.isoʳ Z ⟩
                D.id
              ∎
        where
        open D.HomReasoning

setoid : ∀ {o ℓ e o′ ℓ′ e′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′} → Setoid _ _
setoid {C = C} {D} = record
  { Carrier = Functor C D
  ; _≈_ = NaturalIsomorphism
  ; isEquivalence = equiv {C = C} {D}
  }

_ⓘˡ_ : ∀ {o₀ ℓ₀ e₀ o₁ ℓ₁ e₁ o₂ ℓ₂ e₂}
     → {C : Category o₀ ℓ₀ e₀} {D : Category o₁ ℓ₁ e₁} {E : Category o₂ ℓ₂ e₂}
     → {F G : Functor C D}
     → (H : Functor D E) → (η : NaturalIsomorphism F G) → NaturalIsomorphism (H ∘F F) (H ∘F G)
_ⓘˡ_ {C = C} {D} {E} {F} {G} H η = record
  { F⇒G = H ∘ˡ η.F⇒G
  ; F⇐G = H ∘ˡ η.F⇐G
  ; iso = λ X → FunctorsAlways.resp-Iso H (η.iso X)
  }
  where
  module η = NaturalIsomorphism η

_ⓘʳ_ : ∀ {o₀ ℓ₀ e₀ o₁ ℓ₁ e₁ o₂ ℓ₂ e₂}
     → {C : Category o₀ ℓ₀ e₀} {D : Category o₁ ℓ₁ e₁} {E : Category o₂ ℓ₂ e₂}
     → {F G : Functor C D}
     → (η : NaturalIsomorphism F G) → (K : Functor E C) → NaturalIsomorphism (F ∘F K) (G ∘F K)
η ⓘʳ K = record
  { F⇒G = η.F⇒G ∘ʳ K
  ; F⇐G = η.F⇐G ∘ʳ K
  ; iso = λ X → η.iso (K.F₀ X)
  }
  where
  module η = NaturalIsomorphism η
  module K = Functor K

-- try ≡→iso again, but via first de-embedding some helpers, as that seems to make things
-- go 'weird' in combination with irrelevance
private
  _©_ : ∀ {o ℓ e o′ ℓ′ e′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′} {F G : Functor C D} →
       NaturalTransformation F G → (x : Category.Obj C) → D [ Functor.F₀ F x , Functor.F₀ G x ]
  _©_ = NaturalTransformation.η

  my-sym : ∀ {o ℓ e o′ ℓ′ e′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′} (F G : Functor C D) → F ≡F G → G ≡F F
  my-sym {D = D} _ _ F≡G X = Heterogeneous.sym D (F≡G X)

  oneway : ∀ {o ℓ e o′ ℓ′ e′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′} (F G : Functor C D) →
    F ≡F G → NaturalTransformation F G
  oneway {C = C} {D} F G F≡G =
    record
    { η = my-η
    ; commute = my-commute
    }
    where
    module C = Category C
    module D = Category D
    module F = Functor F
    module G = Functor G
    open Heterogeneous D
    same-Objs : ∀ A → F.F₀ A ≣ G.F₀ A
    same-Objs A = domain-≣ (F≡G (C.id {A}))
    my-η : ∀ X → D [ F.F₀ X , G.F₀ X ]
    my-η X = ≣-subst (λ x → D [ F.F₀ X , x ]) (same-Objs X) D.id

    .my-commute : ∀ {X Y} (f : C [ X , Y ]) → D [ D [ my-η Y ∘ F.F₁ f ] ≡ D [ G.F₁ f ∘ my-η X ] ]
    my-commute {X} {Y} f with helper₃
      where
      helper₁ : D [ my-η Y ∘ F.F₁ f ] ∼ F.F₁ f
      helper₁ with F.F₀ Y | G.F₀ Y | same-Objs Y | F.F₁ f
      helper₁ | _ | ._ | ≣-refl | f′ = ≡⇒∼ D.identityˡ
      helper₂ : G.F₁ f ∼ D [ G.F₁ f ∘ my-η X ]
      helper₂ with F.F₀ X | G.F₀ X | same-Objs X | G.F₁ f
      helper₂ | _ | ._ | ≣-refl | f′ = ≡⇒∼ (D.Equiv.sym D.identityʳ)
      helper₃ : D [ my-η Y ∘ F.F₁ f ] ∼ D [ G.F₁ f ∘ my-η X ]
      helper₃ = trans helper₁ (trans (F≡G f) helper₂)
    my-commute f | Heterogeneous.≡⇒∼ pf = irr pf

≡→iso : ∀ {o ℓ e o′ ℓ′ e′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′} (F G : Functor C D) → F ≡F G → NaturalIsomorphism F G
≡→iso {C = C} {D} F G F≡G =
  record
  { F⇒G = oneway F G F≡G
  ; F⇐G = oneway G F (my-sym F G F≡G)
  ; iso = λ X → record
    { isoˡ = my-iso G F (my-sym F G F≡G) F≡G X
    ; isoʳ = my-iso F G F≡G (my-sym F G F≡G) X
    }
  }
  where
  module C = Category C
  module D = Category D
  open Heterogeneous D

  .my-iso : (F G : Functor C D) (F≡G : F ≡F G) (G≡F : G ≡F F) (x : C.Obj) → D [ D [ oneway F G F≡G © x ∘ oneway G F G≡F © x ] ≡ D.id ]
  my-iso F G F≡G G≡F x = func (F.F₀ x) (G.F₀ x) (domain-≣ (F≡G (C.id {x}))) (domain-≣ (G≡F (C.id {x})))
    where
    module F = Functor F
    module G = Functor G
    -- hand-written function that "with" cannot properly abstract on its own, it gets itself all confused.
    func : (w z : D.Obj) (zz : w ≣ z ) (ww : z ≣ w) →
        ≣-subst (D._⇒_ w) zz (D.id {w}) D.∘ ≣-subst (D._⇒_ z) ww (D.id {z}) D.≡ D.id
    func w .w ≣-refl ≣-refl = D.identityʳ


{-# OPTIONS --cubical --safe #-}
module Cubical.Structures.Group where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.FunExtEquiv
open import Cubical.Data.Prod.Base hiding (_×_) renaming (_×Σ_ to _×_)

open import Cubical.Foundations.SIP renaming (SNS-PathP to SNS)

open import Cubical.Structures.Monoid

private
  variable
    ℓ ℓ' : Level

group-axiom : (X : Type ℓ) → monoid-structure X → Type ℓ
group-axiom G ((e , _·_) , _) = ((x : G) → Σ G (λ x' → (x · x' ≡ e) × (x' · x ≡ e)))

group-structure : Type ℓ → Type ℓ
group-structure = add-to-structure (monoid-structure) group-axiom

Groups : Type (ℓ-suc ℓ)
Groups {ℓ} = TypeWithStr ℓ group-structure

-- Extracting components of a group

⟨_⟩ : Groups {ℓ} → Type ℓ
⟨ (G , _) ⟩ = G

id : (G : Groups {ℓ}) → ⟨ G ⟩
id (_ , ((e , _) , _) , _) = e

group-operation : (G : Groups {ℓ}) → ⟨ G ⟩ → ⟨ G ⟩ → ⟨ G ⟩
group-operation (_ , ((_ , f) , _) , _) = f

infixl 20 group-operation
syntax group-operation G x y = x ·⟨ G ⟩ y

group-is-set : (G : Groups {ℓ}) → isSet ⟨ G ⟩
group-is-set (_ , (_ , (P , _)) , _) = P

group-assoc : (G : Groups {ℓ})
            → (x y z : ⟨ G ⟩) → (x ·⟨ G ⟩ (y ·⟨ G ⟩ z)) ≡ ((x ·⟨ G ⟩ y) ·⟨ G ⟩ z)
group-assoc (_ , (_ , (_ , P , _)) , _) = P

group-runit : (G : Groups {ℓ})
            → (x : ⟨ G ⟩) → x ·⟨ G ⟩ (id G) ≡ x
group-runit (_ , (_ , (_ , _ , P , _)) , _) = P

group-lunit : (G : Groups {ℓ})
            → (x : ⟨ G ⟩) → (id G) ·⟨ G ⟩ x ≡ x
group-lunit (_ , (_ , (_ , _ , _ , P)) , _) = P

group-Σinv : (G : Groups {ℓ})
           → (x : ⟨ G ⟩) → Σ (⟨ G ⟩) (λ x' → (x ·⟨ G ⟩ x' ≡ (id G)) × (x' ·⟨ G ⟩ x ≡ (id G)))
group-Σinv (_ , _ , P) = P

-- Defining the inverse function

inv : (G : Groups {ℓ}) → ⟨ G ⟩ → ⟨ G ⟩
inv (_ , _ , P) x = fst (P x)

group-rinv : (G : Groups {ℓ})
               → (x : ⟨ G ⟩) → x ·⟨ G ⟩ (inv G x) ≡ id G
group-rinv (_ , _ , P) x = fst (snd (P x))

group-linv : (G : Groups {ℓ})
               → (x : ⟨ G ⟩) → (inv G x) ·⟨ G ⟩ x ≡ id G
group-linv (_ , _ , P) x = snd (snd (P x))

-- Iso for groups are those for monoids

group-iso : StrIso group-structure ℓ
group-iso = add-to-iso monoid-structure monoid-iso group-axiom

-- Auxiliary lemmas for subtypes (taken from Escardo)

to-Σ-≡ : {X : Type ℓ} {A : X → Type ℓ'} {σ τ : Σ X A}
       → (Σ (fst σ ≡ fst τ) λ p → PathP (λ i → A (p i)) (snd σ) (snd τ))
       → σ ≡ τ
to-Σ-≡ (eq , p) = λ i → eq i , p i

to-subtype-≡ : {X : Type ℓ} {A : X → Type ℓ'} {x y : X}
               {a : A x} {b : A y}
             → ((x : X) → isProp (A x))
             → x ≡ y
             → Path (Σ X (λ x → A x)) (x , a) (y , b)
to-subtype-≡  {x = x} {y} {a} {b} f eq = to-Σ-≡ (eq , toPathP (f y _ b))
-- TODO: this proof without toPathP?

-- Group axiom isProp

group-axiom-isProp : (X : Type ℓ)
                   → (s : monoid-structure X)
                   → isProp (group-axiom X s)
group-axiom-isProp X (((e , _·_) , s@(isSet , assoc , rid , lid))) = isPropPi γ
  where
    γ : (x : X) → isProp (Σ X (λ x' → (x · x' ≡ e) × (x' · x ≡ e)))
    γ x (y , a , q) (z , p , b) = to-subtype-≡ u t
      where
        t : y ≡ z
        t = inv-lemma X e _·_ s x y z q p

        u : (x' : X) → isProp ((x · x' ≡ e) × (x' · x ≡ e))
        u x' = isPropΣ (isSet _ _)
               (λ _ →   isSet _ _)

-- Group paths equivalent to equality

group-is-SNS : SNS {ℓ} group-structure group-iso
group-is-SNS = add-axioms-SNS monoid-structure monoid-iso
               group-axiom group-axiom-isProp monoid-is-SNS

GroupPath : (M N : Groups {ℓ}) → (M ≃[ group-iso ] N) ≃ (M ≡ N)
GroupPath M N = SIP group-structure group-iso group-is-SNS M N

-- Trying to improve isomorphisms to only have to preserve
-- _·_

group-iso' : StrIso group-structure ℓ
group-iso' G S f =
  (x y : ⟨ G ⟩) → equivFun f (x ·⟨ G ⟩ y) ≡ equivFun f x ·⟨ S ⟩ equivFun f y

-- Trying to reduce isomorphisms to simpler ones
-- First we prove that both notions of group-iso are equal
-- since both are props and there is are functions from
-- one to the other

-- Functions

group-iso→group-iso' : (G S : Groups {ℓ}) (f : ⟨ G ⟩ ≃ ⟨ S ⟩)
                     → group-iso G S f → group-iso' G S f
group-iso→group-iso' G S f γ = snd γ

group-iso'→group-iso : (G S : Groups {ℓ}) (f : ⟨ G ⟩ ≃ ⟨ S ⟩)
                     → group-iso' G S f → group-iso G S f
group-iso'→group-iso G S f γ = η , γ
  where
  g : ⟨ G ⟩ → ⟨ S ⟩
  g = equivFun f

  e : ⟨ G ⟩
  e = id G

  d : ⟨ S ⟩
  d = id S

  δ : g e ≡ g e ·⟨ S ⟩ g e
  δ = g e ≡⟨ cong g (sym (group-lunit G _)) ⟩
      g (e ·⟨ G ⟩ e) ≡⟨ γ e e ⟩
      g e ·⟨ S ⟩ g e ∎

  η : g e ≡ d
  η = g e                                   ≡⟨ sym (group-runit S _) ⟩
      g e ·⟨ S ⟩ d                          ≡⟨ cong (λ - → g e ·⟨ S ⟩ -) (sym (group-rinv S _)) ⟩
      g e ·⟨ S ⟩ (g e ·⟨ S ⟩ (inv S (g e))) ≡⟨ group-assoc S _ _ _ ⟩
     (g e ·⟨ S ⟩ g e) ·⟨ S ⟩ (inv S (g e))  ≡⟨ cong (λ - → group-operation S - (inv S (g e))) (sym δ) ⟩
      g e ·⟨ S ⟩ (inv S (g e))              ≡⟨ group-rinv S _ ⟩
      d ∎

-- Both are Props

isProp-Iso : (G S : Groups {ℓ}) (f : ⟨ G ⟩ ≃ ⟨ S ⟩) → isProp (group-iso G S f)
isProp-Iso G S f = isPropΣ (group-is-set S _ _)
                   (λ _ → isPropPi (λ x → isPropPi λ y → group-is-set S _ _))

isProp-Iso' : (G S : Groups {ℓ}) (f : ⟨ G ⟩ ≃ ⟨ S ⟩) → isProp (group-iso' G S f)
isProp-Iso' G S f = isPropPi (λ x → isPropPi λ y → group-is-set S _ _)

-- Propositional equality

to-Prop-≡ : {X Y : Type ℓ} (f : X → Y) (g : Y → X)
          → isProp X → isProp Y
          → X ≡ Y
to-Prop-≡ {ℓ} {X} {Y} f g p q = isoToPath (iso f g aux₂ aux₁)
  where
  aux₁ : (x : X) → g (f x) ≡ x
  aux₁ x = p _ _

  aux₂ : (y : Y) → f (g y) ≡ y
  aux₂ y = q _ _

-- Finally both are equal

group-iso'≡group-iso : group-iso' {ℓ} ≡ group-iso
group-iso'≡group-iso = funExt₃ γ
  where
    γ : ∀ (G S : Groups {ℓ}) (f : ⟨ G ⟩ ≃ ⟨ S ⟩)
      → group-iso' G S f ≡ group-iso G S f
    γ G S f = to-Prop-≡ (group-iso'→group-iso G S f)
                        (group-iso→group-iso' G S f)
                        (isProp-Iso' G S f)
                        (isProp-Iso  G S f)

-- And Finally we have what we wanted

group-is-SNS' : SNS {ℓ} group-structure group-iso'
group-is-SNS' = transport γ group-is-SNS
  where
  γ : SNS {ℓ} group-structure group-iso ≡ SNS {ℓ} group-structure group-iso'
  γ = cong (SNS group-structure) (sym group-iso'≡group-iso)

GroupPath' : (M N : Groups {ℓ}) → (M ≃[ group-iso' ] N) ≃ (M ≡ N)
GroupPath' M N = SIP group-structure group-iso' group-is-SNS' M N

---------------------------------------------------------------------
-- Abelians group (just add one axiom and prove that it is a hProp)
---------------------------------------------------------------------

abelian-group-axiom : (X : Type ℓ) → group-structure X → Type ℓ
abelian-group-axiom G (((_ , _·_), _), _) = (x y : G) → x · y ≡ y · x

abelian-group-structure : Type ℓ → Type ℓ
abelian-group-structure = add-to-structure (group-structure) abelian-group-axiom

AbGroups : Type (ℓ-suc ℓ)
AbGroups {ℓ} = TypeWithStr ℓ abelian-group-structure

abelian-group-iso : StrIso abelian-group-structure ℓ
abelian-group-iso = add-to-iso group-structure group-iso abelian-group-axiom

abelian-group-axiom-isProp : (X : Type ℓ)
                           → (s : group-structure X)
                           → isProp (abelian-group-axiom X s)
abelian-group-axiom-isProp X ((_ , (group-isSet , _)) , _) =
  isPropPi (λ x → isPropPi λ y → group-isSet _ _)

abelian-group-is-SNS : SNS {ℓ} abelian-group-structure abelian-group-iso
abelian-group-is-SNS = add-axioms-SNS group-structure group-iso
               abelian-group-axiom abelian-group-axiom-isProp group-is-SNS

AbGroupPath : (M N : AbGroups {ℓ}) → (M ≃[ abelian-group-iso ] N) ≃ (M ≡ N)
AbGroupPath M N = SIP abelian-group-structure abelian-group-iso abelian-group-is-SNS M N


open import Common.Prelude hiding (_>>=_)
open import Common.Reflection
open import Common.Equality

record Functor (F : Set → Set) : Set₁ where
  field
    fmap : ∀ {A B} → (A → B) → F A → F B

IdF : Functor (λ A → A)
unquoteDef IdF =
  defineFun IdF (clause (vArg (projP (quote Functor.fmap)) ∷ vArg (var "f") ∷ vArg (var "x") ∷ [])
                        (var 1 (vArg (var 0 []) ∷ [])) ∷ [])

check : ∀ {A B} (f : A → B) (x : A) → Functor.fmap IdF f x ≡ f x
check f x = refl

open Functor {{...}}

instance
  InstF : Functor (λ A → A)
  unquoteDef InstF =
    defineFun InstF (clause (iArg (projP (quote fmap)) ∷ vArg (var "f") ∷ vArg (var "x") ∷ [])
                            (var 1 (vArg (var 0 []) ∷ [])) ∷ [])

check₁ : ∀ {A B} (f : A → B) (x : A) → fmap f x ≡ f x
check₁ f x = refl


-- Andreas, 2016-10-03, issue #2233
-- Positivity check should return the same result when change
-- all involved definitions from non-abstract to abstract.

abstract
  data Functor : Set where
    Id : Functor

  _·_ : Functor → Set → Set
  Id · A = A

  data ν (F : Functor) : Set where
    inn : F · ν F → ν F

-- Should positivity check ok.