{-# OPTIONS --without-K --safe #-}
open import Categories.Category

-- Mainly *properties* of isomorphisms, and a lot of other things too

-- TODO: split things up more semantically?

module Categories.Morphism.Isomorphism {o ℓ e} (𝒞 : Category o ℓ e) where

open import Level using (_⊔_)
open import Function using (flip)

open import Data.Product using (_,_)
open import Relation.Binary using (Rel; _Preserves_⟶_; IsEquivalence)
open import Relation.Binary.Construct.Closure.Transitive
open import Relation.Binary.PropositionalEquality as ≡ using (_≡_)

import Categories.Category.Construction.Core as Core
open import Categories.Category.Groupoid using (IsGroupoid)
import Categories.Category.Groupoid.Properties as GroupoidProps
import Categories.Morphism as Morphism
import Categories.Morphism.Properties as MorphismProps
import Categories.Morphism.IsoEquiv as IsoEquiv
import Categories.Category.Construction.Path as Path

open Core 𝒞 using (Core; Core-isGroupoid; CoreGroupoid)
open Morphism 𝒞
open MorphismProps 𝒞
open IsoEquiv 𝒞 using (_≃_; ⌞_⌟)
open Path 𝒞

import Categories.Morphism.Reasoning as MR

open Category 𝒞

private
  module MCore where
    open IsGroupoid    Core-isGroupoid public
    open GroupoidProps CoreGroupoid public
    open MorphismProps Core public
    open Morphism      Core public
    open Path          Core public

  variable
    A B C D E F : Obj

open MCore using () renaming (_∘_ to _∘ᵢ_) public

CommutativeIso = IsGroupoid.CommutativeSquare Core-isGroupoid

--------------------
-- Also stuff about transitive closure

∘ᵢ-tc : A [ _≅_ ]⁺ B → A ≅ B
∘ᵢ-tc = MCore.∘-tc

infix 4 _≃⁺_
_≃⁺_ : Rel (A [ _≅_ ]⁺ B) _
_≃⁺_ = MCore._≈⁺_

TransitiveClosure : Category _ _ _
TransitiveClosure = MCore.Path

--------------------
-- some infrastructure setup in order to say something about morphisms and isomorphisms
module _ where
  private
    data IsoPlus : A [ _⇒_ ]⁺ B → Set (o ⊔ ℓ ⊔ e) where
      [_]     : {f : A ⇒ B} {g : B ⇒ A} → Iso f g → IsoPlus [ f ]
      _∼⁺⟨_⟩_ : ∀ A {f⁺ : A [ _⇒_ ]⁺ B} {g⁺ : B [ _⇒_ ]⁺ C} → IsoPlus f⁺ → IsoPlus g⁺ → IsoPlus (_ ∼⁺⟨ f⁺ ⟩ g⁺)

  open _≅_

  ≅⁺⇒⇒⁺ : A [ _≅_ ]⁺ B → A [ _⇒_ ]⁺ B
  ≅⁺⇒⇒⁺ [ f ]            = [ from f ]
  ≅⁺⇒⇒⁺ (_ ∼⁺⟨ f⁺ ⟩ f⁺′) = _ ∼⁺⟨ ≅⁺⇒⇒⁺ f⁺ ⟩ ≅⁺⇒⇒⁺ f⁺′

  reverse : A [ _≅_ ]⁺ B → B [ _≅_ ]⁺ A
  reverse [ f ]            = [ ≅.sym f ]
  reverse (_ ∼⁺⟨ f⁺ ⟩ f⁺′) = _ ∼⁺⟨ reverse f⁺′ ⟩ reverse f⁺

  reverse⇒≅-sym : (f⁺ : A [ _≅_ ]⁺ B) → ∘ᵢ-tc (reverse f⁺) ≡ ≅.sym (∘ᵢ-tc f⁺)
  reverse⇒≅-sym [ f ]            = ≡.refl
  reverse⇒≅-sym (_ ∼⁺⟨ f⁺ ⟩ f⁺′)  = ≡.cong₂ (Morphism.≅.trans 𝒞) (reverse⇒≅-sym f⁺′) (reverse⇒≅-sym f⁺)

  TransitiveClosure-groupoid : IsGroupoid TransitiveClosure
  TransitiveClosure-groupoid = record
    { _⁻¹ = reverse
    ; iso = λ {_ _ f⁺} → record { isoˡ = isoˡ′ f⁺ ; isoʳ = isoʳ′ f⁺ }
    }
    where
      open MCore.HomReasoning

      isoˡ′ : (f⁺ : A [ _≅_ ]⁺ B) → ∘ᵢ-tc (reverse f⁺) ∘ᵢ ∘ᵢ-tc f⁺ ≃ ≅.refl
      isoˡ′ f⁺ = begin
          ∘ᵢ-tc (reverse f⁺) ∘ᵢ ∘ᵢ-tc f⁺
        ≡⟨ ≡.cong (_∘ᵢ ∘ᵢ-tc f⁺) (reverse⇒≅-sym f⁺) ⟩
          ≅.sym (∘ᵢ-tc f⁺) ∘ᵢ ∘ᵢ-tc f⁺
        ≈⟨ MCore.iso.isoˡ ⟩
          ≅.refl
        ∎

      isoʳ′ : (f⁺ : A [ _≅_ ]⁺ B) → ∘ᵢ-tc f⁺ ∘ᵢ ∘ᵢ-tc (reverse f⁺) ≃ ≅.refl
      isoʳ′ f⁺ = begin
          ∘ᵢ-tc f⁺ ∘ᵢ ∘ᵢ-tc (reverse f⁺)
        ≡⟨ ≡.cong (∘ᵢ-tc f⁺ ∘ᵢ_) (reverse⇒≅-sym f⁺) ⟩
          ∘ᵢ-tc f⁺ ∘ᵢ ≅.sym (∘ᵢ-tc f⁺)
        ≈⟨ MCore.iso.isoʳ ⟩
          ≅.refl
        ∎

  from-∘ᵢ-tc : (f⁺ : A [ _≅_ ]⁺ B) → from (∘ᵢ-tc f⁺) ≡ ∘-tc (≅⁺⇒⇒⁺ f⁺)
  from-∘ᵢ-tc [ f ]            = ≡.refl
  from-∘ᵢ-tc (_ ∼⁺⟨ f⁺ ⟩ f⁺′) = ≡.cong₂ _∘_ (from-∘ᵢ-tc f⁺′) (from-∘ᵢ-tc f⁺)

  ≅*⇒⇒*-cong : ≅⁺⇒⇒⁺ {A} {B} Preserves _≃⁺_ ⟶ _≈⁺_
  ≅*⇒⇒*-cong {_} {_} {f⁺} {g⁺} f⁺≃⁺g⁺ = begin
    ∘-tc (≅⁺⇒⇒⁺ f⁺)  ≡˘⟨ from-∘ᵢ-tc f⁺ ⟩
    from (∘ᵢ-tc f⁺)  ≈⟨ _≃_.from-≈ f⁺≃⁺g⁺ ⟩
    from (∘ᵢ-tc g⁺)  ≡⟨ from-∘ᵢ-tc g⁺ ⟩
    ∘-tc (≅⁺⇒⇒⁺ g⁺)  ∎
    where open HomReasoning

  ≅-shift : ∀ {f⁺ : A [ _≅_ ]⁺ B} {g⁺ : B [ _≅_ ]⁺ C} {h⁺ : A [ _≅_ ]⁺ C} →
              (_ ∼⁺⟨ f⁺ ⟩  g⁺) ≃⁺ h⁺ → g⁺ ≃⁺ (_ ∼⁺⟨ reverse f⁺ ⟩ h⁺)
  ≅-shift {f⁺ = f⁺} {g⁺ = g⁺} {h⁺ = h⁺} eq = begin
    ∘ᵢ-tc g⁺                                      ≈⟨ introʳ (I.isoʳ f⁺) ⟩
    ∘ᵢ-tc g⁺ ∘ᵢ (∘ᵢ-tc f⁺ ∘ᵢ ∘ᵢ-tc (reverse f⁺))  ≈⟨ pullˡ eq ⟩
    ∘ᵢ-tc h⁺ ∘ᵢ ∘ᵢ-tc (reverse f⁺)                ∎
    where
      open MCore.HomReasoning
      open MR Core
      module I {A B} (f⁺ : A [ _≅_ ]⁺ B) = Morphism.Iso (IsGroupoid.iso TransitiveClosure-groupoid {f = f⁺})

  lift : ∀ {f⁺ : A [ _⇒_ ]⁺ B} → IsoPlus f⁺ → A [ _≅_ ]⁺ B
  lift [ iso ]            = [ record
    { from = _
    ; to   = _
    ; iso  = iso
    } ]
  lift (_ ∼⁺⟨ iso ⟩ iso′) = _ ∼⁺⟨ lift iso ⟩ lift iso′

  reduce-lift : ∀ {f⁺ : A [ _⇒_ ]⁺ B} (f′ : IsoPlus f⁺) → from (∘ᵢ-tc (lift f′)) ≡ ∘-tc f⁺
  reduce-lift [ f ]           = ≡.refl
  reduce-lift (_ ∼⁺⟨ f′ ⟩ f″) = ≡.cong₂ _∘_ (reduce-lift f″) (reduce-lift f′)

  lift-cong : ∀ {f⁺ g⁺ : A [ _⇒_ ]⁺ B} (f′ : IsoPlus f⁺) (g′ : IsoPlus g⁺) →
              f⁺ ≈⁺ g⁺ → lift f′ ≃⁺ lift g′
  lift-cong {_} {_} {f⁺} {g⁺} f′ g′ eq = ⌞ from-≈′ ⌟
    where
      open HomReasoning

      from-≈′ : from (∘ᵢ-tc (lift f′)) ≈ from (∘ᵢ-tc (lift g′))
      from-≈′ = begin
        from (∘ᵢ-tc (lift f′))  ≡⟨ reduce-lift f′ ⟩
        ∘-tc f⁺                 ≈⟨ eq ⟩
        ∘-tc g⁺                 ≡˘⟨ reduce-lift g′ ⟩
        from (∘ᵢ-tc (lift g′))  ∎

  lift-triangle : {f : A ⇒ B} {g : C ⇒ A} {h : C ⇒ B} {k : B ⇒ C} {i : B ⇒ A} {j : A ⇒ C} →
    f ∘ g ≈ h → (f′ : Iso f i) → (g′ : Iso g j) → (h′ : Iso h k) →
    lift (_ ∼⁺⟨ [ g′ ] ⟩ [ f′ ]) ≃⁺ lift [ h′ ]
  lift-triangle eq f′ g′ h′ = lift-cong (_ ∼⁺⟨ [ g′ ] ⟩ [ f′ ]) [ h′ ] eq

  lift-square : {f : A ⇒ B} {g : C ⇒ A} {h : D ⇒ B} {i : C ⇒ D} {j : D ⇒ C} {a : B ⇒ A} {b : A ⇒ C} {c : B ⇒ D} →
    f ∘ g ≈ h ∘ i → (f′ : Iso f a) → (g′ : Iso g b) → (h′ : Iso h c) → (i′ : Iso i j) →
    lift (_ ∼⁺⟨ [ g′ ] ⟩ [ f′ ]) ≃⁺ lift (_ ∼⁺⟨ [ i′ ] ⟩ [ h′ ])
  lift-square eq f′ g′ h′ i′ = lift-cong (_ ∼⁺⟨ [ g′ ] ⟩ [ f′ ]) (_ ∼⁺⟨ [ i′ ] ⟩ [ h′ ]) eq

  lift-pentagon : {f : A ⇒ B} {g : C ⇒ A} {h : D ⇒ C} {i : E ⇒ B} {j : D ⇒ E} {l : E ⇒ D}
                  {a : B ⇒ A} {b : A ⇒ C} {c : C ⇒ D} {d : B ⇒ E} →
    f ∘ g ∘ h ≈ i ∘ j →
    (f′ : Iso f a) → (g′ : Iso g b) → (h′ : Iso h c) → (i′ : Iso i d) → (j′ : Iso j l) →
    lift (_ ∼⁺⟨ _ ∼⁺⟨ [ h′ ] ⟩ [ g′ ] ⟩ [ f′ ]) ≃⁺ lift (_ ∼⁺⟨ [ j′ ] ⟩ [ i′ ])
  lift-pentagon eq f′ g′ h′ i′ j′ = lift-cong (_ ∼⁺⟨ _ ∼⁺⟨ [ h′ ] ⟩ [ g′ ] ⟩ [ f′ ]) (_ ∼⁺⟨ [ j′ ] ⟩ [ i′ ]) eq

module _ where
  open _≅_

  -- projecting isomorphism commutations to morphism commutations

  project-triangle : {g : A ≅ B} {f : C ≅ A} {h : C ≅ B} → g ∘ᵢ f ≃ h → from g ∘ from f ≈ from h
  project-triangle = _≃_.from-≈

  project-square : {g : A ≅ B} {f : C ≅ A} {i : D ≅ B} {h : C ≅ D} → g ∘ᵢ f ≃ i ∘ᵢ h → from g ∘ from f ≈ from i ∘ from h
  project-square = _≃_.from-≈

  -- direct lifting from morphism commutations to isomorphism commutations

  lift-triangle′ : {f : A ≅ B} {g : C ≅ A} {h : C ≅ B} → from f ∘ from g ≈ from h → f ∘ᵢ g ≃ h
  lift-triangle′ = ⌞_⌟

  lift-square′ : {f : A ≅ B} {g : C ≅ A} {h : D ≅ B} {i : C ≅ D} → from f ∘ from g ≈ from h ∘ from i → f ∘ᵢ g ≃ h ∘ᵢ i
  lift-square′ = ⌞_⌟

  lift-pentagon′ : {f : A ≅ B} {g : C ≅ A} {h : D ≅ C} {i : E ≅ B} {j : D ≅ E} →
                   from f ∘ from g ∘ from h ≈ from i ∘ from j → f ∘ᵢ g ∘ᵢ h ≃ i ∘ᵢ j
  lift-pentagon′ = ⌞_⌟

  open MR Core
  open MCore using (_⁻¹)
  open MCore.HomReasoning
  open MR.GroupoidR _ Core-isGroupoid

  squares×≃⇒≃ : {f f′ : A ≅ B} {g : A ≅ C} {h : B ≅ D} {i i′ : C ≅ D} →
                CommutativeIso f g h i → CommutativeIso f′ g h i′ → i ≃ i′ → f ≃ f′
  squares×≃⇒≃ sq₁ sq₂ eq = MCore.isos×≈⇒≈ eq helper₁ (MCore.≅.sym helper₂) sq₁ sq₂
    where
      helper₁ = record { iso = MCore.iso }
      helper₂ = record { iso = MCore.iso }

  -- imagine a triangle prism, if all the sides and the top face commute, the bottom face commute.
  triangle-prism : {i′ : A ≅ B} {f′ : C ≅ A} {h′ : C ≅ B} {i : D ≅ E} {j : D ≅ A}
    {k : E ≅ B} {f : F ≅ D} {g : F ≅ C} {h : F ≅ E} →
    i′ ∘ᵢ f′ ≃ h′ →
    CommutativeIso i j k i′ → CommutativeIso f g j f′ → CommutativeIso h g k h′ →
    i ∘ᵢ f ≃ h
  triangle-prism {i′ = i′} {f′} {_} {i} {_} {k} {f} {g} {_} eq sq₁ sq₂ sq₃ =
    squares×≃⇒≃ glued sq₃ eq
    where
      glued : CommutativeIso (i ∘ᵢ f) g k (i′ ∘ᵢ f′)
      glued = sym (glue (sym sq₁) (sym sq₂))

  elim-triangleˡ : {f : A ≅ B} {g : C ≅ A} {h : D ≅ C} {i : D ≅ B} {j : D ≅ A} →
                   f ∘ᵢ g ∘ᵢ h ≃ i → f ∘ᵢ j ≃ i → g ∘ᵢ h ≃ j
  elim-triangleˡ perim tri = MCore.mono _ _ (perim ○ ⟺ tri)

  elim-triangleˡ′ : {f : A ≅ B} {g : C ≅ A} {h : D ≅ C} {i : D ≅ B} {j : C ≅ B} →
                    f ∘ᵢ g ∘ᵢ h ≃ i → j ∘ᵢ h ≃ i → f ∘ᵢ g ≃ j
  elim-triangleˡ′ {f = f} {g} {h} {i} {j} perim tri = MCore.epi _ _ ( begin
    (f ∘ᵢ g) ∘ᵢ h ≈⟨ MCore.assoc ⟩
    f ∘ᵢ g ∘ᵢ h   ≈⟨ perim ⟩
    i             ≈˘⟨ tri ⟩
    j ∘ᵢ h        ∎ )

  cut-squareʳ : {g : A ≅ B} {f : A ≅ C} {h : B ≅ D} {i : C ≅ D} {j : B ≅ C} →
                CommutativeIso g f h i → i ∘ᵢ j ≃ h → j ∘ᵢ g ≃ f
  cut-squareʳ {g = g} {f = f} {h = h} {i = i} {j = j} sq tri = begin
    j ∘ᵢ g            ≈⟨ switch-fromtoˡ′ {f = i} {h = j} {k = h} tri ⟩∘⟨ refl ⟩
    (i ⁻¹ ∘ᵢ h) ∘ᵢ g  ≈⟨ MCore.assoc ⟩
    i ⁻¹ ∘ᵢ h ∘ᵢ g    ≈˘⟨ switch-fromtoˡ′ {f = i} {h = f} {k = h ∘ᵢ g} (sym sq) ⟩
    f                 ∎


{-# OPTIONS --safe #-}
module Cubical.Algebra.Module.Base where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.SIP

open import Cubical.Data.Sigma

open import Cubical.Displayed.Base
open import Cubical.Displayed.Auto
open import Cubical.Displayed.Record
open import Cubical.Displayed.Universe

open import Cubical.Reflection.RecordEquiv

open import Cubical.Algebra.Ring
open import Cubical.Algebra.AbGroup
open import Cubical.Algebra.Group

open Iso

private
  variable
    ℓ ℓ' : Level

record IsLeftModule (R : Ring ℓ) {M : Type ℓ'}
  (0m : M)
  (_+_ : M → M → M)
  (-_ : M → M)
  (_⋆_ : ⟨ R ⟩ → M → M) : Type (ℓ-max ℓ ℓ') where

  open RingStr (snd R) using (_·_; 1r) renaming (_+_ to _+r_)

  field
    +IsAbGroup : IsAbGroup 0m _+_ -_
    ⋆Assoc : (r s : ⟨ R ⟩) (x : M) → (r · s) ⋆ x ≡ r ⋆ (s ⋆ x)
    ⋆DistR+ : (r : ⟨ R ⟩) (x y : M) → r ⋆ (x + y) ≡ (r ⋆ x) + (r ⋆ y)
    ⋆DistL+ : (r s : ⟨ R ⟩) (x : M) → (r +r s) ⋆ x ≡ (r ⋆ x) + (s ⋆ x)
    ⋆IdL   : (x : M) → 1r ⋆ x ≡ x

  open IsAbGroup +IsAbGroup public
    renaming
    ( isSemigroup to +IsSemigroup
    ; isMonoid    to +IsMonoid
    ; isGroup     to +IsGroup
    )

unquoteDecl IsLeftModuleIsoΣ = declareRecordIsoΣ IsLeftModuleIsoΣ (quote IsLeftModule)

record LeftModuleStr (R : Ring ℓ) (A : Type ℓ') : Type (ℓ-max ℓ ℓ') where

  field
    0m             : A
    _+_            : A → A → A
    -_             : A → A
    _⋆_            : ⟨ R ⟩ → A → A
    isLeftModule   : IsLeftModule R 0m _+_ -_ _⋆_

  open IsLeftModule isLeftModule public

LeftModule : (R : Ring ℓ) → ∀ ℓ' → Type (ℓ-max ℓ (ℓ-suc ℓ'))
LeftModule R ℓ' = Σ[ A ∈ Type ℓ' ] LeftModuleStr R A

module _ {R : Ring ℓ} where

  module _ (M : LeftModule R ℓ') where
    LeftModule→AbGroup : AbGroup ℓ'
    LeftModule→AbGroup .fst = M .fst
    LeftModule→AbGroup .snd .AbGroupStr.0g = _
    LeftModule→AbGroup .snd .AbGroupStr._+_ = _
    LeftModule→AbGroup .snd .AbGroupStr.-_  = _
    LeftModule→AbGroup .snd .AbGroupStr.isAbGroup =
      IsLeftModule.+IsAbGroup (M .snd .LeftModuleStr.isLeftModule)

  isSetLeftModule : (M : LeftModule R ℓ') → isSet ⟨ M ⟩
  isSetLeftModule M = isSetAbGroup (LeftModule→AbGroup M)

  open RingStr (snd R) using (1r) renaming (_+_ to _+r_; _·_ to _·s_)

  module _  {M : Type ℓ'} {0m : M}
           {_+_ : M → M → M} { -_ : M → M} {_⋆_ : ⟨ R ⟩ → M → M}
                  (isSet-M : isSet M)
                  (+Assoc  :  (x y z : M) → x + (y + z) ≡ (x + y) + z)
                  (+IdR    : (x : M) → x + 0m ≡ x)
                  (+InvR   : (x : M) → x + (- x) ≡ 0m)
                  (+Comm   : (x y : M) → x + y ≡ y + x)
                  (⋆Assoc  : (r s : ⟨ R ⟩) (x : M) → (r ·s s) ⋆ x ≡ r ⋆ (s ⋆ x))
                  (⋆DistR+ : (r : ⟨ R ⟩) (x y : M) → r ⋆ (x + y) ≡ (r ⋆ x) + (r ⋆ y))
                  (⋆DistL+ : (r s : ⟨ R ⟩) (x : M) → (r +r s) ⋆ x ≡ (r ⋆ x) + (s ⋆ x))
                  (⋆IdL    : (x : M) → 1r ⋆ x ≡ x)
    where

    makeIsLeftModule : IsLeftModule R 0m _+_ -_ _⋆_
    makeIsLeftModule .IsLeftModule.+IsAbGroup = makeIsAbGroup isSet-M +Assoc +IdR +InvR +Comm
    makeIsLeftModule .IsLeftModule.⋆Assoc = ⋆Assoc
    makeIsLeftModule .IsLeftModule.⋆DistR+ = ⋆DistR+
    makeIsLeftModule .IsLeftModule.⋆DistL+ = ⋆DistL+
    makeIsLeftModule .IsLeftModule.⋆IdL = ⋆IdL

record IsLeftModuleHom {R : Ring ℓ} {A B : Type ℓ'}
  (M : LeftModuleStr R A) (f : A → B) (N : LeftModuleStr R B)
  : Type (ℓ-max ℓ ℓ')
  where

  -- Shorter qualified names
  private
    module M = LeftModuleStr M
    module N = LeftModuleStr N

  field
    pres0 : f M.0m ≡ N.0m
    pres+ : (x y : A) → f (x M.+ y) ≡ f x N.+ f y
    pres- : (x : A) → f (M.- x) ≡ N.- (f x)
    pres⋆ : (r : ⟨ R ⟩) (y : A) → f (r M.⋆ y) ≡ r N.⋆ f y

LeftModuleHom : {R : Ring ℓ} (M N : LeftModule R ℓ') → Type (ℓ-max ℓ ℓ')
LeftModuleHom M N = Σ[ f ∈ (⟨ M ⟩ → ⟨ N ⟩) ] IsLeftModuleHom (M .snd) f (N .snd)

IsLeftModuleEquiv : {R : Ring ℓ} {A B : Type ℓ'}
  (M : LeftModuleStr R A) (e : A ≃ B) (N : LeftModuleStr R B)
  → Type (ℓ-max ℓ ℓ')
IsLeftModuleEquiv M e N = IsLeftModuleHom M (e .fst) N

LeftModuleEquiv : {R : Ring ℓ} (M N : LeftModule R ℓ') → Type (ℓ-max ℓ ℓ')
LeftModuleEquiv M N = Σ[ e ∈ ⟨ M ⟩ ≃ ⟨ N ⟩ ] IsLeftModuleEquiv (M .snd) e (N .snd)

isPropIsLeftModule : (R : Ring ℓ) {M : Type ℓ'}
  (0m : M)
  (_+_ : M → M → M)
  (-_ : M → M)
  (_⋆_ : ⟨ R ⟩ → M → M)
  → isProp (IsLeftModule R 0m _+_ -_ _⋆_)
isPropIsLeftModule R _ _ _ _ =
  isOfHLevelRetractFromIso 1 IsLeftModuleIsoΣ
    (isPropΣ (isPropIsAbGroup _ _ _)
      (λ ab →
        isProp× (isPropΠ3 λ _ _ _ → ab .is-set _ _)
          (isProp× (isPropΠ3 λ _ _ _ → ab .is-set _ _)
            (isProp× (isPropΠ3 λ _ _ _ → ab .is-set _ _)
              (isPropΠ λ _ → ab .is-set _ _)))))
  where
  open IsAbGroup

𝒮ᴰ-LeftModule : (R : Ring ℓ) → DUARel (𝒮-Univ ℓ') (LeftModuleStr R) (ℓ-max ℓ ℓ')
𝒮ᴰ-LeftModule R =
  𝒮ᴰ-Record (𝒮-Univ _) (IsLeftModuleEquiv {R = R})
    (fields:
      data[ 0m ∣ autoDUARel _ _ ∣ pres0 ]
      data[ _+_ ∣ autoDUARel _ _ ∣ pres+ ]
      data[ -_ ∣ autoDUARel _ _ ∣ pres- ]
      data[ _⋆_ ∣ autoDUARel _ _ ∣ pres⋆ ]
      prop[ isLeftModule ∣ (λ _ _ → isPropIsLeftModule _ _ _ _ _) ])
  where
  open LeftModuleStr
  open IsLeftModuleHom

LeftModulePath : {R : Ring ℓ} (M N : LeftModule R ℓ') → (LeftModuleEquiv M N) ≃ (M ≡ N)
LeftModulePath {R = R} = ∫ (𝒮ᴰ-LeftModule R) .UARel.ua


postulate
  F : Set → Set

{-# POLARITY F * #-}

data D : Set where
  d : F D → D


open import HoTT
open import groups.Exactness
open import groups.HomSequence

module groups.ExactSequence where

is-exact-seq : ∀ {i} {G H : Group i}
  → HomSequence G H → Type i
is-exact-seq (_ ⊣|ᴳ) = Lift ⊤
is-exact-seq (_ →⟨ φ ⟩ᴳ _ ⊣|ᴳ) = Lift ⊤
is-exact-seq (_ →⟨ φ ⟩ᴳ _ →⟨ ψ ⟩ᴳ seq) =
  is-exact φ ψ × is-exact-seq (_ →⟨ ψ ⟩ᴳ seq)

ExactSequence : ∀ {i} (G H : Group i) → Type (lsucc i)
ExactSequence G H = Σ (HomSequence G H) is-exact-seq

{- equivalences preserve exactness -}

abstract
  seq-equiv-preserves-exact : ∀ {i₀ i₁} {G₀ H₀ : Group i₀} {G₁ H₁ : Group i₁}
    {seq₀ : HomSequence G₀ H₀} {seq₁ : HomSequence G₁ H₁}
    {ξG : G₀ →ᴳ G₁} {ξH : H₀ →ᴳ H₁}
    → HomSeqEquiv seq₀ seq₁ ξG ξH
    → is-exact-seq seq₀ → is-exact-seq seq₁
  seq-equiv-preserves-exact ((_ ↓|ᴳ) , _) _ = lift tt
  seq-equiv-preserves-exact ((_ ↓⟨ _ ⟩ᴳ _ ↓|ᴳ) , _) _ = lift tt
  seq-equiv-preserves-exact
    ( (ξG ↓⟨ φ□ ⟩ᴳ _↓⟨_⟩ᴳ_ ξH {ξK} ψ□ seq-map)
    , (ξG-ise , ξH-ise , seq-map-ise))
    (φ₀-ψ₀-is-exact , ψ₀-seq₀-is-exact-seq) =
      equiv-preserves-exact
        φ□ ψ□ ξG-ise ξH-ise (is-seqᴳ-equiv.head seq-map-ise)
        φ₀-ψ₀-is-exact ,
      seq-equiv-preserves-exact
        ((ξH ↓⟨ ψ□ ⟩ᴳ seq-map) , (ξH-ise , seq-map-ise))
        ψ₀-seq₀-is-exact-seq

  seq-equiv-preserves'-exact : ∀ {i} {G₀ G₁ H₀ H₁ : Group i}
    {seq₀ : HomSequence G₀ H₀} {seq₁ : HomSequence G₁ H₁}
    {ξG : G₀ →ᴳ G₁} {ξH : H₀ →ᴳ H₁}
    → HomSeqEquiv seq₀ seq₁ ξG ξH
    → is-exact-seq seq₁ → is-exact-seq seq₀
  seq-equiv-preserves'-exact seq-equiv =
    seq-equiv-preserves-exact (HomSeqEquiv-inverse seq-equiv)

private
  exact-seq-index-type : ∀ {i} {G H : Group i} → ℕ → HomSequence G H → Type i
  exact-seq-index-type _ (G ⊣|ᴳ) = Lift ⊤
  exact-seq-index-type _ (G →⟨ φ ⟩ᴳ H ⊣|ᴳ) = Lift ⊤
  exact-seq-index-type O (G →⟨ φ ⟩ᴳ H →⟨ ψ ⟩ᴳ s) = is-exact φ ψ
  exact-seq-index-type (S n) (_ →⟨ _ ⟩ᴳ s) = exact-seq-index-type n s

abstract
  exact-seq-index : ∀ {i} {G H : Group i}
    → (n : ℕ) (seq : ExactSequence G H)
    → exact-seq-index-type n (fst seq)
  exact-seq-index _     ((G ⊣|ᴳ) , _) = lift tt
  exact-seq-index _     ((G →⟨ φ ⟩ᴳ H ⊣|ᴳ) , _) = lift tt
  exact-seq-index O     ((G →⟨ φ ⟩ᴳ H →⟨ ψ ⟩ᴳ seq) , ise-seq) = fst ise-seq
  exact-seq-index (S n) ((G →⟨ φ ⟩ᴳ H →⟨ ψ ⟩ᴳ seq) , ise-seq) =
    exact-seq-index n ((H →⟨ ψ ⟩ᴳ seq) , snd ise-seq)

{-
private
  exact-build-arg-type : ∀ {i} {G H : Group i} → HomSequence G H → List (Type i)
  exact-build-arg-type (G ⊣|) = nil
  exact-build-arg-type (G ⟨ φ ⟩→ H ⊣|) = nil
  exact-build-arg-type (G ⟨ φ ⟩→ H ⟨ ψ ⟩→ s) =
    is-exact φ ψ :: exact-build-arg-type (H ⟨ ψ ⟩→ s)

  exact-build-helper : ∀ {i} {G H : Group i} (seq : HomSequence G H)
    → HList (exact-build-arg-type seq) → is-exact-seq seq
  exact-build-helper (G ⊣|) nil = exact-seq-zero
  exact-build-helper (G ⟨ φ ⟩→ H ⊣|) nil = exact-seq-one
  exact-build-helper (G ⟨ φ ⟩→ H ⟨ ψ ⟩→ s) (ie :: ies) =
    exact-seq-more ie (exact-build-helper (H ⟨ ψ ⟩→ s) ies)

exact-build : ∀ {i} {G H : Group i} (seq : HomSequence G H)
  → hlist-curry-type (exact-build-arg-type seq) (λ _ → is-exact-seq seq)
exact-build seq = hlist-curry (exact-build-helper seq)

hom-seq-concat : ∀ {i} {G H K : Group i}
  → HomSequence G H → HomSequence H K → HomSequence G K
hom-seq-concat (G ⊣|) s₂ = s₂
hom-seq-concat (G ⟨ φ ⟩→ s₁) s₂ = G ⟨ φ ⟩→ (hom-seq-concat s₁ s₂)

abstract
  exact-concat : ∀ {i} {G H K L : Group i}
    {seq₁ : HomSequence G H} {φ : H →ᴳ K} {seq₂ : HomSequence K L}
    → is-exact-seq (hom-seq-snoc seq₁ φ) → is-exact-seq (H ⟨ φ ⟩→ seq₂)
    → is-exact-seq (hom-seq-concat seq₁ (H ⟨ φ ⟩→ seq₂))
  exact-concat {seq₁ = G ⊣|} exact-seq-one es₂ = es₂
  exact-concat {seq₁ = G ⟨ ψ ⟩→ H ⊣|} (exact-seq-more ex _) es₂ =
    exact-seq-more ex es₂
  exact-concat {seq₁ = G ⟨ ψ ⟩→ H ⟨ χ ⟩→ s} (exact-seq-more ex es₁) es₂ =
    exact-seq-more ex (exact-concat {seq₁ = H ⟨ χ ⟩→ s} es₁ es₂)
-}


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

module Container.Stream where

open import Prelude
open import Data.Fin
open import Container

Stream : Type a → Type a
Stream = ⟦ ⊤ , const ℕ ⟧


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

pattern vArg x = arg (arg-info visible (modality relevant quantity-ω)) x

macro
  macaroo : Term → TC ⊤
  macaroo hole = unify hole (con (quote suc) (vArg unknown ∷ []))

test : Nat
test = macaroo


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

open import lib.Basics
open import lib.Equivalence2
open import lib.Function2
open import lib.NType2
open import lib.types.Group
open import lib.types.Pi
open import lib.types.Subtype
open import lib.types.Truncation
open import lib.groups.Homomorphism
open import lib.groups.SubgroupProp

module lib.groups.Isomorphism where

GroupStructureIso : ∀ {i j} {GEl : Type i} {HEl : Type j}
  (GS : GroupStructure GEl) (HS : GroupStructure HEl) → Type (lmax i j)
GroupStructureIso GS HS = Σ (GroupStructureHom GS HS) (λ φ → is-equiv (GroupStructureHom.f φ))

infix 30 _≃ᴳˢ_ -- [ˢ] for structures
_≃ᴳˢ_ = GroupStructureIso

GroupIso : ∀ {i j} (G : Group i) (H : Group j) → Type (lmax i j)
GroupIso G H = Σ (G →ᴳ H) (λ φ → is-equiv (GroupHom.f φ))

infix 30 _≃ᴳ_
_≃ᴳ_ = GroupIso

≃ᴳˢ-to-≃ᴳ : ∀ {i j} {G : Group i} {H : Group j}
  → (Group.group-struct G ≃ᴳˢ Group.group-struct H) → (G ≃ᴳ H)
≃ᴳˢ-to-≃ᴳ (φ , φ-is-equiv) = →ᴳˢ-to-→ᴳ φ , φ-is-equiv

≃-to-≃ᴳ : ∀ {i j} {G : Group i} {H : Group j} (e : Group.El G ≃ Group.El H)
  → preserves-comp (Group.comp G) (Group.comp H) (–> e) → G ≃ᴳ H
≃-to-≃ᴳ (f , f-is-equiv) pres-comp = group-hom f pres-comp , f-is-equiv

≃-to-≃ᴳˢ : ∀ {i j} {GEl : Type i} {HEl : Type j}
  {GS : GroupStructure GEl} {HS : GroupStructure HEl} (e : GEl ≃ HEl)
  → preserves-comp (GroupStructure.comp GS) (GroupStructure.comp HS) (–> e)
  → GS ≃ᴳˢ HS
≃-to-≃ᴳˢ (f , f-is-equiv) pres-comp = group-structure-hom f pres-comp , f-is-equiv

private
  inverse-preserves-comp : ∀ {i j} {A : Type i} {B : Type j}
    (A-comp : A → A → A) (B-comp : B → B → B) {f : A → B} (f-ie : is-equiv f)
    → preserves-comp A-comp B-comp f
    → preserves-comp B-comp A-comp (is-equiv.g f-ie)
  inverse-preserves-comp Ac Bc ie pc b₁ b₂ = let open is-equiv ie in
    ap2 (λ w₁ w₂ → g (Bc w₁ w₂)) (! (f-g b₁)) (! (f-g b₂))
    ∙ ! (ap g (pc (g b₁) (g b₂)))
    ∙ g-f (Ac (g b₁) (g b₂))

module GroupStructureIso {i j} {GEl : Type i} {HEl : Type j}
  {GS : GroupStructure GEl} {HS : GroupStructure HEl}
  (iso : GroupStructureIso GS HS) where

  f-shom : GS →ᴳˢ HS
  f-shom = fst iso

  open GroupStructureHom {GS = GS} {HS = HS} f-shom public

  f-is-equiv : is-equiv f
  f-is-equiv = snd iso

  open is-equiv f-is-equiv public

  f-equiv : GEl ≃ HEl
  f-equiv = f , f-is-equiv

  g-shom : HS →ᴳˢ GS
  g-shom = group-structure-hom g (inverse-preserves-comp (GroupStructure.comp GS) (GroupStructure.comp HS) f-is-equiv pres-comp)

  g-is-equiv : is-equiv g
  g-is-equiv = is-equiv-inverse f-is-equiv

  g-equiv : HEl ≃ GEl
  g-equiv = g , g-is-equiv

module GroupIso {i j} {G : Group i} {H : Group j} (iso : GroupIso G H) where

  f-hom : G →ᴳ H
  f-hom = fst iso

  open GroupHom {G = G} {H = H} f-hom public

  f-is-equiv : is-equiv f
  f-is-equiv = snd iso

  open is-equiv f-is-equiv public

  f-equiv : Group.El G ≃ Group.El H
  f-equiv = f , f-is-equiv

  g-hom : H →ᴳ G
  g-hom = group-hom g (inverse-preserves-comp (Group.comp G) (Group.comp H) f-is-equiv pres-comp)

  g-is-equiv : is-equiv g
  g-is-equiv = is-equiv-inverse f-is-equiv

  g-equiv : Group.El H ≃ Group.El G
  g-equiv = g , g-is-equiv

idiso : ∀ {i} (G : Group i) → (G ≃ᴳ G)
idiso G = idhom G , idf-is-equiv _

idsiso : ∀ {i} {GEl : Type i} (GS : GroupStructure GEl) → (GS ≃ᴳˢ GS)
idsiso GS = idshom GS , idf-is-equiv _

{- equality of isomomorphisms -}
abstract
  group-hom=-to-iso= : ∀ {i j} {G : Group i} {H : Group j} {φ ψ : G ≃ᴳ H}
    → GroupIso.f-hom φ == GroupIso.f-hom ψ → φ == ψ
  group-hom=-to-iso= = Subtype=-out (is-equiv-prop ∘sub GroupHom.f)

  group-iso= : ∀ {i j} {G : Group i} {H : Group j} {φ ψ : G ≃ᴳ H}
    → GroupIso.f φ == GroupIso.f ψ → φ == ψ
  group-iso= {H = H} p = group-hom=-to-iso= $ group-hom= p

{- compositions -}

infixr 80 _∘eᴳˢ_ _∘eᴳ_

_∘eᴳˢ_ : ∀ {i j k} {GEl : Type i} {HEl : Type j} {KEl : Type k}
  {GS : GroupStructure GEl} {HS : GroupStructure HEl} {KS : GroupStructure KEl}
  → HS ≃ᴳˢ KS → GS ≃ᴳˢ HS → GS ≃ᴳˢ KS
(φ₂ , ie₂) ∘eᴳˢ (φ₁ , ie₁) = (φ₂ ∘ᴳˢ φ₁ , ie₂ ∘ise ie₁)

_∘eᴳ_ : ∀ {i j k} {G : Group i} {H : Group j} {K : Group k}
  → H ≃ᴳ K → G ≃ᴳ H → G ≃ᴳ K
(φ₂ , ie₂) ∘eᴳ (φ₁ , ie₁) = (φ₂ ∘ᴳ φ₁ , ie₂ ∘ise ie₁)

infixr 10 _≃ᴳˢ⟨_⟩_ _≃ᴳ⟨_⟩_
infix  15 _≃ᴳˢ∎ _≃ᴳ∎

_≃ᴳˢ⟨_⟩_ : ∀ {i j k} {GEl : Type i} {HEl : Type j} {KEl : Type k}
  (GS : GroupStructure GEl) {HS : GroupStructure HEl} {KS : GroupStructure KEl}
  → GS ≃ᴳˢ HS → HS ≃ᴳˢ KS → GS ≃ᴳˢ KS
GS ≃ᴳˢ⟨ e₁ ⟩ e₂ = e₂ ∘eᴳˢ e₁

_≃ᴳ⟨_⟩_ : ∀ {i j k} (G : Group i) {H : Group j} {K : Group k}
  → G ≃ᴳ H → H ≃ᴳ K → G ≃ᴳ K
G ≃ᴳ⟨ e₁ ⟩ e₂ = e₂ ∘eᴳ e₁

_≃ᴳˢ∎ : ∀ {i} {GEl : Type i} (GS : GroupStructure GEl) → (GS ≃ᴳˢ GS)
_≃ᴳˢ∎ = idsiso

_≃ᴳ∎ : ∀ {i} (G : Group i) → (G ≃ᴳ G)
_≃ᴳ∎ = idiso

infixl 120 _⁻¹ᴳˢ _⁻¹ᴳ

_⁻¹ᴳˢ : ∀ {i j} {GEl : Type i} {HEl : Type j} {GS : GroupStructure GEl} {HS : GroupStructure HEl}
  → GS ≃ᴳˢ HS → HS ≃ᴳˢ GS
_⁻¹ᴳˢ {GS = GS} {HS} (φ , ie) = GroupStructureIso.g-shom (φ , ie) , is-equiv-inverse ie

_⁻¹ᴳ : ∀ {i j} {G : Group i} {H : Group j} → G ≃ᴳ H → H ≃ᴳ G
_⁻¹ᴳ {G = G} {H = H} (φ , ie) = GroupIso.g-hom (φ , ie) , is-equiv-inverse ie

{- mimicking notations for equivalences -}

–>ᴳ : ∀ {i j} {G : Group i} {H : Group j} → (G ≃ᴳ H) → (G →ᴳ H)
–>ᴳ = GroupIso.f-hom

<–ᴳ : ∀ {i j} {G : Group i} {H : Group j} → (G ≃ᴳ H) → (H →ᴳ G)
<–ᴳ = GroupIso.g-hom

{- univalence -}

module _ {i} {G H : Group i} (iso : GroupIso G H) where
  private
    module G = Group G
    module H = Group H
    open module φ = GroupIso {G = G} {H = H} iso
  El= = ua f-equiv

  private
    ap3-lemma : ∀ {i j k l} {C : Type i} {D : C → Type j} {E : C → Type k}
      {F : Type l} {c₁ c₂ : C} {d₁ : D c₁} {d₂ : D c₂} {e₁ : E c₁} {e₂ : E c₂}
      (f : (c : C) → D c → E c → F) (p : c₁ == c₂)
      → (d₁ == d₂ [ D ↓ p ]) → (e₁ == e₂ [ E ↓ p ])
      → (f c₁ d₁ e₁ == f c₂ d₂ e₂)
    ap3-lemma f idp idp idp = idp

    ap3-lemma-El : ∀ {i} {G H : Group i}
      (p : Group.El G == Group.El H)
      (q : Group.El-level G == Group.El-level H [ _ ↓ p ])
      (r : Group.group-struct G == Group.group-struct H [ _ ↓ p ])
      → ap Group.El (ap3-lemma (λ a b c → group a {{b}} c) p q r) == p
    ap3-lemma-El idp idp idp = idp

  {- a homomorphism which is an equivalence gives a path between groups -}
  abstract
    uaᴳ : G == H
    uaᴳ =
      ap3-lemma (λ a b c → group a {{b}} c)
        El=
        prop-has-all-paths-↓
        (↓-group-structure= El= ident= inv= comp=)
      where
      ident= : G.ident == H.ident [ (λ C → C) ↓ El= ]
      ident= = ↓-idf-ua-in _ pres-ident

      inv= : G.inv == H.inv [ (λ C → C → C) ↓ El= ]
      inv= =
        ↓-→-from-transp $ λ= λ a →
          transport (λ C → C) El= (G.inv a)
            =⟨ to-transp (↓-idf-ua-in _ idp) ⟩
          f (G.inv a)
            =⟨ pres-inv a ⟩
          H.inv (f a)
            =⟨ ap H.inv (! (to-transp (↓-idf-ua-in _ idp))) ⟩
          H.inv (transport (λ C → C) El= a) =∎

      comp=' : (a : G.El)
        → G.comp a == H.comp (f a) [ (λ C → C → C) ↓ El= ]
      comp=' a =
        ↓-→-from-transp $ λ= λ b →
          transport (λ C → C) El= (G.comp a b)
            =⟨ to-transp (↓-idf-ua-in _ idp) ⟩
          f (G.comp a b)
            =⟨ pres-comp a b ⟩
          H.comp (f a) (f b)
            =⟨ ! (to-transp (↓-idf-ua-in _ idp))
               |in-ctx (λ w → H.comp (f a) w) ⟩
          H.comp (f a) (transport (λ C → C) El= b) =∎

      comp= : G.comp == H.comp [ (λ C → C → C → C) ↓ El= ]
      comp= =
        ↓-→-from-transp $ λ= λ a →
          transport (λ C → C → C) El= (G.comp a)
            =⟨ to-transp (comp=' a) ⟩
          H.comp (f a)
            =⟨ ! (to-transp (↓-idf-ua-in _ idp)) |in-ctx (λ w → H.comp w) ⟩
          H.comp (transport (λ C → C) El= a) =∎

    -- XXX This stretches the naming convention a little bit.
    El=-β : ap Group.El uaᴳ == El=
    El=-β = ap3-lemma-El El= _ _

{- homomorphism from equality of groups -}

abstract
  transp-El-pres-comp : ∀ {i j} {A : Type i} (B : A → Group j) {a₁ a₂ : A} (p : a₁ == a₂)
    → preserves-comp (Group.comp (B a₁)) (Group.comp (B a₂)) (transport (Group.El ∘ B) p)
  transp-El-pres-comp B idp g₁ g₂ = idp

  transp!-El-pres-comp : ∀ {i j} {A : Type i} (B : A → Group j) {a₁ a₂ : A} (p : a₁ == a₂)
    → preserves-comp (Group.comp (B a₂)) (Group.comp (B a₁)) (transport! (Group.El ∘ B) p)
  transp!-El-pres-comp B idp h₁ h₂ = idp

transportᴳ : ∀ {i j} {A : Type i} (B : A → Group j) {a₁ a₂ : A} (p : a₁ == a₂)
  → (B a₁ →ᴳ B a₂)
transportᴳ B p = record {f = transport (Group.El ∘ B) p; pres-comp = transp-El-pres-comp B p}

transport!ᴳ : ∀ {i j} {A : Type i} (B : A → Group j) {a₁ a₂ : A} (p : a₁ == a₂)
  → (B a₂ →ᴳ B a₁)
transport!ᴳ B p = record {f = transport! (Group.El ∘ B) p; pres-comp = transp!-El-pres-comp B p}

abstract
  transpᴳ-is-iso : ∀ {i j} {A : Type i} (B : A → Group j) {a₁ a₂ : A} (p : a₁ == a₂)
    → is-equiv (GroupHom.f (transportᴳ B p))
  transpᴳ-is-iso B idp = idf-is-equiv _

  transp!ᴳ-is-iso : ∀ {i j} {A : Type i} (B : A → Group j) {a₁ a₂ : A} (p : a₁ == a₂)
    → is-equiv (GroupHom.f (transport!ᴳ B p))
  transp!ᴳ-is-iso B idp = idf-is-equiv _

transportᴳ-iso : ∀ {i j} {A : Type i} (B : A → Group j) {a₁ a₂ : A} (p : a₁ == a₂)
  → B a₁ ≃ᴳ B a₂
transportᴳ-iso B p = transportᴳ B p , transpᴳ-is-iso B p

transport!ᴳ-iso : ∀ {i j} {A : Type i} (B : A → Group j) {a₁ a₂ : A} (p : a₁ == a₂)
  → B a₂ ≃ᴳ B a₁
transport!ᴳ-iso B p = transport!ᴳ B p , transp!ᴳ-is-iso B p

coeᴳ : ∀ {i} {G H : Group i} → G == H → (G →ᴳ H)
coeᴳ = transportᴳ (idf _)

coe!ᴳ : ∀ {i} {G H : Group i} → G == H → (H →ᴳ G)
coe!ᴳ = transport!ᴳ (idf _)

coeᴳ-iso : ∀ {i} {G H : Group i} → G == H → G ≃ᴳ H
coeᴳ-iso = transportᴳ-iso (idf _)

coe!ᴳ-iso : ∀ {i} {G H : Group i} → G == H → H ≃ᴳ G
coe!ᴳ-iso = transport!ᴳ-iso (idf _)

abstract
  coeᴳ-β : ∀ {i} {G H : Group i} (iso : G ≃ᴳ H)
    → coeᴳ (uaᴳ iso) == GroupIso.f-hom iso
  coeᴳ-β iso = group-hom= $
      ap coe (El=-β iso)
    ∙ λ= (coe-β (GroupIso.f-equiv iso))

-- triviality

iso-preserves-trivial : ∀ {i j} {G : Group i} {H : Group j}
  → G ≃ᴳ H → is-trivialᴳ G → is-trivialᴳ H
iso-preserves-trivial iso G-is-trivial h =
    ! (GroupIso.f-g iso h)
  ∙ ap (GroupIso.f iso) (G-is-trivial _)
  ∙ GroupIso.pres-ident iso

iso-preserves'-trivial : ∀ {i j} {G : Group i} {H : Group j}
  → G ≃ᴳ H → is-trivialᴳ H → is-trivialᴳ G
iso-preserves'-trivial iso H-is-trivial g =
    ! (GroupIso.g-f iso g)
  ∙ ap (GroupIso.g iso) (H-is-trivial _)
  ∙ GroupHom.pres-ident (GroupIso.g-hom iso)

-- a surjective and injective homomorphism is an isomorphism
module _ {i j} {G : Group i} {H : Group j} (φ : G →ᴳ H)
  (surj : is-surjᴳ φ) (inj : is-injᴳ φ) where
  private
    module G = Group G
    module H = Group H
    module φ = GroupHom φ

    abstract
      instance
        image-prop : (h : H.El) → is-prop (hfiber φ.f h)
        image-prop h = all-paths-is-prop λ {(g₁ , p₁) (g₂ , p₂) →
          pair= (inj g₁ g₂ (p₁ ∙ ! p₂)) prop-has-all-paths-↓}

  surjᴳ-and-injᴳ-is-equiv : is-equiv φ.f
  surjᴳ-and-injᴳ-is-equiv = contr-map-is-equiv
    (λ h → let (g₁ , p₁) = Trunc-rec (idf _) (surj h) in
      has-level-in ((g₁ , p₁) , (λ {(g₂ , p₂) →
        pair= (inj g₁ g₂ (p₁ ∙ ! p₂))
                prop-has-all-paths-↓})))

  surjᴳ-and-injᴳ-iso : G ≃ᴳ H
  surjᴳ-and-injᴳ-iso = φ , surjᴳ-and-injᴳ-is-equiv

-- isomorphisms preserve abelianess.
module _ {i} {G H : Group i} (iso : G ≃ᴳ H) (G-abelian : is-abelian G) where
  private
    module G = Group G
    module H = Group H
    open GroupIso iso

  abstract
    iso-preserves-abelian : is-abelian H
    iso-preserves-abelian h₁ h₂ =
      H.comp h₁ h₂
        =⟨ ap2 H.comp (! $ f-g h₁) (! $ f-g h₂) ⟩
      H.comp (f (g h₁)) (f (g h₂))
        =⟨ ! $ pres-comp (g h₁) (g h₂) ⟩
      f (G.comp (g h₁) (g h₂))
        =⟨ G-abelian (g h₁) (g h₂) |in-ctx f ⟩
      f (G.comp (g h₂) (g h₁))
        =⟨ pres-comp (g h₂) (g h₁) ⟩
      H.comp (f (g h₂)) (f (g h₁))
        =⟨ ap2 H.comp (f-g h₂) (f-g h₁) ⟩
      H.comp h₂ h₁
        =∎

pre∘ᴳ-iso : ∀ {i j k} {G : Group i} {H : Group j} (K : AbGroup k)
  → (G ≃ᴳ H) → (hom-group H K ≃ᴳ hom-group G K)
pre∘ᴳ-iso K iso = ≃-to-≃ᴳ (equiv to from to-from from-to) to-pres-comp where
  to = GroupHom.f (pre∘ᴳ-hom K (–>ᴳ iso))
  to-pres-comp = GroupHom.pres-comp (pre∘ᴳ-hom K (–>ᴳ iso))
  from = GroupHom.f (pre∘ᴳ-hom K (<–ᴳ iso))
  abstract
    to-from : ∀ φ → to (from φ) == φ
    to-from φ = group-hom= $ λ= λ g → ap (GroupHom.f φ) (GroupIso.g-f iso g)

    from-to : ∀ φ → from (to φ) == φ
    from-to φ = group-hom= $ λ= λ h → ap (GroupHom.f φ) (GroupIso.f-g iso h)

post∘ᴳ-iso : ∀ {i j k} (G : Group i) (H : AbGroup j) (K : AbGroup k)
  → (AbGroup.grp H ≃ᴳ AbGroup.grp K) → (hom-group G H ≃ᴳ hom-group G K)
post∘ᴳ-iso G H K iso = ≃-to-≃ᴳ (equiv to from to-from from-to) to-pres-comp where
  to = GroupHom.f (post∘ᴳ-hom G H K (–>ᴳ iso))
  to-pres-comp = GroupHom.pres-comp (post∘ᴳ-hom G H K(–>ᴳ iso))
  from = GroupHom.f (post∘ᴳ-hom G K H (<–ᴳ iso))
  abstract
    to-from : ∀ φ → to (from φ) == φ
    to-from φ = group-hom= $ λ= λ g → GroupIso.f-g iso (GroupHom.f φ g)

    from-to : ∀ φ → from (to φ) == φ
    from-to φ = group-hom= $ λ= λ h → GroupIso.g-f iso (GroupHom.f φ h)


-- Non-index (plain) monads in form of Kleisli triple.

module Control.Monad where

open import Function using () renaming (_∘′_ to _∘_)
open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

open import Axiom.FunctionExtensionality
open import Control.Functor

-- The operations of a monad.

module T-MonadOps (M : Set → Set) where

  T-return = ∀ {A}   (a : A)                 → M A
  T-bind   = ∀ {A B} (m : M A) (k : A → M B) → M B

record MonadOps (M : Set → Set) : Set₁ where
  open T-MonadOps M

  infixr 6 _>>=_

  field
    return : T-return
    _>>=_  : T-bind

  bind = _>>=_

  functorOps : FunctorOps M
  functorOps = record
    { map = λ f m → m >>= λ a → return (f a)
    }

  open FunctorOps functorOps public

-- The laws of a monad (Kleisli triple variant).

module T-MonadLaws {M : Set → Set} (ops : MonadOps M) where
  open MonadOps ops public

  T-bind-β = ∀ {A B} (k : A → M B) (a : A) →

      return a >>= k  ≡  k a

  T-bind-η = ∀ {A} (m : M A) →

      m >>= return  ≡  m

  T-bind-assoc = ∀ {A B C} (m : M A) {k : A → M B} {l : B → M C} →

      (m >>= k) >>= l  ≡  m >>= λ a → (k a >>= l)

  -- Provable laws.

  -- A variant of bind-β using function extensionality.

  T-bind-β-ext = ∀ {A B C : Set} (f : A → B) (k : B → M C) →

      (λ a → return (f a) >>= k)  ≡  k ∘ f

  T-map-after-bind = ∀ {A B C} (m : M A) {k : A → M B} {f : B → C} →

      f <$> (m >>= k)  ≡  m >>= λ a → f <$> k a

  T-bind-after-map = ∀ {A B C} (m : M A) {k : B → M C} {f : A → B} →

     (f <$> m) >>= k  ≡  m >>= λ a → k (f a)

record MonadLaws {M : Set → Set} (ops : MonadOps M) : Set₁ where
  open T-MonadLaws ops

  -- Axioms.

  field
    bind-β     : T-bind-β
    bind-η     : T-bind-η
    bind-assoc : T-bind-assoc

  -- Derived laws.

  bind-β-ext : T-bind-β-ext
  bind-β-ext f k = fun-ext (λ a → bind-β k (f a))

  map-after-bind : T-map-after-bind
  map-after-bind m = bind-assoc m

  -- A more detailed proof.  (NF: trans (bind-assoc m) refl)
  private
    map-after-bind′ : T-map-after-bind
    map-after-bind′ m {k = k} {f = f} = begin
        f <$> (m >>= k)
      ≡⟨⟩                                        -- definition of map
        ((m >>= k) >>= λ b → return (f b))
      ≡⟨ bind-assoc m ⟩                          -- associativity of bind
        m >>= (λ a → k a >>= λ b → return (f b))
      ≡⟨⟩                                        -- definition of map
        m >>= (λ a → f <$> k a)
      ∎

  bind-after-map : T-bind-after-map
  bind-after-map m {k = k} {f = f} = begin
      (f <$> m) >>= k
    ≡⟨⟩                                        -- definition of map
      (m >>= λ a → return (f a)) >>= k
    ≡⟨ bind-assoc m ⟩                          -- associativity of bind
      m >>= (λ a → return (f a) >>= k)
    ≡⟨ cong (_>>=_ m) (bind-β-ext _ _) ⟩       -- beta for bind
      m >>= (λ a → k (f a))
    ∎

  -- Functor laws.

  open T-FunctorLaws functorOps using (T-map-∘)

  private
    abstract
      map-comp : T-map-∘
      map-comp {f = f} {g = g} = fun-ext λ m → begin
          g ∘ f <$> m                                          ≡⟨⟩
          (m >>= λ a → return (g (f a)))                       ≡⟨ cong (_>>=_ m) (sym (bind-β-ext _ _)) ⟩
          (m >>= λ a → return (f a) >>= λ b → return (g b))    ≡⟨ sym (bind-assoc m) ⟩
          (m >>= λ a → return (f a)) >>= (λ b → return (g b))  ≡⟨⟩
          g <$> f <$> m
        ∎

  functorLaws : FunctorLaws functorOps
  functorLaws = record
    { map-id = fun-ext bind-η
    ; map-∘  = map-comp
    }

  open FunctorLaws functorLaws public

record IsMonad (M : Set → Set) : Set₁ where

  field
    ops  : MonadOps  M
    laws : MonadLaws ops

  open MonadOps  ops  public
  open MonadLaws laws public

{-

-- The operations of a monad.

record MonadOps (M : Set → Set) : Set₁ where

  infixr 6 _>>=_

  T-return = ∀ {A}   (a : A)                 → M A
  T-bind   = ∀ {A B} (m : M A) (k : A → M B) → M B

  field
    return : T-return
    _>>=_  : T-bind

  bind = _>>=_

  functorOps : FunctorOps M
  functorOps = record
    { _<$>_ = λ f m → m >>= λ a → return (f a)
    }

  open FunctorOps functorOps public

-- The laws of a monad (Kleisli triple variant).

record MonadLaws {M : Set → Set} (ops : MonadOps M) : Set₁ where

  open MonadOps ops

  T-bind-β = ∀ {A B} (a : A) (k : A → M B) →

      return a >>= k  ≡  k a

  T-bind-η = ∀ {A} (m : M A) →

      m >>= return  ≡  m

  T-bind-assoc = ∀ {A B C} (m : M A) {k : A → M B} {l : B → M C} →

      (m >>= k) >>= l  ≡  m >>= λ a → (k a >>= l)

  field
    bind-β     : T-bind-β
    bind-η     : T-bind-η
    bind-assoc : T-bind-assoc

  private
    abstract
      map-comp : FunctorLaws.T-map-∘ {!!}
      map-comp = {!!}

  functorLaws : FunctorLaws functorOps
  functorLaws = record
    { map-id = bind-η
    ; map-∘  = {!!}
    }

record IsMonad (M : Set → Set) : Set₁ where

record IsMonad (M : Set → Set) : Set₁ where

  infixr 6 _>>=_

  field
    return : ∀ {A}   (a : A)                 → M A
    _>>=_  : ∀ {A B} (m : M A) (k : A → M B) → M B

    -- Laws

    bind-β : ∀ {A B} (a : A) (k : A → M B) →

      return a >>= k  ≡  k a

    bind-η : ∀ {A} (m : M A) →

      m >>= return  ≡  m

    bind-assoc  : ∀ {A B C} (m : M A) {k : A → M B} {l : B → M C} →

      (m >>= k) >>= l  ≡  m >>= λ a → (k a >>= l)

  bind = _>>=_

  private
    map : Map-T F
    map = λ f m → m >>= λ a → return (f a)

    abstract
      map-comp : Map-Comp-T map

  functor : IsFunctor M
  functor = record
    { _<$>_  = λ f m → m >>= λ a → return (f a)
    ; map-id = bind-η
    ; map-∘  = map-comp
        where x = {!bind-assoc!}
    }
-}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Argument information used in the reflection machinery
------------------------------------------------------------------------

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

module Reflection.Argument.Information where

open import Data.Product
open import Relation.Nullary
import Relation.Nullary.Decidable as Dec
open import Relation.Nullary.Product using (_×-dec_)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality

open import Reflection.Argument.Relevance as Relevance using (Relevance)
open import Reflection.Argument.Visibility as Visibility using (Visibility)

------------------------------------------------------------------------
-- Re-exporting the builtins publically

open import Agda.Builtin.Reflection public using (ArgInfo)
open ArgInfo public

------------------------------------------------------------------------
-- Operations

visibility : ArgInfo → Visibility
visibility (arg-info v _) = v

relevance : ArgInfo → Relevance
relevance (arg-info _ r) = r

------------------------------------------------------------------------
-- Decidable equality

arg-info-injective₁ : ∀ {v r v′ r′} → arg-info v r ≡ arg-info v′ r′ → v ≡ v′
arg-info-injective₁ refl = refl

arg-info-injective₂ : ∀ {v r v′ r′} → arg-info v r ≡ arg-info v′ r′ → r ≡ r′
arg-info-injective₂ refl = refl

arg-info-injective : ∀ {v r v′ r′} → arg-info v r ≡ arg-info v′ r′ → v ≡ v′ × r ≡ r′
arg-info-injective = < arg-info-injective₁ , arg-info-injective₂ >

_≟_ : DecidableEquality ArgInfo
arg-info v r ≟ arg-info v′ r′ =
  Dec.map′ (uncurry (cong₂ arg-info))
           arg-info-injective
           (v Visibility.≟ v′ ×-dec r Relevance.≟ r′)


module Structure.Operator.Vector.LinearMaps where

open import Functional
open import Function.Proofs
open import Logic.Predicate
import      Lvl
open import Structure.Function
open import Structure.Function.Multi
open import Structure.Operator.Properties
open import Structure.Operator.Vector.LinearMap
open import Structure.Operator.Vector.Proofs
open import Structure.Operator.Vector
open import Structure.Relator.Properties
open import Structure.Setoid
open import Syntax.Transitivity
open import Type

private variable ℓ ℓᵥ ℓᵥₗ ℓᵥᵣ ℓᵥ₁ ℓᵥ₂ ℓᵥ₃ ℓₛ ℓᵥₑ ℓᵥₑₗ ℓᵥₑᵣ ℓᵥₑ₁ ℓᵥₑ₂ ℓᵥₑ₃ ℓₛₑ : Lvl.Level
private variable V Vₗ Vᵣ V₁ V₂ V₃ S : Type{ℓ}
private variable _+ᵥ_ _+ᵥₗ_ _+ᵥᵣ_ _+ᵥ₁_ _+ᵥ₂_ _+ᵥ₃_ : V → V → V
private variable _⋅ₛᵥ_ _⋅ₛᵥₗ_ _⋅ₛᵥᵣ_ _⋅ₛᵥ₁_ _⋅ₛᵥ₂_ _⋅ₛᵥ₃_ : S → V → V
private variable _+ₛ_ _⋅ₛ_ : S → S → S
private variable f g : Vₗ → Vᵣ

open VectorSpace ⦃ … ⦄

module _
  ⦃ equiv-Vₗ : Equiv{ℓᵥₑₗ}(Vₗ) ⦄
  ⦃ equiv-Vᵣ : Equiv{ℓᵥₑᵣ}(Vᵣ) ⦄
  ⦃ equiv-S : Equiv{ℓₛₑ}(S) ⦄
  (vectorSpaceₗ : VectorSpace{V = Vₗ}{S = S}(_+ᵥₗ_)(_⋅ₛᵥₗ_)(_+ₛ_)(_⋅ₛ_))
  (vectorSpaceᵣ : VectorSpace{V = Vᵣ}{S = S}(_+ᵥᵣ_)(_⋅ₛᵥᵣ_)(_+ₛ_)(_⋅ₛ_))
  where

  instance _ = vectorSpaceₗ
  instance _ = vectorSpaceᵣ

  zero : LinearMap(vectorSpaceₗ)(vectorSpaceᵣ)(const 𝟎ᵥ)
  Preserving.proof (LinearMap.preserves-[+ᵥ] zero) {x} {y} =
    const 𝟎ᵥ (x +ᵥₗ y)            🝖[ _≡_ ]-[]
    𝟎ᵥ                            🝖[ _≡_ ]-[ identityₗ(_+ᵥᵣ_)(𝟎ᵥ) ]-sym
    𝟎ᵥ +ᵥᵣ 𝟎ᵥ                     🝖[ _≡_ ]-[]
    (const 𝟎ᵥ x) +ᵥᵣ (const 𝟎ᵥ y) 🝖-end
  Preserving.proof (LinearMap.preserves-[⋅ₛᵥ] zero {s}) {x} =
    const 𝟎ᵥ (s ⋅ₛᵥₗ x) 🝖[ _≡_ ]-[]
    𝟎ᵥ                  🝖[ _≡_ ]-[ [⋅ₛᵥ]-absorberᵣ ]-sym
    s ⋅ₛᵥᵣ 𝟎ᵥ           🝖[ _≡_ ]-[]
    s ⋅ₛᵥᵣ (const 𝟎ᵥ x) 🝖-end

module _
  ⦃ equiv-V : Equiv{ℓᵥₑ}(V) ⦄
  ⦃ equiv-S : Equiv{ℓₛₑ}(S) ⦄
  (vectorSpace : VectorSpace{V = V}{S = S}(_+ᵥ_)(_⋅ₛᵥ_)(_+ₛ_)(_⋅ₛ_))
  where

  instance _ = vectorSpace

  identity : LinearOperator(vectorSpace)(id)
  Preserving.proof (LinearMap.preserves-[+ᵥ]  identity) = reflexivity(_≡_)
  Preserving.proof (LinearMap.preserves-[⋅ₛᵥ] identity) = reflexivity(_≡_)

module _
  ⦃ equiv-V₁ : Equiv{ℓᵥₑ₁}(V₁) ⦄
  ⦃ equiv-V₂ : Equiv{ℓᵥₑ₂}(V₂) ⦄
  ⦃ equiv-V₂ : Equiv{ℓᵥₑ₃}(V₃) ⦄
  ⦃ equiv-S : Equiv{ℓₛₑ}(S) ⦄
  (vectorSpace₁ : VectorSpace{V = V₁}{S = S}(_+ᵥ₁_)(_⋅ₛᵥ₁_)(_+ₛ_)(_⋅ₛ_))
  (vectorSpace₂ : VectorSpace{V = V₂}{S = S}(_+ᵥ₂_)(_⋅ₛᵥ₂_)(_+ₛ_)(_⋅ₛ_))
  (vectorSpace₃ : VectorSpace{V = V₃}{S = S}(_+ᵥ₃_)(_⋅ₛᵥ₃_)(_+ₛ_)(_⋅ₛ_))
  where

  instance _ = vectorSpace₁
  instance _ = vectorSpace₂
  instance _ = vectorSpace₃

  compose : LinearMap(vectorSpace₂)(vectorSpace₃)(f) → LinearMap(vectorSpace₁)(vectorSpace₂)(g) → LinearMap(vectorSpace₁)(vectorSpace₃)(f ∘ g)
  LinearMap.function (compose {f} {g} F G) = [∘]-function {f = f}{g = g}
  Preserving.proof (LinearMap.preserves-[+ᵥ] (compose {f} {g} F G)) {x}{y} =
    (f ∘ g)(x +ᵥ₁ y)          🝖[ _≡_ ]-[]
    f(g(x +ᵥ₁ y))             🝖[ _≡_ ]-[ congruence₁(f) (preserving₂(g) (_+ᵥ₁_)(_+ᵥ₂_)) ]
    f(g(x) +ᵥ₂ g(y))          🝖[ _≡_ ]-[ preserving₂(f) (_+ᵥ₂_)(_+ᵥ₃_) ]
    f(g(x)) +ᵥ₃ f(g(y))       🝖[ _≡_ ]-[]
    (f ∘ g)(x) +ᵥ₃ (f ∘ g)(y) 🝖-end
  Preserving.proof (LinearMap.preserves-[⋅ₛᵥ] (compose {f} {g} F G) {s}) {v} =
    (f ∘ g) (s ⋅ₛᵥ₁ v) 🝖[ _≡_ ]-[]
    f(g(s ⋅ₛᵥ₁ v))     🝖[ _≡_ ]-[ congruence₁(f) (preserving₁(g) (s ⋅ₛᵥ₁_)(s ⋅ₛᵥ₂_)) ]
    f(s ⋅ₛᵥ₂ g(v))     🝖[ _≡_ ]-[ preserving₁(f) (s ⋅ₛᵥ₂_)(s ⋅ₛᵥ₃_) ]
    s ⋅ₛᵥ₃ f(g(v))     🝖[ _≡_ ]-[]
    s ⋅ₛᵥ₃ (f ∘ g)(v)  🝖-end

module _ ⦃ equiv-S : Equiv{ℓₛₑ}(S) ⦄ {_+ₛ_ _⋅ₛ_ : S → S → S} where
  private variable A B C : VectorSpaceVObject {ℓᵥ}{_}{ℓᵥₑ}{ℓₛₑ} ⦃ equiv-S ⦄ (_+ₛ_)(_⋅ₛ_)
  open VectorSpaceVObject hiding (𝟎ᵥ)

  𝟎ˡⁱⁿᵉᵃʳᵐᵃᵖ : A →ˡⁱⁿᵉᵃʳᵐᵃᵖ B
  𝟎ˡⁱⁿᵉᵃʳᵐᵃᵖ {A = A}{B = B} = [∃]-intro (const 𝟎ᵥ) ⦃ zero (vectorSpace A) (vectorSpace B) ⦄

  idˡⁱⁿᵉᵃʳᵐᵃᵖ : A →ˡⁱⁿᵉᵃʳᵐᵃᵖ A
  idˡⁱⁿᵉᵃʳᵐᵃᵖ {A = A} = [∃]-intro id ⦃ identity(vectorSpace A) ⦄

  _∘ˡⁱⁿᵉᵃʳᵐᵃᵖ_ : let _ = A in (B →ˡⁱⁿᵉᵃʳᵐᵃᵖ C) → (A →ˡⁱⁿᵉᵃʳᵐᵃᵖ B) → (A →ˡⁱⁿᵉᵃʳᵐᵃᵖ C)
  _∘ˡⁱⁿᵉᵃʳᵐᵃᵖ_ {A = A}{B = B}{C = C} ([∃]-intro f ⦃ linmap-f ⦄) ([∃]-intro g ⦃ linmap-g ⦄) = [∃]-intro (f ∘ g) ⦃ compose (vectorSpace A) (vectorSpace B) (vectorSpace C) linmap-f linmap-g ⦄


module _ where

record Semiring (A : Set) : Set where
  infixl 6 _+_
  field _+_ : A → A → A

open Semiring {{...}} public

infix 4 _≡_

postulate
  Ord : Set → Set
  Nat Bool  : Set
  zero  : Nat
  _≡_   : Nat → Nat → Set
  refl  : ∀ {x} → x ≡ x
  to    : ∀ {x} y → x ≡ y
  trans : {x y z : Nat} → x ≡ y → y ≡ z → x ≡ z

  instance
    ringNat′ : Semiring Nat

  _+N_ : Nat → Nat → Nat

instance
  ringNat : Semiring Nat
  ringNat ._+_ = _+N_

bad : (a b c : Nat) → a +N b ≡ c +N a
bad a b c =
  trans (to (a + c)) refl

-- Should list the errors from testing both ringNat and ringNat′


open import Base
open import Homotopy.Connected

module Homotopy.Extensions.ProductPushoutToProductToConnected.Magic
  {i j} {D E : Set i} (h : E → D) where

  {-
         k
      E ---> F x
      |    /^
      | ≃ /
      |  / l?
      v /
    (x : D)
  -}

  -- The mapping l and the coherence data.
  extension : (F : D → Set j) (k : ∀ x → F (h x)) → Set (max i j)
  extension F k = Σ (Π D F) (λ l → ∀ x → k x ≡ l (h x))

  -- Specialized J rules.
  private
    -- This is a combination of 2~3 basic rules.
    lemma₁ : ∀ (F : D → Set j) (k : ∀ x → F (h x))
      {l₁ l₂ : ∀ x → F x} (p : l₁ ≡ l₂) (q : ∀ x → k x ≡ l₁ (h x)) a
      → transport (λ l → ∀ x → k x ≡ l (h x)) p q a
      ≡ q a ∘ happly p (h a)
    lemma₁ F k refl q a = ! $ refl-right-unit _

    -- May be generalized later.
    lemma₂ : ∀ {i} {X : Set i} {x₁ x₂ x₃ : X}
      (p₁ : x₁ ≡ x₂) (p₂ : x₂ ≡ x₃) (p₃ : x₁ ≡ x₃)
      → (p₁ ∘ p₂ ≡ p₃) ≡ (p₂ ≡ ! p₁ ∘ p₃)
    lemma₂ refl _ _ = refl

    -- May be generalized later.
    lemma₃ : ∀ {i} {X : Set i} {x₁ x₂ : X}
      (p₁ : x₁ ≡ x₂) (p₂ : x₁ ≡ x₂)
      → (p₁ ≡ p₂) ≡ (p₂ ≡ p₁)
    lemma₃ p₁ p₂ = eq-to-path $ ! , iso-is-eq ! ! opposite-opposite opposite-opposite

    lemma₄ : ∀ {i j} {A A′ : Set i} (B′ : A′ → Set j) (eq : A ≃ A′)
      → Σ A (λ x → (B′ (eq ☆ x))) ≡ Σ A′ B′
    lemma₄ {j = j} B′ eq = equiv-induction
      (λ {A A′} eq → ∀ (B′ : A′ → Set j) → Σ A (λ x → (B′ (eq ☆ x))) ≡ Σ A′ B′)
      (λ A _ → refl)
      eq B′

  -- The main lemma
  module _ {n₁ : ℕ₋₂} (h-is-conn : has-connected-fibers n₁ h) where
    open import Homotopy.Truncation

    extension-is-truncated :
      (F : D → Set j)
      {n₂ : ℕ₋₂} ⦃ F-is-trunc : ∀ x → is-truncated (n₂ +2+ n₁) (F x) ⦄
      (k : ∀ x → F (h x))
      → is-truncated n₂ (extension F k)
    extension-is-truncated F {⟨-2⟩} ⦃ F-is-trunc ⦄ k =
      center , (λ e″ → Σ-eq (path-l e″) (path-coh e″))
        where
          -- The section
          l′ : ∀ x → τ n₁ (hfiber h x) → F x
          l′ x = τ-extend-nondep ⦃ F-is-trunc x ⦄
            λ{(preimage , shift) → transport F shift (k preimage)}

          -- The section
          l : ∀ x → F x
          l x = l′ x (π₁ (h-is-conn x))

          -- The coherence data (commutivity)
          abstract
            coh : ∀ x → k x ≡ l (h x)
            coh x = ap (l′ (h x)) $ π₂ (h-is-conn (h x)) $ proj (x , refl)

          -- The canonical choice of section+coherence
          center : extension F k
          center = l , coh

          -- The path between the canonical choice and others (pointwise).
          abstract
            path-l-pointwise′ : ∀ (e : extension F k) x → τ n₁ (hfiber h x) → π₁ e x ≡ l x
            path-l-pointwise′ = λ{(l″ , coh″) x →
              τ-extend-nondep
              ⦃ ≡-is-truncated n₁ $ F-is-trunc x ⦄
              -- The point is to make all artifacts go away when shift = refl _.
              (λ{(pre , shift) → transport (λ x → l″ x ≡ l x) shift $
                l″ (h pre)
                  ≡⟨ ! $ coh″ pre ⟩
                k pre
                  ≡⟨ coh pre ⟩∎
                l (h pre)
                  ∎})}

          -- The path between the canonical choice and others (pointwise).
          abstract
            path-l-pointwise : ∀ (e : extension F k) x → π₁ e x ≡ l x
            path-l-pointwise = λ e x →
              path-l-pointwise′ e x (π₁ (h-is-conn x))

          -- The path between the canonical choice and others.
          abstract
            path-l : ∀ (e : extension F k) → π₁ e ≡ l
            path-l = funext ◯ path-l-pointwise

          -- The path between the canonical choice and others.
          abstract
            path-coh : ∀ (e : extension F k)
              → transport (λ l → ∀ x → k x ≡ l (h x)) (path-l e) (π₂ e)
              ≡ coh
            path-coh e″ = funext λ x → let coh″ = π₂ e″ in
              transport (λ l → ∀ x → k x ≡ l (h x)) (path-l e″) coh″ x
                ≡⟨ lemma₁ F k (path-l e″) coh″ x ⟩
              coh″ x ∘ happly (path-l e″) (h x)
                ≡⟨ ap (λ p → coh″ x ∘ p (h x)) $ happly-funext (path-l-pointwise e″) ⟩
              coh″ x ∘ (path-l-pointwise′ e″ (h x) (π₁ (h-is-conn (h x))))
                ≡⟨ ap (λ y → π₂ e″ x ∘ (path-l-pointwise′ e″ (h x) y))
                      $ ! $ π₂ (h-is-conn (h x)) $ proj (x , refl) ⟩
              coh″ x ∘ (path-l-pointwise′ e″ (h x) (proj (x , refl)))
                ≡⟨ refl ⟩
              coh″ x ∘ ((! $ coh″ x) ∘ coh x)
                ≡⟨ ! $ concat-assoc (coh″ x) (! $ coh″ x) (coh x) ⟩
              (coh″ x ∘ (! $ coh″ x)) ∘ coh x
                ≡⟨ ap (λ p → p ∘ coh x) $ opposite-right-inverse (coh″ x) ⟩∎
              coh x
                ∎
    extension-is-truncated F {S n₂} ⦃ F-is-trunc ⦄ k = λ e₁ e₂ →
      transport (is-truncated n₂)
      (! $ extension≡-extension′-path e₁ e₂)
      (extension′-is-trunc e₁ e₂) where
        module _ (e₁ e₂ : extension F k) where
          l₁ = π₁ e₁
          l₂ = π₁ e₂
          coh₁ = π₂ e₁
          coh₂ = π₂ e₂

          -- The trick: Make a new F for the path space.
          F′ : ∀ D → Set j
          F′ x = l₁ x ≡ l₂ x

          k′ : ∀ x → F′ (h x)
          k′ x = ! (coh₁ x) ∘ coh₂ x

          F′-is-trunc : ∀ x → is-truncated (n₂ +2+ n₁) (F′ x)
          F′-is-trunc x = F-is-trunc x (l₁ x) (l₂ x)

          extension′ : Set (max i j)
          extension′ = extension F′ k′

          -- Conversion between paths and new extensions.
          abstract
            extension≡-extension′-path : (e₁ ≡ e₂) ≡ extension′
            extension≡-extension′-path =
              e₁ ≡ e₂
                ≡⟨ ! $ eq-to-path $ total-Σ-eq-equiv ⟩
              Σ (l₁ ≡ l₂) (λ l₁≡l₂ → transport (λ l → ∀ x → k x ≡ l (h x)) l₁≡l₂ coh₁ ≡ coh₂)
                ≡⟨ ap (Σ (l₁ ≡ l₂)) (funext λ _ → ! $ eq-to-path $ funext-equiv) ⟩
              Σ (l₁ ≡ l₂) (λ l₁≡l₂ → ∀ x → transport (λ l → ∀ x → k x ≡ l (h x)) l₁≡l₂ coh₁ x ≡ coh₂ x)
                ≡⟨ ap (Σ (l₁ ≡ l₂)) (funext λ l₁≡l₂ → ap (λ p → ∀ x → p x ≡ coh₂ x)
                      $ funext $ lemma₁ F k l₁≡l₂ coh₁) ⟩
              Σ (l₁ ≡ l₂) (λ l₁≡l₂ → ∀ x → coh₁ x ∘ happly l₁≡l₂ (h x) ≡ coh₂ x)
                ≡⟨ ap (Σ (l₁ ≡ l₂)) (funext λ l₁≡l₂ → ap (λ p → ∀ x → p x)
                      $ funext λ x → lemma₂ (coh₁ x) (happly l₁≡l₂ (h x)) (coh₂ x)) ⟩
              Σ (l₁ ≡ l₂) (λ l₁≡l₂ → ∀ x → happly l₁≡l₂ (h x) ≡ ! (coh₁ x) ∘ coh₂ x)
                ≡⟨ ap (Σ (l₁ ≡ l₂)) (funext λ l₁≡l₂ → ap (λ p → ∀ x → p x)
                      $ funext λ x → lemma₃ (happly l₁≡l₂ (h x)) (! (coh₁ x) ∘ coh₂ x)) ⟩
              Σ (l₁ ≡ l₂) (λ l₁≡l₂ → ∀ x → ! (coh₁ x) ∘ coh₂ x ≡ happly l₁≡l₂ (h x))
                ≡⟨ lemma₄ (λ l₁x≡l₂x → ∀ x → ! (coh₁ x) ∘ coh₂ x ≡ l₁x≡l₂x (h x)) happly-equiv ⟩∎
              extension′
                ∎

          -- Recursive calls.
          abstract
            extension′-is-trunc : is-truncated n₂ extension′
            extension′-is-trunc = extension-is-truncated F′ {n₂} ⦃ F′-is-trunc ⦄ k′


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

open import lib.Basics
open import lib.NType2
open import lib.types.Pi
open import lib.types.Group

{-
    The definition of G-sets.  Thanks to Daniel Grayson.
-}

module lib.types.GroupSet {i} where

  -- The right group action with respect to the group [grp].
  record GroupSetStructure (grp : Group i) {j} (El : Type j)
    (_ : is-set El) : Type (lmax i j) where
    constructor groupset-structure
    private
      module G = Group grp
      module GS = GroupStructure G.group-struct
    field
      act : El → G.El → El
      unit-r : ∀ x → act x GS.ident == x
      assoc : ∀ x g₁ g₂ → act (act x g₁) g₂ == act x (GS.comp g₁ g₂)

  -- The definition of a G-set.  A set [El] equipped with
  -- a right group action with respect to [grp].
  record GroupSet (grp : Group i) j : Type (lsucc (lmax i j)) where
    constructor groupset
    field
      El : Type j
      El-level : is-set El
      grpset-struct : GroupSetStructure grp El El-level
    open GroupSetStructure grpset-struct public
    El-is-set = El-level

  -- A helper function to establish equivalence between two G-sets.
  -- Many data are just props and this function do the coversion for them
  -- for you.  You only need to show the non-trivial parts.
  module _ {grp : Group i} {j} {El : Type j} {El-level : is-set El} where
    private
      module G = Group grp
      module GS = GroupStructure G.group-struct
    open GroupSetStructure
    private
      groupset-structure=' : ∀ {gss₁ gss₂ : GroupSetStructure grp El El-level}
        → (act= : act gss₁ == act gss₂)
        → unit-r gss₁ == unit-r gss₂
          [ (λ act → ∀ x → act x GS.ident == x) ↓ act= ]
        → assoc gss₁ == assoc gss₂
          [ (λ act → ∀ x g₁ g₂ →
              act (act x g₁) g₂ == act x (GS.comp g₁ g₂)) ↓ act= ]
        → gss₁ == gss₂
      groupset-structure=' {groupset-structure _ _ _} {groupset-structure ._ ._ ._}
        idp idp idp = idp

    groupset-structure= : ∀ {gss₁ gss₂ : GroupSetStructure grp El El-level}
      → (∀ x g → act gss₁ x g == act gss₂ x g)
      → gss₁ == gss₂
    groupset-structure= act= = groupset-structure='
      (λ= λ x → λ= λ g → act= x g)
      (prop-has-all-paths-↓ (Π-level λ _ → El-level _ _))
      (prop-has-all-paths-↓
        (Π-level λ _ → Π-level λ _ → Π-level λ _ → El-level _ _))

  module _ {grp : Group i} {j : ULevel} where
    private
      module G = Group grp
      module GS = GroupStructure G.group-struct
    open GroupSet {grp} {j}
    private
      groupset='' : ∀ {gs₁ gs₂ : GroupSet grp j}
        → (El= : El gs₁ == El gs₂)
        → (El-level : El-level gs₁ == El-level gs₂ [ is-set ↓ El= ])
        → grpset-struct gs₁ == grpset-struct gs₂
          [ uncurry (GroupSetStructure grp) ↓ pair= El= El-level ]
        → gs₁ == gs₂
      groupset='' {groupset _ _ _} {groupset ._ ._ ._} idp idp idp = idp

      groupset=' : ∀ {gs₁ gs₂ : GroupSet grp j}
        → (El= : El gs₁ == El gs₂)
        → (El-level : El-level gs₁ == El-level gs₂ [ is-set ↓ El= ])
        → (∀ {x₁} {x₂} (p : x₁ == x₂ [ idf _ ↓ El= ]) g
            → act gs₁ x₁ g == act gs₂ x₂ g [ idf _ ↓ El= ])
        → gs₁ == gs₂
      groupset=' {groupset _ _ _} {groupset ._ ._ _} idp idp act= =
        groupset='' idp idp (groupset-structure= λ x g → act= idp g)

    groupset= : ∀ {gs₁ gs₂ : GroupSet grp j}
      → (El≃ : El gs₁ ≃ El gs₂)
      → (∀ {x₁} {x₂}
          → –> El≃ x₁ == x₂
          → ∀ g → –> El≃ (act gs₁ x₁ g) == act gs₂ x₂ g)
      → gs₁ == gs₂
    groupset= El≃ act= =
      groupset='
        (ua El≃)
        (prop-has-all-paths-↓ is-set-is-prop)
        (λ x= g → ↓-idf-ua-in El≃ $ act= (↓-idf-ua-out El≃ x=) g)

  -- The GroupSet homomorphism.
  record GroupSetHom {grp : Group i} {j}
    (gset₁ gset₂ : GroupSet grp j) : Type (lmax i j) where
    constructor groupset-hom
    open GroupSet
    field
      f : El gset₁ → El gset₂
      pres-act : ∀ g x → f (act gset₁ x g) == act gset₂ (f x) g

  private
    groupset-hom=' : ∀ {grp : Group i} {j} {gset₁ gset₂ : GroupSet grp j}
      {gsh₁ gsh₂ : GroupSetHom gset₁ gset₂}
      → (f= : GroupSetHom.f gsh₁ == GroupSetHom.f gsh₂)
      → (GroupSetHom.pres-act gsh₁ == GroupSetHom.pres-act gsh₂
        [ (λ f → ∀ g x → f (GroupSet.act gset₁ x g) == GroupSet.act gset₂ (f x) g) ↓ f= ] )
      → gsh₁ == gsh₂
    groupset-hom=' idp idp = idp

  groupset-hom= : ∀ {grp : Group i} {j} {gset₁ gset₂ : GroupSet grp j}
    {gsh₁ gsh₂ : GroupSetHom gset₁ gset₂}
    → (∀ x → GroupSetHom.f gsh₁ x == GroupSetHom.f gsh₂ x)
    → gsh₁ == gsh₂
  groupset-hom= {gset₂ = gset₂} f= =
    groupset-hom='
      (λ= f=)
      (prop-has-all-paths-↓ $
        Π-level λ _ → Π-level λ _ → GroupSet.El-level gset₂ _ _)

  group-to-group-set : ∀ (grp : Group i) → GroupSet grp i
  group-to-group-set grp = record {
    El = G.El;
    El-level = G.El-level;
    grpset-struct = record {
      act = G.comp;
      unit-r = G.unit-r;
      assoc = G.assoc}}
    where module G = Group grp


------------------------------------------------------------------------
-- The one-step truncation HIT with an erased higher constructor
------------------------------------------------------------------------

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

-- The module is parametrised by a notion of equality. The higher
-- constructor of the HIT defining the one-step truncation operator
-- uses path equality, but the supplied notion of equality is used for
-- many other things.

import Equality.Path as P

module H-level.Truncation.Propositional.One-step.Erased
  {e⁺} (eq : ∀ {a p} → P.Equality-with-paths a p e⁺) where

open P.Derived-definitions-and-properties eq hiding (elim)

open import Logical-equivalence using (_⇔_)
open import Prelude

open import Bijection equality-with-J using (_↔_)
open import Equality.Decidable-UIP equality-with-J using (Constant)
import Equality.Decidable-UIP P.equality-with-J as PD
open import Equality.Path.Isomorphisms eq
open import Equivalence equality-with-J as Eq using (_≃_)
open import Equivalence.Erased.Cubical eq as EEq using (_≃ᴱ_)
open import Function-universe equality-with-J as F hiding (id; _∘_)
open import H-level.Closure equality-with-J
open import Surjection equality-with-J using (_↠_)

private
  variable
    a b p   : Level
    A B     : Type a
    P       : A → Type p
    e r x y : A
    n       : ℕ

------------------------------------------------------------------------
-- The type

-- One-step truncation.
--
-- This definition is based on that in van Doorn's "Constructing the
-- Propositional Truncation using Non-recursive HITs", but has an
-- erased higher constructor.

data ∥_∥¹ᴱ (A : Type a) : Type a where
  ∣_∣             : A → ∥ A ∥¹ᴱ
  @0 ∣∣-constantᴾ : PD.Constant (∣_∣ {A = A})

-- The function ∣_∣ is constant (in erased contexts).

@0 ∣∣-constant : Constant (∣_∣ {A = A})
∣∣-constant x y = _↔_.from ≡↔≡ (∣∣-constantᴾ x y)

------------------------------------------------------------------------
-- Eliminators

-- A dependent eliminator, expressed using paths.

record Elimᴾ {A : Type a} (P : ∥ A ∥¹ᴱ → Type p) : Type (a ⊔ p) where
  no-eta-equality
  field
    ∣∣ʳ             : ∀ x → P ∣ x ∣
    @0 ∣∣-constantʳ :
      (x y : A) →
      P.[ (λ i → P (∣∣-constantᴾ x y i)) ] ∣∣ʳ x ≡ ∣∣ʳ y

open Elimᴾ public

elimᴾ : Elimᴾ P → (x : ∥ A ∥¹ᴱ) → P x
elimᴾ {A = A} {P = P} e = helper
  where
  module E = Elimᴾ e

  helper : (x : ∥ A ∥¹ᴱ) → P x
  helper ∣ x ∣                = E.∣∣ʳ x
  helper (∣∣-constantᴾ x y i) = E.∣∣-constantʳ x y i

-- A non-dependent eliminator, expressed using paths.

record Recᴾ (A : Type a) (B : Type b) : Type (a ⊔ b) where
  no-eta-equality
  field
    ∣∣ʳ             : A → B
    @0 ∣∣-constantʳ : PD.Constant ∣∣ʳ

open Recᴾ public

recᴾ : Recᴾ A B → ∥ A ∥¹ᴱ → B
recᴾ r = elimᴾ λ where
    .∣∣ʳ          → R.∣∣ʳ
    .∣∣-constantʳ → R.∣∣-constantʳ
  where
  module R = Recᴾ r

-- A dependent eliminator.

record Elim {A : Type a} (P : ∥ A ∥¹ᴱ → Type p) : Type (a ⊔ p) where
  no-eta-equality
  field
    ∣∣ʳ             : ∀ x → P ∣ x ∣
    @0 ∣∣-constantʳ :
      (x y : A) → subst P (∣∣-constant x y) (∣∣ʳ x) ≡ ∣∣ʳ y

open Elim public

elim : Elim P → (x : ∥ A ∥¹ᴱ) → P x
elim e = elimᴾ λ where
    .∣∣ʳ              → E.∣∣ʳ
    .∣∣-constantʳ x y → subst≡→[]≡ (E.∣∣-constantʳ x y)
  where
  module E = Elim e

-- A "computation" rule.

@0 elim-∣∣-constant :
  dcong (elim e) (∣∣-constant x y) ≡ Elim.∣∣-constantʳ e x y
elim-∣∣-constant = dcong-subst≡→[]≡ (refl _)

-- A non-dependent eliminator.

record Rec (A : Type a) (B : Type b) : Type (a ⊔ b) where
  no-eta-equality
  field
    ∣∣ʳ             : A → B
    @0 ∣∣-constantʳ : Constant ∣∣ʳ

open Rec public

rec : Rec A B → ∥ A ∥¹ᴱ → B
rec r = recᴾ λ where
    .∣∣ʳ              → R.∣∣ʳ
    .∣∣-constantʳ x y → _↔_.to ≡↔≡ (R.∣∣-constantʳ x y)
  where
  module R = Rec r

-- A "computation" rule.

@0 rec-∣∣-constant :
  cong (rec r) (∣∣-constant x y) ≡ Rec.∣∣-constantʳ r x y
rec-∣∣-constant = cong-≡↔≡ (refl _)

-- A variant of rec.

rec′ : (f : A → B) → @0 Constant f → ∥ A ∥¹ᴱ → B
rec′ f c = rec λ where
  .Rec.∣∣ʳ          → f
  .Rec.∣∣-constantʳ → c

------------------------------------------------------------------------
-- Some preservation lemmas

-- A map function for ∥_∥¹ᴱ.

∥∥¹ᴱ-map : (A → B) → ∥ A ∥¹ᴱ → ∥ B ∥¹ᴱ
∥∥¹ᴱ-map f = rec λ where
  .∣∣ʳ x            → ∣ f x ∣
  .∣∣-constantʳ x y → ∣∣-constant (f x) (f y)

-- The truncation operator preserves logical equivalences.

∥∥¹ᴱ-cong-⇔ : A ⇔ B → ∥ A ∥¹ᴱ ⇔ ∥ B ∥¹ᴱ
∥∥¹ᴱ-cong-⇔ A⇔B = record
  { to   = ∥∥¹ᴱ-map (_⇔_.to   A⇔B)
  ; from = ∥∥¹ᴱ-map (_⇔_.from A⇔B)
  }

private

  -- A lemma used below.

  @0 ∥∥¹ᴱ-cong-lemma :
    (f : A → B) (g : B → A) (eq : ∀ x → f (g x) ≡ x) →
    subst (λ z → ∥∥¹ᴱ-map f (∥∥¹ᴱ-map g z) ≡ z)
      (∣∣-constant x y) (cong ∣_∣ (eq x)) ≡
    cong ∣_∣ (eq y)
  ∥∥¹ᴱ-cong-lemma {x = x} {y = y} f g eq =
    subst
      (λ z → ∥∥¹ᴱ-map f (∥∥¹ᴱ-map g z) ≡ z)
      (∣∣-constant x y) (cong ∣_∣ (eq x))                           ≡⟨ subst-in-terms-of-trans-and-cong ⟩

    trans (sym (cong (∥∥¹ᴱ-map f ∘ ∥∥¹ᴱ-map g) (∣∣-constant x y)))
      (trans (cong ∣_∣ (eq x)) (cong id (∣∣-constant x y)))         ≡⟨ cong₂ (λ p q → trans (sym p) (trans (cong ∣_∣ (eq x)) q))
                                                                         (trans (sym $ cong-∘ _ _ _) $
                                                                          trans (cong (cong (∥∥¹ᴱ-map f)) rec-∣∣-constant) $
                                                                          rec-∣∣-constant)
                                                                         (sym $ cong-id _) ⟩
    trans (sym (∣∣-constant (f (g x)) (f (g y))))
      (trans (cong ∣_∣ (eq x)) (∣∣-constant x y))                   ≡⟨ cong (λ f → trans _ (trans (cong ∣_∣ (f _)) _)) $ sym $
                                                                       _≃_.left-inverse-of (Eq.extensionality-isomorphism bad-ext) eq ⟩
    trans (sym (∣∣-constant (f (g x)) (f (g y))))
      (trans (cong ∣_∣ (ext⁻¹ (⟨ext⟩ eq) x)) (∣∣-constant x y))     ≡⟨ elim₁
                                                                         (λ {f} eq → trans (sym (∣∣-constant (f x) (f y)))
                                                                                (trans (cong ∣_∣ (ext⁻¹ eq x)) (∣∣-constant x y)) ≡
                                                                                cong ∣_∣ (ext⁻¹ eq y))
                                                                         (
      trans (sym (∣∣-constant x y))
        (trans (cong ∣_∣ (ext⁻¹ (refl id) x)) (∣∣-constant x y))          ≡⟨ cong (trans _) $
                                                                             trans (cong (flip trans _) $
                                                                                trans (cong (cong _) $ cong-refl _) $
                                                                                cong-refl _) $
                                                                             trans-reflˡ _ ⟩

      trans (sym (∣∣-constant x y)) (∣∣-constant x y)                     ≡⟨ trans-symˡ _ ⟩

      refl _                                                              ≡⟨ trans (sym $ cong-refl _) $
                                                                             cong (cong _) $ sym $ cong-refl _ ⟩∎
      cong ∣_∣ (ext⁻¹ (refl _) y)                                         ∎)
                                                                         _ ⟩

    cong ∣_∣ (ext⁻¹ (⟨ext⟩ eq) y)                                   ≡⟨ cong (λ f → cong ∣_∣ (f _)) $
                                                                       _≃_.left-inverse-of (Eq.extensionality-isomorphism bad-ext) eq ⟩∎
    cong ∣_∣ (eq y)                                                 ∎

-- The truncation operator preserves split surjections.

∥∥¹ᴱ-cong-↠ : A ↠ B → ∥ A ∥¹ᴱ ↠ ∥ B ∥¹ᴱ
∥∥¹ᴱ-cong-↠ A↠B = record
  { logical-equivalence = ∥∥¹ᴱ-cong-⇔ (_↠_.logical-equivalence A↠B)
  ; right-inverse-of    = elim λ where
      .∣∣ʳ x            → cong ∣_∣ (_↠_.right-inverse-of A↠B x)
      .∣∣-constantʳ x y →
        ∥∥¹ᴱ-cong-lemma (_↠_.to A↠B) (_↠_.from A↠B)
          (_↠_.right-inverse-of A↠B)
  }

-- The truncation operator preserves bijections.

∥∥¹ᴱ-cong-↔ : A ↔ B → ∥ A ∥¹ᴱ ↔ ∥ B ∥¹ᴱ
∥∥¹ᴱ-cong-↔ A↔B = record
  { surjection      = ∥∥¹ᴱ-cong-↠ (_↔_.surjection A↔B)
  ; left-inverse-of = elim λ where
      .∣∣ʳ x            → cong ∣_∣ (_↔_.left-inverse-of A↔B x)
      .∣∣-constantʳ x y →
        ∥∥¹ᴱ-cong-lemma (_↔_.from A↔B) (_↔_.to A↔B)
          (_↔_.left-inverse-of A↔B)
  }

-- The truncation operator preserves equivalences.

∥∥¹ᴱ-cong-≃ : A ≃ B → ∥ A ∥¹ᴱ ≃ ∥ B ∥¹ᴱ
∥∥¹ᴱ-cong-≃ = from-isomorphism ∘ ∥∥¹ᴱ-cong-↔ ∘ from-isomorphism

-- The truncation operator preserves equivalences with erased proofs.

∥∥¹ᴱ-cong-≃ᴱ : A ≃ᴱ B → ∥ A ∥¹ᴱ ≃ᴱ ∥ B ∥¹ᴱ
∥∥¹ᴱ-cong-≃ᴱ A≃B =
  EEq.[≃]→≃ᴱ (EEq.[proofs] (∥∥¹ᴱ-cong-≃ (EEq.≃ᴱ→≃ A≃B)))

------------------------------------------------------------------------
-- Iterated applications of the one-step truncation operator

-- Applies the one-step truncation the given number of times, from the
-- "outside".
--
-- This definition and the next one are taken from van Doorn's
-- "Constructing the Propositional Truncation using Non-recursive
-- HITs".

∥_∥¹ᴱ-out-^ : Type a → ℕ → Type a
∥ A ∥¹ᴱ-out-^ zero    = A
∥ A ∥¹ᴱ-out-^ (suc n) = ∥ ∥ A ∥¹ᴱ-out-^ n ∥¹ᴱ

-- A "constructor" for ∥_∥¹ᴱ-out-^.

∣_∣-out-^ : A → ∀ n → ∥ A ∥¹ᴱ-out-^ n
∣ x ∣-out-^ zero    = x
∣ x ∣-out-^ (suc n) = ∣ ∣ x ∣-out-^ n ∣

-- A rearrangement lemma.

∥∥¹ᴱ-out-^+≃ :
  ∀ m → ∥ A ∥¹ᴱ-out-^ (m + n) ≃ ∥ ∥ A ∥¹ᴱ-out-^ n ∥¹ᴱ-out-^ m
∥∥¹ᴱ-out-^+≃                 zero    = F.id
∥∥¹ᴱ-out-^+≃ {A = A} {n = n} (suc m) =
  ∥ ∥ A ∥¹ᴱ-out-^ (m + n) ∥¹ᴱ          ↝⟨ ∥∥¹ᴱ-cong-≃ (∥∥¹ᴱ-out-^+≃ m) ⟩□
  ∥ ∥ ∥ A ∥¹ᴱ-out-^ n ∥¹ᴱ-out-^ m ∥¹ᴱ  □

-- ∥_∥¹ᴱ commutes with ∥_∥¹ᴱ-out-^ n.

∥∥¹ᴱ-∥∥¹ᴱ-out-^-commute :
  ∀ n → ∥ ∥ A ∥¹ᴱ-out-^ n ∥¹ᴱ ↔ ∥ ∥ A ∥¹ᴱ ∥¹ᴱ-out-^ n
∥∥¹ᴱ-∥∥¹ᴱ-out-^-commute         zero    = F.id
∥∥¹ᴱ-∥∥¹ᴱ-out-^-commute {A = A} (suc n) =
  ∥ ∥ ∥ A ∥¹ᴱ-out-^ n ∥¹ᴱ ∥¹ᴱ  ↝⟨ ∥∥¹ᴱ-cong-↔ (∥∥¹ᴱ-∥∥¹ᴱ-out-^-commute n) ⟩□
  ∥ ∥ ∥ A ∥¹ᴱ ∥¹ᴱ-out-^ n ∥¹ᴱ  □

private

  -- The lemma above is defined using _↔_ rather than _≃_ because the
  -- following equalities hold by definition when _↔_ is used, but (at
  -- the time of writing) the second one does not hold when _≃_ is
  -- used.

  _ :
    {x : A} →
    _↔_.left-inverse-of (∥∥¹ᴱ-∥∥¹ᴱ-out-^-commute 0) ∣ x ∣ ≡ refl ∣ x ∣
  _ = refl _

  _ :
    {A : Type a} {x : ∥ A ∥¹ᴱ-out-^ (suc n)} →
    _↔_.left-inverse-of (∥∥¹ᴱ-∥∥¹ᴱ-out-^-commute (1 + n)) ∣ x ∣ ≡
    cong ∣_∣ (_↔_.left-inverse-of (∥∥¹ᴱ-∥∥¹ᴱ-out-^-commute n) x)
  _ = refl _

-- A variant of ∥_∥¹ᴱ-out-^ which applies the one-step truncation the
-- given number of times from the "inside".

∥_∥¹ᴱ-in-^ : Type a → ℕ → Type a
∥ A ∥¹ᴱ-in-^ zero    = A
∥ A ∥¹ᴱ-in-^ (suc n) = ∥ ∥ A ∥¹ᴱ ∥¹ᴱ-in-^ n

-- The two variants of ∥_∥¹ᴱ^ are pointwise equivalent.

∥∥¹ᴱ-out-^≃∥∥¹ᴱ-in-^ : ∀ n → ∥ A ∥¹ᴱ-out-^ n ≃ ∥ A ∥¹ᴱ-in-^ n
∥∥¹ᴱ-out-^≃∥∥¹ᴱ-in-^         zero    = F.id
∥∥¹ᴱ-out-^≃∥∥¹ᴱ-in-^ {A = A} (suc n) =
  ∥ ∥ A ∥¹ᴱ-out-^ n ∥¹ᴱ  ↔⟨ ∥∥¹ᴱ-∥∥¹ᴱ-out-^-commute n ⟩
  ∥ ∥ A ∥¹ᴱ ∥¹ᴱ-out-^ n  ↝⟨ ∥∥¹ᴱ-out-^≃∥∥¹ᴱ-in-^ n ⟩□
  ∥ ∥ A ∥¹ᴱ ∥¹ᴱ-in-^ n   □

-- ∥_∥¹ᴱ commutes with ∥_∥¹ᴱ-in-^ n.

∥∥¹ᴱ-∥∥¹ᴱ-in-^-commute : ∀ n → ∥ ∥ A ∥¹ᴱ-in-^ n ∥¹ᴱ ≃ ∥ ∥ A ∥¹ᴱ ∥¹ᴱ-in-^ n
∥∥¹ᴱ-∥∥¹ᴱ-in-^-commute {A = A} n =
  ∥ ∥ A ∥¹ᴱ-in-^ n ∥¹ᴱ   ↝⟨ ∥∥¹ᴱ-cong-≃ (inverse $ ∥∥¹ᴱ-out-^≃∥∥¹ᴱ-in-^ n) ⟩
  ∥ ∥ A ∥¹ᴱ-out-^ n ∥¹ᴱ  ↔⟨⟩
  ∥ A ∥¹ᴱ-out-^ (suc n)  ↝⟨ ∥∥¹ᴱ-out-^≃∥∥¹ᴱ-in-^ (suc n) ⟩
  ∥ A ∥¹ᴱ-in-^ (suc n)   ↔⟨⟩
  ∥ ∥ A ∥¹ᴱ ∥¹ᴱ-in-^ n   □

-- A "constructor" for ∥_∥¹ᴱ-in-^.

∣_,_∣-in-^ : ∀ n → ∥ A ∥¹ᴱ-in-^ n → ∥ A ∥¹ᴱ-in-^ (suc n)
∣ zero  , x ∣-in-^ = ∣ x ∣
∣ suc n , x ∣-in-^ = ∣ n , x ∣-in-^

-- ∣_,_∣-in-^ is related to ∣_∣.

∣∣≡∣,∣-in-^ :
  ∀ n {x : ∥ A ∥¹ᴱ-out-^ n} →
  _≃_.to (∥∥¹ᴱ-out-^≃∥∥¹ᴱ-in-^ (suc n)) ∣ x ∣ ≡
  ∣ n , _≃_.to (∥∥¹ᴱ-out-^≃∥∥¹ᴱ-in-^ n) x ∣-in-^
∣∣≡∣,∣-in-^ zero    {x = x} = ∣ x ∣  ∎
∣∣≡∣,∣-in-^ (suc n) {x = x} =
  _≃_.to (∥∥¹ᴱ-out-^≃∥∥¹ᴱ-in-^ (2 + n)) ∣ x ∣            ≡⟨⟩

  _≃_.to (∥∥¹ᴱ-out-^≃∥∥¹ᴱ-in-^ (1 + n))
    ∣ _↔_.to (∥∥¹ᴱ-∥∥¹ᴱ-out-^-commute n) x ∣             ≡⟨ ∣∣≡∣,∣-in-^ n ⟩∎

  ∣ n , _≃_.to (∥∥¹ᴱ-out-^≃∥∥¹ᴱ-in-^ n)
          (_↔_.to (∥∥¹ᴱ-∥∥¹ᴱ-out-^-commute n) x) ∣-in-^  ∎

-- A variant of ∣∣≡∣,∣-in-^.

∣,∣-in-^≡∣∣ :
  ∀ n {x : ∥ A ∥¹ᴱ-in-^ n} →
  _≃_.from (∥∥¹ᴱ-out-^≃∥∥¹ᴱ-in-^ (suc n)) ∣ n , x ∣-in-^ ≡
  ∣ _≃_.from (∥∥¹ᴱ-out-^≃∥∥¹ᴱ-in-^ n) x ∣
∣,∣-in-^≡∣∣ zero    {x = x} = ∣ x ∣  ∎
∣,∣-in-^≡∣∣ (suc n) {x = x} =
  _≃_.from (∥∥¹ᴱ-out-^≃∥∥¹ᴱ-in-^ (2 + n)) ∣ 1 + n , x ∣-in-^  ≡⟨⟩

  _↔_.from (∥∥¹ᴱ-∥∥¹ᴱ-out-^-commute (1 + n))
    (_≃_.from (∥∥¹ᴱ-out-^≃∥∥¹ᴱ-in-^ (1 + n)) ∣ n , x ∣-in-^)  ≡⟨ cong (_↔_.from (∥∥¹ᴱ-∥∥¹ᴱ-out-^-commute (1 + n))) $ ∣,∣-in-^≡∣∣ n ⟩∎

  _↔_.from (∥∥¹ᴱ-∥∥¹ᴱ-out-^-commute (1 + n))
    ∣ _≃_.from (∥∥¹ᴱ-out-^≃∥∥¹ᴱ-in-^ n) x ∣                   ∎


{-# OPTIONS --cubical #-}

open import 17-number-theory
open import Cubical.Core.Everything

data circle-C : UU lzero where
  base : circle-C
  loop : Path circle-C base base


------------------------------------------------------------------------
-- Some properties that hold for Erased do not hold for every
-- topological modality
------------------------------------------------------------------------

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

open import Equality

module Erased.Counterexamples
  {e⁺} (eq : ∀ {a p} → Equality-with-J a p e⁺) where

open Derived-definitions-and-properties eq

open import Prelude

open import Bijection eq using (_↔_)
open import Equality.Decision-procedures eq
open import Equivalence.Path-split eq
open import Function-universe eq hiding (_∘_)
open import Erased.Stability eq
open import H-level eq
open import H-level.Closure eq

private
  variable
    a b ℓ ℓ′ p : Level
    A          : Type a

-- The zero modality.
--
-- This modality is taken from "Modalities in Homotopy Type Theory" by
-- Rijke, Shulman and Spitters.

Zero : Type ℓ → Type ℓ
Zero _ = ↑ _ ⊤

-- A type A is Zero-stable if Zero A implies A.

Zero-stable : Type ℓ → Type ℓ
Zero-stable A = Zero A → A

-- A type is Zero-modal if it is contractible.
--
-- This definition is based on "Modalities in Homotopy Type Theory" by
-- Rijke, Shulman and Spitters.

Zero-modal : Type ℓ → Type ℓ
Zero-modal = Contractible

-- Zero-modal types are Zero-stable.

Zero-modal→Zero-stable : Zero-modal A → Zero-stable A
Zero-modal→Zero-stable m _ = proj₁ m

-- A type A has Zero-stable equality if x ≡ y is Zero-stable for all
-- values x and y of type A.

Zero-stable-≡ : Type a → Type a
Zero-stable-≡ = For-iterated-equality 1 Zero-stable

-- A type A has Zero-modal equality if x ≡ y is Zero-modal for all
-- values x and y of type A.

Zero-modal-≡ : Type a → Type a
Zero-modal-≡ = For-iterated-equality 1 Zero-modal

-- The zero modality is a Σ-closed reflective subuniverse.
--
-- This proof is based on "Modalities in Homotopy Type Theory" by
-- Rijke, Shulman and Spitters.

Zero-modality : Σ-closed-reflective-subuniverse ℓ
Zero-modality {ℓ = ℓ} = λ where
    .◯                      → Zero
    .η                      → return
    .Is-modal               → Zero-modal
    .Is-modal-propositional → λ ext → H-level-propositional ext 0
    .Is-modal-◯             → ↑-closure 0 ⊤-contractible
    .Is-modal-respects-≃    → H-level-cong _ 0
    .extendable-along-η     → extendable
    .Σ-closed               → Σ-closure 0
  where
  open Σ-closed-reflective-subuniverse

  return : A → Zero A
  return = _

  extendable :
    {A B : Type ℓ} →
    Zero-modal B →
    Is-∞-extendable-along-[ return {A = A} ] (λ (_ : Zero A) → B)
  extendable cB zero    = _
  extendable cB (suc n) =
      (λ g → (λ _ → proj₁ cB) , (λ x → proj₂ cB (g x)))
    , (λ _ _ → extendable (⇒≡ 0 cB) n)

-- The zero modality is topological (for all universe levels).
--
-- This result is based on "Modalities in Homotopy Type Theory" by
-- Rijke, Shulman and Spitters.

Zero-topological : Topological ℓ′ (Zero-modality {ℓ = ℓ})
Zero-topological {ℓ′ = ℓ′} {ℓ = ℓ} =
    ↑ ℓ′ ⊤
  , (λ _ → ⊥)
  , (λ _ → ⊥-propositional)
  , (λ _ → record { to = to; from = from })
  where
  open Σ-closed-reflective-subuniverse Zero-modality

  to :
    Zero-modal A →
    ↑ ℓ′ ⊤ → Is-∞-extendable-along-[ η ] (λ _ → A)
  to cA _ zero    = _
  to cA _ (suc n) =
      (λ _ → (λ _ → proj₁ cA) , (λ ()))
    , (λ _ _ → to (⇒≡ 0 cA) _ n)

  from :
    (↑ ℓ′ ⊤ → Is-∞-extendable-along-[ η ] (λ _ → A)) →
    Zero-modal A
  from {A = A} ext =
      inh
    , (λ x →
         ext _ 2 .proj₂ (const inh) (const x) .proj₁ ⊥-elim .proj₁ _)
    where
    inh : A
    inh = ext _ 1 .proj₁ ⊥-elim .proj₁ _

-- It is not the case that Zero ⊥ is isomorphic to ⊥.
--
-- Compare with Erased.Level-1.Erased-⊥↔⊥.

¬[Zero-⊥↔⊥] : ¬ (Zero (⊥ {ℓ = ℓ}) ↔ ⊥ {ℓ = ℓ})
¬[Zero-⊥↔⊥] hyp =
         $⟨ _ ⟩
  ↑ _ ⊤  ↝⟨ hyp ⟩
  ⊥      ↝⟨ ⊥↔⊥ ⟩□
  ⊥₀     □

-- It is not the case that Zero A implies ¬ ¬ A for all types A.
--
-- Compare with Erased.Stability.Erased→¬¬.

¬[Zero→¬¬] : ¬ ({A : Type a} → Zero A → ¬ ¬ A)
¬[Zero→¬¬] hyp =
          $⟨ _ ⟩
  Zero ⊥  ↝⟨ hyp ⟩
  ¬ ¬ ⊥   ↝⟨ ⊥-elim ∘ (_$ ⊥-elim) ⟩□
  ⊥       □

-- It is not the case that, for all types A, if A is stable for
-- double-negation, then A is Zero-stable.
--
-- Compare with Erased.Stability.¬¬-stable→Stable.

¬[¬¬-stable→Zero-stable] :
  ¬ ({A : Type a} → (¬ ¬ A → A) → Zero-stable A)
¬[¬¬-stable→Zero-stable] hyp =
                $⟨ ⊥-elim ∘ (_$ ⊥-elim) ⟩
  (¬ ¬ ⊥ → ⊥)   ↝⟨ hyp ⟩
  (Zero ⊥ → ⊥)  ↝⟨ _$ _ ⟩
  ⊥             ↔⟨ ⊥↔⊥ ⟩□
  ⊥₀            □

-- It is not the case that, for all types A, if A is decided, then A
-- is Zero-stable.
--
-- Compare with Erased.Stability.Dec→Stable.

¬[Dec→Zero-stable] : ¬ ({A : Type a} → Dec A → Zero-stable A)
¬[Dec→Zero-stable] hyp =
                $⟨ inj₂ ⊥-elim ⟩
  Dec ⊥         ↝⟨ hyp ⟩
  (Zero ⊥ → ⊥)  ↝⟨ _$ _ ⟩
  ⊥             ↔⟨ ⊥↔⊥ ⟩□
  ⊥₀            □

-- It is not the case that, for all types A, if equality is decidable
-- for A, then equality for A is Zero-stable.

¬[Decidable-equality→Zero-stable-≡] :
  ¬ ({A : Type a} → Decidable-equality A → Zero-stable-≡ A)
¬[Decidable-equality→Zero-stable-≡] {a = a} hyp =
                                                            $⟨ ↑.Dec._≟_ Bool._≟_ ⟩
  Decidable-equality (↑ a Bool)                             ↝⟨ (λ dec → hyp dec _ _) ⟩
  (Zero (lift true ≡ lift false) → lift true ≡ lift false)  ↝⟨ _$ _ ⟩
  lift true ≡ lift false                                    ↝⟨ Bool.true≢false ∘ cong lower ⟩□
  ⊥₀                                                        □

-- It is not the case that, for all types A, if equality is decidable
-- for A, then equality for A is Zero-modal.
--
-- Compare with
-- Erased.Stability.[]-cong₁.Decidable-equality→Very-stable-≡.

¬[Decidable-equality→Zero-modal-≡] :
  ¬ ({A : Type a} → Decidable-equality A → Zero-modal-≡ A)
¬[Decidable-equality→Zero-modal-≡] {a = a} =
  ({A : Type a} →
   Decidable-equality A → Zero-modal-≡ A)   ↝⟨ (implicit-∀-cong _ $ ∀-cong _ λ _ → ∀-cong _ λ _ → ∀-cong _ λ _ →
                                                Zero-modal→Zero-stable) ⟩
  ({A : Type a} →
   Decidable-equality A → Zero-stable-≡ A)  ↝⟨ ¬[Decidable-equality→Zero-stable-≡] ⟩□

  ⊥                                         □

-- It is not the case that the empty types are Zero-modal.
--
-- Compare with Erased.Stability.Very-stable-⊥.

¬[Zero-modal-⊥] : ¬ Zero-modal (⊥ {ℓ = ℓ})
¬[Zero-modal-⊥] =
  Contractible ⊥  ↝⟨ proj₁ ⟩
  ⊥               ↔⟨ ⊥↔⊥ ⟩□
  ⊥₀              □

-- It is not the case that, for any type A and type family P over A,
-- if A is Zero-modal, then W A P is Zero-modal.
--
-- Compare with Erased.Stability.[]-cong₂-⊔₁.Very-stable-W, which is
-- proved under the assumption of function extensionality.

¬[Zero-modal-W] :
  ¬ ({A : Type a} {P : A → Type p} → Zero-modal A → Zero-modal (W A P))
¬[Zero-modal-W] hyp =                   $⟨ ↑-closure 0 ⊤-contractible ⟩
  Zero-modal (↑ _ ⊤)                    ↝⟨ hyp ⟩
  Zero-modal (W (↑ _ ⊤) (λ _ → ↑ _ ⊤))  ↝⟨ proj₁ ⟩
  W (↑ _ ⊤) (λ _ → ↑ _ ⊤)               ↝⟨ inhabited⇒W-empty _ ⟩□
  ⊥                                     □

-- It is not the case that, for all types A and B, if equality is
-- Zero-stable for A and B, then equality is Zero-stable for A ⊎ B.
--
-- Compare with Erased.Stability.Stable-≡-⊎.

¬[Zero-stable-≡-⊎] :
  ¬ ({A : Type a} {B : Type b} →
     Zero-stable-≡ A →
     Zero-stable-≡ B →
     Zero-stable-≡ (A ⊎ B))
¬[Zero-stable-≡-⊎] hyp =                         $⟨ (λ _ _ _ → refl _)
                                                  , (λ _ _ _ → refl _)
                                                  ⟩
  Zero-stable-≡ (↑ _ ⊤) × Zero-stable-≡ (↑ _ ⊤)  ↝⟨ uncurry hyp ⟩
  Zero-stable-≡ (↑ _ ⊤ ⊎ ↑ _ ⊤)                  ↝⟨ (_$ _) ∘ (_$ _) ∘ (_$ _) ⟩
  inj₁ _ ≡ inj₂ _                                ↝⟨ ⊎.inj₁≢inj₂ ⟩□
  ⊥                                              □

-- It is not the case that, for all types A and B, if equality is
-- Zero-modal for A and B, then equality is Zero-modal for A ⊎ B.
--
-- Compare with Erased.Stability.[]-cong₂-⊔₂.Very-stable-≡-⊎.

¬[Zero-modal-≡-⊎] :
  ¬ ({A : Type a} {B : Type b} →
     Zero-modal-≡ A →
     Zero-modal-≡ B →
     Zero-modal-≡ (A ⊎ B))
¬[Zero-modal-≡-⊎] hyp =                        $⟨ (λ _ _ → +⇒≡ (mono₁ 0 (↑-closure 0 ⊤-contractible)))
                                                , (λ _ _ → +⇒≡ (mono₁ 0 (↑-closure 0 ⊤-contractible)))
                                                ⟩
  Zero-modal-≡ (↑ _ ⊤) × Zero-modal-≡ (↑ _ ⊤)  ↝⟨ uncurry hyp ⟩
  Zero-modal-≡ (↑ _ ⊤ ⊎ ↑ _ ⊤)                 ↝⟨ proj₁ ∘ (_$ _) ∘ (_$ _) ⟩
  inj₁ _ ≡ inj₂ _                              ↝⟨ ⊎.inj₁≢inj₂ ⟩□
  ⊥                                            □

-- It is not the case that, for all types A, if equality is
-- Zero-stable for A, then equality is Zero-stable for List A.
--
-- Compare with Erased.Stability.Stable-≡-List.

¬[Zero-stable-≡-List] :
  ¬ ({A : Type a} → Zero-stable-≡ A → Zero-stable-≡ (List A))
¬[Zero-stable-≡-List] hyp =     $⟨ (λ _ _ _ → refl _) ⟩
  Zero-stable-≡ (↑ _ ⊤)         ↝⟨ hyp ⟩
  Zero-stable-≡ (List (↑ _ ⊤))  ↝⟨ (_$ _) ∘ (_$ _) ∘ (_$ _) ⟩
  [] ≡ _ ∷ []                   ↝⟨ List.[]≢∷ ⟩□
  ⊥                             □

-- It is not the case that, for all types A, if equality is Zero-modal
-- for A, then equality is Zero-modal for List A.
--
-- Compare with Erased.Stability.[]-cong₁.Very-stable-≡-List.

¬[Zero-modal-≡-List] :
  ¬ ({A : Type a} → Zero-modal-≡ A → Zero-modal-≡ (List A))
¬[Zero-modal-≡-List] hyp =     $⟨ (λ _ _ → +⇒≡ (mono₁ 0 (↑-closure 0 ⊤-contractible))) ⟩
  Zero-modal-≡ (↑ _ ⊤)         ↝⟨ hyp ⟩
  Zero-modal-≡ (List (↑ _ ⊤))  ↝⟨ proj₁ ∘ (_$ _) ∘ (_$ _) ⟩
  [] ≡ _ ∷ []                  ↝⟨ List.[]≢∷ ⟩□
  ⊥                            □


------------------------------------------------------------------------
-- The Agda standard library
--
-- Lists with fast append
------------------------------------------------------------------------

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

module Data.DifferenceList where

open import Level using (Level)
open import Data.List.Base as List using (List)
open import Function
open import Data.Nat.Base

private
  variable
    a b : Level
    A : Set a
    B : Set b

------------------------------------------------------------------------
-- Type definition and list function lifting

DiffList : Set a → Set a
DiffList A = List A → List A

lift : (List A → List A) → (DiffList A → DiffList A)
lift f xs = λ k → f (xs k)

------------------------------------------------------------------------
-- Building difference lists

infixr 5 _∷_ _++_

[] : DiffList A
[] = λ k → k

_∷_ : A → DiffList A → DiffList A
_∷_ x = lift (x List.∷_)

[_] : A → DiffList A
[ x ] = x ∷ []

_++_ : DiffList A → DiffList A → DiffList A
xs ++ ys = λ k → xs (ys k)

infixl 6 _∷ʳ_
_∷ʳ_ : DiffList A → A → DiffList A
xs ∷ʳ x = λ k → xs (x List.∷ k)

------------------------------------------------------------------------
-- Conversion back and forth with List

toList : DiffList A → List A
toList xs = xs List.[]

-- fromList xs is linear in the length of xs.

fromList : List A → DiffList A
fromList xs = λ k → xs ⟨ List._++_ ⟩ k

------------------------------------------------------------------------
-- Transforming difference lists

-- It is OK to use List._++_ here, since map is linear in the length of
-- the list anyway.

map : (A → B) → DiffList A → DiffList B
map f xs = λ k → List.map f (toList xs) ⟨ List._++_ ⟩ k

-- concat is linear in the length of the outer list.

concat : DiffList (DiffList A) → DiffList A
concat xs = concat' (toList xs)
  where
  concat' : List (DiffList A) → DiffList A
  concat' = List.foldr _++_ []

take : ℕ → DiffList A → DiffList A
take n = lift (List.take n)

drop : ℕ → DiffList A → DiffList A
drop n = lift (List.drop n)