open import Agda.Primitive using (lzero; lsuc; _⊔_)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym; trans; cong; subst; setoid)
open import Data.Product using (_×_; Σ; _,_; proj₁; proj₂; zip; map; <_,_>; swap)
import Function.Equality
open import Relation.Binary using (Setoid)
import Relation.Binary.Reasoning.Setoid as SetoidR

import Categories.Category
import Categories.Functor
import Categories.Category.Instance.Setoids
import Categories.Monad.Relative
import Categories.Category.Equivalence
import Categories.Category.Cocartesian
import Categories.Category.Construction.Functors
import Categories.Category.Product
import Categories.NaturalTransformation
import Categories.NaturalTransformation.NaturalIsomorphism

import SecondOrder.Arity
import SecondOrder.Signature
import SecondOrder.Metavariable
import SecondOrder.VRenaming
import SecondOrder.MRenaming
import SecondOrder.Term
import SecondOrder.Substitution
import SecondOrder.RelativeMonadMorphism
import SecondOrder.Instantiation
import SecondOrder.IndexedCategory
import SecondOrder.RelativeKleisli
import SecondOrder.Mslot

module SecondOrder.MRelativeMonad
  {ℓ}
  {𝔸 : SecondOrder.Arity.Arity}
  (Σ : SecondOrder.Signature.Signature ℓ 𝔸)
  where

  open SecondOrder.Signature.Signature Σ
  open SecondOrder.Metavariable Σ
  open SecondOrder.Term Σ
  open SecondOrder.VRenaming Σ
  open SecondOrder.MRenaming Σ
  open SecondOrder.Mslot Σ
  open SecondOrder.Substitution Σ
  open SecondOrder.Instantiation Σ
  open import SecondOrder.RelativeMonadMorphism
  open Categories.Category
  open Categories.Functor using (Functor)
  open Categories.NaturalTransformation renaming (id to idNt)
  open Categories.NaturalTransformation.NaturalIsomorphism renaming (refl to reflNt; sym to symNt; trans to transNt)
  open Categories.Category.Construction.Functors
  open Categories.Category.Instance.Setoids
  open Categories.Category.Product
  open Function.Equality using () renaming (setoid to Π-setoid)
  open SecondOrder.IndexedCategory
  -- open import SecondOrder.RelativeKleisli

  module MTerm {Γ : VContext} where
    open Category
    open NaturalTransformation
    open Functor
    open Categories.Monad.Relative
    open Function.Equality using () renaming (setoid to Π-setoid)
    open Categories.Category.Equivalence using (StrongEquivalence)
    open SecondOrder.RelativeKleisli

    MMonad : Monad Mslots
    MMonad =
      let open Function.Equality using (_⟨$⟩_) renaming (cong to func-cong) in
      record
      { F₀ = λ Θ A →
           record
           { F₀ = λ Ψ → record
                          { F₀ = λ Δ → Term-setoid (Θ ,, Ψ) (Γ ,, Δ) A
                          ; F₁ = λ {Δ} {Ξ} ρ → record { _⟨$⟩_ = [_]ᵛ_ (ʳ⇑ᵛ ρ) ; cong = λ t≈s → []ᵛ-resp-≈ t≈s }
                          ; identity = λ t≈s → ≈-trans ([]ᵛ-resp-≡ᵛ idᵛ+idᵛ) (≈-trans [idᵛ] t≈s)
                          ; homomorphism = λ t≈s → ≈-trans ([]ᵛ-resp-≈ t≈s) ∘ᵛ-resp-ʳ⇑ᵛ-term
                          ; F-resp-≈ = λ ρ≈τ t≈s → {!!}
                          }
           ; F₁ = λ ι → record
                         { η = λ Δ → record { _⟨$⟩_ = [_]ᵐ_ (ᵐ⇑ᵐ ι) ; cong = λ t≈s → []ᵐ-resp-≈ t≈s }
                         ; commute = λ ρ t≈s → ≈-trans ([]ᵐ-resp-≈ ([]ᵛ-resp-≈ t≈s)) vr-comm-mr
                         ; sym-commute = λ ρ t≈s → ≈-trans (≈-sym vr-comm-mr) ([]ᵐ-resp-≈ ([]ᵛ-resp-≈ t≈s))
                         }
           ; identity = λ t≈s → ≈-trans ([]ᵐ-resp-≈ t≈s) (≈-trans ([]ᵐ-resp-≡ᵐ ᵐ⇑ᵐ-resp-idᵐ) [idᵐ])
           ; homomorphism = λ t≈s → ≈-trans ([]ᵐ-resp-≈ t≈s) ∘ᵐ-resp-ᵐ⇑-term
           ; F-resp-≈ = λ ι≈μ t≈s → ≈-trans ([]ᵐ-resp-≈ t≈s) ([]ᵐ-resp-≡ᵐ (ᵐ⇑ᵐ-resp-≡ᵐ ι≈μ))
           }
      ; unit = λ A → record
                      { η = λ Θ →
                          record
                          { η = λ Δ → record { _⟨$⟩_ = [_]ᵛ_ inrᵛ ; cong = λ t≈s → []ᵛ-resp-≈ t≈s }
                          ; commute = λ ρ t≈s → ≈-trans ([]ᵛ-resp-≈ ([]ᵛ-resp-≈ t≈s)) (≈-sym ʳ⇑ᵛ-comm-inrᵛ-term)
                          ; sym-commute = λ ρ t≈s → ≈-trans ʳ⇑ᵛ-comm-inrᵛ-term ([]ᵛ-resp-≈ ([]ᵛ-resp-≈ t≈s))
                          }
                      ; commute = λ f t≈s → ≈-trans ([]ᵛ-resp-≈ ([]ᵐ-resp-≈ t≈s)) mr-comm-vr
                      ; sym-commute = λ f t≈s → ≈-trans ? ([]ᵛ-resp-≈ ([]ᵐ-resp-≈ t≈s))
                      }
      ; extend = λ I A → record
                          { η = λ Θ →
                              record
                              { η = λ Ψ → record { _⟨$⟩_ = [_]ⁱ_ {!!} ; cong = {!!} }
                              ; commute = {!!}
                              ; sym-commute = {!!}
                              }
                          ; commute = {!!}
                          ; sym-commute = {!!}
                          }
      ; identityʳ = {!!}
      ; identityˡ = {!!}
      ; assoc = {!!}
      ; extend-≈ = {!!}
      }


open import Prelude hiding (lift; Fin′; subst; id)

module Implicits.Substitutions.LNMetaType where

open import Implicits.Syntax.LNMetaType
open import Data.Fin.Substitution
open import Data.Star as Star hiding (map)
open import Data.Star.Properties

module MetaTypeApp {T} (l : Lift T MetaType) where
  open Lift l hiding (var)

  infixl 8 _/_

  mutual
    _simple/_ : ∀ {m n} → MetaSType m → Sub T m n → MetaType n
    tc c simple/ σ = simpl (tc c)
    tvar x simple/ σ = simpl (tvar x)
    mvar x simple/ σ = lift $ lookup x σ
    (a →' b) simple/ σ = simpl ((a / σ) →' (b / σ))

    _/_ : ∀ {m n} → MetaType m → Sub T m n → MetaType n
    (simpl c) / σ = (c simple/ σ)
    (a ⇒ b)  / σ = (a / σ) ⇒ (b / σ)
    (∀' a)   / σ = ∀' (a / σ)

  open Application (record { _/_ = _/_ }) using (_/✶_)

  →'-/✶-↑✶ : ∀ k {m n a b} (ρs : Subs T m n) →
             (simpl (a →' b)) /✶ ρs ↑✶ k ≡ simpl ((a /✶ ρs ↑✶ k) →' (b /✶ ρs ↑✶ k))
  →'-/✶-↑✶ k ε        = refl
  →'-/✶-↑✶ k (r ◅ ρs) = cong₂ _/_ (→'-/✶-↑✶ k ρs) refl

  ⇒-/✶-↑✶ : ∀ k {m n a b} (ρs : Subs T m n) →
             (a ⇒ b) /✶ ρs ↑✶ k ≡ (a /✶ ρs ↑✶ k) ⇒ (b /✶ ρs ↑✶ k)
  ⇒-/✶-↑✶ k ε        = refl
  ⇒-/✶-↑✶ k (r ◅ ρs) = cong₂ _/_ (⇒-/✶-↑✶ k ρs) refl

  tc-/✶-↑✶ : ∀ k {c m n} (ρs : Subs T m n) →
             (simpl (tc c)) /✶ ρs ↑✶ k ≡ simpl (tc c)
  tc-/✶-↑✶ k ε        = refl
  tc-/✶-↑✶ k (r ◅ ρs) = cong₂ _/_ (tc-/✶-↑✶ k ρs) refl

  tvar-/✶-↑✶ : ∀ k {c m n} (ρs : Subs T m n) →
             (simpl (tvar c)) /✶ ρs ↑✶ k ≡ simpl (tvar c)
  tvar-/✶-↑✶ k ε        = refl
  tvar-/✶-↑✶ k (r ◅ ρs) = cong₂ _/_ (tvar-/✶-↑✶ k ρs) refl

  ∀'-/✶-↑✶ : ∀ k {m n a} (ρs : Subs T m n) →
             (∀' a) /✶ ρs ↑✶ k ≡ ∀' (a /✶ ρs ↑✶ k)
  ∀'-/✶-↑✶ k ε = refl
  ∀'-/✶-↑✶ k (x ◅ ρs) = cong₂ _/_ (∀'-/✶-↑✶ k ρs) refl

typeSubst : TermSubst MetaType
typeSubst = record { var = (λ n → simpl (mvar n)); app = MetaTypeApp._/_ }

open TermSubst typeSubst public hiding (var)
open MetaTypeApp termLift public using (_simple/_)
open MetaTypeApp varLift public using () renaming (_simple/_ to _simple/Var_)

infix 8 _[/_]

-- Shorthand for single-variable type substitutions
_[/_] : ∀ {n} → MetaType (suc n) → MetaType n → MetaType n
a [/ b ] = a / sub b

_◁m₁ : ∀ {m} (r : MetaType m) → ℕ
_◁m₁ (a ⇒ b) = b ◁m₁
_◁m₁ (∀' r) = 1 N+ r ◁m₁
_◁m₁ (simpl x) = zero

-- heads of metatypes
_◁m : ∀ {m} (r : MetaType m) → (MetaType ((r ◁m₁) N+ m))
(a ⇒ b) ◁m = b ◁m
∀' r ◁m = open-meta zero (r ◁m)
simpl x ◁m = simpl x


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.ZCohomology.Groups.Sn where

open import Cubical.ZCohomology.Base
open import Cubical.ZCohomology.Properties
open import Cubical.ZCohomology.MayerVietorisUnreduced
open import Cubical.ZCohomology.Groups.Unit
open import Cubical.ZCohomology.Groups.Connected
open import Cubical.ZCohomology.KcompPrelims
open import Cubical.ZCohomology.Groups.Prelims

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

open import Cubical.HITs.Pushout
open import Cubical.HITs.Sn
open import Cubical.HITs.S1
open import Cubical.HITs.Susp
open import Cubical.HITs.SetTruncation renaming (rec to sRec ; elim to sElim ; elim2 to sElim2)
open import Cubical.HITs.PropositionalTruncation renaming (rec to pRec ; elim to pElim ; elim2 to pElim2 ; ∥_∥ to ∥_∥₁ ; ∣_∣ to ∣_∣₁) hiding (map)

open import Cubical.Data.Bool
open import Cubical.Data.Sigma
open import Cubical.Data.Int renaming (_+_ to _+ℤ_; +-comm to +ℤ-comm ; +-assoc to +ℤ-assoc)
open import Cubical.Data.Nat
open import Cubical.HITs.Truncation renaming (elim to trElim ; map to trMap ; rec to trRec)
open import Cubical.Data.Unit

open import Cubical.Algebra.Group

infixr 31 _□_
_□_ : _
_□_ = compGroupIso

open GroupEquiv
open vSES
open GroupIso
open GroupHom
open BijectionIso

Sn-connected : (n : ℕ) (x : typ (S₊∙ (suc n))) → ∥ pt (S₊∙ (suc n)) ≡ x ∥₁
Sn-connected zero = toPropElim (λ _ → propTruncIsProp) ∣ refl ∣₁
Sn-connected (suc zero) = suspToPropElim base (λ _ → propTruncIsProp) ∣ refl ∣₁
Sn-connected (suc (suc n)) = suspToPropElim north (λ _ → propTruncIsProp) ∣ refl ∣₁

H⁰-Sⁿ≅ℤ : (n : ℕ) → GroupIso (coHomGr 0 (S₊ (suc n))) intGroup
H⁰-Sⁿ≅ℤ zero = H⁰-connected base (Sn-connected 0)
H⁰-Sⁿ≅ℤ (suc n) = H⁰-connected north (Sn-connected (suc n))

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

--- We will need to switch between Sⁿ defined using suspensions and using pushouts
--- in order to apply Mayer Vietoris.

S1Iso : Iso S¹ (Pushout {A = Bool} (λ _ → tt) λ _ → tt)
S1Iso = S¹IsoSuspBool ⋄ invIso PushoutSuspIsoSusp

coHomPushout≅coHomSn : (n m : ℕ) → GroupIso (coHomGr m (S₊ (suc n))) (coHomGr m (Pushout {A = S₊ n} (λ _ → tt) λ _ → tt))
coHomPushout≅coHomSn zero m =
  Iso+Hom→GrIso (setTruncIso (domIso S1Iso))
                (sElim2 (λ _ _ → isSet→isGroupoid setTruncIsSet _ _) (λ _ _ → refl))
coHomPushout≅coHomSn (suc n) m =
  Iso+Hom→GrIso (setTruncIso (domIso (invIso PushoutSuspIsoSusp)))
                (sElim2 (λ _ _ → isSet→isGroupoid setTruncIsSet _ _) (λ _ _ → refl))

-------------------------- H⁰(S⁰) -----------------------------
S0→Int : (a : Int × Int) → S₊ 0 → Int
S0→Int a true = fst a
S0→Int a false = snd a

H⁰-S⁰≅ℤ×ℤ : GroupIso (coHomGr 0 (S₊ 0)) (dirProd intGroup intGroup)
fun (map H⁰-S⁰≅ℤ×ℤ) = sRec (isSet× isSetInt isSetInt) λ f → (f true) , (f false)
isHom (map H⁰-S⁰≅ℤ×ℤ) = sElim2 (λ _ _ → isSet→isGroupoid (isSet× isSetInt isSetInt) _ _)
                                λ a b i → addLemma (a true) (b true) i , addLemma (a false) (b false) i
inv H⁰-S⁰≅ℤ×ℤ a = ∣ S0→Int a ∣₂
rightInv H⁰-S⁰≅ℤ×ℤ _ = refl
leftInv H⁰-S⁰≅ℤ×ℤ = sElim (λ _ → isSet→isGroupoid setTruncIsSet _ _)
                           λ f → cong ∣_∣₂ (funExt (λ {true → refl ; false → refl}))

-- --------------------------H¹(S¹) -----------------------------------
{-
In order to apply Mayer-Vietoris, we need the following lemma.
Given the following diagram
  a ↦ (a , 0)   ψ         ϕ
 A -->  A × A -------> B --->  C
If ψ is an isomorphism and ϕ is surjective with ker ϕ ≡ {ψ (a , a) ∣ a ∈ A}, then C ≅ B
-}

diagonalIso : ∀ {ℓ ℓ' ℓ''} {A : Group {ℓ}} (B : Group {ℓ'}) {C : Group {ℓ''}}
               (ψ : GroupIso (dirProd A A) B) (ϕ : GroupHom B C)
             → isSurjective _ _ ϕ
             → ((x : ⟨ B ⟩) → isInKer B C ϕ x
                                    → ∃[ y ∈ ⟨ A ⟩ ] x ≡ (fun (map ψ)) (y , y))
             → ((x : ⟨ B ⟩) → (∃[ y ∈ ⟨ A ⟩ ] x ≡ (fun (map ψ)) (y , y))
                                    → isInKer B C ϕ x)
             → GroupIso A C
diagonalIso {A = A} B {C = C} ψ ϕ issurj ker→diag diag→ker = BijectionIsoToGroupIso bijIso
  where
  open GroupStr
  module A = GroupStr (snd A)
  module B = GroupStr (snd B)
  module C = GroupStr (snd C)
  module A×A = GroupStr (snd (dirProd A A))
  module ψ = GroupIso ψ
  module ϕ = GroupHom ϕ
  ψ⁻ = inv ψ

  fstProj : GroupHom A (dirProd A A)
  fun fstProj a = a , GroupStr.0g (snd A)
  isHom fstProj g0 g1 i = (g0 A.+ g1) , GroupStr.lid (snd A) (GroupStr.0g (snd A)) (~ i)

  bijIso : BijectionIso A C
  map' bijIso = compGroupHom fstProj (compGroupHom (map ψ) ϕ)
  inj bijIso a inker = pRec (isSetCarrier A _ _)
                             (λ {(a' , id) → (cong fst (sym (leftInv ψ (a , GroupStr.0g (snd A))) ∙∙ cong ψ⁻ id ∙∙ leftInv ψ (a' , a')))
                                           ∙ cong snd (sym (leftInv ψ (a' , a')) ∙∙ cong ψ⁻ (sym id) ∙∙ leftInv ψ (a , GroupStr.0g (snd A)))})
                             (ker→diag _ inker)
  surj bijIso c =
    pRec propTruncIsProp
         (λ { (b , id) → ∣ (fst (ψ⁻ b) A.+ (A.- snd (ψ⁻ b)))
                          , ((sym (GroupStr.rid (snd C) _)
                           ∙∙ cong ((fun ϕ) ((fun (map ψ)) (fst (ψ⁻ b) A.+ (A.- snd (ψ⁻ b)) , GroupStr.0g (snd A))) C.+_)
                                  (sym (diag→ker (fun (map ψ) ((snd (ψ⁻ b)) , (snd (ψ⁻ b))))
                                                  ∣ (snd (ψ⁻ b)) , refl ∣₁))
                           ∙∙ sym ((isHom ϕ) _ _))
                           ∙∙ cong (fun ϕ) (sym ((isHom (map ψ)) _ _)
                                        ∙∙ cong (fun (map ψ)) (ΣPathP (sym (GroupStr.assoc (snd A) _ _ _)
                                                                           ∙∙ cong (fst (ψ⁻ b) A.+_) (GroupStr.invl (snd A) _)
                                                                           ∙∙ GroupStr.rid (snd A) _
                                                                        , (GroupStr.lid (snd A) _)))
                                        ∙∙ rightInv ψ b)
                           ∙∙ id) ∣₁ })
         (issurj c)

H¹-S¹≅ℤ : GroupIso intGroup (coHomGr 1 (S₊ 1))
H¹-S¹≅ℤ =
    diagonalIso (coHomGr 0 (S₊ 0))
                (invGroupIso H⁰-S⁰≅ℤ×ℤ)
                (K.d 0)
                (λ x → K.Ker-i⊂Im-d 0 x
                                     (ΣPathP (isOfHLevelSuc 0 (isContrHⁿ-Unit 0) _ _
                                            , isOfHLevelSuc 0 (isContrHⁿ-Unit 0) _ _)))
                ((sElim (λ _ → isOfHLevelΠ 2 λ _ → isOfHLevelSuc 1 propTruncIsProp)
                        (λ x inker
                            → pRec propTruncIsProp
                                    (λ {((f , g) , id') → helper x f g id' inker})
                                    ((K.Ker-d⊂Im-Δ 0 ∣ x ∣₂ inker)))))
                ((sElim (λ _ → isOfHLevelΠ 2 λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
                         λ F surj
                           → pRec (setTruncIsSet _ _)
                                   (λ { (x , id) → K.Im-Δ⊂Ker-d 0 ∣ F ∣₂
                                                      ∣ (∣ (λ _ → x) ∣₂ , ∣ (λ _ → 0) ∣₂) ,
                                                       (cong ∣_∣₂ (funExt (surjHelper x))) ∙ sym id ∣₁ })
                                   surj) )
  □ invGroupIso (coHomPushout≅coHomSn 0 1)
  where
  module K = MV Unit Unit (S₊ 0) (λ _ → tt) (λ _ → tt)

  surjHelper :  (x : Int) (x₁ : S₊ 0) → x -[ 0 ]ₖ 0 ≡ S0→Int (x , x) x₁
  surjHelper x true = Iso.leftInv (Iso-Kn-ΩKn+1 0) x
  surjHelper x false = Iso.leftInv (Iso-Kn-ΩKn+1 0) x

  helper : (F : S₊ 0 → Int) (f g : ∥ (Unit → Int) ∥₂)
           (id : GroupHom.fun (K.Δ 0) (f , g) ≡ ∣ F ∣₂)
         → isInKer (coHomGr 0 (S₊ 0))
                    (coHomGr 1 (Pushout (λ _ → tt) (λ _ → tt)))
                    (K.d 0)
                    ∣ F ∣₂
         → ∃[ x ∈ Int ] ∣ F ∣₂ ≡ inv H⁰-S⁰≅ℤ×ℤ (x , x)
  helper F =
    sElim2 (λ _ _ → isOfHLevelΠ 2 λ _ → isOfHLevelΠ 2 λ _ → isOfHLevelSuc 1 propTruncIsProp)
           λ f g id inker
             → pRec propTruncIsProp
                     (λ ((a , b) , id2)
                        → sElim2 {C = λ f g → GroupHom.fun (K.Δ 0) (f , g) ≡ ∣ F ∣₂ → _ }
                                  (λ _ _ → isOfHLevelΠ 2 λ _ → isOfHLevelSuc 1 propTruncIsProp)
                                  (λ f g id → ∣ (helper2 f g .fst) , (sym id ∙ sym (helper2 f g .snd)) ∣₁)
                                  a b id2)
                     (MV.Ker-d⊂Im-Δ _ _ (S₊ 0) (λ _ → tt) (λ _ → tt) 0 ∣ F ∣₂ inker)
    where
    helper2 : (f g : Unit → Int)
            → Σ[ x ∈ Int ] (inv H⁰-S⁰≅ℤ×ℤ (x , x))
             ≡ GroupHom.fun (K.Δ 0) (∣ f ∣₂ , ∣ g ∣₂)
    helper2 f g = (f _ -[ 0 ]ₖ g _) , cong ∣_∣₂ (funExt λ {true → refl ; false → refl})

------------------------- H¹(S⁰) ≅ 0 -------------------------------

private
  Hⁿ-S0≃Kₙ×Kₙ : (n : ℕ) → Iso (S₊ 0 → coHomK (suc n)) (coHomK (suc n) × coHomK (suc n))
  Iso.fun (Hⁿ-S0≃Kₙ×Kₙ n) f = (f true) , (f false)
  Iso.inv (Hⁿ-S0≃Kₙ×Kₙ n) (a , b) true = a
  Iso.inv (Hⁿ-S0≃Kₙ×Kₙ n) (a , b) false = b
  Iso.rightInv (Hⁿ-S0≃Kₙ×Kₙ n) a = refl
  Iso.leftInv (Hⁿ-S0≃Kₙ×Kₙ n) b = funExt λ {true → refl ; false → refl}

  isContrHⁿ-S0 : (n : ℕ) → isContr (coHom (suc n) (S₊ 0))
  isContrHⁿ-S0 n = isContrRetract (Iso.fun (setTruncIso (Hⁿ-S0≃Kₙ×Kₙ n)))
                                  (Iso.inv (setTruncIso (Hⁿ-S0≃Kₙ×Kₙ n)))
                                  (Iso.leftInv (setTruncIso (Hⁿ-S0≃Kₙ×Kₙ n)))
                                  (isContrHelper n)
    where
    isContrHelper : (n : ℕ) → isContr (∥ (coHomK (suc n) × coHomK (suc n)) ∥₂)
    fst (isContrHelper zero) = ∣ (0₁ , 0₁) ∣₂
    snd (isContrHelper zero) = sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
                                  λ y → elim2 {B = λ x y → ∣ (0₁ , 0₁) ∣₂ ≡ ∣(x , y) ∣₂ }
                                  (λ _ _ → isOfHLevelPlus {n = 2} 2 setTruncIsSet _ _)
                                  (toPropElim2 (λ _ _ → setTruncIsSet _ _) refl) (fst y) (snd y)
    isContrHelper (suc zero) = ∣ (0₂ , 0₂) ∣₂
                          , sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
                                  λ y → elim2 {B = λ x y → ∣ (0₂ , 0₂) ∣₂ ≡ ∣(x , y) ∣₂ }
                                  (λ _ _ → isOfHLevelPlus {n = 2} 3 setTruncIsSet _ _)
                                  (suspToPropElim2 base (λ _ _ → setTruncIsSet _ _) refl) (fst y) (snd y)
    isContrHelper (suc (suc n)) = ∣ (0ₖ (3 + n) , 0ₖ (3 + n)) ∣₂
                          , sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
                                  λ y → elim2 {B = λ x y → ∣ (0ₖ (3 + n) , 0ₖ (3 + n)) ∣₂ ≡ ∣(x , y) ∣₂ }
                                  (λ _ _ → isProp→isOfHLevelSuc (4 + n) (setTruncIsSet _ _))
                                  (suspToPropElim2 north (λ _ _ → setTruncIsSet _ _) refl) (fst y) (snd y)

H¹-S⁰≅0 : (n : ℕ) → GroupIso (coHomGr (suc n) (S₊ 0)) trivialGroup
H¹-S⁰≅0 n = IsoContrGroupTrivialGroup (isContrHⁿ-S0 n)

------------------------- H²(S¹) ≅ 0 -------------------------------

H²-S¹≅0 : GroupIso (coHomGr 2 (S₊ 1)) trivialGroup
H²-S¹≅0 =
    coHomPushout≅coHomSn 0 2
  □ invGroupIso (vSES→GroupIso _ _ vSES-helper)
  □ H¹-S⁰≅0 0

  where
  module I = MV Unit Unit (S₊ 0) (λ _ → tt) (λ _ → tt)
  vSES-helper : vSES (coHomGr 1 (S₊ 0)) (coHomGr 2 (Pushout (λ _ → tt) (λ _ → tt)))
                     _ _
  isTrivialLeft vSES-helper = isOfHLevelSuc 0 (isOfHLevelΣ 0 (isContrHⁿ-Unit 0) (λ _ → isContrHⁿ-Unit 0))
  isTrivialRight vSES-helper = isOfHLevelSuc 0 (isOfHLevelΣ 0 (isContrHⁿ-Unit 1) (λ _ → isContrHⁿ-Unit 1))
  left vSES-helper = I.Δ 1
  right vSES-helper = I.i 2
  vSES.ϕ vSES-helper = I.d 1
  Ker-ϕ⊂Im-left vSES-helper = I.Ker-d⊂Im-Δ 1
  Ker-right⊂Im-ϕ vSES-helper = sElim (λ _ → isOfHLevelΠ 2 λ _ → isOfHLevelSuc 1 propTruncIsProp) -- doesn't terminate without elimination
                                          λ a → I.Ker-i⊂Im-d 1 ∣ a ∣₂

-- --------------- H¹(Sⁿ), n ≥ 1 --------------------------------------------

H¹-Sⁿ≅0 : (n : ℕ) → GroupIso (coHomGr 1 (S₊ (2 + n))) trivialGroup
H¹-Sⁿ≅0 zero = coHomPushout≅coHomSn 1 1
             □ BijectionIsoToGroupIso bijIso
             □ dirProdGroupIso (Hⁿ-Unit≅0 0) (Hⁿ-Unit≅0 0)
             □ lUnitGroupIso
  where
  module K = MV Unit Unit (S₊ 1) (λ _ → tt) (λ _ → tt)
  surj-helper : (x : ⟨ coHomGr 0 (S₊ _) ⟩) → isInIm _ _ (K.Δ 0) x
  surj-helper =
    sElim (λ _ → isOfHLevelSuc 1 propTruncIsProp)
           λ f → ∣ (∣ (λ _ → f base) ∣₂ , 0ₕ 0)
                 , (cong ∣_∣₂ (funExt (toPropElim
                                       (λ _ → isSetInt _ _)
                                       (cong (λ x → f base +[ 0 ]ₖ x) (-0ₖ {n = 0})  ∙ rUnitₖ 0 (f base))))) ∣₁
  helper : isInjective _ _ (K.i 1)
  helper =
    sElim (λ _ → isOfHLevelΠ 2 λ _ → isOfHLevelSuc 1 (setTruncIsSet _ _))
           λ x inker → pRec (setTruncIsSet _ _)
                            (sigmaElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
                                        λ a id → sym id ∙ K.Im-Δ⊂Ker-d 0 ∣ a ∣₂ (surj-helper _))
                            (K.Ker-i⊂Im-d 0 ∣ x ∣₂ inker)
  bijIso : BijectionIso (coHomGr 1 (Pushout (λ _ → tt) (λ _ → tt)))
                                   (dirProd (coHomGr 1 Unit) (coHomGr 1 Unit))
  map' bijIso = K.i 1
  inj bijIso = helper
  surj bijIso x = ∣ 0ₕ _ , isOfHLevelSuc 0 (isOfHLevelΣ 0 (isContrHⁿ-Unit zero) (λ _ → isContrHⁿ-Unit 0)) _ x ∣₁
H¹-Sⁿ≅0 (suc n) = coHomPushout≅coHomSn (2 + n) 1
                 □ BijectionIsoToGroupIso bijIso
                 □ dirProdGroupIso (Hⁿ-Unit≅0 0) (Hⁿ-Unit≅0 0)
                 □ lUnitGroupIso
  where
  module K = MV Unit Unit (S₊ (2 + n)) (λ _ → tt) (λ _ → tt)
  surj-helper : (x : ⟨ coHomGr 0 (S₊ _) ⟩) → isInIm _ _ (K.Δ 0) x
  surj-helper =
    sElim (λ _ → isOfHLevelSuc 1 propTruncIsProp)
           λ f → ∣ (∣ (λ _ → f north) ∣₂ , 0ₕ 0)
                 , cong ∣_∣₂ (funExt (suspToPropElim
                                        (ptSn (suc n))
                                        (λ _ → isSetInt _ _)
                                        (cong (λ x → f north +[ 0 ]ₖ x) (-0ₖ {n = 0})  ∙ rUnitₖ 0 (f north)))) ∣₁
  helper : isInjective _ _ (K.i 1)
  helper =
    sElim (λ _ → isOfHLevelΠ 2 λ _ → isOfHLevelSuc 1 (setTruncIsSet _ _))
           λ x inker → pRec (setTruncIsSet _ _)
                            (sigmaElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
                                        λ a id → sym id ∙ K.Im-Δ⊂Ker-d 0 ∣ a ∣₂ (surj-helper _))
                            (K.Ker-i⊂Im-d 0 ∣ x ∣₂ inker)
  bijIso : BijectionIso (coHomGr 1 (Pushout (λ _ → tt) (λ _ → tt)))
                                   (dirProd (coHomGr 1 Unit) (coHomGr 1 Unit))
  map' bijIso = K.i 1
  inj bijIso = helper
  surj bijIso x = ∣ 0ₕ _ , isOfHLevelSuc 0 (isOfHLevelΣ 0 (isContrHⁿ-Unit zero) (λ _ → isContrHⁿ-Unit 0)) _ x ∣₁

--------- Direct proof of H¹(S¹) ≅ ℤ without Mayer-Vietoris -------

-- The strategy is to use the proof that ΩS¹ ≃ ℤ. Since we only have this for S¹ with the base/loop definition
-- we begin with some functions translating between H¹(S₊ 1) and ∥ S¹ → S¹ ∥₀.  The latter type is easy to characterise,
-- by (S¹ → S¹) ≃ S¹ × ℤ (see Cubical.ZCohomology.Groups.Prelims). Truncating this leaves only ℤ, since S¹ is connected.

-- The translation mentioned above uses the basechange function. We use basechange-lemma (Cubical.ZCohomology.Groups.Prelims) to prove the basechange2⁻ preserves
-- path composition (in a more general sense than what is proved in basechange2⁻-morph)

-- We can now give the group equivalence. The first bit is just a big composition of our previously defined translations and is pretty uninteresting.
-- The harder step is proving that the equivalence is a morphism. This relies heavily on the fact that addition the cohomology groups essentially is defined using an
-- application of cong₂, which allows us to use basechange-lemma.

coHom1S1≃ℤ : GroupIso (coHomGr 1 (S₊ 1)) intGroup
coHom1S1≃ℤ = theIso
  where
  F = Iso.fun S¹→S¹≡S¹×Int
  F⁻ = Iso.inv S¹→S¹≡S¹×Int

  theIso : GroupIso (coHomGr 1 (S₊ 1)) intGroup
  fun (map theIso) = sRec isSetInt (λ f → snd (F f))
  isHom (map theIso) = sElim2 (λ _ _ → isOfHLevelPath 2 isSetInt _ _)
                              λ f g → ((λ i → winding (guy (ΩKn+1→Kn 1 (Kn→ΩKn+1 1 (f base) ∙ Kn→ΩKn+1 1 (g base)))
                                              (λ i → S¹map (ΩKn+1→Kn 1 (Kn→ΩKn+1 1 (f (loop i)) ∙ Kn→ΩKn+1 1 (g (loop i))))))))
                                   ∙∙ cong winding (helper (f base) (g base) f g refl refl)
                                   ∙∙ winding-hom (guy (f base) (λ i → S¹map (f (loop i))))
                                                  (guy (g base) (λ i → S¹map (g (loop i))))
    where
    guy = basechange2⁻ ∘ S¹map

    helper : (x y : coHomK 1) (f g : S₊ 1 → coHomK 1)
           → (f base) ≡ x
           → (g base) ≡ y
           → (guy (ΩKn+1→Kn 1 (Kn→ΩKn+1 1 (f base) ∙ Kn→ΩKn+1 1 (g base)))
                   (λ i → S¹map ((ΩKn+1→Kn 1 (Kn→ΩKn+1 1 (f (loop i)) ∙ Kn→ΩKn+1 1 (g (loop i)))))))
             ≡ (guy (f base)
                    (λ i → S¹map (f (loop i))))
             ∙ (guy (g base)
                    (λ i → S¹map ((g (loop i)))))
    helper =
      elim2 (λ _ _ → isGroupoidΠ4 λ _ _ _ _ → isOfHLevelPath 3 (isOfHLevelSuc 3 (isGroupoidS¹) base base) _ _)
            (toPropElim2
              (λ _ _ → isPropΠ4 λ _ _ _ _ → isGroupoidS¹ _ _ _ _)
              λ f g reflf reflg →
              basechange-lemma base base
                (S¹map ∘ (ΩKn+1→Kn 1))
                ((Kn→ΩKn+1 1) ∘ f) ((Kn→ΩKn+1 1) ∘ g)
                (cong (Kn→ΩKn+1 1) reflf ∙ Kn→ΩKn+10ₖ 1) (cong (Kn→ΩKn+1 1) reflg ∙ Kn→ΩKn+10ₖ 1)
              ∙ λ j → guy (Iso.leftInv (Iso-Kn-ΩKn+1 1) (f base) j)
                          (λ i → S¹map (Iso.leftInv (Iso-Kn-ΩKn+1 1) (f (loop i)) j))
                    ∙ guy (Iso.leftInv (Iso-Kn-ΩKn+1 1) (g base) j)
                          (λ i → S¹map (Iso.leftInv (Iso-Kn-ΩKn+1 1) (g (loop i)) j)))
  inv theIso a = ∣ (F⁻ (base , a)) ∣₂
  rightInv theIso a = cong snd (Iso.rightInv S¹→S¹≡S¹×Int (base , a))
  leftInv theIso = sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
                          λ f → cong ((sRec setTruncIsSet ∣_∣₂)
                                        ∘ sRec setTruncIsSet λ x → ∣ F⁻ (x , (snd (F f))) ∣₂)
                                      (Iso.inv PathIdTrunc₀Iso (isConnectedS¹ (fst (F f))))
                              ∙ cong ∣_∣₂ (Iso.leftInv S¹→S¹≡S¹×Int f)

---------------------------- Hⁿ(Sⁿ) ≅ ℤ , n ≥ 1 -------------------

Hⁿ-Sⁿ≅ℤ : (n : ℕ) → GroupIso intGroup (coHomGr (suc n) (S₊ (suc n)))
Hⁿ-Sⁿ≅ℤ zero = invGroupIso coHom1S1≃ℤ
Hⁿ-Sⁿ≅ℤ (suc n) =
    Hⁿ-Sⁿ≅ℤ n
  □ vSES→GroupIso _ _ theIso
  □ invGroupIso (coHomPushout≅coHomSn (suc n) (suc (suc n)))
  where
  module K = MV Unit Unit (S₊ (suc n)) (λ _ → tt) (λ _ → tt)
  theIso : vSES (coHomGr (suc n) (S₊ (suc n))) (coHomGr (suc (suc n))
                (Pushout {A = S₊ (suc n)} (λ _ → tt) (λ _ → tt)))
                _
                _
  isTrivialLeft theIso p q = ΣPathP (isOfHLevelSuc 0 (isContrHⁿ-Unit n) (fst p) (fst q)
                                        , isOfHLevelSuc 0 (isContrHⁿ-Unit n) (snd p) (snd q))
  isTrivialRight theIso p q = ΣPathP (isOfHLevelSuc 0 (isContrHⁿ-Unit (suc n)) (fst p) (fst q)
                                         , isOfHLevelSuc 0 (isContrHⁿ-Unit (suc n)) (snd p) (snd q))
  left theIso = K.Δ (suc n)
  right theIso = K.i (2 + n)
  vSES.ϕ theIso = K.d (suc n)
  Ker-ϕ⊂Im-left theIso = K.Ker-d⊂Im-Δ  (suc n)
  Ker-right⊂Im-ϕ theIso = K.Ker-i⊂Im-d (suc n)


open import Mockingbird.Forest.Base using (Forest)

module Mockingbird.Forest.Birds {b ℓ} (forest : Forest {b} {ℓ}) where

open import Level using (_⊔_)
open import Data.Product using (_×_; ∃-syntax)
open import Relation.Unary using (Pred)
open import Relation.Binary using (Rel)

open Forest forest

-- TODO: consider using implicit arguments in the predicates, e.g.
--   IsMockingbird M = ∀ {x} → M ∙ x ≈ x ∙ x.

IsComposition : (A B C : Bird) → Set (b ⊔ ℓ)
IsComposition A B C = ∀ x → C ∙ x ≈ A ∙ (B ∙ x)

-- A forest ‘has composition’ if for every two birds A and B there exists a bird
-- C = A ∘ B such that C is the composition of A and B.
record HasComposition : Set (b ⊔ ℓ) where
  infixr 6 _∘_

  field
    _∘_ : (A B : Bird) → Bird
    isComposition : ∀ A B → IsComposition A B (A ∘ B)

open HasComposition ⦃ ... ⦄ public

IsMockingbird : Pred Bird (b ⊔ ℓ)
IsMockingbird M = ∀ x → M ∙ x ≈ x ∙ x

record HasMockingbird : Set (b ⊔ ℓ) where
  field
    M : Bird
    isMockingbird : IsMockingbird M

open HasMockingbird ⦃ ... ⦄ public

infix 4 _IsFondOf_
_IsFondOf_ : Rel Bird ℓ
A IsFondOf B = A ∙ B ≈ B

IsEgocentric : Pred Bird ℓ
IsEgocentric A = A IsFondOf A

Agree : (A B x : Bird) → Set ℓ
Agree A B x = A ∙ x ≈ B ∙ x

IsAgreeable : Pred Bird (b ⊔ ℓ)
IsAgreeable A = ∀ B → ∃[ x ] Agree A B x

Compatible : Rel Bird (b ⊔ ℓ)
Compatible A B = ∃[ x ] ∃[ y ] (A ∙ x ≈ y) × (B ∙ y ≈ x)

IsHappy : Pred Bird (b ⊔ ℓ)
IsHappy A = Compatible A A

IsNormal : Pred Bird (b ⊔ ℓ)
IsNormal A = ∃[ x ] A IsFondOf x

infix 4 _IsFixatedOn_
_IsFixatedOn_ : Rel Bird (b ⊔ ℓ)
A IsFixatedOn B = ∀ x → A ∙ x ≈ B

IsHopelesslyEgocentric : Pred Bird (b ⊔ ℓ)
IsHopelesslyEgocentric A = A IsFixatedOn A

IsKestrel : Pred Bird (b ⊔ ℓ)
IsKestrel K = ∀ x y → (K ∙ x) ∙ y ≈ x
-- Alternative definition:
-- IsKestrel K = ∀ x → K ∙ x IsFixatedOn x

record HasKestrel : Set (b ⊔ ℓ) where
  field
    K : Bird
    isKestrel : IsKestrel K

open HasKestrel ⦃ ... ⦄ public

IsIdentity : Pred Bird (b ⊔ ℓ)
IsIdentity I = ∀ x → I ∙ x ≈ x

record HasIdentity : Set (b ⊔ ℓ) where
  field
    I : Bird
    isIdentity : IsIdentity I

open HasIdentity ⦃ ... ⦄ public

IsLark : Pred Bird (b ⊔ ℓ)
IsLark L = ∀ x y → (L ∙ x) ∙ y ≈ x ∙ (y ∙ y)

record HasLark : Set (b ⊔ ℓ) where
  field
    L : Bird
    isLark : IsLark L

IsSageBird : Pred Bird (b ⊔ ℓ)
IsSageBird Θ = ∀ x → x IsFondOf (Θ ∙ x)

open HasLark ⦃ ... ⦄ public

record HasSageBird : Set (b ⊔ ℓ) where
  field
    Θ : Bird
    isSageBird : IsSageBird Θ

IsBluebird : Pred Bird (b ⊔ ℓ)
IsBluebird B = ∀ x y z → B ∙ x ∙ y ∙ z ≈ x ∙ (y ∙ z)

open HasSageBird ⦃ ... ⦄ public

record HasBluebird : Set (b ⊔ ℓ) where
  field
    B : Bird
    isBluebird : IsBluebird B

open HasBluebird ⦃ ... ⦄ public

IsDove : Pred Bird (b ⊔ ℓ)
IsDove D = ∀ x y z w → D ∙ x ∙ y ∙ z ∙ w ≈ x ∙ y ∙ (z ∙ w)

record HasDove : Set (b ⊔ ℓ) where
  field
    D : Bird
    isDove : IsDove D

open HasDove ⦃ ... ⦄ public

IsBlackbird : Pred Bird (b ⊔ ℓ)
IsBlackbird B₁ = ∀ x y z w → B₁ ∙ x ∙ y ∙ z ∙ w ≈ x ∙ (y ∙ z ∙ w)

record HasBlackbird : Set (b ⊔ ℓ) where
  field
    B₁ : Bird
    isBlackbird : IsBlackbird B₁

open HasBlackbird ⦃ ... ⦄ public

IsEagle : Pred Bird (b ⊔ ℓ)
IsEagle E = ∀ x y z w v → E ∙ x ∙ y ∙ z ∙ w ∙ v ≈ x ∙ y ∙ (z ∙ w ∙ v)

record HasEagle : Set (b ⊔ ℓ) where
  field
    E : Bird
    isEagle : IsEagle E

open HasEagle ⦃ ... ⦄ public

IsBunting : Pred Bird (b ⊔ ℓ)
IsBunting B₂ = ∀ x y z w v → B₂ ∙ x ∙ y ∙ z ∙ w ∙ v ≈ x ∙ (y ∙ z ∙ w ∙ v)

record HasBunting : Set (b ⊔ ℓ) where
  field
    B₂ : Bird
    isBunting : IsBunting B₂

open HasBunting ⦃ ... ⦄ public

IsDickcissel : Pred Bird (b ⊔ ℓ)
IsDickcissel D₁ = ∀ x y z w v → D₁ ∙ x ∙ y ∙ z ∙ w ∙ v ≈ x ∙ y ∙ z ∙ (w ∙ v)

record HasDickcissel : Set (b ⊔ ℓ) where
  field
    D₁ : Bird
    isDickcissel : IsDickcissel D₁

open HasDickcissel ⦃ ... ⦄ public

IsBecard : Pred Bird (b ⊔ ℓ)
IsBecard B₃ = ∀ x y z w → B₃ ∙ x ∙ y ∙ z ∙ w ≈ x ∙ (y ∙ (z ∙ w))

record HasBecard : Set (b ⊔ ℓ) where
  field
    B₃ : Bird
    isBecard : IsBecard B₃

open HasBecard ⦃ ... ⦄ public

IsDovekie : Pred Bird (b ⊔ ℓ)
IsDovekie D₂ = ∀ x y z w v → D₂ ∙ x ∙ y ∙ z ∙ w ∙ v ≈ x ∙ (y ∙ z) ∙ (w ∙ v)

record HasDovekie : Set (b ⊔ ℓ) where
  field
    D₂ : Bird
    isDovekie : IsDovekie D₂

open HasDovekie ⦃ ... ⦄ public

IsBaldEagle : Pred Bird (b ⊔ ℓ)
IsBaldEagle Ê = ∀ x y₁ y₂ y₃ z₁ z₂ z₃ → Ê ∙ x ∙ y₁ ∙ y₂ ∙ y₃ ∙ z₁ ∙ z₂ ∙ z₃ ≈ x ∙ (y₁ ∙ y₂ ∙ y₃) ∙ (z₁ ∙ z₂ ∙ z₃)

record HasBaldEagle : Set (b ⊔ ℓ) where
  field
    Ê : Bird
    isBaldEagle : IsBaldEagle Ê

open HasBaldEagle ⦃ ... ⦄ public

IsWarbler : Pred Bird (b ⊔ ℓ)
IsWarbler W = ∀ x y → W ∙ x ∙ y ≈ x ∙ y ∙ y

record HasWarbler : Set (b ⊔ ℓ) where
  field
    W : Bird
    isWarbler : IsWarbler W

open HasWarbler ⦃ ... ⦄ public

IsCardinal : Pred Bird (b ⊔ ℓ)
IsCardinal C = ∀ x y z → C ∙ x ∙ y ∙ z ≈ x ∙ z ∙ y

record HasCardinal : Set (b ⊔ ℓ) where
  field
    C : Bird
    isCardinal : IsCardinal C

open HasCardinal ⦃ ... ⦄ public

IsThrush : Pred Bird (b ⊔ ℓ)
IsThrush T = ∀ x y → T ∙ x ∙ y ≈ y ∙ x

record HasThrush : Set (b ⊔ ℓ) where
  field
    T : Bird
    isThrush : IsThrush T

open HasThrush ⦃ ... ⦄ public

Commute : (x y : Bird) → Set ℓ
Commute x y = x ∙ y ≈ y ∙ x

IsRobin : Pred Bird (b ⊔ ℓ)
IsRobin R = ∀ x y z → R ∙ x ∙ y ∙ z ≈ y ∙ z ∙ x

record HasRobin : Set (b ⊔ ℓ) where
  field
    R : Bird
    isRobin : IsRobin R

open HasRobin ⦃ ... ⦄ public

IsFinch : Pred Bird (b ⊔ ℓ)
IsFinch F = ∀ x y z → F ∙ x ∙ y ∙ z ≈ z ∙ y ∙ x

record HasFinch : Set (b ⊔ ℓ) where
  field
    F : Bird
    isFinch : IsFinch F

open HasFinch ⦃ ... ⦄ public

IsVireo : Pred Bird (b ⊔ ℓ)
IsVireo V = ∀ x y z → V ∙ x ∙ y ∙ z ≈ z ∙ x ∙ y

record HasVireo : Set (b ⊔ ℓ) where
  field
    V : Bird
    isVireo : IsVireo V

open HasVireo ⦃ ... ⦄ public

IsCardinalOnceRemoved : Pred Bird (b ⊔ ℓ)
IsCardinalOnceRemoved C* = ∀ x y z w → C* ∙ x ∙ y ∙ z ∙ w ≈ x ∙ y ∙ w ∙ z

record HasCardinalOnceRemoved : Set (b ⊔ ℓ) where
  field
    C* : Bird
    isCardinalOnceRemoved : IsCardinalOnceRemoved C*

open HasCardinalOnceRemoved ⦃ ... ⦄ public

IsRobinOnceRemoved : Pred Bird (b ⊔ ℓ)
IsRobinOnceRemoved R* = ∀ x y z w → R* ∙ x ∙ y ∙ z ∙ w ≈ x ∙ z ∙ w ∙ y

record HasRobinOnceRemoved : Set (b ⊔ ℓ) where
  field
    R* : Bird
    isRobinOnceRemoved : IsRobinOnceRemoved R*

open HasRobinOnceRemoved ⦃ ... ⦄ public

IsFinchOnceRemoved : Pred Bird (b ⊔ ℓ)
IsFinchOnceRemoved F* = ∀ x y z w → F* ∙ x ∙ y ∙ z ∙ w ≈ x ∙ w ∙ z ∙ y

record HasFinchOnceRemoved : Set (b ⊔ ℓ) where
  field
    F* : Bird
    isFinchOnceRemoved : IsFinchOnceRemoved F*

open HasFinchOnceRemoved ⦃ ... ⦄ public

IsVireoOnceRemoved : Pred Bird (b ⊔ ℓ)
IsVireoOnceRemoved V* = ∀ x y z w → V* ∙ x ∙ y ∙ z ∙ w ≈ x ∙ w ∙ y ∙ z

record HasVireoOnceRemoved : Set (b ⊔ ℓ) where
  field
    V* : Bird
    isVireoOnceRemoved : IsVireoOnceRemoved V*

open HasVireoOnceRemoved ⦃ ... ⦄ public

IsCardinalTwiceRemoved : Pred Bird (b ⊔ ℓ)
IsCardinalTwiceRemoved C** = ∀ x y z₁ z₂ z₃ → C** ∙ x ∙ y ∙ z₁ ∙ z₂ ∙ z₃ ≈ x ∙ y ∙ z₁ ∙ z₃ ∙ z₂

record HasCardinalTwiceRemoved : Set (b ⊔ ℓ) where
  field
    C** : Bird
    isCardinalTwiceRemoved : IsCardinalTwiceRemoved C**

open HasCardinalTwiceRemoved ⦃ ... ⦄ public

IsRobinTwiceRemoved : Pred Bird (b ⊔ ℓ)
IsRobinTwiceRemoved R** = ∀ x y z₁ z₂ z₃ → R** ∙ x ∙ y ∙ z₁ ∙ z₂ ∙ z₃ ≈ x ∙ y ∙ z₂ ∙ z₃ ∙ z₁

record HasRobinTwiceRemoved : Set (b ⊔ ℓ) where
  field
    R** : Bird
    isRobinTwiceRemoved : IsRobinTwiceRemoved R**

open HasRobinTwiceRemoved ⦃ ... ⦄ public

IsFinchTwiceRemoved : Pred Bird (b ⊔ ℓ)
IsFinchTwiceRemoved F** = ∀ x y z₁ z₂ z₃ → F** ∙ x ∙ y ∙ z₁ ∙ z₂ ∙ z₃ ≈ x ∙ y ∙ z₃ ∙ z₂ ∙ z₁

record HasFinchTwiceRemoved : Set (b ⊔ ℓ) where
  field
    F** : Bird
    isFinchTwiceRemoved : IsFinchTwiceRemoved F**

open HasFinchTwiceRemoved ⦃ ... ⦄ public

IsVireoTwiceRemoved : Pred Bird (b ⊔ ℓ)
IsVireoTwiceRemoved V** = ∀ x y z₁ z₂ z₃ → V** ∙ x ∙ y ∙ z₁ ∙ z₂ ∙ z₃ ≈ x ∙ y ∙ z₃ ∙ z₁ ∙ z₂

record HasVireoTwiceRemoved : Set (b ⊔ ℓ) where
  field
    V** : Bird
    isVireoTwiceRemoved : IsVireoTwiceRemoved V**

open HasVireoTwiceRemoved ⦃ ... ⦄ public

IsQueerBird : Pred Bird (b ⊔ ℓ)
IsQueerBird Q = ∀ x y z → Q ∙ x ∙ y ∙ z ≈ y ∙ (x ∙ z)

record HasQueerBird : Set (b ⊔ ℓ) where
  field
    Q : Bird
    isQueerBird : IsQueerBird Q

open HasQueerBird ⦃ ... ⦄ public

IsQuixoticBird : Pred Bird (b ⊔ ℓ)
IsQuixoticBird Q₁ = ∀ x y z → Q₁ ∙ x ∙ y ∙ z ≈ x ∙ (z ∙ y)

record HasQuixoticBird : Set (b ⊔ ℓ) where
  field
    Q₁ : Bird
    isQuixoticBird : IsQuixoticBird Q₁

open HasQuixoticBird ⦃ ... ⦄ public

IsQuizzicalBird : Pred Bird (b ⊔ ℓ)
IsQuizzicalBird Q₂ = ∀ x y z → Q₂ ∙ x ∙ y ∙ z ≈ y ∙ (z ∙ x)

record HasQuizzicalBird : Set (b ⊔ ℓ) where
  field
    Q₂ : Bird
    isQuizzicalBird : IsQuizzicalBird Q₂

open HasQuizzicalBird ⦃ ... ⦄ public

IsQuirkyBird : Pred Bird (b ⊔ ℓ)
IsQuirkyBird Q₃ = ∀ x y z → Q₃ ∙ x ∙ y ∙ z ≈ z ∙ (x ∙ y)

record HasQuirkyBird : Set (b ⊔ ℓ) where
  field
    Q₃ : Bird
    isQuirkyBird : IsQuirkyBird Q₃

open HasQuirkyBird ⦃ ... ⦄ public

IsQuackyBird : Pred Bird (b ⊔ ℓ)
IsQuackyBird Q₄ = ∀ x y z → Q₄ ∙ x ∙ y ∙ z ≈ z ∙ (y ∙ x)

record HasQuackyBird : Set (b ⊔ ℓ) where
  field
    Q₄ : Bird
    isQuackyBird : IsQuackyBird Q₄

open HasQuackyBird ⦃ ... ⦄ public

IsGoldfinch : Pred Bird (b ⊔ ℓ)
IsGoldfinch G = ∀ x y z w → G ∙ x ∙ y ∙ z ∙ w ≈ x ∙ w ∙ (y ∙ z)

record HasGoldfinch : Set (b ⊔ ℓ) where
  field
    G : Bird
    isGoldfinch : IsGoldfinch G

open HasGoldfinch ⦃ ... ⦄ public

IsDoubleMockingbird : Pred Bird (b ⊔ ℓ)
IsDoubleMockingbird M₂ = ∀ x y → M₂ ∙ x ∙ y ≈ x ∙ y ∙ (x ∙ y)

record HasDoubleMockingbird : Set (b ⊔ ℓ) where
  field
    M₂ : Bird
    isDoubleMockingbird : IsDoubleMockingbird M₂

open HasDoubleMockingbird ⦃ ... ⦄ public

IsConverseWarbler : Pred Bird (b ⊔ ℓ)
IsConverseWarbler W′ = ∀ x y → W′ ∙ x ∙ y ≈ y ∙ x ∙ x

record HasConverseWarbler : Set (b ⊔ ℓ) where
  field
    W′ : Bird
    isConverseWarbler : IsConverseWarbler W′

open HasConverseWarbler ⦃ ... ⦄ public

IsWarblerOnceRemoved : Pred Bird (b ⊔ ℓ)
IsWarblerOnceRemoved W* = ∀ x y z → W* ∙ x ∙ y ∙ z ≈ x ∙ y ∙ z ∙ z

record HasWarblerOnceRemoved : Set (b ⊔ ℓ) where
  field
    W* : Bird
    isWarblerOnceRemoved : IsWarblerOnceRemoved W*

open HasWarblerOnceRemoved ⦃ ... ⦄ public

IsWarblerTwiceRemoved : Pred Bird (b ⊔ ℓ)
IsWarblerTwiceRemoved W** = ∀ x y z w → W** ∙ x ∙ y ∙ z ∙ w ≈ x ∙ y ∙ z ∙ w ∙ w

record HasWarblerTwiceRemoved : Set (b ⊔ ℓ) where
  field
    W** : Bird
    isWarblerTwiceRemoved : IsWarblerTwiceRemoved W**

open HasWarblerTwiceRemoved ⦃ ... ⦄ public

IsHummingbird : Pred Bird (b ⊔ ℓ)
IsHummingbird H = ∀ x y z → H ∙ x ∙ y ∙ z ≈ x ∙ y ∙ z ∙ y

record HasHummingbird : Set (b ⊔ ℓ) where
  field
    H : Bird
    isHummingbird : IsHummingbird H

open HasHummingbird ⦃ ... ⦄ public

IsStarling : Pred Bird (b ⊔ ℓ)
IsStarling S = ∀ x y z → S ∙ x ∙ y ∙ z ≈ x ∙ z ∙ (y ∙ z)

record HasStarling : Set (b ⊔ ℓ) where
  field
    S : Bird
    isStarling : IsStarling S

open HasStarling ⦃ ... ⦄ public

IsPhoenix : Pred Bird (b ⊔ ℓ)
IsPhoenix Φ = ∀ x y z w → Φ ∙ x ∙ y ∙ z ∙ w ≈ x ∙ (y ∙ w) ∙ (z ∙ w)

record HasPhoenix : Set (b ⊔ ℓ) where
  field
    Φ : Bird
    isPhoenix : IsPhoenix Φ

open HasPhoenix ⦃ ... ⦄ public

IsPsiBird : Pred Bird (b ⊔ ℓ)
IsPsiBird Ψ = ∀ x y z w → Ψ ∙ x ∙ y ∙ z ∙ w ≈ x ∙ (y ∙ z) ∙ (y ∙ w)

record HasPsiBird : Set (b ⊔ ℓ) where
  field
    Ψ : Bird
    isPsiBird : IsPsiBird Ψ

open HasPsiBird ⦃ ... ⦄ public

IsTuringBird : Pred Bird (b ⊔ ℓ)
IsTuringBird U = ∀ x y → U ∙ x ∙ y ≈ y ∙ (x ∙ x ∙ y)

record HasTuringBird : Set (b ⊔ ℓ) where
  field
    U : Bird
    isTuringBird : IsTuringBird U

open HasTuringBird ⦃ ... ⦄ public

IsOwl : Pred Bird (b ⊔ ℓ)
IsOwl O = ∀ x y → O ∙ x ∙ y ≈ y ∙ (x ∙ y)

record HasOwl : Set (b ⊔ ℓ) where
  field
    O : Bird
    isOwl : IsOwl O

open HasOwl ⦃ ... ⦄ public

IsChoosy : Pred Bird (b ⊔ ℓ)
IsChoosy A = ∀ x → A IsFondOf x → IsSageBird x

IsJaybird : Pred Bird (b ⊔ ℓ)
IsJaybird J = ∀ x y z w → J ∙ x ∙ y ∙ z ∙ w ≈ x ∙ y ∙ (x ∙ w ∙ z)

record HasJaybird : Set (b ⊔ ℓ) where
  field
    J : Bird
    isJaybird : IsJaybird J

open HasJaybird ⦃ ... ⦄ public


--{-# OPTIONS -vtc:50 #-}
{-# OPTIONS --double-check #-}

open import Agda.Primitive

postulate Id : (l : Level) (A : Set l) → A → A → Set l

postulate w/e : (l : Level) (A : Set l) → A

data Box l (A : Set l) : Set l where
  box : A → Box l A

unbox : (l : Level) (A : Set l) → Box l A → A
unbox l A (box x) = x

record R l (A : Set l) : Set l where
  --no-eta-equality
  -- ^ works if eta is disabled
  field
    boxed : Box l A
    refl  : Id l A (w/e l A) (w/e l A)

postulate
  El    : (l : Level) (A : Set l) → A → A
  trans : (l : Level) (A : Set l) (x : A) → Id l A (w/e l A) (w/e l A) → Id l A (w/e l A) (w/e l A) → Id l A (w/e l A) (w/e l A)
  cong  : (l : Level) (A : Set l) (f : A → A) (x y : A) → Id l A x y → Id l A (f x) (f y)

module _ (l : Level) (BADNESS : Set) (A : Set l) (r : R l A) where

  open R r

  x = w/e l A

  p = trans l A (unbox l A boxed) refl refl

  lemma = El l
            (Id l (Id l A x x) p p)
            (cong l _ (λ p → trans l A (unbox l A boxed) p _) refl refl (w/e l (Id l (Id l A x x) refl refl)))
  -- ^ works if definition of lemma is removed

  test = λ _ → unbox _ _ boxed


open import MLib.Prelude.FromStdlib

module MLib.Prelude.TransitiveProver {a p} {A : Set a} (_⇒_ : A → A → Set p) (trans : Transitive _⇒_) where

import MLib.Prelude.DFS as DFS
open import MLib.Prelude.Path

open List using ([]; _∷_)

open import Relation.Nullary using (yes; no)
open import Relation.Binary using (Decidable; IsStrictTotalOrder)

import Data.AVL as AVL

Database : Set (a ⊔ˡ p)
Database = List (∃₂ λ x y → x ⇒ y)

module Search {r} {_<_ : Rel A r} (isStrictTotalOrder : IsStrictTotalOrder _≡_ _<_) where
  private
    module DFS′ = DFS _⇒_ isStrictTotalOrder
  open DFS′
  open DFS′ public using (Graph)
  open IsStrictTotalOrder isStrictTotalOrder using (_≟_)

  private
    module Tree = AVL isStrictTotalOrder
    open Tree using (Tree)

  mkGraph : Database → Graph
  mkGraph [] = Tree.empty
  mkGraph ((x , y , p) ∷ ps) = Tree.insertWith x ((y , p) ∷ []) List._++_ (mkGraph ps)

  private
    findPath : Graph → ∀ x y → Maybe (Path _⇒_ x y)
    findPath gr x y = findDest gr {y} (λ v → v ≟ y) x

  tryProve′ : Graph → ∀ x y → Maybe (x ⇒ y)
  tryProve′ gr x y = findPath gr x y >>=ₘ just ∘ transPath trans

  findTransTargets′ : Graph → ∀ x → List (∃ λ y → x ⇒ y)
  findTransTargets′ gr x = allTargetsFrom gr x >>=ₗ λ {(y , c) → return (y , transPath trans c)}

  tryProve : Database → ∀ x y → Maybe (x ⇒ y)
  tryProve = tryProve′ ∘ mkGraph

  findTransTargets : Database → ∀ x → List (∃ λ y → x ⇒ y)
  findTransTargets = findTransTargets′ ∘ mkGraph


module _ where

open import Agda.Builtin.Nat
open import Agda.Builtin.Bool
open import Agda.Builtin.Equality

data Nat+Bool : Set where
  nat  : Nat  → Nat+Bool
  bool : Bool → Nat+Bool

data P : Nat+Bool → Set where
  p : {x : Nat+Bool} → P x

mkBool : ∀ {n b} → P (nat n) → P (bool b)
mkBool {zero}  _ = p {bool _}
mkBool {suc _} _ = p {bool _}

f : {x : Nat+Bool} → P x
f = λ { {nat n}  → g
      ; {bool b} → mkBool g }
  where
    g : P _
    g = p

crash : f {bool true} ≡ p {bool true}
crash = refl


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

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

import Equality.Path as P

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

open P.Derived-definitions-and-properties eq

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

open import Bijection equality-with-J as B using (_↔_)
open import Erased.Cubical eq
  using (Σ-closed-reflective-subuniverse; Accessible)
open import Equality.Decision-procedures equality-with-J
open import Equality.Path.Isomorphisms eq
open import Equivalence equality-with-J as Eq
  using (_≃_; Is-equivalence)
open import Equivalence.Path-split equality-with-J as PS
  using (_-Null_; Is-∞-extendable-along-[_])
open import Function-universe equality-with-J as F hiding (id; _∘_)
open import H-level equality-with-J
open import H-level.Closure equality-with-J
open import H-level.Truncation.Propositional eq as T
  using (∥_∥; ∣_∣; Axiom-of-choice)
open import Preimage equality-with-J using (_⁻¹_)

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

-- A type is modal with respect to the modality ∥_∥ if it is a
-- proposition.

∥∥-modal : Type ℓ → Type ℓ
∥∥-modal = Is-proposition

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

∥∥-modality : Σ-closed-reflective-subuniverse ℓ
∥∥-modality {ℓ = ℓ} = λ where
    .◯                      → ∥_∥
    .η                      → ∣_∣
    .Is-modal               → ∥∥-modal
    .Is-modal-propositional → λ ext → H-level-propositional ext 1
    .Is-modal-◯             → T.truncation-is-proposition
    .Is-modal-respects-≃    → H-level-cong _ 1
    .extendable-along-η     → extendable
    .Σ-closed               → Σ-closure 1
  where
  open Σ-closed-reflective-subuniverse

  extendable :
    {A B : Type ℓ} →
    Is-proposition B →
    Is-∞-extendable-along-[ ∣_∣ ] (λ (_ : ∥ A ∥) → B)
  extendable {A = A} {B = B} =
    Is-proposition B                                   →⟨ (λ prop →
                                                             _≃_.is-equivalence $
                                                             Eq.↔→≃
                                                               _
                                                               (T.rec prop)
                                                               refl
                                                               (λ f → ⟨ext⟩ $
                                                                  T.elim
                                                                    _
                                                                    (λ _ → ⇒≡ 1 prop)
                                                                    (λ _ → refl _))) ⟩
    Is-equivalence (λ (f : ∥ A ∥ → B) → f ∘ ∣_∣)       ↔⟨ inverse $ PS.Is-∞-extendable-along≃Is-equivalence ext ⟩□
    Is-∞-extendable-along-[ ∣_∣ ] (λ (_ : ∥ A ∥) → B)  □

-- The propositional truncation modality is accessible.
--
-- This proof is based on "Modalities in Homotopy Type Theory" by
-- Rijke, Shulman and Spitters.

∥∥-accessible : Accessible ℓ′ (∥∥-modality {ℓ = ℓ})
∥∥-accessible {ℓ′ = ℓ′} {ℓ = ℓ} =
    ↑ ℓ′ ⊤
  , (λ _ → ↑ ℓ′ Bool)
  , (λ A →
       Is-proposition A                                  ↝⟨ record { from = from; to = to } ⟩
       (λ _ → ↑ ℓ′ Bool) -Null A                         ↔⟨ inverse $ PS.Π-Is-∞-extendable-along≃Null ext ⟩□
       (↑ ℓ′ ⊤ → Is-∞-extendable-along-[ _ ] (λ _ → A))  □)

  where
  to : Is-proposition A → (λ _ → ↑ ℓ′ Bool) -Null A
  to prop _ =
    _≃_.is-equivalence $
    Eq.⇔→≃
      prop
      (Π-closure ext 1 λ _ → prop)
      _
      (_$ lift true)

  from : (λ _ → ↑ ℓ′ Bool) -Null A → Is-proposition A
  from {A = A} null x y =
    x                                      ≡⟨⟩
    case true ⦂ Bool of if_then x else y   ≡⟨ cong (_$ true) $ sym $ E.right-inverse-of _ ⟩
    E.to (E.from (if_then x else y)) true  ≡⟨⟩
    E.from (if_then x else y)              ≡⟨⟩
    E.to (E.from (if_then x else y)) false ≡⟨ cong (_$ false) $ E.right-inverse-of _ ⟩
    case false ⦂ Bool of if_then x else y  ≡⟨⟩
    y                                      ∎
    where
    ≃Bool→ : A ≃ (Bool → A)
    ≃Bool→ =
      A                ↝⟨ Eq.⟨ _ , null _ ⟩ ⟩
      (↑ ℓ′ Bool → A)  ↝⟨ Eq.↔→≃ (_∘ lift) (_∘ lower) refl refl ⟩□
      (Bool → A)       □

    module E = _≃_ ≃Bool→

-- It is not the case that, for all types A and B and functions
-- f : A → B, "f is ∥∥-connected" implies ∥ Is-equivalence f ∥.

¬[∥∥-connected→∥Is-equivalence∥] :
  ¬ ({A : Type a} {B : Type b} {f : A → B} →
     (∀ y → Contractible ∥ f ⁻¹ y ∥) → ∥ Is-equivalence f ∥)
¬[∥∥-connected→∥Is-equivalence∥] hyp =
                                                                   $⟨ (λ _ → ∣ lift true , refl _ ∣) ⟩

  ((y : ↑ _ ⊤) → ∥ (const (lift tt) ⦂ (↑ _ Bool → ↑ _ ⊤)) ⁻¹ y ∥)  →⟨ (∀-cong _ λ _ →
                                                                       propositional⇒inhabited⇒contractible T.truncation-is-proposition) ⟩
  ((y : ↑ _ ⊤) →
   Contractible ∥ (const (lift tt) ⦂ (↑ _ Bool → ↑ _ ⊤)) ⁻¹ y ∥)   →⟨ hyp ⟩

  ∥ Is-equivalence (const (lift tt) ⦂ (↑ _ Bool → ↑ _ ⊤)) ∥        ↔⟨ T.∥∥↔ (Eq.propositional ext _) ⟩

  Is-equivalence (const (lift tt) ⦂ (↑ _ Bool → ↑ _ ⊤))            →⟨ Eq.⟨ _ ,_⟩ ⟩

  ↑ _ Bool ≃ ↑ _ ⊤                                                 →⟨ (λ eq → Eq.↔⇒≃ B.↑↔ F.∘ eq F.∘ Eq.↔⇒≃ (inverse B.↑↔)) ⟩

  Bool ≃ ⊤                                                         →⟨ (λ eq → H-level-cong _ 1 (inverse eq) (mono₁ 0 ⊤-contractible)) ⟩

  Is-proposition Bool                                              →⟨ ¬-Bool-propositional ⟩□

  ⊥                                                                □

-- It is not the case that, for all types A and B and functions
-- f : A → B, "f is ∥∥-connected" is equivalent to
-- ∥ Is-equivalence f ∥.
--
-- Compare with
-- Erased.Level-1.[]-cong₂-⊔.Erased-connected↔Erased-Is-equivalence.

¬[∥∥-connected≃∥Is-equivalence∥] :
  ¬ ({A : Type a} {B : Type b} {f : A → B} →
     (∀ y → Contractible ∥ f ⁻¹ y ∥) ≃ ∥ Is-equivalence f ∥)
¬[∥∥-connected≃∥Is-equivalence∥] hyp =
  ¬[∥∥-connected→∥Is-equivalence∥] (_≃_.to hyp)

-- If (x : A) → ∥ P x ∥ implies ∥ ((x : A) → P x) ∥ for all types A
-- and type families P over A, then the axiom of choice holds.

[Π∥∥→∥Π∥]→Axiom-of-choice :
  ({A : Type a} {P : A → Type p} →
   ((x : A) → ∥ P x ∥) → ∥ ((x : A) → P x) ∥) →
  Axiom-of-choice a p
[Π∥∥→∥Π∥]→Axiom-of-choice hyp = λ _ → hyp

-- If ∥ ((x : A) → P x) ∥ is isomorphic to (x : A) → ∥ P x ∥ for all
-- types A and type families P over A, then the axiom of choice holds.
--
-- Compare with Erased.Level-1.Erased-Π↔Π.

[∥Π∥↔Π∥∥]→Axiom-of-choice :
  ({A : Type a} {P : A → Type p} →
   ∥ ((x : A) → P x) ∥ ↔ ((x : A) → ∥ P x ∥)) →
  Axiom-of-choice a p
[∥Π∥↔Π∥∥]→Axiom-of-choice hyp =
  [Π∥∥→∥Π∥]→Axiom-of-choice (_↔_.from hyp)

-- If ∥ A ∥ → ∥ B ∥ implies ∥ (A → B) ∥ for all types A and B in the
-- same universe, then ∥ (∥ A ∥ → A) ∥ holds for every type A in this
-- universe. This is a variant of the axiom of choice of which Kraus
-- et al. state that "We expect that this makes it possible to show
-- that, in MLTT with weak propositional truncation, [a logically
-- equivalent variant of the axiom] is not derivable" (see "Notions of
-- Anonymous Existence in Martin-Löf Type Theory").

[[∥∥→∥∥]→∥→∥]→Axiom-of-choice :
  ({A B : Type a} → (∥ A ∥ → ∥ B ∥) → ∥ (A → B) ∥) →
  ({A : Type a} → ∥ (∥ A ∥ → A) ∥)
[[∥∥→∥∥]→∥→∥]→Axiom-of-choice hyp {A = A} =
                       $⟨ T.rec T.truncation-is-proposition id ⟩
  (∥ ∥ A ∥ ∥ → ∥ A ∥)  →⟨ hyp ⟩□
  ∥ (∥ A ∥ → A) ∥      □

-- If ∥ (A → B) ∥ is isomorphic to ∥ A ∥ → ∥ B ∥ for all types A and B
-- in the same universe, then ∥ (∥ A ∥ → A) ∥ holds for every type A
-- in this universe. This is a variant of the axiom of choice of which
-- Kraus et al. state that "We expect that this makes it possible to
-- show that, in MLTT with weak propositional truncation, [a logically
-- equivalent variant of the axiom] is not derivable" (see "Notions of
-- Anonymous Existence in Martin-Löf Type Theory").
--
-- Compare with Erased.Level-1.Erased-Π↔Π-Erased.

[∥→∥↔[∥∥→∥∥]]→Axiom-of-choice :
  ({A B : Type a} → ∥ (A → B) ∥ ↔ (∥ A ∥ → ∥ B ∥)) →
  ({A : Type a} → ∥ (∥ A ∥ → A) ∥)
[∥→∥↔[∥∥→∥∥]]→Axiom-of-choice hyp =
  [[∥∥→∥∥]→∥→∥]→Axiom-of-choice (_↔_.from hyp)

-- It is not the case that, for every type A, if A is ∥∥-modal, then A
-- is (λ (A : Type a) → ∥∥-modal A)-null.

¬[∥∥-modal→∥∥-modal-Null] :
  ¬ ({A : Type a} → ∥∥-modal A → (λ (A : Type a) → ∥∥-modal A) -Null A)
¬[∥∥-modal→∥∥-modal-Null] hyp =                                 $⟨ ⊥-propositional ⟩
  Is-proposition ⊥                                              →⟨ hyp ⟩
  (∀ A → Is-equivalence (const ⦂ (⊥ → Is-proposition A → ⊥)))   →⟨ _$ _ ⟩
  Is-equivalence (const ⦂ (⊥ → Is-proposition (↑ _ Bool) → ⊥))  →⟨ Eq.⟨ _ ,_⟩ ⟩
  ⊥ ≃ (Is-proposition (↑ _ Bool) → ⊥)                           →⟨ →-cong ext
                                                                     (Eq.↔⇒≃ $ inverse $
                                                                      B.⊥↔uninhabited (¬-Bool-propositional ∘ ↑⁻¹-closure 1))
                                                                     Eq.id F.∘_ ⟩
  ⊥ ≃ (⊥₀ → ⊥)                                                  →⟨ Π⊥↔⊤ ext F.∘_ ⟩
  ⊥ ≃ ⊤                                                         →⟨ (λ eq → ⊥-elim $ _≃_.from eq _) ⟩□
  ⊥                                                             □

-- It is not the case that, for every type A, there is an equivalence
-- between "A is ∥∥-modal" and (λ (A : Type a) → ∥∥-modal A) -Null A.
--
-- Compare with Erased.Stability.Very-stable≃Very-stable-Null.

¬[∥∥-modal≃∥∥-modal-Null] :
  ¬ ({A : Type a} → ∥∥-modal A ≃ (λ (A : Type a) → ∥∥-modal A) -Null A)
¬[∥∥-modal≃∥∥-modal-Null] hyp =
  ¬[∥∥-modal→∥∥-modal-Null] (_≃_.to hyp)

-- It is not the case that, for every type A : Type a and proof of
-- Extensionality a a, there is an equivalence between "A is ∥∥-modal"
-- and (λ (A : Type a) → ∥∥-modal A) -Null A.
--
-- Compare with Erased.Stability.Very-stable≃Very-stable-Null.

¬[∥∥-modal≃∥∥-modal-Null]′ :
  ¬ ({A : Type a} →
     Extensionality a a →
     ∥∥-modal A ≃ (λ (A : Type a) → ∥∥-modal A) -Null A)
¬[∥∥-modal≃∥∥-modal-Null]′ hyp =
  ¬[∥∥-modal≃∥∥-modal-Null] (hyp ext)


-- Andreas, 2018-05-11, issue #3051
-- Allow pattern synonyms in mutual blocks

open import Agda.Builtin.Sigma
open import Agda.Builtin.Equality

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

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

_×̇_ : ∀{A C : Set} {B : A → Set} {D : C → Set}
     (f : A → C) (g : ∀{a} → B a → D (f a)) → Σ A B → Σ C D
(f ×̇ g) (x , y) = f x , g y

mutual
  data Cxt : Set₁ where
    _▷_ : (Γ : Cxt) (A : C⦅ Γ ⦆ → Set) → Cxt

  C⦅_⦆ : Cxt → Set
  C⦅ Γ ▷ A ⦆ = Σ C⦅ Γ ⦆ A

mutual
  data _≤_ : (Δ Γ : Cxt) → Set₁ where
    id≤  : ∀{Γ} → Γ ≤ Γ
    weak : ∀{Γ Δ A} (τ : Δ ≤ Γ) → (Δ ▷ A) ≤ Γ
    lift' : ∀{Γ Δ A A'} (τ : Δ ≤ Γ) (p : A' ≡ (A ∘′ τ⦅ τ ⦆)) → (Δ ▷ A') ≤ (Γ ▷ A)

  pattern lift τ = lift' τ refl

  τ⦅_⦆ : ∀{Γ Δ} (τ : Δ ≤ Γ) → C⦅ Δ ⦆ → C⦅ Γ ⦆
  τ⦅ id≤ ⦆ = id
  τ⦅ weak τ ⦆ = τ⦅ τ ⦆ ∘′ fst
  τ⦅ lift τ ⦆ = τ⦅ τ ⦆ ×̇ id

-- Should pass.


------------------------------------------------------------------------
-- The structure identity principle can be used to establish that
-- isomorphism coincides with equality (assuming univalence)
------------------------------------------------------------------------

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

open import Equality

module
  Univalence-axiom.Isomorphism-is-equality.Structure-identity-principle
    {reflexive} (eq : ∀ {a p} → Equality-with-J a p reflexive) where

open import Bijection eq using (_↔_)
open import Category eq
open Derived-definitions-and-properties eq
open import Equivalence eq as Eq using (_≃_)
open import Function-universe eq renaming (_∘_ to _⊚_)
open import H-level eq
open import H-level.Closure eq
open import Logical-equivalence using (_⇔_)
open import Prelude as P
open import Structure-identity-principle eq
open import Univalence-axiom eq
open import Univalence-axiom.Isomorphism-is-equality.Simple eq
  using (Assumptions; module Assumptions;
         Universe; module Universe;
         module Class)

-- The structure identity principle can be used to prove a slightly
-- restricted variant of isomorphism-is-equality (which is defined in
-- Univalence-axiom.Isomorphism-is-equality.Simple.Class).

isomorphism-is-equality′ :
  (Univ : Universe) → let open Universe Univ in
  Assumptions →
  ∀ c X Y →
  (∀ {B} → Is-set B → Is-set (El (proj₁ c) B)) →  -- Extra assumption.
  Is-set (proj₁ X) → Is-set (proj₁ Y) →           -- Extra assumptions.
  Class.Isomorphic Univ c X Y ↔ (X ≡ Y)
isomorphism-is-equality′ Univ ass
  (a , P) (C , x , p) (D , y , q) El-set C-set D-set = isomorphic

  module Isomorphism-is-equality′ where

  open Assumptions ass
  open Universe Univ
  open Class Univ using (Carrier; Instance; Isomorphic)

  -- The category of sets and functions.

  Fun : Category (# 2) (# 1)
  Fun = category-Set (# 1) ext (λ _ _ → univ₁)

  module Fun = Category Fun

  -- The category of sets and bijections.

  Bij : Category (# 2) (# 1)
  Bij = category-Set-≅ (# 1) ext (λ _ _ → univ₁)

  module Bij = Category Bij

  -- If two sets are isomorphic, then the underlying types are
  -- equivalent.

  ≅⇒≃ : (C D : Fun.Obj) → C Fun.≅ D → ⌞ C ⌟ ≃ ⌞ D ⌟
  ≅⇒≃ C D = _≃_.from (≃≃≅-Set (# 1) ext C D)

  -- The "standard notion of structure" that the structure identity
  -- principle is instantiated with.

  S : Standard-notion-of-structure (# 1) (# 1) Bij.precategory
  S = record
    { P               = El a ∘ ⌞_⌟
    ; H               = λ {C D} x y C≅D →
                          Is-isomorphism a (≅⇒≃ C D C≅D) x y
    ; H-prop          = λ {C D} → H-prop′ C D
    ; H-id            = λ {C} → H-id′ C
    ; H-∘             = λ {B C D} → H-∘′ B C D
    ; H-antisymmetric = λ {C} → H-antisymmetric′ C
    }
    where

    module Separate-abstract-block where

      abstract

        H-prop′ :
          (C D : Set (# 1))
          {x : El a ⌞ C ⌟} {y : El a ⌞ D ⌟}
          (f : Bij.Hom C D) →
          Is-proposition (Is-isomorphism a (≅⇒≃ C D f) x y)
        H-prop′ _ D _ = El-set (proj₂ D)

        H-id′ :
          (C : Set (# 1)) {x : El a ⌞ C ⌟} →
          Is-isomorphism a (≅⇒≃ C C (Bij.id {X = C})) x x
        H-id′ C {x} =
          resp a (≅⇒≃ C C (Bij.id {X = C})) x  ≡⟨ cong (λ eq → resp a eq x) $ Eq.lift-equality ext (refl _) ⟩
          resp a Eq.id x                       ≡⟨ resp-id ass a x ⟩∎
          x                                    ∎

        H-∘′ :
          (B C D : Set (# 1))
          {x : El a ⌞ B ⌟} {y : El a ⌞ C ⌟} {z : El a ⌞ D ⌟}
          {B≅C : Bij.Hom B C} {C≅D : Bij.Hom C D} →
          Is-isomorphism a (≅⇒≃ B C B≅C) x y →
          Is-isomorphism a (≅⇒≃ C D C≅D) y z →
          Is-isomorphism a
            (≅⇒≃ B D (Bij._∙_ {X = B} {Y = C} {Z = D} C≅D B≅C)) x z
        H-∘′ B C D {x} {y} {z} {B≅C} {C≅D} x≅y y≅z =
          resp a (≅⇒≃ B D (C≅D Bij.∙ B≅C)) x             ≡⟨ cong (λ eq → resp a eq x) $ Eq.lift-equality ext (refl _) ⟩
          resp a (≅⇒≃ C D C≅D ⊚ ≅⇒≃ B C B≅C) x           ≡⟨ resp-preserves-compositions (El a) (resp a) (resp-id ass a)
                                                                                univ₁ ext (≅⇒≃ B C B≅C) (≅⇒≃ C D C≅D) x ⟩
          resp a (≅⇒≃ C D C≅D) (resp a (≅⇒≃ B C B≅C) x)  ≡⟨ cong (resp a (≅⇒≃ C D C≅D)) x≅y ⟩
          resp a (≅⇒≃ C D C≅D) y                         ≡⟨ y≅z ⟩∎
          z                                              ∎

        H-antisymmetric′ :
          (C : Set (# 1))
          (x y : El a ⌞ C ⌟) →
          Is-isomorphism a (≅⇒≃ C C (Bij.id {X = C})) x y →
          Is-isomorphism a (≅⇒≃ C C (Bij.id {X = C})) y x →
          x ≡ y
        H-antisymmetric′ C x y x≡y _ =
          x                                    ≡⟨ sym $ resp-id ass a x ⟩
          resp a Eq.id x                       ≡⟨ cong (λ eq → resp a eq x) $ Eq.lift-equality ext (refl _) ⟩
          resp a (≅⇒≃ C C (Bij.id {X = C})) x  ≡⟨ x≡y ⟩∎
          y                                    ∎

    open Separate-abstract-block

  open module S = Standard-notion-of-structure S
    using (H; Str; module Str)

  abstract

    -- Every Str morphism is an isomorphism.

    Str-homs-are-isos :
      ∀ {C D x y} (f : ∃ (H {X = C} {Y = D} x y)) →
      Str.Is-isomorphism {X = C , x} {Y = D , y} f
    Str-homs-are-isos {C} {D} {x} {y} (C≅D , x≅y) =

      (D≅C ,
       (resp a (≅⇒≃ D C D≅C) y            ≡⟨ cong (λ eq → resp a eq y) $ Eq.lift-equality ext (refl _) ⟩
        resp a (inverse $ ≅⇒≃ C D C≅D) y  ≡⟨ resp-preserves-inverses (El a) (resp a) (resp-id ass a) univ₁ ext (≅⇒≃ C D C≅D) _ _ x≅y ⟩∎
        x                                 ∎)) ,

      S.lift-equality {X = D , y} {Y = D , y} (
        C≅D Fun.∙≅ D≅C   ≡⟨ _≃_.from (Fun.≡≃≡¹ {X = D} {Y = D}) (Fun._¹⁻¹ {X = C} {Y = D} C≅D) ⟩∎
        Fun.id≅ {X = D}  ∎) ,

      S.lift-equality {X = C , x} {Y = C , x} (
        D≅C Fun.∙≅ C≅D   ≡⟨ _≃_.from (Fun.≡≃≡¹ {X = C} {Y = C}) (Fun._⁻¹¹ {X = C} {Y = D} C≅D) ⟩∎
        Fun.id≅ {X = C}  ∎)

      where

      D≅C : D Fun.≅ C
      D≅C = Fun._⁻¹≅ {X = C} {Y = D} C≅D

    -- The isomorphism that should be constructed.

    isomorphic : Isomorphic (a , P) (C , x , p) (D , y , q) ↔
                 _≡_ {A = Instance (a , P)} (C , x , p) (D , y , q)
    isomorphic =
      Σ (C ≃ D) (λ eq → Is-isomorphism a eq x y)                   ↝⟨ (let ≃≃≅-CD = ≃≃≅-Set (# 1) ext (C , C-set) (D , D-set) in
                                                                       Σ-cong ≃≃≅-CD (λ eq →
                                                                         let eq′ = _≃_.from ≃≃≅-CD (_≃_.to ≃≃≅-CD eq) in
                                                                         Is-isomorphism a eq  x y  ↝⟨ ≡⇒↝ _ $
                                                                                cong (λ eq → Is-isomorphism a eq x y) $ sym $
                                                                                _≃_.left-inverse-of ≃≃≅-CD eq ⟩
                                                                         Is-isomorphism a eq′ x y  □)) ⟩
      ∃ (H {X = C , C-set} {Y = D , D-set} x y)                    ↝⟨ inverse ×-right-identity ⟩
      ∃ (H {X = C , C-set} {Y = D , D-set} x y) × ⊤                ↝⟨ ∃-cong (λ X≅Y → inverse $ _⇔_.to contractible⇔↔⊤ $
                                                                                propositional⇒inhabited⇒contractible
                                                                                (Str.Is-isomorphism-propositional X≅Y)
                                                                                (Str-homs-are-isos X≅Y)) ⟩
      (((C , C-set) , x) Str.≅ ((D , D-set) , y))                  ↔⟨ inverse Eq.⟨ _ , structure-identity-principle ext Bij S
                                                                                {X = (C , C-set) , x} {Y = (D , D-set) , y} ⟩ ⟩
      (((C , λ {_ _} → C-set) , x) ≡ ((D , λ {_ _} → D-set) , y))  ↔⟨ Eq.≃-≡ $ Eq.↔⇒≃ (Σ-assoc ⊚ ∃-cong (λ _ → ×-comm) ⊚ inverse Σ-assoc) ⟩
      (((C , x) , λ {_ _} → C-set) ≡ ((D , y) , λ {_ _} → D-set))  ↝⟨ inverse $ ignore-propositional-component (H-level-propositional ext 2) ⟩
      ((C , x) ≡ (D , y))                                          ↝⟨ ignore-propositional-component (proj₂ (P D y) ass) ⟩
      (((C , x) , p) ≡ ((D , y) , q))                              ↔⟨ Eq.≃-≡ $ Eq.↔⇒≃ Σ-assoc ⟩□
      ((C , x , p) ≡ (D , y , q))                                  □

    -- A simplification lemma.

    proj₁-from-isomorphic :
      ∀ X≡Y →
      proj₁ (_↔_.from isomorphic X≡Y) ≡
      elim (λ {X Y} _ → proj₁ X ≃ proj₁ Y) (λ _ → Eq.id) X≡Y
    proj₁-from-isomorphic X≡Y = Eq.lift-equality ext (

      _≃_.to (proj₁ (_↔_.from isomorphic X≡Y))                         ≡⟨⟩

      cast C-set D-set X≡Y                                             ≡⟨ lemma ⟩∎

      _≃_.to (elim (λ {X Y} _ → proj₁ X ≃ proj₁ Y) (λ _ → Eq.id) X≡Y)  ∎)

      where

      cast : ∀ {X Y} →
             Is-set (Carrier (a , P) X) → Is-set (Carrier (a , P) Y) →
             X ≡ Y → Carrier (a , P) X → Carrier (a , P) Y
      cast {C , x , p} {D , y , q} C-set D-set X≡Y =
        proj₁ $ proj₁ $ proj₁ $
        Str.≡→≅ {X = (C , C-set) , x} {Y = (D , D-set) , y} $
        cong (λ { ((C , x) , C-set) → (C , C-set) , x }) $
        Σ-≡,≡→≡ (proj₁ (Σ-≡,≡←≡
                   (cong (λ { (C , (x , p)) → (C , x) , p }) X≡Y)))
                (proj₁ (+⇒≡ $ H-level-propositional ext 2))

      lemma :
        cast C-set D-set X≡Y ≡
        _≃_.to (elim (λ {X Y} _ → proj₁ X ≃ proj₁ Y) (λ _ → Eq.id) X≡Y)
      lemma = elim¹
        (λ X≡Y → (D-set : Is-set _) →
                 cast C-set D-set X≡Y ≡
                 _≃_.to (elim (λ {X Y} _ → proj₁ X ≃ proj₁ Y)
                              (λ _ → Eq.id) X≡Y))
        (λ C-set′ →

           cast C-set C-set′ (refl (C , x , p))                           ≡⟨ cong (λ eq →
                                                                                proj₁ $ proj₁ $ proj₁ $
                                                                                Str.≡→≅ {X = (C , C-set) , x} {Y = (C , C-set′) , x} $
                                                                                cong (λ { ((C , x) , C-set) → (C , C-set) , x }) $
                                                                                Σ-≡,≡→≡ (proj₁ (Σ-≡,≡←≡ {B = proj₁ ∘ uncurry P} eq))
                                                                                (proj₁ (+⇒≡ $ H-level-propositional ext 2)))
                                                                                (cong-refl (λ { (C , (x , p)) → (C , x) , p })) ⟩
           (proj₁ $ proj₁ $ proj₁ $
            Str.≡→≅ {X = (C , C-set) , x} {Y = (C , C-set′) , x} $
            cong (λ { ((C , x) , C-set) → (C , C-set) , x }) $
            Σ-≡,≡→≡ (proj₁ (Σ-≡,≡←≡ (refl ((C , x) , p))))
                    (proj₁ (+⇒≡ $ H-level-propositional ext 2)))          ≡⟨ cong proj₁ (S.proj₁-≡→≅-¹ _) ⟩

           (proj₁ $
            Fun.≡→≅ $
            cong proj₁ $
            cong (λ { ((C , x) , C-set) → (C , C-set) , x }) $
            Σ-≡,≡→≡ (proj₁ (Σ-≡,≡←≡ (refl ((C , x) , p))))
                    (proj₁ (+⇒≡ $ H-level-propositional ext 2)))          ≡⟨ cong (proj₁ ∘ Fun.≡→≅) $
                                                                               cong-∘ proj₁ (λ { ((C , x) , C-set) → (C , C-set) , x }) _ ⟩
           (proj₁ $
            Fun.≡→≅ $
            cong (λ { ((C , _) , C-set) → C , C-set }) $
            Σ-≡,≡→≡ (proj₁ (Σ-≡,≡←≡ (refl ((C , x) , p))))
                    (proj₁ (+⇒≡ $ H-level-propositional ext 2)))          ≡⟨ Fun.≡→≅-¹ _ ⟩

           (elim (λ {X Y} _ → Fun.Hom X Y) (λ _ → P.id) $
            cong (λ { ((C , _) , C-set) → C , C-set }) $
            Σ-≡,≡→≡ (proj₁ (Σ-≡,≡←≡ (refl ((C , x) , p))))
                    (proj₁ (+⇒≡ $ H-level-propositional ext 2)))          ≡⟨ elim¹ (λ eq → elim (λ {X Y} _ → Fun.Hom X Y) (λ _ → P.id) eq ≡
                                                                                ≡⇒↝ implication (cong proj₁ eq)) (
               elim (λ {X Y} _ → Fun.Hom X Y) (λ _ → P.id)
                    (refl (C , λ {_ _} → C-set))                                        ≡⟨ elim-refl (λ {X Y} _ → Fun.Hom X Y) _ ⟩
               P.id                                                                     ≡⟨ sym $ elim-refl (λ {A B} _ → A → B) _ ⟩
               ≡⇒↝ implication (refl C)                                                 ≡⟨ cong (≡⇒↝ implication) (sym $ cong-refl proj₁) ⟩∎
               ≡⇒↝ implication (cong proj₁ (refl (C , λ {_ _} → C-set)))                ∎) _ ⟩

           (≡⇒↝ implication $
            cong proj₁ $
            cong (λ { ((C , _) , C-set) → C , C-set }) $
            Σ-≡,≡→≡ (proj₁ (Σ-≡,≡←≡ (refl ((C , x) , p))))
                    (proj₁ (+⇒≡ $ H-level-propositional ext 2)))          ≡⟨ cong (≡⇒↝ implication)
                                                                                (cong-∘ proj₁ (λ { ((C , _) , C-set) → C , C-set }) _) ⟩
           (≡⇒↝ implication $
            cong (λ { ((C , _) , _) → C }) $
            Σ-≡,≡→≡ (proj₁ (Σ-≡,≡←≡ (refl ((C , x) , p))))
                    (proj₁ (+⇒≡ $ H-level-propositional ext 2)))          ≡⟨ cong (λ (eq : ∃ λ q → subst (proj₁ ∘ uncurry P) q p ≡ p) →
                                                                                ≡⇒↝ implication $
                                                                                cong (λ { ((C , _) , _) → C }) $
                                                                                Σ-≡,≡→≡ (proj₁ eq)
                                                                                (proj₁ (+⇒≡ $ H-level-propositional ext 2)))
                                                                                (Σ-≡,≡←≡-refl {B = λ { (C , x) → proj₁ (P C x)}}) ⟩
           (≡⇒↝ implication $
            cong (λ { ((C , _) , _) → C }) $
            Σ-≡,≡→≡ (refl (C , x))
                    (proj₁ (+⇒≡ $ H-level-propositional ext 2)))          ≡⟨ cong (≡⇒↝ implication ∘ cong (λ { ((C , _) , _) → C }))
                                                                                (Σ-≡,≡→≡-reflˡ (proj₁ (+⇒≡ $ H-level-propositional ext 2))) ⟩
           (≡⇒↝ implication $
            cong (λ { ((C , _) , _) → C }) $
            cong (_,_ (C , x))
                 (trans (sym $ subst-refl (Is-set ∘ proj₁) C-set)
                        (proj₁ (+⇒≡ $ H-level-propositional ext 2))))     ≡⟨ cong (≡⇒↝ implication)
                                                                                (cong-∘ (λ { ((C , _) , _) → C }) (_,_ (C , x)) _) ⟩
           (≡⇒↝ implication $
            cong (const C)
                 (trans (sym $ subst-refl (Is-set ∘ proj₁) C-set)
                        (proj₁ (+⇒≡ $ H-level-propositional ext 2))))     ≡⟨ cong (≡⇒↝ implication) (cong-const _) ⟩

           ≡⇒↝ implication (refl C)                                       ≡⟨ ≡⇒↝-refl ⟩

           P.id                                                           ≡⟨ sym $ cong _≃_.to $ elim-refl (λ {X Y} _ → proj₁ X ≃ proj₁ Y) _ ⟩∎

           _≃_.to (elim (λ {X Y} _ → proj₁ X ≃ proj₁ Y)
                        (λ _ → Eq.id)
                        (refl (C , x , p)))                               ∎)

        X≡Y D-set

abstract

  -- The from component of isomorphism-is-equality′ is equal
  -- to a simple function.

  from-isomorphism-is-equality′ :
    ∀ Univ ass c X Y → let open Universe Univ; open Class Univ in
    (El-set : ∀ {B} → Is-set B → Is-set (El (proj₁ c) B)) →
    (X-set : Is-set (proj₁ X)) (Y-set : Is-set (proj₁ Y)) →
    _↔_.from (isomorphism-is-equality′
                Univ ass c X Y El-set X-set Y-set) ≡
    elim (λ {X Y} _ → Isomorphic c X Y)
         (λ { (_ , x , _) → Eq.id , resp-id ass (proj₁ c) x })
  from-isomorphism-is-equality′ Univ ass c X Y El-set X-set Y-set =
    apply-ext ext λ eq →
      Σ-≡,≡→≡ (lemma eq) (El-set Y-set _ _)
    where
    open Assumptions ass
    open Universe Univ
    open Class Univ

    lemma :
      ∀ eq →
      proj₁ (_↔_.from (isomorphism-is-equality′
                         Univ ass c X Y El-set X-set Y-set) eq) ≡
      proj₁ (elim (λ {X Y} _ → Isomorphic c X Y)
                  (λ { (_ , x , _) → Eq.id , resp-id ass (proj₁ c) x })
                  eq)
    lemma eq =
      proj₁ (_↔_.from (isomorphism-is-equality′
                         Univ ass c X Y El-set X-set Y-set) eq)          ≡⟨ Isomorphism-is-equality′.proj₁-from-isomorphic
                                                                              Univ ass _ _ _ _ _ _ _ _ El-set X-set Y-set eq ⟩
      elim (λ {X Y} _ → proj₁ X ≃ proj₁ Y) (λ _ → Eq.id) eq              ≡⟨ sym $ elim-∘ (λ {X Y} _ → Isomorphic c X Y) _ proj₁ _ ⟩∎
      proj₁ (elim (λ {X Y} _ → Isomorphic c X Y)
                  (λ { (_ , x , _) → Eq.id , resp-id ass (proj₁ c) x })
                  eq)                                                    ∎


module vector-test-ctors where

open import bool
open import list
open import vector

----------------------------------------------------------------------
-- syntax
----------------------------------------------------------------------

test-vector : 𝕃 (𝕍 𝔹 2)
test-vector = (ff :: tt :: []) :: (tt :: ff :: []) :: (tt :: ff :: []) :: []


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

open import Definition.Typed.EqualityRelation

module Definition.LogicalRelation.Substitution.Introductions.Universe {{eqrel : EqRelSet}} where
open EqRelSet {{...}}

open import Definition.Untyped
open import Definition.LogicalRelation
open import Definition.LogicalRelation.Properties
open import Definition.LogicalRelation.Substitution

open import Tools.Product
import Tools.PropositionalEquality as PE

-- Validity of the universe type.
Uᵛ : ∀ {Γ} ([Γ] : ⊩ᵛ Γ) → Γ ⊩ᵛ⟨ ¹ ⟩ U / [Γ]
Uᵛ [Γ] ⊢Δ [σ] = Uᵣ′ ⁰ 0<1 ⊢Δ , λ _ x₂ → U₌ PE.refl

-- Valid terms of type U are valid types.
univᵛ : ∀ {A Γ l l′} ([Γ] : ⊩ᵛ Γ)
        ([U] : Γ ⊩ᵛ⟨ l ⟩ U / [Γ])
      → Γ ⊩ᵛ⟨ l ⟩ A ∷ U / [Γ] / [U]
      → Γ ⊩ᵛ⟨ l′ ⟩ A / [Γ]
univᵛ {l′ = l′} [Γ] [U] [A] ⊢Δ [σ] =
  let [A]₁ = maybeEmb′ {l′} (univEq (proj₁ ([U] ⊢Δ [σ])) (proj₁ ([A] ⊢Δ [σ])))
  in  [A]₁ , (λ [σ′] [σ≡σ′] → univEqEq (proj₁ ([U] ⊢Δ [σ])) [A]₁
                                       ((proj₂ ([A] ⊢Δ [σ])) [σ′] [σ≡σ′]))

-- Valid term equality of type U is valid type equality.
univEqᵛ : ∀ {A B Γ l l′} ([Γ] : ⊩ᵛ Γ)
          ([U] : Γ ⊩ᵛ⟨ l′ ⟩ U / [Γ])
          ([A] : Γ ⊩ᵛ⟨ l ⟩ A / [Γ])
        → Γ ⊩ᵛ⟨ l′ ⟩ A ≡ B ∷ U / [Γ] / [U]
        → Γ ⊩ᵛ⟨ l ⟩ A ≡ B / [Γ] / [A]
univEqᵛ {A} [Γ] [U] [A] [t≡u] ⊢Δ [σ] =
  univEqEq (proj₁ ([U] ⊢Δ [σ])) (proj₁ ([A] ⊢Δ [σ])) ([t≡u] ⊢Δ [σ])


module OpenModule where

module A where
  postulate X : Set

-- Both open import and open module applies the directives
-- to the "open" rather than to the module.
open import Nat   hiding (zero) renaming (Nat to N)
open module B = A renaming (X to Y)

Test : Set
Test = Y → B.X → N → Nat.Nat

zero : N
zero = Nat.zero

-- If the module isn't opened the directives are applied to
-- the module.
import Nat as N renaming (Nat to N)
module C = A    renaming (X to Z)

Test₂ : Set
Test₂ = N.N → C.Z


module Prelude.Char where

open import Prelude.Bool
open import Prelude.Nat
open import Prelude.Equality
open import Prelude.Equality.Unsafe
open import Prelude.Decidable
open import Prelude.Function
open import Prelude.Ord

open import Agda.Builtin.Char
open Agda.Builtin.Char public using (Char)

isLower    = primIsLower
isDigit    = primIsDigit
isSpace    = primIsSpace
isAscii    = primIsAscii
isLatin1   = primIsLatin1
isPrint    = primIsPrint
isHexDigit = primIsHexDigit
isAlpha    = primIsAlpha

toUpper    = primToUpper
toLower    = primToLower

isAlphaNum : Char → Bool
isAlphaNum c = isAlpha c || isDigit c

charToNat  = primCharToNat
natToChar  = primNatToChar

charToNat-inj : ∀ {x y} → charToNat x ≡ charToNat y → x ≡ y
charToNat-inj {x} p with charToNat x
charToNat-inj refl | ._ = unsafeEqual  -- need to be strict in the proof!

--- Equality --

eqChar : Char → Char → Bool
eqChar = eqNat on charToNat

instance
  EqChar : Eq Char
  _==_ {{EqChar}} x y with eqChar x y
  ... | false = no  unsafeNotEqual
  ... | true  = yes unsafeEqual

-- Missing primitive isUpper
isUpper : Char → Bool
isUpper c = isNo (toLower c == c)

--- Ord ---

instance
  OrdChar : Ord Char
  OrdChar = OrdBy charToNat-inj

  OrdLawsChar : Ord/Laws Char
  OrdLawsChar = OrdLawsBy charToNat-inj


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

open import Definition.Typed.EqualityRelation

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

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.LogicalRelation
open import Definition.LogicalRelation.Irrelevance
open import Definition.LogicalRelation.ShapeView

open import Tools.Embedding
open import Tools.Product

-- Helper function for successors for specific reducible derivations.
sucTerm′ : ∀ {l Γ n}
           ([ℕ] : Γ ⊩⟨ l ⟩ℕ ℕ)
         → Γ ⊩⟨ l ⟩ n ∷ ℕ / ℕ-intr [ℕ]
         → Γ ⊩⟨ l ⟩ suc n ∷ ℕ / ℕ-intr [ℕ]
sucTerm′ (noemb D) (ιx (ℕₜ n [ ⊢t , ⊢u , d ] n≡n prop)) =
  let natN = natural prop
  in  ιx (ℕₜ _ [ sucⱼ ⊢t , sucⱼ ⊢t , id (sucⱼ ⊢t) ]
         (≅-suc-cong (≅ₜ-red (red D) d d ℕₙ
                             (naturalWhnf natN) (naturalWhnf natN) n≡n))
         (sucᵣ (ℕₜ n [ ⊢t , ⊢u , d ] n≡n prop)))
sucTerm′ (emb 0<1 x) (ιx [n]) = ιx (sucTerm′ x [n])

-- Reducible natural numbers can be used to construct reducible successors.
sucTerm : ∀ {l Γ n} ([ℕ] : Γ ⊩⟨ l ⟩ ℕ)
        → Γ ⊩⟨ l ⟩ n ∷ ℕ / [ℕ]
        → Γ ⊩⟨ l ⟩ suc n ∷ ℕ / [ℕ]
sucTerm [ℕ] [n] =
  let [n]′ = irrelevanceTerm [ℕ] (ℕ-intr (ℕ-elim [ℕ])) [n]
  in  irrelevanceTerm (ℕ-intr (ℕ-elim [ℕ]))
                      [ℕ]
                      (sucTerm′ (ℕ-elim [ℕ]) [n]′)

-- Helper function for successor equality for specific reducible derivations.
sucEqTerm′ : ∀ {l Γ n n′}
             ([ℕ] : Γ ⊩⟨ l ⟩ℕ ℕ)
           → Γ ⊩⟨ l ⟩ n ≡ n′ ∷ ℕ / ℕ-intr [ℕ]
           → Γ ⊩⟨ l ⟩ suc n ≡ suc n′ ∷ ℕ / ℕ-intr [ℕ]
sucEqTerm′ (noemb D) (ιx (ℕₜ₌ k k′ [ ⊢t , ⊢u , d ]
                              [ ⊢t₁ , ⊢u₁ , d₁ ] t≡u prop)) =
  let natK , natK′ = split prop
  in  ιx (ℕₜ₌ _ _ (idRedTerm:*: (sucⱼ ⊢t)) (idRedTerm:*: (sucⱼ ⊢t₁))
        (≅-suc-cong (≅ₜ-red (red D) d d₁ ℕₙ (naturalWhnf natK) (naturalWhnf natK′) t≡u))
        (sucᵣ (ℕₜ₌ k k′ [ ⊢t , ⊢u , d ] [ ⊢t₁ , ⊢u₁ , d₁ ] t≡u prop)))
sucEqTerm′ (emb 0<1 x) (ιx [n≡n′]) = ιx (sucEqTerm′ x [n≡n′])

-- Reducible natural number equality can be used to construct reducible equality
-- of the successors of the numbers.
sucEqTerm : ∀ {l Γ n n′} ([ℕ] : Γ ⊩⟨ l ⟩ ℕ)
          → Γ ⊩⟨ l ⟩ n ≡ n′ ∷ ℕ / [ℕ]
          → Γ ⊩⟨ l ⟩ suc n ≡ suc n′ ∷ ℕ / [ℕ]
sucEqTerm [ℕ] [n≡n′] =
  let [n≡n′]′ = irrelevanceEqTerm [ℕ] (ℕ-intr (ℕ-elim [ℕ])) [n≡n′]
  in  irrelevanceEqTerm (ℕ-intr (ℕ-elim [ℕ])) [ℕ]
                        (sucEqTerm′ (ℕ-elim [ℕ]) [n≡n′]′)


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

module TrustMe-with-doubly-indexed-equality where

open import Common.Level

infix 4 _≡_

data _≡_ {a} {A : Set a} : A → A → Set a where
  refl : ∀ {x} → x ≡ x

{-# BUILTIN EQUALITY _≡_  #-}
{-# BUILTIN REFL     refl #-}

sym : ∀ {a} {A : Set a} {x y : A} → x ≡ y → y ≡ x
sym refl = refl

primitive
  primTrustMe : ∀ {a} {A : Set a} {x y : A} → x ≡ y

postulate
  A : Set
  x : A

eq : x ≡ x
eq = primTrustMe

evaluates-to-refl : sym (sym eq) ≡ eq
evaluates-to-refl = refl


module Issue690a where

postulate A : Set

data T : Set → Set where
  c : T (T A)


module Issue2880 where

app : {A : Set} → (A → A) → (A → A)
app f x = f x

{-# COMPILE GHC app = \ A f x -> f (app A f x) #-}

mutual

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

  {-# COMPILE GHC id = id' #-}

  id' : {A : Set} → A → A
  id' x = x

  {-# COMPILE GHC id' = id #-}


open import Signature
import Logic

module Model (Σ Δ : Sig) (V : Set) (Φ : Logic.Program Σ Δ V) where

open import Function
open import Data.Empty renaming (⊥ to Ø)
open import Data.Sum
open import Data.Product renaming (Σ to ∐)
open import Relation.Unary
open import Relation.Binary.PropositionalEquality hiding ([_])

open import Logic Σ Δ V
open import Terms Σ

-- | I-ary relations over A
Rel : Set → Set → Set₁
Rel I A = (I → A) → Set

_⊆ᵣ_ : ∀{I A} → Rel I A → Rel I A → Set
R₁ ⊆ᵣ R₂ = ∀{t} → R₁ t → R₂ t

PredInterpret : Set₁
PredInterpret = (Q : ∥ Δ ∥) → Rel (ar Δ Q) (T∞ Ø)

_⊑ᵢ_ : PredInterpret → PredInterpret → Set
I₁ ⊑ᵢ I₂ = ∀ {Q} → I₁ Q ⊆ᵣ I₂ Q

liftApp∞ : ∀ {V W} {I : Set} → Subst∞ V W → (I → T∞ V) → (I → T∞ W)
liftApp∞ σ f i = app∞ σ (f i)

_≡[_]_ : T∞ Ø → Subst∞ V Ø → T V → Set
t ≡[ σ ] s = t ~ app∞ σ (χ s)

{-
_⊨[_]_ : PredInterpret → Subst∞ V Ø → Formula → Set
I ⊨[ σ ] (inj₁ (Q , ts)) = liftApp∞ σ (χ ∘ ts) ∈ I Q
I ⊨[ σ ] (inj₂ _) = Ø
-}

_⊨[_]_ : PredInterpret → Subst∞ V Ø → Formula → Set
I ⊨[ σ ] (Q , ts) = liftApp∞ σ (χ ∘ ts) ∈ I Q

⟦_⟧ : dom Φ → PredInterpret → PredInterpret
⟦ C ⟧ I = F (get Φ C)
  where
    -- | Forward closure for inductive clauses is given by
    -- F(h ⊢μ Q'(t))(I)(Q)
    --   = {t[σ] | σ : V → Ø ∧ Q ≡ Q' ∧ ∀ P(s) ∈ h. s[σ] ∈ I(P)}.
    -- The backwards closure for coinductive clauses is, on the other hand,
    -- given by
    -- F(h ⊢ν P(s))(I)(Q) = {t[σ] | σ : V → Ø ∧ Q(t) ∈ h ∧ s ∈ I(Q)}
    F : Clause → PredInterpret
    F (h ⊢[ ind ] (Q' , pat)) Q ts =
      ∐ (Q' ≡ Q) (λ p →
      ∃ (λ σ →
        ∀ i → ts (subst _ p i) ≡[ σ ] pat i
        × (∀ j → I ⊨[ σ ] get h j)))
    F (h ⊢[ coind ] φ) Q ts =
      ∃ (λ j →
      ∐ (proj₁ (get h j) ≡ Q) (λ p →
      ∃ (λ σ →
        ∀ i → ts (subst _ p i) ≡[ σ ] proj₂ (get h j) i
        × I ⊨[ σ ] φ)))

FormInterpret : PredInterpret → Formula → Pred (Subst∞ V Ø) _
FormInterpret I (Q , ts) σ = (λ i → app∞ σ (χ (ts i))) ∈ I Q

B : (Formula → Pred (Subst∞ V Ø) _) → (Formula → Pred (Subst∞ V Ø) _)
B D F = {!!}

record ModelData : Set₁ where
  field
    preds : PredInterpret


module Common.Prelude where

{-# IMPORT Common.FFI #-}

import Common.Level

data   ⊥ : Set where
record ⊤ : Set where

postulate Char : Set

{-# BUILTIN CHAR Char #-}
{-# COMPILED_TYPE Char Char #-}

postulate String : Set

{-# BUILTIN STRING String #-}
{-# COMPILED_TYPE String String #-}

data Nat : Set where
  zero : Nat
  suc  : Nat → Nat

{-# BUILTIN NATURAL Nat  #-}

{-# COMPILED_DATA Nat Common.FFI.Nat Common.FFI.Zero Common.FFI.Suc #-}

{-# COMPILED_JS     Nat function (x,v) { return (x < 1? v.zero(): v.suc(x-1)); } #-}
{-# COMPILED_JS     zero 0 #-}
{-# COMPILED_JS     suc function (x) { return x+1; } #-}

_+_ : Nat → Nat → Nat
zero  + n = n
suc m + n = suc (m + n)

{-# COMPILED_JS _+_ function (x) { return function (y) { return x+y; }; } #-}

_∸_ : Nat → Nat → Nat
m     ∸ zero  = m
zero  ∸ _     = zero
suc m ∸ suc n = m ∸ n

{-# COMPILED_JS _∸_ function (x) { return function (y) { return Math.max(0,x-y); }; } #-}

pred : Nat → Nat
pred zero    = zero
pred (suc n) = n

data List A : Set where
  [] : List A
  _∷_ : A → List A → List A

infixr 40 _∷_ _++_

_++_ : ∀ {A : Set} → List A → List A → List A
[]       ++ ys = ys
(x ∷ xs) ++ ys = x ∷ (xs ++ ys)

{-# BUILTIN LIST List #-}
{-# BUILTIN NIL []    #-}
{-# BUILTIN CONS _∷_  #-}

{-# COMPILED_DATA List [] [] (:) #-}

data Bool : Set where
  true false : Bool

if_then_else_ : ∀ {A : Set} → Bool → A → A → A
if true  then t else f = t
if false then t else f = f

{-# BUILTIN BOOL  Bool  #-}
{-# BUILTIN TRUE  true  #-}
{-# BUILTIN FALSE false #-}

{-# COMPILED_DATA Bool Bool True False #-}

{-# COMPILED_JS Bool function (x,v) { return (x? v["true"](): v["false"]()); } #-}
{-# COMPILED_JS true true #-}
{-# COMPILED_JS false false #-}

data Unit : Set where
  unit : Unit

{-# COMPILED_DATA Unit () () #-}

postulate
  IO : Set → Set

{-# COMPILED_TYPE IO IO #-}
{-# BUILTIN IO IO #-}


-- You can omit the right hand side if you pattern match on an empty type. But
-- you have to do the matching.
module NoRHSRequiresAbsurdPattern where

data Zero : Set where

good : {A : Set} -> Zero -> A
good ()

bad : {A : Set} -> Zero -> A
bad h


-- Left ℤ-multiplication on groups and some of its properties
{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Algebra.Group.ZAction where

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

open import Cubical.Data.Sigma
open import Cubical.Data.Int
  renaming (_·_ to _*_ ; _+_ to _+ℤ_ ; _-_ to _-ℤ_)
open import Cubical.Data.Nat
  hiding (_·_) renaming (_+_ to _+ℕ_)
open import Cubical.Data.Empty renaming (rec to ⊥-rec)
open import Cubical.Data.Sum

open import Cubical.Algebra.Group.Base
open import Cubical.Algebra.Group.Properties
open import Cubical.Algebra.Group.Morphisms
open import Cubical.Algebra.Group.MorphismProperties
open import Cubical.Algebra.Group.Instances.Int renaming (ℤ to ℤGroup)
open import Cubical.Algebra.Group.DirProd

open import Cubical.Relation.Nullary

private
  variable
    ℓ ℓ' : Level

open Iso
open GroupStr
open IsGroupHom

_ℤ[_]·_ : ℤ → (G : Group ℓ) → fst G → fst G
pos zero ℤ[ G' ]· g = 1g (snd G')
pos (suc n) ℤ[ G' ]· g = _·_ (snd G') g (pos n ℤ[ G' ]· g)
negsuc zero ℤ[ G' ]· g = inv (snd G') g
negsuc (suc n) ℤ[ G' ]· g =
  _·_ (snd G') (inv (snd G') g) (negsuc n ℤ[ G' ]· g)

homPresℤ· : {G : Group ℓ} {H : Group ℓ'}
         → (ϕ : GroupHom G H)
         → (x : fst G) (z : ℤ)
         → fst ϕ (z ℤ[ G ]· x) ≡ (z ℤ[ H ]· fst ϕ x)
homPresℤ· (ϕ , ϕhom) x (pos zero) = pres1 ϕhom
homPresℤ· {H = H} (ϕ , ϕhom) x (pos (suc n)) =
    pres· ϕhom _ _
  ∙ cong (_·_ (snd H) (ϕ x)) (homPresℤ· (ϕ , ϕhom) x (pos n))
homPresℤ· (ϕ , ϕhom) x (negsuc zero) = presinv ϕhom _
homPresℤ· {H = H} (ϕ , ϕhom) x (negsuc (suc n)) =
    pres· ϕhom _ _
  ∙ cong₂ (_·_ (snd H)) (presinv ϕhom x)
                        (homPresℤ· (ϕ , ϕhom) x (negsuc n))

rUnitℤ· : (G : Group ℓ) (x : ℤ) → (x ℤ[ G ]· 1g (snd G)) ≡ 1g (snd G)
rUnitℤ· G (pos zero) = refl
rUnitℤ· G (pos (suc n)) =
    cong (_·_ (snd G) (1g (snd G)))
      (rUnitℤ· G (pos n))
  ∙ lid (snd G) (1g (snd G))
rUnitℤ· G (negsuc zero) = GroupTheory.inv1g G
rUnitℤ· G (negsuc (suc n)) =
    cong₂ (_·_ (snd G)) (GroupTheory.inv1g G) (rUnitℤ· G (negsuc n))
  ∙ lid (snd G) (1g (snd G))

rUnitℤ·ℤ : (x : ℤ) → (x ℤ[ ℤGroup ]· 1) ≡ x
rUnitℤ·ℤ (pos zero) = refl
rUnitℤ·ℤ (pos (suc n)) = cong (pos 1 +ℤ_) (rUnitℤ·ℤ (pos n)) ∙ sym (pos+ 1 n)
rUnitℤ·ℤ (negsuc zero) = refl
rUnitℤ·ℤ (negsuc (suc n)) = cong (-1 +ℤ_) (rUnitℤ·ℤ (negsuc n))
                          ∙ +Comm (negsuc 0) (negsuc n)

private
  precommℤ : (G : Group ℓ) (g : fst G) (y : ℤ)
           → (snd G · (y ℤ[ G ]· g)) g ≡ (sucℤ y ℤ[ G ]· g)
  precommℤ G g (pos zero) = lid (snd G) g ∙ sym (rid (snd G) g)
  precommℤ G g (pos (suc n)) =
       sym (assoc (snd G) _ _ _)
     ∙ cong ((snd G · g)) (precommℤ G g (pos n))
  precommℤ G g (negsuc zero) = invl (snd G) g
  precommℤ G g (negsuc (suc n)) =
    sym (assoc (snd G) _ _ _)
    ∙ cong ((snd G · inv (snd G) g)) (precommℤ G g (negsuc n))
    ∙ negsucLem n
    where
    negsucLem : (n : ℕ) → (snd G · inv (snd G) g)
      (sucℤ (negsuc n) ℤ[ G ]· g)
      ≡ (sucℤ (negsuc (suc n)) ℤ[ G ]· g)
    negsucLem zero = (rid (snd G) _)
    negsucLem (suc n) = refl

module _ (G : Group ℓ) (g : fst G) where
  private
    lem : (y : ℤ) → (predℤ y ℤ[ G ]· g)
                   ≡ (snd G · inv (snd G) g) (y ℤ[ G ]· g)
    lem (pos zero) = sym (rid (snd G) _)
    lem (pos (suc n)) =
         sym (lid (snd G) ((pos n ℤ[ G ]· g)))
      ∙∙ cong (λ x → _·_ (snd G) x (pos n ℤ[ G ]· g))
              (sym (invl (snd G) g))
      ∙∙ sym (assoc (snd G) _ _ _)
    lem (negsuc n) = refl

  distrℤ· : (x y : ℤ) → ((x +ℤ y) ℤ[ G ]· g)
           ≡ _·_ (snd G) (x ℤ[ G ]· g) (y ℤ[ G ]· g)
  distrℤ· (pos zero) y = cong (_ℤ[ G ]· g) (+Comm 0 y)
                            ∙ sym (lid (snd G) _)
  distrℤ· (pos (suc n)) (pos n₁) =
      cong (_ℤ[ G ]· g) (sym (pos+ (suc n) n₁))
    ∙ cong (_·_ (snd G) g)
           (cong (_ℤ[ G ]· g) (pos+ n n₁) ∙ distrℤ· (pos n) (pos n₁))
    ∙ assoc (snd G) _ _ _
  distrℤ· (pos (suc n)) (negsuc zero) =
      distrℤ· (pos n) 0
    ∙ ((rid (snd G) (pos n ℤ[ G ]· g) ∙ sym (lid (snd G) (pos n ℤ[ G ]· g)))
    ∙ cong (λ x → _·_ (snd G) x (pos n ℤ[ G ]· g))
           (sym (invl (snd G) g)) ∙ sym (assoc (snd G) _ _ _))
    ∙ (assoc (snd G) _ _ _)
    ∙ cong (λ x → _·_ (snd G)  x (pos n ℤ[ G ]· g)) (invl (snd G) g)
    ∙ lid (snd G) _
    ∙ sym (rid (snd G) _)
    ∙ (cong (_·_ (snd G) (pos n ℤ[ G ]· g)) (sym (invr (snd G) g))
    ∙ assoc (snd G) _ _ _)
    ∙ cong (λ x → _·_ (snd G)  x (inv (snd G) g))
           (precommℤ G g (pos n))
  distrℤ· (pos (suc n)) (negsuc (suc n₁)) =
       cong (_ℤ[ G ]· g) (predℤ+negsuc n₁ (pos (suc n)))
    ∙∙ distrℤ· (pos n) (negsuc n₁)
    ∙∙ (cong (λ x → _·_ (snd G) x (negsuc n₁ ℤ[ G ]· g))
             ((sym (rid (snd G) (pos n ℤ[ G ]· g))
             ∙ cong (_·_ (snd G) (pos n ℤ[ G ]· g)) (sym (invr (snd G) g)))
           ∙∙ assoc (snd G) _ _ _
           ∙∙ cong (λ x → _·_ (snd G) x (inv (snd G) g)) (precommℤ G g (pos n)))
      ∙ sym (assoc (snd G) _ _ _))
  distrℤ· (negsuc zero) y =
      cong (_ℤ[ G ]· g) (+Comm -1 y) ∙ lem y
  distrℤ· (negsuc (suc n)) y =
       cong (_ℤ[ G ]· g) (+Comm (negsuc (suc n)) y)
    ∙∙ lem (y +negsuc n)
    ∙∙ cong (snd G · inv (snd G) g)
            (cong (_ℤ[ G ]· g) (+Comm y (negsuc n)) ∙ distrℤ· (negsuc n) y)
     ∙ (assoc (snd G) _ _ _)

GroupHomℤ→ℤpres- : (e : GroupHom ℤGroup ℤGroup) (a : ℤ)
                  → fst e (- a) ≡ - fst e a
GroupHomℤ→ℤpres- e a =
  cong (fst e) (minus≡0- a) ∙∙ presinv (snd e) a ∙∙ sym (minus≡0- _)

ℤ·≡· : (a b : ℤ) → a * b ≡ (a ℤ[ ℤGroup ]· b)
ℤ·≡· (pos zero) b = refl
ℤ·≡· (pos (suc n)) b = cong (b +ℤ_) (ℤ·≡· (pos n) b)
ℤ·≡· (negsuc zero) b = minus≡0- b
ℤ·≡· (negsuc (suc n)) b = cong₂ _+ℤ_ (minus≡0- b) (ℤ·≡· (negsuc n) b)

GroupHomℤ→ℤPres· : (e : GroupHom ℤGroup ℤGroup) (a b : ℤ)
                  → fst e (a * b) ≡ a * fst e b
GroupHomℤ→ℤPres· e a b =
  cong (fst e) (ℤ·≡· a b) ∙∙ homPresℤ· e b a ∙∙ sym (ℤ·≡· a (fst e b))

-- Generators in terms of ℤ-multiplication
-- Todo : generalise
gen₁-by : (G : Group ℓ) → (g : fst G) → Type _
gen₁-by G g = (h : fst G)
          → Σ[ a ∈ ℤ ] h ≡ (a ℤ[ G ]· g)

gen₂-by : ∀ {ℓ} (G : Group ℓ) → (g₁ g₂ : fst G) → Type _
gen₂-by G g₁ g₂ =
  (h : fst G) → Σ[ a ∈ ℤ × ℤ ] h ≡ _·_ (snd G) ((fst a) ℤ[ G ]· g₁) ((snd a) ℤ[ G ]· g₂)

Iso-pres-gen₁ : ∀ {ℓ ℓ'} (G : Group ℓ) (H : Group ℓ') (g : fst G)
  → gen₁-by G g → (e : GroupIso G H)
  → gen₁-by H (Iso.fun (fst e) g)
Iso-pres-gen₁ G H g genG is h =
    (fst (genG (Iso.inv (fst is) h)))
  , (sym (Iso.rightInv (fst is) h)
    ∙∙ cong (Iso.fun (fst is)) (snd (genG (Iso.inv (fst is) h)))
    ∙∙ (homPresℤ· (_ , snd is) g (fst (genG (Iso.inv (fst is) h)))))

Iso-pres-gen₂ : (G : Group ℓ) (H : Group ℓ') (g₁ g₂ : fst G)
  → gen₂-by G g₁ g₂ → (e : GroupIso G H)
  → gen₂-by H (Iso.fun (fst e) g₁) (Iso.fun (fst e) g₂)
fst (Iso-pres-gen₂ G H g₁ g₂ genG is h) = genG (Iso.inv (fst is) h) .fst
snd (Iso-pres-gen₂ G H g₁ g₂ genG is h) =
     sym (Iso.rightInv (fst is) h)
  ∙∙ cong (fun (fst is)) (snd (genG (Iso.inv (fst is) h)))
  ∙∙ (pres· (snd is) _ _
  ∙ cong₂ (_·_ (snd H))
          (homPresℤ· (_ , snd is) g₁ (fst (fst (genG (inv (fst is) h)))))
          (homPresℤ· (_ , snd is) g₂ (snd (fst (genG (inv (fst is) h))))))

private
  intLem₁ : (n m : ℕ) → Σ[ a ∈ ℕ ] (negsuc n * pos (suc m)) ≡ negsuc a
  intLem₁ n zero = n , ·Comm  (negsuc n) (pos 1)
  intLem₁ n (suc m) = lem _ _ .fst ,
       (·Comm (negsuc n) (pos (suc (suc m)))
    ∙∙ cong (negsuc n +ℤ_) (·Comm (pos (suc m)) (negsuc n) ∙ (intLem₁ n m .snd))
    ∙∙ lem _ _ .snd)
    where
    lem : (x y : ℕ) → Σ[ a ∈ ℕ ] negsuc x +ℤ negsuc y ≡ negsuc a
    lem zero zero = 1 , refl
    lem zero (suc y) = (suc (suc y)) , +Comm (negsuc zero) (negsuc (suc y))
    lem (suc x) zero = (suc (suc x)) , refl
    lem (suc x) (suc y) =
       (lem (suc (suc x)) y .fst)
     , (predℤ+negsuc y (negsuc (suc x)) ∙ snd ((lem (suc (suc x))) y))

  intLem₂ : (n x : ℕ)
    → Σ[ a ∈ ℕ ] ((pos (suc x)) * pos (suc (suc n)) ≡ pos (suc (suc a)))
  intLem₂ n zero = n , refl
  intLem₂ n (suc x) = lem _ _ (intLem₂ n x)
    where
    lem : (x : ℤ) (n : ℕ) → Σ[ a ∈ ℕ ] (x ≡ pos (suc (suc a)))
                  → Σ[ a ∈ ℕ ] pos n +ℤ x ≡ pos (suc (suc a))
    lem x n (a , p) = n +ℕ a
      , cong (pos n +ℤ_) p ∙ cong sucℤ (sucℤ+pos a (pos n))
         ∙ sucℤ+pos a (pos (suc n)) ∙ (sym (pos+ (suc (suc n)) a))

  ¬1=x·suc-suc : (n : ℕ) (x : ℤ) → ¬ pos 1 ≡ x * pos (suc (suc n))
  ¬1=x·suc-suc n (pos zero) p = snotz (injPos p)
  ¬1=x·suc-suc n (pos (suc n₁)) p =
    snotz (injPos (sym (cong predℤ (snd (intLem₂ n n₁))) ∙ sym (cong predℤ p)))
  ¬1=x·suc-suc n (negsuc n₁) p = posNotnegsuc _ _ (p ∙ intLem₁ _ _ .snd)

GroupEquivℤ-pres1 : (e : GroupEquiv ℤGroup ℤGroup) (x : ℤ)
  → (fst (fst e) 1) ≡ x → abs (fst (fst e) 1) ≡ 1
GroupEquivℤ-pres1 e (pos zero) p =
  ⊥-rec (snotz (injPos (sym (retEq (fst e) 1)
            ∙∙ (cong (fst (fst (invGroupEquiv e))) p)
            ∙∙ IsGroupHom.pres1 (snd (invGroupEquiv e)))))
GroupEquivℤ-pres1 e (pos (suc zero)) p = cong abs p
GroupEquivℤ-pres1 e (pos (suc (suc n))) p =
  ⊥-rec (¬1=x·suc-suc _ _ (h3 ∙ ·Comm (pos (suc (suc n))) (invEq (fst e) 1)))
  where
  h3 : pos 1 ≡ _
  h3 = sym (retEq (fst e) 1)
    ∙∙ cong (fst (fst (invGroupEquiv e)))
            (p ∙ ·Comm 1 (pos (suc (suc n))))
    ∙∙ GroupHomℤ→ℤPres· (_ , snd (invGroupEquiv e)) (pos (suc (suc n))) 1
GroupEquivℤ-pres1 e (negsuc zero) p = cong abs p
GroupEquivℤ-pres1 e (negsuc (suc n)) p = ⊥-rec (¬1=x·suc-suc _ _ lem₂)
  where
  lem₁ : fst (fst e) (negsuc zero) ≡ pos (suc (suc n))
  lem₁ = GroupHomℤ→ℤpres- (_ , snd e) (pos 1) ∙ cong -_ p

  compGroup : GroupEquiv ℤGroup ℤGroup
  fst compGroup = isoToEquiv (iso -_ -_ -Involutive -Involutive)
  snd compGroup = makeIsGroupHom -Dist+

  compHom : GroupEquiv ℤGroup ℤGroup
  compHom = compGroupEquiv compGroup e

  lem₂ : pos 1 ≡ invEq (fst compHom) (pos 1) * pos (suc (suc n))
  lem₂ = sym (retEq (fst compHom) (pos 1))
     ∙∙ cong (invEq (fst compHom)) lem₁
     ∙∙ (cong (invEq (fst compHom)) (·Comm (pos 1) (pos (suc (suc n))))
       ∙ GroupHomℤ→ℤPres· (_ , (snd (invGroupEquiv compHom)))
                           (pos (suc (suc n))) (pos 1)
       ∙ ·Comm (pos (suc (suc n))) (invEq (fst compHom) (pos 1)))

groupEquivPresGen : ∀ {ℓ} (G : Group ℓ) (ϕ : GroupEquiv G ℤGroup) (x : fst G)
              → (fst (fst ϕ) x ≡ 1) ⊎ (fst (fst ϕ) x ≡ - 1)
              → (ψ : GroupEquiv G ℤGroup)
              → (fst (fst ψ) x ≡ 1) ⊎ (fst (fst ψ) x ≡ - 1)
groupEquivPresGen G (ϕeq , ϕhom) x (inl r) (ψeq , ψhom) =
     abs→⊎ _ _ (cong abs (cong (fst ψeq) (sym (retEq ϕeq x)
               ∙ cong (invEq ϕeq) r))
   ∙ GroupEquivℤ-pres1 (compGroupEquiv
                         (invGroupEquiv (ϕeq , ϕhom)) (ψeq , ψhom)) _ refl)
groupEquivPresGen G (ϕeq , ϕhom) x (inr r) (ψeq , ψhom) =
  abs→⊎ _ _
    (cong abs (cong (fst ψeq) (sym (retEq ϕeq x) ∙ cong (invEq ϕeq) r))
    ∙ cong abs (IsGroupHom.presinv
                (snd (compGroupEquiv (invGroupEquiv (ϕeq , ϕhom))
                       (ψeq , ψhom))) 1)
    ∙ absLem _ (GroupEquivℤ-pres1
                (compGroupEquiv (invGroupEquiv (ϕeq , ϕhom)) (ψeq , ψhom))
                 _ refl))
  where
  absLem : ∀ x → abs x ≡ 1 → abs (pos 0 -ℤ x) ≡ 1
  absLem (pos zero) p = ⊥-rec (snotz (sym p))
  absLem (pos (suc zero)) p = refl
  absLem (pos (suc (suc n))) p = ⊥-rec (snotz (cong predℕ p))
  absLem (negsuc zero) p = refl
  absLem (negsuc (suc n)) p = ⊥-rec (snotz (cong predℕ p))

gen₂ℤ×ℤ : gen₂-by (DirProd ℤGroup ℤGroup) (1 , 0) (0 , 1)
fst (gen₂ℤ×ℤ (x , y)) = x , y
snd (gen₂ℤ×ℤ (x , y)) =
  ΣPathP ((cong₂ _+ℤ_ ((·Comm 1 x) ∙ cong fst (sym (distrLem 1 0 x)))
                     ((·Comm 0 y) ∙ cong fst (sym (distrLem 0 1 y))))
        , +Comm y 0
         ∙ cong₂ _+ℤ_ (·Comm 0 x ∙ cong snd (sym (distrLem 1 0 x)))
                     (·Comm 1 y ∙ cong snd (sym (distrLem 0 1 y))))
  where
  ℤ×ℤ = DirProd ℤGroup ℤGroup
  _+''_ = GroupStr._·_ (snd ℤ×ℤ)

  -lem : (x : ℤ) → - x ≡ 0 -ℤ x
  -lem (pos zero) = refl
  -lem (pos (suc zero)) = refl
  -lem (pos (suc (suc n))) =
    cong predℤ (-lem (pos (suc n)))
  -lem (negsuc zero) = refl
  -lem (negsuc (suc n)) = cong sucℤ (-lem (negsuc n))

  distrLem : (x y : ℤ) (z : ℤ)
         → Path (ℤ × ℤ) (z ℤ[ ℤ×ℤ ]· (x , y)) (z * x , z * y)
  distrLem x y (pos zero) = refl
  distrLem x y (pos (suc n)) =
    (cong ((x , y) +''_) (distrLem x y (pos n)))
  distrLem x y (negsuc zero) = ΣPathP (sym (-lem x) , sym (-lem y))
  distrLem x y (negsuc (suc n)) =
    cong₂ _+''_ (ΣPathP (sym (-lem x) , sym (-lem y)))
                (distrLem x y (negsuc n))


-- Quotients of additive categories
{-# OPTIONS --safe #-}

module Cubical.Categories.Additive.Quotient where

open import Cubical.Algebra.AbGroup.Base
open import Cubical.Categories.Additive.Base
open import Cubical.Categories.Additive.Properties
open import Cubical.Categories.Category.Base
open import Cubical.Categories.Constructions.Quotient
open import Cubical.Categories.Limits.Terminal
open import Cubical.Foundations.Prelude
open import Cubical.HITs.SetQuotients renaming ([_] to ⟦_⟧)

private
  variable
    ℓ ℓ' ℓq : Level

-- Quotients of preadditive categories
module _ (C : PreaddCategory ℓ ℓ') where
  open PreaddCategory C
  open PreaddCategoryTheory C

  module _ (_~_ : {x y : ob} (f g : Hom[ x , y ] ) → Type ℓq)
           (~refl : {x y : ob} (f : Hom[ x , y ] ) → f ~ f)
           (~cong⋆ : {x y z : ob}
                     (f f' : Hom[ x , y ]) → f ~ f'
                   → (g g' : Hom[ y , z ]) → g ~ g'
                   → (f ⋆ g) ~ (f' ⋆ g'))
           (~cong+ : {x y : ob} (f f' g g' : Hom[ x , y ])
                   → f ~ f' → g ~ g' → (f + g) ~ (f' + g'))
           (~cong- : {x y : ob} (f f' : Hom[ x , y ])
                   → f ~ f' → (- f) ~ (- f'))           where

    private
      C/~ = QuotientCategory cat _~_ ~refl ~cong⋆
      Hom[_,_]/~ = λ (x y : ob) → (Hom[ x , y ]) / _~_
      _⋆/~_ = C/~ .Category._⋆_

      _+/~_ : {x y : ob} (f g : Hom[ x , y ]/~) → Hom[ x , y ]/~
      _+/~_ = setQuotBinOp ~refl ~refl _+_ ~cong+

    -- Quotient group structure on homsets
    private
      open AbGroupStr renaming (_+_ to add; -_ to inv)
      homAbStr/~ : (x y : ob) → AbGroupStr Hom[ x , y ]/~
      homAbStr/~ x y .0g        = ⟦ 0h ⟧
      homAbStr/~ x y .add       = _+/~_
      homAbStr/~ x y .inv       = (setQuotUnaryOp -_ ~cong-)
      homAbStr/~ x y .isAbGroup = makeIsAbGroup squash/
          (elimProp3 (λ _ _ _ → squash/ _ _)  λ _ _ _ → cong ⟦_⟧ (+assoc _ _ _))
          (elimProp  (λ _     → squash/ _ _)  λ _     → cong ⟦_⟧ (+idr _))
          (elimProp  (λ _     → squash/ _ _)  λ _     → cong ⟦_⟧ (+invr _))
          (elimProp2 (λ _ _   → squash/ _ _)  λ _ _   → cong ⟦_⟧ (+comm _ _))

    -- Distributivity
    ⋆distl+/~ : {x y z : ob} → (f : Hom[ x , y ]/~) → (g g' : Hom[ y , z ]/~) →
        f  ⋆/~  (g  +/~  g')  ≡  (f  ⋆/~  g)  +/~  (f  ⋆/~  g')
    ⋆distl+/~ = elimProp3 (λ _ _ _ → squash/ _ _) λ _ _ _ → cong ⟦_⟧ (⋆distl+ _ _ _)

    ⋆distr+/~ : {x y z : ob} → (f f' : Hom[ x , y ]/~) → (g : Hom[ y , z ]/~) →
        (f  +/~  f')  ⋆/~  g  ≡  (f  ⋆/~  g)  +/~  (f'  ⋆/~  g)
    ⋆distr+/~ = elimProp3 (λ _ _ _ → squash/ _ _) λ _ _ _ → cong ⟦_⟧ (⋆distr+ _ _ _)

    -- Quotient of preadditive category
    open PreaddCategory
    open PreaddCategoryStr
    PreaddQuotient : PreaddCategory ℓ (ℓ-max ℓ' ℓq)
    PreaddQuotient .cat = QuotientCategory (cat C) _~_ ~refl ~cong⋆
    PreaddQuotient .preadd .homAbStr = homAbStr/~
    PreaddQuotient .preadd .⋆distl+ = ⋆distl+/~
    PreaddQuotient .preadd .⋆distr+ = ⋆distr+/~

-- Quotients of additive categories
module _ (A : AdditiveCategory ℓ ℓ') where
  open AdditiveCategory A

  module _ (_~_ : {x y : ob} (f g : Hom[ x , y ] ) → Type ℓq)
           (~refl : {x y : ob} (f : Hom[ x , y ] ) → f ~ f)
           (~cong⋆ : {x y z : ob}
                     (f f' : Hom[ x , y ]) → f ~ f'
                   → (g g' : Hom[ y , z ]) → g ~ g'
                   → (f ⋆ g) ~ (f' ⋆ g'))
           (~cong+ : {x y : ob} (f f' g g' : Hom[ x , y ])
                   → f ~ f' → g ~ g' → (f + g) ~ (f' + g'))
           (~cong- : {x y : ob} (f f' : Hom[ x , y ])
                   → f ~ f' → (- f) ~ (- f'))           where

    private
      A/~ = PreaddQuotient preaddcat _~_ ~refl ~cong⋆ ~cong+ ~cong-

    -- Zero object
    open ZeroObject
    zero/~ : ZeroObject A/~
    zero/~ .z = zero .z
    zero/~ .zInit = isInitial/~ cat _~_ ~refl ~cong⋆ (zInit zero)
    zero/~ .zTerm = isTerminal/~ cat _~_ ~refl ~cong⋆ (zTerm zero)

    -- Biproducts
    module _ (x y : ob) where
      open Biproduct
      open IsBiproduct

      biprod/~ : Biproduct A/~ x y
      biprod/~ .x⊕y = x ⊕ y
      biprod/~ .i₁ = ⟦ i₁ (biprod x y) ⟧
      biprod/~ .i₂ = ⟦ i₂ (biprod x y) ⟧
      biprod/~ .π₁ = ⟦ π₁ (biprod x y) ⟧
      biprod/~ .π₂ = ⟦ π₂ (biprod x y) ⟧
      biprod/~ .isBipr .i₁⋆π₁ = cong ⟦_⟧ (i₁⋆π₁ (biprod x y))
      biprod/~ .isBipr .i₁⋆π₂ = cong ⟦_⟧ (i₁⋆π₂ (biprod x y))
      biprod/~ .isBipr .i₂⋆π₁ = cong ⟦_⟧ (i₂⋆π₁ (biprod x y))
      biprod/~ .isBipr .i₂⋆π₂ = cong ⟦_⟧ (i₂⋆π₂ (biprod x y))
      biprod/~ .isBipr .∑π⋆i  = cong ⟦_⟧ (∑π⋆i  (biprod x y))

    open AdditiveCategoryStr
    AdditiveQuotient : AdditiveCategory ℓ (ℓ-max ℓ' ℓq)
    AdditiveQuotient .preaddcat = A/~
    AdditiveQuotient .addit .zero = zero/~
    AdditiveQuotient .addit .biprod = biprod/~