module Base.Free.Instance.Maybe where

open import Data.Unit    using (⊤; tt)
open import Data.Empty   using (⊥)

open import Base.Free    using (Free; pure; impure)
open import Base.Partial using (Partial)
open        Partial

-- Representation of the `Maybe` monad using Free.
Shape : Set
Shape = ⊤

Position : Shape → Set
Position _ = ⊥

Maybe : Set → Set
Maybe = Free Shape Position

Nothing : ∀ {A} → Maybe A
Nothing = impure tt λ()

Just : ∀ {A} → A → Maybe A
Just x = pure x

instance
  maybePartial : Partial Shape Position
  undefined maybePartial   = Nothing
  error     maybePartial _ = Nothing


postulate
  A : Set
  P : A → Set

variable
  x : A
  y : P x

data D₁ {x : A} : P x → Set where
  z : D₁ y
  s : D₁ y → D₁ y

data D₂ : {x : A} → P x → Set where
  z : D₂ y
  s : D₂ y → D₂ y


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

module Data.Bool where

open import Data.Bool.Base public
open import Data.Bool.Truth public


open import Prelude
open import MJ.Classtable.Core

module MJ.LexicalScope c where

open import Data.List
open import Data.List.Membership.Propositional
open import MJ.Types

Ctx : Set
Ctx = List (Ty c)

Var : Ctx → Ty c → Set
Var Γ a = a ∈ Γ

_+local_ : Ctx → Ty c → Ctx
_+local_ Γ a = a ∷ Γ


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties for Conats
------------------------------------------------------------------------

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

module Codata.Conat.Properties where

open import Data.Nat
open import Codata.Thunk
open import Codata.Conat
open import Codata.Conat.Bisimilarity
open import Function
open import Relation.Nullary
open import Relation.Binary

sℕ≤s⁻¹ : ∀ {m n} → suc m ℕ≤ suc n → m ℕ≤ n .force
sℕ≤s⁻¹ (sℕ≤s p) = p

_ℕ≤?_ : Decidable _ℕ≤_
zero  ℕ≤? n       = yes zℕ≤n
suc m ℕ≤? zero    = no (λ ())
suc m ℕ≤? suc n with m ℕ≤? n .force
... | yes p = yes (sℕ≤s p)
... | no ¬p = no (¬p ∘′ sℕ≤s⁻¹)

0ℕ+-identity : ∀ {i n} → i ⊢ 0 ℕ+ n ≈ n
0ℕ+-identity = refl

+ℕ0-identity : ∀ {i n} → i ⊢ n +ℕ 0 ≈ n
+ℕ0-identity {n = zero}  = zero
+ℕ0-identity {n = suc n} = suc λ where .force → +ℕ0-identity


module BuiltinConstructorsNeededForLiterals where

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

{-# BUILTIN NATURAL Nat #-}

data ⊥ : Set where

empty : Nat → ⊥
empty (zero n) = empty n
empty (suc n) = empty n

bad : ⊥
bad = empty 0


------------------------------------------------------------------------
-- Quotients, defined as families of equivalence classes
------------------------------------------------------------------------

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

-- Partly based on the presentation of quotients in the HoTT book.
-- Perhaps that presentation is partly based on work by Voevodsky.

-- The generalisation from propositional equivalence relations to
-- "strong" equivalence relations is my own. In light of the results
-- below I see little use for this generalisation…

open import Equality

module Quotient.Families-of-equivalence-classes
  {r} (eq : ∀ {a p} → Equality-with-J a p r) where

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

open import Bijection eq as Bij using (_↔_)
open import Bool eq
private
  module D = Derived-definitions-and-properties eq
  open D hiding (elim)
open import Equality.Decidable-UIP eq using (Constant)
open import Equality.Decision-procedures eq
import Equality.Groupoid eq as EG
open import Equivalence eq as Eq using (_≃_)
open import Equivalence-relation eq
open import Fin eq
open import Function-universe eq as F hiding (_∘_)
open import Groupoid
open import H-level eq as H-level
open import H-level.Closure eq
open import H-level.Truncation.Church eq as Trunc hiding (rec)
open import Nat eq as Nat
open import Surjection eq using (_↠_)
open import Univalence-axiom eq

------------------------------------------------------------------------
-- Strong equivalence relations

mutual

  -- A strengthening of the concept of "equivalence relation".

  Strong-equivalence :
    ∀ {a r} {A : Type a} →
    (A → A → Type r) → Type (a ⊔ lsuc r)
  Strong-equivalence = Strong-equivalence-with equivalence

  -- A generalisation of "strong equivalence".

  Strong-equivalence-with :
    ∀ {a r} {A : Type a} →
    Kind → (A → A → Type r) → Type (a ⊔ lsuc r)
  Strong-equivalence-with k R = ∀ {x y} → R x y ↝[ k ] (R x ≡ R y)

-- Strong equivalence relations (with equivalence) are strong
-- equivalence relations with any kind.

strong-equivalence⇒strong-equivalence-with :
  ∀ {k a r} {A : Type a} {R : A → A → Type r} →
  Strong-equivalence R → Strong-equivalence-with k R
strong-equivalence⇒strong-equivalence-with strong-equivalence =
  from-equivalence strong-equivalence

-- Strong equivalence relations with logical equivalence are
-- equivalence relations.

strong-equivalence-with-⇔⇒equivalence :
  ∀ {a r} {A : Type a} {R : A → A → Type r} →
  Strong-equivalence-with logical-equivalence R →
  Is-equivalence-relation R
strong-equivalence-with-⇔⇒equivalence {R = R} strong-equivalence =
  record
    { reflexive = λ {x} →
                   $⟨ refl (R x) ⟩
        R x ≡ R x  ↝⟨ to-implication $ inverse strong-equivalence ⟩□
        R x x      □
    ; symmetric = λ {x y} →
        R x y      ↝⟨ to-implication strong-equivalence ⟩
        R x ≡ R y  ↝⟨ sym ⟩
        R y ≡ R x  ↝⟨ to-implication $ inverse strong-equivalence ⟩□
        R y x      □
    ; transitive = λ {x y z} Rxy Ryz →
       to-implication (inverse strong-equivalence) (
         R x  ≡⟨ to-implication strong-equivalence Rxy ⟩
         R y  ≡⟨ to-implication strong-equivalence Ryz ⟩∎
         R z  ∎)
    }

-- Strong equivalence relations are equivalence relations.

strong-equivalence⇒equivalence :
  ∀ {a r} {A : Type a} {R : A → A → Type r} →
  Strong-equivalence R →
  Is-equivalence-relation R
strong-equivalence⇒equivalence =
  strong-equivalence-with-⇔⇒equivalence ∘
  strong-equivalence⇒strong-equivalence-with

-- A relation that is an equivalence relation, and a family of
-- propositions, is a strong equivalence relation (assuming
-- extensionality and univalence).

propositional-equivalence⇒strong-equivalence :
  ∀ {a r} {A : Type a} {R : A → A → Type r} →
  Extensionality (a ⊔ r) (lsuc r) →
  Univalence r →
  Is-equivalence-relation R →
  (∀ x y → Is-proposition (R x y)) →
  Strong-equivalence R
propositional-equivalence⇒strong-equivalence
  {a} {r} {R = R} ext univ R-equiv R-prop {x = x} {y = y} =

  Eq.↔⇒≃ (record
    { surjection = record
      { logical-equivalence = record
        { to = λ Rxy → apply-ext (lower-extensionality r lzero ext) λ z →
                 ≃⇒≡ univ $
                 _↔_.to (Eq.⇔↔≃ (lower-extensionality a _ ext)
                                (R-prop x z) (R-prop y z))
                 (R x z  ↝⟨ record { to   = transitive (symmetric Rxy)
                                   ; from = transitive Rxy
                                   } ⟩□
                  R y z  □)
        ; from = λ Rx≡Ry →        $⟨ reflexive ⟩
                           R y y  ↝⟨ subst (_$ y) (sym Rx≡Ry) ⟩□
                           R x y  □
        }
      ; right-inverse-of = λ _ →
          H-level.respects-surjection
            (_≃_.surjection $ Eq.extensionality-isomorphism
                                (lower-extensionality r lzero ext))
            1
            (Π-closure (lower-extensionality r lzero ext) 1 λ z →
             H-level-H-level-≡ˡ
               (lower-extensionality a _ ext)
               univ 0 (R-prop x z))
            _ _
      }
    ; left-inverse-of = λ _ → R-prop x y _ _
    })
  where
  open Is-equivalence-relation R-equiv

-- _≡_ is a strong equivalence relation (assuming extensionality and
-- univalence).

equality-strong-equivalence :
  ∀ {a} {A : Type a} →
  Extensionality a (lsuc a) →
  Univalence a →
  Strong-equivalence (_≡_ {A = A})
equality-strong-equivalence ext univ {x = x} {y = y} =
  x ≡ y                      ↝⟨ inverse $ Π≡≃≡-↔-≡ _ _ (lower-extensionality lzero _ ext) ⟩
  (∀ z → (z ≡ x) ≃ (z ≡ y))  ↝⟨ (∀-cong (lower-extensionality lzero _ ext) λ _ → Eq.↔⇒≃ $
                                 Eq.≃-preserves-bijections (lower-extensionality lzero _ ext)
                                   (Groupoid.⁻¹-bijection (EG.groupoid _))
                                   (Groupoid.⁻¹-bijection (EG.groupoid _))) ⟩
  (∀ z → (x ≡ z) ≃ (y ≡ z))  ↝⟨ (∀-cong ext λ _ → inverse $ ≡≃≃ univ) ⟩
  (∀ z → (x ≡ z) ≡ (y ≡ z))  ↝⟨ Eq.extensionality-isomorphism ext ⟩□
  (x ≡_) ≡ (y ≡_)            □

-- If λ (_ _ : ⊤) → Fin n is a strong equivalence relation, then n is
-- equal to n ! (assuming extensionality and univalence).

const-Fin-strong-equivalence⇒≡! :
  Extensionality (# 0) (# 1) →
  Univalence (# 0) →
  ∀ n → Strong-equivalence (λ (_ _ : ⊤) → Fin n) → n ≡ n !
const-Fin-strong-equivalence⇒≡! ext univ n strong-equivalence =
  _⇔_.to isomorphic-same-size (
    Fin n                          ↔⟨ strong-equivalence ⟩
    const (Fin n) ≡ const (Fin n)  ↔⟨ inverse $ Eq.extensionality-isomorphism ext ⟩
    (⊤ → Fin n ≡ Fin n)            ↝⟨ Π-left-identity ⟩
    Fin n ≡ Fin n                  ↝⟨ [Fin≡Fin]↔Fin! (lower-extensionality _ _ ext) univ n ⟩
    Fin (n !)                      □)

-- Thus there is at least one equivalence relation that is not a
-- strong equivalence relation (assuming extensionality and
-- univalence).

equivalence-but-not-strong-equivalence :
  Extensionality (# 0) (# 1) →
  Univalence (# 0) →
  ∃ λ (A : Type) →
  ∃ λ (R : A → A → Type) →
    (∀ {x} → R x x) ×
    (∀ {x y} → R x y → R y x) ×
    (∀ {x y z} → R x y → R y z → R x z) ×
    ¬ Strong-equivalence R
equivalence-but-not-strong-equivalence ext univ =
  A , R , rfl , sm , trns , not-strong-equivalence
  where
  A : Type
  A = ⊤

  R : A → A → Type
  R _ _ = Fin 3

  rfl : ∀ {x} → R x x
  rfl = fzero

  sm : ∀ {x y} → R x y → R y x
  sm _ = fzero

  trns : ∀ {x y z} → R x y → R y z → R x z
  trns _ _ = fzero

  not-strong-equivalence : ¬ Strong-equivalence R
  not-strong-equivalence =
    Strong-equivalence R  ↝⟨ const-Fin-strong-equivalence⇒≡! ext univ 3 ⟩
    3 ≡ 3 !               ↝⟨ from-⊎ (3 Nat.≟ (3 !)) ⟩□
    ⊥                     □

-- On the other hand, if n is 2, then λ (_ _ : ⊤) → Fin n is a strong
-- equivalence relation (assuming extensionality and univalence).

const-Fin-2-strong-equivalence :
  Extensionality (# 0) (# 1) →
  Univalence (# 0) →
  Strong-equivalence (λ (_ _ : ⊤) → Fin 2)
const-Fin-2-strong-equivalence ext univ =
  Fin 2                          ↔⟨ inverse $ [Fin≡Fin]↔Fin! (lower-extensionality _ _ ext) univ 2 ⟩
  Fin 2 ≡ Fin 2                  ↔⟨ inverse Π-left-identity ⟩
  (⊤ → Fin 2 ≡ Fin 2)            ↝⟨ Eq.extensionality-isomorphism ext ⟩□
  const (Fin 2) ≡ const (Fin 2)  □

-- Thus there is at least one example of a strong equivalence relation
-- that is neither propositional nor the identity type (assuming
-- extensionality and univalence).

strong-equivalence-that-is-neither-propositional-nor-≡ :
  Extensionality (# 0) (# 1) →
  Univalence (# 0) →
  ∃ λ (A : Type) →
  ∃ λ (R : A → A → Type) →
    Strong-equivalence R ×
    ¬ (∀ x y → Is-proposition (R x y)) ×
    ¬ (∀ x y → R x y ≃ (x ≡ y))
strong-equivalence-that-is-neither-propositional-nor-≡ ext univ =
  ⊤ , (λ _ _ → Fin 2) , const-Fin-2-strong-equivalence ext univ ,
  (λ is-prop →                   $⟨ is-prop _ _ ⟩
     Is-proposition (⊤ ⊎ ⊤ ⊎ ⊥)  ↝⟨ H-level.respects-surjection (_↔_.surjection $ inverse Bool↔Fin2) 1 ⟩
     Is-proposition Bool         ↝⟨ ¬-Bool-propositional ⟩□
     ⊥                           □) ,
  (λ ≃≡ → let eq = ≃≡ tt tt in
     ⊎.inj₁≢inj₂ (
       fzero                                 ≡⟨ sym $ _≃_.left-inverse-of eq _ ⟩
       _≃_.from eq (_≃_.to eq fzero)         ≡⟨ cong (_≃_.from eq) $
                                                mono (zero≤ 2) ⊤-contractible _ _ ⟩
       _≃_.from eq (_≃_.to eq (fsuc fzero))  ≡⟨ _≃_.left-inverse-of eq _ ⟩∎
       fsuc fzero                            ∎))

-- It is not in general the case that, if R is a strong equivalence
-- relation, then R on f is a strong equivalence relation (assuming
-- extensionality and univalence).

strong-equivalence-not-closed-under-on :
  Extensionality (# 1) (# 2) →
  Univalence (# 1) →
  Univalence (# 0) →
  ∃ λ (A : Type₁) →
  ∃ λ (B : Type₁) →
  ∃ λ (R : A → A → Type₁) →
  ∃ λ (f : B → A) →
    Strong-equivalence R ×
    ¬ Strong-equivalence (R on f)
strong-equivalence-not-closed-under-on ext univ₁ univ₀ =
  Type , ↑ _ ⊤ , _≡_ , const (Fin 3) ,
  equality-strong-equivalence ext univ₁ ,
  not-strong-equivalence
  where
  not-strong-equivalence : ¬ Strong-equivalence (_≡_ on const (Fin 3))
  not-strong-equivalence strong-equivalence = contradiction
    where
    3!≡3!! = _⇔_.to (isomorphic-same-size { n = 3 ! ! }) (
      Fin (3 !)                                      ↝⟨ inverse $ [Fin≡Fin]↔Fin! (lower-extensionality _ _ ext) univ₀ 3 ⟩
      Fin 3 ≡ Fin 3                                  ↔⟨ strong-equivalence ⟩
      const (Fin 3 ≡ Fin 3) ≡ const (Fin 3 ≡ Fin 3)  ↔⟨ inverse $ Eq.extensionality-isomorphism ext ⟩
      (↑ _ ⊤ → (Fin 3 ≡ Fin 3) ≡ (Fin 3 ≡ Fin 3))    ↝⟨ →-cong₁ ext Bij.↑↔ ⟩
      (⊤ → (Fin 3 ≡ Fin 3) ≡ (Fin 3 ≡ Fin 3))        ↝⟨ Π-left-identity ⟩
      (Fin 3 ≡ Fin 3) ≡ (Fin 3 ≡ Fin 3)              ↔⟨ ≡-preserves-≃ (lower-extensionality lzero _ ext) univ₁ univ₀
                                                                      (Eq.↔⇒≃ $ [Fin≡Fin]↔Fin! (lower-extensionality _ _ ext) univ₀ 3)
                                                                      (Eq.↔⇒≃ $ [Fin≡Fin]↔Fin! (lower-extensionality _ _ ext) univ₀ 3) ⟩
      Fin (3 !) ≡ Fin (3 !)                          ↝⟨ [Fin≡Fin]↔Fin! (lower-extensionality _ _ ext) univ₀ (3 !) ⟩□
      Fin (3 ! !)                                    □)

    contradiction : ⊥
    contradiction = from-⊎ ((3 !) Nat.≟ (3 ! !)) 3!≡3!!

-- However, Strong-equivalence-with k is closed under _on f when f is
-- an equivalence (assuming extensionality).

strong-equivalence-with-closed-under-on :
  ∀ {k a b r} {A : Type a} {B : Type b} {R : A → A → Type r} →
  Extensionality (a ⊔ b) (lsuc r) →
  (B≃A : B ≃ A) →
  Strong-equivalence-with k R →
  Strong-equivalence-with k (R on _≃_.to B≃A)
strong-equivalence-with-closed-under-on
  {a = a} {b} {R = R} ext B≃A strong-equivalence {x} {y} =

  R (f x) (f y)                                  ↝⟨ strong-equivalence ⟩
  R (f x) ≡ R (f y)                              ↔⟨⟩
  (λ z → R (f x)    z)  ≡ (λ z → R (f y)    z)   ↔⟨ inverse $ Eq.extensionality-isomorphism
                                                                (lower-extensionality b lzero ext) ⟩
  (∀ z → R (f x)    z   ≡        R (f y)    z)   ↔⟨ (Π-cong ext (inverse B≃A) λ z →
                                                     ≡⇒≃ $ cong₂ _≡_ (lemma x z) (lemma y z)) ⟩
  (∀ z → R (f x) (f z)  ≡        R (f y) (f z))  ↔⟨ Eq.extensionality-isomorphism
                                                      (lower-extensionality a lzero ext) ⟩
  (λ z → R (f x) (f z)) ≡ (λ z → R (f y) (f z))  ↔⟨⟩
  (R on f) x ≡ (R on f) y                        □
  where
  f   = _≃_.to   B≃A
  f⁻¹ = _≃_.from B≃A

  lemma = λ x z →
    R (f x) z            ≡⟨ cong (R (f x)) $ sym $ _≃_.right-inverse-of B≃A _ ⟩∎
    R (f x) (f (f⁻¹ z))  ∎

-- Various closure properties related to _×_ and _⊎_ fail to hold for
-- Strong-equivalence (assuming extensionality and univalence).

strong-equivalence-not-closed-under-×-or-⊎ :
  Extensionality (# 0) (# 1) →
  Univalence (# 0) →
  ∃ λ (A : Type) →
  ∃ λ (R₁ : A → A → Type) →
  ∃ λ (R₂ : A → A → Type) →
    Strong-equivalence R₁ ×
    Strong-equivalence R₂ ×
    ¬ Strong-equivalence (λ x y → R₁ x y × R₂ x y) ×
    ¬ Strong-equivalence (λ x y → R₁ x y ⊎ R₂ x y) ×
    ¬ Strong-equivalence (λ x y → R₁ (proj₁ x) (proj₁ y) ×
                                  R₂ (proj₂ x) (proj₂ y)) ×
    ¬ Strong-equivalence (λ x y → R₁ (proj₁ x) (proj₁ y) ⊎
                                  R₂ (proj₂ x) (proj₂ y))
strong-equivalence-not-closed-under-×-or-⊎ ext univ =
  ⊤ , R , R ,
  strong-equivalence , strong-equivalence ,
  not-strong-equivalence  (Fin×Fin↔Fin* 2 2) ,
  not-strong-equivalence  (Fin⊎Fin↔Fin+ 2 2) ,
  not-strong-equivalence′ (Fin×Fin↔Fin* 2 2) ,
  not-strong-equivalence′ (Fin⊎Fin↔Fin+ 2 2)
  where
  R : ⊤ → ⊤ → Type
  R = λ _ _ → Fin 2

  strong-equivalence : Strong-equivalence R
  strong-equivalence =
    proj₁ $ proj₂ $ proj₂ $
      strong-equivalence-that-is-neither-propositional-nor-≡ ext univ

  not-strong-equivalence :
    {B : Type} →
    B ↔ Fin 4 →
    ¬ Strong-equivalence (λ (_ _ : ⊤) → B)
  not-strong-equivalence {B} B↔Fin4 =
    Strong-equivalence (λ _ _ → B)      ↝⟨ (≡⇒↝ _ $ cong Strong-equivalence $ apply-ext ext λ _ → apply-ext ext λ _ →
                                            ≃⇒≡ univ $ Eq.↔⇒≃ B↔Fin4) ⟩
    Strong-equivalence (λ _ _ → Fin 4)  ↝⟨ const-Fin-strong-equivalence⇒≡! ext univ 4 ⟩
    4 ≡ 4 !                             ↝⟨ from-⊎ (4 Nat.≟ (4 !)) ⟩□
    ⊥                                   □

  not-strong-equivalence′ :
    {B : Type} →
    B ↔ Fin 4 →
    ¬ Strong-equivalence (λ (_ _ : ⊤ × ⊤) → B)
  not-strong-equivalence′ {B} B↔Fin4 =
    Strong-equivalence (λ (_ _ : ⊤ × ⊤) → B)  ↝⟨ (λ se {_ _} →
        B                                           ↝⟨ se {y = _} ⟩
        const B ≡ const B                           ↝⟨ inverse $ Eq.extensionality-isomorphism ext ⟩
        (⊤ × ⊤ → B ≡ B)                             ↝⟨ →-cong₁ ext ×-right-identity ⟩
        (⊤ → B ≡ B)                                 ↝⟨ Eq.extensionality-isomorphism ext ⟩□
        const B ≡ const B                           □) ⟩
    Strong-equivalence (λ (_ _ : ⊤)     → B)  ↝⟨ not-strong-equivalence B↔Fin4 ⟩□
    ⊥                                         □

-- Is the following a strong equivalence relation?
--
--   R (x , _) (y , _) = x ≡ y
--
-- (This is a combination of equality and the trivial relation, both
-- of which are strong equivalence relations.)
--
-- Answer: No, not in general (assuming extensionality and
-- univalence).

another-negative-result :
  Extensionality (# 1) (# 2) →
  Univalence (# 1) →
  Univalence (# 0) →
  ∃ λ (A : Type₁) →
  ∃ λ (B : Type) →
    ¬ Strong-equivalence {A = A × B} (_≡_ on proj₁)
another-negative-result ext univ₁ univ₀ =
  Type , Fin 2 , not-strong-equivalence
  where
  not-strong-equivalence : ¬ Strong-equivalence (_≡_ on proj₁)
  not-strong-equivalence strong-equivalence = contradiction
    where
    4≡2 = _⇔_.to isomorphic-same-size (
      Fin 4                                                        ↝⟨ inverse $ [Fin→Fin]↔Fin^ (lower-extensionality _ _ ext) 2 2 ⟩
      (Fin 2 → Fin 2)                                              ↝⟨ →-cong (lower-extensionality _ _ ext) F.id $ inverse $
                                                                      [Fin≡Fin]↔Fin! (lower-extensionality _ _ ext) univ₀ 2 ⟩
      (Fin 2 → Fin 2 ≡ Fin 2)                                      ↔⟨ →-cong (lower-extensionality _ lzero ext) F.id $
                                                                      equality-strong-equivalence ext univ₁ ⟩
      (Fin 2 → (λ A → Fin 2 ≡       A) ≡ (λ A → Fin 2 ≡       A))  ↔⟨ →-cong (lower-extensionality _ lzero ext) F.id $ inverse $
                                                                      Eq.extensionality-isomorphism ext ⟩
      (Fin 2 → ∀ A → (Fin 2 ≡       A) ≡       (Fin 2 ≡       A))  ↝⟨ Π-comm ⟩
      (∀ A → Fin 2 → (Fin 2 ≡       A) ≡       (Fin 2 ≡       A))  ↝⟨ inverse currying ⟩
      (∀ A →         (Fin 2 ≡ proj₁ A) ≡       (Fin 2 ≡ proj₁ A))  ↔⟨ Eq.extensionality-isomorphism ext ⟩
      (λ A →          Fin 2 ≡ proj₁ A) ≡ (λ A → Fin 2 ≡ proj₁ A)   ↔⟨ inverse $ strong-equivalence {x = _ , fzero} {y = _ , fzero} ⟩
      Fin 2 ≡ Fin 2                                                ↝⟨ [Fin≡Fin]↔Fin! (lower-extensionality _ _ ext) univ₀ 2 ⟩□
      Fin 2                                                        □)

    contradiction : ⊥
    contradiction = from-⊎ (4 Nat.≟ 2) 4≡2

------------------------------------------------------------------------
-- Quotients

-- Equivalence classes.

_is-equivalence-class-of_ :
  ∀ {a} {A : Type a} →
  (A → Type a) → (A → A → Type a) → Type (lsuc (lsuc a))
_is-equivalence-class-of_ {a} P R =
  ∥ (∃ λ x → R x ≡ P) ∥ 1 (lsuc a)

-- Quotients.

infix 5 _/_

_/_ : ∀ {a} (A : Type a) → (A → A → Type a) → Type (lsuc (lsuc a))
A / R = ∃ λ (P : A → Type _) → P is-equivalence-class-of R

-- Quotienting with equality amounts to the same thing as not
-- quotienting at all (assuming extensionality and univalence).

/≡↔ :
  ∀ {a} {A : Type a} →
  Extensionality (lsuc (lsuc a)) (lsuc a) →
  Univalence a →
  A / _≡_ ↔ A
/≡↔ {A = A} ext univ =
  (∃ λ P → ∥ (∃ λ x → (x ≡_) ≡ P) ∥ 1 _)  ↝⟨ (∃-cong λ _ → ∥∥↔ lzero ext irr) ⟩
  (∃ λ P → ∃ λ x → (x ≡_) ≡ P)            ↝⟨ ∃-comm ⟩
  (∃ λ x → ∃ λ P → (x ≡_) ≡ P)            ↝⟨ drop-⊤-right (λ _ → _⇔_.to contractible⇔↔⊤ $ other-singleton-contractible _) ⟩□
  A                                       □
  where
  se = equality-strong-equivalence
         (lower-extensionality _ lzero ext) univ

  se-refl :
    ∀ x → _≃_.to se (refl x) ≡ refl (x ≡_)
  se-refl x = _≃_.from-to se (
    sym (_≃_.to (≡⇒↝ _ (cong (_$ x) (refl (x ≡_)))) (sym (refl x)))  ≡⟨ cong (λ p → sym (_≃_.to (≡⇒↝ _ p) (sym (refl x)))) $ cong-refl _ ⟩
    sym (_≃_.to (≡⇒↝ _ (refl (x ≡ x))) (sym (refl x)))               ≡⟨ cong (λ eq → sym (_≃_.to eq (sym (refl x)))) ≡⇒↝-refl ⟩
    sym (sym (refl x))                                               ≡⟨ sym-sym _ ⟩∎
    refl x                                                           ∎)

  lemma :
    {x y : A} (p : (x ≡_) ≡ (y ≡_)) →
    cong _≡_ (subst (_$ x) p (refl x)) ≡ sym p
  lemma {x = x} p =
    cong _≡_ (subst (_$ x) p (refl x))                            ≡⟨ cong (λ p → cong _≡_ (subst (_$ x) p (refl x))) $ sym $
                                                                       _≃_.right-inverse-of se _ ⟩
    cong _≡_ (subst (_$ x) (_≃_.to se (_≃_.from se p)) (refl x))  ≡⟨ D.elim (λ p → cong _≡_ (subst (_$ _) (_≃_.to se p) (refl _)) ≡
                                                                                sym (_≃_.to se p))
                                                                            (λ x →
        cong _≡_ (subst (_$ x) (_≃_.to se (refl x)) (refl x))                  ≡⟨ cong (λ p → cong _≡_ (subst (_$ x) p (refl x))) $ se-refl x ⟩
        cong _≡_ (subst (_$ x) (refl (x ≡_)) (refl x))                         ≡⟨ cong (cong _≡_) $ subst-refl _ _ ⟩
        cong _≡_ (refl x)                                                      ≡⟨ cong-refl _ ⟩
        refl (x ≡_ )                                                           ≡⟨ sym sym-refl ⟩
        sym (refl (x ≡_ ))                                                     ≡⟨ cong sym $ sym $ se-refl x ⟩∎
        sym (_≃_.to se (refl x))                                               ∎)
                                                                            (_≃_.from se p) ⟩
    sym (_≃_.to se (_≃_.from se p))                               ≡⟨ cong sym $ _≃_.right-inverse-of se _ ⟩∎
    sym p                                                         ∎

  irr : ∀ {P} (p q : ∃ λ x → (x ≡_) ≡ P) → p ≡ q
  irr {P} (x , x≡≡) (y , y≡≡) =
    Σ-≡,≡→≡
      (_≃_.from se ((x ≡_)  ≡⟨ x≡≡ ⟩
                    P       ≡⟨ sym y≡≡ ⟩∎
                    (y ≡_)  ∎))

      (subst (λ x → (x ≡_) ≡ P)
             (_≃_.from se (trans x≡≡ (sym y≡≡)))
             x≡≡                                                        ≡⟨⟩

       subst (λ x → (x ≡_) ≡ P)
             (sym $ _≃_.to (≡⇒↝ _ (cong (_$ x) (trans x≡≡ (sym y≡≡))))
                           (sym (refl x)))
             x≡≡                                                        ≡⟨ cong (λ eq → subst (λ x → (x ≡_) ≡ P) (sym eq) x≡≡) $ sym $
                                                                             subst-in-terms-of-≡⇒↝ equivalence _ _ _ ⟩
       subst (λ x → (x ≡_) ≡ P)
             (sym $ subst (_$ x) (trans x≡≡ (sym y≡≡)) (sym (refl x)))
             x≡≡                                                        ≡⟨ cong (λ eq → subst (λ x → (x ≡_) ≡ P)
                                                                                (sym (subst (_$ x) (trans x≡≡ (sym y≡≡)) eq)) _)
                                                                             sym-refl ⟩
       subst (λ x → (x ≡_) ≡ P)
             (sym $ subst (_$ x) (trans x≡≡ (sym y≡≡)) (refl x))
             x≡≡                                                        ≡⟨ subst-∘ _ _ _ ⟩

       subst (λ Q → Q ≡ P)
             (cong _≡_ $
                sym $ subst (_$ x) (trans x≡≡ (sym y≡≡)) (refl x))
             x≡≡                                                        ≡⟨ cong (λ eq → subst (λ Q → Q ≡ P) eq _) $ cong-sym _ _ ⟩

       subst (λ Q → Q ≡ P)
             (sym $ cong _≡_ $
                subst (_$ x) (trans x≡≡ (sym y≡≡)) (refl x))
             x≡≡                                                        ≡⟨ subst-trans _ ⟩

       trans (cong _≡_ $ subst (_$ x) (trans x≡≡ (sym y≡≡)) (refl x))
             x≡≡                                                        ≡⟨ cong (flip trans x≡≡) $ lemma _ ⟩

       trans (sym (trans x≡≡ (sym y≡≡))) x≡≡                            ≡⟨ cong (flip trans x≡≡) $ sym-trans _ _ ⟩

       trans (trans (sym (sym y≡≡)) (sym x≡≡)) x≡≡                      ≡⟨ trans-[trans-sym]- _ _ ⟩

       sym (sym y≡≡)                                                    ≡⟨ sym-sym _ ⟩∎

       y≡≡                                                              ∎)

module _ {a} {A : Type a} {R : A → A → Type a} where

  -- Equality characterisation lemmas for the quotient type.

  equality-characterisation₁ :
    Extensionality (lsuc (lsuc a)) (lsuc a) →
    {x y : A / R} →
    x ≡ y
      ↔
    proj₁ x ≡ proj₁ y
  equality-characterisation₁ ext {x} {y} =
    x ≡ y                                                          ↝⟨ inverse Bij.Σ-≡,≡↔≡ ⟩

    (∃ λ (eq : proj₁ x ≡ proj₁ y) →
       subst (_is-equivalence-class-of R) eq (proj₂ x) ≡ proj₂ y)  ↝⟨ (drop-⊤-right λ _ → _⇔_.to contractible⇔↔⊤ $
                                                                       +⇒≡ $ truncation-has-correct-h-level 1 ext) ⟩□
    proj₁ x ≡ proj₁ y                                              □

  equality-characterisation₂ :
    Extensionality (lsuc (lsuc a)) (lsuc a) →
    {x y : A / R} →
    x ≡ y
      ↔
    (∀ z → proj₁ x z ≡ proj₁ y z)
  equality-characterisation₂ ext {x} {y} =
    x ≡ y                          ↝⟨ equality-characterisation₁ ext ⟩

    proj₁ x ≡ proj₁ y              ↔⟨ inverse $ Eq.extensionality-isomorphism
                                                  (lower-extensionality _ lzero ext) ⟩□
    (∀ z → proj₁ x z ≡ proj₁ y z)  □

  equality-characterisation₃ :
    Extensionality (lsuc (lsuc a)) (lsuc a) →
    Univalence a →
    {x y : A / R} →
    x ≡ y
      ↔
    (∀ z → proj₁ x z ≃ proj₁ y z)
  equality-characterisation₃ ext univ {x} {y} =
    x ≡ y                          ↝⟨ equality-characterisation₂ ext ⟩

    (∀ z → proj₁ x z ≡ proj₁ y z)  ↔⟨ (∀-cong (lower-extensionality _ lzero ext) λ _ →
                                       ≡≃≃ univ) ⟩□
    (∀ z → proj₁ x z ≃ proj₁ y z)  □

  -- Constructor for the quotient type.

  [_] : A → A / R
  [ a ] = R a , ∣ (a , refl (R a)) ∣₁

  -- [_] is surjective (assuming extensionality).

  []-surjective :
    Extensionality (lsuc (lsuc a)) (lsuc a) →
    Surjective (lsuc a) [_]
  []-surjective ext (P , P-is-class) =
    ∥∥-map
      1
      (Σ-map
         F.id
         (λ {x} Rx≡P →
            [ x ]             ≡⟨ _↔_.from (equality-characterisation₁ ext) Rx≡P ⟩∎
            (P , P-is-class)  ∎))
      P-is-class

  -- If the relation is a family of types of h-level n, then the
  -- equivalence classes are also families of types of h-level n
  -- (assuming extensionality).

  equivalence-classes-have-same-h-level-as-relation :
    Extensionality a a →
    ∀ n →
    (∀ x y → H-level n (R x y)) →
    (x : A / R) → ∀ y → H-level n (proj₁ x y)
  equivalence-classes-have-same-h-level-as-relation
    ext n h (P , P-is-class) y =

    Trunc.rec
      1
      (H-level-propositional ext n)
      (λ { (z , Rz≡P) → H-level.respects-surjection
                          (≡⇒↝ _ (R z y  ≡⟨ cong (_$ y) Rz≡P ⟩∎
                                  P y    ∎))
                          n
                          (h z y) })
      (with-lower-level _ 1 P-is-class)

  -- If R is a family of types of h-level n, then A / R has h-level
  -- 1 + n (assuming extensionality and univalence).

  quotient's-h-level-is-1-+-relation's-h-level :
    Extensionality (lsuc (lsuc a)) (lsuc a) →
    Univalence a →
    Univalence (# 0) →
    ∀ n →
    (∀ x y → H-level n (R x y)) →
    H-level (1 + n) (A / R)
  quotient's-h-level-is-1-+-relation's-h-level ext univ univ₀ = h′
    where
    lemma₁ :
      ∀ n →
      (∀ x y z → H-level n (proj₁ x z ≡ proj₁ y z)) →
      H-level (1 + n) (A / R)
    lemma₁ n h = ≡↔+ _ _ λ x y →                 $⟨ h x y ⟩
      (∀ z → H-level n (proj₁ x z ≡ proj₁ y z))  ↝⟨ Π-closure (lower-extensionality _ lzero ext) n ⟩
      H-level n (∀ z → proj₁ x z ≡ proj₁ y z)    ↝⟨ H-level.respects-surjection
                                                      (_↔_.surjection (inverse $ equality-characterisation₂ ext))
                                                      n ⟩□
      H-level n (x ≡ y)                          □

    lemma₂ :
      ∀ n →
      (∀ x y → H-level (1 + n) (R x y)) →
      ∀ x y z → H-level (1 + n) (proj₁ x z ≡ proj₁ y z)
    lemma₂ n h x _ z =
      H-level-H-level-≡ˡ
        (lower-extensionality _ _ ext) univ n
        (equivalence-classes-have-same-h-level-as-relation
           (lower-extensionality _ _ ext) (1 + n) h x z)

    h′ : ∀ n →
         (∀ x y → H-level n (R x y)) →
         H-level (1 + n) (A / R)
    h′ (suc n) h = lemma₁ (suc n) (lemma₂ n h)
    h′ zero    h =
      lemma₁ zero λ x y z →
        propositional⇒inhabited⇒contractible
          (lemma₂ 0 (λ x y → mono₁ 0 (h x y)) x y z)
          (                       $⟨ refl _ ⟩
           ⊤ ≡ ⊤                  ↝⟨ ≡-preserves-≃ (lower-extensionality _ _ ext) univ₀ univ
                                       (lemma₃ x z) (lemma₃ y z) ⟩
           proj₁ x z ≡ proj₁ y z  □)
      where
      lemma₃ : ∀ x z → ⊤ ≃ proj₁ x z
      lemma₃ x z =                $⟨ equivalence-classes-have-same-h-level-as-relation
                                       (lower-extensionality _ _ ext)
                                       0 h x z ⟩
        Contractible (proj₁ x z)  ↝⟨ _⇔_.to contractible⇔↔⊤ ⟩
        proj₁ x z ↔ ⊤             ↝⟨ inverse ⟩
        ⊤ ↔ proj₁ x z             ↝⟨ Eq.↔⇒≃ ⟩□
        ⊤ ≃ proj₁ x z             □

  -- If the relation is a strong equivalence relation with k, then it
  -- is k-related to equality under [_] (assuming extensionality).

  related↝[equal] :
    ∀ {k} →
    Extensionality (lsuc (lsuc a)) (lsuc a) →
    Strong-equivalence-with k R →
    ∀ {x y} → R x y ↝[ k ] [ x ] ≡ [ y ]
  related↝[equal] ext strong-equivalence {x} {y} =
    R x y          ↝⟨ strong-equivalence ⟩
    R x ≡ R y      ↔⟨ inverse $ equality-characterisation₁ ext ⟩□
    [ x ] ≡ [ y ]  □

  -- If the relation is a strong equivalence relation with a symmetric
  -- kind k, then functions from quotients to sets are k-related to
  -- relation-respecting functions (assuming extensionality).

  /→set↝relation-respecting :
    ∀ {k} →
    Extensionality (lsuc (lsuc a)) (lsuc (lsuc a)) →
    Strong-equivalence-with ⌊ k ⌋-sym R →
    {B : Type a} →
    Is-set B →
    (A / R → B)
      ↝[ ⌊ k ⌋-sym ]
    ∃ λ (f : A → B) → ∀ x y → R x y → f x ≡ f y
  /→set↝relation-respecting {k} ext strong-equivalence {B = B} B-set =

    ((∃ λ P → ∥ (∃ λ x → R x ≡ P) ∥ 1 _) → B)             ↔⟨ currying ⟩

    (∀ P → ∥ (∃ λ x → R x ≡ P) ∥ 1 _ → B)                 ↔⟨ (∀-cong (lower-extensionality _ lzero ext) λ P → inverse $
                                                              constant-function≃∥inhabited∥⇒inhabited
                                                                lzero (lower-extensionality lzero _ ext) B-set) ⟩
    (∀ P → ∃ λ (f : (∃ λ x → R x ≡ P) → B) → Constant f)  ↔⟨ (∀-cong (lower-extensionality _ _ ext) λ _ →
                                                              Σ-cong currying λ _ → Bij.id) ⟩
    (∀ P → ∃ λ (f : (x : A) → R x ≡ P → B) →
               Constant (uncurry f))                      ↔⟨ ΠΣ-comm ⟩

    (∃ λ (f : ∀ P → (x : A) → R x ≡ P → B) →
       ∀ P → Constant (uncurry (f P)))                    ↝⟨ Σ-cong Π-comm (λ _ → F.id) ⟩

    (∃ λ (f : (x : A) → ∀ P → R x ≡ P → B) →
       ∀ P → Constant (uncurry (flip f P)))               ↝⟨ Σ-cong (∀-cong (lower-extensionality _ _ ext) λ _ →
                                                                     inverse currying) (λ _ →
                                                             F.id) ⟩
    (∃ λ (f : (x : A) → (∃ λ P → R x ≡ P) → B) →
       ∀ P → Constant (uncurry λ x eq → f x (P , eq)))    ↝⟨ inverse $
                                                             Σ-cong (Bij.inverse $
                                                                     ∀-cong (lower-extensionality _ _ ext) λ _ →
                                                                     drop-⊤-left-Π (lower-extensionality _ _ ext) $
                                                                     _⇔_.to contractible⇔↔⊤ $
                                                                     other-singleton-contractible _)
                                                             lemma ⟩□
    (∃ λ (f : A → B) → ∀ x y → R x y → f x ≡ f y)         □

    where

    lemma = λ f →
      (∀ x y → R x y → f x ≡ f y)                                    ↝⟨ (∀-cong (forget-ext? ⌊ k ⌋-sym $ lower-extensionality _ _ ext) λ x →
                                                                         ∀-cong (forget-ext? ⌊ k ⌋-sym $ lower-extensionality _ _ ext) λ y →
                                                                         →-cong (forget-ext? ⌊ k ⌋-sym $ lower-extensionality _ _ ext)
                                                                                strong-equivalence
                                                                                F.id) ⟩
      (∀ x y → R x ≡ R y → f x ≡ f y)                                ↔⟨ (∀-cong (lower-extensionality _ _ ext) λ _ →
                                                                         ∀-cong (lower-extensionality _ _ ext) λ _ →
                                                                         →-cong (lower-extensionality _ _ ext)
                                                                                (Groupoid.⁻¹-bijection (EG.groupoid _))
                                                                                F.id) ⟩
      (∀ x y → R y ≡ R x → f x ≡ f y)                                ↔⟨ (∀-cong (lower-extensionality _ _ ext) λ _ →
                                                                         inverse currying) ⟩
      (∀ x (q : ∃ λ y → R y ≡ R x) → f x ≡ f (proj₁ q))              ↔⟨ (∀-cong (lower-extensionality _ _ ext) λ _ →
                                                                         inverse $ drop-⊤-left-Π {k = bijection} (lower-extensionality _ _ ext) $
                                                                         _⇔_.to contractible⇔↔⊤ $
                                                                         other-singleton-contractible _) ⟩
      (∀ x (Q : ∃ λ P → R x ≡ P) (q : ∃ λ x → R x ≡ proj₁ Q) →
       f x ≡ f (proj₁ q))                                            ↔⟨ (∀-cong (lower-extensionality _ _ ext) λ _ →
                                                                         currying) ⟩
      (∀ x P → R x ≡ P → (q : ∃ λ x → R x ≡ P) → f x ≡ f (proj₁ q))  ↔⟨ Π-comm ⟩

      (∀ P x → R x ≡ P → (q : ∃ λ x → R x ≡ P) → f x ≡ f (proj₁ q))  ↔⟨ (∀-cong (lower-extensionality _ _ ext) λ _ →
                                                                         inverse currying) ⟩
      (∀ P (p q : ∃ λ x → R x ≡ P) → f (proj₁ p) ≡ f (proj₁ q))      ↔⟨⟩

      (∀ P → Constant (uncurry λ x _ → f x))                         ↔⟨ (∀-cong (lower-extensionality _ _ ext) λ _ →
                                                                         ≡⇒↝ bijection $ cong Constant $
                                                                         apply-ext (lower-extensionality _ _ ext) λ _ →
                                                                         sym $ subst-const _) ⟩□
      (∀ P → Constant (uncurry λ x _ → subst (const B) _ (f x)))     □

  -- "Computation rule" for /→set↝relation-respecting.

  proj₁-to-/→set↝relation-respecting :
    ∀ {k}
    (ext : Extensionality (lsuc (lsuc a)) (lsuc (lsuc a)))
    (strong-equivalence : Strong-equivalence-with ⌊ k ⌋-sym R)
    {B : Type a}
    (B-set : Is-set B)
    (f : A / R → B) →
    proj₁ (to-implication
             (/→set↝relation-respecting ext strong-equivalence B-set) f)
      ≡
    f ∘ [_]
  proj₁-to-/→set↝relation-respecting ext eq {B} B-set f =
    apply-ext (lower-extensionality _ _ ext) (lemma _ eq)
    where
    lemma :
      ∀ k (eq : Strong-equivalence-with ⌊ k ⌋-sym R) x →
      proj₁
        (to-implication (/→set↝relation-respecting ext eq B-set) f)
        x
        ≡
      f [ x ]

    lemma logical-equivalence _ x =
      subst (const B) (refl _) (f [ x ])  ≡⟨ subst-refl _ _ ⟩∎
      f [ x ]                             ∎

    lemma bijection _ x =
      subst (const B) (refl _) (f [ x ])  ≡⟨ subst-refl _ _ ⟩∎
      f [ x ]                             ∎

    lemma equivalence _ x =
      subst (const B) (refl _) (f [ x ])  ≡⟨ subst-refl _ _ ⟩∎
      f [ x ]                             ∎

    lemma equivalenceᴱ _ x =
      subst (const B) (refl _) (f [ x ])  ≡⟨ subst-refl _ _ ⟩∎
      f [ x ]                             ∎

  -- Recursor (used to eliminate into sets). The recursor uses
  -- extensionality and reflexivity.

  rec :
    Extensionality (lsuc (lsuc a)) (lsuc a) →
    (∀ {x} → R x x) →
    (B : Type a) →
    Is-set B →
    (f : A → B) →
    (∀ {x y} → R x y → f x ≡ f y) →
    A / R → B
  rec ext refl B B-set f R⇒≡ (P , P-is-class) =
    _≃_.to (constant-function≃∥inhabited∥⇒inhabited lzero ext B-set)
      (f′ , f′-constant)
      P-is-class
    where
    f′ : (∃ λ x → R x ≡ P) → B
    f′ (x , _) = f x

    f′-constant : Constant f′
    f′-constant (x₁ , Rx₁≡P) (x₂ , Rx₂≡P) = R⇒≡ (
               $⟨ refl ⟩
      R x₂ x₂  ↝⟨ ≡⇒→ $ cong (λ Q → Q x₂) Rx₂≡P ⟩
      P x₂     ↝⟨ ≡⇒→ $ cong (λ Q → Q x₂) $ sym Rx₁≡P ⟩□
      R x₁ x₂  □)

  private

    -- The recursor's computation rule holds definitionally.

    rec-[] :
      (ext : Extensionality (lsuc (lsuc a)) (lsuc a))
      (refl : ∀ {x} → R x x)
      (B : Type a)
      (B-set : Is-set B)
      (f : A → B)
      (R⇒≡ : ∀ {x y} → R x y → f x ≡ f y)
      (x : A) →
      rec ext refl B B-set f R⇒≡ [ x ] ≡ f x
    rec-[] _ _ _ _ _ _ _ = refl _

  -- Eliminator (used to eliminate into sets). The eliminator uses
  -- extensionality, and the assumption that the relation is a "strong
  -- equivalence relation with split surjections".

  elim :
    (ext : Extensionality (lsuc (lsuc a)) (lsuc a))
    (strong-equivalence : Strong-equivalence-with surjection R)
    (B : A / R → Type (lsuc a)) →
    (∀ x → Is-set (B x)) →
    (f : ∀ x → B [ x ]) →
    (∀ {x y} (Rxy : R x y) →
       subst B (_↠_.to (related↝[equal]
                          ext strong-equivalence) Rxy) (f x) ≡
       f y) →
    ∀ x → B x
  elim ext strong-equivalence B B-set f R⇒≡ (P , P-is-class) =
    _≃_.to (constant-function≃∥inhabited∥⇒inhabited
              lzero ext (B-set _))
      (f′ , f′-constant)
      P-is-class
    where
    f′ : (∃ λ x → R x ≡ P) → B (P , P-is-class)
    f′ (x , Rx≡P) =
      subst B
            (_↔_.from (equality-characterisation₁ ext) Rx≡P)
            (f x)

    f′-constant : Constant f′
    f′-constant (x , Rx≡P) (y , Ry≡P) =
      subst B
            (_↔_.from (equality-characterisation₁ ext) Rx≡P)
            (f x)                                                     ≡⟨ cong (subst _ _) $ sym $ R⇒≡ _ ⟩

      subst B
            (_↔_.from (equality-characterisation₁ ext) Rx≡P)
            (subst B (_↠_.to (related↝[equal]
                                ext strong-equivalence) lemma₁)
                   (f y))                                             ≡⟨ subst-subst _ _ _ _ ⟩

      subst B
            (trans (_↠_.to (related↝[equal]
                              ext strong-equivalence) lemma₁)
                   (_↔_.from (equality-characterisation₁ ext) Rx≡P))
            (f y)                                                     ≡⟨ cong (λ eq → subst B eq _) lemma₄ ⟩∎

      subst B
            (_↔_.from (equality-characterisation₁ ext) Ry≡P)
            (f y)                                                     ∎
      where
      lemma₁ = _↠_.from strong-equivalence (
         R y  ≡⟨ Ry≡P ⟩
         P    ≡⟨ sym Rx≡P ⟩∎
         R x  ∎)

      lemma₂ = λ x →
        _↔_.to (equality-characterisation₁ ext) (refl x)  ≡⟨⟩
        proj₁ (Σ-≡,≡←≡ (refl x))                          ≡⟨ proj₁-Σ-≡,≡←≡ _ ⟩
        cong proj₁ (refl x)                               ≡⟨ cong-refl _ ⟩∎
        refl (proj₁ x)                                    ∎

      lemma₃ =
        trans (_↠_.to strong-equivalence lemma₁) Rx≡P                    ≡⟨⟩

        trans (_↠_.to strong-equivalence
                 (_↠_.from strong-equivalence (trans Ry≡P (sym Rx≡P))))
              Rx≡P                                                       ≡⟨ cong (flip trans _) $ _↠_.right-inverse-of strong-equivalence _ ⟩

        trans (trans Ry≡P (sym Rx≡P)) Rx≡P                               ≡⟨ trans-[trans-sym]- _ _ ⟩∎

        Ry≡P                                                             ∎

      lemma₄ =
        trans (_↠_.to (related↝[equal] ext strong-equivalence) lemma₁)
              (_↔_.from (equality-characterisation₁ ext) Rx≡P)          ≡⟨⟩

        trans (_↔_.from (equality-characterisation₁ ext)
                        (_↠_.to strong-equivalence lemma₁))
              (_↔_.from (equality-characterisation₁ ext) Rx≡P)          ≡⟨ Bij.trans-to-to≡to-trans
                                                                             (λ _ _ → inverse $ equality-characterisation₁ ext)
                                                                             lemma₂ ⟩
        _↔_.from (equality-characterisation₁ ext)
                 (trans (_↠_.to strong-equivalence lemma₁) Rx≡P)        ≡⟨ cong (_↔_.from (equality-characterisation₁ ext)) lemma₃ ⟩∎

        _↔_.from (equality-characterisation₁ ext) Ry≡P                  ∎

  -- A variant of elim that can be used if the motive composed with
  -- [_] is a family of propositions.
  --
  -- I took the idea for this eliminator from Nicolai Kraus.

  elim-Prop :
    (ext : Extensionality (lsuc (lsuc a)) (lsuc a))
    (strong-equivalence : Strong-equivalence-with surjection R)
    (B : A / R → Type (lsuc a)) →
    (∀ x → Is-proposition (B [ x ])) →
    (f : ∀ x → B [ x ]) →
    ∀ x → B x
  elim-Prop ext strong-equivalence B B-prop f x = elim
    ext
    strong-equivalence
    B
    (elim
        ext
        strong-equivalence
        _
        (λ _ → mono₁ 1 $ H-level-propositional ext′ 2)
        (mono₁ 1 ∘ B-prop)
        (λ _ → H-level-propositional ext′ 2 _ _))
    f
    (λ _ → B-prop _ _ _)
    x
    where
    ext′ = lower-extensionality _ lzero ext

------------------------------------------------------------------------
-- An example

module ⊤/2 where

  -- What happens if we quotient the unit type by the "binary-valued
  -- trivial relation"?

  ⊤/2 : Type₂
  ⊤/2 = ⊤ / λ _ _ → Fin 2

  -- The type is not a set (assuming extensionality and univalence).

  not-a-set :
    Extensionality (# 2) (# 1) →
    Univalence (# 0) →
    ¬ Is-set ⊤/2
  not-a-set ext univ =
    Is-set ⊤/2                              ↝⟨ _⇔_.from (≡↔+ 1 _) ⟩
    ((x y : ⊤/2) → Is-proposition (x ≡ y))  ↝⟨ (λ prop → prop _ _) ⟩
    Is-proposition ([ tt ] ≡ [ tt ])        ↝⟨ H-level.respects-surjection
                                                 (_≃_.surjection $ inverse $
                                                    related↝[equal] ext
                                                      (const-Fin-2-strong-equivalence
                                                         (lower-extensionality _ lzero ext) univ))
                                                 1 ⟩
    Is-proposition (Fin 2)                  ↝⟨ H-level.respects-surjection (_↔_.surjection $ inverse Bool↔Fin2) 1 ⟩
    Is-proposition Bool                     ↝⟨ ¬-Bool-propositional ⟩□
    ⊥                                       □

  -- The type is a groupoid (assuming extensionality and univalence).

  is-groupoid :
    Extensionality (# 2) (# 1) →
    Univalence (# 0) →
    H-level 3 ⊤/2
  is-groupoid ext univ =
    quotient's-h-level-is-1-+-relation's-h-level
      ext univ univ 2 (λ _ _ → Fin-set 2)

  -- Every value in the quotient is merely equal to [ tt ] (assuming
  -- extensionality).

  ∥≡[tt]∥ :
    Extensionality (# 2) (# 1) →
    (x : ⊤/2) → ∥ x ≡ [ tt ] ∥ 1 (# 1)
  ∥≡[tt]∥ ext x =           $⟨ []-surjective ext x ⟩
    ∥ ⊤ × [ tt ] ≡ x ∥ 1 _  ↝⟨ ∥∥-map 1 (sym ∘ proj₂) ⟩□
    ∥ x ≡ [ tt ] ∥ 1 _      □

  -- The type is merely single-valued (assuming extensionality and a
  -- resizing function for the propositional truncation).

  merely-single-valued :
    Extensionality (# 2) (# 2) →
    ({A : Type₂} → ∥ A ∥ 1 (# 1) → ∥ A ∥ 1 (# 2)) →
    (x y : ⊤/2) → ∥ x ≡ y ∥ 1 (# 1)
  merely-single-valued ext resize x y =
    Trunc.rec
      1
      (truncation-has-correct-h-level 1 ext)
      (λ x≡[tt] → ∥∥-map 1
                         (λ y≡[tt] → x       ≡⟨ x≡[tt] ⟩
                                     [ tt ]  ≡⟨ sym y≡[tt] ⟩∎
                                     y       ∎)
                         (∥≡[tt]∥ ext′ y))
      (resize (∥≡[tt]∥ ext′ x))
    where
    ext′ = lower-extensionality lzero _ ext

  -- Every instance of the type's equality type is merely isomorphic
  -- to Fin 2 (assuming extensionality, univalence, and a resizing
  -- function for the propositional truncation).

  ∥≡↔2∥ :
    Extensionality (# 2) (# 2) →
    Univalence (# 0) →
    ({A : Type₂} → ∥ A ∥ 1 (# 1) → ∥ A ∥ 1 (# 2)) →
    (x y : ⊤/2) → ∥ x ≡ y ↔ Fin 2 ∥ 1 (# 1)
  ∥≡↔2∥ ext univ resize x y =
    Trunc.rec
      1
      (truncation-has-correct-h-level 1 ext)
      (λ x≡[tt] →
         ∥∥-map
           1
           (λ y≡[tt] →
              x ≡ y            ↝⟨ ≡⇒↝ _ $ cong₂ _≡_ x≡[tt] y≡[tt] ⟩
              [ tt ] ≡ [ tt ]  ↔⟨ inverse $
                                  related↝[equal]
                                    (lower-extensionality lzero _ ext)
                                    (const-Fin-2-strong-equivalence
                                       (lower-extensionality _ _ ext) univ) ⟩□
              Fin 2            □)
           (∥≡[tt]∥ (lower-extensionality lzero _ ext) y))
      (resize (∥≡[tt]∥ (lower-extensionality lzero _ ext) x))


-- Andreas, 2019-02-23, issue #3578.
-- Preserve types as much as possible during pattern matching.
-- New unifier (from Agda 2.5.1) was normalizing too much.

-- {-# OPTIONS -v tc.lhs.unify:45 #-}

data Nat : Set where
  zero : Nat

postulate
  MustNotBeNamed : Set

A = MustNotBeNamed

data P : Nat → Set where
  z : A → P zero

test : ∀{n} → P n → Set
test (z x) = {!x!}   -- C-c C-,

-- EXPECTED:
--
-- Goal: Set
-- ——————————————
-- x : A


module Data.Maybe.Properties.Extra {a}{A : Set a} where

open import Data.Maybe
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary

nothing≢just : ∀ {a : A} → ¬ (_≡_ {A = Maybe A} nothing (just a))
nothing≢just ()


open import Oscar.Prelude
open import Oscar.Class
open import Oscar.Class.Transitivity

module Oscar.Class.Transassociativity where

module Transassociativity
  {𝔬} {𝔒 : Ø 𝔬}
  {𝔯} (_∼_ : 𝔒 → 𝔒 → Ø 𝔯)
  {ℓ} (_∼̇_ : ∀ {x y} → x ∼ y → x ∼ y → Ø ℓ) (let infix 4 _∼̇_ ; _∼̇_ = _∼̇_)
  (transitivity : Transitivity.type _∼_) (let infixr 9 _∙_ ; _∙_ : FlipTransitivity.type _∼_; _∙_ g f = transitivity f g)
  = ℭLASS (λ {x y} → _∼̇_ {x} {y} , (λ {x y z} → transitivity {x} {y} {z}))
          (∀ {w x y z} (f : w ∼ x) (g : x ∼ y) (h : y ∼ z) → (h ∙ g) ∙ f ∼̇ h ∙ g ∙ f)

module _
  {𝔬} {𝔒 : Ø 𝔬}
  {𝔯} {_∼_ : 𝔒 → 𝔒 → Ø 𝔯}
  {ℓ} {_∼̇_ : ∀ {x y} → x ∼ y → x ∼ y → Ø ℓ}
  {transitivity : Transitivity.type _∼_}
  where
  transassociativity = Transassociativity.method _∼_ _∼̇_ transitivity
  syntax transassociativity f g h = h ⟨∙ g ⟨∙ f

module Transassociativity!
  {𝔬} {𝔒 : Ø 𝔬}
  {𝔯} (_∼_ : 𝔒 → 𝔒 → Ø 𝔯)
  {ℓ} (_∼̇_ : ∀ {x y} → x ∼ y → x ∼ y → Ø ℓ)
  ⦃ _ : Transitivity.class _∼_ ⦄
  = Transassociativity (_∼_) (_∼̇_) transitivity

module _
  {𝔬} {𝔒 : Ø 𝔬}
  {𝔯} {_∼_ : 𝔒 → 𝔒 → Ø 𝔯}
  {ℓ} (_∼̇_ : ∀ {x y} → x ∼ y → x ∼ y → Ø ℓ)
  ⦃ _ : Transitivity.class _∼_ ⦄
  where
  transassociativity![_] = Transassociativity.method _∼_ _∼̇_ transitivity


{-# OPTIONS --cubical --no-import-sorts --no-exact-split --safe #-}
module Cubical.Data.Queue.1List where

open import Cubical.Foundations.Everything

open import Cubical.Structures.Queue

open import Cubical.Data.Empty as ⊥
open import Cubical.Data.Maybe
open import Cubical.Data.List
open import Cubical.Data.Sigma

module 1List {ℓ} (A : Type ℓ) (Aset : isSet A) where
 open Queues-on A Aset

 Q = List A

 emp : Q
 emp = []

 enq : A → Q → Q
 enq = _∷_

 deq : Q → Maybe (Q × A)
 deq [] = nothing
 deq (x ∷ []) = just ([] , x)
 deq (x ∷ x' ∷ xs) = deqMap (enq x) (deq (x' ∷ xs))

 Raw : RawQueue
 Raw = (Q , emp , enq , deq)

 WithLaws : Queue
 WithLaws = (Q , S , isSetQ , refl , deq-enq , isInjEnq , isInjDeq)
  where
   S = str Raw

   isSetQ : isSet Q
   isSetQ = isOfHLevelList 0 Aset

   deq-enq : ∀ a q → deq (enq a q) ≡ just (returnOrEnq S a (deq q))
   deq-enq a [] = refl
   deq-enq a (x ∷ []) = refl
   deq-enq a (x ∷ x' ∷ xs) =
     subst
       (λ t →
         deqMap (enq a) (deqMap (enq x) t)
         ≡ just (returnOrEnq S a (deqMap (enq x) t)))
       (deq-enq x' xs ⁻¹)
       refl

   isInjEnq : ∀ a a' q q' → enq a q ≡ enq a' q' → (a ≡ a') × (q ≡ q')
   isInjEnq _ _ _ _ p = fst c , ListPath.decode _ _ (snd c)
     where
     c = ListPath.encode _ _ p

   isInjReturnOrEnq : ∀ a a' qr qr'
     → returnOrEnq S a qr ≡ returnOrEnq S a' qr'
     → (a ≡ a') × (qr ≡ qr')
   isInjReturnOrEnq a a' nothing nothing p = cong snd p , refl
   isInjReturnOrEnq a a' nothing (just (q' , b')) p =
     ⊥.rec (lower (ListPath.encode _ _ (cong fst p)))
   isInjReturnOrEnq a a' (just (q , b)) nothing p =
     ⊥.rec (lower (ListPath.encode _ _ (cong fst p)))
   isInjReturnOrEnq a a' (just (q , b)) (just (q' , b')) p =
     fst c , cong just (ΣPathP (ListPath.decode _ _ (snd c) , cong snd p))
     where
     c = ListPath.encode _ _ (cong fst p)

   isInjDeq-lemma : ∀ q q' → MaybePath.Cover (deq q) (deq q') → q ≡ q'
   isInjDeq-lemma [] [] _ = refl
   isInjDeq-lemma [] (y ∷ q') c =
     ⊥.rec (lower (subst (MaybePath.Cover nothing) (deq-enq y q') c))
   isInjDeq-lemma (x ∷ q) [] c =
     ⊥.rec (lower (subst (λ r → MaybePath.Cover r nothing) (deq-enq x q) c))
   isInjDeq-lemma (x ∷ q) (y ∷ q') c =
     cong₂ _∷_ (fst p) (isInjDeq-lemma q q' (MaybePath.encode _ _ (snd p)))
     where
     p : (x ≡ y) × (deq q ≡ deq q')
     p =
       isInjReturnOrEnq _ _ _ _
         (subst (uncurry MaybePath.Cover) (ΣPathP (deq-enq x q , deq-enq y q')) c)

   isInjDeq : ∀ q q' → deq q ≡ deq q' → q ≡ q'
   isInjDeq _ _ p = isInjDeq-lemma _ _ (MaybePath.encode _ _ p)

 Finite : FiniteQueue
 Finite = (Q , str WithLaws , subst isEquiv (sym (funExt foldrCons)) (idIsEquiv _))


module Data.Vec.Membership.Propositional.Distinct.Properties where
open import Data.Fin as Fin
open import Relation.Binary.PropositionalEquality as P
open import Data.Vec as Vec using (Vec; [] ; _∷_ ; _++_)
open import Data.Vec.Any
open import Data.Vec.Membership.Propositional.Distinct
open import Data.Vec.Membership.Propositional.Disjoint renaming (Disjoint to _⋈_)
open import Data.Vec.Membership.Propositional.Properties
open import Data.Vec.Membership.Propositional
open import Data.Product
open import Data.Empty using (⊥-elim)
open import Function using (_∘_)
open import Function.Equivalence using (_⇔_; equivalence)

distinct-++ˡ : ∀ {a}{A : Set a}{m n} (xs : Vec A m){ys : Vec A n} → Distinct (xs ++ ys) → Distinct xs
distinct-++ˡ [] dis = distinct-[]
distinct-++ˡ (x ∷ xs) (.x distinct-∷ dis by x∉xsys) = x distinct-∷ distinct-++ˡ xs dis by λ x∈xs → x∉xsys (∈-++⁺ˡ x∈xs)

distinct-++ʳ : ∀ {a}{A : Set a}{m n} (xs : Vec A m) {ys : Vec A n} → Distinct (xs ++ ys) → Distinct ys
distinct-++ʳ [] dys = dys
distinct-++ʳ (x ∷ xs) (.x distinct-∷ dxsys by _) = distinct-++ʳ xs dxsys

distinct-++→disjoint : ∀ {a}{A : Set a}{m n} (xs : Vec A m) {ys : Vec A n} → Distinct (xs ++ ys) → xs ⋈ ys
distinct-++→disjoint [] dxsys {z} () z∈ys
distinct-++→disjoint (x ∷ xs) (.x distinct-∷ dxsys by x∉xsys) {.x} (here refl) x∈ys = x∉xsys (∈-++⁺ʳ xs x∈ys)
distinct-++→disjoint (x ∷ xs) (.x distinct-∷ dxsys by x₁) {z} (there z∈xs) z∈ys = distinct-++→disjoint xs dxsys z∈xs z∈ys

⋈→distinct-++ : ∀ {a}{A : Set a}{m n}{xs : Vec A m}{ys : Vec A n} → Distinct xs → Distinct ys → xs ⋈ ys → Distinct (xs ++ ys)
⋈→distinct-++ {xs = []}  _ dys _ = dys
⋈→distinct-++ {xs = x ∷ xs} (.x distinct-∷ dxs by x∉xs) dys xxs⋈ys = x distinct-∷ ⋈→distinct-++ dxs dys (xxs⋈ys ∘ there)
  by λ x∈xs++ys → xxs⋈ys (here P.refl) (x∈xs++ys→x∉xs→x∈ys xs x∈xs++ys x∉xs)
  where
    x∈xs++ys→x∉xs→x∈ys : ∀ {a} {A : Set a} {m n} (xs : Vec A m){ys : Vec A n} →
                       ∀ {x} → x ∈ xs ++ ys → x ∉ xs → x ∈ ys
    x∈xs++ys→x∉xs→x∈ys [] x∈ys _ = x∈ys
    x∈xs++ys→x∉xs→x∈ys (x ∷ xs) (here refl) x∉xs = ⊥-elim (x∉xs (here refl))
    x∈xs++ys→x∉xs→x∈ys (x ∷ xs) (there x∈xsys) x∉xs = x∈xs++ys→x∉xs→x∈ys xs x∈xsys (x∉xs ∘ there)

distinct-++⇔⋈ : ∀ {a}{A : Set a}{m n} {xs : Vec A m}{ys : Vec A n} →
  Distinct (xs ++ ys) ⇔ (Distinct xs × Distinct ys × xs ⋈ ys)
distinct-++⇔⋈ = equivalence to from
  where
    open import Data.Nat.Properties

    to : ∀ {a}{A : Set a} {m n} {xs : Vec A m}{ys : Vec A n} →
         Distinct (xs ++ ys) → (Distinct xs × Distinct ys × xs ⋈ ys)
    to {xs = xs} dxsys = distinct-++ˡ xs dxsys , distinct-++ʳ xs dxsys , distinct-++→disjoint xs dxsys
    from : ∀ {a}{A : Set a} {m n} {xs : Vec A m}{ ys : Vec A n} →
         (Distinct xs × Distinct ys × xs ⋈ ys) → Distinct (xs ++ ys)
    from (dxs , dys , xs⋈ys) = ⋈→distinct-++ dxs dys xs⋈ys

private
  lookup-∈ : ∀ {a n}{A : Set a} i (xs : Vec A n) → Vec.lookup i xs ∈ xs
  lookup-∈ () []
  lookup-∈ zero (x ∷ xs) = here P.refl
  lookup-∈ (suc i) (x ∷ xs) = there (lookup-∈ i xs)

lookup-injective : ∀ {a n}{A : Set a} {xs : Vec A n}{i j} →
  Distinct xs → Vec.lookup i xs ≡ Vec.lookup j xs → i ≡ j
lookup-injective {i = ()} {j} distinct-[] _
lookup-injective {i = zero} {zero} (x distinct-∷ dxs by x∉xs) eq = P.refl
lookup-injective {i = suc i} {suc j} (x distinct-∷ dxs by x∉xs) eq = P.cong Fin.suc (lookup-injective dxs eq)
lookup-injective {xs = _ ∷ xs} {i = zero} {suc j} (x distinct-∷ dxs by x∉xs) eq rewrite eq =
  ⊥-elim (x∉xs (lookup-∈ j xs))
lookup-injective {xs = _ ∷ xs} {i = suc i} {zero} (x distinct-∷ dxs by x∉xs) eq  rewrite P.sym eq = ⊥-elim (x∉xs (lookup-∈ i xs))


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

open import HoTT
open import cohomology.FunctionOver
open import cohomology.FlipPushout

module cohomology.CofiberSequence {i} where

{- Lemma: pushing flip-susp through susp-fmap -}
⊙flip-susp-fmap : {X Y : Ptd i} (f : fst (X ⊙→ Y))
  → ⊙flip-susp Y ⊙∘ ⊙susp-fmap f == ⊙susp-fmap f ⊙∘ ⊙flip-susp X
⊙flip-susp-fmap {X = X} (f , idp) = ⊙λ= lemma-fst lemma-snd
  where
  lemma-fst : ∀ σ →
    flip-susp (susp-fmap f σ) == susp-fmap f (flip-susp σ)
  lemma-fst = Suspension-elim _ idp idp $ λ y → ↓-='-in $
    ap-∘ (susp-fmap f) flip-susp (merid _ y)
    ∙ ap (ap (susp-fmap f)) (FlipSusp.glue-β y)
    ∙ ap-! (susp-fmap f) (merid _ y)
    ∙ ap ! (SuspFmap.glue-β f y)
    ∙ ! (FlipSusp.glue-β (f y))
    ∙ ! (ap (ap flip-susp) (SuspFmap.glue-β f y))
    ∙ ∘-ap flip-susp (susp-fmap f) (merid _ y)

  lemma-snd :
    ! (merid _ (f (snd X))) == ap (susp-fmap f) (! (merid _ (snd X))) ∙ idp
  lemma-snd =
     ap ! (! (SuspFmap.glue-β f (snd X)))
     ∙ !-ap (susp-fmap f) (merid _ (snd X))
     ∙ ! (∙-unit-r _)

{- Useful abbreviations -}
module _ {X Y : Ptd i} (f : fst (X ⊙→ Y)) where

  ⊙Cof² = ⊙Cof (⊙cfcod f)
  ⊙cfcod² = ⊙cfcod (⊙cfcod f)
  ⊙Cof³ = ⊙Cof ⊙cfcod²
  ⊙cfcod³ = ⊙cfcod ⊙cfcod²
  ⊙Cof⁴ = ⊙Cof ⊙cfcod³
  ⊙cfcod⁴ = ⊙cfcod ⊙cfcod³

{- For [f : X → Y], the cofiber space [Cof(cfcod f)] is equivalent to
 - [Suspension X]. This is essentially an application of the two pushouts
 - lemma:
 -
 -       f
 -   X ––––> Y ––––––––––––––> ∙
 -   |       |                 |
 -   |       |cfcod f          |
 -   v       v                 v
 -   ∙ ––> Cof f ––––––––––> Cof² f
 -                cfcod² f
 -
 - The map [cfcod² f : Cof f → Cof² f] becomes [ext-glue : Cof f → ΣX],
 - and the map [ext-glue : Cof² f → ΣY] becomes [susp-fmap f : ΣX → ΣY].
 -}
module Cof² {X Y : Ptd i} (f : fst (X ⊙→ Y)) where

  module Equiv {X Y : Ptd i} (f : fst (X ⊙→ Y)) where

    module Into = CofiberRec (cfcod (fst f)) {C = fst (⊙Susp X)}
      (south _) ext-glue (λ _ → idp)

    into = Into.f

    module Out = SuspensionRec (fst X) {C = fst (⊙Cof² f)}
      (cfcod _ (cfbase _)) (cfbase _)
      (λ x → ap (cfcod _) (cfglue _ x) ∙ ! (cfglue _ (fst f x)))

    out = Out.f

    into-out : ∀ σ → into (out σ) == σ
    into-out = Suspension-elim (fst X) idp idp
      (λ x → ↓-∘=idf-in into out $
        ap (ap into) (Out.glue-β x)
        ∙ ap-∙ into (ap (cfcod _) (cfglue _ x)) (! (cfglue _ (fst f x)))
        ∙ ap (λ w → ap into (ap (cfcod _) (cfglue _ x)) ∙ w)
             (ap-! into (cfglue _ (fst f x)) ∙ ap ! (Into.glue-β (fst f x)))
        ∙ ∙-unit-r _
        ∙ ∘-ap into (cfcod _) (cfglue _ x) ∙ ExtGlue.glue-β x)

    out-into : ∀ κ → out (into κ) == κ
    out-into = Cofiber-elim (cfcod (fst f))
      idp
      (Cofiber-elim (fst f) idp (cfglue _)
        (λ x → ↓-='-from-square $
          (ap-∘ out ext-glue (cfglue _ x)
           ∙ ap (ap out) (ExtGlue.glue-β x) ∙ Out.glue-β x)
          ∙v⊡ (vid-square {p = ap (cfcod _) (cfglue _ x)}
               ⊡h rt-square (cfglue _ (fst f x)))
          ⊡v∙ ∙-unit-r _))
      (λ y → ↓-∘=idf-from-square out into $
         ap (ap out) (Into.glue-β y) ∙v⊡ connection)

    eq = equiv into out into-out out-into

    space-path : ⊙Cof² f == ⊙Susp X
    space-path = ⊙ua eq (! (merid _ (snd X)))

  cfcod²-over : ⊙cfcod² f == ⊙ext-glue
                [ (λ U → fst (⊙Cof f ⊙→ U)) ↓ Equiv.space-path f ]
  cfcod²-over = ind-lemma f
    where
    {- is there a better way to handle this? -}
    ind-lemma : {X Y : Ptd i} (f : fst (X ⊙→ Y))
      → ⊙cfcod² f == ⊙ext-glue
        [ (λ U → fst (⊙Cof f ⊙→ U)) ↓ Equiv.space-path f ]
    ind-lemma {X = X} (f , idp) =
      codomain-over-⊙equiv (⊙cfcod² (f , idp)) _ _
      ▹ pair= idp (l snd-lemma)
      where
      x₀ = snd X; y₀ = f (snd X); F = (f , idp {a = y₀})

      snd-lemma : ap (Equiv.into F)
                     (ap (cfcod (cfcod f)) (! (! (cfglue _ x₀)))
                      ∙ ! (cfglue _ y₀))
                  == merid _ x₀
      snd-lemma =
        ap (Equiv.into F)
           (ap (cfcod (cfcod f)) (! (! (cfglue _ x₀))) ∙ ! (cfglue _ y₀))
          =⟨ !-! (cfglue _ x₀) |in-ctx (λ w →
               ap (Equiv.into F) (ap (cfcod (cfcod f)) w ∙ ! (cfglue _ y₀))) ⟩
        ap (Equiv.into F)
           (ap (cfcod (cfcod f)) (cfglue _ x₀) ∙ ! (cfglue _ y₀))
          =⟨ ap-∙ (Equiv.into F)
               (ap (cfcod (cfcod f)) (cfglue _ x₀)) (! (cfglue _ y₀)) ⟩
        ap (Equiv.into F) (ap (cfcod (cfcod f)) (cfglue _ x₀))
        ∙ ap (Equiv.into F) (! (cfglue _ y₀))
          =⟨ ∘-ap (Equiv.into F) (cfcod (cfcod f)) (cfglue _ x₀)
             |in-ctx (λ w → w ∙ ap (Equiv.into F) (! (cfglue _ y₀))) ⟩
        ap ext-glue (cfglue _ x₀) ∙ ap (Equiv.into F) (! (cfglue _ y₀))
          =⟨ ExtGlue.glue-β x₀
             |in-ctx (λ w → w ∙ ap (Equiv.into F) (! (cfglue _ y₀))) ⟩
        merid _ x₀ ∙ ap (Equiv.into F) (! (cfglue _ y₀))
          =⟨ ap-! (Equiv.into F) (cfglue _ y₀) |in-ctx (λ w → merid _ x₀ ∙ w) ⟩
        merid _ x₀ ∙ ! (ap (Equiv.into F) (cfglue _ y₀))
          =⟨ Equiv.Into.glue-β F y₀ |in-ctx (λ w → merid _ x₀ ∙ ! w) ⟩
        merid _ x₀ ∙ idp
          =⟨ ∙-unit-r _ ⟩
        merid _ x₀ ∎

      l : ∀ {i} {A : Type i} {x y : A} {p q : x == y}
        → p == q → p ∙ ! q == idp
      l {p = p} {q = q} α = ap (λ r → r ∙ ! q) α ∙ !-inv-r q

  cfcod³-over :
    ⊙ext-glue == ⊙flip-susp Y ⊙∘ ⊙susp-fmap f
    [ (λ U → fst (U ⊙→ ⊙Susp Y)) ↓ Equiv.space-path f ]
  cfcod³-over =
    ⊙λ= fst-lemma (l snd-lemma)
    ◃ domain-over-⊙equiv (⊙flip-susp Y ⊙∘ ⊙susp-fmap f) _ _
    where
    fst-lemma : (κ : fst (⊙Cof² f))
      → ext-glue κ == flip-pushout (susp-fmap (fst f) (Equiv.into f κ))
    fst-lemma = Cofiber-elim (cfcod (fst f))
      idp
      (Cofiber-elim (fst f)
        idp
        (! ∘ merid (fst Y))
        (λ x → ↓-='-from-square $
          ap-cst (south _) (cfglue _ x) ∙v⊡
            connection
          ⊡v∙ ! (ap-∘ (flip-pushout ∘ susp-fmap (fst f)) ext-glue (cfglue _ x)
                 ∙ ap (ap (flip-pushout ∘ susp-fmap (fst f))) (ExtGlue.glue-β x)
                 ∙ ap-∘ flip-pushout (susp-fmap (fst f)) (merid _ x)
                 ∙ ap (ap flip-pushout) (SuspFmap.glue-β (fst f) x)
                 ∙ FlipPushout.glue-β (fst f x))))
      (λ y → ↓-='-from-square $
        ExtGlue.glue-β y ∙v⊡
          tr-square (merid _ y)
        ⊡v∙ ! (ap-∘ (flip-pushout ∘ susp-fmap (fst f)) (Equiv.into f)
                    (cfglue _ y)
               ∙ ap (ap (flip-pushout ∘ susp-fmap (fst f)))
                    (Equiv.Into.glue-β f y)))

    snd-lemma : ap (flip-pushout ∘ susp-fmap (fst f)) (! (merid _ (snd X)))
                == merid _ (snd Y)
    snd-lemma =
      ap (flip-pushout ∘ susp-fmap (fst f)) (! (merid _ (snd X)))
        =⟨ ap-! (flip-pushout ∘ susp-fmap (fst f)) (merid _ (snd X)) ⟩
      ! (ap (flip-pushout ∘ susp-fmap (fst f)) (merid _ (snd X)))
        =⟨ ap ! (ap-∘ flip-pushout (susp-fmap (fst f)) (merid _ (snd X))) ⟩
      ! (ap flip-pushout (ap (susp-fmap (fst f)) (merid _ (snd X))))
        =⟨ ap (! ∘ ap flip-pushout) (SuspFmap.glue-β (fst f) (snd X)) ⟩
      ! (ap flip-pushout (merid _ (fst f (snd X))))
        =⟨ ap ! (FlipPushout.glue-β (fst f (snd X))) ⟩
      ! (! (merid _ (fst f (snd X))))
        =⟨ !-! (merid _ (fst f (snd X))) ⟩
      merid _ (fst f (snd X))
        =⟨ ap (merid _) (snd f) ⟩
      merid _ (snd Y) ∎

    l : ∀ {i} {A : Type i} {x y : A} {p q : x == y}
      → p == q → idp == p ∙ ! q
    l {p = p} {q = q} α = ! (!-inv-r p) ∙ ap (λ w → p ∙ ! w) α

  open Equiv f public

  full-path : Path
    {A = Σ (Ptd i) (λ U → fst (⊙Cof f ⊙→ U) × fst (U ⊙→ ⊙Susp Y))}
    (_ , ⊙cfcod² f , ⊙ext-glue)
    (_ , ⊙ext-glue , ⊙flip-susp Y ⊙∘ ⊙susp-fmap f)
  full-path = pair= space-path (↓-×-in cfcod²-over cfcod³-over)

cofiber-sequence : {X Y : Ptd i} (f : fst (X ⊙→ Y)) → Path
  {A = Σ (Ptd i × Ptd i × Ptd i)
         (λ {(U , V , W) → fst (⊙Cof f ⊙→ U) × fst (U ⊙→ V) × fst (V ⊙→ W)})}
  (_ , ⊙cfcod² f , ⊙cfcod³ f , ⊙cfcod⁴ f)
  (_ , ⊙ext-glue , ⊙susp-fmap f , ⊙susp-fmap (⊙cfcod f))
cofiber-sequence {Y = Y} f =
    ap (λ {(_ , g , _) → (_ , ⊙cfcod² f , ⊙cfcod³ f , g)})
       (Cof².full-path (⊙cfcod² f))
  ∙ ap (λ {(_ , g , h) → (_ , ⊙cfcod² f , g , h)})
       (Cof².full-path (⊙cfcod f))
  ∙ ap (λ {(_ , g , h) → (_ , g , h , ⊙flip-susp (⊙Cof f) ⊙∘
                                      ⊙susp-fmap (⊙cfcod f))})
       (Cof².full-path f)
  ∙ ap (λ g → (_ , ⊙ext-glue , ⊙flip-susp Y ⊙∘ ⊙susp-fmap f , g))
       (⊙flip-susp-fmap (⊙cfcod f))
  ∙ ap (λ {(_ , g , h) → (_ , ⊙ext-glue , g , h)})
       (pair= (flip-⊙pushout-path (suspension-⊙span Y))
          (↓-×-in (codomain-over-⊙equiv
                    (⊙flip-susp Y ⊙∘ ⊙susp-fmap f) _ _
                   ▹ lemma)
                  (domain-over-⊙equiv (⊙susp-fmap (⊙cfcod f)) _ _)))
  where
  lemma : ⊙flip-susp Y ⊙∘ ⊙flip-susp Y ⊙∘ ⊙susp-fmap f
       == ⊙susp-fmap f
  lemma = ! (⊙∘-assoc (⊙flip-susp Y) (⊙flip-susp Y) (⊙susp-fmap f))
          ∙ ap (λ w → w ⊙∘ ⊙susp-fmap f)
               (flip-⊙pushout-involutive (suspension-⊙span Y))
          ∙ ⊙∘-unit-l (⊙susp-fmap f)

suspend-cofiber : {X Y : Ptd i} (f : fst (X ⊙→ Y)) → Path
  {A = Σ _ (λ {(U , V , W) → fst (U ⊙→ V) × fst (V ⊙→ W)})}
  (_ , ⊙susp-fmap f , ⊙cfcod (⊙susp-fmap f))
  (_ , ⊙susp-fmap f , ⊙susp-fmap (⊙cfcod f))
suspend-cofiber f =
  ap (λ {((U , V , W) , _ , g , _) → ((U , V , ⊙Cof g) , g , ⊙cfcod g)})
     (! (cofiber-sequence f))
  ∙ ap (λ {(_ , _ , g , h) → (_ , g , h)}) (cofiber-sequence f)

suspend^-cof= : {X Y Z : Ptd i} (m : ℕ) (f : fst (X ⊙→ Y)) (g : fst (Y ⊙→ Z))
  (p : Path {A = Σ _ (λ U → fst (Y ⊙→ U))} (⊙Cof f , ⊙cfcod f) (Z , g))
  → Path {A = Σ _ (λ {(U , V , W) → fst (U ⊙→ V) × fst (V ⊙→ W)})}
    (_ , ⊙susp^-fmap m f , ⊙cfcod (⊙susp^-fmap m f))
    (_ , ⊙susp^-fmap m f , ⊙susp^-fmap m g)
suspend^-cof= O f g p = ap (λ {(_ , h) → (_ , f , h)}) p
suspend^-cof= (S m) f g p =
  suspend-cofiber (⊙susp^-fmap m f)
  ∙ ap (λ {(_ , h , k) → (_ , ⊙susp-fmap h , ⊙susp-fmap k)})
       (suspend^-cof= m f g p)


{-# OPTIONS --copatterns --sized-types #-}

open import Common.Size

module Issue1038 (A : Set) where

record S (i : Size) : Set where
  field
    force : ∀ (j : Size< i) → A

head : ∀ i → S i → (j : Size< i) → A
head i s j = S.force s _

-- Problem was:
-- Cannot solve size constraints
-- (↑ _9 A i s j) =< (_i_8 A i s j) : Size
-- (_i_8 A i s j) =< i : Size
-- when checking the definition of head

-- Works now.


{-# OPTIONS --safe --warning=error --without-K --guardedness #-}

open import Setoids.Setoids
open import Rings.Definition
open import Rings.Lemmas
open import Rings.Orders.Partial.Definition
open import Rings.Orders.Total.Definition
open import Groups.Definition
open import Groups.Lemmas
open import Fields.Fields
open import Sets.EquivalenceRelations
open import Sequences
open import Setoids.Orders.Partial.Definition
open import Setoids.Orders.Total.Definition
open import Functions.Definition
open import LogicalFormulae
open import Numbers.Naturals.Semiring
open import Numbers.Naturals.Order
open import Numbers.Naturals.Order.Lemmas
open import Semirings.Definition

module Fields.CauchyCompletion.Approximation {m n o : _} {A : Set m} {S : Setoid {m} {n} A} {_+_ : A → A → A} {_*_ : A → A → A} {_<_ : Rel {m} {o} A} {pOrder : SetoidPartialOrder S _<_} {R : Ring S _+_ _*_} {pRing : PartiallyOrderedRing R pOrder} (order : TotallyOrderedRing pRing) (F : Field R) where

open Setoid S
open SetoidTotalOrder (TotallyOrderedRing.total order)
open SetoidPartialOrder pOrder
open Equivalence eq
open PartiallyOrderedRing pRing
open Ring R
open Group additiveGroup
open Field F

open import Fields.Lemmas F
open import Fields.Orders.Lemmas {F = F} record { oRing = order }
open import Rings.Orders.Total.Lemmas order
open import Rings.Orders.Total.AbsoluteValue order
open import Rings.Orders.Partial.Lemmas pRing
open import Fields.CauchyCompletion.Definition order F
open import Fields.CauchyCompletion.Addition order F
open import Fields.CauchyCompletion.Comparison order F
open import Rings.InitialRing R
open import Fields.Orders.Total.Lemmas {F = F} (record { oRing = order })

abstract

  chain : {a b : A} (c : CauchyCompletion) → (a r<C c) → (c <Cr b) → a < b
  chain {a} {b} c record { e = betweenAC ; 0<e = 0<betweenAC ; N = Nac ; pr = prAC } record { e = betweenCB ; 0<e = 0<betweenCB ; N = Nb ; property = prBC } = SetoidPartialOrder.<Transitive pOrder (SetoidPartialOrder.<Transitive pOrder (<WellDefined identLeft (Equivalence.reflexive eq) (orderRespectsAddition 0<betweenAC a)) (<WellDefined groupIsAbelian (Equivalence.reflexive eq) (SetoidPartialOrder.<Transitive pOrder (prAC (succ Nac +N Nb) (le Nb (applyEquality succ (Semiring.commutative ℕSemiring Nb Nac)))) (<WellDefined identLeft (Equivalence.reflexive eq) (orderRespectsAddition 0<betweenCB (index (Sequence.tail (CauchyCompletion.elts c)) (Nac +N Nb))))))) (prBC (succ Nac +N Nb) (le Nac refl))

  private
    approxLemma : (a : CauchyCompletion) (e e/2 : A) → (0G < e) → (e/2 + e/2 ∼ e) → (m N : ℕ) → abs ((index (CauchyCompletion.elts a) m) + inverse (index (CauchyCompletion.elts a) N)) < e/2 → (e/2 + index (CauchyCompletion.elts a) m) < (index (CauchyCompletion.elts a) N + e)
    approxLemma a e e/2 0<e prE/2 m N ans with totality 0R ((index (CauchyCompletion.elts a) m) + inverse (index (CauchyCompletion.elts a) N))
    approxLemma a e e/2 0<e prE/2 m N ans | inl (inl x) with <WellDefined (Equivalence.transitive eq (Equivalence.transitive eq (Equivalence.symmetric eq +Associative) (+WellDefined (Equivalence.reflexive eq) (invLeft))) identRight) groupIsAbelian (orderRespectsAddition ans (index (CauchyCompletion.elts a) N))
    ... | bl = <WellDefined groupIsAbelian (Equivalence.transitive eq (Equivalence.symmetric eq +Associative) (+WellDefined (Equivalence.reflexive eq) prE/2)) (orderRespectsAddition bl e/2)
    approxLemma a e e/2 0<e prE/2 m N ans | inl (inr x) with <WellDefined (Equivalence.transitive eq (Equivalence.transitive eq (Equivalence.symmetric eq +Associative) (+WellDefined (Equivalence.reflexive eq) (invLeft))) identRight) (identLeft) (orderRespectsAddition x (index (CauchyCompletion.elts a) N))
    ... | bl = <WellDefined groupIsAbelian (Equivalence.reflexive eq) (ringAddInequalities bl (halfLess e/2 e 0<e prE/2))
    approxLemma a e e/2 0<e prE/2 m N ans | inr x with transferToRight additiveGroup (Equivalence.symmetric eq x)
    ... | bl = <WellDefined (+WellDefined (Equivalence.reflexive eq) (Equivalence.symmetric eq bl)) groupIsAbelian (orderRespectsAddition (halfLess e/2 e 0<e prE/2) (index (CauchyCompletion.elts a) N))

approximateAboveCrude : (a : CauchyCompletion) → A
approximateAboveCrude a with CauchyCompletion.converges a 1R (0<1 (charNot2ImpliesNontrivial R charNot2))
... | N , conv = (((index (CauchyCompletion.elts a) (succ N)) + 1R) + 1R) + 1R

abstract
  approximateAboveCrudeIsAbove : (a : CauchyCompletion) → a <Cr (approximateAboveCrude a)
  approximateAboveCrudeIsAbove a with CauchyCompletion.converges a 1R (0<1 (charNot2ImpliesNontrivial R charNot2))
  ... | N , conv = record { e = 1R ; 0<e = 0<1 (charNot2ImpliesNontrivial R charNot2) ; N = N ; property = ans }
    where
      ans : (m : ℕ) → (N <N m) → (1R + index (CauchyCompletion.elts a) m) < (((index (CauchyCompletion.elts a) (succ N) + 1R) + 1R) + 1R)
      ans m N<m with conv {m} {succ N} N<m (le 0 refl)
      ... | bl with totality 0G (index (CauchyCompletion.elts a) m + inverse (index (CauchyCompletion.elts a) (succ N)))
      ans m N<m | bl | inl (inl 0<am-aN) with <WellDefined (Equivalence.transitive eq (Equivalence.transitive eq (Equivalence.symmetric eq +Associative) (+WellDefined (Equivalence.reflexive eq) (invLeft))) identRight) (Equivalence.reflexive eq) (orderRespectsAddition bl (index (CauchyCompletion.elts a) (succ N)))
      ... | am<1+an = <WellDefined (Equivalence.transitive eq (+WellDefined (Equivalence.reflexive eq) identLeft) groupIsAbelian) (Equivalence.transitive eq (+WellDefined groupIsAbelian (Equivalence.reflexive eq)) +Associative) (ringAddInequalities am<1+an (orderRespectsAddition (0<1 (charNot2ImpliesNontrivial R charNot2)) 1R))
      ans m N<m | bl | inl (inr am-aN<0) with <WellDefined (Equivalence.transitive eq (Equivalence.transitive eq (Equivalence.symmetric eq +Associative) (+WellDefined (Equivalence.reflexive eq) invLeft)) identRight) identLeft (orderRespectsAddition am-aN<0 (index (CauchyCompletion.elts a) (succ N)))
      ... | am<aN = <WellDefined groupIsAbelian (Equivalence.reflexive eq) (orderRespectsAddition (SetoidPartialOrder.<Transitive pOrder am<aN (<WellDefined (Equivalence.reflexive eq) (+Associative) (<WellDefined identLeft groupIsAbelian (orderRespectsAddition (<WellDefined identLeft (Equivalence.reflexive eq) (ringAddInequalities (0<1 (charNot2ImpliesNontrivial R charNot2)) (0<1 (charNot2ImpliesNontrivial R charNot2)))) (index (CauchyCompletion.elts a) (succ N)))))) 1R)
      ans m N<m | bl | inr 0=am-aN = <WellDefined (Equivalence.transitive eq (+WellDefined identLeft (Equivalence.reflexive eq)) identLeft) (Equivalence.transitive eq groupIsAbelian (Equivalence.transitive eq (+WellDefined (Equivalence.transitive eq groupIsAbelian (+WellDefined (transferToRight additiveGroup (Equivalence.symmetric eq 0=am-aN)) (Equivalence.reflexive eq))) (Equivalence.reflexive eq)) +Associative)) (orderRespectsAddition (ringAddInequalities (0<1 (charNot2ImpliesNontrivial R charNot2)) (0<1 (charNot2ImpliesNontrivial R charNot2))) (1R + (index (CauchyCompletion.elts a) m)))

rationalApproximatelyAbove : (a : CauchyCompletion) → (e : A) → (0G < e) → A
rationalApproximatelyAbove a e 0<e with halve charNot2 e
... | e/2 , prE/2 with halvePositive e/2 (<WellDefined (Equivalence.reflexive eq) (Equivalence.symmetric eq prE/2) 0<e)
... | 0<e/2 with halve charNot2 e/2
... | e/4 , prE/4 with halvePositive e/4 (<WellDefined (Equivalence.reflexive eq) (Equivalence.symmetric eq prE/4) 0<e/2)
... | 0<e/4 with CauchyCompletion.converges a e/4 0<e/4
... | N , cauchyBeyondN = index (CauchyCompletion.elts a) (succ N) + e/2

abstract
  rationalApproximatelyAboveIsAbove : (a : CauchyCompletion) (e : A) → (0<e : 0G < e) → a <Cr (rationalApproximatelyAbove a e 0<e)
  rationalApproximatelyAboveIsAbove a e 0<e with halve charNot2 e
  ... | e/2 , prE/2 with halvePositive e/2 (<WellDefined (Equivalence.reflexive eq) (Equivalence.symmetric eq prE/2) 0<e)
  ... | 0<e/2 with halve charNot2 e/2
  ... | e/4 , prE/4 with halvePositive e/4 (<WellDefined (Equivalence.reflexive eq) (Equivalence.symmetric eq prE/4) 0<e/2)
  ... | 0<e/4 with CauchyCompletion.converges a e/4 0<e/4
  ... | N , cauchyBeyondN with halve charNot2 e/4
  ... | e/8 , prE/8 with halvePositive e/8 (<WellDefined (Equivalence.reflexive eq) (Equivalence.symmetric eq prE/8) 0<e/4)
  ... | 0<e/8 with CauchyCompletion.converges a e/8 0<e/8
  ... | N2 , cauchyBeyondN2 = record { e = e/8 ; 0<e = 0<e/8 ; N = N +N N2 ; property = ans2 }
    where
      ans2 : (m : ℕ) → N +N N2 <N m → (e/8 + index (CauchyCompletion.elts a) m) < (index (CauchyCompletion.elts a) (succ N) + e/2)
      ans2 m <m with cauchyBeyondN {m} {succ N} (inequalityShrinkLeft <m) (le 0 refl)
      ... | absam-aN<e/4 with totality 0R ((index (CauchyCompletion.elts a) m) + inverse (index (CauchyCompletion.elts a) (succ N)))
      ans2 m <m | am-aN<e/4 | inl (inl 0<am-aN) = SetoidPartialOrder.<Transitive pOrder (<WellDefined groupIsAbelian (Equivalence.transitive eq groupIsAbelian  +Associative) (orderRespectsAddition (<WellDefined (Equivalence.transitive eq (Equivalence.transitive eq (Equivalence.symmetric eq +Associative) (+WellDefined (Equivalence.reflexive eq) invLeft)) identRight) (Equivalence.reflexive eq) (orderRespectsAddition am-aN<e/4 (index (CauchyCompletion.elts a) (succ N)))) e/8)) (<WellDefined (Equivalence.reflexive eq) groupIsAbelian (orderRespectsAddition (<WellDefined (Equivalence.reflexive eq) prE/4 (orderRespectsAddition (halfLess e/8 e/4 0<e/4 prE/8) e/4)) (index (CauchyCompletion.elts a) (succ N))))
      ans2 m <m | -[am-aN]<e/4 | inl (inr am-aN<0) with <WellDefined (Equivalence.transitive eq +Associative (Equivalence.transitive eq (+WellDefined invLeft (Equivalence.reflexive eq)) identLeft)) (Equivalence.reflexive eq) (orderRespectsAddition (<WellDefined (Equivalence.reflexive eq) (invTwice additiveGroup _) (ringSwapNegatives' -[am-aN]<e/4)) (e/4 + e/8))
      ... | e/8<am-aN+e/4+e/8 = SetoidPartialOrder.<Transitive pOrder (orderRespectsAddition e/8<am-aN+e/4+e/8 (index (CauchyCompletion.elts a) m)) (<WellDefined (Equivalence.reflexive eq) groupIsAbelian (ringAddInequalities (<WellDefined (Equivalence.reflexive eq) identLeft (ringAddInequalities am-aN<0 (<WellDefined groupIsAbelian prE/4 (orderRespectsAddition (halfLess e/8 e/4 0<e/4 prE/8) e/4)))) am<aN))
        where
          am<aN : (index (CauchyCompletion.elts a) m) < (index (CauchyCompletion.elts a) (succ N))
          am<aN = <WellDefined (Equivalence.transitive eq (Equivalence.transitive eq (Equivalence.symmetric eq +Associative) (+WellDefined (Equivalence.reflexive eq) groupIsAbelian)) (Equivalence.transitive eq (+WellDefined (Equivalence.reflexive eq) invRight) identRight)) identLeft (orderRespectsAddition am-aN<0 (index (CauchyCompletion.elts a) (succ N)))
      ans2 m <m | absam-aN<e/4 | inr 0=am-aN = <WellDefined (Equivalence.reflexive eq) (Equivalence.transitive eq groupIsAbelian (+WellDefined (transferToRight additiveGroup (Equivalence.symmetric eq 0=am-aN)) (Equivalence.reflexive eq))) (orderRespectsAddition {b = e/2} (SetoidPartialOrder.<Transitive pOrder (halfLess e/8 e/4 0<e/4 prE/8) (halfLess e/4 e/2 0<e/2 prE/4)) (index (CauchyCompletion.elts a) m))

  rationalApproximatelyAboveIsNear : (a : CauchyCompletion) (e : A) → (0<e : 0G < e) → (injection (rationalApproximatelyAbove a e 0<e) +C (-C a)) <C (injection e)
  rationalApproximatelyAboveIsNear a e 0<e with halve charNot2 e
  ... | e/2 , prE/2 with halvePositive e/2 (<WellDefined (Equivalence.reflexive eq) (Equivalence.symmetric eq prE/2) 0<e)
  ... | 0<e/2 with halve charNot2 e/2
  ... | e/4 , prE/4 with halvePositive e/4 (<WellDefined (Equivalence.reflexive eq) (Equivalence.symmetric eq prE/4) 0<e/2)
  ... | 0<e/4 with CauchyCompletion.converges a e/4 0<e/4
  ... | N , cauchyBeyondN with halve charNot2 e/4
  ... | e/8 , prE/8 with halvePositive e/8 (<WellDefined (Equivalence.reflexive eq) (Equivalence.symmetric eq prE/8) 0<e/4)
  ... | 0<e/8 with CauchyCompletion.converges a e/8 0<e/8
  ... | N8 , cauchyBeyondN8 with halve charNot2 e/8
  ... | e/16 , prE/16 with halvePositive e/16 (<WellDefined (Equivalence.reflexive eq) (Equivalence.symmetric eq prE/16) 0<e/8)
  ... | 0<e/16 = record { i = (e/2 + e/4) + e/8 ; a<i = record { e = e/8 ; 0<e = 0<e/8 ; N = N +N N8 ; property = ans } ; i<b = record { e = e/16 ; 0<e = 0<e/16 ; N = 0 ; pr = t' } }
    where
      t' : (m : ℕ) → (0 <N m) → (((e/2 + e/4) + e/8) + e/16) < index (constSequence e) m
      t' m 0<m rewrite indexAndConst e m = <WellDefined (Equivalence.reflexive eq) prE/2 (<WellDefined (Equivalence.reflexive eq) (+WellDefined (Equivalence.reflexive eq) prE/4) (<WellDefined +Associative (Equivalence.symmetric eq +Associative) (<WellDefined groupIsAbelian groupIsAbelian (orderRespectsAddition (<WellDefined (Equivalence.reflexive eq) prE/8 (<WellDefined groupIsAbelian groupIsAbelian (orderRespectsAddition (halfLess e/16 e/8 0<e/8 prE/16) e/8))) (e/2 + e/4)))))
      ans : (m : ℕ) → (N +N N8) <N m → (e/8 + index (apply _+_ (constSequence (index (CauchyCompletion.elts a) (succ N) + e/2)) (map inverse (CauchyCompletion.elts a))) m) < ((e/2 + e/4) + e/8)
      ans m N<m rewrite indexAndApply (constSequence (index (CauchyCompletion.elts a) (succ N) + e/2)) (map inverse (CauchyCompletion.elts a)) _+_ {m} | indexAndConst (index (CauchyCompletion.elts a) (succ N) + e/2) m | equalityCommutative (mapAndIndex (CauchyCompletion.elts a) inverse m) = <WellDefined groupIsAbelian (+WellDefined groupIsAbelian (Equivalence.reflexive eq)) (orderRespectsAddition (<WellDefined (Equivalence.transitive eq groupIsAbelian (Equivalence.reflexive eq)) (Equivalence.reflexive eq) q) e/8)
        where
          am : A
          am = index (CauchyCompletion.elts a) m
          aN : A
          aN = index (CauchyCompletion.elts a) (succ N)
          t : abs (am + inverse aN) < e/4
          t = cauchyBeyondN {m} {succ N} (inequalityShrinkLeft N<m) (le 0 refl)
          r : ((inverse am) + aN) < e/4
          r with t
          ... | f with totality 0G (am + inverse aN)
          r | am-aN<e/4 | inl (inl 0<am-aN) = SetoidPartialOrder.<Transitive pOrder (<WellDefined (Equivalence.transitive eq (invContravariant additiveGroup) (Equivalence.transitive eq groupIsAbelian (+WellDefined (Equivalence.reflexive eq) (invTwice additiveGroup _)))) (Equivalence.reflexive eq) (lemm2' _ 0<am-aN)) 0<e/4
          r | f | inl (inr x) = <WellDefined (Equivalence.transitive eq (invContravariant additiveGroup) (Equivalence.transitive eq groupIsAbelian (+WellDefined (Equivalence.reflexive eq) (invTwice additiveGroup _)))) (Equivalence.reflexive eq) f
          r | am-aN<e/4 | inr 0=am-aN = <WellDefined (Equivalence.transitive eq (Equivalence.symmetric eq 0=am-aN) (Equivalence.transitive eq (Equivalence.transitive eq (Equivalence.transitive eq (Equivalence.transitive eq (Equivalence.symmetric eq (invIdent additiveGroup)) (inverseWellDefined additiveGroup 0=am-aN)) (inverseWellDefined additiveGroup groupIsAbelian)) (invContravariant additiveGroup)) (+WellDefined (Equivalence.reflexive eq) (invTwice additiveGroup _)))) (Equivalence.reflexive eq) am-aN<e/4
          q : ((inverse (index (CauchyCompletion.elts a) m)) + (index (CauchyCompletion.elts a) (succ N) + e/2)) < (e/4 + e/2)
          q = <WellDefined (Equivalence.symmetric eq +Associative) (Equivalence.reflexive eq) (orderRespectsAddition r e/2)

  approximateAbove : (a : CauchyCompletion) → (ε : A) → (0G < ε) → Sg A (λ b → (a <Cr b) && (injection b +C (-C a)) <C (injection ε))
  approximateAbove a e 0<e = rationalApproximatelyAbove a e 0<e , (rationalApproximatelyAboveIsAbove a e 0<e ,, rationalApproximatelyAboveIsNear a e 0<e)

  approximateBelow : (a : CauchyCompletion) → (ε : A) → (0G < ε) → Sg A (λ b → (b r<C a) && (a +C (-C injection b)) <C (injection ε))
  approximateBelow a e 0<e with approximateAbove (-C a) e 0<e
  ... | x , (record { e = deltaXAnd-A ; 0<e = 0<deltaXA ; N = NdeltaXA ; property = prDeltaXA } ,, record { i = rationalNear ; a<i = record { e = bound ; 0<e = 0<bound ; N = N ; property = prBound } ; i<b = record { e = bound2 ; 0<e = 0<bound2 ; N = N2 ; pr = prBound2 } }) = inverse x , (record { e = deltaXAnd-A ; 0<e = 0<deltaXA ; N = NdeltaXA ; pr = λ m N<m → <WellDefined (Equivalence.transitive eq groupIsAbelian (Equivalence.transitive eq (Equivalence.symmetric eq +Associative) (+WellDefined (Equivalence.reflexive eq) (Equivalence.transitive eq groupIsAbelian (Equivalence.transitive eq (Equivalence.symmetric eq +Associative) (Equivalence.transitive eq (+WellDefined (Equivalence.reflexive eq) (cancel {m} (CauchyCompletion.elts a))) identRight)))))) (Equivalence.transitive eq +Associative (Equivalence.transitive eq (+WellDefined invRight (Equivalence.reflexive eq)) identLeft)) (orderRespectsAddition (prDeltaXA m N<m) (inverse x + (index (CauchyCompletion.elts a) m))) } ,, record { i = rationalNear ; a<i = record { e = bound ; 0<e = 0<bound ; N = N ; property = pr1 } ; i<b = record { e = bound2 ; 0<e = 0<bound2 ; N = N2 ; pr = prBound2 } })
    where
      cancel : {m : ℕ} (a : Sequence A) → (index (map inverse a) m) + (index a m) ∼ 0G
      cancel {m} a rewrite equalityCommutative (mapAndIndex a inverse m) = invLeft
      pr1 : (m : ℕ) → (N <N m) → (bound + index (apply _+_ (CauchyCompletion.elts a) (map inverse (constSequence (inverse x)))) m) < rationalNear
      pr1 m N<m with prBound m N<m
      ... | bl rewrite indexAndApply (CauchyCompletion.elts a) (map inverse (constSequence (inverse x))) _+_ {m} | equalityCommutative (mapAndIndex (constSequence (inverse x)) inverse m) | indexAndConst x m | indexAndApply (constSequence x) (map inverse (map inverse (CauchyCompletion.elts a))) _+_ {m} | indexAndConst x m | equalityCommutative (mapAndIndex (map inverse (CauchyCompletion.elts a)) inverse m) | equalityCommutative (mapAndIndex (CauchyCompletion.elts a) inverse m) | indexAndConst (inverse x) m = <WellDefined (+WellDefined (Equivalence.reflexive eq) (Equivalence.transitive eq groupIsAbelian (+WellDefined (invTwice additiveGroup _) (Equivalence.symmetric eq (invTwice additiveGroup _))))) (Equivalence.reflexive eq) bl

  boundModulus : (a : CauchyCompletion) → Sg A (λ b → Sg ℕ (λ N → (m : ℕ) → (N <N m) → (abs (index (CauchyCompletion.elts a) m)) < b))
  boundModulus a with approximateBelow a 1R (0<1 (charNot2ImpliesNontrivial R charNot2))
  ... | below , (below<a ,, a-below<e) with approximateAbove a 1R (0<1 (charNot2ImpliesNontrivial R charNot2))
  ... | above , (a<above ,, above-a<e) with totality 0R below
  boundModulus a | below , (below<a ,, a-below<e) | above , (a<above ,, above-a<e) | inl (inl 0<below) with totality 0R above
  boundModulus a | below , (record { e = belowBound ; 0<e = 0<belowBound ; N = Nbelow ; pr = prBelow } ,, a-below<e) | above , (record { e = bound ; 0<e = 0<bound ; N = N ; property = ans } ,, above-a<e) | inl (inl 0<below) | inl (inl 0<above) = above , ((N +N Nbelow) , λ m N<m → SetoidPartialOrder.<Transitive pOrder (res m N<m) (ans m (inequalityShrinkLeft N<m)))
    where
      res : (m : ℕ) → ((N +N Nbelow) <N m) → (abs (index (CauchyCompletion.elts a) m)) < (bound + index (CauchyCompletion.elts a) m)
      res m N<m with totality 0R (index (CauchyCompletion.elts a) m)
      res m N<m | inl (inl _) = <WellDefined identLeft (Equivalence.reflexive eq) (orderRespectsAddition 0<bound (index (CauchyCompletion.elts a) m))
      res m N<m | inl (inr am<0) = exFalso (irreflexive (SetoidPartialOrder.<Transitive pOrder 0<below (SetoidPartialOrder.<Transitive pOrder (SetoidPartialOrder.<Transitive pOrder (<WellDefined identLeft groupIsAbelian (orderRespectsAddition 0<belowBound below)) (prBelow m (inequalityShrinkRight N<m))) am<0)))
      res m N<m | inr 0=am = <WellDefined 0=am (Equivalence.transitive eq (Equivalence.symmetric eq identRight) (+WellDefined (Equivalence.reflexive eq) 0=am)) 0<bound
  boundModulus a | below , (below<a ,, a-below<e) | above , (a<above ,, above-a<e) | inl (inl 0<below) | inl (inr above<0) = exFalso (irreflexive (SetoidPartialOrder.<Transitive pOrder 0<below (SetoidPartialOrder.<Transitive pOrder (chain a below<a a<above) above<0)))
  boundModulus a | below , (below<a ,, a-below<e) | above , (a<above ,, above-a<e) | inl (inl 0<below) | inr 0=above = exFalso (irreflexive (SetoidPartialOrder.<Transitive pOrder 0<below (<WellDefined (Equivalence.reflexive eq) (Equivalence.symmetric eq 0=above) (chain a below<a a<above))))
  boundModulus a | below , (below<a ,, a-below<e) | above , (a<above ,, above-a<e) | inl (inr below<0) with totality 0R above
  boundModulus a | below , (below<a ,, a-below<e) | above , (a<above ,, above-a<e) | inl (inr below<0) | inl (inl 0<above) with totality (inverse below) above
  boundModulus a | below , (record { e = boundBelow ; 0<e = 0<boundBelow ; N = N ; pr = prBoundBelow } ,, a-below<e) | above , (record { e = boundAbove ; 0<e = 0<boundAbove ; N = Nabove ; property = prBoundAbove } ,, above-a<e) | inl (inr below<0) | inl (inl 0<above) | inl (inl -bel<ab) = above , ((N +N Nabove) , ans)
    where
      ans : (m : ℕ) → (N +N Nabove <N m) → abs (index (CauchyCompletion.elts a) m) < above
      ans m N<m with totality 0G (index (CauchyCompletion.elts a) m)
      ans m N<m | inl (inl 0<am) = SetoidPartialOrder.<Transitive pOrder (<WellDefined identLeft (Equivalence.reflexive eq) (orderRespectsAddition 0<boundAbove (index (CauchyCompletion.elts a) m))) (prBoundAbove m (inequalityShrinkRight N<m))
      ans m N<m | inl (inr am<0) = SetoidPartialOrder.<Transitive pOrder (ringSwapNegatives' (prBoundBelow m (inequalityShrinkLeft N<m))) (SetoidPartialOrder.<Transitive pOrder (ringSwapNegatives' (<WellDefined identLeft groupIsAbelian (orderRespectsAddition 0<boundBelow below))) -bel<ab)
      ans m N<m | inr 0=am = <WellDefined 0=am (Equivalence.reflexive eq) 0<above
  boundModulus a | below , (record { e = boundBelow ; 0<e = 0<boundBelow ; N = N ; pr = prBoundBelow } ,, a-below<e) | above , (record { e = boundAbove ; 0<e = 0<boundAbove ; N = Nabove ; property = prBoundAbove } ,, above-a<e) | inl (inr below<0) | inl (inl 0<above) | inl (inr ab<-bel) = inverse below , ((N +N Nabove) , ans)
    where
      ans : (m : ℕ) → (N +N Nabove <N m) → abs (index (CauchyCompletion.elts a) m) < (inverse below)
      ans m N<m with totality 0G (index (CauchyCompletion.elts a) m)
      ans m N<m | inl (inl 0<am) = SetoidPartialOrder.<Transitive pOrder (SetoidPartialOrder.<Transitive pOrder (<WellDefined identLeft (Equivalence.reflexive eq) (orderRespectsAddition 0<boundAbove (index (CauchyCompletion.elts a) m))) (prBoundAbove m (inequalityShrinkRight N<m))) ab<-bel
      ans m N<m | inl (inr am<0) = ringSwapNegatives' (SetoidPartialOrder.<Transitive pOrder (<WellDefined identLeft groupIsAbelian (orderRespectsAddition 0<boundBelow below)) (prBoundBelow m (inequalityShrinkLeft N<m)))
      ans m N<m | inr 0=am = <WellDefined 0=am (Equivalence.reflexive eq) (lemm2 below below<0)
  boundModulus a | below , (record { e = boundBelow ; 0<e = 0<boundBelow ; N = N ; pr = prBoundBelow } ,, a-below<e) | above , (record { e = boundAbove ; 0<e = 0<boundAbove ; N = Nabove ; property = prBoundAbove } ,, above-a<e) | inl (inr below<0) | inl (inl 0<above) | inr -bel=ab = above , ((N +N Nabove) , ans)
    where
      ans : (m : ℕ) → (N +N Nabove <N m) → abs (index (CauchyCompletion.elts a) m) < above
      ans m N<m with totality 0G (index (CauchyCompletion.elts a) m)
      ans m N<m | inl (inl 0<am) = SetoidPartialOrder.<Transitive pOrder (<WellDefined identLeft (Equivalence.reflexive eq) (orderRespectsAddition 0<boundAbove (index (CauchyCompletion.elts a) m))) (prBoundAbove m (inequalityShrinkRight N<m))
      ans m N<m | inl (inr am<0) = <WellDefined (Equivalence.reflexive eq) (-bel=ab) (ringSwapNegatives' (SetoidPartialOrder.<Transitive pOrder (<WellDefined identLeft groupIsAbelian (orderRespectsAddition 0<boundBelow below)) (prBoundBelow m (inequalityShrinkLeft N<m))))
      ans m N<m | inr 0=am = <WellDefined 0=am (Equivalence.reflexive eq) 0<above
  boundModulus a | below , (record { e = boundBelow ; 0<e = 0<boundBelow ; N = N ; pr = prBoundBelow } ,, a-below<e) | above , (record { e = boundAbove ; 0<e = 0<boundAbove ; N = Nabove ; property = prBoundAbove } ,, above-a<e) | inl (inr below<0) | inl (inr above<0) = inverse below , ((N +N Nabove) , ans)
    where
      ans : (m : ℕ) → ((N +N Nabove) <N m) → abs (index (CauchyCompletion.elts a) m) < inverse below
      ans m N<m with totality 0R (index (CauchyCompletion.elts a) m)
      ans m N<m | inl (inl 0<am) = exFalso (irreflexive {0G} (SetoidPartialOrder.<Transitive pOrder 0<am (SetoidPartialOrder.<Transitive pOrder (SetoidPartialOrder.<Transitive pOrder (<WellDefined identLeft (Equivalence.reflexive eq) (orderRespectsAddition 0<boundAbove (index (CauchyCompletion.elts a) m))) (prBoundAbove m (inequalityShrinkRight N<m))) above<0)))
      ans m N<m | inl (inr am<0) = ringSwapNegatives' (SetoidPartialOrder.<Transitive pOrder (<WellDefined identLeft groupIsAbelian (orderRespectsAddition 0<boundBelow below)) (prBoundBelow m (inequalityShrinkLeft N<m)))
      ans m N<m | inr 0=am = exFalso (irreflexive {0G} (<WellDefined (Equivalence.symmetric eq 0=am) (Equivalence.reflexive eq) (SetoidPartialOrder.<Transitive pOrder (SetoidPartialOrder.<Transitive pOrder (<WellDefined identLeft (Equivalence.reflexive eq) (orderRespectsAddition 0<boundAbove (index (CauchyCompletion.elts a) m))) (prBoundAbove m (inequalityShrinkRight N<m))) above<0)))
  boundModulus a | below , (record { e = boundBelow ; 0<e = 0<boundBelow ; N = N ; pr = prBoundBelow } ,, a-below<e) | above , (record { e = boundAbove ; 0<e = 0<boundAbove ; N = Nabove ; property = prBoundAbove } ,, above-a<e) | inl (inr below<0) | inr 0=above = inverse below , ((N +N Nabove) , ans)
    where
      ans : (m : ℕ) → ((N +N Nabove) <N m) → abs (index (CauchyCompletion.elts a) m) < inverse below
      ans m N<m with totality 0R (index (CauchyCompletion.elts a) m)
      ans m N<m | inl (inl 0<am) = exFalso (irreflexive {0G} (<WellDefined (Equivalence.reflexive eq) (Equivalence.symmetric eq 0=above) (SetoidPartialOrder.<Transitive pOrder 0<am (SetoidPartialOrder.<Transitive pOrder (<WellDefined identLeft (Equivalence.reflexive eq) (orderRespectsAddition 0<boundAbove (index (CauchyCompletion.elts a) m))) (prBoundAbove m (inequalityShrinkRight N<m))))))
      ans m N<m | inl (inr am<0) = ringSwapNegatives' (SetoidPartialOrder.<Transitive pOrder (<WellDefined identLeft groupIsAbelian (orderRespectsAddition 0<boundBelow below)) (prBoundBelow m (inequalityShrinkLeft N<m)))
      ans m N<m | inr 0=am = <WellDefined 0=am (Equivalence.reflexive eq) (lemm2 _ below<0)
  boundModulus a | below , (record { e = boundBelow ; 0<e = boundBelowDiff ; N = Nb ; pr = ansBelow } ,, a-below<e) | above , (record { e = bound ; 0<e = 0<bound ; N = N ; property = ans } ,, above-a<e) | inr 0=below = above , ((N +N Nb) , λ m N<m → SetoidPartialOrder.<Transitive pOrder (res m N<m) (ans m (inequalityShrinkLeft N<m)))
    where
      res : (m : ℕ) → (N +N Nb) <N m → (abs (index (CauchyCompletion.elts a) m)) < (bound + index (CauchyCompletion.elts a) m)
      res m N<m with totality 0R (index (CauchyCompletion.elts a) m)
      res m N<m | inl (inl 0<am) = <WellDefined identLeft (Equivalence.reflexive eq) (orderRespectsAddition 0<bound (index (CauchyCompletion.elts a) m))
      res m N<m | inl (inr am<0) = exFalso (irreflexive (<WellDefined (Equivalence.symmetric eq 0=below) (Equivalence.reflexive eq) (SetoidPartialOrder.<Transitive pOrder (SetoidPartialOrder.<Transitive pOrder (<WellDefined identLeft groupIsAbelian (orderRespectsAddition boundBelowDiff below)) (ansBelow m (inequalityShrinkRight N<m))) am<0)))
      res m N<m | inr 0=am = <WellDefined 0=am (Equivalence.transitive eq (Equivalence.symmetric eq identRight) (+WellDefined (Equivalence.reflexive eq) 0=am)) 0<bound


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

open import HoTT
open import homotopy.JoinComm
open import homotopy.JoinAssocCubical

module homotopy.JoinSusp where

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

  private

      module Into = JoinRec {A = Bool} {B = A}
        {D = Suspension A}
        (if_then north else south)
        (λ _ → south)
        (λ {(true , a) → merid a;
            (false , a) → idp})

      into = Into.f

      module Out = SuspensionRec {C = Bool * A}
        (left true)
        (left false)
        (λ a → glue (true , a) ∙ ! (glue (false , a)))

      out = Out.f

      into-out : ∀ σ → into (out σ) == σ
      into-out = Suspension-elim
        idp
        idp
        (↓-∘=idf-from-square into out ∘ λ a → vert-degen-square $
           ap (ap into) (Out.merid-β a)
           ∙ ap-∙ into (glue (true , a)) (! (glue (false , a)))
           ∙ (Into.glue-β (true , a)
              ∙2 (ap-! into (glue (false , a))
                  ∙ ap ! (Into.glue-β (false , a))))
           ∙ ∙-unit-r _)

      out-into : ∀ j → out (into j) == j
      out-into = Join-elim
        (λ{true → idp ; false → idp})
        (λ a → glue (false , a))
        (↓-∘=idf-from-square out into ∘
          λ {(true , a) →
                (ap (ap out) (Into.glue-β (true , a)) ∙ Out.merid-β a)
                ∙v⊡ (vid-square {p = glue (true , a)}
                      ⊡h rt-square (glue (false , a)))
                ⊡v∙ ∙-unit-r _;
             (false , a) →
               ap (ap out) (Into.glue-β (false , a)) ∙v⊡ connection})

  *-Bool-equiv-Suspension : Bool * A ≃ Suspension A
  *-Bool-equiv-Suspension = equiv into out into-out out-into

  *-Lift-Bool-equiv-Suspension : Lift {j = i} Bool * A ≃ Suspension A
  *-Lift-Bool-equiv-Suspension = *-Bool-equiv-Suspension ∘e equiv-* lower-equiv (ide A)

  *-Bool = ua *-Bool-equiv-Suspension

module _ {i} (X : Ptd i) where

  ⊙*-⊙Bool : ⊙Bool ⊙* X == ⊙Susp X
  ⊙*-⊙Bool = ⊙ua (⊙≃-in *-Bool-equiv-Suspension idp)

  ⊙*-⊙Lift-⊙Bool : ⊙Lift {j = i} ⊙Bool ⊙* X == ⊙Susp X
  ⊙*-⊙Lift-⊙Bool = ⊙ua (⊙≃-in *-Lift-Bool-equiv-Suspension idp)

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

  *-Suspension : Suspension A * B == Suspension (A * B)
  *-Suspension =
    ap (_* B) (! *-Bool)
    ∙ join-rearrange-path
    ∙ ua swap-equiv
    ∙ *-Bool
    ∙ ap Suspension (ua swap-equiv)

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

  ⊙*-⊙Susp : ⊙Susp X ⊙* Y == ⊙Susp (X ⊙* Y)
  ⊙*-⊙Susp =
    ap (_⊙* Y) (! (⊙*-⊙Bool X))
    ∙ join-rearrange-⊙path (⊙Sphere 0) X Y
    ∙ ⊙ua (⊙≃-in swap-equiv (! (glue _)))
    ∙ ⊙*-⊙Bool (Y ⊙* X)
    ∙ ap (λ A → (Suspension A , north)) (ua swap-equiv)

module _ {i} where

  ⊙*-⊙Sphere : (m : ℕ) (X : Ptd i) → ⊙Sphere m ⊙* X == ⊙Susp^ (S m) X
  ⊙*-⊙Sphere O X = ⊙*-⊙Bool X
  ⊙*-⊙Sphere (S m) X = ⊙*-⊙Susp (⊙Sphere m) X
                     ∙ ap ⊙Susp (⊙*-⊙Sphere m X)

  ⊙*-⊙Lift-⊙Sphere : (m : ℕ) (X : Ptd i) → ⊙Lift {j = i} (⊙Sphere m) ⊙* X == ⊙Susp^ (S m) X
  ⊙*-⊙Lift-⊙Sphere O X = ⊙*-⊙Lift-⊙Bool X
  ⊙*-⊙Lift-⊙Sphere (S m) X = ap (_⊙* X) (! $ ⊙Susp-⊙Lift (⊙Sphere m))
                           ∙ ⊙*-⊙Susp (⊙Lift (⊙Sphere m)) X
                           ∙ ap ⊙Susp (⊙*-⊙Lift-⊙Sphere m X)


module AllStdLib where

-- Ensure that the entire standard library is compiled.
import README

open import Data.Unit.Polymorphic using (⊤)
open import Data.String
open import IO hiding (_>>_)
import IO.Primitive as Prim

import DivMod
import HelloWorld
import HelloWorldPrim
import ShowNat
import TrustMe
import Vec
import dimensions

infixr 1 _>>_
_>>_ : ∀ {A B : Set} → Prim.IO A → Prim.IO B → Prim.IO B
m >> m₁ = m Prim.>>= λ _ → m₁

main : Prim.IO ⊤
main = run (putStrLn "Hello World!") >>
       DivMod.main >>
       HelloWorld.main >>
       HelloWorldPrim.main >>
       ShowNat.main >>
       TrustMe.main >>
       Vec.main >>
       dimensions.main


open import Common.Reflection
open import Common.Prelude
open import Common.Equality
open import Agda.Builtin.Sigma

pattern `Nat = def (quote Nat) []
pattern _`→_ a b = pi (vArg a) (abs "_" b)
pattern `Set     = sort (lit 0)
pattern `⊥       = def (quote ⊥) []

pattern `zero  = con (quote zero) []
pattern `suc n = con (quote suc) (vArg n ∷ [])

prDef : FunDef
prDef =
  funDef (`Nat `→ `Nat)
       ( clause [] [] (extLam ( clause [] (vArg `zero ∷ []) `zero
                              ∷ clause (("x" , vArg `Nat) ∷ []) (vArg (`suc (var 0)) ∷ []) (var 0 [])
                              ∷ []) [])
       ∷ [] )

magicDef : FunDef
magicDef =
  funDef (pi (hArg `Set) (abs "A" (`⊥ `→ var 1 [])))
       ( clause [] [] (extLam ( absurdClause (("()" , vArg `⊥) ∷ []) (vArg absurd ∷ [])
                              ∷ []) [])
       ∷ [] )

unquoteDecl magic = define (vArg magic) magicDef

checkMagic : {A : Set} → ⊥ → A
checkMagic = magic

unquoteDecl pr = define (vArg pr) prDef

magic′ : {A : Set} → ⊥ → A
magic′ = unquote (give (extLam (absurdClause (("()" , vArg `⊥) ∷ []) (vArg absurd ∷ []) ∷ []) []))

module Pred (A : Set) where
  unquoteDecl pr′ = define (vArg pr′) prDef

check : pr 10 ≡ 9
check = refl

check′ : Pred.pr′ ⊥ 10 ≡ 9
check′ = refl