module Structure.Setoid.Category.HomFunctor where

import      Functional as Fn
open import Function.Equals
open import Function.Equals.Proofs
open import Logic.Predicate
import      Lvl
open import Structure.Category
open import Structure.Category.Dual
open import Structure.Category.Functor.Contravariant
open import Structure.Category.Functor
open import Structure.Categorical.Properties
open import Structure.Function
open import Structure.Operator
open import Structure.Relator.Equivalence
open import Structure.Setoid
open import Syntax.Function
open import Syntax.Transitivity
open import Structure.Setoid.Category
open import Type

private variable ℓ ℓₒ ℓₘ ℓₑ : Lvl.Level

module _ (C : CategoryObject{ℓₒ}{ℓₘ}{ℓₑ}) where
  open CategoryObject(C)
  open Category ⦃ … ⦄
  open ArrowNotation
  private open module MorphismEquiv {x}{y} = Equivalence (Equiv-equivalence ⦃ morphism-equiv{x}{y} ⦄) using ()

  covariantHomFunctor : Object → (C →ᶠᵘⁿᶜᵗᵒʳ setoidCategoryObject)
  ∃.witness (covariantHomFunctor x) y = [∃]-intro (x ⟶ y)
  Functor.map (∃.proof (covariantHomFunctor _)) f = [∃]-intro (f ∘_) ⦃ BinaryOperator.right binaryOperator ⦄
  _⊜_.proof (Function.congruence (Functor.map-function (∃.proof (covariantHomFunctor _))) {f₁} {f₂} f₁f₂) {g} =
    f₁ ∘ g 🝖-[ congruence₂ₗ(_∘_) g f₁f₂ ]
    f₂ ∘ g 🝖-end
  _⊜_.proof (Functor.op-preserving (∃.proof (covariantHomFunctor _)) {f = f} {g = g}) {h} =
    (f ∘ g) ∘ h            🝖[ _≡_ ]-[ Morphism.associativity(_∘_) ]
    f ∘ (g ∘ h)            🝖[ _≡_ ]-[]
    ((f ∘_) Fn.∘ (g ∘_)) h 🝖-end
  _⊜_.proof (Functor.id-preserving (∃.proof (covariantHomFunctor _))) {f} =
    id ∘ f   🝖[ _≡_ ]-[ Morphism.identityₗ(_∘_)(id) ]
    f        🝖[ _≡_ ]-[]
    Fn.id(f) 🝖-end

  contravariantHomFunctor : Object → (C →ᶜᵒⁿᵗʳᵃᵛᵃʳⁱᵃⁿᵗᶠᵘⁿᶜᵗᵒʳ setoidCategoryObject)
  ∃.witness (contravariantHomFunctor x) y = [∃]-intro (y ⟶ x)
  Functor.map (∃.proof (contravariantHomFunctor _)) f = [∃]-intro (_∘ f) ⦃ BinaryOperator.left binaryOperator ⦄
  _⊜_.proof (Function.congruence (Functor.map-function (∃.proof (contravariantHomFunctor _))) {g₁} {g₂} g₁g₂) {f} =
    f ∘ g₁ 🝖-[ congruence₂ᵣ(_∘_) f g₁g₂ ]
    f ∘ g₂ 🝖-end
  _⊜_.proof (Functor.op-preserving (∃.proof (contravariantHomFunctor _)) {f = h} {g = g}) {f} =
    f ∘ (g ∘ h)            🝖[ _≡_ ]-[ Morphism.associativity(_∘_) ]-sym
    (f ∘ g) ∘ h            🝖[ _≡_ ]-[]
    ((_∘ h) Fn.∘ (_∘ g)) f 🝖-end
  _⊜_.proof (Functor.id-preserving (∃.proof (contravariantHomFunctor _))) {f} =
    f ∘ id   🝖[ _≡_ ]-[ Morphism.identityᵣ(_∘_)(id) ]
    f        🝖[ _≡_ ]-[]
    Fn.id(f) 🝖-end


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

open import HoTT

module homotopy.PushoutComm where

-- How do I prevent [to] from being exported?
private
 module _ {i j k} (s : Span {i} {j} {k}) where

  open Span s

  flip : Span
  flip = span B A C g f

  to : Pushout s → Pushout flip
  to = To.f  module M where

    module To = PushoutRec right left (λ (c : C) → ! (glue c))

  open M public

private
 module _ {i j k} (s : Span {i} {j} {k}) where

  to-to-flip : (x : Pushout (flip s)) → to s (to (flip s) x) == x
  to-to-flip = Pushout-elim (λ _ → idp) (λ _ → idp)
    (λ c → ↓-∘=idf-in (to s) (to (flip s))
      (ap (to s) (ap (to (flip s)) (glue c))   =⟨ To.glue-β (flip s) c |in-ctx ap (to s) ⟩
       ap (to s) (! (glue c))                  =⟨ ap-! (to s) (glue c) ⟩
       ! (ap (to s) (glue c))                  =⟨ To.glue-β s c |in-ctx ! ⟩
       ! (! (glue c))                          =⟨ !-! (glue c) ⟩
       glue c ∎))

module _ {i j k} (s : Span {i} {j} {k}) where

  Pushout-comm : Pushout s ≃ Pushout (flip s)
  Pushout-comm = equiv (to s) (to (flip s)) (to-to-flip s) (to-to-flip (flip s))


{-# OPTIONS --without-K #-}
open import HoTT.Base
open import HoTT.Identity
open import HoTT.Equivalence

module HoTT.Identity.Sigma where

open variables

_=Σ_ : Σ A P → Σ A P → 𝒰 _
_=Σ_ {P = P} x y = Σ[ p ∶ x₁ == y₁ ] transport P p x₂ == y₂
  where
  open Σ x renaming (pr₁ to x₁ ; pr₂ to x₂)
  open Σ y renaming (pr₁ to y₁ ; pr₂ to y₂)

pair⁼' : {x y : Σ A P} → Σ[ p ∶ pr₁ x == pr₁ y ] pr₂ x == transport P (p ⁻¹) (pr₂ y) → x == y
pair⁼' {x = _ , _} {y = _ , _} (refl , refl) = refl

=Σ-equiv : {x y : Σ A P} → (x == y) ≃ x =Σ y
=Σ-equiv {x = _ , _} {y = _ , _} = let open Iso in iso→eqv λ where
  .f refl → (refl , refl)
  .g (refl , refl) → refl
  .η refl → refl
  .ε (refl , refl) → refl

pair⁼ : {x y : Σ A P} → x =Σ y → x == y
pair⁼ = Iso.g (eqv→iso =Σ-equiv)


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

-- https://personal.cis.strath.ac.uk/conor.mcbride/pub/DepRep/DepRep.pdf

module Experiment.Outrageous.#02 where

data Zero : Set where
magic : Zero → (X : Set) → X
magic ()
record 𝟏 : Set where
  constructor void
data 𝟐 : Set where
  tt : 𝟐
  ff : 𝟐
If : 𝟐 → Set → Set → Set
If tt T F = T
If ff T F = F
if : (b : 𝟐) → (P : 𝟐 → Set) → P tt → P ff → P b
if tt P t f = t
if ff P t f = f
data ℕ : Set where
  ze : ℕ
  su : ℕ → ℕ
rec : (n : ℕ) → (P : ℕ → Set) → P ze → ((n : ℕ) → P n → P (su n)) → P n
rec ze     P z s = z
rec (su n) P z s = s n (rec n P z s)
record Σ (S : Set) (T : S → Set) : Set where
  constructor _,_
  field
    fst : S
    snd : T fst


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

-- The category build from ObjectRestriction can be done so Functorially

module Categories.Functor.Construction.ObjectRestriction where

open import Level
open import Data.Product using (proj₁)
open import Relation.Unary using (Pred)
open import Function using () renaming (id to id→)

open import Categories.Category.Core
open import Categories.Category.Construction.ObjectRestriction
open import Categories.Functor.Core
open import Categories.Functor.Properties using (Faithful; Full)

private
  variable
    o ℓ e ℓ′ : Level
    C : Category o ℓ e

RestrictionFunctor : {ℓ′ : Level} → (C : Category o ℓ e) → (E : Pred (Category.Obj C) ℓ′) → Functor (ObjectRestriction C E) C
RestrictionFunctor C E = record
  { F₀ = proj₁
  ; F₁ = id→
  ; identity = Equiv.refl
  ; homomorphism = Equiv.refl
  ; F-resp-≈ = id→
  }
  where
  open Category C

RF-Faithful : {E : Pred (Category.Obj C) ℓ′} → Faithful (RestrictionFunctor C E)
RF-Faithful _ _ = id→

RF-Full : {E : Pred (Category.Obj C) ℓ′} → Full (RestrictionFunctor C E)
RF-Full {C = C} = record
  { from = record
    { _⟨$⟩_ = id→
    ; cong = id→
    }
  ; right-inverse-of = λ _ → Category.Equiv.refl C
  }


{-# OPTIONS --prop #-}

open import Agda.Primitive

record LiftP {ℓ ℓ'}(A : Prop ℓ) : Prop (ℓ ⊔ ℓ') where
  constructor liftP
  field
    unliftP : A
open LiftP public

unliftP' : {ℓ ℓ' ℓ'' : Level} {A : Prop ℓ}{B : Set ℓ''}(f : A → B) → LiftP {ℓ}{ℓ'} A → B
unliftP' f (liftP x) = f x


open import Formalization.PredicateLogic.Signature

module Formalization.PredicateLogic.Syntax.NegativeTranslations (𝔏 : Signature) where
open Signature(𝔏)

open import Data.ListSized
import      Lvl
open import Formalization.PredicateLogic.Syntax (𝔏)
open import Functional using (_∘_ ; _∘₂_ ; swap)
open import Numeral.Finite
open import Numeral.Natural
open import Sets.PredicateSet using (PredSet)
open import Type

private variable ℓ : Lvl.Level
private variable args vars : ℕ

-- Also called: Gödel-Gentzen's negative translation.
-- 2.3.3
ggTrans : Formula(vars) → Formula(vars)
ggTrans (P $ x) = ¬¬(P $ x)
ggTrans ⊤       = ⊤
ggTrans ⊥       = ⊥
ggTrans (φ ∧ ψ) = (ggTrans φ) ∧ (ggTrans ψ)
ggTrans (φ ∨ ψ) = ¬(¬(ggTrans φ) ∧ ¬(ggTrans ψ))
ggTrans (φ ⟶ ψ) = (ggTrans φ) ⟶ (ggTrans ψ)
ggTrans (Ɐ φ)   = Ɐ(ggTrans φ)
ggTrans (∃ φ)   = ¬ Ɐ(¬(ggTrans φ))

-- Also called: Kolmogorov's negative translation.
-- 2.3.7A
koTrans : Formula(vars) → Formula(vars)
koTrans (P $ x) = ¬¬(P $ x)
koTrans ⊤       = ⊤
koTrans ⊥       = ⊥
koTrans (φ ∧ ψ) = ¬¬((koTrans φ) ∧ (koTrans ψ))
koTrans (φ ∨ ψ) = ¬¬((koTrans φ) ∨ (koTrans ψ))
koTrans (φ ⟶ ψ) = ¬¬((koTrans φ) ⟶ (koTrans ψ))
koTrans (Ɐ φ)   = ¬¬ Ɐ(koTrans φ)
koTrans (∃ φ)   = ¬¬ ∃(koTrans φ)

-- Also called: Kuroda's negative translation.
-- 2.3.7B
kuTrans : Formula(vars) → Formula(vars)
kuTrans (P $ x) = P $ x
kuTrans ⊤       = ⊤
kuTrans ⊥       = ⊥
kuTrans (φ ∧ ψ) = ((koTrans φ) ∧ (koTrans ψ))
kuTrans (φ ∨ ψ) = ((koTrans φ) ∨ (koTrans ψ))
kuTrans (φ ⟶ ψ) = ((koTrans φ) ⟶ (koTrans ψ))
kuTrans (Ɐ φ)   = Ɐ(¬¬(koTrans φ))
kuTrans (∃ φ)   = ∃(koTrans φ)


open import Type

module Graph.Walk.Proofs {ℓ₁ ℓ₂} {V : Type{ℓ₁}} where

open import Lang.Instance
open import Logic
import      Lvl
open import Graph{ℓ₁}{ℓ₂}(V)
open import Graph.Walk{ℓ₁}{ℓ₂}{V}
open import Relator.Equals.Proofs.Equiv
import      Structure.Relator.Names as Names
open import Structure.Relator.Properties
open import Type.Properties.Singleton

private variable ℓ : Lvl.Level
private variable _⟶_ : Graph
private variable a b : V
private variable _▫_ : V → V → Type{ℓ}

-- There is a walk between two vertices when there is one edge between them.
instance
  Walk-super : (_⟶_) ⊆₂ (Walk(_⟶_))
  _⊆₂_.proof Walk-super p = prepend p at

-- Walk is a "smallest" reflexive-transitive closure
Walk-sub : ⦃ _ : Reflexivity(_▫_) ⦄ → ⦃ _ : Transitivity(_▫_) ⦄ → ⦃ _ : (_⟶_) ⊆₂ (_▫_) ⦄ → (Walk(_⟶_)) ⊆₂ (_▫_)
Walk-sub {_▫_ = _▫_}{_⟶_ = _⟶_} = intro proof where
  proof : Names.Subrelation(Walk(_⟶_))(_▫_)
  proof at                    = transitivity(_▫_) (reflexivity(_▫_)) (reflexivity(_▫_))
  proof (prepend ab1 walkb1b) = transitivity(_▫_) (sub₂(_⟶_)(_▫_) ab1) (proof walkb1b)

Walk-transitivity-raw : Names.Transitivity(Walk(_⟶_))
Walk-transitivity-raw at              xz = xz
Walk-transitivity-raw (prepend xb by) yz = prepend xb (Walk-transitivity-raw by yz)

instance
  -- A walk can be joined/concatenated to form a new walk.
  Walk-transitivity : Transitivity(Walk(_⟶_))
  Transitivity.proof Walk-transitivity = Walk-transitivity-raw

instance
  Walk-reflexivity : Reflexivity(Walk(_⟶_))
  Walk-reflexivity = intro at


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

open import HoTT
open import homotopy.DisjointlyPointedSet

module groups.DisjointlyPointedSet where

  diff-and-separate : ∀ {i j} {X : Ptd i} (G : Group j)
    → (de⊙ X → Group.El G) → Group.El G × (MinusPoint X → Group.El G)
  diff-and-separate {X = X} G f =
    f (pt X) , λ x- → Group.diff G (f (fst x-)) (f (pt X))

  shift-and-unite : ∀ {i j} {X : Ptd i} (G : Group j)
    → is-separable X
    → Group.El G × (MinusPoint X → Group.El G) → (de⊙ X → Group.El G)
  shift-and-unite {X = X} G X-sep p x with X-sep x
  ... | inl _ = fst p
  ... | inr pt≠x = Group.comp G (snd p (x , pt≠x)) (fst p)

  diff-and-separate-hom : ∀ {i j} {X : Ptd i} (G : AbGroup j)
    →  Πᴳ (de⊙ X) (λ _ → AbGroup.grp G)
    →ᴳ AbGroup.grp G ×ᴳ Πᴳ (MinusPoint X) (λ _ → AbGroup.grp G)
  diff-and-separate-hom {X = X} G = group-hom (diff-and-separate grp) lemma where
    open AbGroup G
    abstract
      lemma : preserves-comp
                (Group.comp (Πᴳ (de⊙ X) (λ _ → AbGroup.grp G)))
                (Group.comp (AbGroup.grp G ×ᴳ Πᴳ (MinusPoint X) (λ _ → AbGroup.grp G)))
                (diff-and-separate grp)
      lemma f₀ f₁ = pair×= idp
        (λ= λ x- → diff-comp (f₀ (fst x-)) (f₁ (fst x-)) (f₀ (pt X)) (f₁ (pt X)))

  diff-and-separate-is-equiv : ∀ {i j} {X : Ptd i} (G : Group j)
    → is-separable X → is-equiv (diff-and-separate {X = X} G)
  diff-and-separate-is-equiv {X = X} G X-sep = is-eq to from to-from (λ= ∘ from-to)
    where
      open Group G
      to = diff-and-separate {X = X} G
      from = shift-and-unite {X = X} G X-sep

      abstract
        fst-to-from : ∀ p → fst (to (from p)) == fst p
        fst-to-from _ with X-sep (pt X)
        ... | inl _ = idp
        ... | inr pt≠pt = ⊥-rec (pt≠pt idp)

        snd-to-from : ∀ p x → snd (to (from p)) x == snd p x
        snd-to-from p x with X-sep (fst x)
        ... | inl pt=x = ⊥-rec (snd x pt=x)
        ... | inr pt≠x with X-sep (pt X)
        ...   | inl _ = assoc (snd p (fst x , pt≠x)) (fst p) (inv (fst p))
                      ∙ ap (comp (snd p (fst x , pt≠x))) (inv-r (fst p))
                      ∙ unit-r (snd p (fst x , pt≠x))
                      ∙ ap (λ neq → snd p (fst x , neq)) (prop-has-all-paths _ _)
        ...   | inr pt≠pt = ⊥-rec (pt≠pt idp)

        to-from : ∀ p → to (from p) == p
        to-from p = pair×= (fst-to-from p) (λ= (snd-to-from p))

        from-to : ∀ f x → from (to f) x == f x
        from-to f x with X-sep x
        ... | inl idp = idp
        ... | inr _ = assoc (f x) (inv (f (pt X))) (f (pt X))
                    ∙ ap (comp (f x)) (inv-l (f (pt X)))
                    ∙ unit-r (f x)

  diff-and-separate-iso : ∀ {i j} {X : Ptd i} (G : AbGroup j)
    → is-separable X
    →  Πᴳ (de⊙ X) (λ _ → AbGroup.grp G)
    ≃ᴳ AbGroup.grp G ×ᴳ Πᴳ (MinusPoint X) (λ _ → AbGroup.grp G)
  diff-and-separate-iso G X-sep =
    diff-and-separate-hom G , diff-and-separate-is-equiv (AbGroup.grp G) X-sep


{-# OPTIONS --allow-unsolved-metas #-}

module _ where

open import Agda.Primitive using (Level)

variable
 l : Level

postulate
  Σ : {l' : Level}{X : Set} (Y : X → Set l') -> Set
  _,_ : {l' : Level}{X : Set} {Y : X → Set l'} -> (x : X)(y : Y x) -> Σ Y
  is-universal-element : {l' : Level}{X : Set} {A : X → Set l'} -> Σ A → Set

  universality-section : {X : Set} {A : X → Set l}  -> (x : X) (a : A x)
                          → is-universal-element {X = X} (x , a)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Union of two binary relations
------------------------------------------------------------------------

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

module Relation.Binary.Construct.Union where

open import Data.Product
open import Data.Sum
open import Function using (_∘_)
open import Level using (_⊔_)
open import Relation.Binary
open import Relation.Nullary using (yes; no)

------------------------------------------------------------------------
-- Definition

_∪_ : ∀ {a b ℓ₁ ℓ₂} {A : Set a} {B : Set b} →
      REL A B ℓ₁ → REL A B ℓ₂ → REL A B (ℓ₁ ⊔ ℓ₂)
L ∪ R = λ i j → L i j ⊎ R i j

------------------------------------------------------------------------
-- Properties

module _ {a ℓ} {A : Set a} (L : Rel A ℓ) (R : Rel A ℓ) where

  reflexive : Reflexive L ⊎ Reflexive R → Reflexive (L ∪ R)
  reflexive (inj₁ L-refl) = inj₁ L-refl
  reflexive (inj₂ R-refl) = inj₂ R-refl

  total : Total L ⊎ Total R → Total (L ∪ R)
  total (inj₁ L-total) x y = [ inj₁ ∘ inj₁ , inj₂ ∘ inj₁ ] (L-total x y)
  total (inj₂ R-total) x y = [ inj₁ ∘ inj₂ , inj₂ ∘ inj₂ ] (R-total x y)

  min : ∀ {⊤} → Minimum L ⊤ ⊎ Minimum R ⊤ → Minimum (L ∪ R) ⊤
  min = [ inj₁ ∘_ , inj₂ ∘_ ]

  max : ∀ {⊥} → Maximum L ⊥ ⊎ Maximum R ⊥ → Maximum (L ∪ R) ⊥
  max = [ inj₁ ∘_ , inj₂ ∘_ ]

module _ {a ℓ} {A : Set a} {L : Rel A ℓ} {R : Rel A ℓ} where

  symmetric : Symmetric L → Symmetric R → Symmetric (L ∪ R)
  symmetric L-sym R-sym = [ inj₁ ∘ L-sym , inj₂ ∘ R-sym ]

  respects : ∀ {p} {P : A → Set p} →
             P Respects L → P Respects R → P Respects (L ∪ R)
  respects resp-L resp-R = [ resp-L , resp-R ]

module _ {a b ℓ₁ ℓ₂ ℓ₃} {A : Set a} {B : Set b}
         (≈ : REL A B ℓ₁) (L : REL A B ℓ₂) (R : REL A B ℓ₃) where

  implies : (≈ ⇒ L) ⊎ (≈ ⇒ R) → ≈ ⇒ (L ∪ R)
  implies = [ inj₁ ∘_ , inj₂ ∘_ ]

  irreflexive : Irreflexive ≈ L → Irreflexive ≈ R → Irreflexive ≈ (L ∪ R)
  irreflexive L-irrefl R-irrefl x≈y = [ L-irrefl x≈y , R-irrefl x≈y ]

module _ {a b ℓ₁ ℓ₂} {A : Set a} {B : Set b} {L : REL A B ℓ₁} {R : REL A B ℓ₂} where

  decidable : Decidable L → Decidable R → Decidable (L ∪ R)
  decidable L? R? x y with L? x y | R? x y
  ... | yes Lxy | _       = yes (inj₁ Lxy)
  ... | no  _   | yes Rxy = yes (inj₂ Rxy)
  ... | no ¬Lxy | no ¬Rxy = no [ ¬Lxy , ¬Rxy ]


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

open import Categories.Category
open import Categories.Functor hiding (id)

-- Limit of a Cone over a Functor F : J → C
module Categories.Diagram.Limit
  {o ℓ e} {o′ ℓ′ e′} {C : Category o ℓ e} {J : Category o′ ℓ′ e′} (F : Functor J C) where

private
  module C = Category C
  module J = Category J
open C
open HomReasoning
open Functor F

open import Level
open import Data.Product using (proj₂)

open import Categories.Category.Construction.Cones F renaming (Cone⇒ to _⇨_)
open import Categories.Object.Terminal as T hiding (up-to-iso; transport-by-iso)
open import Categories.Morphism.Reasoning C
open import Categories.Morphism C
open import Categories.Morphism Cones as MC using () renaming (_≅_ to _⇔_)

private
  variable
    K K′  : Cone
    A B   : J.Obj
    X Y Z : Obj
    q     : K ⇨ K′

-- A Limit is a Terminal object in the category of Cones
--   (This could be unpacked...)
record Limit : Set (o ⊔ ℓ ⊔ e ⊔ o′ ⊔ ℓ′ ⊔ e′) where
  field
    terminal : Terminal Cones

  module terminal = Terminal terminal

  open terminal using () renaming (⊤ to limit) public
  open Cone limit hiding (apex) renaming (N to apex; ψ to proj; commute to limit-commute) public

  rep-cone : ∀ K → K ⇨ limit
  rep-cone K = terminal.! {K}

  rep : ∀ K → Cone.N K ⇒ apex
  rep K = arr
    where open _⇨_ (rep-cone K)

  unrep : X ⇒ apex → Cone
  unrep f = record {
    apex        = record
      { ψ       = λ A → proj A ∘ f
      ; commute = λ g → pullˡ (limit-commute g)
      }
    }

  conify : (f : X ⇒ apex) → unrep f ⇨ limit
  conify f = record
    { arr     = f
    ; commute = refl
    }

  commute : proj A ∘ rep K ≈ Cone.ψ K A
  commute {K = K} = _⇨_.commute (rep-cone K)

  unrep-cone : (K ⇨ limit) → Cone
  unrep-cone f = unrep (_⇨_.arr f)

  g-η : ∀ {f : X ⇒ apex} → rep (unrep f) ≈ f
  g-η {f = f} = terminal.!-unique (conify f)

  η-cone : Cones [ rep-cone limit ≈ Category.id Cones ]
  η-cone = terminal.⊤-id (rep-cone limit)

  η : rep limit ≈ id
  η = η-cone

  rep-cone∘ : Cones [ Cones [ rep-cone K ∘ q ] ≈ rep-cone K′ ]
  rep-cone∘ {K = K} {q = q} = Equiv.sym (terminal.!-unique (Cones [ rep-cone K ∘ q ]))

  rep∘ : ∀ {q : K′ ⇨ K} → rep K ∘ _⇨_.arr q ≈ rep K′
  rep∘ {q = q} = rep-cone∘ {q = q}

  rep-cone-self-id : Cones [ rep-cone limit ≈ Cones.id ]
  rep-cone-self-id = terminal.!-unique Cones.id

  rep-self-id : rep limit ≈ id
  rep-self-id = rep-cone-self-id

open Limit

up-to-iso-cone : (L₁ L₂ : Limit) → limit L₁ ⇔ limit L₂
up-to-iso-cone L₁ L₂ = T.up-to-iso Cones (terminal L₁) (terminal L₂)

up-to-iso : (L₁ L₂ : Limit) → apex L₁ ≅ apex L₂
up-to-iso L₁ L₂ = iso-cone⇒iso-apex (up-to-iso-cone L₁ L₂)

transport-by-iso-cone : (L : Limit) → limit L ⇔ K → Limit
transport-by-iso-cone L L⇿K = record
  { terminal = T.transport-by-iso Cones (terminal L) L⇿K
  }

transport-by-iso : (L : Limit) → apex L ≅ X → Limit
transport-by-iso L L≅X = transport-by-iso-cone L (proj₂ p)
  where p = cone-resp-iso (limit L) L≅X

module _ (X : Obj) (apex₁ : Apex X) (apex₂ : Apex X) (L : Limit) where
  private
    module apex₁ = Apex apex₁
    module apex₂ = Apex apex₂
    module L = Limit L

    K₁ : Cone
    K₁ = record { apex = apex₁ }
    module K₁ = Cone K₁

    K₂ : Cone
    K₂ = record { apex = apex₂ }
    module K₂ = Cone K₂

  ψ-≈⇒rep-≈ : (∀ A → apex₁.ψ A ≈ apex₂.ψ A) → L.rep K₁ ≈ L.rep K₂
  ψ-≈⇒rep-≈ ∀eq = trans (L.terminal.!-unique K₁⇒limit) identityʳ
    where K₁⇒K₂ : K₁ ⇨ K₂
          K₁⇒K₂ = record
            { arr     = id
            ; commute = λ {X} → trans identityʳ (sym (∀eq X))
            }

          K₁⇒limit : K₁ ⇨ L.limit
          K₁⇒limit = Cones [ L.terminal.! ∘ K₁⇒K₂ ]


module Oscar.Data.Product where

open import Data.Product public using (Σ; _,_; proj₁; proj₂; ∃; ∃₂; _×_)


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

open import Agda.Builtin.Cubical.Path
open import Agda.Primitive

private
  variable
    a   : Level
    A B : Set a

Is-proposition : Set a → Set a
Is-proposition A = (x y : A) → x ≡ y

data ∥_∥ (A : Set a) : Set a where
  ∣_∣        : A → ∥ A ∥
  @0 trivial : Is-proposition ∥ A ∥

rec : @0 Is-proposition B → (A → B) → ∥ A ∥ → B
rec p f ∣ x ∣           = f x
rec p f (trivial x y i) = p (rec p f x) (rec p f y) i


module Type.Category.IntensionalFunctionsCategory.LvlUpFunctor where

import Lvl
open import Relator.Equals
open import Relator.Equals.Proofs.Equiv
open import Structure.Category
open import Structure.Category.Functor
open import Type
open import Type.Category.IntensionalFunctionsCategory

private variable ℓ₁ ℓ₂ : Lvl.Level

instance
  LvlUp-functor : Functor(typeIntensionalFnCategory)(typeIntensionalFnCategory)(Lvl.Up{ℓ₁}{ℓ₂})
  Functor.map           LvlUp-functor f(Lvl.up x) = Lvl.up(f(x))
  Functor.op-preserving LvlUp-functor = [≡]-intro
  Functor.id-preserving LvlUp-functor = [≡]-intro


module L.Base.Coproduct.Core where

open import Agda.Primitive

-- Introducing Coproduct types
data _+_ {a b} (A : Set a) (B : Set b) : Set (a ⊔ b) where
  inl : A → A + B
  inr : B → A + B

case : ∀{a b c} {A : Set a} {B : Set b}
       → (C : A + B → Set c)
       → ((x : A) → C (inl x)) → ((y : B) → C (inr y))
       → (e : A + B) → C e
case C c d (inl a) = c a
case C c d (inr b) = d b


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Algebra.RingSolver.AlmostRing where

open import Cubical.Foundations.Prelude

open import Cubical.Data.Sigma

open import Cubical.Algebra.Semigroup
open import Cubical.Algebra.Monoid
open import Cubical.Algebra.AbGroup

private
  variable
    ℓ : Level

record IsAlmostRing {R : Type ℓ}
                  (0r 1r : R) (_+_ _·_ : R → R → R) (-_ : R → R) : Type ℓ where

  constructor isalmostring

  field
    +IsMonoid : IsMonoid 0r _+_
    ·IsMonoid : IsMonoid 1r _·_
    +Comm : (x y : R) → x + y ≡ y + x
    ·Comm : (x y : R) → x · y ≡ y · x
    ·DistR+ : (x y z : R) → x · (y + z) ≡ (x · y) + (x · z)
    ·DistL+ :  (x y z : R) → (x + y) · z ≡ (x · z) + (y · z)
    -Comm· : (x y : R) → - (x · y) ≡ (- x) · y
    -Dist+ : (x y : R) → - (x + y) ≡ (- x) + (- y)

  open IsMonoid +IsMonoid public
    renaming
      ( assoc       to +Assoc
      ; identity    to +Identity
      ; lid         to +Lid
      ; rid         to +Rid
      ; isSemigroup to +IsSemigroup)

  open IsMonoid ·IsMonoid public
    renaming
      ( assoc       to ·Assoc
      ; identity    to ·Identity
      ; lid         to ·Lid
      ; rid         to ·Rid
      ; isSemigroup to ·IsSemigroup )
    hiding
      ( is-set ) -- We only want to export one proof of this

record AlmostRing : Type (ℓ-suc ℓ) where

  constructor almostring

  field
    Carrier : Type ℓ
    0r      : Carrier
    1r      : Carrier
    _+_     : Carrier → Carrier → Carrier
    _·_     : Carrier → Carrier → Carrier
    -_      : Carrier → Carrier
    isAlmostRing  : IsAlmostRing 0r 1r _+_ _·_ -_

  infixl 8 _·_
  infixl 7 -_
  infixl 6 _+_

  open IsAlmostRing isAlmostRing public

-- Extractor for the carrier type
⟨_⟩ : AlmostRing → Type ℓ
⟨_⟩ = AlmostRing.Carrier

isSetAlmostRing : (R : AlmostRing {ℓ}) → isSet ⟨ R ⟩
isSetAlmostRing R = R .AlmostRing.isAlmostRing .IsAlmostRing.·IsMonoid .IsMonoid.isSemigroup .IsSemigroup.is-set


------------------------------------------------------------------------------
-- The division result is correct
------------------------------------------------------------------------------

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

module FOTC.Program.Division.ResultI where

open import Common.FOL.Relation.Binary.EqReasoning

open import FOTC.Base
open import FOTC.Data.Nat
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.PropertiesI
open import FOTC.Program.Division.ConversionRulesI
open import FOTC.Program.Division.Division
open import FOTC.Program.Division.Specification

------------------------------------------------------------------------------
-- The division result is correct when the dividend is less than
-- the divisor.

div-x<y-helper : ∀ {i j} → N i → N j → i < j → i ≡ j * div i j + i
div-x<y-helper {i} {j} Ni Nj i<j = sym prf
  where
  prf : j * div i j + i ≡ i
  prf = j * div i j + i ≡⟨ +-leftCong (*-rightCong (div-x<y i<j)) ⟩
        j * zero + i    ≡⟨ +-leftCong (*-rightZero Nj) ⟩
        zero + i        ≡⟨ +-leftIdentity i ⟩
        i               ∎

div-x<y-resultCorrect : ∀ {i j} → N i → N j → i < j →
                        ∃[ r ] N r ∧ r < j ∧ i ≡ j * div i j + r
div-x<y-resultCorrect Ni Nj i<j = _ , Ni , i<j , div-x<y-helper Ni Nj i<j

-- The division result is correct when the dividend is greater or equal
-- than the divisor.
-- Using the inductive hypothesis ih we know that
--
-- i ∸ j = j * (div (i ∸ j) j) + r.

-- From that we get
--
-- i = j * (succ (div (i ∸ j) j)) + r and we know
--
-- div i j = succ (div (i ∸ j) j) therefore we get
--
-- i = j * div i j + r.
postulate helper : ∀ {i j r} → N i → N j → N r →
                   i ∸ j ≡ j * div (i ∸ j) j + r →
                   i ≡ j * succ₁ (div (i ∸ j) j) + r

div-x≮y-helper : ∀ {i j r} → N i → N j → N r →
                 i ≮ j →
                 i ∸ j ≡ j * div (i ∸ j) j + r →
                 i ≡ j * div i j + r
div-x≮y-helper {i} {j} {r} Ni Nj Nr i≮j helperH =
  i                             ≡⟨ helper Ni Nj Nr helperH ⟩
  j * succ₁ (div (i ∸ j) j) + r ≡⟨ prf ⟩
  j * div i j + r               ∎
  where
  prf : j * succ₁ (div (i ∸ j) j) + r ≡ j * div i j + r
  prf = subst (λ x → j * x + r ≡ j * div i j + r)
              (div-x≮y i≮j)
              refl

-- 2012-02-29: We are using the existential witness only for
-- documenting the types in the where clause. They could be removed.
div-x≮y-resultCorrect : ∀ {i j} → N i → N j →
                        (divSpec (i ∸ j) j (div (i ∸ j) j)) →
                        i ≮ j →
                        ∃[ r ] N r ∧ r < j ∧ i ≡ j * div i j + r
div-x≮y-resultCorrect {i} {j} Ni Nj (h₁ , r , r-correct) i≮j =
  r , Nr , r<j , div-x≮y-helper Ni Nj Nr i≮j helperH
  where
  Nr : N r
  Nr = ∧-proj₁ r-correct

  r<j : r < j
  r<j = ∧-proj₁ (∧-proj₂ r-correct)

  helperH : i ∸ j ≡ j * div (i ∸ j) j + r
  helperH = ∧-proj₂ (∧-proj₂ r-correct)


-- Andreas, 2016-10-09, re issue #2223

-- The front matter or module telescope of the top-level module
-- may generate level constraints that live in no module!

{-# OPTIONS -v tc.constr.add:45 #-} -- KEEP!

open import Common.Level
open import Issue2223.Setoids -- import necessary!

module _ (S : Setoid lzero lzero) (a : Setoid.Carrier S) (_ : a ⟨ Setoid._≈_ S ⟩ a) where

-- PROBLEM WAS: internal error in debug printing.
-- Should work now.


{-# OPTIONS --type-in-type #-}
open import Data.Unit
open import Data.Product
open import Data.List hiding ( concat )
open import Data.String
open import Relation.Binary.PropositionalEquality
module Spire.Examples.InferredPropositionalDesc where

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

elimEq : {A : Set} (x : A) (P : (y : A) → x ≡ y → Set)
  → P x refl
  → (y : A) (p : x ≡ y) → P y p
elimEq .x P prefl x refl = prefl

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

Label : Set
Label = String

Enum : Set
Enum = List Label

data Tag : Enum → Set where
  here : ∀{l E} → Tag (l ∷ E)
  there : ∀{l E} → Tag E → Tag (l ∷ E)

Cases : {E : Enum} (P : Tag E → Set) → Set
Cases {[]} P = ⊤
Cases {l ∷ E} P = P here × Cases λ t → P (there t)

case : {E : Enum} (P : Tag E → Set) (cs : Cases P) (t : Tag E) → P t
case {l ∷ E} P (c , cs) here = c
case {l ∷ E} P (c , cs) (there t) = case (λ t → P (there t)) cs t

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

data Desc (I : Set) : Set₁ where
  `End : (i : I) → Desc I
  `Rec : (i : I) (D : Desc I) → Desc I
  `Arg : (A : Set) (B : A → Desc I) → Desc I
  `RecFun : (A : Set) (B : A → I) (D : Desc I) → Desc I

ISet : Set → Set₁
ISet I = I → Set

El : {I : Set} (D : Desc I) (X : ISet I) → ISet I
El (`End j) X i = j ≡ i
El (`Rec j D) X i = X j × El D X i
El (`Arg A B) X i = Σ A (λ a → El (B a) X i)
El (`RecFun A B D) X i = ((a : A) → X (B a)) × El D X i

data μ {I : Set} (D : Desc I) (i : I) : Set where
  con : El D (μ D) i → μ D i

All : {I : Set} (D : Desc I) {X : ISet I} (P : (i : I) → X i → Set) (i : I) (xs : El D X i) → Set
All (`End j) P i q = ⊤
All (`Rec j D) P i (x , xs) = P j x × All D P i xs
All (`Arg A B) P i (a , b) = All (B a) P i b
All (`RecFun A B D) P i (f , xs) = ((a : A) → P (B a) (f a)) × All D P i xs

caseD : (E : Enum) (I : Set) (cs : Cases (λ _ → Desc I)) (t : Tag E) → Desc I
caseD E I cs t = case (λ _ → Desc I) cs t

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

ind :
  {I : Set}
  (D : Desc I)
  (P : (i : I) → μ D i → Set)
  (pcon : (i : I) (xs : El D (μ D) i) → All D P i xs → P i (con xs))
  {i : I}
  (x : μ D i)
  → P i x

hyps :
  {I : Set}
  (D₁ : Desc I)
  (P : (i : I) → μ D₁ i → Set)
  (pcon : (i : I) (xs : El D₁ (μ D₁) i) → All D₁ P i xs → P i (con xs))
  (D₂ : Desc I)
  {i : I}
  (xs : El D₂ (μ D₁) i)
  → All D₂ P i xs

ind D P pcon (con xs) = pcon _ xs (hyps D P pcon D xs)

hyps D P pcon (`End j) q = tt
hyps D P pcon (`Rec j A) (x , xs) = ind D P pcon x , hyps D P pcon A xs
hyps D P pcon (`Arg A B) (a , b) = hyps D P pcon (B a) b
hyps D P pcon (`RecFun A B E) (f , xs) = (λ a → ind D P pcon (f a)) , hyps D P pcon E xs

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

module Desugared where

  ℕT : Enum
  ℕT = "zero" ∷ "suc" ∷ []

  VecT : Enum
  VecT = "nil" ∷ "cons" ∷ []

  ℕC : Tag ℕT → Desc ⊤
  ℕC = caseD ℕT ⊤
    ( `End tt
    , `Rec tt (`End tt)
    , tt
    )

  ℕD : Desc ⊤
  ℕD = `Arg (Tag ℕT) ℕC

  ℕ : ⊤ → Set
  ℕ = μ ℕD

  zero : ℕ tt
  zero = con (here , refl)

  suc : ℕ tt → ℕ tt
  suc n = con (there here , n , refl)

  VecC : (A : Set) → Tag VecT → Desc (ℕ tt)
  VecC A = caseD VecT (ℕ tt)
    ( `End zero
    , `Arg (ℕ tt) (λ n → `Arg A λ _ → `Rec n (`End (suc n)))
    , tt
    )

  VecD : (A : Set) → Desc (ℕ tt)
  VecD A = `Arg (Tag VecT) (VecC A)

  Vec : (A : Set) (n : ℕ tt) → Set
  Vec A n = μ (VecD A) n

  nil : (A : Set) → Vec A zero
  nil A = con (here , refl)

  cons : (A : Set) (n : ℕ tt) (x : A) (xs : Vec A n) → Vec A (suc n)
  cons A n x xs = con (there here , n , x , xs , refl)

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

  module Induction where

    add : ℕ tt → ℕ tt → ℕ tt
    add = ind ℕD (λ _ _ → ℕ tt → ℕ tt)
      (λ u t,c → case
        (λ t → (c : El (ℕC t) ℕ u)
               (ih : All ℕD (λ u n → ℕ u → ℕ u) u (t , c))
               → ℕ u → ℕ u
        )
        ( (λ q ih n → n)
        , (λ m,q ih,tt n → suc (proj₁ ih,tt n))
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )

    mult : ℕ tt → ℕ tt → ℕ tt
    mult = ind ℕD (λ _ _ → ℕ tt → ℕ tt)
      (λ u t,c → case
        (λ t → (c : El (ℕC t) ℕ u)
               (ih : All ℕD (λ u n → ℕ u → ℕ u) u (t , c))
               → ℕ u → ℕ u
        )
        ( (λ q ih n → zero)
        , (λ m,q ih,tt n → add n (proj₁ ih,tt n))
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )

    append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
    append A m = ind (VecD A) (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n))
      (λ m t,c → case
        (λ t → (c : El (VecC A t) (Vec A) m)
               (ih : All (VecD A) (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)) m (t , c))
               (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
        )
        ( (λ q ih n ys → subst (λ m → Vec A (add m n)) q ys)
        , (λ m',x,xs,q ih,tt n ys →
            let m' = proj₁ m',x,xs,q
                x = proj₁ (proj₂ m',x,xs,q)
                q = proj₂ (proj₂ (proj₂ m',x,xs,q))
                ih = proj₁ ih,tt
            in
            subst (λ m → Vec A (add m n)) q (cons A (add m' n) x (ih n ys))
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )

    concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
    concat A m n = ind (VecD (Vec A m)) (λ n xss → Vec A (mult n m))
      (λ n t,c → case
        (λ t → (c : El (VecC (Vec A m) t) (Vec (Vec A m)) n)
               (ih : All (VecD (Vec A m)) (λ n xss → Vec A (mult n m)) n (t , c))
               → Vec A (mult n m)
        )
        ( (λ q ih → subst (λ n → Vec A (mult n m)) q (nil A))
        , (λ n',xs,xss,q ih,tt →
            let n' = proj₁ n',xs,xss,q
                xs = proj₁ (proj₂ n',xs,xss,q)
                q = proj₂ (proj₂ (proj₂ n',xs,xss,q))
                ih = proj₁ ih,tt
            in
            subst (λ n → Vec A (mult n m)) q (append A m xs (mult n' m) ih)
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )

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

  module Eliminator where

    elimℕ : (P : (ℕ tt) → Set)
      (pzero : P zero)
      (psuc : (m : ℕ tt) → P m → P (suc m))
      (n : ℕ tt)
      → P n
    elimℕ P pzero psuc = ind ℕD (λ u n → P n)
      (λ u t,c → case
        (λ t → (c : El (ℕC t) ℕ u)
               (ih : All ℕD (λ u n → P n) u (t , c))
               → P (con (t , c))
        )
        ( (λ q ih →
            elimEq tt (λ u q → P (con (here , q)))
              pzero
              u q
          )
        , (λ n,q ih,tt →
            elimEq tt (λ u q → P (con (there here , proj₁ n,q , q)))
              (psuc (proj₁ n,q) (proj₁ ih,tt))
              u (proj₂ n,q)
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )

    elimVec : (A : Set) (P : (n : ℕ tt) → Vec A n → Set)
      (pnil : P zero (nil A))
      (pcons : (n : ℕ tt) (a : A) (xs : Vec A n) → P n xs → P (suc n) (cons A n a xs))
      (n : ℕ tt)
      (xs : Vec A n)
      → P n xs
    elimVec A P pnil pcons n = ind (VecD A) (λ n xs → P n xs)
      (λ n t,c → case
        (λ t → (c : El (VecC A t) (Vec A) n)
               (ih : All (VecD A) (λ n xs → P n xs) n (t , c))
               → P n (con (t , c))
        )
        ( (λ q ih →
            elimEq zero (λ n q → P n (con (here , q)))
              pnil
              n q
          )
        , (λ n',x,xs,q ih,tt →
            let n' = proj₁ n',x,xs,q
                x = proj₁ (proj₂ n',x,xs,q)
                xs = proj₁ (proj₂ (proj₂ n',x,xs,q))
                q = proj₂ (proj₂ (proj₂ n',x,xs,q))
                ih = proj₁ ih,tt
            in
            elimEq (suc n') (λ n q → P n (con (there here , n' , x , xs , q)))
              (pcons n' x xs ih )
              n q
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )

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

    add : ℕ tt → ℕ tt → ℕ tt
    add = elimℕ (λ _ → ℕ tt → ℕ tt)
      (λ n → n)
      (λ m ih n → suc (ih n))

    mult : ℕ tt → ℕ tt → ℕ tt
    mult = elimℕ (λ _ → ℕ tt → ℕ tt)
      (λ n → zero)
      (λ m ih n → add n (ih n))

    append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
    append A = elimVec A (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n))
      (λ n ys → ys)
      (λ m x xs ih n ys → cons A (add m n) x (ih n ys))

    concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
    concat A m = elimVec (Vec A m) (λ n xss → Vec A (mult n m))
      (nil A)
      (λ n xs xss ih → append A m xs (mult n m) ih)

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


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

open import Definition.Typed.EqualityRelation

module Definition.LogicalRelation.Properties.Reflexivity {{eqrel : EqRelSet}} where

open import Definition.Untyped
open import Definition.Typed
open import Definition.LogicalRelation

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

-- Reflexivity of reducible types.
reflEq : ∀ {l Γ A} ([A] : Γ ⊩⟨ l ⟩ A) → Γ ⊩⟨ l ⟩ A ≡ A / [A]
reflEq (Uᵣ′ l′ l< ⊢Γ) = (U₌ PE.refl)
reflEq (ℕᵣ D) = ιx (ℕ₌ (red D))
reflEq (ne′ K [ ⊢A , ⊢B , D ] neK K≡K) =
  ιx (ne₌ _ [ ⊢A , ⊢B , D ] neK K≡K)
reflEq (Πᵣ′ F G [ ⊢A , ⊢B , D ] ⊢F ⊢G A≡A [F] [G] G-ext) =
  Π₌ _ _ D A≡A
     (λ ρ ⊢Δ → reflEq ([F] ρ ⊢Δ))
     (λ ρ ⊢Δ [a] → reflEq ([G] ρ ⊢Δ [a]))
reflEq (emb′ 0<1 [A]) = ιx (reflEq [A])

reflNatural-prop : ∀ {Γ n}
                 → Natural-prop Γ n
                 → [Natural]-prop Γ n n
reflNatural-prop (sucᵣ (ℕₜ n d t≡t prop)) =
  sucᵣ (ℕₜ₌ n n d d t≡t
            (reflNatural-prop prop))
reflNatural-prop zeroᵣ = zeroᵣ
reflNatural-prop (ne (neNfₜ neK ⊢k k≡k)) = ne (neNfₜ₌ neK neK k≡k)

-- Reflexivity of reducible terms.
reflEqTerm : ∀ {l Γ A t} ([A] : Γ ⊩⟨ l ⟩ A)
           → Γ ⊩⟨ l ⟩ t ∷ A / [A]
           → Γ ⊩⟨ l ⟩ t ≡ t ∷ A / [A]
reflEqTerm (Uᵣ′ ⁰ 0<1 ⊢Γ) (Uₜ A d typeA A≡A [A]) =
  Uₜ₌ A A d d typeA typeA A≡A [A] [A] (reflEq [A])
reflEqTerm (ℕᵣ D) (ιx (ℕₜ n [ ⊢t , ⊢u , d ] t≡t prop)) =
  ιx (ℕₜ₌ n n [ ⊢t , ⊢u , d ] [ ⊢t , ⊢u , d ] t≡t
      (reflNatural-prop prop))
reflEqTerm (ne′ K D neK K≡K) (ιx (neₜ k d (neNfₜ neK₁ ⊢k k≡k))) =
  ιx (neₜ₌ k k d d (neNfₜ₌ neK₁ neK₁ k≡k))
reflEqTerm (Πᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext) (Πₜ f d funcF f≡f [f] [f]₁) =
  Πₜ₌ f f d d funcF funcF f≡f
      (Πₜ f d funcF f≡f [f] [f]₁)
      (Πₜ f d funcF f≡f [f] [f]₁)
      (λ ρ ⊢Δ [a] → [f] ρ ⊢Δ [a] [a] (reflEqTerm ([F] ρ ⊢Δ) [a]))
reflEqTerm (emb′ 0<1 [A]) (ιx t) = ιx (reflEqTerm [A] t)


module Common.Sum where

open import Common.Level

data _⊎_ {a b} (A : Set a) (B : Set b) : Set (a ⊔ b) where
  inj₁ : (x : A) → A ⊎ B
  inj₂ : (y : B) → A ⊎ B


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

open import Categories.Category

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

open import Level
open import Data.Product using (_,_; proj₁; proj₂)

open import Categories.Category.Construction.Arrow 𝒞

open import Categories.Diagram.Pullback 𝒞
open import Categories.Diagram.Pushout 𝒞

open import Categories.Morphism.Lifts 𝒞

open import Categories.Morphism.Reasoning 𝒞 renaming (glue to glue-■)
import Categories.Morphism as Mor

open Category 𝒞
open Definitions 𝒞
open HomReasoning

-- We want to talk about retracts of morphisms, so
-- we don't use the definition of 'Retract' applied to '𝒞'
open Mor 𝒞 hiding (Retract)
open Mor using (Retract)
open Morphism⇒

--------------------------------------------------------------------------------
-- Lifting and Retractions

module _ {X Y T} {f : X ⇒ Y} {i : X ⇒ T} {p : T ⇒ Y} (factors : f ≈ p ∘ i) where

  -- If 'f' factors into 'p ∘ i' and 'f' has the left lifting property
  -- with respect to 'p', then 'f' is a retraction of 'i' in the arrow
  -- category of 𝒞.
  retract-liftˡ : Lifts f p → Retract Arrow (mor f) (mor i)
  retract-liftˡ lifts = record
    { section = mor⇒ (fill-commˡ ○ ⟺ identityʳ)
    ; retract = mor⇒ (⟺ factors ○ ⟺ identityʳ)
    ; is-retract = identity² , fill-commʳ
    }
    where
      open Filler (lifts (identityˡ ○ factors))

  -- We have an analogous situation for right lifts.
  retract-liftʳ : Lifts i f → Retract Arrow (mor f) (mor p)
  retract-liftʳ lifts = record
    { section = mor⇒ (identityˡ ○ factors)
    ; retract = mor⇒ (identityˡ ○ ⟺ fill-commʳ)
    ; is-retract = fill-commˡ , identity²
    }
    where
      open Filler (lifts (⟺ factors ○ ⟺ identityʳ))

--------------------------------------------------------------------------------
-- Closure Properties of Injective and Projective morphisms.

module _ {j} (J : MorphismClass j) where
  private
    variable
      X Y Z : Obj
      f g h i p : X ⇒ Y

  -- If 'f' is an isomorphism, then it must be J-Projective.
  iso-proj : ∀ {X Y} (f : X ⇒ Y) → IsIso f → Proj J f
  iso-proj f f-iso g g∈J {h} {i} comm = record
    { filler = h ∘ inv
    ; fill-commˡ = cancelʳ isoˡ
    ; fill-commʳ = extendʳ (⟺ comm) ○ elimʳ isoʳ
    }
    where
      open IsIso f-iso

  -- Dually, If 'f' is an isomorphism, then it must be J-Injective.
  iso-inj : ∀ {X Y} (f : X ⇒ Y) → IsIso f → Inj J f
  iso-inj f f-iso g g∈J {h} {i} comm = record
    { filler = inv ∘ i
    ; fill-commˡ = extendˡ comm ○ elimˡ isoˡ
    ; fill-commʳ = cancelˡ isoʳ
    }
    where
      open IsIso f-iso

  -- J-Projective morphisms are closed under composition.
  proj-∘ : ∀ {X Y Z} {f : Y ⇒ Z} {g : X ⇒ Y} → Proj J f → Proj J g → Proj J (f ∘ g)
  proj-∘ {f = f} {g = g} f-proj g-proj h h∈J {k} {i} comm = record
    { filler = UpperFiller.filler
    ; fill-commˡ = begin
        UpperFiller.filler ∘ f ∘ g
      ≈⟨ pullˡ UpperFiller.fill-commˡ ⟩
        LowerFiller.filler ∘ g
      ≈⟨ LowerFiller.fill-commˡ ⟩
        k
      ∎

    ; fill-commʳ = UpperFiller.fill-commʳ
    }
    where
      module LowerFiller = Filler (g-proj h h∈J (assoc ○ comm))
      module UpperFiller = Filler (f-proj h h∈J (⟺ LowerFiller.fill-commʳ))

  -- J-Injective morphisms are closed under composition.
  inj-∘ : ∀ {X Y Z} {f : Y ⇒ Z} {g : X ⇒ Y} → Inj J f → Inj J g → Inj J (f ∘ g)
  inj-∘ {f = f} {g = g} f-inj g-inj h h∈J {k} {i} comm = record
    { filler = LowerFiller.filler
    ; fill-commˡ = LowerFiller.fill-commˡ
    ; fill-commʳ = begin
        (f ∘ g) ∘ LowerFiller.filler
      ≈⟨ pullʳ LowerFiller.fill-commʳ ⟩
        f ∘ UpperFiller.filler
      ≈⟨ UpperFiller.fill-commʳ ⟩
        i
      ∎
    }
    where
      module UpperFiller = Filler (f-inj h h∈J (comm ○ assoc))
      module LowerFiller = Filler (g-inj h h∈J UpperFiller.fill-commˡ)

  -- J-Projective morphisms are stable under pushout.
  proj-pushout : ∀ {X Y Z} {p : X ⇒ Y} {f : X ⇒ Z} → (P : Pushout p f) → Proj J p → Proj J (Pushout.i₂ P)
  proj-pushout {p = p} {f = f} po p-proj h h∈J sq = record
    { filler = universal fill-commˡ
    ; fill-commˡ = universal∘i₂≈h₂
    ; fill-commʳ = unique-diagram (pullʳ universal∘i₁≈h₁ ○ fill-commʳ) (pullʳ universal∘i₂≈h₂ ○ ⟺ sq)
    }
    where
      open Pushout po
      open Filler (p-proj h h∈J (glue-■ sq commute))

  -- J-Injective morphisms are stable under pullback.
  inj-pullback : ∀ {X Y Z} {i : X ⇒ Z} {f : Y ⇒ Z} → (P : Pullback i f) → Inj J i → Inj J (Pullback.p₂ P)
  inj-pullback {i = i} {f = f} pb i-inj h h∈J sq = record
    { filler = universal fill-commʳ
    ; fill-commˡ = unique-diagram (pullˡ p₁∘universal≈h₁ ○ fill-commˡ) (pullˡ p₂∘universal≈h₂ ○ sq)
    ; fill-commʳ = p₂∘universal≈h₂
    }
    where
      open Pullback pb
      open Filler (i-inj h h∈J (glue-■ (⟺ commute) sq))

  -- J-Projective morphisms are stable under retractions.
  proj-retract : Proj J p → Retract Arrow (mor f) (mor p) → Proj J f
  proj-retract {p = p} {f = f} p-proj f-retracts h h∈J {g} {k} sq = record
    { filler = filler ∘ cod⇒ section
    ; fill-commˡ = begin
        (filler ∘ cod⇒ section) ∘ f
      ≈⟨ extendˡ (square section) ⟩
        (filler ∘ p) ∘ dom⇒ section
      ≈⟨ fill-commˡ ⟩∘⟨refl ⟩
        (g ∘ dom⇒ retract) ∘ dom⇒ section
      ≈⟨ cancelʳ (proj₁ is-retract) ⟩
        g
      ∎
    ; fill-commʳ = begin
        h ∘ filler ∘ cod⇒ section
      ≈⟨ extendʳ fill-commʳ ⟩
        k ∘ (cod⇒ retract ∘ cod⇒ section)
      ≈⟨ elimʳ (proj₂ is-retract) ⟩
        k
      ∎
    }
    where
      open Retract f-retracts
      open Filler (p-proj h h∈J (glue-■ sq (square retract)))

  -- J-Injective morphisms are stable under retractions.
  inj-retract : Inj J i → Retract Arrow (mor f) (mor i) → Inj J f
  inj-retract {i = i} {f = f} i-inj f-retracts h h∈J {g} {k} sq = record
    { filler = dom⇒ retract ∘ filler
    ; fill-commˡ = begin
        (dom⇒ retract ∘ filler) ∘ h
      ≈⟨ extendˡ fill-commˡ ⟩
        (dom⇒ retract ∘ dom⇒ section) ∘ g
      ≈⟨ elimˡ (proj₁ is-retract) ⟩
        g
      ∎
    ; fill-commʳ = begin
        f ∘ dom⇒ retract ∘ filler
      ≈⟨ extendʳ (⟺ (square retract)) ⟩
        cod⇒ retract ∘ i ∘ filler
      ≈⟨ refl⟩∘⟨ fill-commʳ ⟩
        cod⇒ retract ∘ cod⇒ section ∘ k
      ≈⟨ cancelˡ (proj₂ is-retract) ⟩
        k
      ∎
    }
    where
      open Retract f-retracts
      open Filler (i-inj h h∈J (glue-■ (square section) sq))


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

module 08-contractible-types where

import 07-equivalences
open 07-equivalences public

-- Section 6.1 Contractible types

is-contr :
  {i : Level} → UU i → UU i
is-contr A = Σ A (λ a → (x : A) → Id a x)

abstract
  center :
    {i : Level} {A : UU i} → is-contr A → A
  center (pair c is-contr-A) = c

  -- We make sure that the contraction is coherent in a straightforward way
  contraction :
    {i : Level} {A : UU i} (is-contr-A : is-contr A) →
    (const A A (center is-contr-A) ~ id)
  contraction (pair c C) x = (inv (C c)) ∙ (C x)

  coh-contraction :
    {i : Level} {A : UU i} (is-contr-A : is-contr A) →
    Id (contraction is-contr-A (center is-contr-A)) refl
  coh-contraction (pair c C) = left-inv (C c)

-- We show that contractible types satisfy an induction principle akin to the induction principle of the unit type: singleton induction. This can be helpful to give short proofs of many facts.

ev-pt :
  {i j : Level} (A : UU i) (a : A) (B : A → UU j) → ((x : A) → B x) → B a
ev-pt A a B f = f a

abstract
  sing-ind-is-contr :
    {i j : Level} (A : UU i) (is-contr-A : is-contr A) (B : A → UU j) →
    (a : A) → B a → (x : A) → B x
  sing-ind-is-contr A is-contr-A B a b x =
    tr B ((inv (contraction is-contr-A a)) ∙ (contraction is-contr-A x)) b

  sing-comp-is-contr :
    {i j : Level} (A : UU i) (is-contr-A : is-contr A) (B : A → UU j) (a : A) →
    ((ev-pt A a B) ∘ (sing-ind-is-contr A is-contr-A B a)) ~ id
  sing-comp-is-contr A is-contr-A B a b =
    ap (λ ω → tr B ω b) (left-inv (contraction is-contr-A a))

  sec-ev-pt-is-contr :
    {i j : Level} (A : UU i) (is-contr-A : is-contr A) (B : A → UU j) (a : A) →
    sec (ev-pt A a B)
  sec-ev-pt-is-contr A is-contr-A B a =
    pair
      ( sing-ind-is-contr A is-contr-A B a)
      ( sing-comp-is-contr A is-contr-A B a)

abstract
  is-sing-is-contr :
    {i j : Level} (A : UU i) (is-contr-A : is-contr A) (B : A → UU j) →
    ( a : A) → sec (ev-pt A a B)
  is-sing-is-contr A is-contr-A B a =
    pair
      ( sing-ind-is-contr A is-contr-A B a)
      ( sing-comp-is-contr A is-contr-A B a)

is-sing :
  {i : Level} (A : UU i) → A → UU (lsuc i)
is-sing {i} A a = (B : A → UU i) → sec (ev-pt A a B)

abstract
  is-contr-sing-ind :
    {i : Level} (A : UU i) (a : A) →
    ((P : A → UU i) → P a → (x : A) → P x) → is-contr A
  is-contr-sing-ind A a S = pair a (S (λ x → Id a x) refl)

abstract
  is-contr-is-sing :
    {i : Level} (A : UU i) (a : A) → is-sing A a → is-contr A
  is-contr-is-sing A a S = is-contr-sing-ind A a (λ P → pr1 (S P))

abstract
  is-sing-unit : is-sing unit star
  is-sing-unit B = pair ind-unit (λ b → refl)

is-contr-unit : is-contr unit
is-contr-unit = is-contr-is-sing unit star (is-sing-unit)

abstract
  is-sing-total-path :
    {i : Level} (A : UU i) (a : A) →
    is-sing (Σ A (λ x → Id a x)) (pair a refl)
  is-sing-total-path A a B = pair (ind-Σ ∘ (ind-Id a _)) (λ b → refl)

abstract
  is-contr-total-path :
    {i : Level} {A : UU i} (a : A) → is-contr (Σ A (λ x → Id a x))
  is-contr-total-path {A = A} a = is-contr-is-sing _ _ (is-sing-total-path A a)

-- Section 6.2 Contractible maps

-- We first introduce the notion of a fiber of a map.
fib :
  {i j : Level} {A : UU i} {B : UU j} (f : A → B) (b : B) → UU (i ⊔ j)
fib f b = Σ _ (λ x → Id (f x) b)

fib' :
  {i j : Level} {A : UU i} {B : UU j} (f : A → B) (b : B) → UU (i ⊔ j)
fib' f b = Σ _ (λ x → Id b (f x))

-- A map is said to be contractible if its fibers are contractible in the usual sense.
is-contr-map :
  {i j : Level} {A : UU i} {B : UU j} (f : A → B) → UU (i ⊔ j)
is-contr-map f = (y : _) → is-contr (fib f y)

-- Our goal is to show that contractible maps are equivalences.
-- First we construct the inverse of a contractible map.
inv-is-contr-map :
  {i j : Level} {A : UU i} {B : UU j} {f : A → B} →
  is-contr-map f → B → A
inv-is-contr-map is-contr-f y = pr1 (center (is-contr-f y))

-- Then we show that the inverse is a section.
issec-is-contr-map :
  {i j : Level} {A : UU i} {B : UU j} {f : A → B}
  (is-contr-f : is-contr-map f) → (f ∘ (inv-is-contr-map is-contr-f)) ~ id
issec-is-contr-map is-contr-f y = pr2 (center (is-contr-f y))

-- Then we show that the inverse is also a retraction.
isretr-is-contr-map :
  {i j : Level} {A : UU i} {B : UU j} {f : A → B}
  (is-contr-f : is-contr-map f) → ((inv-is-contr-map is-contr-f) ∘ f) ~ id
isretr-is-contr-map {_} {_} {A} {B} {f} is-contr-f x =
  ap ( pr1 {B = λ z → Id (f z) (f x)})
     ( ( inv
         ( contraction
           ( is-contr-f (f x))
           ( pair
             ( inv-is-contr-map is-contr-f (f x))
             ( issec-is-contr-map is-contr-f (f x))))) ∙
       ( contraction (is-contr-f (f x)) (pair x refl)))

-- Finally we put it all together to show that contractible maps are equivalences.

abstract
  is-equiv-is-contr-map :
    {i j : Level} {A : UU i} {B : UU j} {f : A → B} →
    is-contr-map f → is-equiv f
  is-equiv-is-contr-map is-contr-f =
    is-equiv-has-inverse
      ( inv-is-contr-map is-contr-f)
      ( issec-is-contr-map is-contr-f)
      ( isretr-is-contr-map is-contr-f)

-- Section 6.3 Equivalences are contractible maps

-- The goal in this section is to show that all equivalences are contractible maps. This theorem is much harder than anything we've seen so far, but many future results will depend on it.

-- We characterize the identity types of fibers

Eq-fib :
  {i j : Level} {A : UU i} {B : UU j} (f : A → B) (y : B) →
  fib f y → fib f y → UU (i ⊔ j)
Eq-fib f y s t =
  Σ (Id (pr1 s) (pr1 t)) (λ α → Id ((ap f α) ∙ (pr2 t)) (pr2 s))

reflexive-Eq-fib :
  {i j : Level} {A : UU i} {B : UU j} (f : A → B) (y : B) →
  (s : fib f y) → Eq-fib f y s s
reflexive-Eq-fib f y s = pair refl refl

Eq-fib-eq :
  {i j : Level} {A : UU i} {B : UU j} (f : A → B) (y : B) →
  {s t : fib f y} → (Id s t) → Eq-fib f y s t
Eq-fib-eq f y {s} refl = reflexive-Eq-fib f y s

eq-Eq-fib :
  {i j : Level} {A : UU i} {B : UU j} (f : A → B) (y : B) →
  {s t : fib f y} → Eq-fib f y s t → Id s t
eq-Eq-fib f y {pair x p} {pair .x .p} (pair refl refl) = refl

issec-eq-Eq-fib :
  {i j : Level} {A : UU i} {B : UU j} (f : A → B) (y : B) →
  {s t : fib f y} → ((Eq-fib-eq f y {s} {t}) ∘ (eq-Eq-fib f y {s} {t})) ~ id
issec-eq-Eq-fib f y {pair x p} {pair .x .p} (pair refl refl) = refl

isretr-eq-Eq-fib :
  {i j : Level} {A : UU i} {B : UU j} (f : A → B) (y : B) →
  {s t : fib f y} → ((eq-Eq-fib f y {s} {t}) ∘ (Eq-fib-eq f y {s} {t})) ~ id
isretr-eq-Eq-fib f y {pair x p} {.(pair x p)} refl = refl

abstract
  is-equiv-Eq-fib-eq :
    {i j : Level} {A : UU i} {B : UU j} (f : A → B) (y : B) →
    {s t : fib f y} → is-equiv (Eq-fib-eq f y {s} {t})
  is-equiv-Eq-fib-eq f y {s} {t} =
    is-equiv-has-inverse
      ( eq-Eq-fib f y)
      ( issec-eq-Eq-fib f y)
      ( isretr-eq-Eq-fib f y)

abstract
  is-equiv-eq-Eq-fib :
    {i j : Level} {A : UU i} {B : UU j} (f : A → B) (y : B) →
    {s t : fib f y} → is-equiv (eq-Eq-fib f y {s} {t})
  is-equiv-eq-Eq-fib f y {s} {t} =
    is-equiv-has-inverse
      ( Eq-fib-eq f y)
      ( isretr-eq-Eq-fib f y)
      ( issec-eq-Eq-fib f y)

-- Next, we improve the homotopy G : f ∘ g ~ id if f comes equipped with the
-- structure has-inverse f.

inv-has-inverse :
  {i j : Level} {A : UU i} {B : UU j} {f : A → B} →
  has-inverse f → B → A
inv-has-inverse inv-f = pr1 inv-f

issec-inv-has-inverse :
  {i j : Level} {A : UU i} {B : UU j} {f : A → B} →
  (inv-f : has-inverse f) → (f ∘ (inv-has-inverse inv-f)) ~ id
issec-inv-has-inverse {f = f} (pair g (pair G H)) y =
  (inv (G (f (g y)))) ∙ (ap f (H (g y)) ∙ (G y))

isretr-inv-has-inverse :
  {i j : Level} {A : UU i} {B : UU j} {f : A → B} →
  (inv-f : has-inverse f) → ((inv-has-inverse inv-f) ∘ f) ~ id
isretr-inv-has-inverse inv-f = pr2 (pr2 inv-f)

-- Before we start we will develop some of the ingredients of the construction.

-- We will need the naturality of homotopies.
htpy-nat :
  {i j : Level} {A : UU i} {B : UU j} {f g : A → B} (H : f ~ g)
  {x y : A} (p : Id x y) →
  Id ((H x) ∙ (ap g p)) ((ap f p) ∙ (H y))
htpy-nat H refl = right-unit

-- We will also need to undo concatenation on the left and right. One might notice that, in the terminology of Lecture 9, we almost show here that concat p and concat' q are embeddings.
left-unwhisk :
  {i : Level} {A : UU i} {x y z : A} (p : Id x y) {q r : Id y z} →
  Id (p ∙ q) (p ∙ r) → Id q r
left-unwhisk refl s = (inv left-unit) ∙ (s ∙ left-unit)

right-unwhisk :
  {i : Level} {A : UU i} {x y z : A} {p q : Id x y}
  (r : Id y z) → Id (p ∙ r) (q ∙ r) → Id p q
right-unwhisk refl s = (inv right-unit) ∙ (s ∙ right-unit)

-- We will also need to compute with homotopies to the identity function.
htpy-red :
  {i : Level} {A : UU i} {f : A → A} (H : f ~ id) →
  (x : A) → Id (H (f x)) (ap f (H x))
htpy-red {_} {A} {f} H x =
  right-unwhisk (H x)
    ( ( ap (concat (H (f x)) x) (inv (ap-id (H x)))) ∙
      ( htpy-nat H (H x)))

square :
  {i : Level} {A : UU i} {x y1 y2 z : A}
  (p1 : Id x y1) (q1 : Id y1 z) (p2 : Id x y2) (q2 : Id y2 z) → UU i
square p q p' q' = Id (p ∙ q) (p' ∙ q')

sq-left-whisk :
  {i : Level} {A : UU i} {x y1 y2 z : A} {p1 p1' : Id x y1}
  (s : Id p1 p1') {q1 : Id y1 z} {p2 : Id x y2} {q2 : Id y2 z} →
  square p1 q1 p2 q2 → square p1' q1 p2 q2
sq-left-whisk refl sq = sq

sq-top-whisk :
  {i : Level} {A : UU i} {x y1 y2 z : A}
  (p1 : Id x y1) (q1 : Id y1 z)
  (p2 : Id x y2) {p2' : Id x y2} (s : Id p2 p2') (q2 : Id y2 z) →
  square p1 q1 p2 q2 → square p1 q1 p2' q2
sq-top-whisk p1 q1 p2 refl q2 sq = sq

coherence-inv-has-inverse :
  {i j : Level} {A : UU i} {B : UU j} {f : A → B} →
  (inv-f : has-inverse f) →
  (f ·l (isretr-inv-has-inverse inv-f)) ~ ((issec-inv-has-inverse inv-f) ·r f)
coherence-inv-has-inverse {f = f} (pair g (pair G H)) x =
  inv-con
    ( G (f (g (f x))))
    ( ap f (H x))
    ( (ap f (H (g (f x)))) ∙ (G (f x)))
    ( sq-top-whisk
      ( G (f (g (f x))))
      ( ap f (H x))
      ( (ap (f ∘ (g ∘ f)) (H x)))
      ( (ap-comp f (g ∘ f) (H x)) ∙ (inv (ap (ap f) (htpy-red H x))))
      ( G (f x))
      ( htpy-nat (htpy-right-whisk G f) (H x)))

-- Now the proof that equivalences are contractible maps really begins. Note that we have already shown that any equivalence has an inverse. Our strategy is therefore to first show that maps with inverses are contractible, and then deduce the claim about equivalences.

abstract
  center-has-inverse :
    {i j : Level} {A : UU i} {B : UU j} {f : A → B} →
    has-inverse f → (y : B) → fib f y
  center-has-inverse {i} {j} {A} {B} {f} inv-f y =
    pair
      ( inv-has-inverse inv-f y)
      ( issec-inv-has-inverse inv-f y)

  contraction-has-inverse :
    {i j : Level} {A : UU i} {B : UU j} {f : A → B} →
    (I : has-inverse f) → (y : B) → (t : fib f y) →
    Id (center-has-inverse I y) t
  contraction-has-inverse {i} {j} {A} {B} {f}
    ( pair g (pair G H)) y (pair x refl) =
    eq-Eq-fib f y (pair
      ( H x)
      ( ( right-unit) ∙
        ( coherence-inv-has-inverse (pair g (pair G H)) x)))

  is-contr-map-has-inverse : {i j : Level} {A : UU i} {B : UU j} {f : A → B} →
    has-inverse f → is-contr-map f
  is-contr-map-has-inverse inv-f y =
    pair
      ( center-has-inverse inv-f y)
      ( contraction-has-inverse inv-f y)

  is-contr-map-is-equiv : {i j : Level} {A : UU i} {B : UU j} {f : A → B} →
    is-equiv f → is-contr-map f
  is-contr-map-is-equiv = is-contr-map-has-inverse ∘ has-inverse-is-equiv

abstract
  is-contr-total-path' :
    {i : Level} {A : UU i} (a : A) → is-contr (Σ A (λ x → Id x a))
  is-contr-total-path' a = is-contr-map-is-equiv (is-equiv-id _) a

-- Exercises

-- Exercise 6.1

-- In this exercise we are asked to show that the identity types of a contractible type are again contractible. In the terminology of Lecture 8: we are showing that contractible types are propositions.

abstract
  is-prop-is-contr : {i : Level} {A : UU i} → is-contr A →
    (x y : A) → is-contr (Id x y)
  is-prop-is-contr {i} {A} is-contr-A =
    sing-ind-is-contr A is-contr-A
      ( λ x → ((y : A) → is-contr (Id x y)))
      ( center is-contr-A)
      ( λ y → pair
        ( contraction is-contr-A y)
        ( ind-Id
          ( center is-contr-A)
          ( λ z (p : Id (center is-contr-A) z) →
            Id (contraction is-contr-A z) p)
          ( coh-contraction is-contr-A)
          ( y)))

abstract
  is-prop-is-contr' : {i : Level} {A : UU i} → is-contr A →
    (x y : A) → Id x y
  is-prop-is-contr' is-contr-A x y =
    center (is-prop-is-contr is-contr-A x y)

-- Exercise 6.2

-- In this exercise we are showing that contractible types are closed under retracts.

abstract
  is-contr-retract-of : {i j : Level} {A : UU i} (B : UU j) →
    A retract-of B → is-contr B → is-contr A
  is-contr-retract-of B (pair i (pair r isretr)) is-contr-B =
    pair
      ( r (center is-contr-B))
      ( λ x → (ap r (contraction is-contr-B (i x))) ∙ (isretr x))

-- Exercise 6.3

-- In this exercise we are showing that a type is contractible if and only if the constant map to the unit type is an equivalence. This can be used to derive a '3-for-2 property' for contractible types, which may come in handy sometimes.

abstract
  is-equiv-const-is-contr :
    {i : Level} {A : UU i} → is-contr A → is-equiv (const A unit star)
  is-equiv-const-is-contr {i} {A} is-contr-A =
    pair
      ( pair (ind-unit (center is-contr-A)) (ind-unit refl))
      ( pair (const unit A (center is-contr-A)) (contraction is-contr-A))

abstract
  is-contr-is-equiv-const :
    {i : Level} {A : UU i} → is-equiv (const A unit star) → is-contr A
  is-contr-is-equiv-const (pair (pair g issec) (pair h isretr)) =
    pair (h star) isretr

abstract
  is-contr-is-equiv :
    {i j : Level} {A : UU i} (B : UU j) (f : A → B) →
    is-equiv f → is-contr B → is-contr A
  is-contr-is-equiv B f is-equiv-f is-contr-B =
    is-contr-is-equiv-const
      ( is-equiv-comp'
        ( const B unit star)
        ( f)
        ( is-equiv-f)
        ( is-equiv-const-is-contr is-contr-B))

abstract
  is-contr-equiv :
    {i j : Level} {A : UU i} (B : UU j) (e : A ≃ B) → is-contr B → is-contr A
  is-contr-equiv B (pair e is-equiv-e) is-contr-B =
    is-contr-is-equiv B e is-equiv-e is-contr-B

abstract
  is-contr-is-equiv' :
    {i j : Level} (A : UU i) {B : UU j} (f : A → B) →
    is-equiv f → is-contr A → is-contr B
  is-contr-is-equiv' A f is-equiv-f is-contr-A =
    is-contr-is-equiv A
      ( inv-is-equiv is-equiv-f)
      ( is-equiv-inv-is-equiv is-equiv-f)
      ( is-contr-A)

abstract
  is-contr-equiv' :
    {i j : Level} (A : UU i) {B : UU j} (e : A ≃ B) → is-contr A → is-contr B
  is-contr-equiv' A (pair e is-equiv-e) is-contr-A =
    is-contr-is-equiv' A e is-equiv-e is-contr-A

abstract
  is-equiv-is-contr :
    {i j : Level} {A : UU i} {B : UU j} (f : A → B) →
    is-contr A → is-contr B → is-equiv f
  is-equiv-is-contr {i} {j} {A} {B} f is-contr-A is-contr-B =
    is-equiv-has-inverse
      ( const B A (center is-contr-A))
      ( sing-ind-is-contr B is-contr-B _ _
        ( inv (contraction is-contr-B (f (center is-contr-A)))))
      ( contraction is-contr-A)

equiv-is-contr :
  {i j : Level} {A : UU i} {B : UU j} →
  is-contr A → is-contr B → A ≃ B
equiv-is-contr is-contr-A is-contr-B =
  pair
    ( λ a → center is-contr-B)
    ( is-equiv-is-contr _ is-contr-A is-contr-B)

-- Exercise 6.4

-- In this exercise we will show that if the base type in a Σ-type is contractible, then the Σ-type is equivalent to the fiber at the center of contraction. This can be seen as a left unit law for Σ-types. We will derive a right unit law for Σ-types in Lecture 7 (not because it is unduable here, but it is useful to have some knowledge of fiberwise equivalences).

left-unit-law-Σ-map :
  {i j : Level} {C : UU i} (B : C → UU j)
  (is-contr-C : is-contr C) → B (center is-contr-C) → Σ C B
left-unit-law-Σ-map B is-contr-C y = pair (center is-contr-C) y

left-unit-law-Σ-map-conv :
  {i j : Level} {C : UU i} (B : C → UU j)
  (is-contr-C : is-contr C) → Σ C B → B (center is-contr-C)
left-unit-law-Σ-map-conv B is-contr-C =
  ind-Σ
    ( sing-ind-is-contr _ is-contr-C
      ( λ x → B x → B (center is-contr-C))
      ( center is-contr-C)
      ( id))

left-inverse-left-unit-law-Σ-map-conv :
  {i j : Level} {C : UU i} (B : C → UU j) (is-contr-C : is-contr C) →
  ( ( left-unit-law-Σ-map-conv B is-contr-C) ∘
    ( left-unit-law-Σ-map B is-contr-C)) ~ id
left-inverse-left-unit-law-Σ-map-conv B is-contr-C y =
  ap
    ( λ (f : B (center is-contr-C) → B (center is-contr-C)) → f y)
    ( sing-comp-is-contr _ is-contr-C
      ( λ x → B x → B (center is-contr-C))
      ( center is-contr-C)
      ( id))

right-inverse-left-unit-law-Σ-map-conv :
  {i j : Level} {C : UU i} (B : C → UU j) (is-contr-C : is-contr C) →
  ( ( left-unit-law-Σ-map B is-contr-C) ∘
    ( left-unit-law-Σ-map-conv B is-contr-C)) ~ id
right-inverse-left-unit-law-Σ-map-conv B is-contr-C =
  ind-Σ
    ( sing-ind-is-contr _ is-contr-C
      ( λ x → (y : B x) →
        Id ( ( ( left-unit-law-Σ-map B is-contr-C) ∘
               ( left-unit-law-Σ-map-conv B is-contr-C))
             ( pair x y))
           ( id (pair x y))) (center is-contr-C)
      ( λ y → ap
        ( left-unit-law-Σ-map B is-contr-C)
        ( ap
          ( λ f → f y)
          ( sing-comp-is-contr _ is-contr-C
            ( λ x → B x → B (center is-contr-C)) (center is-contr-C) id))))

abstract
  is-equiv-left-unit-law-Σ-map :
    {i j : Level} {C : UU i} (B : C → UU j) (is-contr-C : is-contr C) →
    is-equiv (left-unit-law-Σ-map B is-contr-C)
  is-equiv-left-unit-law-Σ-map B is-contr-C =
    is-equiv-has-inverse
      ( left-unit-law-Σ-map-conv B is-contr-C)
      ( right-inverse-left-unit-law-Σ-map-conv B is-contr-C)
      ( left-inverse-left-unit-law-Σ-map-conv B is-contr-C)

abstract
  is-equiv-left-unit-law-Σ-map-conv :
    {i j : Level} {C : UU i} (B : C → UU j) (is-contr-C : is-contr C) →
    is-equiv (left-unit-law-Σ-map-conv B is-contr-C)
  is-equiv-left-unit-law-Σ-map-conv B is-contr-C =
    is-equiv-has-inverse
      ( left-unit-law-Σ-map B is-contr-C)
      ( left-inverse-left-unit-law-Σ-map-conv B is-contr-C)
      ( right-inverse-left-unit-law-Σ-map-conv B is-contr-C)

left-unit-law-Σ : {i j : Level} {C : UU i} (B : C → UU j)
  (is-contr-C : is-contr C) → B (center is-contr-C) ≃ Σ C B
left-unit-law-Σ B is-contr-C =
  pair
    ( left-unit-law-Σ-map B is-contr-C)
    ( is-equiv-left-unit-law-Σ-map B is-contr-C)

left-unit-law-Σ-map-gen :
  {l1 l2 : Level} {A : UU l1} (B : A → UU l2) →
  is-contr A → (x : A) → B x → Σ A B
left-unit-law-Σ-map-gen B is-contr-A x y = pair x y

abstract
  is-equiv-left-unit-law-Σ-map-gen :
    {l1 l2 : Level} {A : UU l1} (B : A → UU l2) →
    (is-contr-A : is-contr A) →
    (x : A) → is-equiv (left-unit-law-Σ-map-gen B is-contr-A x)
  is-equiv-left-unit-law-Σ-map-gen B is-contr-A x =
    is-equiv-comp
      ( left-unit-law-Σ-map-gen B is-contr-A x)
      ( left-unit-law-Σ-map B is-contr-A)
      ( tr B (inv (contraction is-contr-A x)))
      ( λ y → eq-pair (inv (contraction is-contr-A x)) refl)
      ( is-equiv-tr B (inv (contraction is-contr-A x)))
      ( is-equiv-left-unit-law-Σ-map B is-contr-A)

left-unit-law-Σ-gen :
  {l1 l2 : Level} {A : UU l1} (B : A → UU l2) →
  (is-contr-A : is-contr A) →
  (x : A) → B x ≃ Σ A B
left-unit-law-Σ-gen B is-contr-A x =
  pair
    ( left-unit-law-Σ-map-gen B is-contr-A x)
    ( is-equiv-left-unit-law-Σ-map-gen B is-contr-A x)

-- Exercise 6.6

-- In this exercise we show that the domain of a map is equivalent to the total space of its fibers.

Σ-fib-to-domain :
  {i j : Level} {A : UU i} {B : UU j} (f : A → B ) → (Σ B (fib f)) → A
Σ-fib-to-domain f t = pr1 (pr2 t)

triangle-Σ-fib-to-domain :
  {i j : Level} {A : UU i} {B : UU j} (f : A → B ) →
  pr1 ~ (f ∘ (Σ-fib-to-domain f))
triangle-Σ-fib-to-domain f t = inv (pr2 (pr2 t))

domain-to-Σ-fib :
  {i j : Level} {A : UU i} {B : UU j} (f : A → B) → A → Σ B (fib f)
domain-to-Σ-fib f x = pair (f x) (pair x refl)

left-inverse-domain-to-Σ-fib :
  {i j : Level} {A : UU i} {B : UU j} (f : A → B ) →
  ((domain-to-Σ-fib f) ∘ (Σ-fib-to-domain f)) ~ id
left-inverse-domain-to-Σ-fib f (pair .(f x) (pair x refl)) = refl

right-inverse-domain-to-Σ-fib :
  {i j : Level} {A : UU i} {B : UU j} (f : A → B ) →
  ((Σ-fib-to-domain f) ∘ (domain-to-Σ-fib f)) ~ id
right-inverse-domain-to-Σ-fib f x = refl

abstract
  is-equiv-Σ-fib-to-domain :
    {i j : Level} {A : UU i} {B : UU j} (f : A → B ) →
    is-equiv (Σ-fib-to-domain f)
  is-equiv-Σ-fib-to-domain f =
    is-equiv-has-inverse
      ( domain-to-Σ-fib f)
      ( right-inverse-domain-to-Σ-fib f)
      ( left-inverse-domain-to-Σ-fib f)

equiv-Σ-fib-to-domain :
  {i j : Level} {A : UU i} {B : UU j} (f : A → B ) → Σ B (fib f) ≃ A
equiv-Σ-fib-to-domain f =
  pair (Σ-fib-to-domain f) (is-equiv-Σ-fib-to-domain f)

-- Exercise 6.7

-- In this exercise we show that if a cartesian product is contractible, then so are its factors. We make use of the fact that contractible types are closed under retracts, just because that is a useful property to practice with. Other proofs are possible too.

abstract
  is-contr-left-factor-prod :
    {i j : Level} (A : UU i) (B : UU j) → is-contr (A × B) → is-contr A
  is-contr-left-factor-prod A B is-contr-AB =
    is-contr-retract-of
      ( A × B)
      ( pair
        ( λ x → pair x (pr2 (center is-contr-AB)))
        ( pair pr1 (λ x → refl)))
      ( is-contr-AB)

abstract
  is-contr-right-factor-prod :
    {i j : Level} (A : UU i) (B : UU j) → is-contr (A × B) → is-contr B
  is-contr-right-factor-prod A B is-contr-AB =
    is-contr-left-factor-prod B A
      ( is-contr-equiv
        ( A × B)
        ( equiv-swap-prod B A)
        ( is-contr-AB))

abstract
  is-contr-prod :
    {i j : Level} {A : UU i} {B : UU j} →
    is-contr A → is-contr B → is-contr (A × B)
  is-contr-prod {A = A} {B = B} is-contr-A is-contr-B =
    is-contr-equiv' B
      ( left-unit-law-Σ (λ x → B) is-contr-A)
      ( is-contr-B)

-- Exercise 6.8

-- Given any family B over A, there is a map from the fiber of the projection map (pr1 : Σ A B → A) to the type (B a), i.e. the fiber of B at a. In this exercise we define this map, and show that it is an equivalence, for every a : A.

fib-fam-fib-pr1 :
  {i j : Level} {A : UU i} (B : A → UU j)
  (a : A) → fib (pr1 {B = B}) a → B a
fib-fam-fib-pr1 B a (pair (pair x y) p) = tr B p y

fib-pr1-fib-fam :
  {i j : Level} {A : UU i} (B : A → UU j)
  (a : A) → B a → fib (pr1 {B = B}) a
fib-pr1-fib-fam B a b = pair (pair a b) refl

left-inverse-fib-pr1-fib-fam :
  {i j : Level} {A : UU i} (B : A → UU j) (a : A) →
  ((fib-pr1-fib-fam B a) ∘ (fib-fam-fib-pr1 B a)) ~ id
left-inverse-fib-pr1-fib-fam B a (pair (pair .a y) refl) = refl

right-inverse-fib-pr1-fib-fam :
  {i j : Level} {A : UU i} (B : A → UU j) (a : A) →
  ((fib-fam-fib-pr1 B a) ∘ (fib-pr1-fib-fam B a)) ~ id
right-inverse-fib-pr1-fib-fam B a b = refl

abstract
  is-equiv-fib-fam-fib-pr1 :
    {i j : Level} {A : UU i} (B : A → UU j) (a : A) →
    is-equiv (fib-fam-fib-pr1 B a)
  is-equiv-fib-fam-fib-pr1 B a =
    is-equiv-has-inverse
      ( fib-pr1-fib-fam B a)
      ( right-inverse-fib-pr1-fib-fam B a)
      ( left-inverse-fib-pr1-fib-fam B a)

equiv-fib-fam-fib-pr1 :
  {i j : Level} {A : UU i} (B : A → UU j) (a : A) →
  fib (pr1 {B = B}) a ≃ B a
equiv-fib-fam-fib-pr1 B a =
  pair (fib-fam-fib-pr1 B a) (is-equiv-fib-fam-fib-pr1 B a)

abstract
  is-equiv-fib-pr1-fib-fam :
    {i j : Level} {A : UU i} (B : A → UU j) (a : A) →
    is-equiv (fib-pr1-fib-fam B a)
  is-equiv-fib-pr1-fib-fam B a =
    is-equiv-has-inverse
      ( fib-fam-fib-pr1 B a)
      ( left-inverse-fib-pr1-fib-fam B a)
      ( right-inverse-fib-pr1-fib-fam B a)

equiv-fib-pr1-fib-fam :
  {i j : Level} {A : UU i} (B : A → UU j) (a : A) →
  B a ≃ fib (pr1 {B = B}) a
equiv-fib-pr1-fib-fam B a =
  pair (fib-pr1-fib-fam B a) (is-equiv-fib-pr1-fib-fam B a)

abstract
  is-equiv-pr1-is-contr :
    {i j : Level} {A : UU i} (B : A → UU j) →
    ((a : A) → is-contr (B a)) → is-equiv (pr1 {B = B})
  is-equiv-pr1-is-contr B is-contr-B =
    is-equiv-is-contr-map
      ( λ x → is-contr-equiv
        ( B x)
        ( equiv-fib-fam-fib-pr1 B x)
        ( is-contr-B x))

equiv-pr1 :
  {i j : Level} {A : UU i} {B : A → UU j} →
  ((a : A) → is-contr (B a)) → (Σ A B) ≃ A
equiv-pr1 is-contr-B = pair pr1 (is-equiv-pr1-is-contr _ is-contr-B)

abstract
  is-contr-is-equiv-pr1 :
    {i j : Level} {A : UU i} (B : A → UU j) →
    (is-equiv (pr1 {B = B})) → ((a : A) → is-contr (B a))
  is-contr-is-equiv-pr1 B is-equiv-pr1-B a =
    is-contr-equiv'
      ( fib pr1 a)
      ( equiv-fib-fam-fib-pr1 B a)
      ( is-contr-map-is-equiv is-equiv-pr1-B a)

right-unit-law-Σ :
  {i j : Level} {A : UU i} (B : A → UU j) →
  ((a : A) → is-contr (B a)) → (Σ A B) ≃ A
right-unit-law-Σ B is-contr-B =
  pair pr1 (is-equiv-pr1-is-contr B is-contr-B)


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

open import lib.Basics
open import lib.Relation

module lib.types.SetQuotient where

module _ {i} {A : Type i} {j} where

  private
    data #SetQuotient-aux (R : Rel A j) : Type i where
      #q[_] : A → #SetQuotient-aux R

    data #SetQuotient (R : Rel A j) : Type i where
      #setquot : #SetQuotient-aux R → (Unit → Unit) → #SetQuotient R

  SetQuotient : (R : Rel A j) → Type i
  SetQuotient = #SetQuotient

  module _ {R : Rel A j} where

    q[_] : (a : A) → SetQuotient R
    q[ a ] = #setquot #q[ a ] _

    postulate  -- HIT
      quot-rel : {a₁ a₂ : A} → R a₁ a₂ → q[ a₁ ] == q[ a₂ ]

    postulate  -- HIT
      SetQuotient-level : is-set (SetQuotient R)

    SetQuotient-is-set = SetQuotient-level

    module SetQuotElim {k} {P : SetQuotient R → Type k}
      (p : (x : SetQuotient R) → is-set (P x)) (q[_]* : (a : A) → P q[ a ])
      (rel* : ∀ {a₁ a₂} (r : R a₁ a₂) → q[ a₁ ]* == q[ a₂ ]* [ P ↓ quot-rel r ]) where

      f : Π (SetQuotient R) P
      f = f-aux phantom phantom where

        f-aux : Phantom p
          → Phantom {A = ∀ {a₁ a₂} (r : R a₁ a₂) → _} rel*
          → Π (SetQuotient R) P
        f-aux phantom phantom (#setquot #q[ a ] _) = q[ a ]*

      postulate  -- HIT
        quot-rel-β : ∀ {a₁ a₂} (r : R a₁ a₂) → apd f (quot-rel r) == rel* r

open SetQuotElim public renaming (f to SetQuot-elim)

module SetQuotRec {i} {A : Type i} {j} {R : Rel A j} {k} {B : Type k} (p : is-set B)
  (q[_]* : A → B) (rel* : ∀ {a₁ a₂} (r : R a₁ a₂) → q[ a₁ ]* == q[ a₂ ]*) where

  private
    module M = SetQuotElim (λ x → p) q[_]* (λ {a₁ a₂} r → ↓-cst-in (rel* r))

  f : SetQuotient R → B
  f = M.f

open SetQuotRec public renaming (f to SetQuot-rec)


-- A generic proof of confluence for a rewriting system with the diamond property.

module Confluence where

open import Prelude

postulate
  Tm : Set
  _=>_ : Tm -> Tm -> Set
  diamond : ∀{M N P : Tm} → (M => N) → (M => P) →
            Σ[ Q :: Tm ] (N => Q × P => Q)

data _=>*_ : Tm → Tm → Set where
  eval-refl : {e : Tm} → e =>* e
  eval-cons : {e e' e'' : Tm} →
              (S1 : e => e') → (D : e' =>* e'') → e =>* e''

strip : ∀{M N P : Tm} → (M => N) → (M =>* P) →
         Σ[ Q :: Tm ] (N =>* Q × P => Q)
strip S1 eval-refl = , (eval-refl , S1)
strip S1 (eval-cons S2 D) with diamond S1 S2
... | Q' , S1' , S2' with strip S2' D
... | Q , D1 , S' = Q , ((eval-cons S1' D1) , S')

confluence : ∀{M N P : Tm} → (M =>* N) → (M =>* P) →
             Σ[ Q :: Tm ] (N =>* Q × P =>* Q)
confluence eval-refl D2 = , (D2 , eval-refl)
confluence (eval-cons S1 D1) D2 with strip S1 D2
... | M' , D3 , S3 with confluence D1 D3
... | Q , D4 , D4' = Q , D4 , eval-cons S3 D4'


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

open import HoTT
open import cohomology.Theory

{- Cohomology groups of the n-torus (S¹)ⁿ.
 - We have Ĉᵏ(Tⁿ) == C⁰(S⁰)^(n choose' k) where _choose'_ defined as below.
 - This argument could give Cᵏ((Sᵐ)ⁿ) with a little more work. -}

module cohomology.Torus {i} (OT : OrdinaryTheory i) where

open OrdinaryTheory OT
open import cohomology.Sn OT
open import cohomology.SphereProduct cohomology-theory
open import cohomology.Unit cohomology-theory

{- Almost n choose k, but with n choose' O = 0 for any n. -}
_choose'_ : ℕ → ℤ → ℕ
n choose' (neg _) = 0
n choose' O = 0
n choose' pos O = n
O choose' (pos (S k)) = 0
S n choose' pos (S k) = (n choose' (pos k)) + (n choose' (pos (S k)))

_-⊙Torus : ℕ → Ptd i
O -⊙Torus = ⊙Lift ⊙Unit
(S n) -⊙Torus = (⊙Sphere {i} 1) ⊙× (n -⊙Torus)

C-nTorus : (k : ℤ) (n : ℕ)
  → C k (n -⊙Torus) == (C O (⊙Sphere 0)) ^ᴳ (n choose' k)

C-nTorus (neg k) O = C-Unit-is-trivial (neg k)

C-nTorus (neg k) (S n) =
  C-Sphere× (neg k) 1 (n -⊙Torus)
  ∙ ap (λ K → K ×ᴳ (C (neg k) (⊙Susp^ 1 (n -⊙Torus))
                    ×ᴳ C (neg k) (n -⊙Torus)))
       (C-Sphere-≠ (neg k) 1 (ℤ-neg≠pos _ _))
  ∙ ×ᴳ-unit-l {G = C (neg k) (⊙Susp (n -⊙Torus))
                   ×ᴳ C (neg k) (n -⊙Torus)}
  ∙ ap (λ K → C (neg k) (⊙Susp (n -⊙Torus)) ×ᴳ K)
        (C-nTorus (neg k) n)
  ∙ ×ᴳ-unit-r {G = C (neg k) (⊙Susp (n -⊙Torus))}
  ∙ C-Susp (neg (S k)) (n -⊙Torus)
  ∙ C-nTorus (neg (S k)) n

C-nTorus O O = C-Unit-is-trivial O

C-nTorus O (S n) =
  C-Sphere× O 1 (n -⊙Torus)
  ∙ ap (λ K → K ×ᴳ (C O (⊙Susp (n -⊙Torus)) ×ᴳ C O (n -⊙Torus)))
       (C-Sphere-≠ O 1 (ℤ-O≠pos _))
  ∙ ×ᴳ-unit-l {G = C O (⊙Susp (n -⊙Torus)) ×ᴳ C O (n -⊙Torus)}
  ∙ ap (λ K → C O (⊙Susp (n -⊙Torus)) ×ᴳ K)
       (C-nTorus O n)
  ∙ ×ᴳ-unit-r {G = C O (⊙Susp (n -⊙Torus))}
  ∙ C-Susp (neg O) (n -⊙Torus)
  ∙ C-nTorus (neg O) n

C-nTorus (pos O) O =
  C-Unit-is-trivial (pos O)

C-nTorus (pos O) (S n) =
  C-Sphere× (pos O) 1 (n -⊙Torus)
  ∙ ap (λ K → K ×ᴳ (C (pos O) (⊙Susp (n -⊙Torus))
                     ×ᴳ C (pos O) (n -⊙Torus)))
       (C-Sphere-diag 1)
  ∙ ap (λ K → C O (⊙Sphere O) ×ᴳ K)
       (ap2 _×ᴳ_
         (C-Susp O (n -⊙Torus) ∙ C-nTorus O n)
         (C-nTorus (pos O) n)
        ∙ ×ᴳ-unit-l {G = C O (⊙Sphere 0) ^ᴳ (n choose' pos O)})

C-nTorus (pos (S k)) O =
  C-Unit-is-trivial (pos (S k))

C-nTorus (pos (S k)) (S n) =
  C-Sphere× (pos (S k)) 1 (n -⊙Torus)
  ∙ ap (λ K → K ×ᴳ (C (pos (S k)) (⊙Susp (n -⊙Torus))
                     ×ᴳ C (pos (S k)) (n -⊙Torus)))
       (C-Sphere-≠ (pos (S k)) 1 (ℕ-S≠O k ∘ pos-injective (S k) 0))
  ∙ ×ᴳ-unit-l {G = (C (pos (S k)) (⊙Susp (n -⊙Torus))
                    ×ᴳ (C (pos (S k)) (n -⊙Torus)))}
  ∙ ap2 _×ᴳ_ (C-Susp (pos k) (n -⊙Torus) ∙ C-nTorus (pos k) n)
             (C-nTorus (pos (S k)) n)
  ∙ ^ᴳ-sum (C O (⊙Sphere 0)) (n choose' pos k) (n choose' pos (S k))


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of operations on floats
------------------------------------------------------------------------

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

module Data.Float.Properties where

open import Data.Bool.Base as Bool using (Bool)
open import Data.Float.Base
import Data.Word.Base as Word
import Data.Word.Properties as Wₚ
open import Relation.Nullary.Decidable as RN using (map′)
open import Relation.Binary
import Relation.Binary.Construct.On as On
open import Relation.Binary.PropositionalEquality

------------------------------------------------------------------------
-- Primitive properties

open import Agda.Builtin.Float.Properties
  renaming (primFloatToWord64Injective to toWord-injective)
  public

------------------------------------------------------------------------
-- Properties of _≈_

≈⇒≡ : _≈_ ⇒ _≡_
≈⇒≡ eq = toWord-injective _ _  (Wₚ.≈⇒≡ eq)

≈-reflexive : _≡_ ⇒ _≈_
≈-reflexive eq = Wₚ.≈-reflexive (cong toWord eq)

≈-refl : Reflexive _≈_
≈-refl = refl

≈-sym : Symmetric _≈_
≈-sym = sym

≈-trans : Transitive _≈_
≈-trans = trans

≈-subst : ∀ {ℓ} → Substitutive _≈_ ℓ
≈-subst P x≈y p = subst P (≈⇒≡ x≈y) p

infix 4 _≈?_
_≈?_ : Decidable _≈_
_≈?_ = On.decidable toWord Word._≈_ Wₚ._≈?_

≈-isEquivalence : IsEquivalence _≈_
≈-isEquivalence = record
  { refl  = λ {i} → ≈-refl {i}
  ; sym   = λ {i j} → ≈-sym {i} {j}
  ; trans = λ {i j k} → ≈-trans {i} {j} {k}
  }

≈-setoid : Setoid _ _
≈-setoid = record
  { isEquivalence = ≈-isEquivalence
  }

≈-isDecEquivalence : IsDecEquivalence _≈_
≈-isDecEquivalence = record
  { isEquivalence = ≈-isEquivalence
  ; _≟_           = _≈?_
  }

≈-decSetoid : DecSetoid _ _
≈-decSetoid = record
  { isDecEquivalence = ≈-isDecEquivalence
  }
------------------------------------------------------------------------
-- Properties of _≡_

infix 4 _≟_
_≟_ : DecidableEquality Float
x ≟ y = map′ ≈⇒≡ ≈-reflexive (x ≈? y)

≡-setoid : Setoid _ _
≡-setoid = setoid Float

≡-decSetoid : DecSetoid _ _
≡-decSetoid = decSetoid _≟_

------------------------------------------------------------------------
-- Boolean equality test.

infix 4 _==_
_==_ : Float → Float → Bool
w₁ == w₂ = RN.⌊ w₁ ≟ w₂ ⌋

------------------------------------------------------------------------
-- Properties of _<_

infix 4 _<?_
_<?_ : Decidable _<_
_<?_ = On.decidable toWord Word._<_ Wₚ._<?_

<-strictTotalOrder-≈ : StrictTotalOrder _ _ _
<-strictTotalOrder-≈ = On.strictTotalOrder Wₚ.<-strictTotalOrder-≈ toWord


module Tuples where

open import Haskell.Prelude

swap : a × b → b × a
swap (a , b) = b , a

{-# COMPILE AGDA2HS swap #-}

unit2unit : ⊤ → Tuple []
unit2unit tt = []

{-# COMPILE AGDA2HS unit2unit #-}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Vectors defined in terms of Data.Star
------------------------------------------------------------------------

module Data.Star.Vec where

open import Data.Star
open import Data.Star.Nat
open import Data.Star.Fin using (Fin)
open import Data.Star.Decoration
open import Data.Star.Pointer as Pointer hiding (lookup)
open import Data.Star.List using (List)
open import Relation.Binary
open import Relation.Binary.Consequences
open import Function
open import Data.Unit

-- The vector type. Vectors are natural numbers decorated with extra
-- information (i.e. elements).

Vec : Set → ℕ → Set
Vec a = All (λ _ → a)

-- Nil and cons.

[] : ∀ {a} → Vec a zero
[] = ε

infixr 5 _∷_

_∷_ : ∀ {a n} → a → Vec a n → Vec a (suc n)
x ∷ xs = ↦ x ◅ xs

-- Projections.

head : ∀ {a n} → Vec a (1# + n) → a
head (↦ x ◅ _) = x

tail : ∀ {a n} → Vec a (1# + n) → Vec a n
tail (↦ _ ◅ xs) = xs

-- Append.

infixr 5 _++_

_++_ : ∀ {a m n} → Vec a m → Vec a n → Vec a (m + n)
_++_ = _◅◅◅_

-- Safe lookup.

lookup : ∀ {a n} → Fin n → Vec a n → a
lookup i xs with Pointer.lookup i xs
... | result _ x = x

------------------------------------------------------------------------
-- Conversions

fromList : ∀ {a} → (xs : List a) → Vec a (length xs)
fromList ε        = []
fromList (x ◅ xs) = x ∷ fromList xs

toList : ∀ {a n} → Vec a n → List a
toList = gmap (const tt) decoration


data _≡_ {A : Set} (x : A) : A → Set where
  refl : x ≡ x

data Maybe (A : Set) : Set where
  nothing : Maybe A
  just : A → Maybe A

postulate
  String : Set

{-# BUILTIN STRING String #-}

infix 1000 ♯_

postulate
  ∞  : ∀ {a} (A : Set a) → Set a
  ♯_ : ∀ {a} {A : Set a} → A → ∞ A
  ♭  : ∀ {a} {A : Set a} → ∞ A → A

{-# BUILTIN INFINITY ∞  #-}
{-# BUILTIN SHARP    ♯_ #-}
{-# BUILTIN FLAT     ♭  #-}

infixr 5 _∷_

data Colist (A : Set) : Set where
  []  : Colist A
  _∷_ : (x : A) (xs : ∞ (Colist A)) → Colist A

postulate
  Char : Set

{-# BUILTIN CHAR Char #-}

Costring : Set
Costring = Colist Char

data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ

{-# BUILTIN NATURAL ℕ #-}

data List {a} (A : Set a) : Set a where
  []  : List A
  _∷_ : (x : A) (xs : List A) → List A

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

private
 primitive
  primStringAppend   : String → String → String
  primStringToList   : String → List Char
  primStringFromList : List Char → String

infixr 5 _++_

_++_ : String → String → String
_++_ = primStringAppend

toList : String → List Char
toList = primStringToList

fromList : List Char → String
fromList = primStringFromList

fromListToColist : {A : Set} → List A → Colist A
fromListToColist []       = []
fromListToColist (x ∷ xs) = x ∷ ♯ fromListToColist xs

toCostring : String → Costring
toCostring s = fromListToColist (toList s)

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

costringToString : Costring → ℕ → Maybe String
costringToString []       _       = just ""
costringToString (x ∷ xs) 0       with ♭ xs
... | []    = just (fromList (x ∷ []))
... | _ ∷ _ = nothing
costringToString (x ∷ xs) (suc n) with costringToString (♭ xs) n
... | nothing  = nothing
... | just xs′ = just (fromList (x ∷ []) ++ xs′)

test0 : costringToString (toCostring "") 0 ≡ just ""
test0 = refl

test1 : costringToString (toCostring "apa") 3 ≡ just "apa"
test1 = refl


{-# OPTIONS --without-K  #-}
module algebra.group.morphism where

open import level
open import algebra.group.core
open import algebra.monoid.morphism

module _ {i}{j}
         {X : Set i}⦃ sX : IsGroup X ⦄
         {Y : Set j}⦃ sY : IsGroup Y ⦄ where
  open IsGroup ⦃ ... ⦄

  IsGroupMorphism : (X → Y) → Set (i ⊔ j)
  IsGroupMorphism f = IsMonoidMorphism f


{-# OPTIONS --without-K #-}
module hott.level.sets where

open import hott.level.sets.core public
open import hott.level.sets.extra public


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

module MorePropAlgebra.Bundles where

open import Agda.Primitive renaming (_⊔_ to ℓ-max; lsuc to ℓ-suc; lzero to ℓ-zero)

private
  variable
    ℓ ℓ' : Level

open import Cubical.Foundations.Everything renaming (_⁻¹ to _⁻¹ᵖ; assoc to ∙-assoc)
open import Cubical.Relation.Nullary.Base renaming (¬_ to ¬ᵗ_)-- ¬ᵗ_
open import Cubical.Foundations.Logic
open import MoreLogic.Definitions
open import Utils
open import MorePropAlgebra.Structures

-- taken from the cubical standard library and adapted to hProps:
-- Semigroup
-- Monoid
-- Group
-- AbGroup
-- Ring
-- CommRing

record Semigroup : Type (ℓ-suc ℓ) where
  constructor semigroup
  field
    Carrier      : Type ℓ
    _·_          : Carrier → Carrier → Carrier
    is-Semigroup : IsSemigroup _·_

  infixl 7 _·_

  open IsSemigroup is-Semigroup public

record Monoid : Type (ℓ-suc ℓ) where
  constructor monoid
  field
    Carrier   : Type ℓ
    ε         : Carrier
    _·_       : Carrier → Carrier → Carrier
    is-Monoid : IsMonoid ε _·_

  infixl 7 _·_

  open IsMonoid is-Monoid public

record Group : Type (ℓ-suc ℓ) where
  constructor group
  field
    Carrier  : Type ℓ
    0g       : Carrier
    _+_      : Carrier → Carrier → Carrier
    -_       : Carrier → Carrier
    is-Group : IsGroup 0g _+_ -_

  infix  8 -_
  infixr 7 _+_

  open IsGroup is-Group public

record AbGroup : Type (ℓ-suc ℓ) where
  constructor abgroup
  field
    Carrier    : Type ℓ
    0g         : Carrier
    _+_        : Carrier → Carrier → Carrier
    -_         : Carrier → Carrier
    is-AbGroup : IsAbGroup 0g _+_ -_

  infix  8 -_
  infixl 7 _+_

  open IsAbGroup is-AbGroup public

record Ring : Type (ℓ-suc ℓ) where
  constructor ring
  field
    Carrier : Type ℓ
    0r      : Carrier
    1r      : Carrier
    _+_     : Carrier → Carrier → Carrier
    _·_     : Carrier → Carrier → Carrier
    -_      : Carrier → Carrier
    is-Ring : IsRing 0r 1r _+_ _·_ -_

  infix  8 -_
  infixl 7 _·_
  infixl 6 _+_

  open IsRing is-Ring public

record CommRing : Type (ℓ-suc ℓ) where
  constructor commring
  field
    Carrier     : Type ℓ
    0r          : Carrier
    1r          : Carrier
    _+_         : Carrier → Carrier → Carrier
    _·_         : Carrier → Carrier → Carrier
    -_          : Carrier → Carrier
    is-CommRing : IsCommRing 0r 1r _+_ _·_ -_

  infix  8 -_
  infixl 7 _·_
  infixl 6 _+_

  open IsCommRing is-CommRing public

record ClassicalField : Type (ℓ-suc ℓ) where
  field
    Carrier : Type ℓ
    0f      : Carrier
    1f      : Carrier
    _+_     : Carrier → Carrier → Carrier
    _·_     : Carrier → Carrier → Carrier
    -_      : Carrier → Carrier
    _⁻¹     : (x : Carrier) → {{ ! ¬ᵗ(x ≡ 0f) }} → Carrier -- WARNING: we do not have `_⁻¹` as an assuption
    is-ClassicalField : [ isClassicalField 0f 1f _+_ _·_ -_ _⁻¹ ]

  infix  9 _⁻¹
  infix  8 -_
  infixl 7 _·_
  infixl 6 _+_

  open IsClassicalField is-ClassicalField public

record ConstructiveField : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  constructor constructivefield
  field
    Carrier : Type ℓ
    0f      : Carrier
    1f      : Carrier
    _+_     : Carrier → Carrier → Carrier
    _·_     : Carrier → Carrier → Carrier
    -_      : Carrier → Carrier
    _#_     : hPropRel Carrier Carrier ℓ'
    is-ConstructiveField : [ isConstructiveField 0f 1f _+_ _·_ -_ _#_ ]

  infixl 7 _·_
  infix  6 -_
  infixl 5 _+_
  infixl 4 _#_

  open IsConstructiveField is-ConstructiveField public

record Lattice : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  constructor lattice
  field
    Carrier : Type ℓ
    _≤_ : hPropRel Carrier Carrier ℓ'
    min max : Carrier → Carrier → Carrier
    is-Lattice : [ isLattice _≤_ min max ]

  infixl 4 _≤_

  open IsLattice is-Lattice public

record AlmostPartiallyOrderedField : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  constructor almostpartiallyorderedfield
  field
    Carrier : Type ℓ
    0f 1f   : Carrier
    _+_     : Carrier → Carrier → Carrier
    -_      : Carrier → Carrier
    _·_     : Carrier → Carrier → Carrier
    min max : Carrier → Carrier → Carrier
    _<_     : hPropRel Carrier Carrier ℓ'
  field
    is-AlmostPartiallyOrderedField : [ isAlmostPartiallyOrderedField 0f 1f _+_ _·_ -_ _<_ min max {- _⁻¹ -} ] -- defines `_≤_` and `_#_`

  infixl 7 _·_
  infix  6 -_
  infixl 5 _+_
  infixl 4 _<_

  open IsAlmostPartiallyOrderedField is-AlmostPartiallyOrderedField public

record PartiallyOrderedField : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  constructor partiallyorderedfield
  field
    Carrier : Type ℓ
    0f 1f   : Carrier
    _+_     : Carrier → Carrier → Carrier
    -_      : Carrier → Carrier
    _·_     : Carrier → Carrier → Carrier
    min max : Carrier → Carrier → Carrier
    _<_     : hPropRel Carrier Carrier ℓ'

  field
    is-PartiallyOrderedField : [ isPartiallyOrderedField 0f 1f _+_ _·_ -_ _<_ min max ] -- defines `_≤_` and `_#_`

  infixl 7 _·_
  infix  6 -_
  infixl 5 _+_
  infixl 4 _<_

  open IsPartiallyOrderedField is-PartiallyOrderedField public

  -- abstract
  --   -- NOTE: there might be some reason not to "do" (or "open") all the theory of a record within that record
  --   +-preserves-< : ∀ a b x → a < b → a + x < b + x
  --   +-preserves-< a b x a<b = (
  --      a            <  b            ⇒⟨ transport (λ i → sym (fst (+-identity a)) i < sym (fst (+-identity b)) i) ⟩
  --      a +    0f    <  b +    0f    ⇒⟨ transport (λ i → a + sym (+-rinv x) i < b + sym (+-rinv x) i) ⟩
  --      a + (x  - x) <  b + (x  - x) ⇒⟨ transport (λ i → +-assoc a x (- x) i < +-assoc b x (- x) i) ⟩
  --     (a +  x) - x  < (b +  x) - x  ⇒⟨ +-<-extensional (- x) (a + x) (- x) (b + x) ⟩
  --     (a + x < b + x) ⊎ (- x < - x) ⇒⟨ (λ{ (inl a+x<b+x) → a+x<b+x -- somehow ⊥-elim needs a hint in the next line
  --                                        ; (inr  -x<-x ) → ⊥-elim {A = λ _ → (a + x < b + x)} (<-irrefl (- x) -x<-x) }) ⟩
  --      a + x < b + x ◼) a<b
  --
  --   ≤-isPreorder : IsPreorder _≤_
  --   ≤-isPreorder = ≤-isPreorder' {_<_ = _<_} {<-isStrictPartialOrder}


{-# OPTIONS --without-K #-}
open import HoTT.Base
open import HoTT.Equivalence

module HoTT.Equivalence.Transport where

open variables

transport-equiv : {x y : A} → x == y → P x ≃ P y
transport-equiv {A = A} {P = P} p = f , qinv→isequiv (g , η p , ε p)
  where
  f = transport P p
  g = transport P (p ⁻¹)
  variable x y : A
  η : (p : x == y) → transport P (p ⁻¹) ∘ transport P p ~ id
  η refl _ = refl
  ε : (p : x == y) → transport P p ∘ transport P (p ⁻¹) ~ id
  ε refl _ = refl


------------------------------------------------------------------------------
-- First-Order Theory of Combinators (FOTC)
------------------------------------------------------------------------------

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

-- Code accompanying the paper "Combining Interactive and Automatic
-- Reasoning in First Order Theories of Functional Programs" by Ana
-- Bove, Peter Dybjer and Andrés Sicard-Ramírez (FoSSaCS 2012).

-- The code presented here does not match the paper exactly.

module FOTC.README where

------------------------------------------------------------------------------
-- Description

-- Verification of functional programs using a version of Azcel's
-- First-Order Theory of Combinators and showing the combination of
-- interactive proofs with automatics proofs carried out by
-- first-order automatic theorem provers (ATPs).

------------------------------------------------------------------------------
-- For the paper, prerequisites, tested versions of the ATPs and use,
-- see https://github.com/asr/fotc/.

------------------------------------------------------------------------------
-- Conventions

-- If the module's name ends in 'I' the module contains interactive
-- proofs, if it ends in 'ATP' the module contains combined proofs,
-- otherwise the module contains definitions and/or interactive proofs
-- that are used by the interactive and combined proofs.

------------------------------------------------------------------------------
-- Base axioms
open import FOTC.Base

-- Properties for the base axioms

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

-- Axioms for lists, colists, streams, etc.
open import FOTC.Base.List

-- Properties for axioms for lists, colists, streams, etc
open import FOTC.Base.List.PropertiesATP
open import FOTC.Base.List.PropertiesI

------------------------------------------------------------------------------
-- Booleans

-- The axioms
open import FOTC.Data.Bool

-- The inductive predicate
open import FOTC.Data.Bool.Type

-- Properties
open import FOTC.Data.Bool.PropertiesATP
open import FOTC.Data.Bool.PropertiesI

------------------------------------------------------------------------------
-- Natural numbers

-- The axioms
open import FOTC.Data.Nat

-- The inductive predicate
open import FOTC.Data.Nat.Type

-- Properties
open import FOTC.Data.Nat.PropertiesATP
open import FOTC.Data.Nat.PropertiesI

open import FOTC.Data.Nat.PropertiesByInductionATP
open import FOTC.Data.Nat.PropertiesByInductionI

-- Divisibility relation
open import FOTC.Data.Nat.Divisibility.By0.PropertiesATP
open import FOTC.Data.Nat.Divisibility.By0.PropertiesI
open import FOTC.Data.Nat.Divisibility.NotBy0.PropertiesATP
open import FOTC.Data.Nat.Divisibility.NotBy0.PropertiesI

-- Induction
open import FOTC.Data.Nat.Induction.Acc.WF-I
open import FOTC.Data.Nat.Induction.NonAcc.LexicographicI

-- Inequalites
open import FOTC.Data.Nat.Inequalities.EliminationPropertiesATP
open import FOTC.Data.Nat.Inequalities.EliminationPropertiesI
open import FOTC.Data.Nat.Inequalities.PropertiesATP
open import FOTC.Data.Nat.Inequalities.PropertiesI

-- Unary numbers
open import FOTC.Data.Nat.UnaryNumbers.Inequalities.PropertiesATP
open import FOTC.Data.Nat.UnaryNumbers.TotalityATP

------------------------------------------------------------------------------
-- Lists

-- The axioms
open import FOTC.Data.List

-- The inductive predicate
open import FOTC.Data.List.Type

-- Properties
open import FOTC.Data.List.PropertiesATP
open import FOTC.Data.List.PropertiesI

-- Well-founded induction
open import FOTC.Data.List.WF-Relation.LT-Cons.Induction.Acc.WF-I
open import FOTC.Data.List.WF-Relation.LT-Cons.PropertiesI
open import FOTC.Data.List.WF-Relation.LT-Length.Induction.Acc.WF-I
open import FOTC.Data.List.WF-Relation.LT-Length.PropertiesI

------------------------------------------------------------------------------
-- Lists of natural numbers

-- The inductive predicate
open import FOTC.Data.Nat.List

-- Properties
open import FOTC.Data.Nat.List.PropertiesATP
open import FOTC.Data.Nat.List.PropertiesI

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

-- Some axioms
open import FOTC.Data.Conat

-- The co-inductive predicate
open import FOTC.Data.Conat.Type

-- Properties
open import FOTC.Data.Conat.PropertiesATP
open import FOTC.Data.Conat.PropertiesI

-- Equality
open import FOTC.Data.Conat.Equality.Type

-- Equality properties
open import FOTC.Data.Conat.Equality.PropertiesATP
open import FOTC.Data.Conat.Equality.PropertiesI

------------------------------------------------------------------------------
-- Streams

-- Some axioms
open import FOTC.Data.Stream

-- The co-inductive predicate
open import FOTC.Data.Stream.Type

-- Properties
open import FOTC.Data.Stream.PropertiesATP
open import FOTC.Data.Stream.PropertiesI

-- Equality properties
open import FOTC.Data.Stream.Equality.PropertiesATP
open import FOTC.Data.Stream.Equality.PropertiesI

------------------------------------------------------------------------------
-- Bisimilary relation

-- The co-inductive predicate
open import FOTC.Relation.Binary.Bisimilarity.Type

-- Properties
open import FOTC.Relation.Binary.Bisimilarity.PropertiesATP
open import FOTC.Relation.Binary.Bisimilarity.PropertiesI

------------------------------------------------------------------------------
-- Verification of programs

-- Burstall's sort list algorithm: A structurally recursive algorithm
open import FOTC.Program.SortList.CorrectnessProofATP
open import FOTC.Program.SortList.CorrectnessProofI

-- The division algorithm: A non-structurally recursive algorithm
open import FOTC.Program.Division.CorrectnessProofATP
open import FOTC.Program.Division.CorrectnessProofI

-- The GCD algorithm: A non-structurally recursive algorithm
open import FOTC.Program.GCD.Partial.CorrectnessProofATP
open import FOTC.Program.GCD.Partial.CorrectnessProofI
open import FOTC.Program.GCD.Total.CorrectnessProofATP
open import FOTC.Program.GCD.Total.CorrectnessProofI

-- The nest function: A very simple function with nested recursion
open import FOTC.Program.Nest.PropertiesATP

-- The McCarthy 91 function: A function with nested recursion
open import FOTC.Program.McCarthy91.PropertiesATP

-- The mirror function: A function with higher-order recursion
open import FOTC.Program.Mirror.PropertiesATP
open import FOTC.Program.Mirror.PropertiesI

-- The map-iterate property: A property using co-induction
open import FOTC.Program.MapIterate.MapIterateATP
open import FOTC.Program.MapIterate.MapIterateI

-- The alternating bit protocol: A program using induction and co-induction
open import FOTC.Program.ABP.CorrectnessProofATP
open import FOTC.Program.ABP.CorrectnessProofI

-- The iter₀ function: A partial function
open import FOTC.Program.Iter0.PropertiesATP
open import FOTC.Program.Iter0.PropertiesI

-- The Collatz function: A function without a termination proof
open import FOTC.Program.Collatz.PropertiesATP
open import FOTC.Program.Collatz.PropertiesI


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

open import lib.Basics
open import lib.types.Group
open import lib.groups.Homomorphism
open import lib.types.TwoSemiCategory
open import lib.two-semi-categories.Functor

module lib.two-semi-categories.GroupToCategory where

group-to-cat : ∀ {i} → Group i → TwoSemiCategory lzero i
group-to-cat G =
  record
  { El = ⊤
  ; Arr = λ _ _ → G.El
  ; Arr-level = λ _ _ → raise-level 0 G.El-level
  ; two-semi-cat-struct =
    record
    { comp = G.comp
    ; assoc = G.assoc
    ; pentagon-identity = λ _ _ _ _ → =ₛ-in (prop-path (has-level-apply G.El-level _ _) _ _)
    }
  }
  where
    module G = Group G

homomorphism-to-functor : ∀ {i j} {G : Group i} {H : Group j}
  → G →ᴳ H
  → TwoSemiFunctor (group-to-cat G) (group-to-cat H)
homomorphism-to-functor {G = G} {H = H} φ =
  record
  { F₀ = idf ⊤
  ; F₁ = φ.f
  ; pres-comp = φ.pres-comp
  ; pres-comp-coh = λ _ _ _ → =ₛ-in $ prop-path (has-level-apply H.El-level _ _) _ _
  }
  where
    module G = Group G
    module H = Group H
    module φ = GroupHom φ


{-# OPTIONS --prop --rewriting #-}

module Examples.Sorting.Parallel where

open import Examples.Sorting.Parallel.Comparable

open import Calf costMonoid
open import Calf.Types.Nat
open import Calf.Types.List

open import Relation.Binary.PropositionalEquality as Eq using (_≡_)
open import Data.Product using (_,_)
open import Data.Nat using (z≤n; s≤s)

test/forward  = 1 ∷ 2 ∷ 3 ∷ 4 ∷ 5 ∷ 6 ∷ 7 ∷ 8 ∷ 9 ∷ 10 ∷ 11 ∷ 12 ∷ 13 ∷ 14 ∷ 15 ∷ 16 ∷ []
test/backward = 16 ∷ 15 ∷ 14 ∷ 13 ∷ 12 ∷ 11 ∷ 10 ∷ 9 ∷ 8 ∷ 7 ∷ 6 ∷ 5 ∷ 4 ∷ 3 ∷ 2 ∷ 1 ∷ []
test/shuffled = 4 ∷ 8 ∷ 12 ∷ 16 ∷ 13 ∷ 3 ∷ 5 ∷ 14 ∷ 9 ∷ 6 ∷ 7 ∷ 10 ∷ 11 ∷ 1 ∷ 2 ∷ 15 ∷ []

module Ex/InsertionSort where
  import Examples.Sorting.Parallel.InsertionSort NatComparable as Sort

  list' = list nat

  ex/insert : cmp (F list')
  ex/insert = Sort.insert 3 (1 ∷ 2 ∷ 4 ∷ [])

  ex/sort : cmp (F list')
  ex/sort = Sort.sort (1 ∷ 5 ∷ 3 ∷ 1 ∷ 2 ∷ [])

  ex/sort/forward : cmp (F list')
  ex/sort/forward = Sort.sort test/forward  -- cost: 15 , 15

  ex/sort/backward : cmp (F list')
  ex/sort/backward = Sort.sort test/backward  -- cost: 120 , 120

  ex/sort/shuffled : cmp (F list')
  ex/sort/shuffled = Sort.sort test/shuffled  -- cost: 76 , 76

module Ex/MergeSort where
  import Examples.Sorting.Parallel.MergeSort NatComparable as Sort

  list' = list nat

  ex/split : cmp (F Sort.pair)
  ex/split = Sort.split (6 ∷ 2 ∷ 8 ∷ 3 ∷ 1 ∷ 8 ∷ 5 ∷ [])

  ex/merge : cmp (F list')
  ex/merge = Sort.merge (2 ∷ 3 ∷ 6 ∷ 8 ∷ [] , 1 ∷ 5 ∷ 8 ∷ [])

  ex/sort : cmp (F list')
  ex/sort = Sort.sort (1 ∷ 5 ∷ 3 ∷ 1 ∷ 2 ∷ [])

  ex/sort/forward : cmp (F list')
  ex/sort/forward = Sort.sort test/forward  -- cost: 32, 15

  ex/sort/backward : cmp (F list')
  ex/sort/backward = Sort.sort test/backward  -- cost: 32, 15

  ex/sort/shuffled : cmp (F list')
  ex/sort/shuffled = Sort.sort test/shuffled  -- cost: 47, 26

module Ex/MergeSortPar where
  import Examples.Sorting.Parallel.MergeSortPar NatComparable as Sort

  list' = list nat

  ex/split : cmp (F Sort.pair)
  ex/split = Sort.split (6 ∷ 2 ∷ 8 ∷ 3 ∷ 1 ∷ 8 ∷ 5 ∷ [])

  ex/splitMid : cmp (F Sort.triple)
  ex/splitMid = Sort.splitMid test/forward (s≤s z≤n)

  ex/splitBy : cmp (F Sort.pair)
  ex/splitBy = Sort.splitBy test/forward 5

  ex/merge : cmp (F list')
  ex/merge = Sort.merge (2 ∷ 3 ∷ 6 ∷ 8 ∷ [] , 1 ∷ 5 ∷ 8 ∷ [])

  ex/sort : cmp (F list')
  ex/sort = Sort.sort (1 ∷ 5 ∷ 3 ∷ 1 ∷ 2 ∷ [])

  ex/sort/forward : cmp (F list')
  ex/sort/forward = Sort.sort test/forward  -- cost: 40, 21

  ex/sort/backward : cmp (F list')
  ex/sort/backward = Sort.sort test/backward  -- cost: 40, 21

  ex/sort/shuffled : cmp (F list')
  ex/sort/shuffled = Sort.sort test/shuffled  -- cost: 43, 17

module SortEquivalence (M : Comparable) where
  open Comparable M
  open import Examples.Sorting.Parallel.Core M

  import Examples.Sorting.Parallel.InsertionSort M as ISort
  import Examples.Sorting.Parallel.MergeSort     M as MSort
  import Examples.Sorting.Parallel.MergeSortPar  M as PSort

  isort≡msort : ◯ (ISort.sort ≡ MSort.sort)
  isort≡msort = IsSort⇒≡ ISort.sort ISort.sort/correct MSort.sort MSort.sort/correct

  msort≡psort : ◯ (MSort.sort ≡ PSort.sort)
  msort≡psort = IsSort⇒≡ MSort.sort MSort.sort/correct PSort.sort PSort.sort/correct