------------------------------------------------------------------------
-- The Agda standard library
--
-- Decision procedures for finite sets and subsets of finite sets
------------------------------------------------------------------------

module Data.Fin.Dec where

open import Function
import Data.Bool as Bool
open import Data.Nat hiding (_<_)
open import Data.Vec hiding (_∈_)
open import Data.Vec.Equality as VecEq
  using () renaming (module PropositionalEquality to PropVecEq)
open import Data.Fin
open import Data.Fin.Subset
open import Data.Fin.Subset.Properties
open import Data.Product as Prod
open import Data.Empty
open import Function
import Function.Equivalence as Eq
open import Relation.Binary as B
import Relation.Binary.HeterogeneousEquality as H
open import Relation.Nullary
import Relation.Nullary.Decidable as Dec
open import Relation.Unary as U using (Pred)

infix 4 _∈?_

_∈?_ : ∀ {n} x (p : Subset n) → Dec (x ∈ p)
zero  ∈? inside  ∷ p = yes here
zero  ∈? outside ∷ p = no  λ()
suc n ∈? s ∷ p       with n ∈? p
...                  | yes n∈p = yes (there n∈p)
...                  | no  n∉p = no  (n∉p ∘ drop-there)

private

  restrictP : ∀ {p n} → (Fin (suc n) → Set p) → (Fin n → Set p)
  restrictP P f = P (suc f)

  restrict : ∀ {p n} {P : Fin (suc n) → Set p} →
             U.Decidable P → U.Decidable (restrictP P)
  restrict dec f = dec (suc f)

any? : ∀ {n} {P : Fin n → Set} →
       U.Decidable P → Dec (∃ P)
any? {zero}      dec = no λ { (() , _) }
any? {suc n} {P} dec with dec zero | any? (restrict dec)
...                  | yes p | _            = yes (_ , p)
...                  | _     | yes (_ , p') = yes (_ , p')
...                  | no ¬p | no ¬p'       = no helper
  where
  helper : ∄ P
  helper (zero  , p)  = ¬p p
  helper (suc f , p') = ¬p' (_ , p')

nonempty? : ∀ {n} (p : Subset n) → Dec (Nonempty p)
nonempty? p = any? (λ x → x ∈? p)

private

  restrict∈ : ∀ {p q n}
              (P : Fin (suc n) → Set p) {Q : Fin (suc n) → Set q} →
              (∀ {f} → Q f → Dec (P f)) →
              (∀ {f} → restrictP Q f → Dec (restrictP P f))
  restrict∈ _ dec {f} Qf = dec {suc f} Qf

decFinSubset : ∀ {p q n} {P : Fin n → Set p} {Q : Fin n → Set q} →
               U.Decidable Q →
               (∀ {f} → Q f → Dec (P f)) →
               Dec (∀ {f} → Q f → P f)
decFinSubset {n = zero}          _    _    = yes λ{}
decFinSubset {n = suc n} {P} {Q} decQ decP = helper
  where
  helper : Dec (∀ {f} → Q f → P f)
  helper with decFinSubset (restrict decQ) (restrict∈ P decP)
  helper | no ¬q⟶p = no (λ q⟶p → ¬q⟶p (λ {f} q → q⟶p {suc f} q))
  helper | yes q⟶p with decQ zero
  helper | yes q⟶p | yes q₀ with decP q₀
  helper | yes q⟶p | yes q₀ | no ¬p₀ = no (λ q⟶p → ¬p₀ (q⟶p {zero} q₀))
  helper | yes q⟶p | yes q₀ | yes p₀ = yes (λ {_} → hlpr _)
    where
    hlpr : ∀ f → Q f → P f
    hlpr zero    _  = p₀
    hlpr (suc f) qf = q⟶p qf
  helper | yes q⟶p | no ¬q₀ = yes (λ {_} → hlpr _)
    where
    hlpr : ∀ f → Q f → P f
    hlpr zero    q₀ = ⊥-elim (¬q₀ q₀)
    hlpr (suc f) qf = q⟶p qf

all∈? : ∀ {n p} {P : Fin n → Set p} {q} →
        (∀ {f} → f ∈ q → Dec (P f)) →
        Dec (∀ {f} → f ∈ q → P f)
all∈? {q = q} dec = decFinSubset (λ f → f ∈? q) dec

all? : ∀ {n p} {P : Fin n → Set p} →
       U.Decidable P → Dec (∀ f → P f)
all? dec with all∈? {q = ⊤} (λ {f} _ → dec f)
...      | yes ∀p = yes (λ f → ∀p ∈⊤)
...      | no ¬∀p = no  (λ ∀p → ¬∀p (λ {f} _ → ∀p f))

decLift : ∀ {n} {P : Fin n → Set} →
          U.Decidable P → U.Decidable (Lift P)
decLift dec p = all∈? (λ {x} _ → dec x)

private

  restrictSP : ∀ {n} → Side → (Subset (suc n) → Set) → (Subset n → Set)
  restrictSP s P p = P (s ∷ p)

  restrictS : ∀ {n} {P : Subset (suc n) → Set} →
              (s : Side) → U.Decidable P → U.Decidable (restrictSP s P)
  restrictS s dec p = dec (s ∷ p)

anySubset? : ∀ {n} {P : Subset n → Set} →
             U.Decidable P → Dec (∃ P)
anySubset? {zero} {P} dec with dec []
... | yes P[] = yes (_ , P[])
... | no ¬P[] = no helper
  where
  helper : ∄ P
  helper ([] , P[]) = ¬P[] P[]
anySubset? {suc n} {P} dec with anySubset? (restrictS inside  dec)
                              | anySubset? (restrictS outside dec)
... | yes (_ , Pp) | _            = yes (_ , Pp)
... | _            | yes (_ , Pp) = yes (_ , Pp)
... | no ¬Pp       | no ¬Pp'      = no helper
    where
    helper : ∄ P
    helper (inside  ∷ p , Pp)  = ¬Pp  (_ , Pp)
    helper (outside ∷ p , Pp') = ¬Pp' (_ , Pp')

-- If a decidable predicate P over a finite set is sometimes false,
-- then we can find the smallest value for which this is the case.

¬∀⟶∃¬-smallest :
  ∀ n {p} (P : Fin n → Set p) → U.Decidable P →
  ¬ (∀ i → P i) → ∃ λ i → ¬ P i × ((j : Fin′ i) → P (inject j))
¬∀⟶∃¬-smallest zero    P dec ¬∀iPi = ⊥-elim (¬∀iPi (λ()))
¬∀⟶∃¬-smallest (suc n) P dec ¬∀iPi with dec zero
¬∀⟶∃¬-smallest (suc n) P dec ¬∀iPi | no ¬P0 = (zero , ¬P0 , λ ())
¬∀⟶∃¬-smallest (suc n) P dec ¬∀iPi | yes P0 =
  Prod.map suc (Prod.map id extend′) $
    ¬∀⟶∃¬-smallest n (λ n → P (suc n)) (dec ∘ suc) (¬∀iPi ∘ extend)
  where
  extend : (∀ i → P (suc i)) → (∀ i → P i)
  extend ∀iP[1+i] zero    = P0
  extend ∀iP[1+i] (suc i) = ∀iP[1+i] i

  extend′ : ∀ {i : Fin n} →
            ((j : Fin′ i) → P (suc (inject j))) →
            ((j : Fin′ (suc i)) → P (inject j))
  extend′ g zero    = P0
  extend′ g (suc j) = g j

-- Decision procedure for _⊆_ (obtained via the natural lattice
-- order).

infix 4 _⊆?_

_⊆?_ : ∀ {n} → B.Decidable (_⊆_ {n = n})
p₁ ⊆? p₂ =
  Dec.map (Eq.sym NaturalPoset.orders-equivalent) $
  Dec.map′ PropVecEq.to-≡ PropVecEq.from-≡ $
  VecEq.DecidableEquality._≟_ Bool.decSetoid p₁ (p₁ ∩ p₂)


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

module Data.Sigma.Base where

open import Agda.Builtin.Sigma
  using (Σ; _,_; fst; snd)
  public
open import Level

infixr 4.5 ∃-syntax
∃-syntax : ∀ {a b} {A : Type a} (B : A → Type b) → Type (a ℓ⊔ b)
∃-syntax {A = A} = Σ A

syntax ∃-syntax (λ x → e) = ∃ x × e

infixr 4.5 Σ⦂-syntax
Σ⦂-syntax : (A : Type a) (B : A → Type b) → Type (a ℓ⊔ b)
Σ⦂-syntax = Σ

syntax Σ⦂-syntax t (λ x → e) = Σ[ x ⦂ t ] × e

infixr 4.5 _×_
_×_ : (A : Type a) → (B : Type b) → Type (a ℓ⊔ b)
A × B = Σ A λ _ → B

curry : ∀ {A : Type a} {B : A → Type b} {C : Σ A B → Type c} →
          ((p : Σ A B) → C p) →
          ((x : A) → (y : B x) → C (x , y))
curry f x y = f (x , y)
{-# INLINE curry #-}

uncurry : ∀ {A : Type a} {B : A → Type b} {C : Σ A B → Type c} →
            ((x : A) → (y : B x) → C (x , y)) →
            ((p : Σ A B) → C p)
uncurry f (x , y) = f x y
{-# INLINE uncurry #-}

map-Σ : ∀ {p q} {P : A → Set p} {Q : B → Set q} →
        (f : A → B) → (∀ {x} → P x → Q (f x)) →
        Σ A P → Σ B Q
map-Σ f g (x , y) = f x , g y
{-# INLINE map-Σ #-}

map₁ : (A → B) → A × C → B × C
map₁ f = map-Σ f (λ x → x)
{-# INLINE map₁ #-}

map₁-Σ : ∀ {A : Set a} {B : Set b} {C : B → Set b}
       → (f : A → B) → Σ A (λ x → C (f x)) → Σ B C
map₁-Σ f (x , y) = f x , y
{-# INLINE map₁-Σ #-}

map₂ : ∀ {A : Set a} {B : A → Set b} {C : A → Set c} →
        (∀ {x} → B x → C x) → Σ A B → Σ A C
map₂ f = map-Σ (λ x → x) f
{-# INLINE map₂ #-}


{-# OPTIONS --verbose tc.constr.findInScope:20 #-}

module InstanceArgumentsConstraints where

data Bool : Set where
  true false : Bool

postulate A1 A2 B C : Set
          a1 : A1
          a2 : A2
          someF : A1 → C

record Class (R : Bool → Set) : Set where
  field f : (t : Bool) → R t

open Class {{...}}

class1 : Class (λ _ → A1)
class1 = record { f = λ _ → a1 }

class2 : Class (λ _ → A2)
class2 = record { f = λ _ → a2 }

test : C
test = someF (f true)


-- Andreas, 2012-06-05 let for record patterns

-- {-# OPTIONS --show-implicit #-}
-- {-# OPTIONS -v tc.term.let.pattern:100 #-}
-- {-# OPTIONS -v tc.lhs.top:100 #-}

module LetPair where

import Common.Level
open import Common.Equality

infixl 6 _×_
infixl 0 _,_

record _×_ (A B : Set) : Set where
  constructor _,_
  field
    fst : A
    snd : B
open _×_

swap : {A B : Set} → A × B → B × A
swap p =
  let (a , b) = p
  in  (b , a)

prop_swap : {A B : Set}{p : A × B} →
  (fst (swap p) ≡ snd p) ×
  (snd (swap p) ≡ fst p)
prop_swap = refl , refl

rot3 : {A B C : Set} → A × B × C → B × C × A
rot3 = λ t → let
      a , b , c = t
  in  b , c , a

postulate
  A B C : Set

rot3' = λ t → let
      x : A × B × C
      x = t
      a , b , c = x
  in  b , c , a

record ⊤ : Set where
  constructor tt

test = let tt , _ = tt , tt in A


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

open import Level using (_⊔_)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; cong; trans; subst₂)
open import Function using (_∘_)
open import Relation.Nullary.Negation using (contradiction)

module PiCalculus.Utils where

module ListInv {a} {A : Set a} where
  open import Data.List as List using (List; []; _∷_; [_]; _++_)
  import Data.List.Properties as Listₚ
  import Data.List.Membership.Propositional.Properties as ∈ₚ
  import Data.List.Relation.Unary.Any.Properties as Anyₚ
  open import Data.List.Relation.Unary.Any using (Any; here; there)
  open import Data.List.Membership.Propositional using (_∈_; _∉_)
  open import Data.List.Relation.Binary.Equality.Propositional {A = A} using (_≋_; []; _∷_; ≋⇒≡; ≡⇒≋; ≋-refl)

  inv-++ˡ' : ∀ lx ly {rx ry} s → s ∉ lx → s ∉ ly → lx ++ [ s ] ++ rx ≋ ly ++ [ s ] ++ ry → lx ≋ ly
  inv-++ˡ' [] [] s ∉lx ∉ly eq = []
  inv-++ˡ' [] (x ∷ ly) .x ∉lx ∉ly (refl ∷ eq) = contradiction (here refl) ∉ly
  inv-++ˡ' (x ∷ lx) [] .x ∉lx ∉ly (refl ∷ eq) = contradiction (here refl) ∉lx
  inv-++ˡ' (x ∷ lx) (.x ∷ ly) s ∉lx ∉ly (refl ∷ eq)
    rewrite ≋⇒≡ (inv-++ˡ' lx ly s (∉lx ∘ there) (∉ly ∘ there) eq) = ≋-refl

  inv-++ˡ : ∀ lx ly {rx ry} s → s ∉ lx → s ∉ ly → lx ++ [ s ] ++ rx ≡ ly ++ [ s ] ++ ry → lx ≡ ly
  inv-++ˡ lx ly s ∉lx ∉ly = ≋⇒≡ ∘ inv-++ˡ' lx ly s ∉lx ∉ly ∘ ≡⇒≋

  inv-++ʳ : ∀ lx ly {rx ry} s → s ∉ rx → s ∉ ry → lx ++ [ s ] ++ rx ≡ ly ++ [ s ] ++ ry → rx ≡ ry
  inv-++ʳ lx ly {rx} {ry} s ∉rx ∉ry
    = Listₚ.reverse-injective
    ∘ inv-++ˡ (List.reverse rx) (List.reverse ry) s (∉rx ∘ Anyₚ.reverse⁻) (∉ry ∘ Anyₚ.reverse⁻)
    ∘ subst₂ _≡_ (do-reverse lx _) (do-reverse ly _)
    ∘ cong List.reverse

    where do-reverse : ∀ (lx rx : List A) {s}
                     → List.reverse (lx ++ [ s ] ++ rx) ≡ List.reverse rx ++ [ s ] ++ List.reverse lx
          do-reverse lx rx {s} = trans (Listₚ.reverse-++-commute lx _)
                                       (trans (cong (_++ List.reverse lx) (Listₚ.unfold-reverse s rx))
                                              (Listₚ.++-assoc (List.reverse rx) _ _))


------------------------------------------------------------------------------
-- Co-inductive natural numbers
------------------------------------------------------------------------------

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

module GFPs.Conat where

open import FOTC.Base
open import FOTC.Base.PropertiesI

------------------------------------------------------------------------------
-- Conat is a greatest fixed-point of a functor

-- The functor.
NatF : (D → Set) → D → Set
NatF A n = n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')

-- The co-natural numbers are the greatest fixed-point of NatF.
postulate
  Conat : D → Set

  -- Conat is a post-fixed point of NatF, i.e.
  --
  -- Conat ≤ NatF Conat.
  Conat-out : ∀ {n} → Conat n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')

  -- The higher-order version.
  Conat-out-ho : ∀ {n} → Conat n → NatF Conat n

  -- Conat is the greatest post-fixed point of NatF, i.e.
  --
  -- ∀ A. A ≤ NatF A ⇒ A ≤ Conat.
  Conat-coind :
    (A : D → Set) →
    -- A is post-fixed point of ConatF.
    (∀ {n} → A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
    -- Conat is greater than A.
    ∀ {n} → A n → Conat n

  -- The higher-order version.
  Conat-coind-ho :
    (A : D → Set) → (∀ {n} → A n → NatF A n) → ∀ {n} → A n → Conat n

  -- 22 December 2013. This is a stronger induction principle. If we
  -- use it, we can use the trivial predicate A = λ x → x ≡ x in the
  -- proofs. Unfortunately, we don't have a justification/proof for
  -- this principle.
  Conat-stronger-coind₁ :
    ∀ (A : D → Set) {n} →
    (A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
    A n → Conat n

  -- Other stronger co-induction principle
  --
  -- Adapted from (Paulson, 1997. p. 16).
  Conat-stronger-coind₂ :
    (A : D → Set) →
    (∀ {n} → A n → (n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) ∨ Conat n) →
    ∀ {n} → A n → Conat n

------------------------------------------------------------------------------
-- Conat-out and Conat-out-ho are equivalents

Conat-out-fo : ∀ {n} → Conat n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')
Conat-out-fo = Conat-out-ho

Conat-out-ho' : ∀ {n} → Conat n → NatF Conat n
Conat-out-ho' = Conat-out

------------------------------------------------------------------------------
-- Conat-coind and Conat-coind-ho are equivalents

Conat-coind-fo :
  (A : D → Set) →
  (∀ {n} → A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
  ∀ {n} → A n → Conat n
Conat-coind-fo = Conat-coind-ho

Conat-coind-ho' :
  (A : D → Set) → (∀ {n} → A n → NatF A n) → ∀ {n} → A n → Conat n
Conat-coind-ho' = Conat-coind

------------------------------------------------------------------------------
-- Because a greatest post-fixed point is a fixed-point, then the
-- Conat predicate is also a pre-fixed point of the functional NatF,
-- i.e.
--
-- NatF Conat ≤ Conat.
Conat-in : ∀ {n} →
           n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n') →
           Conat n
Conat-in h = Conat-coind A h' h
  where
  A : D → Set
  A n = n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')

  h' : ∀ {n} → A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')
  h' (inj₁ n≡0)              = inj₁ n≡0
  h' (inj₂ (n' , prf , Cn')) = inj₂ (n' , prf , Conat-out Cn')

-- The higher-order version.
Conat-in-ho : ∀ {n} → NatF Conat n → Conat n
Conat-in-ho = Conat-in

-- A different definition.
Conat-in' : (∀ {n} → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')) →
            ∀ {n} → Conat n
Conat-in' h = Conat-coind (λ m → m ≡ m) (h' h) refl
  where
  h' : (∀ {n} → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')) →
       ∀ {m} → m ≡ m → m ≡ zero ∨ (∃[ m' ] m ≡ succ₁ m' ∧ m' ≡ m')
  h' h'' {m} _ with (h'' {m})
  ... | inj₁ m≡0            = inj₁ m≡0
  ... | inj₂ (m' , prf , _) = inj₂ (m' , prf , refl)

Conat-in-ho' : (∀ {n} → NatF Conat n) → ∀ {n} → Conat n
Conat-in-ho' = Conat-in'

------------------------------------------------------------------------------
-- From Conat-coind/Conat-stronger-coind₁ to Conat-stronger-coind₁/Conat-coind

Conat-coind'' :
  (A : D → Set) →
  (∀ {n} → A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
  ∀ {n} → A n → Conat n
Conat-coind'' A h An = Conat-stronger-coind₁ A h An

-- 22 December 2013: We couln't prove Conat-stronger-coind₁ using
-- Conat-coind.
Conat-stronger-coind₁' :
  ∀ (A : D → Set) {n} →
  (A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
  A n → Conat n
Conat-stronger-coind₁' A {n} h An = Conat-in (case prf₁ prf₂ (h An))
  where
  prf₁ : n ≡ zero → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')
  prf₁ n≡0 = inj₁ n≡0

  prf₂ : ∃[ n' ] n ≡ succ₁ n' ∧ A n' →
         n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ Conat n')
  prf₂ (n' , prf , An') = inj₂ (n' , prf , {!!})

------------------------------------------------------------------------------
-- From Conat-stronger-coind₂ to Conat-stronger-coind₁

-- 13 January 2014: We couln't prove Conat-stronger-coind₁ using
-- Conat-stronger-coind₂.
Conat-stronger-coind₁'' :
  ∀ (A : D → Set) {n} →
  (A n → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ A n')) →
  A n → Conat n
Conat-stronger-coind₁'' A h An = Conat-stronger-coind₂ A {!!} An

------------------------------------------------------------------------------
-- References
--
-- Paulson, L. C. (1997). Mechanizing Coinduction and Corecursion in
-- Higher-order Logic. Journal of Logic and Computation 7.2,
-- pp. 175–204.


------------------------------------------------------------------------------
-- PA properties
------------------------------------------------------------------------------

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

module PA.Axiomatic.Mendelson.PropertiesATP where

open import PA.Axiomatic.Mendelson.Base

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

+-leftIdentity : ∀ n → zero + n ≈ n
+-leftIdentity = S₅

-- See Issue https://github.com/asr/apia/issues/81 .
+-rightIdentityA : ℕ → Set
+-rightIdentityA i = i + zero ≈ i
{-# ATP definition +-rightIdentityA #-}

+-rightIdentity : ∀ n → n + zero ≈ n
+-rightIdentity = S₉ +-rightIdentityA A0 is
  where
  A0 : +-rightIdentityA zero
  A0 = +-leftIdentity zero

  postulate is : ∀ i → +-rightIdentityA i → +-rightIdentityA (succ i)
  {-# ATP prove is #-}

-- See Issue https://github.com/asr/apia/issues/81 .
x+Sy≈S[x+y]A : ℕ → ℕ → Set
x+Sy≈S[x+y]A n i = i + succ n ≈ succ (i + n)
{-# ATP definition x+Sy≈S[x+y]A #-}

x+Sy≈S[x+y] : ∀ m n → m + succ n ≈ succ (m + n)
x+Sy≈S[x+y] m n = S₉ (x+Sy≈S[x+y]A n) A0 is m
  where
  postulate A0 : x+Sy≈S[x+y]A n zero
  {-# ATP prove A0 #-}

  postulate is : ∀ i → x+Sy≈S[x+y]A n i → x+Sy≈S[x+y]A n (succ i)
  {-# ATP prove is #-}

-- See Issue https://github.com/asr/apia/issues/81 .
+-leftCongA : ℕ → ℕ → ℕ → Set
+-leftCongA m n i = m + i ≈ n + i
{-# ATP definition +-leftCongA #-}

+-leftCong : ∀ {m n o} → m ≈ n → m + o ≈ n + o
+-leftCong {m} {n} {o} h = S₉ (+-leftCongA m n) A0 is o
  where
  postulate A0 : +-leftCongA m n zero
  {-# ATP prove A0 +-rightIdentity #-}

  postulate is : ∀ i → +-leftCongA m n i → +-leftCongA m n (succ i)
  {-# ATP prove is x+Sy≈S[x+y] #-}

-- See Issue https://github.com/asr/apia/issues/81 .
+-commA : ℕ → ℕ → Set
+-commA n i = i + n ≈ n + i
{-# ATP definition +-commA #-}

+-comm : ∀ m n → m + n ≈ n + m
+-comm m n = S₉ (+-commA n) A0 is m
  where
  postulate A0 : +-commA n zero
  {-# ATP prove A0 +-rightIdentity #-}

  postulate is : ∀ i → +-commA n i → +-commA n (succ i)
  {-# ATP prove is x+Sy≈S[x+y] #-}

+-asocc : ∀ m n o → m + n + o ≈ m + (n + o)
+-asocc m n o = S₉ A A0 is m
  where
  A : ℕ → Set
  A i = i + n + o ≈ i + (n + o)
  {-# ATP definition A #-}

  postulate A0 : A zero
  {-# ATP prove A0 +-leftCong #-}

  postulate is : ∀ i → A i → A (succ i)
  {-# ATP prove is +-leftCong #-}


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

open import Categories.Category using (Category; module Commutation)
open import Categories.Category.Monoidal
open import Categories.Category.Monoidal.Braided using (Braided)

module Categories.Category.Monoidal.Braided.Properties
  {o ℓ e} {C : Category o ℓ e} {M : Monoidal C} (BM : Braided M) where

open import Data.Product using (_,_)

open import Categories.Category.Monoidal.Properties M
open import Categories.Category.Monoidal.Reasoning M
open import Categories.Category.Monoidal.Utilities M
open import Categories.Functor using (Functor)
open import Categories.Morphism C using (module ≅)
open import Categories.Morphism.IsoEquiv C using (_≃_; ⌞_⌟)
open import Categories.Morphism.Reasoning C hiding (push-eq)
open import Categories.NaturalTransformation.NaturalIsomorphism using (niHelper)
open import Categories.NaturalTransformation.NaturalIsomorphism.Properties
  using (push-eq)

open Category C
open Braided BM
open Commutation C

private
  variable
    X Y Z : Obj

  -- A shorthand for the braiding
  B : ∀ {X Y} → X ⊗₀ Y ⇒ Y ⊗₀ X
  B {X} {Y} = braiding.⇒.η (X , Y)

  -- It's easier to prove the following lemma, which is the desired
  -- coherence theorem moduolo application of the |-⊗ unit| functor.
  -- Because |-⊗ unit| is equivalent to the identity functor, the
  -- lemma and the theorem are equivalent.

  -- The following diagram illustrates the hexagon that we are
  -- operating on. The main outer hexagon is hexagon₁, the braiding
  -- coherence, instantiated with X, 1 and 1 (Here we denote the unit
  -- by 1 for brevity).
  -- In the middle are X1 and 1X along with morphisms towards them.
  -- The lower hexagon (given by the double lines) commutes and is
  -- an intermediary in the final proof. It is there to effectively
  -- get rid of the top half of the main hexagon.
  -- The rest of the proof is isolating the bottom left triangle
  -- which represents our desired identity. It is doing that by
  -- proving that the pentagon to the right of it commutes.
  -- The pentagon commuting is, in turn, proved by gluing the
  -- rightmost "square" onto the middle triangle.
  --
  --
  --       ┌─────>  X(11)  ─────────>  (11)X ──────┐
  --      ┌┘ α        │        B         │       α └┐
  --     ┌┘           │id⊗λ              │λ⊗id     └┐
  --    ┌┘            V                  V           V
  --  (X1)1 ═══════> X1  ════════════>  1X <══════ 1(1X)
  --    ╚╗   ρ⊗id     Λ <───┐  B              λ      Λ
  --     ╚╗           │λ⊗id └────────┐              ╔╝
  --      ╚╗          │           λ   └┐           ╔╝
  --       ╚═════>  (1X)1  ═════════>  1(X1)  ═════╝
  --       B⊗id                α                id⊗B

  braiding-coherence⊗unit : [ (X ⊗₀ unit) ⊗₀ unit ⇒ X ⊗₀ unit ]⟨
               B ⊗₁ id                       ⇒⟨ (unit ⊗₀ X) ⊗₀ unit ⟩
               unitorˡ.from ⊗₁ id
             ≈ unitorʳ.from ⊗₁ id
             ⟩
  braiding-coherence⊗unit = cancel-fromˡ braiding.FX≅GX (
    begin
      B ∘ unitorˡ.from ⊗₁ id ∘ B ⊗₁ id                               ≈⟨ pullˡ (⟺ (glue◽◃ unitorˡ-commute-from coherence₁)) ⟩
      (unitorˡ.from ∘ id ⊗₁ B ∘ associator.from) ∘ B ⊗₁ id           ≈⟨ assoc²' ⟩
      unitorˡ.from ∘ id ⊗₁ B ∘ associator.from ∘ B ⊗₁ id             ≈⟨ refl⟩∘⟨ hexagon₁ ⟩
      unitorˡ.from ∘ associator.from ∘ B ∘ associator.from            ≈⟨ pullˡ coherence₁ ⟩
      unitorˡ.from ⊗₁ id ∘ B ∘ associator.from                       ≈˘⟨ pushˡ (braiding.⇒.commute _) ⟩
      (B ∘ id ⊗₁ unitorˡ.from) ∘ associator.from                     ≈⟨ pullʳ triangle ⟩
      B ∘ unitorʳ.from ⊗₁ id
    ∎)

-- The desired theorem follows from |braiding-coherence⊗unit| by
-- translating it along the right unitor (which is a natural iso).

braiding-coherence : [ X ⊗₀ unit ⇒ X ]⟨
                       B              ⇒⟨ unit ⊗₀ X ⟩
                       unitorˡ.from
                     ≈ unitorʳ.from
                     ⟩
braiding-coherence = push-eq unitorʳ-naturalIsomorphism (begin
  (unitorˡ.from ∘ B) ⊗₁ id           ≈⟨ homomorphism ⟩
  (unitorˡ.from ⊗₁ id) ∘ (B ⊗₁ id)   ≈⟨ braiding-coherence⊗unit ⟩
  unitorʳ.from  ⊗₁ id                ∎)
  where open Functor (-⊗ unit)

-- Shorthands for working with isomorphisms.

open ≅ using () renaming (refl to idᵢ; sym to _⁻¹)
infixr 9 _∘ᵢ_
private
  _∘ᵢ_ = λ {A B C} f g → ≅.trans {A} {B} {C} g f
  Bᵢ   = braiding.FX≅GX
  B⁻¹  = λ {X} {Y} → braiding.⇐.η (X , Y)

-- Variants of the hexagon identities defined on isos.

hexagon₁-iso : idᵢ ⊗ᵢ Bᵢ ∘ᵢ associator ∘ᵢ Bᵢ {X , Y} ⊗ᵢ idᵢ {Z}  ≃
               associator ∘ᵢ Bᵢ {X , Y ⊗₀ Z} ∘ᵢ associator
hexagon₁-iso = ⌞ hexagon₁ ⌟

hexagon₂-iso : (Bᵢ ⊗ᵢ idᵢ ∘ᵢ associator ⁻¹) ∘ᵢ idᵢ {X} ⊗ᵢ Bᵢ {Y , Z} ≃
               (associator ⁻¹ ∘ᵢ Bᵢ {X ⊗₀ Y , Z}) ∘ᵢ associator ⁻¹
hexagon₂-iso = ⌞ hexagon₂ ⌟

-- A variants of the above coherence law defined on isos.

braiding-coherence-iso : unitorˡ ∘ᵢ Bᵢ ≃ unitorʳ {X}
braiding-coherence-iso = ⌞ braiding-coherence ⌟

-- The inverse of the braiding is also a braiding on M.

inv-Braided : Braided M
inv-Braided = record
  { braiding = niHelper (record
    { η       = λ _ → B⁻¹
    ; η⁻¹     = λ _ → B
    ; commute = λ{ (f , g) → braiding.⇐.commute (g , f) }
    ; iso     = λ{ (X , Y) → record
      { isoˡ = braiding.iso.isoʳ (Y , X)
      ; isoʳ = braiding.iso.isoˡ (Y , X) } }
    })
  ; hexagon₁ = _≃_.to-≈ hexagon₂-iso
  ; hexagon₂ = _≃_.to-≈ hexagon₁-iso
  }

-- A variant of the above coherence law for the inverse of the braiding.

inv-braiding-coherence : [ unit ⊗₀ X ⇒ X ]⟨
                           B⁻¹            ⇒⟨ X ⊗₀ unit ⟩
                           unitorʳ.from
                         ≈ unitorˡ.from
                         ⟩
inv-braiding-coherence = ⟺ (switch-fromtoʳ Bᵢ braiding-coherence)


{-# OPTIONS --safe #-}
module STLC.Denotational where

open import STLC.Syntax
open import STLC.Typing
open import Data.Nat using (ℕ; suc)
open import Data.Fin using (Fin) renaming (zero to fzero; suc to fsuc)
open import Data.Product using (_×_; _,_; proj₁; proj₂)
open import Data.Unit using (⊤; tt)

private
  variable
    n : ℕ
    Γ : Ctx n
    A : Type

⟦_⟧ : Type → Set
⟦ A ⇒ B ⟧ = ⟦ A ⟧ → ⟦ B ⟧
⟦ unit ⟧ = ⊤
⟦ A ×' B ⟧ = ⟦ A ⟧ × ⟦ B ⟧

data Env : Ctx n → Set where
  ∅ : Env ●
  ⟨_,_⟩ : Env Γ → ⟦ A ⟧ → Env (Γ ,- A)

lookup : Env {n} Γ → (v : Fin n) → ⟦ find Γ v ⟧
lookup ⟨ ρ , term ⟩ fzero = term
lookup ⟨ ρ , term ⟩ (fsuc n) = lookup ρ n

⟦_⟧⟨_⟩ : ∀ {term : Term n} {type : Type} → (Γ ⊢ term ∈ type) → Env Γ → ⟦ type ⟧
⟦ ty-abs body ⟧⟨ ρ ⟩ = λ x → ⟦ body ⟧⟨ ⟨ ρ , x ⟩ ⟩
⟦ ty-app f x ⟧⟨ ρ ⟩ = ⟦ f ⟧⟨ ρ ⟩ ⟦ x ⟧⟨ ρ ⟩
⟦ ty-var v ⟧⟨ ρ ⟩ = lookup ρ v
⟦ ty-⋆ ⟧⟨ _ ⟩ = tt
⟦ ty-pair l r ⟧⟨ ρ ⟩ = ⟦ l ⟧⟨ ρ ⟩ , ⟦ r ⟧⟨ ρ ⟩
⟦ ty-projₗ p ⟧⟨ ρ ⟩ = proj₁ ⟦ p ⟧⟨ ρ ⟩
⟦ ty-projᵣ p ⟧⟨ ρ ⟩ = proj₂ ⟦ p ⟧⟨ ρ ⟩


------------------------------------------------------------------------
-- The Agda standard library
--
-- Pointwise lifting of binary relations to sigma types
------------------------------------------------------------------------

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

module Data.Product.Relation.Binary.Pointwise.Dependent where

open import Data.Product as Prod
open import Level
open import Function
open import Relation.Binary as B
  using (_⇒_; Setoid; IsEquivalence)
open import Relation.Binary.Indexed.Heterogeneous as I
  using (IREL; IRel; IndexedSetoid; IsIndexedEquivalence)
open import Relation.Binary.PropositionalEquality as P using (_≡_)

------------------------------------------------------------------------
-- Pointwise lifting

infixr 4 _,_

record POINTWISE {a₁ a₂ b₁ b₂ ℓ₁ ℓ₂}
                 {A₁ : Set a₁} (B₁ : A₁ → Set b₁)
                 {A₂ : Set a₂} (B₂ : A₂ → Set b₂)
                 (_R₁_ : B.REL A₁ A₂ ℓ₁) (_R₂_ : IREL B₁ B₂ ℓ₂)
                 (xy₁ : Σ A₁ B₁) (xy₂ : Σ A₂ B₂)
                 : Set (a₁ ⊔ a₂ ⊔ b₁ ⊔ b₂ ⊔ ℓ₁ ⊔ ℓ₂) where
  constructor _,_
  field
    proj₁ : (proj₁ xy₁) R₁ (proj₁ xy₂)
    proj₂ : (proj₂ xy₁) R₂ (proj₂ xy₂)

open POINTWISE public

Pointwise : ∀ {a b ℓ₁ ℓ₂} {A : Set a} (B : A → Set b)
            (_R₁_ : B.Rel A ℓ₁) (_R₂_ : IRel B ℓ₂) → B.Rel (Σ A B) _
Pointwise B = POINTWISE B B

------------------------------------------------------------------------
-- Pointwise preserves many relational properties

module _ {a b ℓ₁ ℓ₂} {A : Set a} {B : A → Set b}
         {R : B.Rel A ℓ₁} {S : IRel B ℓ₂} where

  private
    R×S = Pointwise B R S

  refl : B.Reflexive R → I.Reflexive B S → B.Reflexive R×S
  refl refl₁ refl₂ = (refl₁ , refl₂)

  symmetric : B.Symmetric R → I.Symmetric B S → B.Symmetric R×S
  symmetric sym₁ sym₂ (x₁Rx₂ , y₁Ry₂) = (sym₁ x₁Rx₂ , sym₂ y₁Ry₂)

  transitive : B.Transitive R → I.Transitive B S → B.Transitive R×S
  transitive trans₁ trans₂ (x₁Rx₂ , y₁Ry₂) (x₂Rx₃ , y₂Ry₃) =
    (trans₁ x₁Rx₂ x₂Rx₃ , trans₂ y₁Ry₂ y₂Ry₃)

  isEquivalence : IsEquivalence R → IsIndexedEquivalence B S →
                  IsEquivalence R×S
  isEquivalence eq₁ eq₂ = record
    { refl  = refl       Eq.refl  IEq.refl
    ; sym   = symmetric  Eq.sym   IEq.sym
    ; trans = transitive Eq.trans IEq.trans
    } where
    module Eq = IsEquivalence eq₁
    module IEq = IsIndexedEquivalence eq₂

module _ {a b ℓ₁ ℓ₂} where

  setoid : (A : Setoid a ℓ₁) →
           IndexedSetoid (Setoid.Carrier A) b ℓ₂ →
           Setoid _ _
  setoid s₁ s₂ = record
    { isEquivalence = isEquivalence Eq.isEquivalence IEq.isEquivalence
    } where
    module Eq = Setoid s₁
    module IEq = IndexedSetoid s₂

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

-- Version 0.15

Rel = Pointwise
{-# WARNING_ON_USAGE Rel
"Warning: Rel was deprecated in v0.15.
Please use Pointwise instead."
#-}

-- Version 0.15

REL = POINTWISE
{-# WARNING_ON_USAGE REL
"Warning: REL was deprecated in v1.0.
Please use POINTWISE instead."
#-}


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

module Categories.Object.Product.Core {o ℓ e} (𝒞 : Category o ℓ e) where

open import Level
open import Function using (flip; _$_)

open import Categories.Morphism 𝒞
open import Categories.Morphism.Reasoning 𝒞

open Category 𝒞
open HomReasoning

private
  variable
    A B C D X Y Z : Obj
    h i j : A ⇒ B

-- Borrowed from Dan Doel's definition of products
record Product (A B : Obj) : Set (o ⊔ ℓ ⊔ e) where

  infix 10 ⟨_,_⟩

  field
    A×B   : Obj
    π₁    : A×B ⇒ A
    π₂    : A×B ⇒ B
    ⟨_,_⟩ : C ⇒ A → C ⇒ B → C ⇒ A×B

    project₁ : π₁ ∘ ⟨ h , i ⟩ ≈ h
    project₂ : π₂ ∘ ⟨ h , i ⟩ ≈ i
    unique   : π₁ ∘ h ≈ i → π₂ ∘ h ≈ j → ⟨ i , j ⟩ ≈ h

  g-η : ⟨ π₁ ∘ h , π₂ ∘ h ⟩ ≈ h
  g-η = unique refl refl

  η : ⟨ π₁ , π₂ ⟩ ≈ id
  η = unique identityʳ identityʳ

  ⟨⟩-cong₂ : ∀ {f f′ : C ⇒ A} {g g′ : C ⇒ B} → f ≈ f′ → g ≈ g′ → ⟨ f , g ⟩ ≈ ⟨ f′ , g′ ⟩
  ⟨⟩-cong₂ f≡f′ g≡g′ = unique (project₁ ○ ⟺ f≡f′) (project₂ ○ ⟺ g≡g′)

  ∘-distribʳ-⟨⟩ : ∀ {f : C ⇒ A} {g : C ⇒ B} {q : D ⇒ C} → ⟨ f , g ⟩ ∘ q ≈ ⟨ f ∘ q , g ∘ q ⟩
  ∘-distribʳ-⟨⟩ = ⟺ $ unique (pullˡ project₁) (pullˡ project₂)

  unique′ : π₁ ∘ h ≈ π₁ ∘ i → π₂ ∘ h ≈ π₂ ∘ i → h ≈ i
  unique′ eq₁ eq₂ = trans (sym (unique eq₁ eq₂)) g-η

module _ {A B : Obj} where
  open Product {A} {B} renaming (⟨_,_⟩ to _⟨_,_⟩)

  repack : (p₁ p₂ : Product A B) → A×B p₁ ⇒ A×B p₂
  repack p₁ p₂ = p₂ ⟨ π₁ p₁ , π₂ p₁ ⟩

  repack∘ : (p₁ p₂ p₃ : Product A B) → repack p₂ p₃ ∘ repack p₁ p₂ ≈ repack p₁ p₃
  repack∘ p₁ p₂ p₃ = ⟺ $ unique p₃
    (glueTrianglesʳ (project₁ p₃) (project₁ p₂))
    (glueTrianglesʳ (project₂ p₃) (project₂ p₂))

  repack≡id : (p : Product A B) → repack p p ≈ id
  repack≡id = η

  repack-cancel : (p₁ p₂ : Product A B) → repack p₁ p₂ ∘ repack p₂ p₁ ≈ id
  repack-cancel p₁ p₂ = repack∘ p₂ p₁ p₂ ○ repack≡id p₂

up-to-iso : ∀ (p₁ p₂ : Product A B) → Product.A×B p₁ ≅ Product.A×B p₂
up-to-iso p₁ p₂ = record
  { from = repack p₁ p₂
  ; to   = repack p₂ p₁
  ; iso  = record
    { isoˡ = repack-cancel p₂ p₁
    ; isoʳ = repack-cancel p₁ p₂
    }
  }

transport-by-iso : ∀ (p : Product A B) → ∀ {X} → Product.A×B p ≅ X → Product A B
transport-by-iso p {X} p≅X = record
  { A×B = X
  ; π₁ = π₁ ∘ to
  ; π₂ = π₂ ∘ to
  ; ⟨_,_⟩ = λ h₁ h₂ → from ∘ ⟨ h₁ , h₂ ⟩
  ; project₁ = cancelInner isoˡ ○ project₁
  ; project₂ = cancelInner isoˡ ○ project₂
  ; unique = λ {_ i l r} pf₁ pf₂ → begin
    from ∘ ⟨ l , r ⟩                         ≈˘⟨ refl⟩∘⟨ ⟨⟩-cong₂ pf₁ pf₂ ⟩
    from ∘ ⟨ (π₁ ∘ to) ∘ i , (π₂ ∘ to) ∘ i ⟩ ≈⟨ refl⟩∘⟨ unique (⟺ assoc) (⟺ assoc) ⟩
    from ∘ to ∘ i                           ≈⟨ cancelˡ isoʳ ⟩
    i                                        ∎
  }
  where open Product p
        open _≅_ p≅X

Reversible : (p : Product A B) → Product B A
Reversible p = record
  { A×B       = A×B
  ; π₁        = π₂
  ; π₂        = π₁
  ; ⟨_,_⟩     = flip ⟨_,_⟩
  ; project₁  = project₂
  ; project₂  = project₁
  ; unique = flip unique
  }
  where open Product p

Commutative : (p₁ : Product A B) (p₂ : Product B A) → Product.A×B p₁ ≅ Product.A×B p₂
Commutative p₁ p₂ = up-to-iso p₁ (Reversible p₂)

Associable : ∀ (p₁ : Product X Y) (p₂ : Product Y Z) (p₃ : Product X (Product.A×B p₂)) → Product (Product.A×B p₁) Z
Associable p₁ p₂ p₃ = record
  { A×B       = A×B p₃
  ; π₁        = p₁ ⟨ π₁ p₃ , π₁ p₂ ∘ π₂ p₃ ⟩
  ; π₂        = π₂ p₂ ∘ π₂ p₃
  ; ⟨_,_⟩     = λ f g → p₃ ⟨ π₁ p₁ ∘ f , p₂ ⟨ π₂ p₁ ∘ f , g ⟩ ⟩
  ; project₁  = λ {_ f g} → begin
    p₁ ⟨ π₁ p₃ , π₁ p₂ ∘ π₂ p₃ ⟩ ∘ p₃ ⟨ π₁ p₁ ∘ f , p₂ ⟨ π₂ p₁ ∘ f , g ⟩ ⟩ ≈⟨ ∘-distribʳ-⟨⟩ p₁ ⟩
    p₁ ⟨ π₁ p₃ ∘ p₃ ⟨ π₁ p₁ ∘ f , p₂ ⟨ π₂ p₁ ∘ f , g ⟩ ⟩
       , (π₁ p₂ ∘ π₂ p₃) ∘ p₃ ⟨ π₁ p₁ ∘ f , p₂ ⟨ π₂ p₁ ∘ f , g ⟩ ⟩ ⟩       ≈⟨ ⟨⟩-cong₂ p₁ (project₁ p₃) (glueTrianglesˡ (project₁ p₂) (project₂ p₃)) ⟩
    p₁ ⟨ π₁ p₁ ∘ f , π₂ p₁ ∘ f ⟩                                           ≈⟨ g-η p₁ ⟩
    f                                                                      ∎
  ; project₂  = λ {_ f g} → glueTrianglesˡ (project₂ p₂) (project₂ p₃)
  ; unique = λ {_ i f g} pf₁ pf₂ → begin
    p₃ ⟨ π₁ p₁ ∘ f , p₂ ⟨ π₂ p₁ ∘ f , g ⟩ ⟩             ≈⟨ ⟨⟩-cong₂ p₃ (∘-resp-≈ʳ (sym pf₁))
                                                          (⟨⟩-cong₂ p₂ (∘-resp-≈ʳ (sym pf₁)) (sym pf₂)) ⟩
    p₃ ⟨ π₁ p₁ ∘ p₁ ⟨ π₁ p₃ , π₁ p₂ ∘ π₂ p₃ ⟩ ∘ i
       , p₂ ⟨ π₂ p₁ ∘ p₁ ⟨ π₁ p₃ , π₁ p₂ ∘ π₂ p₃ ⟩ ∘ i
            , (π₂ p₂ ∘ π₂ p₃) ∘ i ⟩ ⟩                   ≈⟨ ⟨⟩-cong₂ p₃ (pullˡ (project₁ p₁))
                                                          (⟨⟩-cong₂ p₂ (trans (pullˡ (project₂ p₁)) assoc)
                                                                       assoc) ⟩
    p₃ ⟨ π₁ p₃ ∘ i
       , p₂ ⟨ π₁ p₂ ∘ π₂ p₃ ∘ i , π₂ p₂ ∘ π₂ p₃ ∘ i ⟩ ⟩ ≈⟨ ⟨⟩-cong₂ p₃ refl (g-η p₂) ⟩
    p₃ ⟨ π₁ p₃ ∘ i , π₂ p₃ ∘ i ⟩                        ≈⟨ g-η p₃ ⟩
    i                                                   ∎
  }
  where open Product renaming (⟨_,_⟩ to _⟨_,_⟩)

Associative : ∀ (p₁ : Product X Y) (p₂ : Product Y Z)
                (p₃ : Product X (Product.A×B p₂)) (p₄ : Product (Product.A×B p₁) Z) →
                (Product.A×B p₃) ≅ (Product.A×B p₄)
Associative p₁ p₂ p₃ p₄ = up-to-iso (Associable p₁ p₂ p₃) p₄

Mobile : ∀ {A₁ B₁ A₂ B₂} (p : Product A₁ B₁) → A₁ ≅ A₂ → B₁ ≅ B₂ → Product A₂ B₂
Mobile p A₁≅A₂ B₁≅B₂ = record
  { A×B              = A×B
  ; π₁               = from A₁≅A₂ ∘ π₁
  ; π₂               = from B₁≅B₂ ∘ π₂
  ; ⟨_,_⟩            = λ h k → ⟨ to A₁≅A₂ ∘ h , to B₁≅B₂ ∘ k ⟩
  ; project₁         = begin
    (from A₁≅A₂ ∘ π₁) ∘ ⟨ to A₁≅A₂ ∘ _ , to B₁≅B₂ ∘ _ ⟩ ≈⟨ pullʳ project₁ ⟩
    from A₁≅A₂ ∘ (to A₁≅A₂ ∘ _)                         ≈⟨ cancelˡ (isoʳ A₁≅A₂) ⟩
    _                                                   ∎
  ; project₂         = begin
    (from B₁≅B₂ ∘ π₂) ∘ ⟨ to A₁≅A₂ ∘ _ , to B₁≅B₂ ∘ _ ⟩ ≈⟨ pullʳ project₂ ⟩
    from B₁≅B₂ ∘ (to B₁≅B₂ ∘ _)                         ≈⟨ cancelˡ (isoʳ B₁≅B₂) ⟩
    _                                                   ∎
  ; unique        = λ pfˡ pfʳ → unique (switch-fromtoˡ A₁≅A₂ (⟺ assoc ○ pfˡ))
                                       (switch-fromtoˡ B₁≅B₂ (⟺ assoc ○ pfʳ))
  }
  where open Product p
        open _≅_


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

module Data.Bits.Order.Reverse where

open import Prelude
open import Data.Bits

-- Least significant bit first

infix 4 _≲ᴮ_&_
_≲ᴮ_&_ : Bits → Bits → Bool → Bool
[]    ≲ᴮ ys    & true  = true
[]    ≲ᴮ []    & false = false
[]    ≲ᴮ 0∷ ys & false = true
[]    ≲ᴮ 1∷ ys & false = true
0∷ xs ≲ᴮ []    & s     = false
0∷ xs ≲ᴮ 0∷ ys & s     = xs ≲ᴮ ys & s
0∷ xs ≲ᴮ 1∷ ys & s     = xs ≲ᴮ ys & true
1∷ xs ≲ᴮ []    & s     = false
1∷ xs ≲ᴮ 0∷ ys & s     = xs ≲ᴮ ys & false
1∷ xs ≲ᴮ 1∷ ys & s     = xs ≲ᴮ ys & s

infix 4 _≤ᴮ_ _<ᴮ_
_≤ᴮ_ : Bits → Bits → Bool
xs ≤ᴮ ys = xs ≲ᴮ ys & true

_<ᴮ_ : Bits → Bits → Bool
xs <ᴮ ys = xs ≲ᴮ ys & false

infix 4 _≤_ _<_
_≤_ : Bits → Bits → Type
xs ≤ ys = T (xs ≤ᴮ ys)

_<_ : Bits → Bits → Type
xs < ys = T (xs <ᴮ ys)


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

open import Cubical.Foundations.Everything renaming (_⁻¹ to _⁻¹ᵖ; assoc to ∙-assoc)
open import Function.Base using (_∋_)
open import MorePropAlgebra.Bundles

import Cubical.Algebra.AbGroup as Std

module MorePropAlgebra.Properties.AbGroup {ℓ} (assumptions : AbGroup {ℓ}) where
open AbGroup assumptions renaming (Carrier to G)

import MorePropAlgebra.Properties.Group
module Group'Properties = MorePropAlgebra.Properties.Group   (record { AbGroup assumptions })
module Group'           =                            Group   (record { AbGroup assumptions })
(      Group')          =                            Group ∋ (record { AbGroup assumptions })

stdIsAbGroup : Std.IsAbGroup 0g _+_ (-_)
stdIsAbGroup  .Std.IsAbGroup.isGroup = Group'Properties.stdIsGroup
stdIsAbGroup  .Std.IsAbGroup.comm    = is-comm

stdAbGroup : Std.AbGroup {ℓ}
stdAbGroup = record { AbGroup assumptions ; isAbGroup = stdIsAbGroup }


module Data.Num.Binary where

-- open import Data.Product using (_×_; Σ; _,_)
open import Data.List
open import Data.Unit
open import Data.Empty
-- open import Data.Nat renaming (_+_ to _⊹_)
--
-- data Bin : Set where
--     [] : Bin
--     0- : Bin → Bin
--     1- : Bin → Bin
--
-- carry : Bin → Bin
-- carry [] = 1- []
-- carry (0- xs) = 1- xs
-- carry (1- xs) = 0- (carry xs)
--
-- _+_ : Bin → Bin → Bin
-- [] + ys = ys
-- xs + [] = xs
-- 0- xs + 0- ys = 0- (xs + ys)
-- 0- xs + 1- ys = 1- (xs + ys)
-- 1- xs + 0- ys = 1- (xs + ys)
-- 1- xs + 1- ys = 0- (carry (xs + ys))
--

-- data Desc : Set₁ where
--     arg : (A : Set)             -- a bag of tags to choose constructors with
--         → (A → Desc)            -- given a tag, return the description of the constructor it corresponds to
--         → Desc
--     rec : Desc → Desc           -- recursive subnode
--     ret : Desc                  -- stop
--
-- -- the "decoder", "interpreter"
-- -- ⟦_⟧ : Desc → Set → Set
-- -- ⟦ arg A D ⟧ R = Σ A (λ a → ⟦ D a ⟧ R)
-- -- ⟦ rec D   ⟧ R = R × ⟦ D ⟧ R
-- -- ⟦ ret     ⟧ R = ⊤

-- data BinF : Set where
--     arg : (ℕ → BinF) → BinF
--     rec : BinF → BinF
--     ret : BinF
--
-- ⟦_⟧ : BinF → Set → Set
-- ⟦_⟧ (arg F) X = Σ ℕ (λ n → ⟦ F n ⟧ X)
-- ⟦_⟧ (rec F) X = X × ⟦ F ⟧ X
-- ⟦_⟧ ret X = ⊤
--
-- data μ (F : BinF) : Set where
--     ⟨_⟩ : ⟦ F ⟧ (μ F) → μ F
--
-- Bin : Set
-- Bin = μ (arg {! λ   !})

--
-- data Digit : Set where
--     [0] : Digit
--     [1] : Digit
--
-- Binary : Set
-- Binary = List Digit
--
-- _⊕_ : Digit → Digit → Digit
-- [0] ⊕ [0] = [0]
-- [0] ⊕ [1] = [1]
-- [1] ⊕ [0] = [1]
-- [1] ⊕ [1] = [0]
--
-- _⊚_ : Digit → Digit → Digit
-- [1] ⊚ [1] = [1]
-- _   ⊚ _   = [0]
--
-- carry : Digit → Binary → Binary
-- carry [0] ys = ys
-- carry [1] [] = [1] ∷ []
-- carry [1] ([0] ∷ ys) = [1] ∷ ys
-- carry [1] ([1] ∷ ys) = [0] ∷ carry [1] ys
--
-- _+_ : Binary → Binary → Binary
-- [] + ys = ys
-- xs + [] = xs
-- (x ∷ xs) + (y ∷ ys) = x ⊕ y ∷ carry (x ⊚ y) (xs + ys)
--
-- _≈_ : Binary → Binary → Set
-- [] ≈ [] = ⊤
-- [] ≈ (y ∷ ys) = ⊥
-- (x ∷ xs) ≈ [] = ⊥
-- ([0] ∷ xs) ≈ ([0] ∷ ys) = xs ≈ ys
-- ([0] ∷ xs) ≈ ([1] ∷ ys) = ⊥
-- ([1] ∷ xs) ≈ ([0] ∷ ys) = ⊥
-- ([1] ∷ xs) ≈ ([1] ∷ ys) = xs ≈ ys

data Bin : Set where
    ∙ : Bin
    [0]_ : Bin → Bin
    [1]_ : Bin → Bin

two : Bin
two = [1] [0] ∙

1+ : Bin → Bin
1+ ∙ = [1] ∙
1+ ([0] x) = [1] x
1+ ([1] x) = [0] 1+ x

_+_ : Bin → Bin → Bin
∙ + ys = ys
xs + ∙ = xs
([0] xs) + ([0] ys) = [0] (xs + ys)
([0] xs) + ([1] ys) = [1] (xs + ys)
([1] xs) + ([0] ys) = [1] (xs + ys)
([1] xs) + ([1] ys) = [0] (1+ (xs + ys))


{-# OPTIONS --without-K --safe #-}
module Categories.NaturalTransformation where

-- all the important stuff about NaturalTransformation are defined in .Core

open import Categories.NaturalTransformation.Core public


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Algebra.Ring.Kernel where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Structure
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Powerset

open import Cubical.Algebra.Ring.Base
open import Cubical.Algebra.Ring.Properties
open import Cubical.Algebra.Ring.Ideal

private
  variable
    ℓ : Level

module _ {{R S : Ring {ℓ}}} (f′ : RingHom R S) where
  open RingHom f′
  open HomTheory f′
  open RingStr ⦃...⦄
  open isIdeal
  open Theory
  private
    instance
      _ = R
      _ = S
      _ = snd R
      _ = snd S

  kernel : ⟨ R ⟩ → hProp ℓ
  kernel x = (f x ≡ 0r) , isSetRing S _ _

  kernelIsIdeal : isIdeal R kernel
  +-closed kernelIsIdeal =
    λ fx≡0 fy≡0 → f (_ + _)  ≡⟨ isHom+ _ _ ⟩
                  f _ + f _  ≡⟨ cong (λ u → u + f _) fx≡0 ⟩
                  0r + f _   ≡⟨ cong (λ u → 0r + u) fy≡0 ⟩
                  0r + 0r    ≡⟨ 0-idempotent S ⟩
                  0r ∎
  -closed kernelIsIdeal =
    λ fx≡0 → f (- _)  ≡⟨ -commutesWithHom _ ⟩
             - f _    ≡⟨ cong -_ fx≡0 ⟩
             - 0r     ≡⟨ 0-selfinverse S ⟩
             0r       ∎
  0r-closed kernelIsIdeal = f 0r ≡⟨ homPres0 ⟩ 0r ∎
  ·-closedLeft kernelIsIdeal = λ r fx≡0 →
    f (r · _)    ≡⟨ isHom· _ _ ⟩
    f r · f (_)  ≡⟨ cong (λ u → f r · u) fx≡0 ⟩
    f r · 0r     ≡⟨ 0-rightNullifies S _ ⟩
    0r ∎
  ·-closedRight kernelIsIdeal = λ r fx≡0 →
    f (_ · r)    ≡⟨ isHom· _ _ ⟩
    f _ · f r     ≡⟨ cong (λ u → u · f r) fx≡0 ⟩
    0r · f r      ≡⟨ 0-leftNullifies S _ ⟩
    0r ∎


{-# OPTIONS --without-K --exact-split --allow-unsolved-metas #-}

module 17-groups where

import 16-sets
open 16-sets public

-- Section 12.3 Groups in univalent mathematics

{- We first introduce semi-groups, and then groups. We do this because the
   category of groups is a full subcategory of the category of semi-groups.
   In particular, it is a proposition for a semi-group to be a group. Therefore
   this approach gives us in a straightforward way that equality of groups is
   equality of semi-groups. This will be useful in showing that group
   isomorphisms are equivalent to identifications of groups. -}

has-associative-mul :
  {l : Level} (X : UU-Set l) → UU l
has-associative-mul X =
  Σ ( ( type-Set X) →
      ( ( type-Set X) → (type-Set X))) (λ μ →
    ( x y z : type-Set X) → Id (μ (μ x y) z) (μ x (μ y z)))

Semi-Group :
  (l : Level) → UU (lsuc l)
Semi-Group l = Σ (UU-Set l) has-associative-mul

{- Bureaucracy of semi-groups. -}

set-Semi-Group :
  {l : Level} → Semi-Group l → UU-Set l
set-Semi-Group G = pr1 G

type-Semi-Group :
  {l : Level} → Semi-Group l → UU l
type-Semi-Group G = pr1 (set-Semi-Group G)

is-set-type-Semi-Group :
  {l : Level} (G : Semi-Group l) → is-set (type-Semi-Group G)
is-set-type-Semi-Group G = pr2 (set-Semi-Group G)

associative-mul-Semi-Group :
  {l : Level} (G : Semi-Group l) →
  has-associative-mul (set-Semi-Group G)
associative-mul-Semi-Group G = pr2 G

mul-Semi-Group :
  {l : Level} (G : Semi-Group l) →
  type-Semi-Group G →
    type-Semi-Group G → type-Semi-Group G
mul-Semi-Group G = pr1 (associative-mul-Semi-Group G)

is-associative-mul-Semi-Group :
  {l : Level} (G : Semi-Group l) (x y z : type-Semi-Group G) →
  Id ( mul-Semi-Group G (mul-Semi-Group G x y) z)
     ( mul-Semi-Group G x (mul-Semi-Group G y z))
is-associative-mul-Semi-Group G = pr2 (associative-mul-Semi-Group G)

{- The property that a semi-group is a monoid is just that the semi-group
   possesses a unit that satisfies the left and right unit laws. -}

is-unital :
  {l : Level} → Semi-Group l → UU l
is-unital G =
  Σ ( type-Semi-Group G)
    ( λ e →
      ( (y : type-Semi-Group G) → Id (mul-Semi-Group G e y) y) ×
      ( (x : type-Semi-Group G) → Id (mul-Semi-Group G x e) x))

{- We show that is-unital is a proposition. -}

abstract
  is-prop-is-unital' :
    {l : Level} (G : Semi-Group l) → is-prop' (is-unital G)
  is-prop-is-unital' (pair (pair X is-set-X) (pair μ assoc-μ))
    (pair e (pair left-unit-e right-unit-e))
    (pair e' (pair left-unit-e' right-unit-e')) =
    eq-subtype
      ( λ e → is-prop-prod
        ( is-prop-Π (λ y → is-set-X (μ e y) y))
        ( is-prop-Π (λ x → is-set-X (μ x e) x)))
      ( (inv (left-unit-e' e)) ∙ (right-unit-e e'))

abstract
  is-prop-is-unital :
    {l : Level} (G : Semi-Group l) → is-prop (is-unital G)
  is-prop-is-unital G = is-prop-is-prop' (is-prop-is-unital' G)

{- The property that a monoid is a group is just the property that the monoid
   that every element is invertible, i.e., it comes equipped with an inverse
   operation that satisfies the left and right inverse laws. -}

is-group' :
  {l : Level} (G : Semi-Group l) → is-unital G → UU l
is-group' G is-unital-G =
  Σ ( type-Semi-Group G → type-Semi-Group G)
    ( λ i →
      ( (x : type-Semi-Group G) →
        Id (mul-Semi-Group G (i x) x) (pr1 is-unital-G)) ×
      ( (x : type-Semi-Group G) →
        Id (mul-Semi-Group G x (i x)) (pr1 is-unital-G)))

is-group :
  {l : Level} (G : Semi-Group l) → UU l
is-group G =
  Σ (is-unital G) (is-group' G)

Group :
  (l : Level) → UU (lsuc l)
Group l = Σ (Semi-Group l) is-group

{- Some bureaucracy of Groups. -}

semi-group-Group :
  {l : Level} → Group l → Semi-Group l
semi-group-Group G = pr1 G

set-Group :
  {l : Level} → Group l → UU-Set l
set-Group G = pr1 (semi-group-Group G)

type-Group :
  {l : Level} → Group l → UU l
type-Group G = pr1 (set-Group G)

is-set-type-Group :
  {l : Level} (G : Group l) → is-set (type-Group G)
is-set-type-Group G = pr2 (set-Group G)

associative-mul-Group :
  {l : Level} (G : Group l) → has-associative-mul (set-Group G)
associative-mul-Group G = pr2 (semi-group-Group G)

mul-Group :
  {l : Level} (G : Group l) →
  type-Group G → type-Group G → type-Group G
mul-Group G = pr1 (associative-mul-Group G)

is-associative-mul-Group :
  {l : Level} (G : Group l) (x y z : type-Group G) →
  Id (mul-Group G (mul-Group G x y) z) (mul-Group G x (mul-Group G y z))
is-associative-mul-Group G = pr2 (associative-mul-Group G)

is-group-Group :
  {l : Level} (G : Group l) → is-group (semi-group-Group G)
is-group-Group G = pr2 G

is-unital-Group :
  {l : Level} (G : Group l) → is-unital (semi-group-Group G)
is-unital-Group G = pr1 (is-group-Group G)

unit-Group :
  {l : Level} (G : Group l) → type-Group G
unit-Group G = pr1 (is-unital-Group G)

left-unit-law-Group :
  {l : Level} (G : Group l) (x : type-Group G) →
  Id (mul-Group G (unit-Group G) x) x
left-unit-law-Group G = pr1 (pr2 (is-unital-Group G))

right-unit-law-Group :
  {l : Level} (G : Group l) (x : type-Group G) →
  Id (mul-Group G x (unit-Group G)) x
right-unit-law-Group G = pr2 (pr2 (is-unital-Group G))

has-inverses-Group :
  {l : Level} (G : Group l) →
  is-group' (semi-group-Group G) (is-unital-Group G)
has-inverses-Group G = pr2 (is-group-Group G)

inv-Group :
  {l : Level} (G : Group l) →
  type-Group G → type-Group G
inv-Group G = pr1 (has-inverses-Group G)

left-inverse-law-Group :
  {l : Level} (G : Group l) (x : type-Group G) →
  Id (mul-Group G (inv-Group G x) x) (unit-Group G)
left-inverse-law-Group G = pr1 (pr2 (has-inverses-Group G))

right-inverse-law-Group :
  {l : Level} (G : Group l) (x : type-Group G) →
  Id (mul-Group G x (inv-Group G x)) (unit-Group G)
right-inverse-law-Group G = pr2 (pr2 (has-inverses-Group G))

{- We show that being a group is a proposition. -}

abstract
  is-prop-is-group' :
    {l : Level} (G : Semi-Group l) (e : is-unital G) → is-prop' (is-group' G e)
  is-prop-is-group'
    ( pair (pair G is-set-G) (pair μ assoc-G))
    ( pair e (pair left-unit-G right-unit-G))
    ( pair i (pair left-inv-i right-inv-i))
    ( pair i' (pair left-inv-i' right-inv-i')) =
    eq-subtype
      ( λ i →
        is-prop-prod
          ( is-prop-Π (λ x → is-set-G (μ (i x) x) e))
          ( is-prop-Π (λ x → is-set-G (μ x (i x)) e)))
      ( eq-htpy
        ( λ x →                                             -- ix
          ( inv (left-unit-G (i x))) ∙                      -- = 1·(ix)
          ( ( ap (λ y → μ y (i x)) (inv (left-inv-i' x))) ∙ -- = (i'x·x)·(ix)
            ( ( assoc-G (i' x) x (i x)) ∙                   -- = (i'x)·(x·i'x)
              ( ( ap (μ (i' x)) (right-inv-i x)) ∙          -- = (i'x)·1
                ( right-unit-G (i' x)))))))                 -- = i'x

abstract
  is-prop-is-group :
    {l : Level} (G : Semi-Group l) → is-prop (is-group G)
  is-prop-is-group G =
    is-prop-Σ
      ( is-prop-is-unital G)
      ( λ e → is-prop-is-prop' (is-prop-is-group' G e))

{- We give two examples of groups. The first is the group ℤ of integers. The
   second is the loop space of a pointed 1-type.  -}

{- The group of integers. -}

semi-group-ℤ : Semi-Group lzero
semi-group-ℤ = pair set-ℤ (pair add-ℤ associative-add-ℤ)

group-ℤ : Group lzero
group-ℤ =
  pair
    ( semi-group-ℤ)
    ( pair
      ( pair zero-ℤ (pair left-unit-law-add-ℤ right-unit-law-add-ℤ))
      ( pair neg-ℤ (pair left-inverse-law-add-ℤ right-inverse-law-add-ℤ)))

{- The loop space of a 1-type as a group. -}

loop-space :
  {l : Level} {A : UU l} → A → UU l
loop-space a = Id a a

set-loop-space :
  {l : Level} (A : UU l) (a : A) (is-set-Ω : is-set (Id a a)) → UU-Set l
set-loop-space A a is-set-Ω = pair (Id a a) is-set-Ω

semi-group-loop-space :
  {l : Level} (A : UU l) (a : A) (is-set-Ω : is-set (Id a a)) → Semi-Group l
semi-group-loop-space A a is-set-Ω =
  pair
    ( set-loop-space A a is-set-Ω)
    ( pair (λ p q → p ∙ q) assoc)

group-loop-space :
  {l : Level} (A : UU l) (a : A) (is-set-Ω : is-set (Id a a)) → Group l
group-loop-space A a is-set-Ω =
  pair
    ( semi-group-loop-space A a is-set-Ω)
    ( pair
      ( pair refl (pair (λ q → left-unit) (λ p → right-unit)))
      ( pair inv (pair left-inv right-inv)))

set-loop-space-1-type :
  {l : Level} (A : 1-type l) (a : pr1 A) → UU-Set l
set-loop-space-1-type (pair A is-1-type-A) a =
  set-loop-space A a (is-1-type-A a a)

semi-group-loop-space-1-type :
  {l : Level} (A : 1-type l) (a : pr1 A) → Semi-Group l
semi-group-loop-space-1-type (pair A is-1-type-A) a =
  semi-group-loop-space A a (is-1-type-A a a)

group-loop-space-1-type :
  {l : Level} (A : 1-type l) (a : pr1 A) → Group l
group-loop-space-1-type (pair A is-1-type-A) a =
  group-loop-space A a (is-1-type-A a a)

{- We introduce the automorphism group on a set X. -}

aut-Set :
  {l : Level} (X : UU-Set l) → UU-Set l
aut-Set X = set-equiv X X

associative-comp-equiv :
  {l1 l2 l3 l4 : Level} {A : UU l1} {B : UU l2} {C : UU l3} {D : UU l4} →
  (e : A ≃ B) (f : B ≃ C) (g : C ≃ D) →
  Id ((g ∘e f) ∘e e) (g ∘e (f ∘e e))
associative-comp-equiv e f g = eq-htpy-equiv refl-htpy

has-associative-mul-aut-Set :
  {l : Level} (X : UU-Set l) → has-associative-mul (aut-Set X)
has-associative-mul-aut-Set X =
  pair
    ( λ e f → f ∘e e)
    ( λ e f g → inv (associative-comp-equiv e f g))

aut-Semi-Group :
  {l : Level} (X : UU-Set l) → Semi-Group l
aut-Semi-Group X =
  pair
    ( aut-Set X)
    ( has-associative-mul-aut-Set X)

left-unit-law-equiv :
  {l1 l2 : Level} {X : UU l1} {Y : UU l2} (e : X ≃ Y) →
  Id ((equiv-id Y) ∘e e) e
left-unit-law-equiv e = eq-htpy-equiv refl-htpy

right-unit-law-equiv :
  {l1 l2 : Level} {X : UU l1} {Y : UU l2} (e : X ≃ Y) →
  Id (e ∘e (equiv-id X)) e
right-unit-law-equiv e = eq-htpy-equiv refl-htpy

is-unital-aut-Semi-Group :
  {l : Level} (X : UU-Set l) → is-unital (aut-Semi-Group X)
is-unital-aut-Semi-Group X =
  pair
    ( equiv-id (type-Set X))
    ( pair
      ( right-unit-law-equiv)
      ( left-unit-law-equiv))

left-inverse-law-equiv :
  {l1 l2 : Level} {X : UU l1} {Y : UU l2} (e : X ≃ Y) →
  Id ((inv-equiv e) ∘e e) (equiv-id X)
left-inverse-law-equiv e =
  eq-htpy-equiv (isretr-inv-is-equiv (is-equiv-map-equiv e))

right-inverse-law-equiv :
  {l1 l2 : Level} {X : UU l1} {Y : UU l2} (e : X ≃ Y) →
  Id (e ∘e (inv-equiv e)) (equiv-id Y)
right-inverse-law-equiv e =
  eq-htpy-equiv (issec-inv-is-equiv (is-equiv-map-equiv e))

is-group-aut-Semi-Group' :
  {l : Level} (X : UU-Set l) →
  is-group' (aut-Semi-Group X) (is-unital-aut-Semi-Group X)
is-group-aut-Semi-Group' X =
  pair
    ( inv-equiv)
    ( pair right-inverse-law-equiv left-inverse-law-equiv)

aut-Group :
  {l : Level} → UU-Set l → Group l
aut-Group X =
  pair
    ( aut-Semi-Group X)
    ( pair (is-unital-aut-Semi-Group X) (is-group-aut-Semi-Group' X))

{- Now we introduce homomorphisms of semi-groups. Group homomorphisms are just
   homomorphisms between their underlying semi-groups. -}

preserves-mul :
  { l1 l2 : Level} (G : Semi-Group l1) (H : Semi-Group l2) →
  (type-Semi-Group G → type-Semi-Group H) → UU (l1 ⊔ l2)
preserves-mul G H f =
  (x y : type-Semi-Group G) →
      Id (f (mul-Semi-Group G x y)) (mul-Semi-Group H (f x) (f y))

abstract
  is-prop-preserves-mul :
    { l1 l2 : Level} (G : Semi-Group l1) (H : Semi-Group l2) →
    ( f : type-Semi-Group G → type-Semi-Group H) →
    is-prop (preserves-mul G H f)
  is-prop-preserves-mul G (pair (pair H is-set-H) (pair μ-H assoc-H)) f =
    is-prop-Π (λ x →
      is-prop-Π (λ y →
        is-set-H (f (mul-Semi-Group G x y)) (μ-H (f x) (f y))))

hom-Semi-Group :
  { l1 l2 : Level} (G : Semi-Group l1) (H : Semi-Group l2) → UU (l1 ⊔ l2)
hom-Semi-Group G H =
  Σ ( type-Semi-Group G → type-Semi-Group H)
    ( preserves-mul G H)

{- Bureaucracy of homomorphisms of semi-groups. -}

map-hom-Semi-Group :
  { l1 l2 : Level} (G : Semi-Group l1) (H : Semi-Group l2) →
  ( hom-Semi-Group G H) →
  ( type-Semi-Group G) → (type-Semi-Group H)
map-hom-Semi-Group G H f = pr1 f

preserves-mul-hom-Semi-Group :
  { l1 l2 : Level} (G : Semi-Group l1) (H : Semi-Group l2) →
  ( f : hom-Semi-Group G H) →
  preserves-mul G H (map-hom-Semi-Group G H f)
preserves-mul-hom-Semi-Group G H f = pr2 f

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

htpy-hom-Semi-Group :
  { l1 l2 : Level} (G : Semi-Group l1) (H : Semi-Group l2)
  (f g : hom-Semi-Group G H) → UU (l1 ⊔ l2)
htpy-hom-Semi-Group G H f g =
  (map-hom-Semi-Group G H f) ~ (map-hom-Semi-Group G H g)

reflexive-htpy-hom-Semi-Group :
  { l1 l2 : Level} (G : Semi-Group l1) (H : Semi-Group l2) →
  ( f : hom-Semi-Group G H) → htpy-hom-Semi-Group G H f f
reflexive-htpy-hom-Semi-Group G H f = refl-htpy

htpy-hom-Semi-Group-eq :
  { l1 l2 : Level} (G : Semi-Group l1) (H : Semi-Group l2) →
  ( f g : hom-Semi-Group G H) → Id f g → htpy-hom-Semi-Group G H f g
htpy-hom-Semi-Group-eq G H f .f refl = reflexive-htpy-hom-Semi-Group G H f

abstract
  is-contr-total-htpy-hom-Semi-Group :
    { l1 l2 : Level} (G : Semi-Group l1) (H : Semi-Group l2) →
    ( f : hom-Semi-Group G H) →
    is-contr (Σ (hom-Semi-Group G H) (htpy-hom-Semi-Group G H f))
  is-contr-total-htpy-hom-Semi-Group G H f =
    is-contr-total-Eq-substructure
      ( is-contr-total-htpy (map-hom-Semi-Group G H f))
      ( is-prop-preserves-mul G H)
      ( map-hom-Semi-Group G H f)
      ( refl-htpy)
      ( preserves-mul-hom-Semi-Group G H f)

abstract
  is-equiv-htpy-hom-Semi-Group-eq :
    { l1 l2 : Level} (G : Semi-Group l1) (H : Semi-Group l2) →
    ( f g : hom-Semi-Group G H) → is-equiv (htpy-hom-Semi-Group-eq G H f g)
  is-equiv-htpy-hom-Semi-Group-eq G H f =
    fundamental-theorem-id f
      ( reflexive-htpy-hom-Semi-Group G H f)
      ( is-contr-total-htpy-hom-Semi-Group G H f)
      ( htpy-hom-Semi-Group-eq G H f)

eq-htpy-hom-Semi-Group :
  { l1 l2 : Level} (G : Semi-Group l1) (H : Semi-Group l2) →
  { f g : hom-Semi-Group G H} → htpy-hom-Semi-Group G H f g → Id f g
eq-htpy-hom-Semi-Group G H {f} {g} =
  inv-is-equiv (is-equiv-htpy-hom-Semi-Group-eq G H f g)

{- We show that the type of semi-group homomorphisms between two semi-groups is
   a set. -}

is-set-hom-Semi-Group :
  { l1 l2 : Level} (G : Semi-Group l1) (H : Semi-Group l2) →
  is-set (hom-Semi-Group G H)
is-set-hom-Semi-Group G H (pair f μ-f) (pair g μ-g) =
  is-prop-is-equiv
    ( htpy-hom-Semi-Group G H (pair f μ-f) (pair g μ-g))
    ( htpy-hom-Semi-Group-eq G H (pair f μ-f) (pair g μ-g))
    ( is-equiv-htpy-hom-Semi-Group-eq G H (pair f μ-f) (pair g μ-g))
    ( is-prop-Π (λ x → is-set-type-Semi-Group H (f x) (g x)))

{- We introduce group homomorphisms. -}

hom-Group :
  { l1 l2 : Level} (G : Group l1) (H : Group l2) → UU (l1 ⊔ l2)
hom-Group G H =
  hom-Semi-Group
    ( semi-group-Group G)
    ( semi-group-Group H)

{- Bureaucracy of group homomorphisms. -}

map-hom-Group :
  { l1 l2 : Level} (G : Group l1) (H : Group l2) →
  ( hom-Group G H) →
  ( type-Group G) → (type-Group H)
map-hom-Group G H f = pr1 f

preserves-mul-hom-Group :
  { l1 l2 : Level} (G : Group l1) (H : Group l2) →
  ( f : hom-Group G H) →
  preserves-mul
    ( semi-group-Group G)
    ( semi-group-Group H)
    ( map-hom-Group G H f)
preserves-mul-hom-Group G H f = pr2 f

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

htpy-hom-Group :
  { l1 l2 : Level} (G : Group l1) (H : Group l2)
  (f g : hom-Group G H) → UU (l1 ⊔ l2)
htpy-hom-Group G H =
  htpy-hom-Semi-Group
    ( semi-group-Group G)
    ( semi-group-Group H)

reflexive-htpy-hom-Group :
  { l1 l2 : Level} (G : Group l1) (H : Group l2) →
  ( f : hom-Group G H) → htpy-hom-Group G H f f
reflexive-htpy-hom-Group G H =
  reflexive-htpy-hom-Semi-Group
    ( semi-group-Group G)
    ( semi-group-Group H)

htpy-hom-Group-eq :
  { l1 l2 : Level} (G : Group l1) (H : Group l2) →
  ( f g : hom-Group G H) → Id f g → htpy-hom-Group G H f g
htpy-hom-Group-eq G H =
  htpy-hom-Semi-Group-eq
    ( semi-group-Group G)
    ( semi-group-Group H)

abstract
  is-contr-total-htpy-hom-Group :
    { l1 l2 : Level} (G : Group l1) (H : Group l2) →
    ( f : hom-Group G H) →
    is-contr (Σ (hom-Group G H) (htpy-hom-Group G H f))
  is-contr-total-htpy-hom-Group G H =
    is-contr-total-htpy-hom-Semi-Group
      ( semi-group-Group G)
      ( semi-group-Group H)

abstract
  is-equiv-htpy-hom-Group-eq :
    { l1 l2 : Level} (G : Group l1) (H : Group l2) →
    ( f g : hom-Group G H) → is-equiv (htpy-hom-Group-eq G H f g)
  is-equiv-htpy-hom-Group-eq G H =
    is-equiv-htpy-hom-Semi-Group-eq
      ( semi-group-Group G)
      ( semi-group-Group H)

eq-htpy-hom-Group :
  { l1 l2 : Level} (G : Group l1) (H : Group l2) →
  { f g : hom-Group G H} → htpy-hom-Group G H f g → Id f g
eq-htpy-hom-Group G H =
  eq-htpy-hom-Semi-Group (semi-group-Group G) (semi-group-Group H)

{- Next, we construct the identity group homomorphism, and we show that
   compositions of group homomorphisms are again group homomorphisms. -}

preserves-mul-id :
  {l : Level} (G : Semi-Group l) → preserves-mul G G id
preserves-mul-id (pair (pair G is-set-G) (pair μ-G assoc-G)) x y = refl

id-Semi-Group :
  {l : Level} (G : Semi-Group l) → hom-Semi-Group G G
id-Semi-Group G =
  pair id (preserves-mul-id G)

id-Group :
  {l : Level} (G : Group l) → hom-Group G G
id-Group G = id-Semi-Group (semi-group-Group G)

composition-Semi-Group :
  {l1 l2 l3 : Level} →
  (G : Semi-Group l1) (H : Semi-Group l2) (K : Semi-Group l3) →
  (hom-Semi-Group H K) → (hom-Semi-Group G H) → (hom-Semi-Group G K)
composition-Semi-Group G H K (pair g μ-g) (pair f μ-f) =
  pair
    ( g ∘ f)
    ( λ x y → (ap g (μ-f x y)) ∙ (μ-g (f x) (f y)))

composition-Group :
  {l1 l2 l3 : Level} (G : Group l1) (H : Group l2) (K : Group l3) →
  (hom-Group H K) → (hom-Group G H) → (hom-Group G K)
composition-Group G H K =
  composition-Semi-Group
    ( semi-group-Group G)
    ( semi-group-Group H)
    ( semi-group-Group K)

{- Next, we prove the that the laws for a category hold for group homomorphisms,
   i.e., we show that composition is associative and satisfies the left and
   right unit laws. Before we show that these laws hold, we will characterize
   the identity type of the types of semi-group homomorphisms and group
   homomorphisms. -}

associative-Semi-Group :
  { l1 l2 l3 l4 : Level} (G : Semi-Group l1) (H : Semi-Group l2)
  ( K : Semi-Group l3) (L : Semi-Group l4) (h : hom-Semi-Group K L) →
  ( g : hom-Semi-Group H K) (f : hom-Semi-Group G H) →
  Id ( composition-Semi-Group G H L
       ( composition-Semi-Group H K L h g) f)
     ( composition-Semi-Group G K L h
       ( composition-Semi-Group G H K g f))
associative-Semi-Group G H K L (pair h μ-h) (pair g μ-g) (pair f μ-f) =
  eq-htpy-hom-Semi-Group G L refl-htpy

left-unit-law-Semi-Group :
  { l1 l2 : Level} (G : Semi-Group l1) (H : Semi-Group l2)
  ( f : hom-Semi-Group G H) →
  Id ( composition-Semi-Group G H H (id-Semi-Group H) f) f
left-unit-law-Semi-Group G
  (pair (pair H is-set-H) (pair μ-H assoc-H)) (pair f μ-f) =
  eq-htpy-hom-Semi-Group G
    ( pair (pair H is-set-H) (pair μ-H assoc-H))
    ( refl-htpy)

right-unit-law-Semi-Group :
  { l1 l2 : Level} (G : Semi-Group l1) (H : Semi-Group l2)
  ( f : hom-Semi-Group G H) →
  Id ( composition-Semi-Group G G H f (id-Semi-Group G)) f
right-unit-law-Semi-Group
  (pair (pair G is-set-G) (pair μ-G assoc-G)) H (pair f μ-f) =
  eq-htpy-hom-Semi-Group
    ( pair (pair G is-set-G) (pair μ-G assoc-G)) H refl-htpy

{- Now we introduce the notion of group isomorphism. Finally, we will show that
   isomorphic groups are equal. -}

is-iso-Semi-Group :
  { l1 l2 : Level} (G : Semi-Group l1) (H : Semi-Group l2) →
  ( f : hom-Semi-Group G H) → UU (l1 ⊔ l2)
is-iso-Semi-Group G H f =
  Σ ( hom-Semi-Group H G) (λ g →
    ( Id (composition-Semi-Group H G H f g) (id-Semi-Group H)) ×
    ( Id (composition-Semi-Group G H G g f) (id-Semi-Group G)))

iso-Semi-Group :
  { l1 l2 : Level} (G : Semi-Group l1) (H : Semi-Group l2) → UU (l1 ⊔ l2)
iso-Semi-Group G H =
  Σ (hom-Semi-Group G H) (is-iso-Semi-Group G H)

abstract
  is-prop-is-iso-Semi-Group' :
    { l1 l2 : Level} (G : Semi-Group l1) (H : Semi-Group l2) →
    ( f : hom-Semi-Group G H) → is-prop' (is-iso-Semi-Group G H f)
  is-prop-is-iso-Semi-Group' G H f
    (pair g (pair issec isretr)) (pair g' (pair issec' isretr')) =
    eq-subtype
      ( λ h →
        is-prop-prod
          ( is-set-hom-Semi-Group H H
            ( composition-Semi-Group H G H f h)
            ( id-Semi-Group H))
          ( is-set-hom-Semi-Group G G
            ( composition-Semi-Group G H G h f)
            ( id-Semi-Group G)))
      ( ( inv (left-unit-law-Semi-Group H G g)) ∙
        ( ( inv (ap (λ h → composition-Semi-Group H G G h g) isretr')) ∙
          ( ( associative-Semi-Group H G H G g' f g) ∙
            ( ( ap (composition-Semi-Group H H G g') issec) ∙
              ( right-unit-law-Semi-Group H G g')))))

abstract
  is-prop-is-iso-Semi-Group :
    { l1 l2 : Level} (G : Semi-Group l1) (H : Semi-Group l2) →
    ( f : hom-Semi-Group G H) → is-prop (is-iso-Semi-Group G H f)
  is-prop-is-iso-Semi-Group G H f =
    is-prop-is-prop' (is-prop-is-iso-Semi-Group' G H f)

abstract
  preserves-mul-inv-is-equiv-Semi-Group :
    { l1 l2 : Level} (G : Semi-Group l1) (H : Semi-Group l2) →
    ( f : hom-Semi-Group G H)
    ( is-equiv-f : is-equiv (map-hom-Semi-Group G H f)) →
    preserves-mul H G (inv-is-equiv is-equiv-f)
  preserves-mul-inv-is-equiv-Semi-Group
    ( pair (pair G is-set-G) (pair μ-G assoc-G))
    ( pair (pair H is-set-H) (pair μ-H assoc-H))
    ( pair f μ-f) is-equiv-f x y =
    inv-is-equiv
      ( is-emb-is-equiv f is-equiv-f
        ( inv-is-equiv is-equiv-f (μ-H x y))
        ( μ-G (inv-is-equiv is-equiv-f x) (inv-is-equiv is-equiv-f y)))
      ( ( ( issec-inv-is-equiv is-equiv-f (μ-H x y)) ∙
          ( ( ap (λ t → μ-H t y) (inv (issec-inv-is-equiv is-equiv-f x))) ∙
            ( ap
              ( μ-H (f (inv-is-equiv is-equiv-f x)))
              ( inv (issec-inv-is-equiv is-equiv-f y))))) ∙
        ( inv (μ-f (inv-is-equiv is-equiv-f x) (inv-is-equiv is-equiv-f y))))

abstract
  is-iso-is-equiv-hom-Semi-Group :
    { l1 l2 : Level} (G : Semi-Group l1) (H : Semi-Group l2) →
    ( f : hom-Semi-Group G H) (is-equiv-f : is-equiv (pr1 f)) →
    is-iso-Semi-Group G H f
  is-iso-is-equiv-hom-Semi-Group
    ( pair (pair G is-set-G) (pair μ-G assoc-G))
    ( pair (pair H is-set-H) (pair μ-H assoc-H))
    ( pair f μ-f) is-equiv-f =
    pair
      ( pair
        ( inv-is-equiv is-equiv-f)
        ( preserves-mul-inv-is-equiv-Semi-Group
          ( pair (pair G is-set-G) (pair μ-G assoc-G))
          ( pair (pair H is-set-H) (pair μ-H assoc-H))
          ( pair f μ-f) is-equiv-f))
      ( pair
        ( eq-htpy-hom-Semi-Group
          ( pair (pair H is-set-H) (pair μ-H assoc-H))
          ( pair (pair H is-set-H) (pair μ-H assoc-H))
          ( issec-inv-is-equiv is-equiv-f))
        ( eq-htpy-hom-Semi-Group
          ( pair (pair G is-set-G) (pair μ-G assoc-G))
          ( pair (pair G is-set-G) (pair μ-G assoc-G))
          ( isretr-inv-is-equiv is-equiv-f)))

abstract
  is-equiv-hom-is-iso-Semi-Group :
    { l1 l2 : Level} (G : Semi-Group l1) (H : Semi-Group l2) →
    ( f : hom-Semi-Group G H) (is-iso-f : is-iso-Semi-Group G H f) →
    ( is-equiv (pr1 f))
  is-equiv-hom-is-iso-Semi-Group
    ( pair (pair G is-set-G) (pair μ-G assoc-G))
    ( pair (pair H is-set-H) (pair μ-H assoc-H))
    ( pair f μ-f)
    ( pair (pair g μ-g) (pair issec isretr)) =
    is-equiv-has-inverse g
      ( htpy-eq (ap pr1 issec))
      ( htpy-eq (ap pr1 isretr))

equiv-Semi-Group :
  { l1 l2 : Level} (G : Semi-Group l1) (H : Semi-Group l2) → UU (l1 ⊔ l2)
equiv-Semi-Group G H =
  Σ ( type-Semi-Group G ≃ type-Semi-Group H)
    ( λ e → preserves-mul G H (map-equiv e))

total-is-equiv-hom-Semi-Group :
  { l1 l2 : Level} (G : Semi-Group l1) (H : Semi-Group l2) → UU (l1 ⊔ l2)
total-is-equiv-hom-Semi-Group G H =
  Σ (hom-Semi-Group G H) (λ f → is-equiv (map-hom-Semi-Group G H f))

preserves-mul' :
  { l1 l2 : Level} (G : Semi-Group l1) (H : UU-Set l2)
  ( μ-H : has-associative-mul H) →
  ( e : (type-Semi-Group G) ≃ (type-Set H)) →
  UU (l1 ⊔ l2)
preserves-mul' G H μ-H e = preserves-mul G (pair H μ-H) (map-equiv e)

equiv-Semi-Group' :
  { l1 l2 : Level} (G : Semi-Group l1) (H : Semi-Group l2) → UU (l1 ⊔ l2)
equiv-Semi-Group' G H = equiv-Semi-Group G (pair (pr1 H) (pr2 H))

abstract
  equiv-iso-Semi-Group-equiv-Semi-Group :
    { l1 l2 : Level} (G : Semi-Group l1) (H : Semi-Group l2) →
    equiv-Semi-Group' G H ≃ iso-Semi-Group G H
  equiv-iso-Semi-Group-equiv-Semi-Group G H =
    ( ( ( equiv-total-subtype
          ( λ f → is-subtype-is-equiv (map-hom-Semi-Group G H f))
          ( is-prop-is-iso-Semi-Group G H)
          ( is-iso-is-equiv-hom-Semi-Group G H)
          ( is-equiv-hom-is-iso-Semi-Group G H)) ∘e
        ( ( inv-equiv
            ( equiv-Σ-assoc
              ( type-Semi-Group G → type-Semi-Group H)
              ( preserves-mul G H)
              ( λ f → is-equiv (map-hom-Semi-Group G H f)))) ∘e
          ( equiv-tot
            ( λ f → equiv-swap-prod (is-equiv f) (preserves-mul G H f))))) ∘e
      ( equiv-Σ-assoc
        ( type-Semi-Group G → type-Semi-Group H)
        ( is-equiv)
        ( λ e → preserves-mul G H (map-equiv e)))) ∘e
    ( equiv-tr (equiv-Semi-Group G) (η-pair H))

center-total-preserves-mul-id :
  { l1 : Level} (G : Semi-Group l1) →
  Σ (has-associative-mul (pr1 G)) (λ μ → preserves-mul G (pair (pr1 G) μ) id)
center-total-preserves-mul-id (pair (pair G is-set-G) (pair μ-G assoc-G)) =
  pair (pair μ-G assoc-G) (λ x y → refl)

contraction-total-preserves-mul-id :
  { l1 : Level} (G : Semi-Group l1) →
  ( t : Σ ( has-associative-mul (pr1 G))
          ( λ μ → preserves-mul G (pair (pr1 G) μ) id)) →
  Id (center-total-preserves-mul-id G) t
contraction-total-preserves-mul-id
  ( pair (pair G is-set-G) (pair μ-G assoc-G))
  ( pair (pair μ-G' assoc-G') μ-id) =
  eq-subtype
    ( λ μ →
      is-prop-preserves-mul
        ( pair (pair G is-set-G) (pair μ-G assoc-G))
        ( pair (pair G is-set-G) μ) id)
    ( eq-subtype
      ( λ μ →
        is-prop-Π (λ x →
          is-prop-Π (λ y →
            is-prop-Π (λ z →
              is-set-G (μ (μ x y) z) (μ x (μ y z))))))
      ( eq-htpy (λ x → eq-htpy (λ y → μ-id x y))))

is-contr-total-preserves-mul-id :
  { l1 : Level} (G : Semi-Group l1) →
  is-contr (Σ (has-associative-mul (pr1 G)) (λ μ → preserves-mul G (pair (pr1 G) μ) id))
is-contr-total-preserves-mul-id G =
  pair
    ( center-total-preserves-mul-id G)
    ( contraction-total-preserves-mul-id G)

is-contr-total-equiv-Semi-Group :
  { l1 : Level} (G : Semi-Group l1) →
  is-contr (Σ (Semi-Group l1) (λ H → equiv-Semi-Group' G H))
is-contr-total-equiv-Semi-Group {l1} G =
  is-contr-total-Eq-structure
    ( preserves-mul' G)
    ( is-contr-total-Eq-substructure
      ( is-contr-total-equiv (type-Semi-Group G))
      ( is-prop-is-set)
      ( type-Semi-Group G)
      ( equiv-id (type-Semi-Group G))
      ( is-set-type-Semi-Group G))
    ( pair (pr1 G) (equiv-id (type-Semi-Group G)))
    ( is-contr-total-preserves-mul-id G)

is-contr-total-iso-Semi-Group :
  { l1 : Level} (G : Semi-Group l1) →
  is-contr (Σ (Semi-Group l1) (iso-Semi-Group G))
is-contr-total-iso-Semi-Group {l1} G =
  is-contr-equiv'
    ( Σ (Semi-Group l1) (λ H → equiv-Semi-Group' G H))
    ( equiv-tot (λ H → equiv-iso-Semi-Group-equiv-Semi-Group G H))
    ( is-contr-total-equiv-Semi-Group G)

iso-id-Semi-Group :
  { l1 : Level} (G : Semi-Group l1) → iso-Semi-Group G G
iso-id-Semi-Group G =
  pair
    ( id-Semi-Group G)
    ( pair
      ( id-Semi-Group G)
      ( pair
        ( left-unit-law-Semi-Group G G (id-Semi-Group G))
        ( right-unit-law-Semi-Group G G (id-Semi-Group G))))

iso-eq-Semi-Group :
  { l1 : Level} (G H : Semi-Group l1) → Id G H → iso-Semi-Group G H
iso-eq-Semi-Group G .G refl = iso-id-Semi-Group G

is-equiv-iso-eq-Semi-Group :
  { l1 : Level} (G H : Semi-Group l1) → is-equiv (iso-eq-Semi-Group G H)
is-equiv-iso-eq-Semi-Group G =
  fundamental-theorem-id G
    ( iso-id-Semi-Group G)
    ( is-contr-total-iso-Semi-Group G)
    ( iso-eq-Semi-Group G)

equiv-iso-eq-Semi-Group :
  { l1 : Level} (G H : Semi-Group l1) → Id G H ≃ iso-Semi-Group G H
equiv-iso-eq-Semi-Group G H =
  pair (iso-eq-Semi-Group G H) (is-equiv-iso-eq-Semi-Group G H)

eq-iso-Semi-Group :
  { l1 : Level} (G H : Semi-Group l1) → iso-Semi-Group G H → Id G H
eq-iso-Semi-Group G H = inv-is-equiv (is-equiv-iso-eq-Semi-Group G H)

{- Finally we show that isomorphic groups are equal. -}

iso-Group :
  { l1 l2 : Level} (G : Group l1) (H : Group l2) → UU (l1 ⊔ l2)
iso-Group G H =
  iso-Semi-Group
    ( semi-group-Group G)
    ( semi-group-Group H)

iso-id-Group :
  { l1 : Level} (G : Group l1) → iso-Group G G
iso-id-Group G = iso-id-Semi-Group (semi-group-Group G)

iso-eq-Group :
  { l1 : Level} (G H : Group l1) → Id G H → iso-Group G H
iso-eq-Group G .G refl = iso-id-Group G

abstract
  equiv-iso-eq-Group' :
    { l1 : Level} (G H : Group l1) → Id G H ≃ iso-Group G H
  equiv-iso-eq-Group' G H =
    ( equiv-iso-eq-Semi-Group
      ( semi-group-Group G)
      ( semi-group-Group H)) ∘e
    ( equiv-ap-pr1-is-subtype is-prop-is-group {s = G} {t = H})

abstract
  is-contr-total-iso-Group :
    { l1 : Level} (G : Group l1) → is-contr (Σ (Group l1) (iso-Group G))
  is-contr-total-iso-Group {l1} G =
    is-contr-equiv'
      ( Σ (Group l1) (Id G))
      ( equiv-tot (λ H → equiv-iso-eq-Group' G H))
      ( is-contr-total-path G)

is-equiv-iso-eq-Group :
  { l1 : Level} (G H : Group l1) → is-equiv (iso-eq-Group G H)
is-equiv-iso-eq-Group G =
  fundamental-theorem-id G
    ( iso-id-Group G)
    ( is-contr-total-iso-Group G)
    ( iso-eq-Group G)

eq-iso-Group :
  { l1 : Level} (G H : Group l1) → iso-Group G H → Id G H
eq-iso-Group G H = inv-is-equiv (is-equiv-iso-eq-Group G H)

-- Categories

underlying-type-Set :
  {l : Level} → UU-Set l → UU l
underlying-type-Set A = pr1 A

is-set-underlying-type-Set :
  {l : Level} (A : UU-Set l) → is-set (underlying-type-Set A)
is-set-underlying-type-Set A = pr2 A

associative-composition-structure :
  {l1 l2 : Level} (A : UU l1) (hom : A → A → UU-Set l2) → UU (l1 ⊔ l2)
associative-composition-structure A hom =
  Σ ( (x y z : A)
      → underlying-type-Set (hom x y)
      → underlying-type-Set (hom y z)
      → underlying-type-Set (hom x z))
    ( λ μ → (x y z w : A) (f : underlying-type-Set (hom x y)) (g : underlying-type-Set (hom y z)) (h : underlying-type-Set (hom z w)) →
      Id (μ x z w (μ x y z f g) h) (μ x y w f (μ y z w g h)))

is-unital-composition-structure :
  {l1 l2 : Level} (A : UU l1) (hom : A → A → UU-Set l2) →
  associative-composition-structure A hom → UU _
is-unital-composition-structure A hom (pair μ assoc-μ) =
  Σ ( (x : A) → underlying-type-Set (hom x x))
    ( λ e →
      ( (x y : A) (f : underlying-type-Set (hom x y)) → Id (μ x x y (e x) f) f)
      × ( (x y : A) (f : underlying-type-Set (hom x y)) → Id (μ x y y f (e y)) f))

is-prop-is-unital-composition-structure' :
  {l1 l2 : Level} (A : UU l1) (hom : A → A → UU-Set l2) →
  ( μ : associative-composition-structure A hom) →
  is-prop' (is-unital-composition-structure A hom μ)
is-prop-is-unital-composition-structure' A hom
  ( pair μ assoc-μ)
  ( pair e (pair left-unit-law-e right-unit-law-e))
  ( pair e' (pair left-unit-law-e' right-unit-law-e')) =
  eq-subtype
    ( λ x →
      is-prop-prod
        ( is-prop-Π
          ( λ a → is-prop-Π
            ( λ b → is-prop-Π
              ( λ f' →
                is-set-underlying-type-Set (hom a b) (μ a a b (x a) f') f'))))
        ( is-prop-Π
          ( λ a → is-prop-Π
            ( λ b → is-prop-Π
              ( λ f' →
                is-set-underlying-type-Set (hom a b) (μ a b b f' (x b)) f')))))
    ( eq-htpy
      ( λ x → (inv (left-unit-law-e' x x (e x))) ∙ right-unit-law-e x x (e' x)))

Precategory :
  (l1 l2 : Level) → UU (lsuc l1 ⊔ lsuc l2)
Precategory l1 l2 =
  Σ ( UU l1) (λ A →
    Σ (A → A → UU-Set l2) (λ hom →
      Σ ( associative-composition-structure A hom)
        ( is-unital-composition-structure A hom)))

obj-Precat :
  {l1 l2 : Level} → Precategory l1 l2 → UU l1
obj-Precat C = pr1 C

hom-Set-Precat :
  {l1 l2 : Level} (C : Precategory l1 l2) (x y : obj-Precat C) → UU-Set l2
hom-Set-Precat C = pr1 (pr2 C)

hom-Precat :
  {l1 l2 : Level} (C : Precategory l1 l2) (x y : obj-Precat C) → UU l2
hom-Precat C x y = pr1 (hom-Set-Precat C x y)

is-set-hom-Precat :
  {l1 l2 : Level} (C : Precategory l1 l2) (x y : obj-Precat C) →
  is-set (hom-Precat C x y)
is-set-hom-Precat C x y = pr2 (hom-Set-Precat C x y)

associative-composition-Precat :
  {l1 l2 : Level} (C : Precategory l1 l2) →
  associative-composition-structure (obj-Precat C) (hom-Set-Precat C)
associative-composition-Precat C = pr1 (pr2 (pr2 C))

composition-Precat :
  {l1 l2 : Level} (C : Precategory l1 l2) {x y z : obj-Precat C} →
  hom-Precat C x y → hom-Precat C y z → hom-Precat C x z
composition-Precat C {x} {y} {z} =
  pr1 (associative-composition-Precat C) x y z

is-associative-composition-Precat :
  { l1 l2 : Level} (C : Precategory l1 l2) {x y z w : obj-Precat C} →
  ( f : hom-Precat C x y) (g : hom-Precat C y z) (h : hom-Precat C z w) →
  Id (composition-Precat C (composition-Precat C f g) h)
     (composition-Precat C f (composition-Precat C g h))
is-associative-composition-Precat C {x} {y} {z} {w} =
  pr2 (associative-composition-Precat C) x y z w

is-unital-Precat :
  { l1 l2 : Level} (C : Precategory l1 l2) →
  is-unital-composition-structure
    ( obj-Precat C)
    ( hom-Set-Precat C)
    ( associative-composition-Precat C)
is-unital-Precat C = pr2 (pr2 (pr2 C))

id-Precat :
  { l1 l2 : Level} (C : Precategory l1 l2) {x : obj-Precat C} →
  hom-Precat C x x
id-Precat (pair A (pair hom (pair (pair μ assoc-μ) t))) {x} =
  pr1 (is-unital-Precat {!!}) x

-- Exercises

-- Exercise

{- We show that group homomorphisms preserve the unit. -}

preserves-unit :
  { l1 l2 : Level} (G : Group l1) (H : Group l2) →
  ( f : hom-Semi-Group
    ( semi-group-Group G)
    ( semi-group-Group H)) →
  UU l2
preserves-unit G H f =
  Id (map-hom-Group G H f (unit-Group G)) (unit-Group H)

abstract
  preserves-unit-group-hom :
    { l1 l2 : Level} (G : Group l1) (H : Group l2) →
    ( f : hom-Group G H) → preserves-unit G H f
  preserves-unit-group-hom
    ( pair ( pair (pair G is-set-G) (pair μ-G assoc-G))
           ( pair ( pair e-G (pair left-unit-G right-unit-G))
                  ( pair i-G (pair left-inv-G right-inv-G))))
    ( pair ( pair (pair H is-set-H) (pair μ-H assoc-H))
           ( pair ( pair e-H (pair left-unit-H right-unit-H))
                  ( pair i-H (pair left-inv-H right-inv-H))))
    ( pair f μ-f) =
    ( inv (left-unit-H (f e-G))) ∙
    ( ( ap (λ x → μ-H x (f e-G)) (inv (left-inv-H (f e-G)))) ∙
      ( ( assoc-H (i-H (f e-G)) (f e-G) (f e-G)) ∙
        ( ( ap (μ-H (i-H (f e-G))) (inv (μ-f e-G e-G))) ∙
          ( ( ap (λ x → μ-H (i-H (f e-G)) (f x)) (left-unit-G e-G)) ∙
            ( left-inv-H (f e-G))))))

{- We show that group homomorphisms preserve inverses. -}

preserves-inverses :
  { l1 l2 : Level} (G : Group l1) (H : Group l2) →
  ( f : hom-Group G H) → UU (l1 ⊔ l2)
preserves-inverses G H f =
  ( x : type-Group G) →
  Id ( map-hom-Group G H f (inv-Group G x))
     ( inv-Group H (map-hom-Group G H f x))

abstract
  preserves-inverses-group-hom' :
    { l1 l2 : Level} (G : Group l1) (H : Group l2) →
    ( f : hom-Group G H) →
    preserves-unit G H f → preserves-inverses G H f
  preserves-inverses-group-hom'
    ( pair ( pair (pair G is-set-G) (pair μ-G assoc-G))
           ( pair ( pair e-G (pair left-unit-G right-unit-G))
                  ( pair i-G (pair left-inv-G right-inv-G))))
    ( pair ( pair (pair H is-set-H) (pair μ-H assoc-H))
           ( pair ( pair e-H (pair left-unit-H right-unit-H))
                  ( pair i-H (pair left-inv-H right-inv-H))))
    ( pair f μ-f) preserves-unit-f x =
    ( inv ( right-unit-H (f (i-G x)))) ∙
    ( ( ap (μ-H (f (i-G x))) (inv (right-inv-H (f x)))) ∙
      ( ( inv (assoc-H (f (i-G x)) (f x) (i-H (f x)))) ∙
        ( ( inv (ap (λ y → μ-H y (i-H (f x))) (μ-f (i-G x) x))) ∙
          ( ( ap (λ y → μ-H (f y) (i-H (f x))) (left-inv-G x)) ∙
            ( ( ap
                ( λ y → μ-H y (i-H (f x)))
                ( preserves-unit-f)) ∙
              ( left-unit-H (i-H (f x))))))))

abstract
  preserves-inverses-group-hom :
    { l1 l2 : Level} (G : Group l1) (H : Group l2) →
    ( f : hom-Group G H) → preserves-inverses G H f
  preserves-inverses-group-hom G H f =
    preserves-inverses-group-hom' G H f (preserves-unit-group-hom G H f)

hom-Group' :
  { l1 l2 : Level} (G : Group l1) (H : Group l2) → UU (l1 ⊔ l2)
hom-Group' G H =
  Σ ( hom-Group G H) (λ f →
    ( preserves-unit G H f) × (preserves-inverses G H f))

preserves-all-hom-Group :
  { l1 l2 : Level} (G : Group l1) (H : Group l2) →
  hom-Group G H → hom-Group' G H
preserves-all-hom-Group G H f =
  pair f
    ( pair
      ( preserves-unit-group-hom G H f)
      ( preserves-inverses-group-hom G H f))

-- Exercise

{-
hom-mul-Group :
  {l : Level} (G : Group l) →
  hom-Group G Aut
-}


open import Agda.Builtin.Equality

_∋_ : ∀ {a} (A : Set a) → A → A
A ∋ x = x

cong : ∀ {a b} {A : Set a} {B : Set b}
       (f : A → B) {x y} → x ≡ y → f x ≡ f y
cong f refl = refl

record IsRG (Node : Set) (Edge : Set) : Set where
  field
    src : Edge → Node
    tgt : Edge → Node
    rfl : Node → Edge
    eq-src-rfl : ∀{x} → src (rfl x) ≡ x
    eq-tgt-rfl : ∀{x} → tgt (rfl x) ≡ x
open IsRG {{...}} public

module norecord where

  source : ∀{Node Edge : Set} {{i : IsRG Node Edge}} → Edge → Node
  source x = src x

  lemma1 : ∀{Node Edge : Set} {{i : IsRG Node Edge}} → (e : Edge) → (Node ∋ source e) ≡ src e
  lemma1 e = refl

  rfl-src : ∀{Node Edge : Set} {{i : IsRG Node Edge}} → Edge → Edge
  rfl-src {Node} e = rfl (Node ∋ src e)

  lemma2 : ∀{Node Edge : Set} {{i : IsRG Node Edge}} → (n : Node) → rfl-src {Node} (rfl n) ≡ (Edge ∋ rfl n)
  lemma2 {Node}{Edge} n = cong (rfl {Node = Node}) (eq-src-rfl {Edge = Edge})

module yesrecord where

  record RG : Set₁ where
    constructor mkRG
    field
      Node : Set
      Edge : Set
      {{isRG}} : IsRG Node Edge
  open RG public

  source : ∀{rg} → Edge rg → Node rg
  source x = src x

  lemma1 : ∀{rg} → (e : Edge rg) → (Node rg ∋ source {mkRG (Node rg) (Edge rg)} e) ≡ src e
  --causes problems:
  --lemma1 : ∀{rg} → (e : Edge rg) → (Node rg ∋ source {_} e) ≡ src e
  lemma1 e = refl

  rfl-src : ∀{rg} → Edge rg → Edge rg
  rfl-src {rg} e = rfl (Node rg ∋ src e)

  lemma2 : ∀{rg} → (n : Node rg) → rfl-src {rg} (rfl n) ≡ (Edge rg ∋ rfl n)
  lemma2 {rg} n = cong (rfl {Node = Node rg}) (eq-src-rfl {Edge = Edge rg})