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

-- Inspired by Thorsten Altenkirch's definition of Groupoids
-- see his OmegaCats repo on github.  And copumpkin's definition of
-- Category (see his categories repo, also on github).

module Groupoid where

open import Level using (zero)
open import Data.Empty using (⊥)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Data.Product using (_×_; proj₁; proj₂; _,_)
open import Function using (flip)
open import Relation.Binary
  using (Rel; IsEquivalence; Reflexive; Symmetric; Transitive;
         module IsEquivalence)

------------------------------------------------------------------------------
-- Useful

Rel0 : Set → Set₁
Rel0 A = Rel A zero

-- 1-groupoids are those where the various laws hold up to ≈.

record 1Groupoid : Set₁ where
  infixr 9 _∘_
  infixr 5 _↝_
  infix  4 _≈_
  field
    set      : Set₀
    _↝_      : set → set → Set
    _≈_      : ∀ {A B} → A ↝ B → A ↝ B → Set
    id       : ∀ {x} → x ↝ x
    _∘_      : ∀ {x y z} → y ↝ z → x ↝ y → x ↝ z
    _⁻¹      : ∀ {x y} → x ↝ y → y ↝ x
    lneutr   : ∀ {x y} (α : x ↝ y) → id ∘ α ≈ α
    rneutr   : ∀ {x y} (α : x ↝ y) → α ∘ id ≈ α
    assoc    : ∀ {w x y z} (α : y ↝ z) (β : x ↝ y) (δ : w ↝ x) →
               (α ∘ β) ∘ δ ≈ α ∘ (β ∘ δ)
    equiv    : ∀ {x y} → IsEquivalence (_≈_ {x} {y})
    linv     : ∀ {x y}(α : x ↝ y) → α ⁻¹ ∘ α ≈ id {x}
    rinv     : ∀ {x y}(α : x ↝ y) → α ∘ α ⁻¹ ≈ id {y}
    ∘-resp-≈ : ∀ {x y z} {f h : y ↝ z} {g i : x ↝ y} → f ≈ h → g ≈ i →
               f ∘ g ≈ h ∘ i

_[_,_] : (C : 1Groupoid) → 1Groupoid.set C → 1Groupoid.set C → Set
_[_,_] = 1Groupoid._↝_

open 1Groupoid

_⊎G_ : 1Groupoid → 1Groupoid → 1Groupoid
A ⊎G B = record
  { set      = A.set ⊎ B.set
  ; _↝_      =  _⇛_
  ; _≈_      = λ {x} → mk≈ {x}
  ; id       = λ {x} → id⇛ {x}
  ; _∘_      = λ {x} → _∙G_ {x = x}
  ; _⁻¹      = λ {x} → inv {x = x}
  ; lneutr   = λ {x} → lid⇛ {x}
  ; rneutr   = λ {x} → rid⇛ {x}
  ; assoc    = λ {x} a b g → assoc∙ {x} a b g
  ; equiv    = λ {x} → equiv≈ {x}
  ; linv     = λ {x} → linv⇛ {x}
  ; rinv     = λ {x} → rinv⇛ {x}
  ; ∘-resp-≈ = λ {x} → resp {x} }
  where
    module A = 1Groupoid A
    module B = 1Groupoid B
    C : Set
    C = set A ⊎ set B

    _⇛_ : set A ⊎ set B → set A ⊎ set B → Set
    _⇛_ (inj₁ x) (inj₁ y) = A._↝_ x y
    _⇛_ (inj₁ _) (inj₂ _) = ⊥
    _⇛_ (inj₂ _) (inj₁ _) = ⊥
    _⇛_ (inj₂ x) (inj₂ y) = B._↝_ x y

    mk≈ : {x y : set A ⊎ set B} → x ⇛ y → x ⇛ y → Set
    mk≈ {inj₁ z} {inj₁ z'} a b = A._≈_ a b
    mk≈ {inj₁ x} {inj₂ y}  () ()
    mk≈ {inj₂ y} {inj₁ x}  () ()
    mk≈ {inj₂ y} {inj₂ y'} a b = B._≈_ a b

    id⇛ : {x : set A ⊎ set B} → x ⇛ x
    id⇛ {inj₁ _} = id A
    id⇛ {inj₂ _} = id B

    _∙G_ : {x y z : set A ⊎ set B} → y ⇛ z → x ⇛ y → x ⇛ z
    _∙G_ {inj₁ _} {inj₁ _} {inj₁ _} a b = A._∘_ a b
    _∙G_ {inj₁ _} {inj₁ _} {inj₂ _} () b
    _∙G_ {inj₁ x} {inj₂ y} a ()
    _∙G_ {inj₂ y} {inj₁ x} a ()
    _∙G_ {inj₂ y} {inj₂ y₁} {inj₁ x} () b
    _∙G_ {inj₂ _} {inj₂ _} {inj₂ _} a b = B._∘_ a b

    inv : {x y : set A ⊎ set B} → x ⇛ y → y ⇛ x
    inv {inj₁ _} {inj₁ _} a = A._⁻¹ a
    inv {inj₁ _} {inj₂ _} ()
    inv {inj₂ _} {inj₁ _} ()
    inv {inj₂ _} {inj₂ _} a = B._⁻¹ a

    lid⇛ : {x y : C} (α : x ⇛ y) → mk≈ {x} (_∙G_ {x} (id⇛ {y}) α) α
    lid⇛ {inj₁ _} {inj₁ _} a = A.lneutr a
    lid⇛ {inj₁ _} {inj₂ _} ()
    lid⇛ {inj₂ _} {inj₁ _} ()
    lid⇛ {inj₂ _} {inj₂ _} a = B.lneutr a

    rid⇛ : {x y : A.set ⊎ B.set} (α : x ⇛ y) → mk≈ {x} (_∙G_ {x} α (id⇛ {x})) α
    rid⇛ {inj₁ _} {inj₁ _} α = A.rneutr α
    rid⇛ {inj₁ _} {inj₂ _} ()
    rid⇛ {inj₂ _} {inj₁ _} ()
    rid⇛ {inj₂ _} {inj₂ _} α = B.rneutr α

    assoc∙ : {w x y z : C} (α : y ⇛ z) (β : x ⇛ y) (δ : w ⇛ x) →
           mk≈ {w} {z} (_∙G_ {w} (_∙G_ {x} α β) δ) (_∙G_ {w} α (_∙G_ {w} β δ))
    assoc∙ {inj₁ x} {inj₁ x₁} {inj₁ x₂} {inj₁ x₃} α β γ = A.assoc α β γ
    assoc∙ {inj₁ x} {inj₁ x₁} {inj₁ x₂} {inj₂ y} () _ _
    assoc∙ {inj₁ x} {inj₁ x₁} {inj₂ y} _ () _
    assoc∙ {inj₁ x} {inj₂ y} _ _ ()
    assoc∙ {inj₂ y} {inj₁ x} _ _ ()
    assoc∙ {inj₂ y} {inj₂ y₁} {inj₁ x} _ () _
    assoc∙ {inj₂ y} {inj₂ y₁} {inj₂ y₂} {inj₁ x} () _ _
    assoc∙ {inj₂ y} {inj₂ y₁} {inj₂ y₂} {inj₂ y₃}  α β γ = B.assoc α β γ

    linv⇛ : {x y : C} (α : x ⇛ y) → mk≈ {x} (_∙G_ {x} (inv {x} α) α) (id⇛ {x})
    linv⇛ {inj₁ _} {inj₁ _} α = A.linv α
    linv⇛ {inj₁ x} {inj₂ y} ()
    linv⇛ {inj₂ y} {inj₁ x} ()
    linv⇛ {inj₂ _} {inj₂ _} α = B.linv α

    rinv⇛ : {x y : C} (α : x ⇛ y) → mk≈ {y} (_∙G_ {y} α (inv {x} α)) (id⇛ {y})
    rinv⇛ {inj₁ _} {inj₁ _} α = A.rinv α
    rinv⇛ {inj₁ x} {inj₂ y} ()
    rinv⇛ {inj₂ y} {inj₁ x} ()
    rinv⇛ {inj₂ _} {inj₂ _} α = B.rinv α

    refl≈ : {x y : C} → Reflexive (mk≈ {x} {y})
    refl≈ {inj₁ _} {inj₁ _} = IsEquivalence.refl A.equiv
    refl≈ {inj₁ _} {inj₂ _} {()}
    refl≈ {inj₂ _} {inj₁ _} {()}
    refl≈ {inj₂ y} {inj₂ y₁} = IsEquivalence.refl B.equiv

    sym≈ : {x y : C} → Symmetric (mk≈ {x} {y})
    sym≈ {inj₁ _} {inj₁ _} = IsEquivalence.sym A.equiv
    sym≈ {inj₁ _} {inj₂ _} {()}
    sym≈ {inj₂ _} {inj₁ _} {()}
    sym≈ {inj₂ y} {inj₂ y₁} = IsEquivalence.sym B.equiv

    trans≈ : {x y : C} → Transitive (mk≈ {x} {y})
    trans≈ {inj₁ _} {inj₁ _} = IsEquivalence.trans A.equiv
    trans≈ {inj₁ _} {inj₂ _} {()}
    trans≈ {inj₂ _} {inj₁ _} {()}
    trans≈ {inj₂ _} {inj₂ _} = IsEquivalence.trans B.equiv

    equiv≈ : {x y : C} → IsEquivalence (mk≈ {x} {y})
    equiv≈ {x} =
      record { refl = refl≈ {x}; sym = sym≈ {x}; trans = trans≈ {x} }

    resp : {x y z : C} {f h : y ⇛ z} {g i : x ⇛ y} →
           mk≈ {y} f h → mk≈ {x} g i → mk≈ {x} (_∙G_ {x} f g) (_∙G_ {x} h i)
    resp {inj₁ _} {inj₁ _} {inj₁ _} = A.∘-resp-≈
    resp {inj₁ _} {inj₁ _} {inj₂ _} {()}
    resp {inj₁ _} {inj₂ _} {_} {_} {_} {()}
    resp {inj₂ _} {inj₁ _} {_} {_} {_} {()}
    resp {inj₂ _} {inj₂ _} {inj₁ _} {()}
    resp {inj₂ _} {inj₂ _} {inj₂ _} = B.∘-resp-≈

_×G_ : 1Groupoid → 1Groupoid → 1Groupoid
A ×G B = record
  { set      = A.set × B.set
  ; _↝_      =  liftG A._↝_ B._↝_
  ; _≈_      = liftG A._≈_ B._≈_
  ; id       = A.id , B.id
  ; _∘_      = liftOp2 {Z₁ = A._↝_} {B._↝_} A._∘_ B._∘_
  ; _⁻¹      = λ x₁ → A._⁻¹ (proj₁ x₁) , B._⁻¹ (proj₂ x₁)
  ; lneutr   = λ α → A.lneutr (proj₁ α) , B.lneutr (proj₂ α)
  ; rneutr   = λ α → A.rneutr (proj₁ α) , B.rneutr (proj₂ α)
  ; assoc    = λ α β δ →
                 A.assoc (proj₁ α) (proj₁ β) (proj₁ δ) ,
                 B.assoc (proj₂ α) (proj₂ β) (proj₂ δ)
  ; equiv    = λ {x} {y} →
                 let module W = IsEquivalence (A.equiv {proj₁ x} {proj₁ y})
                     module Z = IsEquivalence (B.equiv {proj₂ x} {proj₂ y}) in
                 record { refl = W.refl , Z.refl
                        ; sym = λ i≈j → W.sym (proj₁ i≈j) , Z.sym (proj₂ i≈j)
                        ; trans = λ i≈j j≈k →
                                    (W.trans (proj₁ i≈j) (proj₁ j≈k)) ,
                                    ((Z.trans (proj₂ i≈j) (proj₂ j≈k))) }
  ; linv     = λ α → A.linv (proj₁ α) , B.linv (proj₂ α)
  ; rinv     = λ α → A.rinv (proj₁ α) , B.rinv (proj₂ α)
  ; ∘-resp-≈ = λ x₁ x₂ →
                 (A.∘-resp-≈ (proj₁ x₁) (proj₁ x₂)) ,
                  B.∘-resp-≈ (proj₂ x₁) (proj₂ x₂) }
  where
    module A = 1Groupoid A
    module B = 1Groupoid B
    C : Set
    C = A.set × B.set

    liftG : {X Y : Set} → Rel0 X → Rel0 Y → X × Y → X × Y → Set
    liftG F G =  λ x y → F (proj₁ x) (proj₁ y) × G (proj₂ x) (proj₂ y)

    liftOp2 : {A₁ A₂ : Set} {x y z : A₁ × A₂} {Z₁ : Rel0 A₁} {Z₂ : Rel0 A₂} →
             let _⇛_ = liftG Z₁ Z₂ in
             let _↝₁_ : (a b : A₁ × A₂) → Set
                 _↝₁_ = λ a b → Z₁ (proj₁ a) (proj₁ b)
                 _↝₂_ : (a b : A₁ × A₂) → Set
                 _↝₂_ = λ a b → Z₂ (proj₂ a) (proj₂ b) in
                   (y ↝₁ z → x ↝₁ y → x ↝₁ z) → (y ↝₂ z → x ↝₂ y → x ↝₂ z)
                → y ⇛ z → x ⇛ y → x ⇛ z
    liftOp2 F G = λ x y → F (proj₁ x) (proj₁ y) , G (proj₂ x) (proj₂ y)

-- Discrete paths.  Essentially ≡.

data DPath {A : Set} (x : A) : A → Set where
  reflD : DPath x x

transD : {A : Set} {x y z : A} → DPath y z → DPath x y → DPath x z
transD reflD reflD = reflD

symD : {A : Set} {x y : A} → DPath x y → DPath y x
symD reflD = reflD

lidD : {A : Set} {x y : A} (α : DPath x y) → DPath (transD reflD α) α
lidD reflD = reflD

ridD : {A : Set} {x y : A} (α : DPath x y) → DPath (transD α reflD) α
ridD reflD = reflD

assocD : {A : Set} {w x y z : A}
         (α : DPath y z) (β : DPath x y) (δ : DPath w x) →
         DPath (transD (transD α β) δ) (transD α (transD β δ))
assocD reflD reflD reflD = reflD

linvD : {A : Set} {x y : A} (α : DPath x y) → DPath (transD (symD α) α) reflD
linvD reflD = reflD

rinvD : {A : Set} {x y : A} (α : DPath x y) → DPath (transD α (symD α)) reflD
rinvD reflD = reflD

equivD : {A : Set} {x y : A} → IsEquivalence {_} {_} {DPath x y} DPath
equivD = λ {A} {x} {y} → record
  { refl = reflD
  ; sym = symD
  ; trans = flip transD }

respD : {A : Set} {x y z : A} {f h : DPath y z} {g i : DPath x y} →
        DPath f h → DPath g i → DPath (transD f g) (transD h i)
respD reflD reflD = reflD

discrete : Set → 1Groupoid
discrete a =  record
    { set       = a
    ; _↝_       = DPath
    ; _≈_       = DPath -- or could use _≡_ .
    ; id        = reflD
    ; _∘_       = transD
    ; _⁻¹       = symD
    ; lneutr    = lidD
    ; rneutr    = ridD
    ; assoc     = assocD
    ; linv      = linvD
    ; rinv      = rinvD
    ; equiv     = equivD
    ;  ∘-resp-≈ = respD }

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


{-# OPTIONS --safe #-}

open import Definition.Typed.EqualityRelation

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

open import Definition.Untyped
open import Definition.Typed
open import Definition.LogicalRelation
import Tools.PropositionalEquality as PE

import Data.Nat as Nat

-- Any level can be embedded into the highest level.
maybeEmb : ∀ {l A r Γ}
         → Γ ⊩⟨ l ⟩ A ^ r
         → Γ ⊩⟨ ∞ ⟩ A ^ r
maybeEmb {ι ⁰} [A] = emb ∞< (emb emb< [A])
maybeEmb {ι ¹} [A] = emb ∞< [A]
maybeEmb {∞} [A] = [A]

-- Any level can be embedded into the highest level.
maybeEmbTerm : ∀ {l A t r Γ}
         → ([A] : Γ ⊩⟨ l ⟩ A ^ r)
         → Γ ⊩⟨ l ⟩ t ∷ A ^ r / [A]
         → Γ ⊩⟨ ∞ ⟩ t ∷ A ^ r / maybeEmb [A]
maybeEmbTerm {ι ⁰} [A] [t] = [t]
maybeEmbTerm {ι ¹} [A] [t] = [t]
maybeEmbTerm {∞} [A] [t] = [t]

-- The lowest level can be embedded in any level.
maybeEmb′ : ∀ {l l' A r Γ}
          → l ≤ l'
          → Γ ⊩⟨ ι l ⟩ A ^ r
          → Γ ⊩⟨ ι l' ⟩ A ^ r
maybeEmb′ (<is≤ 0<1) [A] = emb emb< [A]
maybeEmb′ (≡is≤ PE.refl) [A] = [A]

maybeEmb″ : ∀ {l A r Γ}
         → Γ ⊩⟨ ι ⁰ ⟩ A ^ r
         → Γ ⊩⟨ l ⟩ A ^ r
maybeEmb″ {ι ⁰} [A] = [A]
maybeEmb″ {ι ¹} [A] = emb emb< [A]
maybeEmb″ {∞} [A] = emb ∞< (emb emb< [A])


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

module Definition.Typed.Consequences.Consistency where

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Typed.EqRelInstance
open import Definition.LogicalRelation
open import Definition.LogicalRelation.Irrelevance
open import Definition.LogicalRelation.ShapeView
open import Definition.LogicalRelation.Fundamental.Reducibility

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

zero≢one′ : ∀ {Γ l} ([ℕ] : Γ ⊩⟨ l ⟩ℕ ℕ)
           → Γ ⊩⟨ l ⟩ zero ≡ suc zero ∷ ℕ / ℕ-intr [ℕ] → ⊥
zero≢one′ (noemb x) (ιx (ℕₜ₌ .(suc _) .(suc _) d d′ k≡k′ (sucᵣ x₁))) =
  zero≢suc (whnfRed*Term (redₜ d) zeroₙ)
zero≢one′ (noemb x) (ιx (ℕₜ₌ .zero .zero d d′ k≡k′ zeroᵣ)) =
  zero≢suc (PE.sym (whnfRed*Term (redₜ d′) sucₙ))
zero≢one′ (noemb x) (ιx (ℕₜ₌ k k′ d d′ k≡k′ (ne (neNfₜ₌ neK neM k≡m)))) =
  zero≢ne neK (whnfRed*Term (redₜ d) zeroₙ)
zero≢one′ (emb 0<1 [ℕ]) (ιx n) = zero≢one′ [ℕ] n

-- Zero cannot be judgmentally equal to one.
zero≢one : ∀ {Γ} → Γ ⊢ zero ≡ suc zero ∷ ℕ → ⊥
zero≢one 0≡1 =
  let [ℕ] , [0≡1] = reducibleEqTerm 0≡1
  in  zero≢one′ (ℕ-elim [ℕ]) (irrelevanceEqTerm [ℕ] (ℕ-intr (ℕ-elim [ℕ])) [0≡1])


-- Given two abelian groups A, B
--   the set of all group homomorphisms from A to B
-- is itself an abelian group.
-- In other words, Ab is cartesian closed.
-- This is needed to show Ab is an abelian category.

{-# OPTIONS --safe #-}

module Cubical.Algebra.AbGroup.Instances.Hom where

open import Cubical.Algebra.AbGroup.Base
open import Cubical.Algebra.Group.Morphisms
open import Cubical.Algebra.Group.MorphismProperties
open import Cubical.Algebra.Group.Properties
open import Cubical.Foundations.Prelude

private
  variable
    ℓ ℓ' : Level

module _ (A : AbGroup ℓ) (B : AbGroup ℓ') where

  -- These names are useful for the proofs
  private
    open IsGroupHom
    open AbGroupStr (A .snd) using () renaming (0g to 0A; _+_ to _⋆_; -_ to inv)
    open AbGroupStr (B .snd) using (_+_; -_; +Comm; +Assoc; +IdR ; +InvR)
                             renaming (0g to 0B)
    open GroupTheory (AbGroup→Group B) using (invDistr) renaming (inv1g to inv0B)

    -- Some lemmas
    idrB : (b : B .fst) → b + 0B ≡ b
    idrB b = +IdR b

    invrB : (b : B .fst) → b + (- b) ≡ 0B
    invrB b = +InvR b

    hom0AB : (f : AbGroupHom A B) → f .fst 0A ≡ 0B
    hom0AB f = hom1g (AbGroupStr→GroupStr (A .snd)) (f .fst)
                     (AbGroupStr→GroupStr (B .snd)) (f .snd .pres·)

    homInvAB : (f : AbGroupHom A B) → (a : A .fst) → f .fst (inv a) ≡ (- f .fst a)
    homInvAB f a = homInv (AbGroupStr→GroupStr (A .snd)) (f .fst)
                          (AbGroupStr→GroupStr (B .snd)) (f .snd .pres·) a

  -- Zero morphism
  zero : AbGroupHom A B
  zero .fst a = 0B
  zero .snd .pres· a a' = sym (idrB _)
  zero .snd .pres1 = refl
  zero .snd .presinv a = sym (inv0B)

  -- Pointwise addition of morphisms
  module _ (f* g* : AbGroupHom A B) where
    private
      f = f* .fst
      g = g* .fst

    HomAdd : AbGroupHom A B
    HomAdd .fst = λ a → f a + g a

    HomAdd .snd .pres· a a' =
        f (a ⋆ a') + g (a ⋆ a')           ≡⟨ cong (_+ g(a ⋆ a')) (f* .snd .pres· _ _) ⟩
        (f a + f a') + g (a ⋆ a')         ≡⟨ cong ((f a + f a') +_) (g* .snd .pres· _ _) ⟩
        (f a + f a') + (g a + g a')       ≡⟨ sym (+Assoc _ _ _) ⟩
        f a + (f a' + (g a + g a'))       ≡⟨ cong (f a +_) (+Assoc _ _ _) ⟩
        f a + ((f a' + g a) + g a')       ≡⟨ cong (λ b → (f a + b + g a')) (+Comm _ _) ⟩
        f a + ((g a + f a') + g a')       ≡⟨ cong (f a +_) (sym (+Assoc _ _ _)) ⟩
        f a + (g a + (f a' + g a'))       ≡⟨ +Assoc _ _ _ ⟩
        (f a + g a) + (f a' + g a')       ∎

    HomAdd .snd .pres1 =
        f 0A + g 0A       ≡⟨ cong (_+ g 0A) (hom0AB f*) ⟩
        0B + g 0A         ≡⟨ cong (0B +_) (hom0AB g*) ⟩
        0B + 0B           ≡⟨ idrB _ ⟩
        0B                ∎

    HomAdd .snd .presinv a =
        f (inv a) + g (inv a)     ≡⟨ cong (_+ g (inv a)) (homInvAB f* _) ⟩
        (- f a) + g (inv a)       ≡⟨ cong ((- f a) +_) (homInvAB g* _) ⟩
        (- f a) + (- g a)         ≡⟨ +Comm _ _ ⟩
        (- g a) + (- f a)         ≡⟨ sym (invDistr _ _) ⟩
        - (f a + g a)             ∎

  -- Pointwise inverse of morphism
  module _ (f* : AbGroupHom A B) where
    private
      f = f* .fst

    HomInv : AbGroupHom A B
    HomInv .fst = λ a → - f a

    HomInv .snd .pres· a a' =
        - f (a ⋆ a')            ≡⟨ cong -_ (f* .snd .pres· _ _) ⟩
        - (f a + f a')          ≡⟨ invDistr _ _ ⟩
        (- f a') + (- f a)      ≡⟨ +Comm _ _ ⟩
        (- f a) + (- f a')      ∎

    HomInv .snd .pres1 =
        - (f 0A)      ≡⟨ cong -_ (f* .snd .pres1) ⟩
        - 0B          ≡⟨ inv0B ⟩
        0B            ∎

    HomInv .snd .presinv a =
        - f (inv a)     ≡⟨ cong -_ (homInvAB f* _) ⟩
        - (- f a)       ∎

  -- Group laws for morphisms
  private
    0ₕ = zero
    _+ₕ_ = HomAdd
    -ₕ_ = HomInv

  -- Morphism addition is associative
  HomAdd-assoc : (f g h : AbGroupHom A B) → (f +ₕ (g +ₕ h)) ≡ ((f +ₕ g) +ₕ h)
  HomAdd-assoc f g h = GroupHom≡ (funExt λ a → +Assoc _ _ _)

  -- Morphism addition is commutative
  HomAdd-comm : (f g : AbGroupHom A B) → (f +ₕ g) ≡ (g +ₕ f)
  HomAdd-comm f g = GroupHom≡ (funExt λ a → +Comm _ _)

  -- zero is right identity
  HomAdd-zero : (f : AbGroupHom A B) → (f +ₕ zero) ≡ f
  HomAdd-zero f = GroupHom≡ (funExt λ a → idrB _)

  -- -ₕ is right inverse
  HomInv-invr : (f : AbGroupHom A B) → (f +ₕ (-ₕ f)) ≡ zero
  HomInv-invr f = GroupHom≡ (funExt λ a → invrB _)

-- Abelian group structure on AbGroupHom A B
open AbGroupStr
HomAbGroupStr : (A : AbGroup ℓ) → (B : AbGroup ℓ') → AbGroupStr (AbGroupHom A B)
HomAbGroupStr A B .0g        = zero A B
HomAbGroupStr A B ._+_       = HomAdd A B
HomAbGroupStr A B .-_        = HomInv A B
HomAbGroupStr A B .isAbGroup = makeIsAbGroup isSetGroupHom
    (HomAdd-assoc A B) (HomAdd-zero A B) (HomInv-invr A B) (HomAdd-comm A B)

HomAbGroup : (A : AbGroup ℓ) → (B : AbGroup ℓ') → AbGroup (ℓ-max ℓ ℓ')
HomAbGroup A B = AbGroupHom A B , HomAbGroupStr A B


{-# OPTIONS --universe-polymorphism #-}
module Categories.Globe where

import Level
open import Relation.Binary using (IsEquivalence; module IsEquivalence)
open import Relation.Binary.PropositionalEquality using (isEquivalence)
open import Data.Nat using (ℕ; zero; suc; _<_; _≤_; z≤n; s≤s)
open import Data.Nat.Properties using (<-trans)

open import Categories.Support.PropositionalEquality
open import Categories.Category

-- the stdlib doesn't have this
private
  ≤-unique : ∀ {m n} {x y : m ≤ n} → x ≣ y
  ≤-unique {x = z≤n} {z≤n} = ≣-refl
  ≤-unique {x = s≤s m≤n} {s≤s m≤n'} = ≣-cong s≤s ≤-unique

data GlobeHom : (m n : ℕ) → Set where
  I : {place : ℕ} → GlobeHom place place
  σ : {m n : ℕ} (n<m : n < m) → GlobeHom n m
  τ : {m n : ℕ} (n<m : n < m) → GlobeHom n m

infixl 7 _⊚_

_⊚_ : ∀ {l m n} → GlobeHom m n → GlobeHom l m → GlobeHom l n
I ⊚ y = y
x ⊚ I = x
σ n<m ⊚ σ m<l = σ (<-trans m<l n<m)
σ n<m ⊚ τ m<l = τ (<-trans m<l n<m)
τ n<m ⊚ σ m<l = σ (<-trans m<l n<m)
τ n<m ⊚ τ m<l = τ (<-trans m<l n<m)

Globe : Category Level.zero Level.zero Level.zero
Globe = record
  { Obj = ℕ
  ; _⇒_ = GlobeHom
  ; _≡_ = _≣_
  ; id = I
  ; _∘_ = _⊚_
  ; assoc = λ {_} {_} {_} {_} {f} {g} {h} → assoc {f = f} {g} {h}
  ; identityˡ = λ {A} {B} {f} → ≣-refl
  ; identityʳ = identityʳ
  ; equiv = isEquivalence
  ; ∘-resp-≡ = ∘-resp-≡
  }
  where

  assoc : ∀ {A B C D} {f : GlobeHom A B} {g : GlobeHom B C} {h : GlobeHom C D} → (h ⊚ g) ⊚ f ≣ h ⊚ (g ⊚ f)
  assoc {f = I} {I} {I} = ≣-refl
  assoc {f = I} {I} {σ _} = ≣-refl
  assoc {f = I} {I} {τ _} = ≣-refl
  assoc {f = I} {σ _} {I} = ≣-refl
  assoc {f = I} {σ _} {σ _} = ≣-refl
  assoc {f = I} {σ _} {τ _} = ≣-refl
  assoc {f = I} {τ _} {I} = ≣-refl
  assoc {f = I} {τ _} {σ _} = ≣-refl
  assoc {f = I} {τ _} {τ _} = ≣-refl
  assoc {f = σ _} {I} {I} = ≣-refl
  assoc {f = σ _} {I} {σ _} = ≣-refl
  assoc {f = σ _} {I} {τ _} = ≣-refl
  assoc {f = σ _} {σ _} {I} = ≣-refl
  assoc {f = σ _} {σ _} {σ _} = ≣-cong σ ≤-unique
  assoc {f = σ _} {σ _} {τ _} = ≣-cong σ ≤-unique
  assoc {f = σ _} {τ _} {I} = ≣-refl
  assoc {f = σ _} {τ _} {σ _} = ≣-cong σ ≤-unique
  assoc {f = σ _} {τ _} {τ _} = ≣-cong σ ≤-unique
  assoc {f = τ n<m} {I} {I} = ≣-refl
  assoc {f = τ n<m} {I} {σ _} = ≣-refl
  assoc {f = τ n<m} {I} {τ _} = ≣-refl
  assoc {f = τ n<m} {σ _} {I} = ≣-refl
  assoc {f = τ n<m} {σ _} {σ _} = ≣-cong τ ≤-unique
  assoc {f = τ n<m} {σ _} {τ _} = ≣-cong τ ≤-unique
  assoc {f = τ n<m} {τ _} {I} = ≣-refl
  assoc {f = τ n<m} {τ _} {σ _} = ≣-cong τ ≤-unique
  assoc {f = τ n<m} {τ _} {τ _} = ≣-cong τ ≤-unique

  -- this is necessary because Agda lies...
  identityʳ : ∀ {A B} {f : GlobeHom A B} → f ⊚ I ≣ f
  identityʳ {f = I} = ≣-refl
  identityʳ {f = σ _} = ≣-refl
  identityʳ {f = τ _} = ≣-refl

  ∘-resp-≡ : ∀ {A B C} {f h : GlobeHom B C} {g i : GlobeHom A B} → f ≣ h → g ≣ i → f ⊚ g ≣ h ⊚ i
  ∘-resp-≡ ≣-refl ≣-refl = ≣-refl

infixl 30 _σ′
infixl 30 _τ′

data GlobeHom′ : (m n : ℕ) → Set where
  I : ∀ {place : ℕ} → GlobeHom′ place place
  _σ′ : ∀ {n m : ℕ} → GlobeHom′ (suc n) m → GlobeHom′ n m
  _τ′ : ∀ {n m : ℕ} → GlobeHom′ (suc n) m → GlobeHom′ n m

data GlobeEq′ : {m n : ℕ} → GlobeHom′ m n → GlobeHom′ m n → Set where
  both-I : ∀ {m} → GlobeEq′ {m} {m} I I
  both-σ : ∀ {m n x y} → GlobeEq′ {m} {n} (x σ′) (y σ′)
  both-τ : ∀ {m n x y} → GlobeEq′ {m} {n} (x τ′) (y τ′)

GlobeEquiv : ∀ {m n} → IsEquivalence (GlobeEq′ {m} {n})
GlobeEquiv = record { refl = refl; sym = sym; trans = trans }
  where
  refl : ∀ {m n} {x : GlobeHom′ m n} → GlobeEq′ x x
  refl {x = I} = both-I
  refl {x = y σ′} = both-σ
  refl {x = y τ′} = both-τ
  sym : ∀ {m n} {x y : GlobeHom′ m n} → GlobeEq′ x y → GlobeEq′ y x
  sym both-I = both-I
  sym both-σ = both-σ
  sym both-τ = both-τ
  trans : ∀ {m n} {x y z : GlobeHom′ m n} → GlobeEq′ x y → GlobeEq′ y z → GlobeEq′ x z
  trans both-I y∼z = y∼z
  trans both-σ both-σ = both-σ
  trans both-τ both-τ = both-τ

infixl 7 _⊚′_

_⊚′_ : ∀ {l m n} → GlobeHom′ m n → GlobeHom′ l m → GlobeHom′ l n
x ⊚′ I = x
x ⊚′ y σ′ = (x ⊚′ y) σ′
x ⊚′ y τ′ = (x ⊚′ y) τ′

Globe′ : Category Level.zero Level.zero Level.zero
Globe′ = record
  { Obj = ℕ
  ; _⇒_ = GlobeHom′
  ; _≡_ = GlobeEq′
  ; id = I
  ; _∘_ = _⊚′_
  ; assoc = λ {_ _ _ _ f g h} → assoc {f = f} {g} {h}
  ; identityˡ = identityˡ
  ; identityʳ = identityʳ
  ; equiv = GlobeEquiv
  ; ∘-resp-≡ = ∘-resp-≡
  }
  where
  assoc : ∀ {A B C D} {f : GlobeHom′ A B} {g : GlobeHom′ B C} {h : GlobeHom′ C D} → GlobeEq′ ((h ⊚′ g) ⊚′ f) (h ⊚′ (g ⊚′ f))
  assoc {f = I} = refl
    where open IsEquivalence GlobeEquiv
  assoc {f = y σ′} = both-σ
  assoc {f = y τ′} = both-τ
  identityˡ : ∀ {A B} {f : GlobeHom′ A B} → GlobeEq′ (I ⊚′ f) f
  identityˡ {f = I} = both-I
  identityˡ {f = y σ′} = both-σ
  identityˡ {f = y τ′} = both-τ
  identityʳ : ∀ {A B} {f : GlobeHom′ A B} → GlobeEq′ (f ⊚′ I) f
  identityʳ = IsEquivalence.refl GlobeEquiv
  ∘-resp-≡ : ∀ {A B C} {f h : GlobeHom′ B C} {g i : GlobeHom′ A B} → GlobeEq′ f h → GlobeEq′ g i → GlobeEq′ (f ⊚′ g) (h ⊚′ i)
  ∘-resp-≡ f∼h both-I = f∼h
  ∘-resp-≡ f∼h both-σ = both-σ
  ∘-resp-≡ f∼h both-τ = both-τ

-- Fix this
{-
data ReflexiveGlobeHom : (m n : ℕ) → Set where
  plain : ∀ {m n} → GlobeHom m n → ReflexiveGlobeHom m n
  ι : ∀ {m n} → ReflexiveGlobeHom m n → ReflexiveGlobeHom m (suc n)

stripped : ∀ {m n} → (cons : n < m → GlobeHom n m) → n < suc m → GlobeHom n m
stripped cons n<Sm with <-unsucʳ n<Sm
stripped cons n<Sm | inl ≣-refl = I
stripped cons n<Sm | inr n<m = cons n<m

_⊚ʳ_ : ∀ {l m n} → ReflexiveGlobeHom m n → ReflexiveGlobeHom l m → ReflexiveGlobeHom l n
ι x ⊚ʳ y = ι (x ⊚ʳ y)
plain x ⊚ʳ plain y = plain (x ⊚ y)
plain I ⊚ʳ ι y = ι y
plain (σ _) ⊚ʳ ι y = (plain (stripped σ n<m)) ⊚ʳ y
plain (τ n<m) ⊚ʳ ι y = (plain (stripped τ n<m)) ⊚ʳ y
-}


module Issue251 where

record Foo : Set₁ where
  field
    A : Set
    B : Set

foo : Set → Set → Foo
foo = λ A B → record {A = A; B = B}


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

module Pi0Cat where

-- Proving that Pi at level 0 symmetric rig groupoid

open import Level using () renaming (zero to lzero)
open import Data.Unit using (tt)
open import Data.Product using (_,_)

open import Categories.Category using (Category)
open import Categories.Groupoid using (Groupoid)
open import Categories.Monoidal using (Monoidal)
open import Categories.Monoidal.Helpers using (module MonoidalHelperFunctors)
open import Categories.Bifunctor using (Bifunctor)
open import Categories.NaturalIsomorphism using (NaturalIsomorphism)
open import Categories.Monoidal.Braided using (Braided)
open import Categories.Monoidal.Symmetric using (Symmetric)
open import Categories.RigCategory
  using (RigCategory; module BimonoidalHelperFunctors)

open import PiU using (U; PLUS; ZERO; TIMES; ONE)
open import PiLevel0 using (_⟷_; !; triv≡; triv≡Equiv;
  id⟷; _◎_;
  _⊕_; unite₊l; uniti₊l; unite₊r; uniti₊r; swap₊; assocr₊; assocl₊;
  _⊗_; unite⋆l; uniti⋆l; unite⋆r; uniti⋆r; swap⋆; assocr⋆; assocl⋆;
  absorbl; absorbr; factorzl; factorzr;
  dist; factor; distl; factorl)

------------------------------------------------------------------------------
-- It is a category...

PiCat : Category lzero lzero lzero
PiCat = record
  { Obj = U
  ; _⇒_ = _⟷_
  ; _≡_ = triv≡
  ; id = id⟷
  ; _∘_ = λ y⟷z x⟷y → x⟷y ◎ y⟷z
  ; assoc = tt
  ; identityˡ = tt
  ; identityʳ = tt
  ; equiv = triv≡Equiv
  ; ∘-resp-≡ = λ _ _ → tt
  }

-- and a groupoid

PiGroupoid : Groupoid PiCat
PiGroupoid = record
  { _⁻¹ = !
  ; iso = record { isoˡ = tt ; isoʳ = tt }
  }

-- additive bifunctor and monoidal structure

⊕-bifunctor : Bifunctor PiCat PiCat PiCat
⊕-bifunctor = record
  { F₀ = λ {(u , v) → PLUS u v}
  ; F₁ = λ {(x⟷y , z⟷w) → x⟷y ⊕ z⟷w }
  ; identity = tt
  ; homomorphism = tt
  ; F-resp-≡ = λ _ → tt
  }

module ⊎h = MonoidalHelperFunctors PiCat ⊕-bifunctor ZERO

0⊕x≡x : NaturalIsomorphism ⊎h.id⊗x ⊎h.x
0⊕x≡x = record
  { F⇒G = record
    { η = λ X → unite₊l
    ; commute = λ _ → tt }
  ; F⇐G = record
    { η = λ X → uniti₊l
    ; commute = λ _ → tt }
  ; iso = λ X → record { isoˡ = tt; isoʳ = tt }
  }

x⊕0≡x : NaturalIsomorphism ⊎h.x⊗id ⊎h.x
x⊕0≡x = record
  { F⇒G = record
    { η = λ X → unite₊r
    ; commute = λ _ → tt
    }
  ; F⇐G = record
    { η = λ X → uniti₊r
    ; commute = λ _ → tt
    }
  ; iso = λ X → record
    { isoˡ = tt
    ; isoʳ = tt
    }
  }

[x⊕y]⊕z≡x⊕[y⊕z] : NaturalIsomorphism ⊎h.[x⊗y]⊗z ⊎h.x⊗[y⊗z]
[x⊕y]⊕z≡x⊕[y⊕z] = record
  { F⇒G = record
    { η = λ X → assocr₊
    ; commute = λ f → tt
    }
  ; F⇐G = record
    { η = λ X → assocl₊
    ; commute = λ _ → tt
    }
  ; iso = λ X → record
    { isoˡ = tt
    ; isoʳ = tt
    }
  }

M⊕ : Monoidal PiCat
M⊕ = record
  { ⊗ = ⊕-bifunctor
  ; id = ZERO
  ; identityˡ = 0⊕x≡x
  ; identityʳ = x⊕0≡x
  ; assoc = [x⊕y]⊕z≡x⊕[y⊕z]
  ; triangle = tt
  ; pentagon = tt
  }

-- multiplicative bifunctor and monoidal structure

⊗-bifunctor : Bifunctor PiCat PiCat PiCat
⊗-bifunctor =  record
  { F₀ = λ {(u , v) → TIMES u v}
  ; F₁ = λ {(x⟷y , z⟷w) → x⟷y ⊗ z⟷w }
  ; identity = tt
  ; homomorphism = tt
  ; F-resp-≡ = λ _ → tt
  }

module ⊗h = MonoidalHelperFunctors PiCat ⊗-bifunctor ONE

1⊗x≡x : NaturalIsomorphism ⊗h.id⊗x ⊗h.x
1⊗x≡x = record
  { F⇒G = record
    { η = λ X → unite⋆l
    ; commute = λ _ → tt }
  ; F⇐G = record
    { η = λ X → uniti⋆l
    ; commute = λ _ → tt }
  ; iso = λ X → record { isoˡ = tt; isoʳ = tt }
  }

x⊗1≡x : NaturalIsomorphism ⊗h.x⊗id ⊗h.x
x⊗1≡x = record
  { F⇒G = record
    { η = λ X → unite⋆r
    ; commute = λ _ → tt
    }
  ; F⇐G = record
    { η = λ X → uniti⋆r
    ; commute = λ _ → tt
    }
  ; iso = λ X → record
    { isoˡ = tt
    ; isoʳ = tt
    }
  }

[x⊗y]⊗z≡x⊗[y⊗z] : NaturalIsomorphism ⊗h.[x⊗y]⊗z ⊗h.x⊗[y⊗z]
[x⊗y]⊗z≡x⊗[y⊗z] = record
  { F⇒G = record
    { η = λ X → assocr⋆
    ; commute = λ f → tt
    }
  ; F⇐G = record
    { η = λ X → assocl⋆
    ; commute = λ _ → tt
    }
  ; iso = λ X → record
    { isoˡ = tt
    ; isoʳ = tt
    }
  }

M⊗ : Monoidal PiCat
M⊗ = record
  { ⊗ = ⊗-bifunctor
  ; id = ONE
  ; identityˡ = 1⊗x≡x
  ; identityʳ = x⊗1≡x
  ; assoc = [x⊗y]⊗z≡x⊗[y⊗z]
  ; triangle = tt
  ; pentagon = tt
  }

x⊕y≡y⊕x : NaturalIsomorphism ⊎h.x⊗y ⊎h.y⊗x
x⊕y≡y⊕x = record
  { F⇒G = record { η = λ X → swap₊ ; commute = λ f → tt }
  ; F⇐G = record { η = λ X → swap₊ ; commute = λ f → tt }
  ; iso = λ X → record { isoˡ = tt ; isoʳ = tt } }

BM⊕ : Braided M⊕
BM⊕ = record { braid = x⊕y≡y⊕x ; unit-coh = tt; hexagon₁ = tt ; hexagon₂ = tt }

x⊗y≡y⊗x : NaturalIsomorphism ⊗h.x⊗y ⊗h.y⊗x
x⊗y≡y⊗x = record
  { F⇒G = record { η = λ X → swap⋆ ; commute = λ f → tt }
  ; F⇐G = record { η = λ X → swap⋆ ; commute = λ f → tt }
  ; iso = λ X → record { isoˡ = tt ; isoʳ = tt } }

BM⊗ : Braided M⊗
BM⊗ = record { braid = x⊗y≡y⊗x ; unit-coh = tt; hexagon₁ = tt ; hexagon₂ = tt }

SBM⊕ : Symmetric BM⊕
SBM⊕ = record { symmetry = tt }

SBM⊗ : Symmetric BM⊗
SBM⊗ = record { symmetry = tt }

module r = BimonoidalHelperFunctors BM⊕ BM⊗

x⊗0≡0 : NaturalIsomorphism r.x⊗0 r.0↑
x⊗0≡0 = record
  { F⇒G = record { η = λ X → absorbl ; commute = λ f → tt }
  ; F⇐G = record { η = λ X → factorzr ; commute = λ f → tt }
  ; iso = λ X → record { isoˡ = tt ; isoʳ = tt }
  }

0⊗x≡0 : NaturalIsomorphism r.0⊗x r.0↑
0⊗x≡0 = record
  { F⇒G = record { η = λ X → absorbr ; commute = λ f → tt }
  ; F⇐G = record { η = λ X → factorzl ; commute = λ f → tt }
  ; iso = λ X → record { isoˡ = tt ; isoʳ = tt }
  }

x⊗[y⊕z]≡[x⊗y]⊕[x⊗z] : NaturalIsomorphism r.x⊗[y⊕z] r.[x⊗y]⊕[x⊗z]
x⊗[y⊕z]≡[x⊗y]⊕[x⊗z] = record -- this probably says we need distl/distr
  { F⇒G = record { η = λ X → distl ; commute = λ f → tt }
  ; F⇐G = record { η = λ X → factorl ; commute = λ f → tt }
  ; iso = λ X → record { isoˡ = tt ; isoʳ = tt }
  }

[x⊕y]⊗z≡[x⊗z]⊕[y⊗z] : NaturalIsomorphism r.[x⊕y]⊗z r.[x⊗z]⊕[y⊗z]
[x⊕y]⊗z≡[x⊗z]⊕[y⊗z] = record
  { F⇒G = record { η = λ X → dist ; commute = λ f → tt }
  ; F⇐G = record { η = λ X → factor ; commute = λ f → tt }
  ; iso = λ X → record { isoˡ = tt ; isoʳ = tt }
  }

Pi0Rig : RigCategory SBM⊕ SBM⊗
Pi0Rig = record
  { distribₗ = x⊗[y⊕z]≡[x⊗y]⊕[x⊗z]
  ; distribᵣ = [x⊕y]⊗z≡[x⊗z]⊕[y⊗z]
  ; annₗ = 0⊗x≡0
  ; annᵣ = x⊗0≡0
  ; laplazaI = tt
  ; laplazaII = tt
  ; laplazaIV = tt
  ; laplazaVI = tt
  ; laplazaIX = tt
  ; laplazaX = tt
  ; laplazaXI = tt
  ; laplazaXIII = tt
  ; laplazaXV = tt
  ; laplazaXVI = tt
  ; laplazaXVII = tt
  ; laplazaXIX = tt
  ; laplazaXXIII = tt
  }

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


open import Relation.Binary using (IsDecEquivalence)
open import Agda.Builtin.Equality

module UnifyMguCorrectG (FunctionName : Set) ⦃ isDecEquivalenceA : IsDecEquivalence (_≡_ {A = FunctionName}) ⦄ (PredicateName VariableName : Set) where

open import UnifyTermF FunctionName
open import UnifyMguF FunctionName
open import UnifyMguCorrectF FunctionName

open import Data.Nat
open import Data.Vec
open import Function
open import Data.Fin renaming (thin to thinF; thick to thickF)

data Formula (n : ℕ) : Set
 where
  atomic : PredicateName → ∀ {t} → Vec (Term n) t → Formula n
  logical : Formula n →
            Formula n →
            Formula n
  quantified : Formula (suc n) → Formula n

open import Relation.Binary.PropositionalEquality

instance ThinFormula : Thin Formula
Thin.thin ThinFormula x (atomic x₁ x₂) = atomic x₁ (thin x x₂)
Thin.thin ThinFormula x (logical x₁ x₂) = logical (thin x x₁) (thin x x₂)
Thin.thin ThinFormula x (quantified x₁) = quantified (thin zero x₁)
Thin.thinfact1 ThinFormula f {atomic pn1 ts1} {atomic pn2 ts2} r = {!!}
Thin.thinfact1 ThinFormula f {atomic x x₁} {logical y y₁} ()
Thin.thinfact1 ThinFormula f {atomic x x₁} {quantified y} ()
Thin.thinfact1 ThinFormula f {logical x x₁} {atomic x₂ x₃} ()
Thin.thinfact1 ThinFormula f {logical x x₁} {logical y y₁} x₂ = {!!}
Thin.thinfact1 ThinFormula f {logical x x₁} {quantified y} ()
Thin.thinfact1 ThinFormula f {quantified x} {atomic x₁ x₂} ()
Thin.thinfact1 ThinFormula f {quantified x} {logical y y₁} ()
Thin.thinfact1 ThinFormula f {quantified x} {quantified y} x₁ = {!!}

foo~ : ∀ {m₁ n₁} →
       (Fin m₁ → Term n₁) →
       Fin (suc m₁) → Term (suc n₁)
foo~ f = (λ { zero → i zero ; (suc x) → thin zero (f x)})

foo~i≐i : ∀ {m} → foo~ {m} i ≐ i
foo~i≐i zero = refl
foo~i≐i (suc x) = refl

instance SubstitutionFormula : Substitution Formula
Substitution._◃_ SubstitutionFormula = _◃′_ where
  _◃′_ : ∀ {m n} -> (f : m ~> n) -> Formula m -> Formula n
  f ◃′ atomic 𝑃 τs = atomic 𝑃 (f ◃ τs)
  f ◃′ logical φ₁ φ₂ = logical (f ◃ φ₁) (f ◃ φ₂)
  f ◃′ quantified φ = quantified (foo~ f ◃ φ)

instance SubstitutionExtensionalityFormula : SubstitutionExtensionality Formula
SubstitutionExtensionality.◃ext SubstitutionExtensionalityFormula x (atomic x₁ x₂) = cong (atomic x₁) (◃ext x x₂)
SubstitutionExtensionality.◃ext SubstitutionExtensionalityFormula x (logical t t₁) = cong₂ logical (◃ext x t) (◃ext x t₁)
SubstitutionExtensionality.◃ext SubstitutionExtensionalityFormula x (quantified t) = cong quantified ((◃ext (λ { zero → refl ; (suc x₁) → cong (mapTerm suc) (x x₁)}) t)) --

instance SubFact1Formula : Sub.Fact1 Formula
Sub.Fact1.fact1 SubFact1Formula (atomic x x₁) = cong (atomic x) (Sub.fact1 x₁)
Sub.Fact1.fact1 SubFact1Formula (logical t t₁) = cong₂ logical (Sub.fact1 t) (Sub.fact1 t₁)
Sub.Fact1.fact1 SubFact1Formula {n} (quantified φ) = cong quantified (trans (◃ext {Formula} {_} {_} {foo~ {_} i} {i} (foo~i≐i {_}) φ) (Sub.fact1 φ))

Unifies⋆F : ∀ {m} (s t : Formula m) -> Property⋆ m
Unifies⋆F s t f = f ◃ s ≡ f ◃ t


{-# OPTIONS --safe --warning=error #-}

open import Boolean.Definition
open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)
open import LogicalFormulae
open import Logic.PropositionalLogic
open import Functions.Definition
open import Numbers.Naturals.Order
open import Vectors

module Logic.PropositionalLogicExamples where

emptySubset : {a : _} (A : Set a) → IsSubset False A
emptySubset A = record { ofElt = λ () }

emptyEntailment : {a b : _} {A : Set a} {P : Propositions A} → Entails (emptySubset (Propositions A)) P → Tautology P
emptyEntailment {a} {b} {A} {P} entails v = entails {v} λ {s} → exFalso s

emptyEntailment' : {a b : _} {A : Set a} {P : Propositions A} → Tautology P → Entails (emptySubset (Propositions A)) P
emptyEntailment' isTaut {v} _ = isTaut v

data TwoElements : Set where
  One : TwoElements
  Two : TwoElements

twoElementSubset : {a : _} {A : Set a} → {P Q R : Propositions A} → TwoElements → Propositions A
twoElementSubset {P = P} {Q} {R} One = implies P Q
twoElementSubset {P = P} {Q} {R} Two = implies Q R

twoElementSubsetInj : {a : _} {A : Set a} {P Q R : Propositions A} → (P ≡ Q → False) → Injection (twoElementSubset {P = P} {Q} {R})
twoElementSubsetInj {P = P} {Q} {R} p!=q {One} {One} refl = refl
twoElementSubsetInj {P = P} {Q} {R} p!=q {One} {Two} pr with impliesInjective pr
twoElementSubsetInj {P = P} {Q} {R} p!=q {One} {Two} pr | fst ,, snd = exFalso (p!=q fst)
twoElementSubsetInj {P = P} {Q} {R} p!=q {Two} {One} pr with impliesInjective pr
twoElementSubsetInj {P = P} {Q} {R} p!=q {Two} {One} pr | fst ,, snd = exFalso (p!=q (equalityCommutative fst))
twoElementSubsetInj {P = P} {Q} {R} p!=q {Two} {Two} refl = refl

badBool : BoolFalse ≡ BoolTrue → False
badBool ()

semanticEntailmentTransitive : {a : _} {A : Set a} {P Q R : Propositions A} → (p!=q : P ≡ Q → False) → Entails record { ofElt = twoElementSubset } (implies P R)
semanticEntailmentTransitive {P = P} {Q} {R} p!=q {v} pr with inspect (Valuation.v v P)
semanticEntailmentTransitive {P = P} {Q} {R} p!=q {v} pr | BoolTrue with≡ pT with inspect (Valuation.v v Q)
semanticEntailmentTransitive {P = P} {Q} {R} p!=q {v} pr | BoolTrue with≡ pT | BoolTrue with≡ qT with inspect (Valuation.v v R)
semanticEntailmentTransitive {P = P} {Q} {R} p!=q {v} pr | BoolTrue with≡ pT | BoolTrue with≡ qT | BoolTrue with≡ rT = Valuation.vImplicationT v rT
semanticEntailmentTransitive {P = P} {Q} {R} p!=q {v} pr | BoolTrue with≡ pT | BoolTrue with≡ qT | BoolFalse with≡ rF = exFalso (badBool (transitivity (equalityCommutative (Valuation.vImplicationF v qT rF)) (pr {Two})))
semanticEntailmentTransitive {P = P} {Q} {R} p!=q {v} pr | BoolTrue with≡ pT | BoolFalse with≡ qF = exFalso (badBool (transitivity (equalityCommutative (Valuation.vImplicationF v pT qF)) (pr {One})))
semanticEntailmentTransitive {P = P} {Q} {R} p!=q {v} pr | BoolFalse with≡ pF = Valuation.vImplicationVacuous v pF

-- Subset {p -> q, q -> r}
pQQR : {a : _} {A : Set a} {P Q R : Propositions A} → TwoElements → Propositions A
pQQR {P = P} {Q} {R} One = implies P Q
pQQR {P = P} {Q} {R} Two = implies Q R

pQQRSubsetInj : {a : _} {A : Set a} {P Q R : Propositions A} → (P ≡ Q → False) → Injection (pQQR {P = P} {Q} {R})
pQQRSubsetInj {P = P} {Q} {R} p!=q {One} {One} refl = refl
pQQRSubsetInj {P = P} {Q} {R} p!=q {One} {Two} pr with impliesInjective pr
pQQRSubsetInj {P = P} {Q} {R} p!=q {One} {Two} pr | p=q ,, _ = exFalso (p!=q p=q)
pQQRSubsetInj {P = P} {Q} {R} p!=q {Two} {One} pr with impliesInjective pr
pQQRSubsetInj {P = P} {Q} {R} p!=q {Two} {One} pr | q=p ,, _ = exFalso (p!=q (equalityCommutative q=p))
pQQRSubsetInj {P = P} {Q} {R} p!=q {Two} {Two} refl = refl

syntacticEntailmentExample : {a : _} {A : Set a} {P Q R : Propositions A} → (p!=q : P ≡ Q → False) → Proof propositionalAxioms (record { ofElt = pQQR {P = P} {Q} {R} }) 7
syntacticEntailmentExample {P = P} {Q} {R} p!=q = nextStep 6 (nextStep 5 (nextStep 4 (nextStep 3 (nextStep 2 (nextStep 1 (nextStep 0 empty (axiom (Two , record { one = P ; two = Q ; three = R }))) (given Two)) (axiom (One , ((implies Q R) ,, P)))) (modusPonens (record { element = implies (implies Q R) (implies P (implies Q R)) ; position = 0 ; pos<N = le 2 refl ; elementIsAt = refl }) (record { element = implies Q R ; position = 1 ; elementIsAt = refl ; pos<N = le 1 refl }) (implies P (implies Q R)) refl)) (modusPonens (record { element = implies (implies P (implies Q R)) (implies (implies P Q) (implies P R)) ; position = 3 ; pos<N = le 0 refl ; elementIsAt = refl }) (record { element = implies P (implies Q R) ; position = 0 ; pos<N = succIsPositive _ ; elementIsAt = refl }) (implies (implies P Q) (implies P R)) refl)) (given One)) (modusPonens (record { element = implies (implies P Q) (implies P R) ; position = 1 ; pos<N = succPreservesInequality (succIsPositive _) ; elementIsAt = refl }) (record { element = implies P Q ; position = 0 ; pos<N = succIsPositive _ ; elementIsAt = refl }) (implies P R) refl)

pQQRProof : {a : _} {A : Set a} {P Q R : Propositions A} → (p!=q : P ≡ Q → False) → Proves propositionalAxioms (record { ofElt = pQQR {P = P} {Q} {R} }) (implies P R)
pQQRProof p!=q = record { n = 6 ; proof = syntacticEntailmentExample p!=q ; ofStatement = refl }

-- Subset {p}
pSubset : {a : _} {A : Set a} {P : Propositions A} → True → Propositions A
pSubset {P = P} record {} = implies P P

pSubsetInj : {a : _} {A : Set a} {P : Propositions A} → Injection (pSubset {P = P})
pSubsetInj {P = P} {record {}} {record {}} refl = refl

syntacticEntailmentPP : {a : _} {A : Set a} {P : Propositions A} → Proof propositionalAxioms record { ofElt = pSubset {P = P} } 5
syntacticEntailmentPP {P = P} = nextStep 4 (nextStep 3 (nextStep 2 (nextStep 1 (nextStep 0 empty (axiom (One , (P ,, (implies P P))))) (axiom (Two , record { one = P ; two = implies P P ; three = P }))) (modusPonens (record { element = implies (implies P (implies (implies P P) P)) (implies (implies P (implies P P)) (implies P P)) ; position = 0 ; pos<N = succIsPositive _ ; elementIsAt = refl }) (record { element = implies P (implies (implies P P) P) ; position = 1 ; pos<N = succPreservesInequality (succIsPositive _) ; elementIsAt = refl }) (implies (implies P (implies P P)) (implies P P)) refl)) (axiom (One , (P ,, P)))) (modusPonens (record { element = implies (implies P (implies P P)) (implies P P) ; position = 1 ; pos<N = succPreservesInequality (succIsPositive _) ; elementIsAt = refl }) (record { element = implies P (implies P P) ; position = 0 ; pos<N = succIsPositive _ ; elementIsAt = refl }) (implies P P) refl)

pImpliesP : {a : _} {A : Set a} {P : Propositions A} → Proves propositionalAxioms record { ofElt = pSubset {P = P} } (implies P P)
Proves.n (pImpliesP {P = P}) = 4
Proves.proof (pImpliesP {P = P}) = syntacticEntailmentPP {P = P}
Proves.ofStatement (pImpliesP {P = P}) = refl


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

module Categories.FreeObjects.Free where

open import Level
open import Relation.Binary.PropositionalEquality using (_≡_; refl; cong)
open import Relation.Binary using (IsEquivalence)
open import Categories.Functor renaming (id to idF)
open import Categories.Category
open import Categories.Adjoint
open import Categories.NaturalTransformation.Core

import Categories.Morphism.Reasoning as MR

private
  variable
    o ℓ e o' ℓ' e' : Level

record FreeObject {C : Category o ℓ e} {D : Category o' ℓ' e'} (U : Functor D C) (X : Category.Obj C) : Set (suc (e ⊔ e' ⊔ o ⊔ ℓ ⊔ o' ⊔ ℓ')) where

  private
    module C = Category C using (Obj; id; identityʳ; identityˡ; _⇒_; _∘_; equiv; module Equiv)
    module D = Category D using (Obj; _⇒_; _∘_; equiv)
    module U = Functor U using (₀; ₁)

  field
     FX : D.Obj
     η : C [ X , U.₀ FX ]
     _* : ∀ {A : D.Obj} → C [ X , U.₀ A ] → D [ FX , A ]
     *-lift : ∀ {A : D.Obj} (f : C [ X , U.₀ A ]) → C [ (U.₁ (f *) C.∘ η) ≈ f ]
     *-uniq : ∀ {A : D.Obj} (f : C [ X , U.₀ A ]) (g : D [ FX , A ]) → C [ (U.₁ g) C.∘ η ≈ f ] → D [ g ≈ f * ]

  *-cong : ∀ {A : D.Obj} {f g : C [ X , U.₀ A ]} → C [ f ≈ g ] → D [ f * ≈ g * ]
  *-cong {A} {f} {g} f≈g = *-uniq g (f *) (trans (*-lift f) f≈g)    where open C.Equiv

open FreeObject

module _  {C : Category o ℓ e} {D : Category o' ℓ' e'} (U : Functor D C) where

  private
    module C = Category C using (Obj; id; _⇒_; _∘_; identityʳ; identityˡ; assoc; equiv; module Equiv; module HomReasoning)
    module D = Category D using (Obj; id; _⇒_; _∘_; identityʳ; identityˡ; assoc; equiv; module Equiv; module HomReasoning)
    module U = Functor U using (₀; ₁; identity; homomorphism)

  -- free object construction is functorial
  FO⇒Functor : (F : ((X : C.Obj) → FreeObject U X)) → Functor C D
  FO⇒Functor F =
    record
      { F₀ = λ X → FX (F X)
      ; F₁ = λ {X} {Y} f → _* (F X) (η (F Y) C.∘ f)
      ; identity = λ {X} → sym (*-uniq (F X) (η (F X) C.∘ C.id) D.id (id-proof {X}))
      ; homomorphism = λ {X} {Y} {Z} {f} {g} →
          sym (*-uniq (F X) (η (F Z) C.∘ (g C.∘ f))
              ((_* (F Y) (η (F Z) C.∘ g)) D.∘ (_* (F X) (η (F Y) C.∘ f)))
              (⟺ (hom-proof {X} {Y} {Z} {f} {g}))
              )
      ; F-resp-≈ = λ {X} {Y} {f} {g} f≈g → sym (*-uniq (F X) (η (F Y) C.∘ f) (_* (F X) (η (F Y) C.∘ g)) (resp-proof  f≈g))
      }
      where
        open C.HomReasoning
        open D.Equiv

        id-proof : ∀ {X : C.Obj} → C [ U.₁ D.id C.∘ η (F X) ≈ η (F X) C.∘ C.id ]
        id-proof {X} = begin
           (U.₁ D.id) C.∘ FX.η         ≈⟨ U.identity ⟩∘⟨refl ⟩
           C.id C.∘ FX.η               ≈⟨ id-comm-sym ⟩
           FX.η C.∘ C.id               ∎
           where
            open MR C
            module FX = FreeObject (F X) using (η)

        hom-proof : ∀ {X : C.Obj} {Y : C.Obj} {Z : C.Obj} {f : C [ X , Y ]} {g : C [ Y , Z ]} →
            C [ (η (F Z) C.∘ (g C.∘ f)) ≈ (U.₁ (_* (F Y) (η (F Z) C.∘ g) D.∘ _* (F X) (η (F Y) C.∘ f) ) C.∘ η (F X)) ]
        hom-proof {X} {Y} {Z} {f} {g} =  begin
          FZ.η C.∘ (g C.∘ f)                                                     ≈˘⟨ pushˡ (FY.*-lift (FZ.η C.∘ g)) ⟩
          (U.₁((FZ.η C.∘ g) FY.*) C.∘ FY.η) C.∘ f                                ≈˘⟨ pushʳ (FX.*-lift (FY.η C.∘ f)) ⟩
          U.₁((FZ.η C.∘ g) FY.*) C.∘ (U.₁((FY.η C.∘ f) FX.*) C.∘ FX.η)           ≈˘⟨ pushˡ U.homomorphism ⟩
          U.₁ ((FZ.η C.∘ g) FY.* D.∘ (FY.η C.∘ f) FX.*) C.∘ FX.η                 ∎
          where
            open MR C
            open C.Equiv
            module FX =  FreeObject (F X) using (η; _*; *-lift)
            module FY =  FreeObject (F Y) using (η; _*; *-lift)
            module FZ =  FreeObject (F Z) using (η)

        resp-proof :{X Y : C.Obj} {f g : C [ X , Y ]} → C [ f ≈ g ] → C [ U.₁ ((F X *) (η (F Y) C.∘ g)) C.∘ η (F X) ≈ η (F Y) C.∘ f ]
        resp-proof {X} {Y} {f} {g} f≈g =  begin
            U.₁((FY.η C.∘ g) FX.*) C.∘ FX.η      ≈⟨ FX.*-lift (FY.η C.∘ g) ⟩
            (FY.η C.∘ g)                         ≈˘⟨ refl⟩∘⟨ f≈g ⟩
            (FY.η C.∘ f)                         ∎
            where
              module FX = FreeObject (F X) using (η; _*; *-lift)
              module FY = FreeObject (F Y) using (η; _*; *-lift)

  FO⇒unit : (F : ((X : C.Obj) → FreeObject U X)) → NaturalTransformation idF (U ∘F FO⇒Functor F)
  FO⇒unit F = ntHelper (record { η = λ X → η (F X) ; commute = λ {X} {Y} f → sym (*-lift (F X) (η (F Y) C.∘ f)) }) where open C.Equiv

  -- define a counit
  FO⇒counit : (F : ((X : C.Obj) → FreeObject U X)) → NaturalTransformation (FO⇒Functor F ∘F U) idF
  FO⇒counit F = ntHelper (record { η = λ X → _* (F (U.₀ X)) C.id ; commute = λ {X} {Y} f → counit-comm {X} {Y} f })
      where
      open D.Equiv
      module F = Functor (FO⇒Functor F) using (₀; ₁; identity; homomorphism)

      counit-comm : {X Y : D.Obj} (f : D [ X , Y ]) → D [ (_* (F (U.₀ Y)) C.id D.∘ F.₁ (U.₁ f)) ≈ (f D.∘ _* (F (U.₀ X)) C.id) ]
        -- proof idea: id* ∘ FU f ≈ (U f)* ≈ f ∘ id* using *-uniq two times

        -- left identity
      counit-comm-left : {X Y : D.Obj} (f : D [ X , Y ]) → C [ U.₁ ((_* (F (U.₀ Y)) C.id) D.∘ (F.₁ (U.₁ f)) ) C.∘ η (F (U.₀ X))  ≈ U.₁ f ]
      counit-comm-left {X} {Y} f =  begin
        U.₁(C.id FUY.* D.∘ F.₁(U.₁ f)) C.∘ FUX.η               ≈⟨ U.homomorphism ⟩∘⟨refl ⟩
        (U.₁ (C.id FUY.*) C.∘ U.₁ (F.₁(U.₁ f))) C.∘ FUX.η      ≈⟨ C.assoc ⟩
        U.₁ (C.id FUY.*) C.∘ (U.₁(F.₁(U.₁ f)) C.∘ FUX.η)       ≈⟨ refl⟩∘⟨ FUX.*-lift (FUY.η C.∘ U.₁ f) ⟩
        U.₁ (C.id FUY.*) C.∘ (FUY.η C.∘ U.₁ f)                 ≈˘⟨ C.assoc ⟩
        (U.₁ (C.id FUY.*) C.∘ FUY.η) C.∘ U.₁ f                 ≈⟨ FUY.*-lift C.id ⟩∘⟨refl ⟩
        C.id C.∘ U.₁ f                                         ≈⟨ C.identityˡ ⟩
        U.₁ f                                                  ∎
          where
            open C.HomReasoning
            module FUX = FreeObject (F (U.₀ X)) using (η; *-lift)
            module FUY = FreeObject (F (U.₀ Y)) using (η; _*; *-lift)

      -- right identity
      counit-comm-right : {X Y : D.Obj} (f : D [ X , Y ]) → C [ U.₁ (f D.∘ (_* (F (U.₀ X)) C.id)) C.∘ η (F (U.₀ X)) ≈ U.₁ f ]
      counit-comm-right {X} {Y} f =  begin
        U.₁ (f D.∘ (C.id FUX.*)) C.∘ FUX.η                ≈⟨ U.homomorphism ⟩∘⟨refl ⟩
        (U.₁ f C.∘ U.₁ (C.id FUX.*)) C.∘ FUX.η            ≈⟨ C.assoc ⟩
        U.₁ f C.∘ (U.₁ (C.id FUX.*) C.∘ FUX.η)            ≈⟨ refl⟩∘⟨ FUX.*-lift C.id ⟩
        U.₁ f C.∘ C.id                                    ≈⟨ C.identityʳ ⟩
        U.₁ f                                             ∎
        where
          open C.HomReasoning
          module FUX = FreeObject (F (U.₀ X)) using (η; _*; *-lift)

      counit-comm {X} {Y} f =  begin
        C.id FUY.* D.∘ F.₁ (U.₁ f)        ≈⟨ FUX.*-uniq (U.₁ f) (C.id FUY.* D.∘ F.₁ (U.₁ f)) (counit-comm-left {X} {Y} f) ⟩
        (U.₁ f) FUX.*                     ≈˘⟨ FUX.*-uniq (U.₁ f) (f D.∘ C.id FUX.*) (counit-comm-right {X} {Y} f) ⟩
        f D.∘ C.id FUX.*                  ∎
        where
          open D.HomReasoning
          module FUX = FreeObject (F (U.₀ X)) using (η; _*; *-lift; *-uniq)
          module FUY = FreeObject (F (U.₀ Y)) using (η; _*; *-lift)

  -- Free object functor is left adjoint to the forgetful functor
  FO⇒LAdj : (F : ((X : C.Obj) → FreeObject U X)) → (FO⇒Functor F) ⊣ U
  FO⇒LAdj F =  record
    { unit = FO⇒unit F
    ; counit = FO⇒counit F
    ; zig = zig
    ; zag = zag
    }
    where
      module F = Functor (FO⇒Functor F) using (₀; ₁; identity; homomorphism)

      zig-comm1 : {X : C.Obj} → C [ U.₁ D.id C.∘ η (F X) ≈ η (F X) ]
      zig-comm1 {X} =  elimˡ (U.identity)  where open MR C

      zig-helper1 : {X : C.Obj} → D [ _* (F X) (η (F X)) ≈ D.id ]
      zig-helper1 {X} =  sym (FX.*-uniq FX.η D.id (zig-comm1 {X}))
        where
          open D.Equiv
          module FX = FreeObject (F X) using (η; *-uniq)

      zig-comm2 : {X : C.Obj} → C [ U.₁ (_* (F (U.₀ (F.₀ X))) C.id D.∘ F.₁ (η (F X)) ) C.∘ η (F X) ≈ η (F X) ]
      zig-comm2 {X} = begin
        U.₁(C.id FUFX.* D.∘ F.₁ FX.η) C.∘ FX.η                   ≈⟨ U.homomorphism ⟩∘⟨refl ⟩
        (U.₁(C.id FUFX.*) C.∘ U.₁(F.₁ FX.η)) C.∘ FX.η            ≈⟨ C.assoc ⟩
        U.₁(C.id FUFX.*) C.∘ (U.₁(F.₁ FX.η) C.∘ FX.η)            ≈˘⟨ refl⟩∘⟨ NaturalTransformation.commute (FO⇒unit F) FX.η ⟩
        U.₁(C.id FUFX.*) C.∘ (FUFX.η C.∘ FX.η)                   ≈˘⟨ C.assoc ⟩
        (U.₁(C.id FUFX.*) C.∘ FUFX.η) C.∘ FX.η                   ≈⟨ FUFX.*-lift C.id ⟩∘⟨refl ⟩
        C.id C.∘ FX.η                                            ≈⟨ C.identityˡ ⟩
        FX.η                                                     ∎
        where
          open C.HomReasoning
          module FX = FreeObject (F X) using (η)
          module FUFX = FreeObject (F (U.₀ (F.₀ X)) ) using (η; _*; *-lift)

      zig-helper2 : {X : C.Obj} → D [ _* (F (U.₀ (F.₀ X))) C.id D.∘ F.₁ (η (F X)) ≈ _* (F X) (η (F X)) ]
      zig-helper2 {X} = FX.*-uniq FX.η (C.id FUFX.* D.∘ F.₁ FX.η) (zig-comm2 {X})
        where
          module FX = FreeObject (F X) using (η; *-uniq)
          module FUFX = FreeObject (F (U.₀ (F.₀ X))) using (η; _*)

      zig : {X : C.Obj} → D [ _* (F (U.₀ (F.₀ X))) C.id D.∘ F.₁ (η (F X)) ≈ D.id ]
      zig {X} = trans zig-helper2 zig-helper1 where open D.Equiv

      zag : {B : D.Obj} → C [ U.₁ (_* (F (U.₀ B)) C.id) C.∘ η (F (U.₀ B)) ≈ C.id ]
      zag {B} = FUB.*-lift C.id
        where module FUB = FreeObject (F (U.₀ B)) using (*-lift)

  -- left adjoints yield free objects
  LAdj⇒FO : (Free : Functor C D) → (Free ⊣ U) → (X : C.Obj) → FreeObject U X
  LAdj⇒FO Free Free⊣U X = record
      { FX = F.₀ X
      ; η = η₁ X
      ; _* =  λ {A : D.Obj} f → ε A D.∘ F.₁ f
      ; *-lift = *-lift'
      ; *-uniq = *-uniq'
      }
      where
        module F = Functor Free using (₀; ₁; identity; homomorphism; F-resp-≈)
        open Adjoint (Free⊣U) using (unit; counit; zig; zag)
        open NaturalTransformation unit renaming (η to η₁; sym-commute to η-sym-commute)
        open NaturalTransformation counit renaming (η to ε; commute to ε-commute)

        *-lift' : {A : D.Obj} (f : C [ X , U.₀ A ]) → C [ U.₁ (ε A D.∘ F.₁ f) C.∘ η₁ X ≈ f ]
        *-lift' {A} f =  begin
          U.₁ (ε A D.∘ F.₁ f) C.∘ η₁ X                ≈⟨ U.homomorphism ⟩∘⟨refl ⟩
          (U.₁ (ε A) C.∘ U.₁ (F.₁ f)) C.∘ η₁ X        ≈⟨ C.assoc ⟩
          U.₁ (ε A) C.∘ (U.₁ (F.₁ f) C.∘ η₁ X)        ≈⟨ refl⟩∘⟨ η-sym-commute f ⟩
          U.₁ (ε A) C.∘ (η₁ (U.₀ A) C.∘ f)            ≈˘⟨ C.assoc ⟩
          (U.₁ (ε A) C.∘ η₁ (U.₀ A)) C.∘ f            ≈⟨ zag ⟩∘⟨refl ⟩
          C.id C.∘ f                                  ≈⟨ C.identityˡ ⟩
          f                                           ∎
          where
            open C.HomReasoning

        *-uniq-sym : {A : D.Obj} (f : C [ X , U.₀ A ]) (g : D [ F.₀ X , A ]) → C [ U.₁ g C.∘ η₁ X ≈ f ] → D [ ε A D.∘ F.₁ f ≈ g ]
        *-uniq-sym {A} f g comm_proof = begin
          ε A D.∘ F.₁ f                               ≈˘⟨ refl⟩∘⟨ F.F-resp-≈ comm_proof ⟩
          ε A D.∘ F.₁ (U.₁ g C.∘ η₁ X)                ≈⟨ refl⟩∘⟨ F.homomorphism ⟩
          ε A D.∘ ( F.₁ (U.₁ g) D.∘ F.₁ (η₁ X) )      ≈˘⟨ D.assoc ⟩
          (ε A D.∘ F.₁ (U.₁ g)) D.∘ F.₁ (η₁ X)        ≈⟨ ε-commute g ⟩∘⟨refl ⟩
          (g D.∘ ε (F.₀ X)) D.∘ F.₁ (η₁ X)            ≈⟨ D.assoc ⟩
          (g D.∘ (ε (F.₀ X) D.∘ F.₁ (η₁ X)))          ≈⟨ refl⟩∘⟨ zig ⟩
          g D.∘ D.id                                  ≈⟨ D.identityʳ ⟩
          g                                           ∎
          where
            open D.HomReasoning

        *-uniq' : {A : D.Obj} (f : C [ X , U.₀ A ]) (g : D [ F.₀ X , A ]) → C [ U.₁ g C.∘ η₁ X ≈ f ] → D [ g ≈ ε A D.∘ F.₁ f ]
        *-uniq' {A} f g comm_proof =  begin
          g                             ≈˘⟨ *-uniq-sym f g comm_proof ⟩
          ε A D.∘ F.₁ f                 ∎
          where
            open D.HomReasoning


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

open import Agda.Primitive

postulate Applicative : ∀ {a b} (F : Set a → Set b) → Set (lsuc a ⊔ b)

record Traversable {a} (T : Set a) : Set (lsuc a) where
  constructor mkTrav
  field traverse : ∀ {F} {{AppF : Applicative F}} → T → F T
    -- unsolved metas in type of F

postulate
  V     : ∀ {a} → Set a
  travV : ∀ {a} {F : Set a → Set a} {{AppF : Applicative F}} → V → F V

module M (a : Level) where
  TravV : Traversable {a} V
  TravV = mkTrav travV

postulate
  a : Level
  F : Set → Set
  instance AppF : Applicative F

mapM : V → F V
mapM = Traversable.traverse (M.TravV _)
  -- Here we try to cast (TypeChecking.Constraints.castConstraintToCurrentContext)
  -- a level constraint from M talking about the local (a : Level) to the top-level
  -- (empty) context. This ought not result in an __IMPOSSIBLE__.


module MissingDefinition where

open import Agda.Builtin.Equality

Q : Set

data U : Set
S : Set
S = U
T : S → Set
T _ = U

V : Set
W : V → Set

private

  X : Set

module AB where

  data A : Set
  B : (a b : A) → a ≡ b

mutual

  U₂ : Set
  data T₂ : U₂ → Set
  V₂ : (u₂ : U₂) → T₂ u₂ → Set
  data W₂ (u₂ : U₂) (t₂ : T₂ u₂) : V₂ u₂ t₂ → Set


open import Preliminaries

module Idea where

  {- de Bruijn indices are representd as proofs that
     an element is in a list -}
  data _∈_ {A : Set} : (x : A) (l : List A) → Set where -- type \in
    i0 : {x : A} {xs : List A} → x ∈ x :: xs
    iS : {x y : A} {xs : List A} → x ∈ xs → x ∈ y :: xs

  {- types of the STLC -}
  data Tp : Set where
    b : Tp             -- uninterpreted base type
    _⇒_ : Tp → Tp → Tp -- type \=>

  {- contexts are lists of Tp's -}
  Ctx = List Tp
  _,,_ : Ctx → Tp → Ctx
  Γ ,, τ = τ :: Γ

  infixr 10 _⇒_
  infixr 9 _,,_
  infixr 8 _⊢_ -- type \entails
  infix 9 _⊇_

  data _⊢_ (Γ : Ctx) : Tp → Set
  data _≡_ {Γ : Ctx} : {τ : Tp} → Γ ⊢ τ → Γ ⊢ τ → Set
  _⊢c_ : Ctx → Ctx → Set
  _⊇_ : Ctx → Ctx → Set -- type \sup=
  ids : {Γ : Ctx} → Γ ⊢c Γ
  rename : {Γ Γ' : Ctx} {τ : Tp} → Γ' ⊇ Γ → Γ ⊢ τ → Γ' ⊢ τ
  subst : {Γ Γ' : Ctx}{τ : Tp} → Γ ⊢c Γ' → Γ' ⊢ τ  → Γ ⊢ τ
  _·ss_ : {Γ1 Γ2 Γ3 : Ctx} → Γ1 ⊢c Γ2 → Γ2 ⊢c Γ3 → Γ1 ⊢c Γ3
  subst1 : {Γ : Ctx} {τ τ0 : Tp} → Γ ⊢ τ0 → (Γ ,, τ0) ⊢ τ → Γ ⊢ τ

  {- Γ ⊢ τ represents a term of type τ in context Γ -}
  data _⊢_ (Γ : Ctx) where
    c   : Γ ⊢ b -- some constant of the base type
    v   : {τ : Tp}
        → τ ∈ Γ
        → Γ ⊢ τ
    lam : {τ1 τ2 : Tp}
        → Γ ,, τ1 ⊢ τ2
        → Γ ⊢ τ1 ⇒ τ2
    app : {τ1 τ2 : Tp}
        → Γ ⊢ τ1 ⇒ τ2
        → Γ ⊢ τ1
        → Γ ⊢ τ2
    foo : {A : Tp} (e1 e2 : Γ ⊢ A) → e1 ≡ e2 → Γ ⊢ A

{-foo : (e1 : ™ Gamma A) (e2 : ™ Gamma A) -> e1 \equiv e2 -> ™ Gamma A-}

  Γ' ⊇ [] = Unit
  Γ' ⊇ (τ :: Γ) = (Γ' ⊇ Γ) × (τ ∈ Γ')

  rename-var : {Γ Γ' : Ctx} {τ : Tp} → Γ' ⊇ Γ → τ ∈ Γ → τ ∈ Γ'
  rename-var (ρ , x') i0 = x'
  rename-var (ρ , _) (iS x) = rename-var ρ x

  p· : {Γ : Ctx} {Γ' : Ctx} → Γ ⊇ Γ' → {τ : Tp} → (Γ ,, τ) ⊇ Γ'
  p· {Γ' = []} ren = <>
  p· {Γ' = (τ :: Γ')} (ρ , x) = p· ρ , iS x

  idr : {Γ : Ctx} → Γ ⊇ Γ
  idr {[]} = <>
  idr {τ :: Γ} = p· idr , i0

  -- category with families notation
  p : {Γ : Ctx} {τ : Tp} → (Γ ,, τ ⊇ Γ)
  p = p· idr

  addvar-ren : {Γ Γ' : Ctx} {τ : Tp} → Γ' ⊇ Γ → Γ' ,, τ ⊇ Γ ,, τ
  addvar-ren ρ = (p· ρ , i0)

  data _≡_ {Γ : Ctx} where
    CongApp  : {τ1 τ2 : Tp} {e e' : Γ ⊢ τ1 ⇒ τ2} {e1 e1' : Γ ⊢ τ1}
           → e ≡ e' → e1 ≡ e1'
           → (app e e1) ≡ (app e' e1')
    CongLam : {τ1 τ2 : Tp} {e e' : (τ1 :: Γ) ⊢ τ2}
           → e ≡ e'
           → (lam e) ≡ (lam e')
    SubstId : ∀ {τ} {e : Γ ⊢ τ} → subst ids e ≡ e
    SubstComp : ∀ {Γ1 Γ2} {τ} {θ' : Γ ⊢c Γ2} {θ : Γ2 ⊢c Γ1} {e : Γ1 ⊢ τ} → subst θ' (subst θ e) ≡ subst (θ' ·ss θ) e
    Stepβ : {τ1 τ2 : Tp} {e : Γ ,, τ1 ⊢ τ2} {e1 : Γ ⊢ τ1}
           → (app (lam e) e1) ≡ subst1 e1 e
    Refl : {τ : Tp} {e : Γ ⊢ τ} → e ≡ e
    Trans : {τ : Tp} {e1 e2 e3 : Γ ⊢ τ}
         → e1 ≡ e2  →  e2 ≡ e3
         → e1 ≡ e3
    SubstCong : ∀ {Γ2} {τ} {Θ : Γ ⊢c Γ2} {e1 e2 : Γ2 ⊢ τ} → e1 ≡ e2 → subst Θ e1 ≡ subst Θ e2
    RenCong : ∀ {Γ2} {τ} {ρ : Γ ⊇ Γ2} {e1 e2 : Γ2 ⊢ τ} → e1 ≡ e2 → rename ρ e1 ≡ rename ρ e2

  rename ρ c = c
  rename ρ (v x) = v (rename-var ρ x)
  rename ρ (lam e) = lam (rename (addvar-ren ρ) e)
  rename ρ (app e e') = app (rename ρ e) (rename ρ e')
  rename ρ (foo e1 e2 p) = foo (rename ρ e1) (rename ρ e2) (RenCong p)

  _·rr_ : {Γ1 Γ2 Γ3 : Ctx} → Γ1 ⊇ Γ2 → Γ2 ⊇ Γ3 → Γ1 ⊇ Γ3
  _·rr_ {Γ1} {Γ2} {[]} ρ2 ρ3 = <>
  _·rr_ {Γ1} {Γ2} {x :: Γ3} ρ2 (ρ3 , x3) = (ρ2 ·rr ρ3) , rename-var ρ2 x3

  Γ' ⊢c [] = Unit
  Γ' ⊢c (τ :: Γ) = (Γ' ⊢c Γ) × (Γ' ⊢ τ)

  _·rs_ : {Γ1 Γ2 Γ3 : Ctx} →  Γ1 ⊇ Γ2 → Γ2 ⊢c Γ3 → Γ1 ⊢c Γ3
  _·rs_ {Γ1} {Γ2} {[]} ρ θ = <>
  _·rs_ {Γ1} {Γ2} {τ3 :: Γ3} ρ (θ , e) = ρ ·rs θ , rename ρ e

  addvar : {Γ Γ' : Ctx} {τ : Tp} → Γ ⊢c Γ' → (Γ ,, τ) ⊢c (Γ' ,, τ)
  addvar θ = p ·rs θ , v i0

  ids {[]} = <>
  ids {τ :: Γ} = p ·rs ids , v i0

  subst-var : {Γ Γ' : Ctx}{τ : Tp} → Γ ⊢c Γ' → τ ∈ Γ' → Γ ⊢ τ
  subst-var (θ , e) i0 = e
  subst-var (θ , _) (iS x) = subst-var θ x

  subst1 e0 e = subst (ids , e0) e

  -- composition of renamings and substitutions

  _·sr_ : {Γ1 Γ2 Γ3 : Ctx} →  Γ1 ⊢c Γ2 → Γ2 ⊇ Γ3 → Γ1 ⊢c Γ3
  _·sr_ {Γ1} {Γ2} {[]} θ ρ = <>
  _·sr_ {Γ1} {Γ2} {τ3 :: Γ3} θ (ρ , x) = _·sr_ θ ρ , subst-var θ x

  _·ss_ {Γ3 = []} θ1 θ2 = <>
  _·ss_ {Γ1} {Γ2} {τ :: Γ3} θ1 (θ2 , e2) = θ1 ·ss θ2 , subst θ1 e2

  subst θ c = c
  subst θ (v x) = subst-var θ x
  subst θ (lam e) = lam (subst (addvar θ) e)
  subst θ (app e e') = app (subst θ e) (subst θ e')
  subst {Γ} {Γ'} {τ} Θ (foo e1 e2 p) = foo (subst Θ e1) (subst Θ e2) (SubstCong p)

  postulate
    semfoo : (A : Set) (x y : A) -> x == y -> A

  module Semantics (B : Set) (elB : B) where

    ⟦_⟧t : Tp → Set
    ⟦_⟧c : Ctx → Set
    ⟦_⟧v : {Γ : Ctx} {τ : Tp} → τ ∈ Γ → ⟦ Γ ⟧c → ⟦ τ ⟧t
    ⟦_⟧ : {Γ : Ctx} {τ : Tp} → Γ ⊢ τ → ⟦ Γ ⟧c → ⟦ τ ⟧t
    sound : {Γ : Ctx} {τ : Tp} {e : Γ ⊢ τ} {e' : Γ ⊢ τ} → e ≡ e'
          → (γ : ⟦ Γ ⟧c) → ⟦ e ⟧ γ == ⟦ e' ⟧ γ

    ⟦ b ⟧t = B
    ⟦ τ1 ⇒ τ2 ⟧t = ⟦ τ1 ⟧t → ⟦ τ2 ⟧t

    ⟦ [] ⟧c = Unit
    ⟦ τ :: Γ ⟧c = ⟦ Γ ⟧c × ⟦ τ ⟧t

    ⟦_⟧v i0 γ = snd γ
    ⟦_⟧v (iS x) γ = ⟦ x ⟧v (fst γ)

    ⟦ c ⟧ γ = elB
    ⟦ v x ⟧ γ = ⟦ x ⟧v γ
    ⟦ lam e ⟧ γ = \ x → ⟦ e ⟧ (γ , x)
    ⟦ app e1 e2 ⟧ γ = ⟦ e1 ⟧ γ (⟦ e2 ⟧ γ)
    ⟦ (foo e1 e2 p) ⟧ γ = semfoo {!!} (⟦ e1 ⟧ γ) (⟦ e2 ⟧ γ) (sound {_} {_} {e1} {e2} p γ)

    ⟦_⟧s : {Γ Γ' : Ctx} → Γ ⊢c Γ' → ⟦ Γ ⟧c → ⟦ Γ' ⟧c
    ⟦_⟧s {Γ' = []} θ _ = <>
    ⟦_⟧s {Γ' = τ :: Γ'} (θ , e) γ = ⟦ θ ⟧s γ , ⟦ e ⟧ γ

    ⟦_⟧r : {Γ Γ' : Ctx} → Γ ⊇ Γ' → ⟦ Γ ⟧c → ⟦ Γ' ⟧c
    ⟦_⟧r {Γ' = []} θ _ = <>
    ⟦_⟧r {Γ' = τ :: Γ'} (θ , x) γ = ⟦ θ ⟧r γ , ⟦ x ⟧v γ

    interp-rename-var : {Γ' Γ : Ctx} {τ : Tp} (x : τ ∈ Γ) (θ : Γ' ⊇ Γ)
             → (γ' : ⟦ Γ' ⟧c) → ⟦ rename-var θ x ⟧v γ' == (⟦ x ⟧v (⟦ θ  ⟧r γ'))
    interp-rename-var i0 θ γ' = Refl
    interp-rename-var (iS x) θ γ' = interp-rename-var x (fst θ) γ'

    interp-subst-var : {Γ' Γ : Ctx} {τ : Tp} (x : τ ∈ Γ) (θ : Γ' ⊢c Γ)
             → (γ' : ⟦ Γ' ⟧c) → ⟦ subst-var θ x ⟧ γ' == (⟦ x ⟧v (⟦ θ  ⟧s γ'))
    interp-subst-var i0 θ γ' = Refl
    interp-subst-var (iS x) θ γ' = interp-subst-var x (fst θ) γ'

    interp-p· : {Γ : Ctx} {Γ' : Ctx} → (θ : Γ ⊇ Γ') → {τ : Tp} (γ' : _)
              → ⟦ p· θ {τ = τ} ⟧r γ' == ⟦ θ ⟧r (fst γ')
    interp-p· {Γ' = []} θ γ' = Refl
    interp-p· {Γ' = τ' :: Γ'} θ γ' = ap2 _,_ (interp-p· (fst θ) _) Refl

    interp-idr : {Γ : Ctx} (γ : _) → ⟦ idr {Γ} ⟧r γ == γ
    interp-idr {[]} γ = Refl
    interp-idr {x :: Γ} γ = ap (λ x₁ → x₁ , snd γ) (interp-idr (fst γ) ∘ interp-p· idr γ)

    interp-rename : {Γ' Γ : Ctx} {τ : Tp} (e : Γ ⊢ τ) (θ : Γ' ⊇ Γ)
          → (γ' : ⟦ Γ' ⟧c) → ⟦ rename θ e ⟧ γ' == (⟦ e ⟧ (⟦ θ  ⟧r γ'))
    interp-rename c θ γ' = Refl
    interp-rename (v x) θ γ' = interp-rename-var x θ γ'
    interp-rename (lam e) θ γ' = λ= (λ x → ap ⟦ e ⟧ (ap2 _,_ (interp-p· θ (γ' , x)) Refl) ∘ interp-rename e (addvar-ren θ) (γ' , x))
    interp-rename (app e e₁) θ γ' = ap2 (λ f x → f x) (interp-rename e θ γ') (interp-rename e₁ θ γ')
    interp-rename (foo e1 e2 p) Θ γ' = {!!} --interp-rename e1 Θ γ'

    interp-·rs : {Γ1 Γ2 Γ3 : Ctx} → (θ1 : Γ1 ⊇ Γ2) (θ2 : Γ2 ⊢c Γ3) (γ : _) → ⟦ θ1 ·rs θ2 ⟧s γ == ⟦ θ2 ⟧s (⟦ θ1 ⟧r γ)
    interp-·rs {Γ3 = []} θ1 θ2 γ = Refl
    interp-·rs {Γ3 = τ :: Γ3} θ1 (θ2 , e) γ = ap2 _,_ (interp-·rs θ1 θ2 γ) (interp-rename e θ1 γ)

    interp-subst : {Γ' Γ : Ctx} {τ : Tp} (e : Γ ⊢ τ) (θ : Γ' ⊢c Γ)
          → (γ' : ⟦ Γ' ⟧c) → ⟦ subst θ e ⟧ γ' == (⟦ e ⟧ (⟦ θ  ⟧s γ'))
    interp-subst c θ γ' = Refl
    interp-subst (v x) θ γ' = interp-subst-var x θ γ'
    interp-subst (lam e) θ γ' = λ= (λ x → ap (λ h → ⟦ e ⟧ (h , x)) (ap ⟦ θ ⟧s (interp-idr γ' ∘ interp-p· idr (γ' , x)) ∘ interp-·rs (p· idr) θ _) ∘ interp-subst e (addvar θ) (γ' , x))
    interp-subst (app e e₁) θ γ' = ap2 (λ f x → f x) (interp-subst e θ γ') (interp-subst e₁ θ γ')
    interp-subst (foo e1 e2 p) Θ γ' = {!!} --interp-subst e1 Θ γ'

    interp-·ss : {Γ1 Γ2 Γ3 : Ctx} → (θ1 : Γ1 ⊢c Γ2) (θ2 : Γ2 ⊢c Γ3) (γ : _) → ⟦ θ1 ·ss θ2 ⟧s γ == ⟦ θ2 ⟧s (⟦ θ1 ⟧s γ)
    interp-·ss {Γ3 = []} θ1 θ2 γ = Refl
    interp-·ss {Γ3 = τ :: Γ3} θ1 (θ2 , e) γ = ap2 _,_ (interp-·ss θ1 θ2 γ) (interp-subst e θ1 γ)

    interp-ids : ∀ {Γ} (γ : _) → ⟦ ids {Γ} ⟧s γ == γ
    interp-ids {[]} γ = Refl
    interp-ids {τ :: Γ} γ = ap (λ x → x , snd γ) (((interp-idr (fst γ) ∘ interp-p· idr γ) ∘ interp-ids (⟦ p ⟧r γ)) ∘ interp-·rs p ids γ)

    sound (CongApp D D') γ = ap2 (λ f x → f x) (sound D γ) (sound D' γ)
    sound (CongLam D) γ = λ= (λ x → sound D (γ , x))
    sound {e' = e'} SubstId γ = ap ⟦ e' ⟧ (interp-ids γ) ∘ interp-subst e' ids γ
    sound (SubstComp {θ' = θ'}{θ}{e = e}) γ = ((! (interp-subst e _ γ) ∘ ap ⟦ e ⟧ (! (interp-·ss θ' θ γ))) ∘ interp-subst e θ (⟦ θ' ⟧s γ)) ∘ interp-subst (subst θ e) θ' γ
    sound (Stepβ {e = e} {e1 = e1}) γ = ! (interp-subst e (ids , e1) γ) ∘ ap (λ x → ⟦ e ⟧ (x , ⟦ e1 ⟧ γ)) (! (interp-ids γ))
    sound Refl γ = Refl
    sound (Trans D D₁) γ = sound D₁ γ ∘ sound D γ
    sound {Γ'} (SubstCong {Γ} {τ} {Θ} {e1} {e2} D) γ = {!!} --(! (interp-subst e2 Θ γ) ∘ sound D (⟦ Θ ⟧s γ)) ∘ interp-subst e1 Θ γ
    sound {Γ'} (RenCong {Γ} {τ} {ρ} {e1} {e2} D) γ = {!!} --(! (interp-rename e2 ρ γ) ∘ sound D (⟦ ρ ⟧r γ)) ∘ interp-rename e1 ρ γ


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

-- Define all the permutations that occur in Pi
-- These are defined by transport, using univalence

module Permutation where

open import Relation.Binary.PropositionalEquality
  using (_≡_; refl)

open import Data.Nat            using    (_+_;_*_)
open import Data.Fin            using    (Fin)
open import Relation.Binary     using    (Setoid)
open import Function.Equality   using    (_⟨$⟩_)

open import Equiv using (_≃_; id≃; sym≃; trans≃; _●_)
open import ConcretePermutation
open import ConcretePermutationProperties
open import SEquivSCPermEquiv
open import FinEquivTypeEquiv using (module PlusE; module TimesE)
open import EquivEquiv

open import Proofs using (
  -- FiniteFunctions
  finext
  )

infixr 5 _●p_

infix 8 _⊎p_
infixr 7 _×p_

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

-- useful short-hands; these should all be moved elsewhere.
e⇒p : ∀ {m n} → (Fin m ≃ Fin n) → CPerm m n
e⇒p e = _≃S_.g univalence ⟨$⟩ e

p⇒e : ∀ {m n} → CPerm m n → (Fin m ≃ Fin n)
p⇒e p = _≃S_.f univalence ⟨$⟩ p

αu : ∀ {m n} → {e f : Fin m ≃ Fin n} → e ≋ f → p⇒e (e⇒p e) ≋ f
αu e≋f = _≃S_.α univalence e≋f

βu : ∀ {m n} → {p q : CPerm m n} → p ≡ q → e⇒p (p⇒e p) ≡ q
βu p≡q = _≃S_.β univalence p≡q

α₁ : ∀ {m n} → {e : Fin m ≃ Fin n} → p⇒e (e⇒p e) ≋ e
α₁ {e = e} = αu (id≋ {x = e}) -- Agda can infer here, but this helps later?

-- inside an e⇒p, we can freely replace equivalences
-- this expresses the fundamental property that equivalent equivalences
-- map to THE SAME permutation.
≋⇒≡ : ∀ {m n} → {e₁ e₂ : Fin m ≃ Fin n} → e₁ ≋ e₂ → e⇒p e₁ ≡ e⇒p e₂
≋⇒≡ {e₁} {e₂} (eq fwd bwd) = p≡ (finext bwd)

-- combination of above, where we use αu on left/right of ●
right-α-over-● : ∀ {m n o} → (e₁ : Fin n ≃ Fin o) → (e₂ : Fin m ≃ Fin n) →
    (e₁ ● (p⇒e (e⇒p e₂))) ≋ (e₁ ● e₂)
right-α-over-● e₁ e₂ = (id≋ {x = e₁}) ◎ (αu {e = e₂} id≋)

left-α-over-● : ∀ {m n o} → (e₁ : Fin n ≃ Fin o) → (e₂ : Fin m ≃ Fin n) →
    ((p⇒e (e⇒p e₁)) ● e₂) ≋ (e₁ ● e₂)
left-α-over-● e₁ e₂ = (αu {e = e₁} id≋) ◎ (id≋ {x = e₂})

------------------------------------------------------------------------------
-- zero permutation
0p : CPerm 0 0
0p = e⇒p (id≃ {A = Fin 0})

-- identity permutation
idp : ∀ {n} → CPerm n n
idp {n} = e⇒p (id≃ {A = Fin n})

-- disjoint union
_⊎p_ : ∀ {m₁ m₂ n₁ n₂} → CPerm m₁ m₂ → CPerm n₁ n₂ → CPerm (m₁ + n₁) (m₂ + n₂)
p₁ ⊎p p₂ = e⇒p ((p⇒e p₁) +F (p⇒e p₂))
  where open PlusE

-- cartesian product
_×p_ : ∀ {m₁ m₂ n₁ n₂} → CPerm m₁ m₂ → CPerm n₁ n₂ → CPerm (m₁ * n₁) (m₂ * n₂)
p₁ ×p p₂ = e⇒p ((p⇒e p₁) *F (p⇒e p₂))
  where open TimesE

-- symmetry
symp : ∀ {m n} → CPerm m n → CPerm n m
symp p = e⇒p (sym≃ (p⇒e p))

-- transitivity; note the 'transposition' of the arguments!
_●p_ : ∀ {m₁ m₂ m₃} → CPerm m₂ m₁ → CPerm m₃ m₂ → CPerm m₃ m₁
p₁ ●p p₂ = e⇒p ((p⇒e p₁) ● (p⇒e p₂))


{-
This file contains a proof of the fact that the Brunerie number,
i.e. absolute value of the Hopf invariant of [e , e] : π₃S², is 2.
Here, e is the generator of π₂S² and [_,_] denotes the Whitehead
product. The proof follows Proposition 5.4.4. in Brunerie (2016)
closely, but, for simplicity, considers only the case n = 2.
-}

{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Homotopy.HopfInvariant.Brunerie where

open import Cubical.Homotopy.HopfInvariant.Base
open import Cubical.Homotopy.Group.Pi4S3.BrunerieNumber
open import Cubical.Homotopy.Group.Pi4S3.S3PushoutIso
open import Cubical.Homotopy.Whitehead

open import Cubical.ZCohomology.Base
open import Cubical.ZCohomology.GroupStructure
open import Cubical.ZCohomology.MayerVietorisUnreduced
open import Cubical.ZCohomology.Groups.Sn
open import Cubical.ZCohomology.Groups.Wedge
open import Cubical.ZCohomology.Groups.SphereProduct
open import Cubical.ZCohomology.RingStructure.CupProduct
open import Cubical.ZCohomology.RingStructure.RingLaws
open import Cubical.ZCohomology.RingStructure.GradedCommutativity

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Function
open import Cubical.Foundations.Pointed
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.Equiv

open import Cubical.Data.Sigma
open import Cubical.Data.Int hiding (_+'_)
open import Cubical.Data.Nat hiding (_+_)
open import Cubical.Data.Unit
open import Cubical.Data.Sum renaming (rec to ⊎rec)

open import Cubical.HITs.Pushout
open import Cubical.HITs.S1
open import Cubical.HITs.Sn
open import Cubical.HITs.Join
open import Cubical.HITs.Susp
open import Cubical.HITs.Wedge
open import Cubical.HITs.Truncation
open import Cubical.HITs.SetTruncation
  renaming (elim to sElim ; elim2 to sElim2 ; map to sMap)
open import Cubical.HITs.PropositionalTruncation
  renaming (map to pMap ; rec to pRec)

open import Cubical.Algebra.Group
open import Cubical.Algebra.Group.ZAction
open import Cubical.Algebra.Group.Exact
open import Cubical.Algebra.Group.Morphisms
open import Cubical.Algebra.Group.MorphismProperties
open import Cubical.Algebra.Group.Instances.Int
open import Cubical.Algebra.Group.Instances.Unit

open Iso
open IsGroupHom
open PlusBis

-- Some abstract versions of imported lemmas/definitions from
-- ZCohomology.Groups.SphereProduct for faster type checking.
abstract
  H²-genₗabs : coHom 2 (S₊ 2 × S₊ 2)
  H²-genₗabs = H²-S²×S²-genₗ

  H²-genᵣabs : coHom 2 (S₊ 2 × S₊ 2)
  H²-genᵣabs = H²-S²×S²-genᵣ

  Hⁿ⁺ᵐ-Sⁿ×Sᵐ≅ℤ-abs : (n m : ℕ)
    → GroupIso (coHomGr ((suc n) +' (suc m))
                    (S₊ (suc n) × S₊ (suc m)))
                ℤGroup
  Hⁿ⁺ᵐ-Sⁿ×Sᵐ≅ℤ-abs = Hⁿ⁺ᵐ-Sⁿ×Sᵐ≅ℤ

  Hⁿ⁺ᵐ-Sⁿ×Sᵐ≅ℤ-abs≡ : (n m : ℕ)
    → Hⁿ⁺ᵐ-Sⁿ×Sᵐ≅ℤ-abs n m ≡ Hⁿ⁺ᵐ-Sⁿ×Sᵐ≅ℤ n m
  Hⁿ⁺ᵐ-Sⁿ×Sᵐ≅ℤ-abs≡ n m = refl

  Hⁿ⁺ᵐ-Sⁿ×Sᵐ≅ℤ-⌣ :
      fun (fst (Hⁿ⁺ᵐ-Sⁿ×Sᵐ≅ℤ-abs 1 1))
          (H²-S²×S²-genₗ ⌣ H²-S²×S²-genᵣ)
    ≡ 1
  Hⁿ⁺ᵐ-Sⁿ×Sᵐ≅ℤ-⌣ =
     fun (fst (Hⁿ⁺ᵐ-Sⁿ×Sᵐ≅ℤ-abs 1 1)) (H²-S²×S²-genₗ ⌣ H²-S²×S²-genᵣ)
    ≡⟨ cong (fun (fst (Hⁿ⁺ᵐ-Sⁿ×Sᵐ≅ℤ-abs 1 1))) (sym H²-S²≅H⁴-S²×S²⌣) ⟩
    fun (fst (Hⁿ⁺ᵐ-Sⁿ×Sᵐ≅ℤ-abs 1 1)) (fun (fst (H²-S²≅H⁴-S²×S²)) ∣ ∣_∣ₕ ∣₂)
    ≡⟨ speedUp ∣_∣ₕ ⟩
    fun (fst (Hⁿ-Sⁿ≅ℤ 1)) ∣ ∣_∣ₕ ∣₂
    ≡⟨ refl ⟩ -- Computation! :-)
    1 ∎
    where
    speedUp : (f : _) →
         fun (fst (Hⁿ⁺ᵐ-Sⁿ×Sᵐ≅ℤ-abs 1 1)) (fun (fst (H²-S²≅H⁴-S²×S²)) ∣ f ∣₂)
       ≡ fun (fst (Hⁿ-Sⁿ≅ℤ 1)) ∣ f ∣₂
    speedUp f i =
      fun (fst (Hⁿ-Sⁿ≅ℤ 1)) (leftInv (fst H²-S²≅H⁴-S²×S²) ∣ f ∣₂ i)

-- Some abbreviations
private
  inl' : S₊ 2 × S₊ 2 → Pushout⋁↪fold⋁ (S₊∙ 2)
  inl' = inl

  qHom : GroupHom (coHomGr 4 (Pushout⋁↪fold⋁ (S₊∙ 2)))
                  (coHomGr 4 (S₊ 2 × S₊ 2))
  qHom = coHomMorph 4 inl'

  qHomGen : (n : ℕ) →
         GroupHom (coHomGr n (Pushout⋁↪fold⋁ (S₊∙ 2)))
                  (coHomGr n (S₊ 2 × S₊ 2))
  qHomGen n = coHomMorph n inl'

-- The type C and generator α, β in dim 2 and 4 respectively
-- Recall, the goal is to prove that α ⌣ α = ±2 β
  CHopf : Type
  CHopf = HopfInvariantPush 0 fold∘W

  Hopfαfold∘W = Hopfα 0 (fold∘W , refl)
  Hopfβfold∘W = Hopfβ 0 (fold∘W , refl)

-- Rewriting CHopf as our favourite pushout
-- S²×S² ← S²∨S² → S²
  CHopfIso : Iso CHopf (Pushout⋁↪fold⋁ (S₊∙ 2))
  CHopfIso =
    compIso (invIso (equivToIso
      (compEquiv (compEquiv pushoutSwitchEquiv
        (isoToEquiv (PushoutDistr.PushoutDistrIso fold⋁ W λ _ → tt)))
            pushoutSwitchEquiv)))
            (equivToIso Pushout-coFibW-fold⋁≃Pushout⋁↪fold⋁)

-- Cohomology group version of the Iso
  coHomCHopfIso : (n : ℕ)
    → GroupIso (coHomGr n CHopf) (coHomGr n (Pushout⋁↪fold⋁ (S₊∙ 2)))
  coHomCHopfIso n = invGroupIso (coHomIso n CHopfIso)

-- We instantiate Mayer-Vietoris for the pushout
module MV-⋁↪-fold⋁ = MV _ _ (S₊∙ 2 ⋁ S₊∙ 2) ⋁↪ fold⋁

-- This give us an iso H⁴(S²×S² ← S²∨S² → S²) ≅ H⁴(S²×S²)
isEquiv-qHom : GroupEquiv (coHomGr 4 (Pushout⋁↪fold⋁ (S₊∙ 2)))
                (coHomGr 4 (S₊ 2 × S₊ 2))
fst (fst isEquiv-qHom) = qHom .fst
snd (fst isEquiv-qHom) =
  subst isEquiv
    (funExt (sElim (λ _ → isSetPathImplicit) (λ _ → refl)))
    (×UnitEquiv (isoToPath
      (invIso
        (fst (Hⁿ-Sᵐ≅0 3 1 λ p → snotz (cong predℕ p)))))
           _ isEquiv-i)
  where
  ×UnitEquiv : {A B C : Type}
         → Unit ≡ C
         → (f : A → B × C)
         → isEquiv f
         → isEquiv (fst ∘ f)
  ×UnitEquiv {A = A} {B = B} =
    J (λ C _ → (f : A → B × C) → isEquiv f → isEquiv (fst ∘ f))
      λ f eq → record { equiv-proof =
        λ b → ((fst (fst (equiv-proof eq (b , tt))))
          , cong fst (fst (equiv-proof eq (b , tt)) .snd))
          , λ y → ΣPathP ((cong fst (equiv-proof eq (b , tt)
                                      .snd ((fst y)
            , ΣPathP ((snd y) , refl))))
            , λ i j → equiv-proof eq (b , tt) .snd ((fst y)
            , ΣPathP ((snd y) , refl)) i .snd j .fst) }

  isEquiv-i : isEquiv (fst (MV-⋁↪-fold⋁.i 4))
  isEquiv-i =
    SES→isEquiv
      (isContr→≡UnitGroup
        (isOfHLevelRetractFromIso 0
          (compIso
            (fst (Hⁿ-⋁ (S₊∙ 2) (S₊∙ 2) 2))
            (compIso
              (prodIso (fst (Hⁿ-Sᵐ≅0 2 1 λ p → snotz (cong predℕ p)))
                       (fst (Hⁿ-Sᵐ≅0 2 1 λ p → snotz (cong predℕ p))))
              rUnit×Iso))
          isContrUnit))
      ((isContr→≡UnitGroup
        (isOfHLevelRetractFromIso 0
          (compIso
            (fst (Hⁿ-⋁ (S₊∙ 2) (S₊∙ 2) 3))
            (compIso
              (prodIso (fst (Hⁿ-Sᵐ≅0 3 1 λ p → snotz (cong predℕ p)))
                       (fst (Hⁿ-Sᵐ≅0 3 1 λ p → snotz (cong predℕ p))))
              rUnit×Iso))
          isContrUnit)))
      (MV-⋁↪-fold⋁.d 3)
      (MV-⋁↪-fold⋁.i 4)
      (MV-⋁↪-fold⋁.Δ 4)
      (MV-⋁↪-fold⋁.Ker-i⊂Im-d 3)
      (MV-⋁↪-fold⋁.Ker-Δ⊂Im-i 4)
snd isEquiv-qHom = qHom .snd

-- The goal now is reducing α ⌣ α = ±2 β to gₗ ⌣ gᵣ = e for
-- gₗ, gᵣ generators of H²(S²×S²) ≅ ℤ × ℤ and e generator of
-- H⁴(S²×S²) ≅ ℤ. This essentially just elementary linear algebra at
-- this point. We do it for an arbitrary (well-behaved) iso
-- H⁴(S²×S²) ≅ ℤ in order to speed up type checking.
module BrunerieNumLem
  (is : GroupIso (coHomGr 4 (S₊ 2 × S₊ 2)) ℤGroup)
  (isEq : (fun (fst is) (H²-S²×S²-genₗ ⌣ H²-S²×S²-genᵣ) ≡ 1)) where

  x = H²-S²×S²-genₗ
  y = H²-S²×S²-genᵣ

  α = Hopfαfold∘W
  β = Hopfβfold∘W

  α' : coHom 2 (Pushout⋁↪fold⋁ (S₊∙ 2))
  α' = fun (fst (coHomCHopfIso 2)) α

  β' : coHom 4 (Pushout⋁↪fold⋁ (S₊∙ 2))
  β' = fun (fst (coHomCHopfIso 4)) β

  rewriteEquation :
       (α' ⌣ α' ≡ β' +ₕ β') ⊎ (α' ⌣ α' ≡ -ₕ (β' +ₕ β'))
    → (α ⌣ α ≡ β +ₕ β) ⊎ (α ⌣ α ≡ -ₕ (β +ₕ β))
  rewriteEquation (inl x) =
    inl ((λ i → leftInv (fst (coHomCHopfIso 2)) α (~ i)
               ⌣ leftInv (fst (coHomCHopfIso 2)) α (~ i))
       ∙∙ cong (inv (fst (coHomCHopfIso 4))) x
       ∙∙ leftInv (fst (coHomCHopfIso 4)) (β +ₕ β))
  rewriteEquation (inr x) =
    inr ((λ i → leftInv (fst (coHomCHopfIso 2)) α (~ i)
               ⌣ leftInv (fst (coHomCHopfIso 2)) α (~ i))
      ∙∙ cong (inv (fst (coHomCHopfIso 4))) x
      ∙∙ leftInv (fst (coHomCHopfIso 4))
           (-ₕ (β +ₕ β)))

  rewriteEquation2 : (qHom .fst β' ≡  x ⌣ y) ⊎ (qHom .fst β' ≡  -ₕ (x ⌣ y))
  rewriteEquation2 =
    ⊎rec
      (λ p → inl (sym (leftInv (fst is) (qHom .fst β'))
                ∙∙ cong (inv (fst is)) (p ∙ sym isEq)
                ∙∙ leftInv (fst is) (x ⌣ y)))
      (λ p → inr (sym (leftInv (fst is) (qHom .fst β'))
               ∙∙ cong (inv (fst is))
                    (p ∙ sym (cong (GroupStr.inv (snd ℤGroup)) isEq))
               ∙∙ (presinv (invGroupIso is .snd) (fun (fst is) (x ⌣ y))
                 ∙ cong -ₕ_ (leftInv (fst is) (x ⌣ y)))))
      eqs
    where
    grIso : GroupEquiv (coHomGr 4 (HopfInvariantPush 0 fold∘W)) ℤGroup
    grIso = compGroupEquiv (GroupIso→GroupEquiv (coHomCHopfIso 4))
          (compGroupEquiv
            isEquiv-qHom
            (GroupIso→GroupEquiv is))

    eqs : (fst (fst grIso) β ≡ 1) ⊎ (fst (fst grIso) β ≡ -1)
    eqs = groupEquivPresGen _ (GroupIso→GroupEquiv (Hopfβ-Iso 0 (fold∘W , refl)))
          β (inl (Hopfβ↦1 0 (fold∘W , refl))) grIso

  qpres⌣ : (x y : coHom 2 _)
    → fst qHom (x ⌣ y) ≡ fst (qHomGen 2) x ⌣ fst (qHomGen 2) y
  qpres⌣ = sElim2 (λ _ _ → isSetPathImplicit) λ _ _ → refl

  α'↦x+y : fst (qHomGen 2) α' ≡ x +ₕ y
  α'↦x+y = lem ((coHomFun 2 (inv CHopfIso) α)) refl
    where
    lem : (x' : coHom 2 (Pushout⋁↪fold⋁ (S₊∙ 2)))
        → coHomFun 2 inr x' ≡ ∣ ∣_∣ ∣₂
        → fst (qHomGen 2) x' ≡ x +ₕ y
    lem = sElim (λ _ → isSetΠ λ _ → isSetPathImplicit)
      λ f p → Cubical.HITs.PropositionalTruncation.rec
        (squash₂ _ _)
        (λ r → cong ∣_∣₂ (funExt (uncurry
          (wedgeconFun 1 1 (λ _ _ → isOfHLevelPath 4 (isOfHLevelTrunc 4) _ _)
            (λ x → cong f (push (inr x)) ∙∙ funExt⁻ r x ∙∙ refl)
            ((λ x → cong f (push (inl x)) ∙∙ funExt⁻ r x ∙∙ sym (rUnitₖ 2 ∣ x ∣ₕ)))
            (cong (_∙∙ funExt⁻ r north ∙∙ refl)
              (cong (cong f) λ j i → push (push tt j) i))))))
        (fun PathIdTrunc₀Iso p)

  mainEq : ((fst qHom) (α' ⌣ α') ≡ qHom .fst (β' +ₕ β'))
         ⊎ ((fst qHom) (α' ⌣ α') ≡ qHom .fst (-ₕ (β' +ₕ β')))
  mainEq =
    ⊎rec
      (λ id → inl (lem₁ ∙ lem₂
                  ∙ cong (λ x → x +ₕ x) (sym id)
                  ∙ sym (pres· (snd qHom) β' β')))
      (λ id → inr (lem₁ ∙ lem₂
                 ∙ ((sym (distLem (x ⌣ y))
                 ∙ cong -ₕ_ (cong (λ x → x +ₕ x) (sym id)))
                 ∙ cong (-ₕ_) (pres· (snd qHom) β' β'))
                 ∙ sym (presinv (snd qHom) (β' +ₕ β'))))
      rewriteEquation2
    where
    triv⌣ : (a : S¹)
      → cong₂ (_⌣ₖ_ {n = 2} {m = 2}) (cong ∣_∣ₕ (merid a)) (cong ∣_∣ₕ (merid a))
       ≡ λ _ → ∣ north ∣ₕ
    triv⌣ a =
      cong₂Funct (_⌣ₖ_ {n = 2} {m = 2})
        (cong ∣_∣ₕ (merid a)) (cong ∣_∣ₕ (merid a))
        ∙ sym (rUnit λ j → _⌣ₖ_ {n = 2} {m = 2} ∣ merid a j ∣ₕ ∣ north ∣)
        ∙ (λ i j → ⌣ₖ-0ₖ 2 2 ∣ merid a j ∣ₕ i)

    distLem : (x : coHom 4 (S₊ 2 × S₊ 2)) → -ₕ ((-ₕ x) +ₕ (-ₕ x)) ≡ x +ₕ x
    distLem =
      sElim (λ _ → isSetPathImplicit)
        λ f → cong ∣_∣₂ (funExt λ x → cong -ₖ_ (sym (-distrₖ 4 (f x) (f x)))
                       ∙ -ₖ^2  (f x +ₖ f x))

    x⌣x≡0 : x ⌣ x ≡ 0ₕ 4
    x⌣x≡0 =
      cong ∣_∣₂
       (funExt (uncurry λ { north y → refl
                          ; south y → refl
                          ; (merid a i) y j → triv⌣ a j i}))

    y⌣y≡0 : y ⌣ y ≡ 0ₕ 4
    y⌣y≡0 =
      cong ∣_∣₂
       (funExt (uncurry λ { x north → refl
                          ; x south → refl
                          ; x (merid a i) j → triv⌣ a j i}))

    -ₕ'Id : (x : coHom 4 (S₊ 2 × S₊ 2)) → (-ₕ'^ 2 · 2) x ≡ x
    -ₕ'Id =
      sElim (λ _ → isSetPathImplicit)
         λ f → cong ∣_∣₂ (funExt λ x → -ₖ'-gen-inl-left 2 2 tt (inl tt) (f x))

    y⌣x≡x⌣y : y ⌣ x ≡ x ⌣ y
    y⌣x≡x⌣y =
      y ⌣ x                                 ≡⟨ gradedComm'-⌣ 2 2 y x ⟩
      (-ₕ'^ 2 · 2) (transport refl (x ⌣ y))  ≡⟨ -ₕ'Id (transport refl (x ⌣ y)) ⟩
      transport refl (x ⌣ y)                ≡⟨ transportRefl (x ⌣ y) ⟩
      x ⌣ y ∎

    lem₂ : (x +ₕ y) ⌣ (x +ₕ y) ≡ (x ⌣ y) +ₕ (x ⌣ y)
    lem₂ =
     (x +ₕ y) ⌣ (x +ₕ y)                       ≡⟨ leftDistr-⌣ 2 2 (x +ₕ y) x y ⟩
     ((x +ₕ y) ⌣ x) +ₕ ((x +ₕ y) ⌣ y)          ≡⟨ cong₂ _+ₕ_ (rightDistr-⌣ 2 2 x y x) (rightDistr-⌣ 2 2 x y y) ⟩
     ((x ⌣ x +ₕ y ⌣ x)) +ₕ (x ⌣ y +ₕ y ⌣ y)    ≡⟨ cong₂ _+ₕ_ (cong (_+ₕ y ⌣ x) x⌣x≡0 ∙ lUnitₕ 4 (y ⌣ x))
                                                             (cong (x ⌣ y +ₕ_) y⌣y≡0 ∙ rUnitₕ 4 (x ⌣ y)) ⟩
     y ⌣ x +ₕ x ⌣ y                            ≡⟨ cong (_+ₕ (x ⌣ y)) y⌣x≡x⌣y ⟩
     ((x ⌣ y) +ₕ (x ⌣ y)) ∎

    lem₁ : (fst qHom) (α' ⌣ α') ≡ (x +ₕ y) ⌣ (x +ₕ y)
    lem₁ =
     fst qHom (α' ⌣ α')                        ≡⟨ refl ⟩
     fst (qHomGen 2) α' ⌣ fst (qHomGen 2) α'   ≡⟨ cong (λ x → x ⌣ x) α'↦x+y ⟩
     ((x +ₕ y) ⌣ (x +ₕ y)) ∎

  main⊎ : (HopfInvariant 0 (fold∘W , refl) ≡ 2)
        ⊎ (HopfInvariant 0 (fold∘W , refl) ≡ -2)
  main⊎ =
    ⊎rec (λ p → inl (lem₁
                   ∙ cong (fun (fst (Hopfβ-Iso 0 (fold∘W , refl)))) p
                   ∙ pres· (Hopfβ-Iso 0 (fold∘W , refl) .snd) β β
                   ∙ cong (λ x → x + x) (Hopfβ↦1 0 (fold∘W , refl))))
         (λ p → inr (lem₁
                   ∙ cong (fun (fst (Hopfβ-Iso 0 (fold∘W , refl)))) p
                   ∙ presinv (Hopfβ-Iso 0 (fold∘W , refl) .snd) (β +ₕ β)
                   ∙ cong (GroupStr.inv (snd ℤGroup))
                          (pres· (Hopfβ-Iso 0 (fold∘W , refl) .snd) β β
                         ∙ cong (λ x → x + x) (Hopfβ↦1 0 (fold∘W , refl)))))
         lem₂
    where
    lem₁ : HopfInvariant 0 (fold∘W , refl)
       ≡ fun (fst (Hopfβ-Iso 0 (fold∘W , refl))) (α ⌣ α)
    lem₁ =
      cong (fun (fst (Hopfβ-Iso 0 (fold∘W , refl)))) (transportRefl (α ⌣ α))

    lem₂ : (α ⌣ α ≡ β +ₕ β) ⊎ (α ⌣ α ≡ -ₕ (β +ₕ β))
    lem₂ =
      rewriteEquation
      (⊎rec (λ p → inl (sym (retEq (fst isEquiv-qHom) (α' ⌣ α'))
                              ∙∙ cong (invEq (fst isEquiv-qHom)) p
                              ∙∙ retEq (fst isEquiv-qHom) (β' +ₕ β')))
             (λ p → inr ((sym (retEq (fst isEquiv-qHom) (α' ⌣ α'))
                       ∙∙ cong (invEq (fst isEquiv-qHom)) p
                       ∙∙ retEq (fst isEquiv-qHom) (-ₕ (β' +ₕ β')))))
             mainEq)

  main : abs (HopfInvariant 0 (fold∘W , refl)) ≡ 2
  main = ⊎→abs _ 2 main⊎

-- We instantiate the module
Brunerie'≡2 : abs (HopfInvariant 0 (fold∘W , refl)) ≡ 2
Brunerie'≡2 = BrunerieNumLem.main (Hⁿ⁺ᵐ-Sⁿ×Sᵐ≅ℤ-abs 1 1) Hⁿ⁺ᵐ-Sⁿ×Sᵐ≅ℤ-⌣

-- We rewrite the it slightly, to get the definition of the Brunerie
-- number in Brunerie (2016)
Brunerie'≡Brunerie : [ ∣ idfun∙ (S₊∙ 2) ∣₂ ∣ ∣ idfun∙ (S₊∙ 2) ∣₂ ]π' ≡ ∣ fold∘W , refl ∣₂
Brunerie'≡Brunerie =
    cong ∣_∣₂ ([]≡[]₂ (idfun∙ (S₊∙ 2)) (idfun∙ (S₊∙ 2)) )
  ∙ sym fold∘W≡Whitehead
  ∙ cong ∣_∣₂ (∘∙-idˡ (fold∘W , refl))

-- And we get the main result
Brunerie≡2 : Brunerie ≡ 2
Brunerie≡2 =
  cong abs (cong (HopfInvariant-π' 0) Brunerie'≡Brunerie)
  ∙ Brunerie'≡2