-- Andreas, 2012-02-25 reported by edgmnt on behalf of xplat.
module Issue574 where

open import Common.Level

wah : ∀ o a → Set (lsuc lzero ⊔ (lsuc a ⊔ o)) → Set ((lsuc lzero ⊔ lsuc a) ⊔ o)
wah o a x = x -- should succeed

-- Error message was:
-- Set (suc zero ⊔ (suc a ⊔ o)) != Set (suc a ⊔ o)
-- when checking that the expression x has type Set (suc a ⊔ o)


{- 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 LibraBFT.Prelude
open import LibraBFT.Base.ByteString

module LibraBFT.Base.Encode where

 -- An encoder for values of type A is
 -- an injective mapping of 'A's into 'ByteString's
 record Encoder {a}(A : Set a) : Set a where
   constructor mkEncoder
   field
     encode     : A → ByteString
     encode-inj : ∀{a₁ a₂} → encode a₁ ≡ encode a₂ → a₁ ≡ a₂
 open Encoder {{...}} public

 ≡-Encoder : ∀ {a} {A : Set a} → Encoder A → DecidableEquality A
 ≡-Encoder (mkEncoder enc enc-inj) x y
    with enc x ≟ByteString enc y
 ...| yes enc≡ = yes (enc-inj enc≡)
 ...| no  neq  = no  (⊥-elim ∘ neq ∘ cong enc)

 postulate  -- valid assumption
  instance
    encℕ   : Encoder ℕ
    encBS  : Encoder ByteString

 instance
   encFin : {n : ℕ} → Encoder (Fin n)
   encFin {n} = record { encode     = encode ⦃ encℕ ⦄ ∘ toℕ ;
                         encode-inj = toℕ-injective ∘ encode-inj ⦃ encℕ ⦄ }


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

open import lib.Basics
open import lib.types.Bool
open import lib.types.Coproduct
open import lib.types.Paths
open import lib.types.Span
open import lib.types.Pushout
open import lib.types.Cofiber
open import lib.types.Sigma
open import lib.types.Wedge

module lib.types.Smash {i j} where

module _ (X : Ptd i) (Y : Ptd j) where

  ⊙∧-span : ⊙Span
  ⊙∧-span = ⊙span (X ⊙× Y) ⊙Bool (X ⊙⊔ Y)
    (⊔-rec (_, pt Y) (pt X ,_) , idp)
    (⊙⊔-fmap {Y = Y} ⊙cst ⊙cst)

  ∧-span : Span
  ∧-span = ⊙Span-to-Span ⊙∧-span

  _∧_ = Pushout ∧-span
  _⊙∧_ = ⊙Pushout ⊙∧-span
  Smash = _∧_
  ⊙Smash = _⊙∧_

module _ {X : Ptd i} {Y : Ptd j} where

  smin : de⊙ X → de⊙ Y → Smash X Y
  smin x y = left (x , y)

  smbasel : Smash X Y
  smbasel = right true

  smbaser : Smash X Y
  smbaser = right false

  smgluel : (x : de⊙ X) → smin x (pt Y) == smbasel
  smgluel x = glue (inl x)

  smgluer : (y : de⊙ Y) → smin (pt X) y == smbaser
  smgluer y = glue (inr y)

  module SmashElim {k} {P : Smash X Y → Type k}
    (smin* : (x : de⊙ X) (y : de⊙ Y) → P (smin x y))
    (smbasel* : P smbasel) (smbaser* : P smbaser)
    (smgluel* : (x : de⊙ X) → smin* x (pt Y) == smbasel* [ P ↓ smgluel x ])
    (smgluer* : (y : de⊙ Y) → smin* (pt X) y == smbaser* [ P ↓ smgluer y ]) where

    private
      module M = PushoutElim
        (uncurry smin*)
        (Coprod-elim (λ _ → smbasel*) (λ _ → smbaser*))
        (Coprod-elim smgluel* smgluer*)
    f = M.f
    smgluel-β = M.glue-β ∘ inl
    smgluer-β = M.glue-β ∘ inr

  Smash-elim = SmashElim.f

  module SmashRec {k} {C : Type k}
    (smin* : (x : de⊙ X) (y : de⊙ Y) → C)
    (smbasel* smbaser* : C)
    (smgluel* : (x : de⊙ X) → smin* x (pt Y) == smbasel*)
    (smgluer* : (y : de⊙ Y) → smin* (pt X) y == smbaser*) where

    private
      module M = PushoutRec {d = ∧-span X Y}
        (uncurry smin*)
        (Coprod-rec (λ _ → smbasel*) (λ _ → smbaser*))
        (Coprod-elim smgluel* smgluer*)
    f = M.f
    smgluel-β = M.glue-β ∘ inl
    smgluer-β = M.glue-β ∘ inr

  Smash-rec = SmashRec.f


------------------------------------------------------------------------
-- The Agda standard library
--
-- Pointwise equality over lists parameterised by a setoid
------------------------------------------------------------------------

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

open import Relation.Binary using (Setoid)

module Data.List.Relation.Binary.Equality.Setoid {a ℓ} (S : Setoid a ℓ) where

open import Data.Fin.Base
open import Data.List.Base
open import Data.List.Relation.Binary.Pointwise as PW using (Pointwise)
open import Data.List.Relation.Unary.Unique.Setoid S using (Unique)
open import Function using (_∘_)
open import Level
open import Relation.Binary renaming (Rel to Rel₂)
open import Relation.Binary.PropositionalEquality as P using (_≡_)
open import Relation.Binary.Properties.Setoid S using (≉-resp₂)
open import Relation.Unary as U using (Pred)

open Setoid S renaming (Carrier to A)

private
  variable
    p q : Level

------------------------------------------------------------------------
-- Definition of equality
------------------------------------------------------------------------

infix 4 _≋_

_≋_ : Rel₂ (List A) (a ⊔ ℓ)
_≋_ = Pointwise _≈_

open PW public
  using ([]; _∷_)

------------------------------------------------------------------------
-- Relational properties
------------------------------------------------------------------------

≋-refl : Reflexive _≋_
≋-refl = PW.refl refl

≋-reflexive : _≡_ ⇒ _≋_
≋-reflexive P.refl = ≋-refl

≋-sym : Symmetric _≋_
≋-sym = PW.symmetric sym

≋-trans : Transitive _≋_
≋-trans = PW.transitive trans

≋-isEquivalence : IsEquivalence _≋_
≋-isEquivalence = PW.isEquivalence isEquivalence

≋-setoid : Setoid _ _
≋-setoid = PW.setoid S

------------------------------------------------------------------------
-- Relationships to predicates
------------------------------------------------------------------------

open PW public
  using () renaming
  ( Any-resp-Pointwise      to Any-resp-≋
  ; All-resp-Pointwise      to All-resp-≋
  ; AllPairs-resp-Pointwise to AllPairs-resp-≋
  )

Unique-resp-≋ : Unique Respects _≋_
Unique-resp-≋ = AllPairs-resp-≋ ≉-resp₂

------------------------------------------------------------------------
-- List operations
------------------------------------------------------------------------

------------------------------------------------------------------------
-- length

≋-length : ∀ {xs ys} → xs ≋ ys → length xs ≡ length ys
≋-length = PW.Pointwise-length

------------------------------------------------------------------------
-- map

module _ {b ℓ₂} (T : Setoid b ℓ₂) where

  open Setoid T using () renaming (_≈_ to _≈′_)
  private
    _≋′_ = Pointwise _≈′_

  map⁺ : ∀ {f} → f Preserves _≈_ ⟶ _≈′_ →
         ∀ {xs ys} → xs ≋ ys → map f xs ≋′ map f ys
  map⁺ {f} pres xs≋ys = PW.map⁺ f f (PW.map pres xs≋ys)

------------------------------------------------------------------------
-- _++_

++⁺ : ∀ {ws xs ys zs} → ws ≋ xs → ys ≋ zs → ws ++ ys ≋ xs ++ zs
++⁺ = PW.++⁺

++-cancelˡ : ∀ xs {ys zs} → xs ++ ys ≋ xs ++ zs → ys ≋ zs
++-cancelˡ = PW.++-cancelˡ

++-cancelʳ : ∀ {xs} ys zs → ys ++ xs ≋ zs ++ xs → ys ≋ zs
++-cancelʳ = PW.++-cancelʳ

------------------------------------------------------------------------
-- concat

concat⁺ : ∀ {xss yss} → Pointwise _≋_ xss yss → concat xss ≋ concat yss
concat⁺ = PW.concat⁺

------------------------------------------------------------------------
-- tabulate

tabulate⁺ : ∀ {n} {f : Fin n → A} {g : Fin n → A} →
            (∀ i → f i ≈ g i) → tabulate f ≋ tabulate g
tabulate⁺ = PW.tabulate⁺

tabulate⁻ : ∀ {n} {f : Fin n → A} {g : Fin n → A} →
            tabulate f ≋ tabulate g → (∀ i → f i ≈ g i)
tabulate⁻ = PW.tabulate⁻

------------------------------------------------------------------------
-- filter

module _ {P : Pred A p} (P? : U.Decidable P) (resp : P Respects _≈_)
  where

  filter⁺ : ∀ {xs ys} → xs ≋ ys → filter P? xs ≋ filter P? ys
  filter⁺ xs≋ys = PW.filter⁺ P? P? resp (resp ∘ sym) xs≋ys

------------------------------------------------------------------------
-- reverse

ʳ++⁺ : ∀{xs xs′ ys ys′} → xs ≋ xs′ → ys ≋ ys′ → xs ʳ++ ys ≋ xs′ ʳ++ ys′
ʳ++⁺ = PW.ʳ++⁺

reverse⁺ : ∀ {xs ys} → xs ≋ ys → reverse xs ≋ reverse ys
reverse⁺ = PW.reverse⁺


{-# OPTIONS --without-K --safe #-}
module Categories.Category.Instance.FamilyOfSetoids where

-- The Category of "Families of Setoids"
-- This fits into this library much better than the Families of Sets

-- This particular formalization should be considered alpha, i.e. its
-- names will change once things settle.

open import Level
open import Relation.Binary
  using (Rel; Setoid; module Setoid; Reflexive; Symmetric; Transitive)
open import Function.Base renaming (id to idf; _∘_ to _⊚_)
open import Function.Equality
open import Function.Inverse using (_InverseOf_)
import Relation.Binary.Reasoning.Setoid as SetoidR

open import Categories.Category

module _ {a b c d : Level} where
  record Fam : Set (suc (a ⊔ b ⊔ c ⊔ d)) where
    constructor fam
    open Setoid using () renaming (Carrier to ∣_∣; _≈_ to _≈≈_)
    field
      U : Setoid a b
    open Setoid U hiding (Carrier)
    field
      T : ∣ U ∣ → Setoid c d
      reindex : {x y : ∣ U ∣} (P : x ≈ y) → T y ⟶ T x

      -- the following coherence laws are needed to make _≃_ below an equivalence
      reindex-refl : {x : ∣ U ∣} {bx : ∣ T x ∣} → _≈≈_ (T x) (reindex refl ⟨$⟩ bx) bx
      reindex-sym : {x y : ∣ U ∣} → (p : x ≈ y) → (reindex (sym p)) InverseOf (reindex p)
      reindex-trans : {x y z : ∣ U ∣} {b : ∣ T z ∣} → (p : x ≈ y) → (q : y ≈ z) →
        Setoid._≈_ (T x) (reindex (trans p q) ⟨$⟩ b)
                         (reindex p ∘ reindex q ⟨$⟩ b)
  open Fam

  record Hom (B B′ : Fam) : Set (a ⊔ b ⊔ c ⊔ d) where
    constructor fhom
    open Setoid (U B) using (_≈_)
    field
      map : U B ⟶ U B′
      transport : (x : Setoid.Carrier (U B)) → T B x ⟶ T B′ (map ⟨$⟩ x)
      transport-coh : {x y : Setoid.Carrier (U B)} → (p : x ≈ y) →
        Setoid._≈_ (T B y ⇨ T B′ (map ⟨$⟩ x))
          (transport x ∘ reindex B p)
          (reindex B′ (Π.cong map p) ∘ transport y)

  record _≈≈_ {X Y} (F F′ : (Hom X Y)) : Set (a ⊔ b ⊔ c ⊔ d) where
    constructor feq
    open Hom
    open Setoid (U X) renaming (Carrier to A) hiding (refl; _≈_)
    open Setoid (U Y)
    -- the order below is chosen to simplify some of the later reasoning
    field
      g≈f : {x : A} → map F ⟨$⟩ x ≈ map F′ ⟨$⟩ x
      φ≈γ : {x : A} → let C = T X x
                          D = T Y (map F ⟨$⟩ x) in
            {bx : Setoid.Carrier C} → Setoid._≈_ D ((reindex Y g≈f ∘ transport F′ x) ⟨$⟩ bx) (transport F x ⟨$⟩ bx)

  fam-id : {A : Fam} → Hom A A
  fam-id {A} = fhom id (λ _ → id) λ p x≈y → Π.cong (reindex A p) x≈y
  comp : {A B C : Fam} → Hom B C → Hom A B → Hom A C
  comp {B = B} {C} (fhom map₀ trans₀ coh₀) (fhom map₁ trans₁ coh₁) =
    fhom (map₀ ∘ map₁) (λ x → trans₀ (map₁ ⟨$⟩ x) ∘ (trans₁ x))
         λ {a} {b} p {x} {y} x≈y →
           let open Setoid (T C (map₀ ∘ map₁ ⟨$⟩ a)) renaming (trans to _⟨≈⟩_) in
           Π.cong (trans₀ (map₁ ⟨$⟩ a)) (coh₁ p x≈y) ⟨≈⟩
           coh₀ (Π.cong map₁ p) (Setoid.refl (T B (map₁ ⟨$⟩ b)))

  ≈≈-refl : ∀ {A B} → Reflexive (_≈≈_ {A} {B})
  ≈≈-refl {B = B} = feq refl (reindex-refl B)
    where open Setoid (U B)

  ≈≈-sym : ∀ {A B} → Symmetric (_≈≈_ {A} {B})
  ≈≈-sym {A} {B} {F} {G} (feq g≈f φ≈γ) = feq (sym g≈f)
    λ {x} {bx} → Setoid.trans ( T B (map G ⟨$⟩ x) )
      (Π.cong (reindex B (sym g≈f)) (Setoid.sym (T B (map F ⟨$⟩ x)) φ≈γ))
      (left-inverse-of (reindex-sym B g≈f) (transport G x ⟨$⟩ bx))
    where
    open Setoid (U B) using (sym; Carrier)
    open Hom
    open _InverseOf_

  ≈≈-trans : ∀ {A B} → Transitive (_≈≈_ {A} {B})
  ≈≈-trans {A} {B} {F} {G} {H}  (feq ≈₁ t₁) (feq ≈₂ t₂) =
    feq (trans ≈₁ ≈₂) (λ {x} {bx} →
      let open Setoid (T B (Hom.map F ⟨$⟩ x)) renaming (trans to _⟨≈⟩_) in
      reindex-trans B ≈₁ ≈₂ ⟨≈⟩ (Π.cong (reindex B ≈₁) t₂ ⟨≈⟩ t₁))
    where
    open Setoid (U B) using (trans)

  comp-resp-≈≈ : {A B C : Fam} {f h : Hom B C} {g i : Hom A B} →
      f ≈≈ h → g ≈≈ i → comp f g ≈≈ comp h i
  comp-resp-≈≈ {A} {B} {C} {f} {h} {g} {i} (feq f≈h t-f≈h) (feq g≈i t-g≈i) =
    feq (trans (Π.cong (map f) g≈i) f≈h)
        λ {x} → let open Setoid (T C (map (comp f g) ⟨$⟩ x)) renaming (trans to _⟨≈⟩_; sym to ≈sym) in
        reindex-trans C (cong (map f) g≈i) f≈h ⟨≈⟩
        (Π.cong (reindex C (cong (map f) g≈i)) t-f≈h ⟨≈⟩
        (≈sym (transport-coh {B} {C} f g≈i (Setoid.refl (T B (map i ⟨$⟩ x)))) ⟨≈⟩
        Π.cong (transport f (map g ⟨$⟩ x)) t-g≈i))
    where
    open _≈≈_
    open Setoid (U C)
    open Hom

  Cat : Category (suc (a ⊔ b ⊔ c ⊔ d)) (a ⊔ b ⊔ c ⊔ d) (a ⊔ b ⊔ c ⊔ d)
  Cat = record
    { Obj = Fam
    ; _⇒_ = Hom
    ; _≈_ = _≈≈_
    ; id = fam-id
    ; _∘_ = comp
    ; assoc     = λ {_} {_} {_} {_} {f} {g} {h} → assoc′ {f = f} {g} {h}
    ; sym-assoc = λ {_} {_} {_} {_} {f} {g} {h} → ≈≈-sym (assoc′ {f = f} {g} {h})
    ; identityˡ = λ {_} {B} → feq (Setoid.refl (U B)) (reindex-refl B)
    ; identityʳ = λ {_} {B} → feq (Setoid.refl (U B)) (reindex-refl B)
    ; identity² = λ {A} → feq (Setoid.refl (U A)) (reindex-refl A)
    ; equiv = λ {A} {B} → let open Setoid (U B) in record
      { refl = ≈≈-refl
      ; sym = ≈≈-sym
      ; trans = ≈≈-trans
      }
    ; ∘-resp-≈ = comp-resp-≈≈
    }
    where
    open _InverseOf_
    assoc′ : {A B C D : Fam} {f : Hom A B} {g : Hom B C} {h : Hom C D} →
      comp (comp h g) f ≈≈ comp h (comp g f)
    assoc′ {D = D} = feq (Setoid.refl (U D)) (reindex-refl D)

  open Category Cat public

FamilyOfSetoids : ∀ a b c d → Category (suc (a ⊔ b ⊔ c ⊔ d)) (a ⊔ b ⊔ c ⊔ d) (a ⊔ b ⊔ c ⊔ d)
FamilyOfSetoids a b c d = Cat {a} {b} {c} {d}


{-# OPTIONS --universe-polymorphism #-}
module Categories.Adjunction.Composition where

open import Level

open import Categories.Category
open import Categories.Functor hiding (equiv; assoc; identityˡ; identityʳ; ∘-resp-≡) renaming (id to idF; _≡_ to _≡F_; _∘_ to _∘F_)
open import Categories.NaturalTransformation hiding (equiv; setoid) renaming (id to idT; _≡_ to _≡T_)

open import Categories.Adjunction

infixr 9 _∘_
_∘_ : ∀ {o ℓ e} {o₁ ℓ₁ e₁} {o₂ ℓ₂ e₂} {C : Category o ℓ e} {D : Category o₁ ℓ₁ e₁} {E : Category o₂ ℓ₂ e₂}
      {F : Functor D C} {G : Functor C D} {H : Functor E D} {I : Functor D E} →
      Adjunction F G → Adjunction H I → Adjunction (F ∘F H) (I ∘F G)
_∘_ {C = C} {D} {E} {F} {G} {H} {I} X Y = record
  { unit = (I ∘ˡ (Xη′ ∘ʳ H)) ∘₁ Yη′
  ; counit = Xε′ ∘₁ (F ∘ˡ (Yε′ ∘ʳ G))
  ; zig = λ {x} → zig′ {x}
  ; zag = λ {x} → zag′ {x}
  }
  where
    module C = Category C
    module D = Category D
    module E = Category E
    module F = Functor F
    module G = Functor G renaming (F₀ to G₀; F₁ to G₁; F-resp-≡ to G-resp-≡)
    module H = Functor H renaming (F₀ to H₀; F₁ to H₁; F-resp-≡ to H-resp-≡)
    module I = Functor I renaming (F₀ to I₀; F₁ to I₁; F-resp-≡ to I-resp-≡)
    module X′ = Adjunction X renaming (unit to Xη′; counit to Xε′)
    module Y′ = Adjunction Y renaming (unit to Yη′; counit to Yε′)
    module Xη = NaturalTransformation (Adjunction.unit X) renaming (η to ηX)
    module Yη = NaturalTransformation (Adjunction.unit Y) renaming (η to ηY)
    module Xε = NaturalTransformation (Adjunction.counit X) renaming (η to εX)
    module Yε = NaturalTransformation (Adjunction.counit Y) renaming (η to εY)
    open C
    open D
    open E
    open F
    open G
    open H
    open I
    open X′
    open Y′
    open Xη
    open Yη
    open Xε
    open Yε

    .zig′ : {x : E.Obj} →
              C.id C.≡
                (εX (F₀ (H₀ x)) C.∘ F₁ (εY (G₀ (F₀ (H₀ x))))) C.∘
                  F₁ (H₁ (I₁ (ηX (H₀ x)) E.∘ ηY x))
    zig′ {x} =
        begin
          C.id
        ↑⟨ F.identity ⟩
          F₁ D.id
        ↓⟨ F-resp-≡ Y′.zig ⟩
          F₁ (D [ εY (H₀ x) ∘ H₁ (ηY x) ])
        ↓⟨ F.homomorphism ⟩
          F₁ (εY (H₀ x)) C.∘ F₁ (H₁ (ηY x))
        ↑⟨ C.∘-resp-≡ˡ C.identityˡ ⟩
          (C.id C.∘ F₁ (εY (H₀ x))) C.∘
            F₁ (H₁ (ηY x))
        ↓⟨ C.∘-resp-≡ˡ (C.∘-resp-≡ˡ X′.zig) ⟩
          ((εX (F₀ (H₀ x)) C.∘ F₁ (ηX (H₀ x))) C.∘ F₁ (εY (H₀ x))) C.∘
            F₁ (H₁ (ηY x))
        ↓⟨ C.∘-resp-≡ˡ C.assoc ⟩
          (εX (F₀ (H₀ x)) C.∘ F₁ (ηX (H₀ x)) C.∘ F₁ (εY (H₀ x))) C.∘
            F₁ (H₁ (ηY x))
        ↓⟨ C.assoc ⟩
          εX (F₀ (H₀ x)) C.∘ (F₁ (ηX (H₀ x)) C.∘ F₁ (εY (H₀ x))) C.∘ F₁ (H₁ (ηY x))
        ↑⟨ C.∘-resp-≡ʳ (C.∘-resp-≡ˡ F.homomorphism) ⟩
          εX (F₀ (H₀ x)) C.∘ F₁ (ηX (H₀ x) D.∘ εY (H₀ x)) C.∘ F₁ (H₁ (ηY x))
        ↑⟨ C.∘-resp-≡ʳ F.homomorphism ⟩
          εX (F₀ (H₀ x)) C.∘ F₁ ((ηX (H₀ x) D.∘ εY (H₀ x)) D.∘ H₁ (ηY x))
        ↑⟨ C.∘-resp-≡ʳ (F-resp-≡ (D.∘-resp-≡ˡ (Yε.commute (ηX (H₀ x))))) ⟩
          εX (F₀ (H₀ x)) C.∘
            F₁ ((εY (G₀ (F₀ (H₀ x))) D.∘ H₁ (I₁ (ηX (H₀ x)))) D.∘ H₁ (ηY x))
        ↓⟨ C.∘-resp-≡ʳ (F-resp-≡ D.assoc) ⟩
          εX (F₀ (H₀ x)) C.∘
            F₁ (εY (G₀ (F₀ (H₀ x))) D.∘ D [ H₁ (I₁ (ηX (H₀ x))) ∘ H₁ (ηY x) ])
        ↑⟨ C.∘-resp-≡ʳ (F-resp-≡ (D.∘-resp-≡ʳ H.homomorphism)) ⟩
          εX (F₀ (H₀ x)) C.∘
            F₁ (D [ εY (G₀ (F₀ (H₀ x))) ∘ H₁ (I₁ (ηX (H₀ x)) E.∘ ηY x) ])
        ↓⟨ C.∘-resp-≡ʳ F.homomorphism ⟩
          εX (F₀ (H₀ x)) C.∘
            F₁ (εY (G₀ (F₀ (H₀ x)))) C.∘ F₁ (H₁ (I₁ (ηX (H₀ x)) E.∘ ηY x))
        ↑⟨ C.assoc ⟩
          (εX (F₀ (H₀ x)) C.∘ F₁ (εY (G₀ (F₀ (H₀ x))))) C.∘
            F₁ (H₁ (I₁ (ηX (H₀ x)) E.∘ ηY x))
        ∎
      where open C.HomReasoning

    .zag′ : {x : C.Obj} →
              E.id E.≡
                I₁ (G₁ (εX x C.∘ F₁ (εY (G₀ x)))) E.∘
                I₁ (ηX (H₀ (I₀ (G₀ x)))) E.∘ ηY (I₀ (G₀ x))
    zag′ {x} =
        begin
          E.id
        ↓⟨ Y′.zag ⟩
          (I₁ (εY (G₀ x))) E.∘ (ηY (I₀ (G₀ x)))
        ↑⟨ E.∘-resp-≡ˡ (I-resp-≡ D.identityˡ) ⟩
          (I₁ (D.id D.∘ (εY (G₀ x)))) E.∘ (ηY (I₀ (G₀ x)))
        ↓⟨ E.∘-resp-≡ˡ (I-resp-≡ (D.∘-resp-≡ˡ X′.zag)) ⟩
          (I₁ ((G₁ (εX x) D.∘ (ηX (G₀ x))) D.∘ (εY (G₀ x)))) E.∘ (ηY (I₀ (G₀ x)))
        ↓⟨ E.∘-resp-≡ˡ (I-resp-≡ D.assoc) ⟩
          I₁ (G₁ (εX x) D.∘ ηX (G₀ x) D.∘ εY (G₀ x)) E.∘ ηY (I₀ (G₀ x))
        ↓⟨ E.∘-resp-≡ˡ (I-resp-≡ (D.∘-resp-≡ʳ (Xη.commute (εY (G₀ x))))) ⟩
          I₁ (G₁ (εX x) D.∘ G₁ (F₁ (εY (G₀ x))) D.∘ ηX (H₀ (I₀ (G₀ x)))) E.∘
            ηY (I₀ (G₀ x))
        ↑⟨ E.∘-resp-≡ˡ (I-resp-≡ D.assoc) ⟩
          I₁ (D [ G₁ (εX x) ∘ G₁ (F₁ (εY (G₀ x))) ] D.∘ ηX (H₀ (I₀ (G₀ x))))
            E.∘ ηY (I₀ (G₀ x))
        ↑⟨ E.∘-resp-≡ˡ (I-resp-≡ (D.∘-resp-≡ˡ G.homomorphism)) ⟩
          I₁ (D [ G₁ (εX x C.∘ F₁ (εY (G₀ x))) ∘ ηX (H₀ (I₀ (G₀ x))) ]) E.∘
            ηY (I₀ (G₀ x))
        ↓⟨ E.∘-resp-≡ˡ I.homomorphism ⟩
          (I₁ (G₁ (εX x C.∘ F₁ (εY (G₀ x)))) E.∘ I₁ (ηX (H₀ (I₀ (G₀ x))))) E.∘
            ηY (I₀ (G₀ x))
        ↓⟨ E.assoc ⟩
          I₁ (G₁ (εX x C.∘ F₁ (εY (G₀ x)))) E.∘
            I₁ (ηX (H₀ (I₀ (G₀ x)))) E.∘ ηY (I₀ (G₀ x))
        ∎
      where open E.HomReasoning


module FFI.MachineWord where

import      Lvl
open import Data.Boolean
open import Numeral.Natural
open import String
open import Syntax.Number
open import Type

postulate Word64 : Type{Lvl.𝟎}
{-# BUILTIN WORD64 Word64 #-}

private
  module Primitives where
    primitive primWord64ToNat   : Word64 → ℕ
    primitive primWord64FromNat : ℕ → Word64

module Word64 where
  open Primitives renaming
    ( primWord64ToNat   to toℕ
    ; primWord64FromNat to fromℕ
    ) public

  instance
    Word64-infiniteNumeral : InfiniteNumeral(Word64)
    Word64-infiniteNumeral = InfiniteNumeral.intro fromℕ


{-# OPTIONS --without-K #-}
module Types where

open import Level
  using (_⊔_; Lift; lift; lower)
  public

infix  1 _≡_
infixr 1 _⊎_
infixr 2 _×_
infix  3 ¬_
infixr 4 _,_
infixr 9 _∘_

-- The negative fragment.
Π : ∀ {a b} (A : Set a) → (A → Set b) → Set _
Π A B = (x : A) → B x

record Σ {a b} (A : Set a) (B : A → Set b) : Set (a ⊔ b) where
  constructor _,_
  field
    π₁ : A
    π₂ : B π₁

open Σ public
-- Projections are defined automatically.

_×_ : ∀ {a b} → Set a → Set b → Set _
A × B = Σ A λ _ → B

-- Unit type with definitional η.
record ⊤ : Set where
  constructor tt

id : ∀ {a} {A : Set a} → A → A
id x = x

_∘_ : ∀ {a b c} {A : Set a} {B : A → Set b} {C : ∀ a → B a → Set c}
  (f : ∀ {a} (b : B a) → C a b)
  (g : ∀ a → B a) →
  ∀ x → C x (g x)
(f ∘ g) x = f (g x)

-- The positive fragment.
data ⊥ : Set where

-- Ex falso quodlibet.
0-elim : ∀ {p} {P : Set p} → ⊥ → P
0-elim ()

¬_ : ∀ {a} → Set a → Set a
¬ A = A → ⊥

-- Unit type without definitional η.
data Unit : Set where
  tt : Unit

1-elim : ∀ {p} (P : Unit → Set p) → P tt →
  ∀ z → P z
1-elim P c tt = c

data _⊎_ {a b} (A : Set a) (B : Set b) : Set (a ⊔ b) where
  inl : A → A ⊎ B
  inr : B → A ⊎ B

-- Case analysis.
case : ∀ {a b p} {A : Set a} {B : Set b} (P : A ⊎ B → Set p)
  (f : ∀ a → P (inl a)) (g : ∀ b → P (inr b)) → ∀ z → P z
case P f g (inl a) = f a
case P f g (inr b) = g b

-- Simga as a positive type.
data Σ′ {a b} (A : Set a) (B : A → Set b) : Set (a ⊔ b) where
  _,_ : (a : A) → B a → Σ′ A B

split : ∀ {a b p} {A : Set a} {B : A → Set b} (P : Σ′ A B → Set p)
  (f : (a : A) (b : B a) → P (a , b)) → ∀ z → P z
split P f (a , b) = f a b

-- Natural numbers.
data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ

{-# BUILTIN NATURAL ℕ #-}

ind : ∀ {p} (P : ℕ → Set p)
  (s : ∀ n → P n → P (suc n))
  (z : P zero) →
  ∀ z → P z
ind P s z zero    = z
ind P s z (suc n) = s n (ind P s z n)

-- Identity type.
data _≡_ {a} {A : Set a} (x : A) : A → Set a where
  refl : x ≡ x

-- When the type cannot be infered.
Id : ∀ {a} (A : Set a) (x y : A) → Set _
Id _ x y = x ≡ y

-- Path induction.
J : ∀ {a p} {A : Set a} (P : ∀ (x : A) y → x ≡ y → Set p)
  (f : ∀ x → P x x refl) → ∀ x y → (p : x ≡ y) → P x y p
J P f x .x refl = f x


{-

Product of structures S and T: X ↦ S X × T X

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

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Structure
open import Cubical.Foundations.RelationalStructure
open import Cubical.Foundations.SIP
open import Cubical.Foundations.Univalence
open import Cubical.Data.Sigma
open import Cubical.HITs.SetQuotients

open import Cubical.Structures.Product

private
  variable
    ℓ ℓ₁ ℓ₁' ℓ₂ ℓ₂' : Level

-- Structured relations

preservesSetsProduct : {S₁ : Type ℓ → Type ℓ₁} {S₂ : Type ℓ → Type ℓ₂}
  → preservesSets S₁ → preservesSets S₂ → preservesSets (ProductStructure S₁ S₂)
preservesSetsProduct p₁ p₂ setX = isSet× (p₁ setX) (p₂ setX)

ProductRelStr :
  {S₁ : Type ℓ → Type ℓ₁} (ρ₁ : StrRel S₁ ℓ₁')
  {S₂ : Type ℓ → Type ℓ₂} (ρ₂ : StrRel S₂ ℓ₂')
  → StrRel (ProductStructure S₁ S₂) (ℓ-max ℓ₁' ℓ₂')
ProductRelStr ρ₁ ρ₂ R (s₁ , s₂) (t₁ , t₂) =
  ρ₁ R s₁ t₁ × ρ₂ R s₂ t₂

open SuitableStrRel

productSuitableRel :
  {S₁ : Type ℓ → Type ℓ₁} {ρ₁ : StrRel S₁ ℓ₁'}
  {S₂ : Type ℓ → Type ℓ₂} {ρ₂ : StrRel S₂ ℓ₂'}
  → SuitableStrRel S₁ ρ₁ → SuitableStrRel S₂ ρ₂
  → SuitableStrRel (ProductStructure S₁ S₂) (ProductRelStr ρ₁ ρ₂)
productSuitableRel θ₁ θ₂ .quo (X , s₁ , s₂) R (r₁ , r₂) .fst .fst =
  θ₁ .quo (X , s₁) R r₁ .fst .fst , θ₂ .quo (X , s₂) R r₂ .fst .fst
productSuitableRel θ₁ θ₂ .quo (X , s₁ , s₂) R (r₁ , r₂) .fst .snd =
  θ₁ .quo (X , s₁) R r₁ .fst .snd , θ₂ .quo (X , s₂) R r₂ .fst .snd
productSuitableRel θ₁ θ₂ .quo (X , s₁ , s₂) R (r₁ , r₂) .snd ((q₁ , q₂) , (c₁ , c₂)) i .fst =
  θ₁ .quo (X , s₁) R r₁ .snd (q₁ , c₁) i .fst , θ₂ .quo (X , s₂) R r₂ .snd (q₂ , c₂) i .fst
productSuitableRel θ₁ θ₂ .quo (X , s₁ , s₂) R (r₁ , r₂) .snd ((q₁ , q₂) , (c₁ , c₂)) i .snd =
  θ₁ .quo (X , s₁) R r₁ .snd (q₁ , c₁) i .snd , θ₂ .quo (X , s₂) R r₂ .snd (q₂ , c₂) i .snd
productSuitableRel θ₁ θ₂ .symmetric R (r₁ , r₂) =
  θ₁ .symmetric R r₁ , θ₂ .symmetric R r₂
productSuitableRel θ₁ θ₂ .transitive R R' (r₁ , r₂) (r₁' , r₂') =
  θ₁ .transitive R R' r₁ r₁' , θ₂ .transitive R R' r₂ r₂'
productSuitableRel θ₁ θ₂ .prop propR (s₁ , s₂) (t₁ , t₂) =
  isProp× (θ₁ .prop propR s₁ t₁) (θ₂ .prop propR s₂ t₂)

productRelMatchesEquiv :
  {S₁ : Type ℓ → Type ℓ₁} (ρ₁ : StrRel S₁ ℓ₁') {ι₁ : StrEquiv S₁ ℓ₁'}
  {S₂ : Type ℓ → Type ℓ₂} (ρ₂ : StrRel S₂ ℓ₂') {ι₂ : StrEquiv S₂ ℓ₂'}
  → StrRelMatchesEquiv ρ₁ ι₁ → StrRelMatchesEquiv ρ₂ ι₂
  → StrRelMatchesEquiv (ProductRelStr ρ₁ ρ₂) (ProductEquivStr ι₁ ι₂)
productRelMatchesEquiv ρ₁ ρ₂ μ₁ μ₂ A B e =
  Σ-cong-equiv (μ₁ _ _ e) (λ _ → μ₂ _ _ e)


module Foundation.Level0 where
{-
it : ∀ {a} {A : Set a} {{x : A}} → A
it {{x}} = x
{-# INLINE it #-}
-}
private

  module Data where

    data ⊥ : Set where

module _ where

  open import Foundation.Bottom

  open import Foundation.Primitive

  instance isBottom-Data : ∀ {a} → IsBottom Data.⊥ a
  IsBottom.⊥-elim isBottom-Data ()

  instance Bottom-Data : ∀ {a} → Bottom 𝟘 a
  Bottom.⊥ Bottom-Data = Data.⊥
  Bottom.isBottom Bottom-Data = isBottom-Data

open import Agda.Builtin.Equality

module _ where

  open import Foundation.Equivalence

  isEquivalence-Builtin : ∀ {a} {A : Set a} → IsEquivalence {A = A} _≡_
  IsEquivalence.reflexivity isEquivalence-Builtin x = refl
  IsEquivalence.symmetry isEquivalence-Builtin x .x refl = refl
  IsEquivalence.transitivity isEquivalence-Builtin x .x z refl x₂ = x₂

  instance _ = isEquivalence-Builtin

  equivalence-Builtin : ∀ {a} {A : Set a} → Equivalence A a
  Equivalence._≈_ equivalence-Builtin = _≡_

  instance _ = equivalence-Builtin


{-# OPTIONS --show-implicit #-}

module PragmasRespected where

postulate
  Foo : {A : Set₁} → Set
  Bar : Foo {A = Set}


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

module lib.types.EilenbergMacLane1 where

open import lib.types.EilenbergMacLane1.Core public
open import lib.types.EilenbergMacLane1.Recursion public
open import lib.types.EilenbergMacLane1.DoubleElim public
open import lib.types.EilenbergMacLane1.DoublePathElim public
open import lib.types.EilenbergMacLane1.FunElim public
open import lib.types.EilenbergMacLane1.PathElim public


{-# OPTIONS --without-K --exact-split #-}

module abelian-groups where

import 17-number-theory
open 17-number-theory public

is-abelian-Group :
  {l : Level} (G : Group l) → UU l
is-abelian-Group G =
  (x y : type-Group G) → Id (mul-Group G x y) (mul-Group G y x)

Ab : (l : Level) → UU (lsuc l)
Ab l = Σ (Group l) is-abelian-Group

group-Ab :
  {l : Level} (A : Ab l) → Group l
group-Ab A = pr1 A

set-Ab :
  {l : Level} (A : Ab l) → UU-Set l
set-Ab A = set-Group (group-Ab A)

type-Ab :
  {l : Level} (A : Ab l) → UU l
type-Ab A = type-Group (group-Ab A)

is-set-type-Ab :
  {l : Level} (A : Ab l) → is-set (type-Ab A)
is-set-type-Ab A = is-set-type-Group (group-Ab A)

associative-add-Ab :
  {l : Level} (A : Ab l) → has-associative-bin-op (set-Ab A)
associative-add-Ab A = associative-mul-Group (group-Ab A)

add-Ab :
  {l : Level} (A : Ab l) → type-Ab A → type-Ab A → type-Ab A
add-Ab A = mul-Group (group-Ab A)

is-associative-add-Ab :
  {l : Level} (A : Ab l) (x y z : type-Ab A) →
  Id (add-Ab A (add-Ab A x y) z) (add-Ab A x (add-Ab A y z))
is-associative-add-Ab A = is-associative-mul-Group (group-Ab A)

semi-group-Ab :
  {l : Level} (A : Ab l) → Semi-Group l
semi-group-Ab A = semi-group-Group (group-Ab A)

is-group-Ab :
  {l : Level} (A : Ab l) → is-group (semi-group-Ab A)
is-group-Ab A = is-group-Group (group-Ab A)

has-zero-Ab :
  {l : Level} (A : Ab l) → is-unital (semi-group-Ab A)
has-zero-Ab A = is-unital-Group (group-Ab A)

zero-Ab :
  {l : Level} (A : Ab l) → type-Ab A
zero-Ab A = unit-Group (group-Ab A)

left-zero-law-Ab :
  {l : Level} (A : Ab l) → (x : type-Ab A) →
  Id (add-Ab A (zero-Ab A) x) x
left-zero-law-Ab A = left-unit-law-Group (group-Ab A)

right-zero-law-Ab :
  {l : Level} (A : Ab l) → (x : type-Ab A) →
  Id (add-Ab A x (zero-Ab A)) x
right-zero-law-Ab A = right-unit-law-Group (group-Ab A)

has-negatives-Ab :
  {l : Level} (A : Ab l) → is-group' (semi-group-Ab A) (has-zero-Ab A)
has-negatives-Ab A = has-inverses-Group (group-Ab A)

neg-Ab :
  {l : Level} (A : Ab l) → type-Ab A → type-Ab A
neg-Ab A = inv-Group (group-Ab A)

left-negative-law-Ab :
  {l : Level} (A : Ab l) (x : type-Ab A) →
  Id (add-Ab A (neg-Ab A x) x) (zero-Ab A)
left-negative-law-Ab A = left-inverse-law-Group (group-Ab A)

right-negative-law-Ab :
  {l : Level} (A : Ab l) (x : type-Ab A) →
  Id (add-Ab A x (neg-Ab A x)) (zero-Ab A)
right-negative-law-Ab A = right-inverse-law-Group (group-Ab A)

is-commutative-add-Ab :
  {l : Level} (A : Ab l) (x y : type-Ab A) →
  Id (add-Ab A x y) (add-Ab A y x)
is-commutative-add-Ab A = pr2 A

{- So far the basic interface of abelian groups. -}

is-prop-is-abelian-Group :
  {l : Level} (G : Group l) → is-prop (is-abelian-Group G)
is-prop-is-abelian-Group G =
  is-prop-Π (λ x → is-prop-Π (λ y → is-set-type-Group G _ _))

{- Homomorphisms of abelian groups -}

preserves-add :
  { l1 l2 : Level} (A : Ab l1) (B : Ab l2) →
  (type-Ab A → type-Ab B) → UU (l1 ⊔ l2)
preserves-add A B = preserves-mul (semi-group-Ab A) (semi-group-Ab B)

hom-Ab :
  {l1 l2 : Level} → Ab l1 → Ab l2 → UU (l1 ⊔ l2)
hom-Ab A B = hom-Group (group-Ab A) (group-Ab B)

map-hom-Ab :
  {l1 l2 : Level} (A : Ab l1) (B : Ab l2) →
  hom-Ab A B → type-Ab A → type-Ab B
map-hom-Ab A B = map-hom-Group (group-Ab A) (group-Ab B)

preserves-add-Ab :
  { l1 l2 : Level} (A : Ab l1) (B : Ab l2) →
  ( f : hom-Ab A B) → preserves-add A B (map-hom-Ab A B f)
preserves-add-Ab A B f = preserves-mul-hom-Group (group-Ab A) (group-Ab B) f

{- We characterize the identity type of the abelian group homomorphisms. -}

htpy-hom-Ab :
  { l1 l2 : Level} (A : Ab l1) (B : Ab l2)
  ( f g : hom-Ab A B) → UU (l1 ⊔ l2)
htpy-hom-Ab A B f g = htpy-hom-Group (group-Ab A) (group-Ab B) f g

reflexive-htpy-hom-Ab :
  { l1 l2 : Level} (A : Ab l1) (B : Ab l2) →
  ( f : hom-Ab A B) → htpy-hom-Ab A B f f
reflexive-htpy-hom-Ab A B f =
  reflexive-htpy-hom-Group (group-Ab A) (group-Ab B) f

htpy-hom-Ab-eq :
  {l1 l2 : Level} (A : Ab l1) (B : Ab l2) →
  (f g : hom-Ab A B) → Id f g → htpy-hom-Ab A B f g
htpy-hom-Ab-eq A B f g = htpy-hom-Group-eq (group-Ab A) (group-Ab B) f g

abstract
  is-contr-total-htpy-hom-Ab :
    { l1 l2 : Level} (A : Ab l1) (B : Ab l2) →
    ( f : hom-Ab A B) →
    is-contr (Σ (hom-Ab A B) (htpy-hom-Ab A B f))
  is-contr-total-htpy-hom-Ab A B f =
    is-contr-total-htpy-hom-Group (group-Ab A) (group-Ab B) f

abstract
  is-equiv-htpy-hom-Ab-eq :
    { l1 l2 : Level} (A : Ab l1) (B : Ab l2) →
    ( f g : hom-Ab A B) → is-equiv (htpy-hom-Ab-eq A B f g)
  is-equiv-htpy-hom-Ab-eq A B f g =
    is-equiv-htpy-hom-Group-eq (group-Ab A) (group-Ab B) f g

eq-htpy-hom-Ab :
  { l1 l2 : Level} (A : Ab l1) (B : Ab l2) →
  { f g : hom-Ab A B} → htpy-hom-Ab A B f g → Id f g
eq-htpy-hom-Ab A B =
  eq-htpy-hom-Group (group-Ab A) (group-Ab B)

is-set-hom-Ab :
  { l1 l2 : Level} (A : Ab l1) (B : Ab l2) →
  is-set (hom-Ab A B)
is-set-hom-Ab A B = is-set-hom-Group (group-Ab A) (group-Ab B)

preserves-add-id :
  {l : Level} (A : Ab l) → preserves-add A A id
preserves-add-id A = preserves-mul-id (semi-group-Ab A)

id-hom-Ab :
  { l1 : Level} (A : Ab l1) → hom-Ab A A
id-hom-Ab A = id-Group (group-Ab A)

comp-hom-Ab :
  { l1 l2 l3 : Level} (A : Ab l1) (B : Ab l2) (C : Ab l3) →
  ( hom-Ab B C) → (hom-Ab A B) → (hom-Ab A C)
comp-hom-Ab A B C =
  comp-Group (group-Ab A) (group-Ab B) (group-Ab C)

is-associative-comp-hom-Ab :
  { l1 l2 l3 l4 : Level} (A : Ab l1) (B : Ab l2) (C : Ab l3) (D : Ab l4) →
  ( h : hom-Ab C D) (g : hom-Ab B C) (f : hom-Ab A B) →
  Id (comp-hom-Ab A B D (comp-hom-Ab B C D h g) f)
     (comp-hom-Ab A C D h (comp-hom-Ab A B C g f))
is-associative-comp-hom-Ab A B C D =
  associative-Semi-Group
    ( semi-group-Ab A)
    ( semi-group-Ab B)
    ( semi-group-Ab C)
    ( semi-group-Ab D)

left-unit-law-comp-hom-Ab :
  { l1 l2 : Level} (A : Ab l1) (B : Ab l2)
  ( f : hom-Ab A B) → Id (comp-hom-Ab A B B (id-hom-Ab B) f) f
left-unit-law-comp-hom-Ab A B =
  left-unit-law-Semi-Group (semi-group-Ab A) (semi-group-Ab B)

right-unit-law-comp-hom-Ab :
  { l1 l2 : Level} (A : Ab l1) (B : Ab l2)
  ( f : hom-Ab A B) → Id (comp-hom-Ab A A B f (id-hom-Ab A)) f
right-unit-law-comp-hom-Ab A B =
  right-unit-law-Semi-Group (semi-group-Ab A) (semi-group-Ab B)

{- Isomorphisms of abelian groups -}

is-iso-hom-Ab :
  { l1 l2 : Level} (A : Ab l1) (B : Ab l2) →
  ( f : hom-Ab A B) → UU (l1 ⊔ l2)
is-iso-hom-Ab A B =
  is-iso-hom-Semi-Group (semi-group-Ab A) (semi-group-Ab B)

inv-is-iso-hom-Ab :
  { l1 l2 : Level} (A : Ab l1) (B : Ab l2) (f : hom-Ab A B) →
  is-iso-hom-Ab A B f → hom-Ab B A
inv-is-iso-hom-Ab A B f = pr1

map-inv-is-iso-hom-Ab :
  { l1 l2 : Level} (A : Ab l1) (B : Ab l2) (f : hom-Ab A B) →
  is-iso-hom-Ab A B f → type-Ab B → type-Ab A
map-inv-is-iso-hom-Ab A B f is-iso-f =
  map-hom-Ab B A (inv-is-iso-hom-Ab A B f is-iso-f)

is-sec-inv-is-iso-hom-Ab :
  { l1 l2 : Level} (A : Ab l1) (B : Ab l2) (f : hom-Ab A B) →
  ( is-iso-f : is-iso-hom-Ab A B f) →
  Id (comp-hom-Ab B A B f (inv-is-iso-hom-Ab A B f is-iso-f)) (id-hom-Ab B)
is-sec-inv-is-iso-hom-Ab A B f is-iso-f = pr1 (pr2 is-iso-f)

is-sec-map-inv-is-iso-hom-Ab :
  { l1 l2 : Level} (A : Ab l1) (B : Ab l2) (f : hom-Ab A B) →
  ( is-iso-f : is-iso-hom-Ab A B f) →
  ( (map-hom-Ab A B f) ∘ (map-hom-Ab B A (inv-is-iso-hom-Ab A B f is-iso-f))) ~
  id
is-sec-map-inv-is-iso-hom-Ab A B f is-iso-f =
  htpy-hom-Ab-eq B B
    ( comp-hom-Ab B A B f (inv-is-iso-hom-Ab A B f is-iso-f))
    ( id-hom-Ab B)
    ( is-sec-inv-is-iso-hom-Ab A B f is-iso-f)

is-retr-inv-is-iso-hom-Ab :
  { l1 l2 : Level} (A : Ab l1) (B : Ab l2) (f : hom-Ab A B) →
  ( is-iso-f : is-iso-hom-Ab A B f) →
  Id (comp-hom-Ab A B A (inv-is-iso-hom-Ab A B f is-iso-f) f) (id-hom-Ab A)
is-retr-inv-is-iso-hom-Ab A B f is-iso-f = pr2 (pr2 is-iso-f)

is-retr-map-inv-is-iso-hom-Ab :
  { l1 l2 : Level} (A : Ab l1) (B : Ab l2) (f : hom-Ab A B) →
  ( is-iso-f : is-iso-hom-Ab A B f) →
  ( (map-inv-is-iso-hom-Ab A B f is-iso-f) ∘ (map-hom-Ab A B f)) ~ id
is-retr-map-inv-is-iso-hom-Ab A B f is-iso-f =
  htpy-hom-Ab-eq A A
    ( comp-hom-Ab A B A (inv-is-iso-hom-Ab A B f is-iso-f) f)
    ( id-hom-Ab A)
    ( is-retr-inv-is-iso-hom-Ab A B f is-iso-f)

is-prop-is-iso-hom-Ab :
  { l1 l2 : Level} (A : Ab l1) (B : Ab l2) (f : hom-Ab A B) →
  is-prop (is-iso-hom-Ab A B f)
is-prop-is-iso-hom-Ab A B f =
  is-prop-is-iso-hom-Semi-Group (semi-group-Ab A) (semi-group-Ab B) f

iso-Ab :
  { l1 l2 : Level} (A : Ab l1) (B : Ab l2) → UU (l1 ⊔ l2)
iso-Ab A B = Σ (hom-Ab A B) (is-iso-hom-Ab A B)

hom-iso-Ab :
  { l1 l2 : Level} (A : Ab l1) (B : Ab l2) →
  iso-Ab A B → hom-Ab A B
hom-iso-Ab A B = pr1

is-iso-hom-iso-Ab :
  { l1 l2 : Level} (A : Ab l1) (B : Ab l2) →
  ( f : iso-Ab A B) → is-iso-hom-Ab A B (hom-iso-Ab A B f)
is-iso-hom-iso-Ab A B = pr2

inv-hom-iso-Ab :
  { l1 l2 : Level} (A : Ab l1) (B : Ab l2) →
  iso-Ab A B → hom-Ab B A
inv-hom-iso-Ab A B f =
  inv-is-iso-hom-Ab A B
    ( hom-iso-Ab A B f)
    ( is-iso-hom-iso-Ab A B f)

id-iso-Ab :
  {l1 : Level} (A : Ab l1) → iso-Ab A A
id-iso-Ab A = iso-id-Group (group-Ab A)

iso-eq-Ab :
  { l1 : Level} (A B : Ab l1) → Id A B → iso-Ab A B
iso-eq-Ab A .A refl = id-iso-Ab A

abstract
  equiv-iso-eq-Ab' :
    {l1 : Level} (A B : Ab l1) → Id A B ≃ iso-Ab A B
  equiv-iso-eq-Ab' A B =
    ( equiv-iso-eq-Group' (group-Ab A) (group-Ab B)) ∘e
    ( equiv-ap-pr1-is-subtype is-prop-is-abelian-Group {A} {B})

abstract
  is-contr-total-iso-Ab :
    { l1 : Level} (A : Ab l1) → is-contr (Σ (Ab l1) (iso-Ab A))
  is-contr-total-iso-Ab {l1} A =
    is-contr-equiv'
      ( Σ (Ab l1) (Id A))
      ( equiv-tot (equiv-iso-eq-Ab' A))
      ( is-contr-total-path A)

is-equiv-iso-eq-Ab :
  { l1 : Level} (A B : Ab l1) → is-equiv (iso-eq-Ab A B)
is-equiv-iso-eq-Ab A =
  fundamental-theorem-id A
    ( id-iso-Ab A)
    ( is-contr-total-iso-Ab A)
    ( iso-eq-Ab A)

eq-iso-Ab :
  { l1 : Level} (A B : Ab l1) → iso-Ab A B → Id A B
eq-iso-Ab A B = inv-is-equiv (is-equiv-iso-eq-Ab A B)


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

module Dodo.Nullary where

open import Dodo.Nullary.Disjoint public
open import Dodo.Nullary.Unique public
open import Dodo.Nullary.XOpt public


open import FRP.JS.Bool using ( Bool ; not )
open import FRP.JS.Event using ( Evt ; accumBy )
open import FRP.JS.RSet using ( RSet ; _⇒_ ; ⟦_⟧ ; ⟨_⟩ )

module FRP.JS.Behaviour where

postulate
  Beh : RSet → RSet
  map : ∀ {A B} → ⟦ A ⇒ B ⟧ → ⟦ Beh A ⇒ Beh B ⟧
  map2 : ∀ {A B C} → ⟦ A ⇒ B ⇒ C ⟧ → ⟦ Beh A ⇒ Beh B ⇒ Beh C ⟧
  [_] : ∀ {A} → A → ⟦ Beh ⟨ A ⟩ ⟧
  join : ∀ {A} → ⟦ Beh (Beh A) ⇒ Beh A ⟧
  hold : ∀ {A} → ⟦ ⟨ A ⟩ ⇒ Evt ⟨ A ⟩ ⇒ Beh ⟨ A ⟩ ⟧

{-# COMPILED_JS map function(A) { return function(B) {
  return function(f) { return function(s) { return function(b) {
    return b.map(function (t,v) { return f(t)(v); });
  }; }; };
}; } #-}

{-# COMPILED_JS map2 function(A) { return function(B) { return function(C) {
  return function(f) { return function(s) { return function(a) { return function(b) {
    return a.map2(b, function (t,v1,v2) { return f(t)(v1)(v2); });
  }; }; }; };
}; }; } #-}

{-# COMPILED_JS [_] function(A) { return function(a) { return function(s) {
  return require("agda.frp").constant(a);
}; }; } #-}

{-# COMPILED_JS join function(A) { return function(s) { return function(b) {
  return b.join();
}; }; } #-}

{-# COMPILED_JS hold function(A) { return function(s) { return function(a) { return function(e) {
  return e.hold(a);
}; }; }; } #-}

accumHoldBy : ∀ {A B} → ⟦ (⟨ B ⟩ ⇒ A ⇒ ⟨ B ⟩) ⟧ → B → ⟦ Evt A ⇒ Beh ⟨ B ⟩ ⟧
accumHoldBy f b σ = hold b (accumBy f b σ)

not* : ⟦ Beh ⟨ Bool ⟩ ⇒ Beh ⟨ Bool ⟩ ⟧
not* = map not


{-# OPTIONS --rewriting #-}

data _==_ {A : Set} (a : A) : A → Set where
  idp : a == a
{-# BUILTIN REWRITE _==_ #-}

ap : {A B : Set} (f : A → B) {x y : A} →
  x == y → f x == f y
ap f idp = idp

{- Circle -}
postulate
  Circle : Set
  base : Circle
  loop : base == base

module _ (P : Set) (base* : P) (loop* : base* == base*) where

  postulate
    Circle-rec : Circle → P
    Circle-base-recβ : Circle-rec base == base*
  {-# REWRITE Circle-base-recβ #-}

f : Circle → Circle
f = Circle-rec Circle base loop

postulate
  rewr : ap (λ z → f (f z)) loop == loop
{-# REWRITE rewr #-}

test : ap (λ z → f (f z)) loop == loop
test = idp


------------------------------------------------------------------------
-- Convenient syntax for relational reasoning using transitive
-- relations
------------------------------------------------------------------------

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

module Relation.Binary.TransReasoning where

open import Level using (suc; _⊔_)
open import Data.Context using (Ctx)
open import Data.Fin.Substitution.Typed using (Typing)
open import Data.Fin.Substitution.TypedRelation using (TypedRel)
open import Data.Nat using (ℕ)
open import Data.Product using (_,_; proj₁; proj₂)
open import Relation.Binary.PropositionalEquality as P using (_≡_; subst)
open import Relation.Binary
open import Relation.Unary using (Pred)

------------------------------------------------------------------------
-- Transitive relations that are not necessarily reflexive
--
-- Following the convention used in the standard library, we define
-- transitive binary relations using a pair of records (see
-- Relation.Binary).

record IsTransRel {a ℓ₁ ℓ₂} {A : Set a}
                  (_≈_ : Rel A ℓ₁) -- The underlying equality.
                  (_∼_ : Rel A ℓ₂) -- The relation.
                  : Set (a ⊔ ℓ₁ ⊔ ℓ₂) where
  field
    isEquivalence : IsEquivalence _≈_
    trans         : Transitive _∼_

    -- _∼_ respects the underlying equality _≈_.
    --
    -- (This always true for preorders, but not necessarily for
    -- irreflexive relations.)
    ∼-resp-≈      : _∼_ Respects₂ _≈_

  module Eq = IsEquivalence isEquivalence

record TransRel c ℓ₁ ℓ₂ : Set (suc (c ⊔ ℓ₁ ⊔ ℓ₂)) where
  infix 4 _≈_ _∼_
  field
    Carrier    : Set c
    _≈_        : Rel Carrier ℓ₁  -- The underlying equality.
    _∼_        : Rel Carrier ℓ₂  -- The relation.
    isTransRel : IsTransRel _≈_ _∼_

  open IsTransRel isTransRel public

-- Sanity check: every pre-order is a transitive relation in the above
-- sense...
preorderIsTransRel : ∀ {c ℓ₁ ℓ₂} → Preorder c ℓ₁ ℓ₂ → TransRel c ℓ₁ ℓ₂
preorderIsTransRel P = record
 { isTransRel = record
   { isEquivalence = isEquivalence
   ; trans         = trans
   ; ∼-resp-≈      = ∼-resp-≈
   }
 }
 where open IsPreorder (Preorder.isPreorder P)

-- ... and so is every strict partial order.
strictPartialOrderIsTransRel : ∀ {c ℓ₁ ℓ₂} →
                               StrictPartialOrder c ℓ₁ ℓ₂ → TransRel c ℓ₁ ℓ₂
strictPartialOrderIsTransRel SPO = record
 { isTransRel = record
   { isEquivalence = isEquivalence
   ; trans         = trans
   ; ∼-resp-≈      = <-resp-≈
   }
 }
 where open IsStrictPartialOrder (StrictPartialOrder.isStrictPartialOrder SPO)

-- A form of relational reasoning for transitive relations.
--
-- The structure of this module is adapted from the
-- Relation.Binary.PreorderReasoning module of the standard library.
-- It differs from the latter in that
--
--  1. it allows reasoning about relations that are transitive but not
--     reflexive, and
--
--  2. the _IsRelatedTo_ predicate is extended with an additional
--     index that tracks whether elements of the carrier are actually
--     related in the transitive relation _∼_ or just in the
--     underlying equality _≈_.
--
-- Proofs that elements x, y are related as (x IsRelatedTo y In rel)
-- can be converted back to proofs that x ∼ y using begin_, whereas
-- proofs of (x IsRelatedTo y In eq) are too weak to do so.  Since the
-- relation _∼_ is not assumed to be reflexive (i.e. not necessarily a
-- preorder) _∎ can only construct proofs of the weaker form (x ∎ : x
-- IsRelatedTo x In eq).  Consequently, at least one use of _∼⟨_⟩_ is
-- necessary to conclude a proof.

module TransRelReasoning {c ℓ₁ ℓ₂} (R : TransRel c ℓ₁ ℓ₂) where

  open TransRel R

  infix  4 _IsRelatedTo_In_
  infix  3 _∎
  infixr 2 _∼⟨_⟩_ _≈⟨_⟩_ _≈⟨⟩_
  infix  1 begin_

  -- Codes for the relation _∼_ and the underlying equality _≈_.
  data RelC : Set where
    rel eq : RelC

  -- A generic relation combining _∼_ and equality.
  data _IsRelatedTo_In_ (x y : Carrier) : RelC → Set (ℓ₁ ⊔ ℓ₂) where
    relTo : (x∼y : x ∼ y) → x IsRelatedTo y In rel
    eqTo  : (x≈y : x ≈ y) → x IsRelatedTo y In eq

  begin_ : ∀ {x y} → x IsRelatedTo y In rel → x ∼ y
  begin (relTo x∼y) = x∼y

  _∼⟨_⟩_ : ∀ x {y z c} → x ∼ y → y IsRelatedTo z In c → x IsRelatedTo z In rel
  _ ∼⟨ x∼y ⟩ relTo y∼z = relTo (trans x∼y y∼z)
  _ ∼⟨ x∼y ⟩ eqTo  y≈z = relTo (proj₁ ∼-resp-≈ y≈z x∼y)

  _≈⟨_⟩_ : ∀ x {y z c} → x ≈ y → y IsRelatedTo z In c → x IsRelatedTo z In c
  x ≈⟨ x≈y ⟩ relTo y∼z = relTo (proj₂ ∼-resp-≈ (Eq.sym x≈y) y∼z)
  x ≈⟨ x≈y ⟩ eqTo  y≈z = eqTo (Eq.trans x≈y y≈z)

  _≈⟨⟩_ : ∀ x {y c} → x IsRelatedTo y In c → x IsRelatedTo y In c
  _ ≈⟨⟩ rt-x∼y = rt-x∼y

  _∎ : ∀ x → x IsRelatedTo x In eq
  _ ∎ = eqTo Eq.refl

------------------------------------------------------------------------
-- FIXME: the following should go into a different module (probably
-- into Data.Fin.Substitution.{Typed,TypedRel})

-- A form of pre-order reasoning for transitive relations in a context.
record TransCtxTermRelReasoning {t₁ t₂ ℓ} {T₁ : Pred ℕ t₁} {T₂ : Pred ℕ t₂}
                                (_⊢_∼_ : Typing T₁ T₂ T₂ ℓ)
                                : Set (t₁ ⊔ t₂ ⊔ ℓ) where

  -- Transitivity of _⊢_∼_ for a given context.
  field ∼-trans : ∀ {n} {Γ : Ctx T₁ n} → Transitive (Γ ⊢_∼_)

  module _ {n} {Γ : Ctx T₁ n} where

    ∼-transRel : TransRel _ _ _
    ∼-transRel = record
      { Carrier = T₂ n
      ; _≈_     = _≡_
      ; _∼_     = Γ ⊢_∼_
      ; isTransRel = record
        { isEquivalence = P.isEquivalence
        ; trans         = ∼-trans
        ; ∼-resp-≈      = subst (Γ ⊢ _ ∼_) , subst (Γ ⊢_∼ _)
        }
      }
    open TransRelReasoning ∼-transRel public
      renaming (_≈⟨_⟩_ to _≡⟨_⟩_; _≈⟨⟩_ to _≡⟨⟩_)

-- A form of pre-order reasoning for typed transitive relations.
record TypedTransRelReasoning {t₁ t₂ t₃ ℓ} {T₁ : Pred ℕ t₁}
                              {T₂ : Pred ℕ t₂} {T₃ : Pred ℕ t₃}
                              (_⊢_∼_∈_ : TypedRel T₁ T₂ T₂ T₃ ℓ)
                              : Set (t₁ ⊔ t₂ ⊔ t₃ ⊔ ℓ) where

  -- Transitivity of _⊢_∼_∈_ for a given context and T₃-"type".
  field ∼-trans : ∀ {n} {Γ : Ctx T₁ n} {t} → Transitive (Γ ⊢_∼_∈ t)

  module _ {n} {Γ : Ctx T₁ n} {t : T₃ n} where

    ∼-transRel : TransRel _ _ _
    ∼-transRel = record
      { Carrier = T₂ n
      ; _≈_     = _≡_
      ; _∼_     = Γ ⊢_∼_∈ t
      ; isTransRel = record
        { isEquivalence = P.isEquivalence
        ; trans         = ∼-trans
        ; ∼-resp-≈      = subst (Γ ⊢ _ ∼_∈ _) , subst (Γ ⊢_∼ _ ∈ _)
        }
      }
    open TransRelReasoning ∼-transRel public
      renaming (_≈⟨_⟩_ to _≡⟨_⟩_; _≈⟨⟩_ to _≡⟨⟩_)


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

module Data.Maybe.Sugar where

open import Prelude
open import Data.Maybe

infixl 4 _<*>_
_>>=_ : Maybe A → (A → Maybe B) → Maybe B
nothing  >>= f = nothing
just x   >>= f = f x

pure : A → Maybe A
pure = just

_<*>_ :  Maybe (A → B) →
         Maybe A →
         Maybe B
nothing   <*> xs       = nothing
just f    <*> nothing  = nothing
just f    <*> just x   = just (f x)

_>>_ : Maybe A → Maybe B → Maybe B
nothing >> _ = nothing
just _  >> y = y

guard : Bool → Maybe ⊤
guard false = nothing
guard true  = just tt

_<|>_ : Maybe A → Maybe A → Maybe A
nothing     <|> ys = ys
xs@(just _) <|> _ = xs


open import Agda.Primitive

variable
  a : Level

postulate
  works : Set a → {a : Set} → a
  fails : Set a → {a : Set} → {!a!}

module _ (A : Set a) (a : A) where
  x : A
  x = a


{-

Definition of the circle as a HIT with a proof that Ω(S¹) ≡ ℤ

-}
{-# OPTIONS --cubical --safe #-}
module Cubical.HITs.S1.Base where

open import Cubical.Core.Glue

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

open import Cubical.Data.Nat
  hiding (_+_ ; _*_ ; +-assoc ; +-comm)
open import Cubical.Data.Int

data S¹ : Type₀ where
  base : S¹
  loop : base ≡ base

-- Check that transp is the identity function for S¹
module _ where
  transpS¹ : ∀ (φ : I) (u0 : S¹) → transp (λ _ → S¹) φ u0 ≡ u0
  transpS¹ φ u0 = refl

  compS1 : ∀ (φ : I) (u : ∀ i → Partial φ S¹) (u0 : S¹ [ φ ↦ u i0 ]) →
    comp (λ _ → S¹) u (outS u0) ≡ hcomp u (outS u0)
  compS1 φ u u0 = refl

helix : S¹ → Type₀
helix base     = Int
helix (loop i) = sucPathInt i

ΩS¹ : Type₀
ΩS¹ = base ≡ base

encode : ∀ x → base ≡ x → helix x
encode x p = subst helix p (pos zero)

winding : ΩS¹ → Int
winding = encode base

intLoop : Int → ΩS¹
intLoop (pos zero)       = refl
intLoop (pos (suc n))    = intLoop (pos n) ∙ loop
intLoop (negsuc zero)    = sym loop
intLoop (negsuc (suc n)) = intLoop (negsuc n) ∙ sym loop

decodeSquare : (n : Int) → PathP (λ i → base ≡ loop i) (intLoop (predInt n)) (intLoop n)
decodeSquare (pos zero) i j    = loop (i ∨ ~ j)
decodeSquare (pos (suc n)) i j = hfill (λ k → λ { (j = i0) → base
                                                ; (j = i1) → loop k } )
                                       (inS (intLoop (pos n) j)) i
decodeSquare (negsuc n) i j = hcomp (λ k → λ { (i = i1) → intLoop (negsuc n) j
                                             ; (j = i0) → base
                                             ; (j = i1) → loop (i ∨ ~ k) })
                                    (intLoop (negsuc n) j)

decode : (x : S¹) → helix x → base ≡ x
decode base         = intLoop
decode (loop i) y j =
  let n : Int
      n = unglue (i ∨ ~ i) y
  in hcomp (λ k → λ { (i = i0) → intLoop (predSuc y k) j
                    ; (i = i1) → intLoop y j
                    ; (j = i0) → base
                    ; (j = i1) → loop i })
           (decodeSquare n i j)

decodeEncode : (x : S¹) (p : base ≡ x) → decode x (encode x p) ≡ p
decodeEncode x p = J (λ y q → decode y (encode y q) ≡ q) (λ _ → refl) p

isSetΩS¹ : isSet ΩS¹
isSetΩS¹ p q r s j i =
  hcomp (λ k → λ { (i = i0) → decodeEncode base p k
                 ; (i = i1) → decodeEncode base q k
                 ; (j = i0) → decodeEncode base (r i) k
                 ; (j = i1) → decodeEncode base (s i) k })
        (decode base (isSetInt (winding p) (winding q) (cong winding r) (cong winding s) j i))

-- This proof does not rely on rewriting hcomp with empty systems in
-- Int as ghcomp has been implemented!
windingIntLoop : (n : Int) → winding (intLoop n) ≡ n
windingIntLoop (pos zero)       = refl
windingIntLoop (pos (suc n))    = cong sucInt (windingIntLoop (pos n))
windingIntLoop (negsuc zero)    = refl
windingIntLoop (negsuc (suc n)) = cong predInt (windingIntLoop (negsuc n))

ΩS¹≡Int : ΩS¹ ≡ Int
ΩS¹≡Int = isoToPath (iso winding intLoop windingIntLoop (decodeEncode base))

-- intLoop and winding are group homomorphisms
private
  intLoop-sucInt : (z : Int) → intLoop (sucInt z) ≡ intLoop z ∙ loop
  intLoop-sucInt (pos n)          = refl
  intLoop-sucInt (negsuc zero)    = sym (lCancel loop)
  intLoop-sucInt (negsuc (suc n)) =
      rUnit (intLoop (negsuc n))
    ∙ (λ i → intLoop (negsuc n) ∙ lCancel loop (~ i))
    ∙ assoc (intLoop (negsuc n)) (sym loop) loop

  intLoop-predInt : (z : Int) → intLoop (predInt z) ≡ intLoop z ∙ sym loop
  intLoop-predInt (pos zero)    = lUnit (sym loop)
  intLoop-predInt (pos (suc n)) =
      rUnit (intLoop (pos n))
    ∙ (λ i → intLoop (pos n) ∙ (rCancel loop (~ i)))
    ∙ assoc (intLoop (pos n)) loop (sym loop)
  intLoop-predInt (negsuc n)    = refl

intLoop-hom : (a b : Int) → (intLoop a) ∙ (intLoop b) ≡ intLoop (a + b)
intLoop-hom a (pos zero)       = sym (rUnit (intLoop a))
intLoop-hom a (pos (suc n))    =
    assoc (intLoop a) (intLoop (pos n)) loop
  ∙ (λ i → (intLoop-hom a (pos n) i) ∙ loop)
  ∙ sym (intLoop-sucInt (a + pos n))
intLoop-hom a (negsuc zero)    = sym (intLoop-predInt a)
intLoop-hom a (negsuc (suc n)) =
    assoc (intLoop a) (intLoop (negsuc n)) (sym loop)
  ∙ (λ i → (intLoop-hom a (negsuc n) i) ∙ (sym loop))
  ∙ sym (intLoop-predInt (a + negsuc n))

winding-hom : (a b : ΩS¹) → winding (a ∙ b) ≡ (winding a) + (winding b)
winding-hom a b i =
  hcomp (λ t → λ { (i = i0) → winding (decodeEncode base a t ∙ decodeEncode base b t)
                 ; (i = i1) → windingIntLoop (winding a + winding b) t })
        (winding (intLoop-hom (winding a) (winding b) i))

-- Based homotopy group

basedΩS¹ : (x : S¹) → Type₀
basedΩS¹ x = x ≡ x

-- Proof that the homotopy group is actually independent on the basepoint
-- first, give a quasi-inverse to the basechange basedΩS¹→ΩS¹ for any loop i
-- (which does *not* match at endpoints)
private
  ΩS¹→basedΩS¹-filler : I → I → ΩS¹ → I → S¹
  ΩS¹→basedΩS¹-filler l i x j =
    hfill (λ t → λ { (j = i0) → loop (i ∧ t)
                   ; (j = i1) → loop (i ∧ t) })
          (inS (x j)) l

  basedΩS¹→ΩS¹-filler : (_ i : I) → basedΩS¹ (loop i) → I → S¹
  basedΩS¹→ΩS¹-filler l i x j =
    hfill (λ t → λ { (j = i0) → loop (i ∧ (~ t))
                   ; (j = i1) → loop (i ∧ (~ t)) })
          (inS (x j)) l

ΩS¹→basedΩS¹ : (i : I) → ΩS¹ → basedΩS¹ (loop i)
ΩS¹→basedΩS¹ i x j = ΩS¹→basedΩS¹-filler i1 i x j

basedΩS¹→ΩS¹ : (i : I) → basedΩS¹ (loop i) → ΩS¹
basedΩS¹→ΩS¹ i x j = basedΩS¹→ΩS¹-filler i1 i x j

basedΩS¹→ΩS¹→basedΩS¹ : (i : I) → (x : basedΩS¹ (loop i))
                        → ΩS¹→basedΩS¹ i (basedΩS¹→ΩS¹ i x) ≡ x
basedΩS¹→ΩS¹→basedΩS¹ i x j k =
  hcomp (λ t → λ { (j = i1) → basedΩS¹→ΩS¹-filler (~ t) i x k
                 ; (j = i0) → ΩS¹→basedΩS¹ i (basedΩS¹→ΩS¹ i x) k
                 ; (k = i0) → loop (i ∧ (t ∨ (~ j)))
                 ; (k = i1) → loop (i ∧ (t ∨ (~ j))) })
        (ΩS¹→basedΩS¹-filler (~ j) i (basedΩS¹→ΩS¹ i x) k)

ΩS¹→basedΩS¹→ΩS¹ : (i : I) → (x : ΩS¹)
                        → basedΩS¹→ΩS¹ i (ΩS¹→basedΩS¹ i x) ≡ x
ΩS¹→basedΩS¹→ΩS¹ i x j k =
  hcomp (λ t → λ { (j = i1) → ΩS¹→basedΩS¹-filler (~ t) i x k
                 ; (j = i0) → basedΩS¹→ΩS¹ i (ΩS¹→basedΩS¹ i x) k
                 ; (k = i0) → loop (i ∧ ((~ t) ∧ j))
                 ; (k = i1) → loop (i ∧ ((~ t) ∧ j)) })
        (basedΩS¹→ΩS¹-filler (~ j) i (ΩS¹→basedΩS¹ i x) k)

-- from the existence of our quasi-inverse, we deduce that the basechange is an equivalence
-- for all loop i

basedΩS¹→ΩS¹-isequiv : (i : I) → isEquiv (basedΩS¹→ΩS¹ i)
basedΩS¹→ΩS¹-isequiv i = isoToIsEquiv (iso (basedΩS¹→ΩS¹ i) (ΩS¹→basedΩS¹ i)
                 (ΩS¹→basedΩS¹→ΩS¹ i) (basedΩS¹→ΩS¹→basedΩS¹ i))

-- now extend the basechange so that both ends match
-- (and therefore we get a basechange for any x : S¹)

private
  loop-conjugation : basedΩS¹→ΩS¹ i1 ≡ λ x → x
  loop-conjugation i x =
    let p = (doubleCompPath-elim loop x (sym loop))
            ∙ (λ i → (lUnit loop i ∙ x) ∙ sym loop)
    in
    ((sym (decodeEncode base (basedΩS¹→ΩS¹ i1 x)))
    ∙ (λ t → intLoop (winding (p t)))
    ∙ (λ t → intLoop (winding-hom (intLoop (pos (suc zero)) ∙ x)
                                  (intLoop (negsuc zero)) t))
    ∙ (λ t → intLoop ((winding-hom (intLoop (pos (suc zero))) x t)
                      + (windingIntLoop (negsuc zero) t)))
    ∙ (λ t → intLoop (((windingIntLoop (pos (suc zero)) t) + (winding x)) + (negsuc zero)))
    ∙ (λ t → intLoop ((+-comm (pos (suc zero)) (winding x) t) + (negsuc zero)))
    ∙ (λ t → intLoop (+-assoc (winding x) (pos (suc zero)) (negsuc zero) (~ t)))
    ∙ (decodeEncode base x)) i

  refl-conjugation : basedΩS¹→ΩS¹ i0 ≡ λ x → x
  refl-conjugation i x j =
    hfill (λ t → λ { (j = i0) → base
                   ; (j = i1) → base })
          (inS (x j)) (~ i)

  basechange : (x : S¹) → basedΩS¹ x → ΩS¹
  basechange base y = y
  basechange (loop i) y =
    hcomp (λ t → λ { (i = i0) → refl-conjugation t y
                   ; (i = i1) → loop-conjugation t y })
          (basedΩS¹→ΩS¹ i y)

  -- for any loop i, the old basechange is equal to the new one
  basedΩS¹→ΩS¹≡basechange : (i : I) → basedΩS¹→ΩS¹ i ≡ basechange (loop i)
  basedΩS¹→ΩS¹≡basechange i j y =
    hfill (λ t → λ { (i = i0) → refl-conjugation t y
                   ; (i = i1) → loop-conjugation t y })
          (inS (basedΩS¹→ΩS¹ i y)) j

  -- so for any loop i, the extended basechange is an equivalence
  basechange-isequiv-aux : (i : I) → isEquiv (basechange (loop i))
  basechange-isequiv-aux i =
    transport (λ j → isEquiv (basedΩS¹→ΩS¹≡basechange i j)) (basedΩS¹→ΩS¹-isequiv i)

  -- as being an equivalence is contractible, basechange is an equivalence for all x : S¹
  basechange-isequiv : (x : S¹) → isEquiv (basechange x)
  basechange-isequiv base = basechange-isequiv-aux i0
  basechange-isequiv (loop i) =
    hcomp (λ t → λ { (i = i0) → basechange-isequiv-aux i0
                   ; (i = i1) → isPropIsEquiv (basechange base) (basechange-isequiv-aux i1)
                                              (basechange-isequiv-aux i0) t })
          (basechange-isequiv-aux i)

  basedΩS¹≡ΩS¹ : (x : S¹) → basedΩS¹ x ≡ ΩS¹
  basedΩS¹≡ΩS¹ x = ua (basechange x , basechange-isequiv x)

basedΩS¹≡Int : (x : S¹) → basedΩS¹ x ≡ Int
basedΩS¹≡Int x = (basedΩS¹≡ΩS¹ x) ∙ ΩS¹≡Int

-- Some tests
module _ where
 private
  test-winding-pos : winding (intLoop (pos 5)) ≡ pos 5
  test-winding-pos = refl

  test-winding-neg : winding (intLoop (negsuc 5)) ≡ negsuc 5
  test-winding-neg = refl

-- the inverse when S¹ is seen as a group

inv : S¹ → S¹
inv base = base
inv (loop i) = loop (~ i)

-- rot, used in the Hopf fibration

rotLoop : (a : S¹) → a ≡ a
rotLoop base       = loop
rotLoop (loop i) j =
  hcomp (λ k → λ { (i = i0) → loop (j ∨ ~ k)
                 ; (i = i1) → loop (j ∧ k)
                 ; (j = i0) → loop (i ∨ ~ k)
                 ; (j = i1) → loop (i ∧ k)}) base

rot : S¹ → S¹ → S¹
rot base x     = x
rot (loop i) x = rotLoop x i

_*_ : S¹ → S¹ → S¹
a * b = rot a b

infixl 30 _*_

-- rot i j = filler-rot i j i1
filler-rot : I → I → I → S¹
filler-rot i j = hfill (λ k → λ { (i = i0) → loop (j ∨ ~ k)
                   ; (i = i1) → loop (j ∧ k)
                   ; (j = i0) → loop (i ∨ ~ k)
                   ; (j = i1) → loop (i ∧ k) }) (inS base)

isPropFamS¹ : ∀ {ℓ} (P : S¹ → Type ℓ) (pP : (x : S¹) → isProp (P x)) (b0 : P base) →
              PathP (λ i → P (loop i)) b0 b0
isPropFamS¹ P pP b0 i = pP (loop i) (transp (λ j → P (loop (i ∧ j))) (~ i) b0)
                                    (transp (λ j → P (loop (i ∨ ~ j))) i b0) i

rotIsEquiv : (a : S¹) → isEquiv (rot a)
rotIsEquiv base = idIsEquiv S¹
rotIsEquiv (loop i) = isPropFamS¹ (λ x → isEquiv (rot x))
                                  (λ x → isPropIsEquiv (rot x))
                                  (idIsEquiv _) i

-- more direct definition of the rot (loop i) equivalence

rotLoopInv : (a : S¹) → PathP (λ i → rotLoop (rotLoop a (~ i)) i ≡ a) refl refl
rotLoopInv a i j =
  hcomp
    (λ k → λ {
      (i = i0) → a;
      (i = i1) → rotLoop a (j ∧ ~ k);
      (j = i0) → rotLoop (rotLoop a (~ i)) i;
      (j = i1) → rotLoop a (i ∧ ~ k)})
    (rotLoop (rotLoop a (~ i ∨ j)) i)

rotLoopEquiv : (i : I) → S¹ ≃ S¹
rotLoopEquiv i =
  isoToEquiv
    (iso (λ a → rotLoop a i)
         (λ a → rotLoop a (~ i))
         (λ a → rotLoopInv a i)
         (λ a → rotLoopInv a (~ i)))

-- some cancellation laws, used in the Hopf fibration
private
  rotInv-aux-1 : I → I → I → I → S¹
  rotInv-aux-1 j k i =
    hfill (λ l → λ { (k = i0) → (loop (i ∧ ~ l)) * loop j
                   ; (k = i1) → loop j
                   ; (i = i0) → (loop k * loop j) * loop (~ k)
                   ; (i = i1) → loop (~ k ∧ ~ l) * loop j })
          (inS ((loop (k ∨ i) * loop j) * loop (~ k)))

  rotInv-aux-2 : I → I → I → S¹
  rotInv-aux-2 i j k =
     hcomp (λ l → λ { (k = i0) → inv (filler-rot (~ i) (~ j) l)
                    ; (k = i1) → loop (j ∧ l)
                    ; (i = i0) → filler-rot k j l
                    ; (i = i1) → loop (j ∧ l)
                    ; (j = i0) → loop (i ∨ k ∨ (~ l))
                    ; (j = i1) → loop ((i ∨ k) ∧ l) })
           (base)

  rotInv-aux-3 : I → I → I → I → S¹
  rotInv-aux-3 j k i =
    hfill (λ l → λ { (k = i0) → rotInv-aux-2 i j l
                   ; (k = i1) → loop j
                   ; (i = i0) → loop (k ∨ l) * loop j
                   ; (i = i1) → loop k * (inv (loop (~ j) * loop k)) })
          (inS (loop k * (inv (loop (~ j) * loop (k ∨ ~ i)))))

  rotInv-aux-4 : I → I → I → I → S¹
  rotInv-aux-4 j k i =
    hfill (λ l → λ { (k = i0) → rotInv-aux-2 i j l
                   ; (k = i1) → loop j
                   ; (i = i0) → loop j * loop (k ∨ l)
                   ; (i = i1) → (inv (loop (~ j) * loop k)) * loop k })
          (inS ((inv (loop (~ j) * loop (k ∨ ~ i))) * loop k))

rotInv-1 : (a b : S¹) → b * a * inv b ≡ a
rotInv-1 base base i = base
rotInv-1 base (loop k) i = rotInv-aux-1 i0 k i i1
rotInv-1 (loop j) base i = loop j
rotInv-1 (loop j) (loop k) i = rotInv-aux-1 j k i i1

rotInv-2 : (a b : S¹) → inv b * a * b ≡ a
rotInv-2 base base i = base
rotInv-2 base (loop k) i = rotInv-aux-1 i0 (~ k) i i1
rotInv-2 (loop j) base i = loop j
rotInv-2 (loop j) (loop k) i = rotInv-aux-1 j (~ k) i i1

rotInv-3 : (a b : S¹) → b * (inv (inv a * b)) ≡ a
rotInv-3 base base i = base
rotInv-3 base (loop k) i = rotInv-aux-3 i0 k (~ i) i1
rotInv-3 (loop j) base i = loop j
rotInv-3 (loop j) (loop k) i = rotInv-aux-3 j k (~ i) i1

rotInv-4 : (a b : S¹) → inv (b * inv a) * b ≡ a
rotInv-4 base base i = base
rotInv-4 base (loop k) i = rotInv-aux-4 i0 k (~ i) i1
rotInv-4 (loop j) base i = loop j
rotInv-4 (loop j) (loop k) i = rotInv-aux-4 j k (~ i) i1