------------------------------------------------------------------------
-- Kuratowski finite subsets
------------------------------------------------------------------------

-- Based on Frumin, Geuvers, Gondelman and van der Weide's "Finite
-- Sets in Homotopy Type Theory".

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

import Equality.Path as P

module Finite-subset.Kuratowski
  {e⁺} (eq : ∀ {a p} → P.Equality-with-paths a p e⁺) where

open P.Derived-definitions-and-properties eq hiding (elim)

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

open import Bijection equality-with-J using (_↔_)
open import Equality.Path.Isomorphisms eq
open import Equivalence equality-with-J as Eq using (_≃_)
import Finite-subset.Listed eq as L
open import Function-universe equality-with-J hiding (id; _∘_)
open import H-level equality-with-J
open import H-level.Truncation.Propositional eq as Trunc
  using (∥_∥; _∥⊎∥_)
open import Monad equality-with-J as M using (Raw-monad; Monad)

private
  variable
    a b p   : Level
    A B     : Type a
    P       : A → Type p
    f g     : (x : A) → P x
    l x y z : A
    m n     : ℕ

------------------------------------------------------------------------
-- Kuratowski finite subsets

-- Kuratowski finite subsets of a given type.

infixr 5 _∪_

data Finite-subset-of (A : Type a) : Type a where
  ∅         : Finite-subset-of A
  singleton : A → Finite-subset-of A
  _∪_       : Finite-subset-of A → Finite-subset-of A →
              Finite-subset-of A
  ∅∪ᴾ       : ∅ ∪ x P.≡ x
  idem-sᴾ   : singleton x ∪ singleton x P.≡ singleton x
  assocᴾ    : x ∪ (y ∪ z) P.≡ (x ∪ y) ∪ z
  commᴾ     : x ∪ y P.≡ y ∪ x
  is-setᴾ   : P.Is-set (Finite-subset-of A)

-- Variants of some of the constructors.

∅∪ : ∅ ∪ x ≡ x
∅∪ = _↔_.from ≡↔≡ ∅∪ᴾ

idem-s : singleton x ∪ singleton x ≡ singleton x
idem-s = _↔_.from ≡↔≡ idem-sᴾ

assoc : x ∪ (y ∪ z) ≡ (x ∪ y) ∪ z
assoc = _↔_.from ≡↔≡ assocᴾ

comm : x ∪ y ≡ y ∪ x
comm = _↔_.from ≡↔≡ commᴾ

is-set : Is-set (Finite-subset-of A)
is-set = _↔_.from (H-level↔H-level 2) is-setᴾ

-- ∅ is a right identity for _∪_.

∪∅ : x ∪ ∅ ≡ x
∪∅ {x = x} =
  x ∪ ∅  ≡⟨ comm ⟩
  ∅ ∪ x  ≡⟨ ∅∪ ⟩∎
  x      ∎

------------------------------------------------------------------------
-- Eliminators

-- A dependent eliminator, expressed using paths.

record Elimᴾ {A : Type a} (P : Finite-subset-of A → Type p) :
             Type (a ⊔ p) where
  field
    ∅ʳ         : P ∅
    singletonʳ : ∀ x → P (singleton x)
    ∪ʳ         : P x → P y → P (x ∪ y)
    ∅∪ʳ        : (p : P x) →
                 P.[ (λ i → P (∅∪ᴾ {x = x} i)) ] ∪ʳ ∅ʳ p ≡ p
    idem-sʳ    : ∀ x →
                 P.[ (λ i → P (idem-sᴾ {x = x} i)) ]
                   ∪ʳ (singletonʳ x) (singletonʳ x) ≡ singletonʳ x
    assocʳ     : (p : P x) (q : P y) (r : P z) →
                 P.[ (λ i → P (assocᴾ {x = x} {y = y} {z = z} i)) ]
                   ∪ʳ p (∪ʳ q r) ≡ ∪ʳ (∪ʳ p q) r
    commʳ      : (p : P x) (q : P y) →
                 P.[ (λ i → P (commᴾ {x = x} {y = y} i)) ]
                   ∪ʳ p q ≡ ∪ʳ q p
    is-setʳ    : ∀ x → P.Is-set (P x)

open Elimᴾ public

elimᴾ : Elimᴾ P → (x : Finite-subset-of A) → P x
elimᴾ {A = A} {P = P} e = helper
  where
  module E = Elimᴾ e

  helper : (x : Finite-subset-of A) → P x
  helper ∅                                  = E.∅ʳ
  helper (singleton x)                      = E.singletonʳ x
  helper (x ∪ y)                            = E.∪ʳ (helper x) (helper y)
  helper (∅∪ᴾ {x = x} i)                    = E.∅∪ʳ (helper x) i
  helper (idem-sᴾ i)                        = E.idem-sʳ _ i
  helper (assocᴾ {x = x} {y = y} {z = z} i) = E.assocʳ
                                                (helper x) (helper y)
                                                (helper z) i
  helper (commᴾ {x = x} {y = y} i)          = E.commʳ
                                                (helper x) (helper y) i
  helper (is-setᴾ x y i j)                  =
    P.heterogeneous-UIP E.is-setʳ (is-setᴾ x y)
      (λ i → helper (x i)) (λ i → helper (y i)) i j

-- A non-dependent eliminator, expressed using paths.

record Recᴾ (A : Type a) (B : Type b) : Type (a ⊔ b) where
  field
    ∅ʳ         : B
    singletonʳ : A → B
    ∪ʳ         : Finite-subset-of A → Finite-subset-of A → B → B → B
    ∅∪ʳ        : ∀ x p → ∪ʳ ∅ x ∅ʳ p P.≡ p
    idem-sʳ    : ∀ x →
                 ∪ʳ (singleton x) (singleton x)
                    (singletonʳ x) (singletonʳ x) P.≡
                 singletonʳ x
    assocʳ     : ∀ p q r →
                 ∪ʳ x (y ∪ z) p (∪ʳ y z q r) P.≡
                 ∪ʳ (x ∪ y) z (∪ʳ x y p q) r
    commʳ      : ∀ p q → ∪ʳ x y p q P.≡ ∪ʳ y x q p
    is-setʳ    : P.Is-set B

open Recᴾ public

recᴾ : Recᴾ A B → Finite-subset-of A → B
recᴾ r = elimᴾ e
  where
  module R = Recᴾ r

  e : Elimᴾ _
  e .∅ʳ                 = R.∅ʳ
  e .singletonʳ         = R.singletonʳ
  e .∪ʳ {x = x} {y = y} = R.∪ʳ x y
  e .∅∪ʳ {x = x}        = R.∅∪ʳ x
  e .idem-sʳ            = R.idem-sʳ
  e .assocʳ             = R.assocʳ
  e .commʳ              = R.commʳ
  e .is-setʳ _          = R.is-setʳ

-- A dependent eliminator, expressed using equality.

record Elim {A : Type a} (P : Finite-subset-of A → Type p) :
            Type (a ⊔ p) where
  field
    ∅ʳ         : P ∅
    singletonʳ : ∀ x → P (singleton x)
    ∪ʳ         : P x → P y → P (x ∪ y)
    ∅∪ʳ        : (p : P x) → subst P (∅∪ {x = x}) (∪ʳ ∅ʳ p) ≡ p
    idem-sʳ    : ∀ x →
                 subst P (idem-s {x = x})
                         (∪ʳ (singletonʳ x) (singletonʳ x)) ≡
                 singletonʳ x
    assocʳ     : (p : P x) (q : P y) (r : P z) →
                 subst P (assoc {x = x} {y = y} {z = z})
                         (∪ʳ p (∪ʳ q r)) ≡
                 ∪ʳ (∪ʳ p q) r
    commʳ      : (p : P x) (q : P y) →
                 subst P (comm {x = x} {y = y}) (∪ʳ p q) ≡ ∪ʳ q p
    is-setʳ    : ∀ x → Is-set (P x)

open Elim public

elim : Elim P → (x : Finite-subset-of A) → P x
elim e = elimᴾ e′
  where
  module E = Elim e

  e′ : Elimᴾ _
  e′ .∅ʳ           = E.∅ʳ
  e′ .singletonʳ   = E.singletonʳ
  e′ .∪ʳ           = E.∪ʳ
  e′ .∅∪ʳ p        = subst≡→[]≡ (E.∅∪ʳ p)
  e′ .idem-sʳ x    = subst≡→[]≡ (E.idem-sʳ x)
  e′ .assocʳ p q r = subst≡→[]≡ (E.assocʳ p q r)
  e′ .commʳ p q    = subst≡→[]≡ (E.commʳ p q)
  e′ .is-setʳ x    = _↔_.to (H-level↔H-level 2) (E.is-setʳ x)

-- A non-dependent eliminator, expressed using equality.

record Rec (A : Type a) (B : Type b) : Type (a ⊔ b) where
  field
    ∅ʳ         : B
    singletonʳ : A → B
    ∪ʳ         : Finite-subset-of A → Finite-subset-of A → B → B → B
    ∅∪ʳ        : ∀ x p → ∪ʳ ∅ x ∅ʳ p ≡ p
    idem-sʳ    : ∀ x →
                 ∪ʳ (singleton x) (singleton x)
                    (singletonʳ x) (singletonʳ x) ≡
                 singletonʳ x
    assocʳ     : ∀ p q r →
                 ∪ʳ x (y ∪ z) p (∪ʳ y z q r) ≡
                 ∪ʳ (x ∪ y) z (∪ʳ x y p q) r
    commʳ      : ∀ p q → ∪ʳ x y p q ≡ ∪ʳ y x q p
    is-setʳ    : Is-set B

open Rec public

rec : Rec A B → Finite-subset-of A → B
rec r = recᴾ r′
  where
  module R = Rec r

  r′ : Recᴾ _ _
  r′ .∅ʳ           = R.∅ʳ
  r′ .singletonʳ   = R.singletonʳ
  r′ .∪ʳ           = R.∪ʳ
  r′ .∅∪ʳ x p      = _↔_.to ≡↔≡ (R.∅∪ʳ x p)
  r′ .idem-sʳ x    = _↔_.to ≡↔≡ (R.idem-sʳ x)
  r′ .assocʳ p q r = _↔_.to ≡↔≡ (R.assocʳ p q r)
  r′ .commʳ p q    = _↔_.to ≡↔≡ (R.commʳ p q)
  r′ .is-setʳ      = _↔_.to (H-level↔H-level 2) R.is-setʳ

-- A dependent eliminator for propositions.

record Elim-prop {A : Type a} (P : Finite-subset-of A → Type p) :
                 Type (a ⊔ p) where
  field
    ∅ʳ              : P ∅
    singletonʳ      : ∀ x → P (singleton x)
    ∪ʳ              : P x → P y → P (x ∪ y)
    is-propositionʳ : ∀ x → Is-proposition (P x)

open Elim-prop public

elim-prop : Elim-prop P → (x : Finite-subset-of A) → P x
elim-prop e = elim e′
  where
  module E = Elim-prop e

  e′ : Elim _
  e′ .∅ʳ           = E.∅ʳ
  e′ .singletonʳ   = E.singletonʳ
  e′ .∪ʳ           = E.∪ʳ
  e′ .∅∪ʳ _        = E.is-propositionʳ _ _ _
  e′ .idem-sʳ _    = E.is-propositionʳ _ _ _
  e′ .assocʳ _ _ _ = E.is-propositionʳ _ _ _
  e′ .commʳ _ _    = E.is-propositionʳ _ _ _
  e′ .is-setʳ _    = mono₁ 1 (E.is-propositionʳ _)

-- A non-dependent eliminator for propositions.

record Rec-prop (A : Type a) (B : Type b) : Type (a ⊔ b) where
  field
    ∅ʳ              : B
    singletonʳ      : A → B
    ∪ʳ              : Finite-subset-of A → Finite-subset-of A →
                      B → B → B
    is-propositionʳ : Is-proposition B

open Rec-prop public

rec-prop : Rec-prop A B → Finite-subset-of A → B
rec-prop r = elim-prop e
  where
  module R = Rec-prop r

  e : Elim-prop _
  e .∅ʳ                 = R.∅ʳ
  e .singletonʳ         = R.singletonʳ
  e .∪ʳ {x = x} {y = y} = R.∪ʳ x y
  e .is-propositionʳ _  = R.is-propositionʳ

------------------------------------------------------------------------
-- Definitions related to listed finite subsets

private

  -- Some definitions used in the implementation of Listed≃Kuratowski
  -- below.

  to : L.Finite-subset-of A → Finite-subset-of A
  to L.[]      = ∅
  to (x L.∷ y) = singleton x ∪ to y

  to (L.dropᴾ {x = x} {y = y} i) =
    (singleton x ∪ (singleton x ∪ to y)  P.≡⟨ assocᴾ ⟩
     (singleton x ∪ singleton x) ∪ to y  P.≡⟨ P.cong (_∪ to y) idem-sᴾ ⟩∎
     singleton x ∪ to y                  ∎) i

  to (L.swapᴾ {x = x} {y = y} {z = z} i) =
    (singleton x ∪ (singleton y ∪ to z)  P.≡⟨ assocᴾ ⟩
     (singleton x ∪ singleton y) ∪ to z  P.≡⟨ P.cong (_∪ to z) commᴾ ⟩
     (singleton y ∪ singleton x) ∪ to z  P.≡⟨ P.sym assocᴾ ⟩∎
     singleton y ∪ (singleton x ∪ to z)  ∎) i

  to (L.is-setᴾ x y i j) =
    is-setᴾ (λ i → to (x i)) (λ i → to (y i)) i j

  to-∪ : (x : L.Finite-subset-of A) → to (x L.∪ y) ≡ to x ∪ to y
  to-∪ {y = y} = L.elim-prop e
    where
    e : L.Elim-prop _
    e .L.is-propositionʳ _ = is-set

    e .L.[]ʳ =
      to y      ≡⟨ sym ∅∪ ⟩∎
      ∅ ∪ to y  ∎

    e .L.∷ʳ {y = z} x hyp =
      singleton x ∪ to (z L.∪ y)   ≡⟨ cong (singleton x ∪_) hyp ⟩
      singleton x ∪ (to z ∪ to y)  ≡⟨ assoc ⟩∎
      (singleton x ∪ to z) ∪ to y  ∎

-- Listed finite subsets are equivalent to Kuratowski finite subsets.

Listed≃Kuratowski : L.Finite-subset-of A ≃ Finite-subset-of A
Listed≃Kuratowski {A = A} = from-bijection (record
  { surjection = record
    { logical-equivalence = record
      { to   = to
      ; from = from
      }
    ; right-inverse-of = to∘from
    }
  ; left-inverse-of = from∘to
  })
  where
  from : Finite-subset-of A → L.Finite-subset-of A
  from ∅             = L.[]
  from (singleton x) = x L.∷ L.[]
  from (x ∪ y)       = from x L.∪ from y

  from (∅∪ᴾ {x = x} _) = from x

  from (idem-sᴾ {x = x} i) = L.dropᴾ {x = x} {y = L.[]} i

  from (assocᴾ {x = x} {y = y} {z = z} i) =
    _↔_.to ≡↔≡ (L.assoc {y = from y} {z = from z} (from x)) i

  from (commᴾ {x = x} {y = y} i) =
    _↔_.to ≡↔≡ (L.comm {y = from y} (from x)) i

  from (is-setᴾ x y i j) =
    L.is-setᴾ (λ i → from (x i)) (λ i → from (y i)) i j

  to∘from : ∀ x → to (from x) ≡ x
  to∘from = elim-prop e
    where
    e : Elim-prop _
    e .is-propositionʳ _            = is-set
    e .∅ʳ                           = refl _
    e .singletonʳ _                 = ∪∅
    e .∪ʳ {x = x} {y = y} hyp₁ hyp₂ =
      to (from x L.∪ from y)     ≡⟨ to-∪ (from x) ⟩
      to (from x) ∪ to (from y)  ≡⟨ cong₂ _∪_ hyp₁ hyp₂ ⟩∎
      x ∪ y                      ∎

  from∘to : ∀ x → from (to x) ≡ x
  from∘to = L.elim-prop e
    where
    e : L.Elim-prop _
    e .L.is-propositionʳ _ = L.is-set
    e .L.[]ʳ               = refl _
    e .L.∷ʳ {y = y} x hyp  =
      x L.∷ from (to y)  ≡⟨ cong (x L.∷_) hyp ⟩∎
      x L.∷ y            ∎

-- The forward direction of Listed≃Kuratowski is homomorphic with
-- respect to L._∪_/_∪_.

to-Listed≃Kuratowski-∪ :
  (x : L.Finite-subset-of A) →
  _≃_.to Listed≃Kuratowski (x L.∪ y) ≡
  _≃_.to Listed≃Kuratowski x ∪ _≃_.to Listed≃Kuratowski y
to-Listed≃Kuratowski-∪ = to-∪

-- The other direction of Listed≃Kuratowski is definitionally
-- homomorphic with respect to _∪_/L._∪_.

_ :
  _≃_.from Listed≃Kuratowski (x ∪ y) ≡
  _≃_.from Listed≃Kuratowski x L.∪ _≃_.from Listed≃Kuratowski y
_ = refl _

-- A list-like dependent eliminator for Finite-subset-of, for
-- propositions.

record List-elim-prop
         {A : Type a} (P : Finite-subset-of A → Type p) :
         Type (a ⊔ p) where
  field
    []ʳ             : P ∅
    ∷ʳ              : ∀ x → P y → P (singleton x ∪ y)
    is-propositionʳ : ∀ x → Is-proposition (P x)

open List-elim-prop public

list-elim-prop : List-elim-prop P → (x : Finite-subset-of A) → P x
list-elim-prop {P = P} l x =
  subst P (_≃_.right-inverse-of Listed≃Kuratowski x)
    (L.elim-prop e (_≃_.from Listed≃Kuratowski x))
  where
  module E = List-elim-prop l

  e : L.Elim-prop (P ∘ _≃_.to Listed≃Kuratowski)
  e .L.[]ʳ               = E.[]ʳ
  e .L.∷ʳ x              = E.∷ʳ x
  e .L.is-propositionʳ _ = E.is-propositionʳ _

-- A list-like non-dependent eliminator for Finite-subset-of,
-- expressed using paths.

record List-recᴾ (A : Type a) (B : Type b) : Type (a ⊔ b) where
  field
    []ʳ     : B
    ∷ʳ      : A → Finite-subset-of A → B → B
    dropʳ   : ∀ x y p →
              ∷ʳ x (singleton x ∪ y) (∷ʳ x y p) P.≡ ∷ʳ x y p
    swapʳ   : ∀ x y z p →
              ∷ʳ x (singleton y ∪ z) (∷ʳ y z p) P.≡
              ∷ʳ y (singleton x ∪ z) (∷ʳ x z p)
    is-setʳ : P.Is-set B

open List-recᴾ public

list-recᴾ : List-recᴾ A B → Finite-subset-of A → B
list-recᴾ l = L.recᴾ r ∘ _≃_.from Listed≃Kuratowski
  where
  module E = List-recᴾ l

  r : L.Recᴾ _ _
  r .L.[]ʳ         = E.[]ʳ
  r .L.∷ʳ x y      = E.∷ʳ x (_≃_.to Listed≃Kuratowski y)
  r .L.dropʳ x y   = E.dropʳ x (_≃_.to Listed≃Kuratowski y)
  r .L.swapʳ x y z = E.swapʳ x y (_≃_.to Listed≃Kuratowski z)
  r .L.is-setʳ     = E.is-setʳ

-- Unit tests documenting some of the computational behaviour of
-- list-recᴾ.

_ : list-recᴾ l ∅ ≡ l .[]ʳ
_ = refl _

_ : list-recᴾ l (singleton x) ≡ l .∷ʳ x ∅ (l .[]ʳ)
_ = refl _

_ : let y′ = _≃_.to Listed≃Kuratowski (_≃_.from Listed≃Kuratowski y) in

    list-recᴾ l (singleton x ∪ y) ≡ l .∷ʳ x y′ (list-recᴾ l y)
_ = refl _

-- A list-like non-dependent eliminator for Finite-subset-of,
-- expressed using equality.

record List-rec (A : Type a) (B : Type b) : Type (a ⊔ b) where
  field
    []ʳ     : B
    ∷ʳ      : A → Finite-subset-of A → B → B
    dropʳ   : ∀ x y p →
              ∷ʳ x (singleton x ∪ y) (∷ʳ x y p) ≡ ∷ʳ x y p
    swapʳ   : ∀ x y z p →
              ∷ʳ x (singleton y ∪ z) (∷ʳ y z p) ≡
              ∷ʳ y (singleton x ∪ z) (∷ʳ x z p)
    is-setʳ : Is-set B

open List-rec public

list-rec : List-rec A B → Finite-subset-of A → B
list-rec l = list-recᴾ l′
  where
  module R = List-rec l

  l′ : List-recᴾ _ _
  l′ .[]ʳ           = R.[]ʳ
  l′ .∷ʳ            = R.∷ʳ
  l′ .dropʳ x y p   = _↔_.to ≡↔≡ (R.dropʳ x y p)
  l′ .swapʳ x y z p = _↔_.to ≡↔≡ (R.swapʳ x y z p)
  l′ .is-setʳ       = _↔_.to (H-level↔H-level 2) R.is-setʳ

-- Unit tests documenting some of the computational behaviour of
-- list-rec.

_ : list-rec l ∅ ≡ l .[]ʳ
_ = refl _

_ : list-rec l (singleton x) ≡ l .∷ʳ x ∅ (l .[]ʳ)
_ = refl _

_ : let y′ = _≃_.to Listed≃Kuratowski (_≃_.from Listed≃Kuratowski y) in

    list-rec l (singleton x ∪ y) ≡ l .∷ʳ x y′ (list-rec l y)
_ = refl _

------------------------------------------------------------------------
-- Membership

-- Membership.

infix 4 _∈_

_∈_ : {A : Type a} → A → Finite-subset-of A → Type a
x ∈ y = x L.∈ _≃_.from Listed≃Kuratowski y

-- Membership is propositional.

∈-propositional : ∀ y → Is-proposition (x ∈ y)
∈-propositional _ = L.∈-propositional

-- A lemma characterising ∅.

∈∅≃ : (x ∈ ∅) ≃ ⊥₀
∈∅≃ = L.∈[]≃

-- A lemma characterising singleton.

∈singleton≃ : (x ∈ singleton y) ≃ ∥ x ≡ y ∥
∈singleton≃ = L.∈singleton≃

-- If x is a member of y, then x is a member of y ∪ z.

∈→∈∪ˡ : ∀ y z → x ∈ y → x ∈ y ∪ z
∈→∈∪ˡ {x = x} y z =
  x ∈ y                                                                ↔⟨⟩
  x L.∈ _≃_.from Listed≃Kuratowski y                                   ↝⟨ L.∈→∈∪ˡ ⟩
  x L.∈ _≃_.from Listed≃Kuratowski y L.∪ _≃_.from Listed≃Kuratowski z  ↔⟨⟩
  x L.∈ _≃_.from Listed≃Kuratowski (y ∪ z)                             ↔⟨⟩
  x ∈ y ∪ z                                                            □

-- If x is a member of z, then x is a member of y ∪ z.

∈→∈∪ʳ : ∀ y z → x ∈ z → x ∈ y ∪ z
∈→∈∪ʳ {x = x} y z =
  x ∈ z                                                                ↔⟨⟩
  x L.∈ _≃_.from Listed≃Kuratowski z                                   ↝⟨ L.∈→∈∪ʳ (_≃_.from Listed≃Kuratowski y) ⟩
  x L.∈ _≃_.from Listed≃Kuratowski y L.∪ _≃_.from Listed≃Kuratowski z  ↔⟨⟩
  x ∈ y ∪ z                                                            □

-- Membership of a union of two subsets can be expressed in terms of
-- membership of the subsets.

∈∪≃ : ∀ y z → (x ∈ y ∪ z) ≃ (x ∈ y ∥⊎∥ x ∈ z)
∈∪≃ {x = x} y z =
  x ∈ y ∪ z                                                            ↔⟨⟩

  x L.∈ _≃_.from Listed≃Kuratowski y L.∪ _≃_.from Listed≃Kuratowski z  ↝⟨ L.∈∪≃ ⟩

  x L.∈ _≃_.from Listed≃Kuratowski y ∥⊎∥
  x L.∈ _≃_.from Listed≃Kuratowski z                                   ↔⟨⟩

  x ∈ y ∥⊎∥ x ∈ z                                                      □

-- If truncated equality is decidable, then membership is also
-- decidable.

member? :
  ((x y : A) → Dec ∥ x ≡ y ∥) →
  (x : A) (y : Finite-subset-of A) → Dec (x ∈ y)
member? equal? x = L.member? equal? x ∘ _≃_.from Listed≃Kuratowski

-- Subsets.

_⊆_ : {A : Type a} → Finite-subset-of A → Finite-subset-of A → Type a
x ⊆ y = ∀ z → z ∈ x → z ∈ y

-- The subset property can be expressed using _∪_ and _≡_.

⊆≃∪≡ : (x ⊆ y) ≃ (x ∪ y ≡ y)
⊆≃∪≡ {x = x} {y = y} =
  x ⊆ y                                                              ↝⟨ L.⊆≃∪≡ (_≃_.from Listed≃Kuratowski x) ⟩

  _≃_.from Listed≃Kuratowski x L.∪ _≃_.from Listed≃Kuratowski y ≡
  _≃_.from Listed≃Kuratowski y                                       ↔⟨⟩

  _≃_.from Listed≃Kuratowski (x ∪ y) ≡ _≃_.from Listed≃Kuratowski y  ↝⟨ Eq.≃-≡ (inverse Listed≃Kuratowski) ⟩□

  x ∪ y ≡ y                                                          □

-- Extensionality.

extensionality :
  (x ≡ y) ≃ (∀ z → z ∈ x ⇔ z ∈ y)
extensionality {x = x} {y = y} =
  x ≡ y                                                        ↝⟨ inverse $ Eq.≃-≡ (inverse Listed≃Kuratowski) ⟩
  _≃_.from Listed≃Kuratowski x ≡ _≃_.from Listed≃Kuratowski y  ↝⟨ L.extensionality ⟩□
  (∀ z → z ∈ x ⇔ z ∈ y)                                        □

------------------------------------------------------------------------
-- A law

-- Union is idempotent.

idem : x ∪ x ≡ x
idem {x = x} = _≃_.from extensionality λ y →
  y ∈ x ∪ x        ↔⟨ ∈∪≃ x x ⟩
  y ∈ x ∥⊎∥ y ∈ x  ↔⟨ Trunc.idempotent ⟩
  ∥ y ∈ x ∥        ↔⟨ Trunc.∥∥↔ (∈-propositional x) ⟩□
  y ∈ x            □

------------------------------------------------------------------------
-- Some operations

-- A map function.

map : (A → B) → Finite-subset-of A → Finite-subset-of B
map f = recᴾ r
  where
  r : Recᴾ _ _
  r .∅ʳ           = ∅
  r .singletonʳ x = singleton (f x)
  r .∪ʳ _ _       = _∪_
  r .∅∪ʳ _ _      = ∅∪ᴾ
  r .idem-sʳ _    = idem-sᴾ
  r .assocʳ _ _ _ = assocᴾ
  r .commʳ _ _    = commᴾ
  r .is-setʳ      = is-setᴾ

-- A filter function.

filter : (A → Bool) → Finite-subset-of A → Finite-subset-of A
filter p = rec r
  where
  r : Rec _ _
  r .∅ʳ           = ∅
  r .singletonʳ x = if p x then singleton x else ∅
  r .∪ʳ _ _       = _∪_
  r .∅∪ʳ _ _      = ∅∪
  r .idem-sʳ _    = idem
  r .assocʳ _ _ _ = assoc
  r .commʳ _ _    = comm
  r .is-setʳ      = is-set

-- Join.

join : Finite-subset-of (Finite-subset-of A) → Finite-subset-of A
join = rec r
  where
  r : Rec _ _
  r .∅ʳ           = ∅
  r .singletonʳ   = id
  r .∪ʳ _ _       = _∪_
  r .∅∪ʳ _ _      = ∅∪
  r .idem-sʳ _    = idem
  r .assocʳ _ _ _ = assoc
  r .commʳ _ _    = comm
  r .is-setʳ      = is-set

-- A universe-polymorphic variant of bind.

infixl 5 _>>=′_

_>>=′_ :
  Finite-subset-of A → (A → Finite-subset-of B) → Finite-subset-of B
x >>=′ f = join (map f x)

-- Bind distributes from the right over union.

_ : (x ∪ y) >>=′ f ≡ (x >>=′ f) ∪ (y >>=′ f)
_ = refl _

-- Bind distributes from the left over union.

>>=-left-distributive :
  ∀ x → (x >>=′ λ x → f x ∪ g x) ≡ (x >>=′ f) ∪ (x >>=′ g)
>>=-left-distributive {f = f} {g = g} = elim-prop e
  where
  e : Elim-prop _
  e .∅ʳ                           = ∅      ≡⟨ sym idem ⟩∎
                                    ∅ ∪ ∅  ∎
  e .singletonʳ _                 = refl _
  e .is-propositionʳ _            = is-set
  e .∪ʳ {x = x} {y = y} hyp₁ hyp₂ =
    (x ∪ y) >>=′ (λ x → f x ∪ g x)                         ≡⟨⟩
    (x >>=′ λ x → f x ∪ g x) ∪ (y >>=′ λ x → f x ∪ g x)    ≡⟨ cong₂ _∪_ hyp₁ hyp₂ ⟩
    ((x >>=′ f) ∪ (x >>=′ g)) ∪ ((y >>=′ f) ∪ (y >>=′ g))  ≡⟨ sym assoc ⟩
    (x >>=′ f) ∪ ((x >>=′ g) ∪ ((y >>=′ f) ∪ (y >>=′ g)))  ≡⟨ cong ((x >>=′ f) ∪_) assoc ⟩
    (x >>=′ f) ∪ (((x >>=′ g) ∪ (y >>=′ f)) ∪ (y >>=′ g))  ≡⟨ cong (((x >>=′ f) ∪_) ∘ (_∪ (y >>=′ g))) comm ⟩
    (x >>=′ f) ∪ (((y >>=′ f) ∪ (x >>=′ g)) ∪ (y >>=′ g))  ≡⟨ cong ((x >>=′ f) ∪_) (sym assoc) ⟩
    (x >>=′ f) ∪ ((y >>=′ f) ∪ ((x >>=′ g) ∪ (y >>=′ g)))  ≡⟨ assoc ⟩
    ((x >>=′ f) ∪ (y >>=′ f)) ∪ ((x >>=′ g) ∪ (y >>=′ g))  ≡⟨⟩
    ((x ∪ y) >>=′ f) ∪ ((x ∪ y) >>=′ g)                    ∎

-- Monad laws.

_ : singleton x >>=′ f ≡ f x
_ = refl _

>>=-singleton : x >>=′ singleton ≡ x
>>=-singleton = elim-prop e _
  where
  e : Elim-prop (λ x → x >>=′ singleton ≡ x)
  e .∅ʳ                           = refl _
  e .singletonʳ _                 = refl _
  e .is-propositionʳ _            = is-set
  e .∪ʳ {x = x} {y = y} hyp₁ hyp₂ =
    (x ∪ y) >>=′ singleton                   ≡⟨⟩
    (x >>=′ singleton) ∪ (y >>=′ singleton)  ≡⟨ cong₂ _∪_ hyp₁ hyp₂ ⟩∎
    x ∪ y                                    ∎

>>=-assoc : ∀ x → x >>=′ (λ x → f x >>=′ g) ≡ x >>=′ f >>=′ g
>>=-assoc {f = f} {g = g} = elim-prop e
  where
  e : Elim-prop _
  e .∅ʳ                           = refl _
  e .singletonʳ _                 = refl _
  e .is-propositionʳ _            = is-set
  e .∪ʳ {x = x} {y = y} hyp₁ hyp₂ =
    (x ∪ y) >>=′ (λ x → f x >>=′ g)                        ≡⟨⟩
    (x >>=′ λ x → f x >>=′ g) ∪ (y >>=′ λ x → f x >>=′ g)  ≡⟨ cong₂ _∪_ hyp₁ hyp₂ ⟩
    (x >>=′ f >>=′ g) ∪ (y >>=′ f >>=′ g)                  ≡⟨⟩
    (x ∪ y) >>=′ f >>=′ g                                  ∎

-- A monad instance.

instance

  raw-monad : Raw-monad {d = a} Finite-subset-of
  raw-monad .M.return = singleton
  raw-monad .M._>>=_  = _>>=′_

  monad : Monad {d = a} Finite-subset-of
  monad .M.Monad.raw-monad           = raw-monad
  monad .M.Monad.left-identity _ _   = refl _
  monad .M.Monad.right-identity _    = >>=-singleton
  monad .M.Monad.associativity x _ _ = >>=-assoc x

------------------------------------------------------------------------
-- Size

-- Size.

infix 4 ∣_∣≡_

∣_∣≡_ : {A : Type a} → Finite-subset-of A → ℕ → Type a
∣ x ∣≡ n = L.∣ _≃_.from Listed≃Kuratowski x ∣≡ n

-- The size predicate is propositional.

∣∣≡-propositional :
  (x : Finite-subset-of A) → Is-proposition (∣ x ∣≡ n)
∣∣≡-propositional = L.∣∣≡-propositional ∘ _≃_.from Listed≃Kuratowski

-- Unit tests documenting some of the computational behaviour of
-- ∣_∣≡_.

_ : (∣ ∅ {A = A} ∣≡ n) ≡ ↑ _ (n ≡ 0)
_ = refl _

_ : ∀ {A : Type a} {x : A} {y} →
    (∣ singleton x ∪ y ∣≡ zero) ≡ (x ∈ y × ∣ y ∣≡ zero ⊎ ⊥)
_ = refl _

_ : (∣ singleton x ∪ y ∣≡ suc n) ≡
    (x ∈ y × ∣ y ∣≡ suc n ⊎ ¬ x ∈ y × ∣ y ∣≡ n)
_ = refl _

-- The size predicate is functional.

∣∣≡-functional :
  (x : Finite-subset-of A) → ∣ x ∣≡ m → ∣ x ∣≡ n → m ≡ n
∣∣≡-functional = L.∣∣≡-functional ∘ _≃_.from Listed≃Kuratowski

-- If truncated equality is decidable, then one can compute the size
-- of a finite subset.

size :
  ((x y : A) → Dec ∥ x ≡ y ∥) →
  (x : Finite-subset-of A) → ∃ λ n → ∣ x ∣≡ n
size equal? = L.size equal? ∘ _≃_.from Listed≃Kuratowski


------------------------------------------------------------------------
-- A solution to a problem posed by Venanzio Capretta
------------------------------------------------------------------------

module VenanziosProblem where

open import Codata.Musical.Notation
open import Codata.Musical.Stream as Stream
  using (Stream; _⋎_; evens; odds; _≈_)
open Stream.Stream; open Stream._≈_
open import Data.Nat
open import Relation.Binary
import Relation.Binary.PropositionalEquality as P

private
  module S {A : Set} = Setoid (Stream.setoid A)

------------------------------------------------------------------------
-- Problem formulation

-- The problem concerns functions satisfying a certain equation:

rhs : {A : Set} → (Stream A → Stream A) → Stream A → Stream A
rhs φ s = s ⋎ φ (evens (φ s))

SatisfiesEquation : {A : Set} → (Stream A → Stream A) → Set
SatisfiesEquation φ = ∀ s → φ s ≈ rhs φ s

-- The statement of the problem:

Statement : Set₁
Statement = {A : Set} {φ₁ φ₂ : Stream A → Stream A} →
            SatisfiesEquation φ₁ → SatisfiesEquation φ₂ →
            ∀ s → φ₁ s ≈ φ₂ s

------------------------------------------------------------------------
-- Solution

module Solution {A : Set} where

  infixr 5 _∷_
  infix  4 _∣_∣_≈P_ _∣_∣_≈W_
  infix  3 _∎
  infixr 2 _≈⟨_⟩_

  -- Let us first define a small language of equality proofs.
  --
  -- m ∣ n ∣ xs ≈P ys means that xs and ys, which are streams
  -- generated in chunks of size 1 + m, where the outer chunk has size
  -- n, are equal.

  mutual

    -- Weak head normal forms of programs.

    data _∣_∣_≈W_ : ℕ → ℕ → Stream A → Stream A → Set where
      reset : ∀ {xs₁ xs₂ m} (xs₁≈xs₂ : ∞ (m ∣ suc m ∣ xs₁ ≈P xs₂)) →
              m ∣ 0 ∣ xs₁ ≈W xs₂
      _∷_   : ∀ x {xs₁ xs₂ m n} (xs₁≈xs₂ : m ∣ n ∣ ♭ xs₁ ≈W ♭ xs₂) →
              m ∣ suc n ∣ x ∷ xs₁ ≈W x ∷ xs₂

    -- Programs.

    data _∣_∣_≈P_ : ℕ → ℕ → Stream A → Stream A → Set where

      -- WHNFs are programs.
      ↑          : ∀ {m n xs₁ xs₂} (xs₁≈xs₂ : m ∣ n ∣ xs₁ ≈W xs₂) →
                   m ∣ n ∣ xs₁ ≈P xs₂

      -- Various congruences.
      _∷_        : ∀ x {xs₁ xs₂ m n} (xs₁≈xs₂ : m ∣ n ∣ ♭ xs₁ ≈P ♭ xs₂) →
                   m ∣ suc n ∣ x ∷ xs₁ ≈P x ∷ xs₂
      _⋎-cong_   : ∀ {xs₁ xs₂ ys₁ ys₂}
                   (xs₁≈xs₂ : 1 ∣ 1 ∣ xs₁ ≈P xs₂)
                   (ys₁≈ys₂ : 0 ∣ 1 ∣ ys₁ ≈P ys₂) →
                   1 ∣ 2 ∣ xs₁ ⋎ ys₁ ≈P xs₂ ⋎ ys₂
      evens-cong : ∀ {xs₁ xs₂}
                   (xs₁≈xs₂ : 1 ∣ 1 ∣ xs₁ ≈P xs₂) →
                   0 ∣ 1 ∣ evens xs₁ ≈P evens xs₂
      odds-cong  : ∀ {xs₁ xs₂}
                   (xs₁≈xs₂ : 1 ∣ 2 ∣ xs₁ ≈P xs₂) →
                   0 ∣ 1 ∣ odds xs₁ ≈P odds xs₂

      -- Equational reasoning.
      _≈⟨_⟩_     : ∀ xs₁ {xs₂ xs₃ m n}
                   (xs₁≈xs₂ : m ∣ n ∣ xs₁ ≈P xs₂)
                   (xs₂≈xs₃ : m ∣ n ∣ xs₂ ≈P xs₃) →
                   m ∣ n ∣ xs₁ ≈P xs₃
      _∎         : ∀ {n m} xs → m ∣ n ∣ xs ≈P xs

      -- If we have already produced 1 + n elements of the last chunk,
      -- then it is safe to pretend that we have only produced n
      -- elements.
      shift      : ∀ {n m xs₁ xs₂} (xs₁≈xs₂ : m ∣ suc n ∣ xs₁ ≈P xs₂) →
                   m ∣ n ∣ xs₁ ≈P xs₂

      -- A variation of the statement we want to prove.
      goal′      : ∀ {φ₁ φ₂ xs₁ xs₂}
                   (s₁ : SatisfiesEquation φ₁)
                   (s₂ : SatisfiesEquation φ₂)
                   (xs₁≈xs₂ : 0 ∣ 1 ∣ xs₁ ≈P xs₂) →
                   1 ∣ 1 ∣ rhs φ₁ xs₁ ≈P rhs φ₂ xs₂

  -- The equality language is complete.

  completeW : ∀ {n m xs ys} → xs ≈ ys → m ∣ n ∣ xs ≈W ys
  completeW {zero}  xs≈ys            = reset (♯ ↑ (completeW xs≈ys))
  completeW {suc n} (P.refl ∷ xs≈ys) = _ ∷ completeW (♭ xs≈ys)

  -- If we can prove that the equality language is sound, then the
  -- following lemma implies the intended result.

  goal : ∀ {φ₁ φ₂ xs₁ xs₂}
         (s₁ : SatisfiesEquation φ₁) (s₂ : SatisfiesEquation φ₂) →
         0 ∣ 1 ∣ xs₁ ≈P xs₂ → 1 ∣ 1 ∣ φ₁ xs₁ ≈P φ₂ xs₂
  goal {φ₁} {φ₂} {xs₁} {xs₂} s₁ s₂ xs₁≈xs₂ =
    φ₁ xs₁      ≈⟨ ↑ (completeW (s₁ xs₁)) ⟩
    rhs φ₁ xs₁  ≈⟨ goal′ s₁ s₂ xs₁≈xs₂ ⟩
    rhs φ₂ xs₂  ≈⟨ ↑ (completeW (S.sym (s₂ xs₂))) ⟩
    φ₂ xs₂      ∎

  -- Some lemmas about weak head normal forms.

  evens-congW : {xs₁ xs₂ : Stream A} →
                1 ∣ 1 ∣ xs₁ ≈W xs₂ → 0 ∣ 1 ∣ evens xs₁ ≈W evens xs₂
  evens-congW (x ∷ reset xs₁≈xs₂) =
    x ∷ reset (♯ odds-cong (♭ xs₁≈xs₂))

  reflW : ∀ xs {m} n → m ∣ n ∣ xs ≈W xs
  reflW xs       zero    = reset (♯ (xs ∎))
  reflW (x ∷ xs) (suc n) = x ∷ reflW (♭ xs) n

  transW : ∀ {xs ys zs m n} →
           m ∣ n ∣ xs ≈W ys → m ∣ n ∣ ys ≈W zs → m ∣ n ∣ xs ≈W zs
  transW (x ∷ xs≈ys)   (.x ∷ ys≈zs)  = x ∷ transW xs≈ys ys≈zs
  transW (reset xs≈ys) (reset ys≈zs) =
    reset (♯ (_ ≈⟨ ♭ xs≈ys ⟩ ♭ ys≈zs))

  shiftW : ∀ n {m xs₁ xs₂} →
           m ∣ suc n ∣ xs₁ ≈W xs₂ → m ∣ n ∣ xs₁ ≈W xs₂
  shiftW zero    (x ∷ reset xs₁≈xs₂) = reset (♯ (x ∷ shift (♭ xs₁≈xs₂)))
  shiftW (suc n) (x ∷       xs₁≈xs₂) = x ∷ shiftW n xs₁≈xs₂

  -- Every program can be transformed into WHNF.

  whnf : ∀ {xs ys m n} → m ∣ n ∣ xs ≈P ys → m ∣ n ∣ xs ≈W ys
  whnf (↑ xs≈ys) = xs≈ys

  whnf (x ∷ xs₁≈xs₂) = x ∷ whnf xs₁≈xs₂

  whnf (xs₁≈xs₂ ⋎-cong ys₁≈ys₂) with whnf xs₁≈xs₂ | whnf ys₁≈ys₂
  ... | x ∷ reset xs₁≈xs₂′ | y ∷ reset ys₁≈ys₂′ =
    x ∷ y ∷ reset (♯ (shift (♭ xs₁≈xs₂′) ⋎-cong ♭ ys₁≈ys₂′))

  whnf (evens-cong xs₁≈xs₂) = evens-congW (whnf xs₁≈xs₂)

  whnf (odds-cong xs₁≈xs₂) with whnf xs₁≈xs₂
  ... | x ∷ xs₁≈xs₂′ = evens-congW xs₁≈xs₂′

  whnf (xs₁ ≈⟨ xs₁≈xs₂ ⟩ xs₂≈xs₃) = transW (whnf xs₁≈xs₂) (whnf xs₂≈xs₃)
  whnf (xs ∎)                     = reflW xs _

  whnf (shift xs₁≈xs₂) = shiftW _ (whnf xs₁≈xs₂)

  whnf (goal′ s₁ s₂ xs₁≈xs₂) with whnf xs₁≈xs₂
  ... | (x ∷ reset xs₁≈xs₂′) =
    x ∷ reset (♯ (goal s₁ s₂ (evens-cong (goal s₁ s₂ xs₁≈xs₂))
                    ⋎-cong
                  ♭ xs₁≈xs₂′))

  -- Soundness follows by a corecursive repetition of the whnf
  -- procedure.

  ⟦_⟧W : ∀ {xs ys m n} → m ∣ n ∣ xs ≈W ys → xs ≈ ys
  ⟦ reset ys≈zs ⟧W with whnf (♭ ys≈zs)
  ... | x ∷ ys≈zs′ = P.refl ∷ ♯ ⟦ ys≈zs′ ⟧W
  ⟦ x ∷ ys≈zs   ⟧W = P.refl ∷ ♯ ⟦ ys≈zs ⟧W

  ⟦_⟧P : ∀ {xs ys m n} → m ∣ n ∣ xs ≈P ys → xs ≈ ys
  ⟦ xs≈ys ⟧P = ⟦ whnf xs≈ys ⟧W

-- Wrapping up.

solution : Statement
solution s₁ s₂ s = ⟦ goal s₁ s₂ (s ∎) ⟧P
  where open Solution


------------------------------------------------------------------------
-- The Agda standard library
--
-- Examples of pretty printing of rose trees
------------------------------------------------------------------------

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

module README.Text.Tree where

open import Data.List.Base
open import Data.String.Base
open import Data.Tree.Rose
open import Function.Base
open import Agda.Builtin.Equality

------------------------------------------------------------------------
-- We import the module defining the pretty printer for rose trees

open import Text.Tree.Linear

------------------------------------------------------------------------
-- Example

_ : unlines (display
  $ node [ "one" ]
      (node [ "two" ] []
     ∷ node ("three" ∷ "and" ∷ "four" ∷ [])
         (node [ "five" ] []
        ∷ node [ "six" ] (node [ "seven" ] [] ∷ [])
        ∷ node [ "eight" ] []
        ∷ [])
     ∷ node [ "nine" ]
         (node [ "ten" ] []
        ∷ node [ "eleven" ] [] ∷ [])
        ∷ []))
  ≡ "one
\   \ ├ two
\   \ ├ three
\   \ │ and
\   \ │ four
\   \ │  ├ five
\   \ │  ├ six
\   \ │  │  └ seven
\   \ │  └ eight
\   \ └ nine
\   \    ├ ten
\   \    └ eleven"
_ = refl


------------------------------------------------------------------------
-- Characters
------------------------------------------------------------------------

module Data.Char where

open import Data.Nat  using (ℕ)
open import Data.Bool using (Bool; true; false)
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as PropEq using (_≡_)

------------------------------------------------------------------------
-- The type

postulate
  Char : Set

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

------------------------------------------------------------------------
-- Operations

private
 primitive
  primCharToNat    : Char → ℕ
  primCharEquality : Char → Char → Bool

toNat : Char → ℕ
toNat = primCharToNat

infix 4 _==_

_==_ : Char → Char → Bool
_==_ = primCharEquality

_≟_ : Decidable {Char} _≡_
s₁ ≟ s₂ with s₁ == s₂
... | true  = yes trustMe
  where postulate trustMe : _
... | false = no trustMe
  where postulate trustMe : _

setoid : Setoid
setoid = PropEq.setoid Char

decSetoid : DecSetoid
decSetoid = PropEq.decSetoid _≟_


------------------------------------------------------------------------
-- The univalence axiom
------------------------------------------------------------------------

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

-- Partly based on Voevodsky's work on so-called univalent
-- foundations.

open import Equality

module Univalence-axiom
  {reflexive} (eq : ∀ {a p} → Equality-with-J a p reflexive) where

open import Bijection eq as Bijection using (_↔_)
open import Bool eq
open Derived-definitions-and-properties eq
open import Equality.Decision-procedures eq
open import Equivalence eq as Eq
  using (_≃_; ⟨_,_⟩; Is-equivalence) renaming (_∘_ to _⊚_)
import Equivalence.Contractible-preimages eq as CP
import Equivalence.Half-adjoint eq as HA
open import Function-universe eq as F hiding (id; _∘_)
open import Groupoid eq
open import H-level eq as H-level
open import H-level.Closure eq
open import Injection eq using (Injective)
open import Logical-equivalence using (_⇔_)
import Nat eq as Nat
open import Prelude hiding (swap)
open import Surjection eq using (_↠_)

------------------------------------------------------------------------
-- The univalence axiom

-- If two sets are equal, then they are equivalent.

≡⇒≃ : ∀ {ℓ} {A B : Type ℓ} → A ≡ B → A ≃ B
≡⇒≃ = ≡⇒↝ equivalence

-- The univalence axiom states that ≡⇒≃ is an equivalence.

record Univalence′ {ℓ} (A B : Type ℓ) : Type (lsuc ℓ) where
  no-eta-equality
  pattern
  field
    univalence : Is-equivalence (≡⇒≃ {A = A} {B = B})

Univalence : ∀ ℓ → Type (lsuc ℓ)
Univalence ℓ = {A B : Type ℓ} → Univalence′ A B

-- An immediate consequence is that equalities are equivalent to
-- equivalences.

≡≃≃ : ∀ {ℓ} {A B : Type ℓ} → Univalence′ A B → (A ≡ B) ≃ (A ≃ B)
≡≃≃ univ = ⟨ ≡⇒≃ , Univalence′.univalence univ ⟩

-- In the case of sets equalities are equivalent to bijections (if we
-- add the assumption of extensionality).

≡≃↔ : ∀ {ℓ} {A B : Type ℓ} →
      Univalence′ A B →
      Extensionality ℓ ℓ →
      Is-set A →
      (A ≡ B) ≃ (A ↔ B)
≡≃↔ {A = A} {B} univ ext A-set =
  (A ≡ B)  ↝⟨ ≡≃≃ univ ⟩
  (A ≃ B)  ↔⟨ inverse $ Eq.↔↔≃ ext A-set ⟩□
  (A ↔ B)  □

-- Some abbreviations.

≡⇒→ : ∀ {ℓ} {A B : Type ℓ} → A ≡ B → A → B
≡⇒→ = _≃_.to ∘ ≡⇒≃

≡⇒← : ∀ {ℓ} {A B : Type ℓ} → A ≡ B → B → A
≡⇒← = _≃_.from ∘ ≡⇒≃

≃⇒≡ : ∀ {ℓ} {A B : Type ℓ} → Univalence′ A B → A ≃ B → A ≡ B
≃⇒≡ univ = _≃_.from (≡≃≃ univ)

-- Univalence′ can be expressed without the record type.

Univalence′≃Is-equivalence-≡⇒≃ :
  ∀ {ℓ} {A B : Type ℓ} →
  Univalence′ A B ≃ Is-equivalence (≡⇒≃ {A = A} {B = B})
Univalence′≃Is-equivalence-≡⇒≃ =
  Eq.↔→≃
    Univalence′.univalence
    (λ eq → record { univalence = eq })
    refl
    (λ { (record { univalence = _ }) → refl _ })

------------------------------------------------------------------------
-- Propositional extensionality

-- Propositional extensionality.
--
-- Basically as defined by Chapman, Uustalu and Veltri in "Quotienting
-- the Delay Monad by Weak Bisimilarity".

Propositional-extensionality : (ℓ : Level) → Type (lsuc ℓ)
Propositional-extensionality ℓ =
  {A B : Type ℓ} → Is-proposition A → Is-proposition B → A ⇔ B → A ≡ B

-- Propositional extensionality is equivalent to univalence restricted
-- to propositions (assuming extensionality).
--
-- I took the statement of this result from Chapman, Uustalu and
-- Veltri's "Quotienting the Delay Monad by Weak Bisimilarity", and
-- Nicolai Kraus helped me with the proof.

Propositional-extensionality-is-univalence-for-propositions :
  ∀ {ℓ} →
  Extensionality (lsuc ℓ) (lsuc ℓ) →

  Propositional-extensionality ℓ
    ≃
  ({A B : Type ℓ} →
   Is-proposition A → Is-proposition B → Univalence′ A B)

Propositional-extensionality-is-univalence-for-propositions {ℓ} ext =
  Propositional-extensionality ℓ                          ↝⟨ lemma ⟩

  ({A B : Type ℓ} →
   Is-proposition A → Is-proposition B →
   Is-equivalence (≡⇒≃ {A = A} {B = B}))                  ↝⟨ (implicit-∀-cong ext $
                                                              implicit-∀-cong ext $
                                                              ∀-cong ext′ λ _ →
                                                              ∀-cong ext′ λ _ →
                                                              inverse Univalence′≃Is-equivalence-≡⇒≃) ⟩□
  ({A B : Type ℓ} →
   Is-proposition A → Is-proposition B → Univalence′ A B) □
  where
  ext′ : Extensionality ℓ (lsuc ℓ)
  ext′ = lower-extensionality _ lzero ext

  ext″ : Extensionality ℓ ℓ
  ext″ = lower-extensionality _ _ ext

  ⇔≃≡ :
    Propositional-extensionality ℓ →
    {A B : Type ℓ} →
    Is-proposition A → Is-proposition B →
    (A ⇔ B) ≃ (A ≡ B)
  ⇔≃≡ prop-ext {A} {B} A-prop B-prop =
    A ⇔ B                        ↝⟨ proj₂ (Eq.propositional-identity≃≡
                                             (λ (A B : Proposition ℓ) → proj₁ A ⇔ proj₁ B)
                                             (λ { (A , A-prop) (B , B-prop) →
                                                  ⇔-closure ext″ 1 A-prop B-prop })
                                             (λ _ → F.id)
                                             (λ { (A , A-prop) (B , B-prop) A⇔B →
                                                  Σ-≡,≡→≡ (prop-ext A-prop B-prop A⇔B)
                                                          (H-level-propositional ext″ 1 _ _) }))
                                          ext ⟩
    (A , A-prop) ≡ (B , B-prop)  ↔⟨ inverse $ ignore-propositional-component
                                                (H-level-propositional ext″ 1) ⟩□
    A ≡ B                        □

  ≡-closure :
    Propositional-extensionality ℓ →
    {A B : Type ℓ} →
    Is-proposition A → Is-proposition B → Is-proposition (A ≡ B)
  ≡-closure prop-ext A-prop B-prop =
    H-level.respects-surjection
      (_≃_.surjection (⇔≃≡ prop-ext A-prop B-prop))
      1
      (⇔-closure ext″ 1 A-prop B-prop)

  lemma =
    Eq.⇔→≃
      ([inhabited⇒+]⇒+ 0 λ prop-ext →
       implicit-Π-closure ext 1 λ _ →
       implicit-Π-closure ext 1 λ _ →
       Π-closure ext′ 1 λ A-prop →
       Π-closure ext′ 1 λ B-prop →
       Π-closure ext′ 1 λ _ →
       ≡-closure (prop-ext {_}) A-prop B-prop)
      (implicit-Π-closure ext 1 λ _ →
       implicit-Π-closure ext 1 λ _ →
       Π-closure ext′ 1 λ _ →
       Π-closure ext′ 1 λ _ →
       Eq.propositional ext _)
      (λ prop-ext A-prop B-prop →
         _⇔_.from HA.Is-equivalence⇔Is-equivalence-CP $ λ A≃B →
         ( prop-ext A-prop B-prop (_≃_.logical-equivalence A≃B)
         , Eq.left-closure ext″ 0 A-prop _ _
         ) , λ _ → Σ-≡,≡→≡
               (≡-closure prop-ext A-prop B-prop _ _)
               (mono₁ 1 (Eq.left-closure ext″ 0 A-prop) _ _))
      (λ univ {A B} A-prop B-prop →
         A ⇔ B  ↔⟨ Eq.⇔↔≃ ext″ A-prop B-prop ⟩
         A ≃ B  ↔⟨ inverse ⟨ _ , univ A-prop B-prop ⟩ ⟩□
         A ≡ B  □)

------------------------------------------------------------------------
-- An alternative formulation of univalence

-- First some supporting lemmas.

-- A variant of a part of Theorem 5.8.2 from the HoTT book.

flip-subst-is-equivalence↔∃-is-contractible :
  ∀ {a pℓ} {A : Type a} {P : A → Type pℓ} {x : A} {p : P x} →
  (∀ y → Is-equivalence (flip (subst {y = y} P) p))
    ↝[ a ⊔ pℓ ∣ a ⊔ pℓ ]
  Contractible (∃ P)
flip-subst-is-equivalence↔∃-is-contractible
  {pℓ = pℓ} {P = P} {x = x} {p = p} =
  generalise-ext?-prop
    lemma
    (λ ext → Π-closure (lower-extensionality pℓ lzero ext) 1 λ _ →
             Eq.propositional ext _)
    Contractible-propositional
  where
  lemma :
    (∀ y → Is-equivalence (flip (subst {y = y} P) p))
      ⇔
    Contractible (∃ P)
  lemma = record
    { to = λ eq →                         $⟨ other-singleton-contractible x ⟩
        Contractible (Other-singleton x)  ↝⟨ id ⟩
        Contractible (∃ (x ≡_))           ↝⟨ H-level.respects-surjection (∃-cong λ y → _≃_.surjection ⟨ _ , eq y ⟩) 0 ⟩□
        Contractible (∃ P)                □
    ; from = λ { ((y , q) , u) z →
        _≃_.is-equivalence (Eq.↔⇒≃ (record
          { surjection = record
            { logical-equivalence = record
              { from = λ r →
                  x  ≡⟨ cong proj₁ $ sym $ u (x , p) ⟩
                  y  ≡⟨ cong proj₁ $ u (z , r) ⟩∎
                  z  ∎
              }
            ; right-inverse-of = λ r →
                subst P (trans (cong proj₁ (sym (u (x , p))))
                               (cong proj₁ (u (z , r)))) p         ≡⟨ sym $ subst-subst _ _ _ _ ⟩

                subst P (cong proj₁ (u (z , r)))
                  (subst P (cong proj₁ (sym (u (x , p)))) p)       ≡⟨ cong (subst P _) $ cong (λ p → subst P p _) $ sym $ proj₁-Σ-≡,≡←≡ _ ⟩

                subst P (cong proj₁ (u (z , r)))
                  (subst P (proj₁ (Σ-≡,≡←≡ (sym (u (x , p))))) p)  ≡⟨ cong (subst P _) $ proj₂ $ Σ-≡,≡←≡ (sym (u (x , p))) ⟩

                subst P (cong proj₁ (u (z , r))) q                 ≡⟨ cong (λ p → subst P p _) $ sym $ proj₁-Σ-≡,≡←≡ _ ⟩

                subst P (proj₁ (Σ-≡,≡←≡ (u (z , r)))) q            ≡⟨ proj₂ $ Σ-≡,≡←≡ (u (z , r)) ⟩∎

                r                                                  ∎
            }
          ; left-inverse-of = elim¹
              (λ {z} x≡z → trans (cong proj₁ (sym (u (x , p))))
                                 (cong proj₁ (u (z , subst P x≡z p))) ≡
                           x≡z)
              (trans (cong proj₁ (sym (u (x , p))))
                     (cong proj₁ (u (x , subst P (refl x) p)))  ≡⟨ cong₂ trans (cong-sym _ _)
                                                                               (cong (λ p → cong proj₁ (u (x , p))) $ subst-refl _ _) ⟩
               trans (sym (cong proj₁ (u (x , p))))
                     (cong proj₁ (u (x , p)))                   ≡⟨ trans-symˡ _ ⟩∎

               refl x                                           ∎)
          })) }
    }

-- If f is an equivalence, then f ∘ sym is also an equivalence.

∘-sym-preserves-equivalences :
  ∀ {a b} {A : Type a} {B : Type b} {x y : A} {f : x ≡ y → B} →
  Is-equivalence f ↝[ a ⊔ b ∣ a ⊔ b ] Is-equivalence (f ∘ sym)
∘-sym-preserves-equivalences {A = A} {B} =
  Is-equivalence≃Is-equivalence-∘ʳ
    (_≃_.is-equivalence $ Eq.↔⇒≃ ≡-comm)

-- An alternative formulation of univalence, due to Martin Escardo
-- (see the following post to the Homotopy Type Theory group from
-- 2018-04-05:
-- https://groups.google.com/forum/#!msg/homotopytypetheory/HfCB_b-PNEU/Ibb48LvUMeUJ).

Other-univalence : ∀ ℓ → Type (lsuc ℓ)
Other-univalence ℓ =
  {B : Type ℓ} → Contractible (∃ λ (A : Type ℓ) → A ≃ B)

-- Univalence and Other-univalence are pointwise isomorphic (assuming
-- extensionality).

Univalence↔Other-univalence :
  ∀ {ℓ} →
  Univalence ℓ ↝[ lsuc ℓ ∣ lsuc ℓ ] Other-univalence ℓ
Univalence↔Other-univalence {ℓ = ℓ} ext =
  Univalence ℓ                                                          ↝⟨ implicit-∀-cong ext $ implicit-∀-cong ext $
                                                                           from-equivalence Univalence′≃Is-equivalence-≡⇒≃ ⟩
  ({A B : Type ℓ} → Is-equivalence (≡⇒≃ {A = A} {B = B}))               ↔⟨ Bijection.implicit-Π↔Π ⟩
  ((A {B} : Type ℓ) → Is-equivalence (≡⇒≃ {A = A} {B = B}))             ↝⟨ (∀-cong ext λ _ → from-bijection Bijection.implicit-Π↔Π) ⟩
  ((A B : Type ℓ) → Is-equivalence (≡⇒≃ {A = A} {B = B}))               ↝⟨ (∀-cong ext λ _ → ∀-cong ext λ _ → ∘-sym-preserves-equivalences ext) ⟩
  ((A B : Type ℓ) → Is-equivalence (≡⇒≃ {A = A} {B = B} ∘ sym))         ↝⟨ (∀-cong ext λ _ → ∀-cong ext λ B →
                                                                            Is-equivalence-cong ext (λ B≡A →
      ≡⇒≃ (sym B≡A)                                                           ≡⟨ ≡⇒↝-in-terms-of-subst-sym _ _ ⟩
      subst (_≃ B) (sym (sym B≡A)) Eq.id                                      ≡⟨ cong (flip (subst _) _) $ sym-sym _ ⟩∎
      subst (_≃ B) B≡A Eq.id                                                  ∎)) ⟩

  ((A B : Type ℓ) → Is-equivalence (flip (subst {y = A} (_≃ B)) F.id))  ↔⟨ Π-comm ⟩
  ((B A : Type ℓ) → Is-equivalence (flip (subst {y = A} (_≃ B)) F.id))  ↝⟨ (∀-cong ext λ _ → flip-subst-is-equivalence↔∃-is-contractible ext) ⟩
  ((B : Type ℓ) → Contractible (∃ λ (A : Type ℓ) → A ≃ B))              ↔⟨ inverse Bijection.implicit-Π↔Π ⟩□
  ({B : Type ℓ} → Contractible (∃ λ (A : Type ℓ) → A ≃ B))              □

------------------------------------------------------------------------
-- Some simple lemmas

abstract

  -- "Evaluation rule" for ≡⇒≃.

  ≡⇒≃-refl : ∀ {a} {A : Type a} →
             ≡⇒≃ (refl A) ≡ Eq.id
  ≡⇒≃-refl = ≡⇒↝-refl

  -- "Evaluation rule" for ≡⇒→.

  ≡⇒→-refl : ∀ {a} {A : Type a} →
             ≡⇒→ (refl A) ≡ id
  ≡⇒→-refl = cong _≃_.to ≡⇒≃-refl

  -- "Evaluation rule" for ≡⇒←.

  ≡⇒←-refl : ∀ {a} {A : Type a} →
             ≡⇒← (refl A) ≡ id
  ≡⇒←-refl = cong _≃_.from ≡⇒≃-refl

  -- "Evaluation rule" (?) for ≃⇒≡.

  ≃⇒≡-id : ∀ {a} {A : Type a}
           (univ : Univalence′ A A) →
           ≃⇒≡ univ Eq.id ≡ refl A
  ≃⇒≡-id univ =
    ≃⇒≡ univ Eq.id           ≡⟨ sym $ cong (≃⇒≡ univ) ≡⇒≃-refl ⟩
    ≃⇒≡ univ (≡⇒≃ (refl _))  ≡⟨ _≃_.left-inverse-of (≡≃≃ univ) _ ⟩∎
    refl _                   ∎

  -- A simplification lemma for ≃⇒≡.

  ≡⇒→-≃⇒≡ : ∀ k {ℓ} {A B : Type ℓ} {eq : A ≃ B}
            (univ : Univalence′ A B) →
            to-implication (≡⇒↝ k (≃⇒≡ univ eq)) ≡ _≃_.to eq
  ≡⇒→-≃⇒≡ k {eq = eq} univ =
    to-implication (≡⇒↝ k (≃⇒≡ univ eq))  ≡⟨ to-implication-≡⇒↝ k _ ⟩
    ≡⇒↝ implication (≃⇒≡ univ eq)         ≡⟨ sym $ to-implication-≡⇒↝ equivalence _ ⟩
    ≡⇒→ (≃⇒≡ univ eq)                     ≡⟨ cong _≃_.to (_≃_.right-inverse-of (≡≃≃ univ) _) ⟩∎
    _≃_.to eq                             ∎

------------------------------------------------------------------------
-- Another alternative formulation of univalence

-- Univalence′ A B is pointwise equivalent to CP.Univalence′ A B
-- (assuming extensionality).

Univalence′≃Univalence′-CP :
  ∀ {ℓ} {A B : Type ℓ} →
  Extensionality (lsuc ℓ) (lsuc ℓ) →
  Univalence′ A B ≃ CP.Univalence′ A B
Univalence′≃Univalence′-CP {ℓ = ℓ} {A = A} {B = B} ext =
  Univalence′ A B                         ↝⟨ Univalence′≃Is-equivalence-≡⇒≃ ⟩

  Is-equivalence ≡⇒≃                      ↝⟨ Is-equivalence-cong ext $
                                             elim
                                               (λ A≡B → ≡⇒≃ A≡B ≡ _≃_.from ≃≃≃ (CP.≡⇒≃ A≡B))
                                               (λ C →
      ≡⇒≃ (refl _)                                ≡⟨ ≡⇒≃-refl ⟩
      Eq.id                                       ≡⟨ Eq.lift-equality ext′ (refl _) ⟩
      _≃_.from ≃≃≃ CP.id                          ≡⟨ cong (_≃_.from ≃≃≃) $ sym CP.≡⇒≃-refl ⟩∎
      _≃_.from ≃≃≃ (CP.≡⇒≃ (refl _))              ∎) ⟩

  Is-equivalence (_≃_.from ≃≃≃ ∘ CP.≡⇒≃)  ↝⟨ Eq.⇔→≃
                                               (Eq.propositional ext _)
                                               (Eq.propositional ext _)
                                               (Eq.Two-out-of-three.g-g∘f (Eq.two-out-of-three _ _)
                                                  (_≃_.is-equivalence (inverse ≃≃≃)))
                                               (flip (Eq.Two-out-of-three.f-g (Eq.two-out-of-three _ _))
                                                  (_≃_.is-equivalence (inverse ≃≃≃))) ⟩

  Is-equivalence CP.≡⇒≃                   ↝⟨ Is-equivalence≃Is-equivalence-CP ext ⟩□

  CP.Is-equivalence CP.≡⇒≃                □
  where
  ext′ : Extensionality ℓ ℓ
  ext′ = lower-extensionality _ _ ext

  ≃≃≃ : {A B : Type ℓ} → (A ≃ B) ≃ (A CP.≃ B)
  ≃≃≃ = ≃≃≃-CP ext′

-- Univalence ℓ is pointwise equivalent to CP.Univalence ℓ (assuming
-- extensionality).

Univalence≃Univalence-CP :
  ∀ {ℓ} →
  Extensionality (lsuc ℓ) (lsuc ℓ) →
  Univalence ℓ ≃ CP.Univalence ℓ
Univalence≃Univalence-CP {ℓ = ℓ} ext =
  implicit-∀-cong ext $ implicit-∀-cong ext $
  Univalence′≃Univalence′-CP ext

------------------------------------------------------------------------
-- A consequence: Type is not a set

-- The univalence axiom implies that Type is not a set. (This was
-- pointed out to me by Thierry Coquand.)

module _ (univ : Univalence′ Bool Bool) where

  -- First note that the univalence axiom implies that there is an
  -- inhabitant of Bool ≡ Bool that is not equal to refl.

  swap-as-an-equality : Bool ≡ Bool
  swap-as-an-equality = ≃⇒≡ univ (Eq.↔⇒≃ swap)

  abstract

    swap≢refl : swap-as-an-equality ≢ refl Bool
    swap≢refl =
      swap-as-an-equality ≡ refl _            ↝⟨ cong ≡⇒→ ⟩
      ≡⇒→ swap-as-an-equality ≡ ≡⇒→ (refl _)  ↝⟨ subst (uncurry _≡_) (cong₂ _,_ (≡⇒→-≃⇒≡ equivalence univ) ≡⇒→-refl) ⟩
      not ≡ id                                ↝⟨ cong (_$ false) ⟩
      true ≡ false                            ↝⟨ Bool.true≢false ⟩□
      ⊥                                       □

    -- This implies that Type is not a set.

    ¬-Type-set : ¬ Is-set Type
    ¬-Type-set =
      Is-set Type                      ↝⟨ (λ h → h _ _) ⟩
      swap-as-an-equality ≡ refl Bool  ↝⟨ swap≢refl ⟩□
      ⊥                                □

abstract

  -- The result can be generalised to arbitrary universe levels.

  ¬-Type-set-↑ : ∀ {ℓ} →
                 Univalence′ (↑ ℓ Bool) (↑ ℓ Bool) →
                 ¬ Is-set (Type ℓ)
  ¬-Type-set-↑ {ℓ} univ =
    Is-set (Type ℓ)                          ↝⟨ (λ h → h _ _) ⟩
    swap-as-an-equality-↑ ≡ refl (↑ ℓ Bool)  ↝⟨ swap-↑≢refl ⟩□
    ⊥                                        □
    where
    swap-as-an-equality-↑ : ↑ ℓ Bool ≡ ↑ ℓ Bool
    swap-as-an-equality-↑ =
      ≃⇒≡ univ $
      Eq.↔⇒≃ $
      (Bijection.inverse Bijection.↑↔
         Bijection.∘
       swap
         Bijection.∘
       Bijection.↑↔)

    swap-↑≢refl : swap-as-an-equality-↑ ≢ refl (↑ ℓ Bool)
    swap-↑≢refl =
      swap-as-an-equality-↑ ≡ refl _            ↝⟨ cong ≡⇒→ ⟩
      ≡⇒→ swap-as-an-equality-↑ ≡ ≡⇒→ (refl _)  ↝⟨ subst (uncurry _≡_) (cong₂ _,_ (≡⇒→-≃⇒≡ equivalence univ) ≡⇒→-refl) ⟩
      lift ∘ not ∘ lower ≡ id                   ↝⟨ cong (lower ∘ (_$ lift false)) ⟩
      true ≡ false                              ↝⟨ Bool.true≢false ⟩□
      ⊥                                         □

------------------------------------------------------------------------
-- A consequence: some equality types have infinitely many inhabitants

abstract

  -- Some equality types have infinitely many inhabitants (assuming
  -- univalence).

  equality-can-have-infinitely-many-inhabitants :
    Univalence′ ℕ ℕ →
    ∃ λ (A : Type) → ∃ λ (B : Type) →
    ∃ λ (p : ℕ → A ≡ B) → Injective p
  equality-can-have-infinitely-many-inhabitants univ =
    (ℕ , ℕ , cast ∘ p , cast-preserves-injections p p-injective)
    where
    cast : ℕ ≃ ℕ → ℕ ≡ ℕ
    cast = ≃⇒≡ univ

    cast-preserves-injections :
      {A : Type} (f : A → ℕ ≃ ℕ) →
      Injective f → Injective (cast ∘ f)
    cast-preserves-injections f inj {x = x} {y = y} cast-f-x≡cast-f-y =
      inj (f x               ≡⟨ sym $ _≃_.right-inverse-of (≡≃≃ univ) (f x) ⟩
           ≡⇒≃ (cast (f x))  ≡⟨ cong ≡⇒≃ cast-f-x≡cast-f-y ⟩
           ≡⇒≃ (cast (f y))  ≡⟨ _≃_.right-inverse-of (≡≃≃ univ) (f y) ⟩∎
           f y               ∎)

    swap_and-0 : ℕ → ℕ → ℕ
    swap i and-0 zero    = i
    swap i and-0 (suc n) with i Nat.≟ suc n
    ... | yes i≡1+n = zero
    ... | no  i≢1+n = suc n

    swap∘swap : ∀ i n → swap i and-0 (swap i and-0 n) ≡ n
    swap∘swap zero    zero    = refl zero
    swap∘swap (suc i) zero    with i Nat.≟ i
    ... | yes _   = refl 0
    ... | no  i≢i = ⊥-elim $ i≢i (refl i)
    swap∘swap i       (suc n) with i Nat.≟ suc n
    ... | yes i≡1+n = i≡1+n
    ... | no  i≢1+n with i Nat.≟ suc n
    ...   | yes i≡1+n = ⊥-elim $ i≢1+n i≡1+n
    ...   | no  _     = refl (suc n)

    p : ℕ → ℕ ≃ ℕ
    p i = Eq.↔⇒≃ record
      { surjection = record
        { logical-equivalence = record { to   = swap i and-0
                                       ; from = swap i and-0
                                       }
        ; right-inverse-of    = swap∘swap i
        }
      ; left-inverse-of = swap∘swap i
      }

    p-injective : Injective p
    p-injective {x = i₁} {y = i₂} p-i₁≡p-i₂ =
      i₁               ≡⟨ refl i₁ ⟩
      swap i₁ and-0 0  ≡⟨ cong (λ f → f 0) swap-i₁≡swap-i₂ ⟩
      swap i₂ and-0 0  ≡⟨ refl i₂ ⟩∎
      i₂               ∎
      where
      swap-i₁≡swap-i₂ : swap i₁ and-0 ≡ swap i₂ and-0
      swap-i₁≡swap-i₂ = cong _≃_.to p-i₁≡p-i₂

------------------------------------------------------------------------
-- A consequence: extensionality for functions

-- The transport theorem.

transport-theorem :
  ∀ {p₁ p₂} (P : Type p₁ → Type p₂) →
  (resp : ∀ {A B} → A ≃ B → P A → P B) →
  (∀ {A} (p : P A) → resp Eq.id p ≡ p) →
  ∀ {A B} (univ : Univalence′ A B) →
  (A≃B : A ≃ B) (p : P A) →
  resp A≃B p ≡ subst P (≃⇒≡ univ A≃B) p
transport-theorem P resp resp-id univ A≃B p =
  resp A≃B p              ≡⟨ sym $ cong (λ q → resp q p) (right-inverse-of A≃B) ⟩
  resp (to (from A≃B)) p  ≡⟨ elim (λ {A B} A≡B → ∀ p →
                                     resp (≡⇒≃ A≡B) p ≡ subst P A≡B p)
                                  (λ A p →
                                     resp (≡⇒≃ (refl A)) p  ≡⟨ trans (cong (λ q → resp q p) ≡⇒↝-refl) (resp-id p) ⟩
                                     p                      ≡⟨ sym $ subst-refl P p ⟩∎
                                     subst P (refl A) p     ∎) _ _ ⟩∎
  subst P (from A≃B) p    ∎
  where open _≃_ (≡≃≃ univ)

abstract

  -- If the univalence axiom holds, then any "resp" function that
  -- preserves identity is an equivalence family.

  resp-is-equivalence :
    ∀ {p₁ p₂} (P : Type p₁ → Type p₂) →
    (resp : ∀ {A B} → A ≃ B → P A → P B) →
    (∀ {A} (p : P A) → resp Eq.id p ≡ p) →
    ∀ {A B} (univ : Univalence′ A B) →
    (A≃B : A ≃ B) → Is-equivalence (resp A≃B)
  resp-is-equivalence P resp resp-id univ A≃B =
    Eq.respects-extensional-equality
      (λ p → sym $ transport-theorem P resp resp-id univ A≃B p)
      (Eq.subst-is-equivalence P (≃⇒≡ univ A≃B))

  -- If f is an equivalence, then (non-dependent) precomposition with
  -- f is also an equivalence (assuming univalence).

  precomposition-is-equivalence :
    ∀ {ℓ c} {A B : Type ℓ} {C : Type c} →
    Univalence′ B A → (A≃B : A ≃ B) →
    Is-equivalence (λ (g : B → C) → g ∘ _≃_.to A≃B)
  precomposition-is-equivalence {ℓ} {c} {C = C} univ A≃B =
    resp-is-equivalence P resp refl univ (Eq.inverse A≃B)
    where
    P : Type ℓ → Type (ℓ ⊔ c)
    P X = X → C

    resp : ∀ {A B} → A ≃ B → P A → P B
    resp A≃B p = p ∘ _≃_.from A≃B

-- If h is an equivalence, then one can cancel (non-dependent)
-- precompositions with h (assuming univalence).

precompositions-cancel :
  ∀ {ℓ c} {A B : Type ℓ} {C : Type c} →
  Univalence′ B A → (A≃B : A ≃ B) {f g : B → C} →
  let open _≃_ A≃B in
  f ∘ to ≡ g ∘ to → f ≡ g
precompositions-cancel univ A≃B {f} {g} f∘to≡g∘to =
  f            ≡⟨ sym $ left-inverse-of f ⟩
  from (to f)  ≡⟨ cong from f∘to≡g∘to ⟩
  from (to g)  ≡⟨ left-inverse-of g ⟩∎
  g            ∎
  where open _≃_ (⟨ _ , precomposition-is-equivalence univ A≃B ⟩)

-- Pairs of equal elements.

_²/≡ : ∀ {ℓ} → Type ℓ → Type ℓ
A ²/≡ = ∃ λ (x : A) → ∃ λ (y : A) → x ≡ y

-- The set of such pairs is isomorphic to the underlying type.

-²/≡↔- : ∀ {a} {A : Type a} → (A ²/≡) ↔ A
-²/≡↔- {A = A} =
  (∃ λ (x : A) → ∃ λ (y : A) → x ≡ y)  ↝⟨ ∃-cong (λ _ → _⇔_.to contractible⇔↔⊤ (other-singleton-contractible _)) ⟩
  A × ⊤                                ↝⟨ ×-right-identity ⟩□
  A                                    □

abstract

  -- The univalence axiom implies non-dependent functional
  -- extensionality.

  extensionality :
    ∀ {a b} {A : Type a} {B : Type b} →
    Univalence′ (B ²/≡) B →
    {f g : A → B} → (∀ x → f x ≡ g x) → f ≡ g
  extensionality {A = A} {B} univ {f} {g} f≡g =
    f          ≡⟨ refl f ⟩
    f′ ∘ pair  ≡⟨ cong (λ (h : B ²/≡ → B) → h ∘ pair) f′≡g′ ⟩
    g′ ∘ pair  ≡⟨ refl g ⟩∎
    g          ∎
    where
    f′ : B ²/≡ → B
    f′ = proj₁

    g′ : B ²/≡ → B
    g′ = proj₁ ∘ proj₂

    f′≡g′ : f′ ≡ g′
    f′≡g′ = precompositions-cancel
              univ
              (Eq.↔⇒≃ $ Bijection.inverse -²/≡↔-)
              (refl id)

    pair : A → B ²/≡
    pair x = (f x , g x , f≡g x)

  -- The univalence axiom implies that contractibility is closed under
  -- Π A.

  Π-closure-contractible :
    ∀ {b} → Univalence′ (Type b ²/≡) (Type b) →
    ∀ {a} {A : Type a} {B : A → Type b} →
    (∀ x → Univalence′ (↑ b ⊤) (B x)) →
    (∀ x → Contractible (B x)) → Contractible ((x : A) → B x)
  Π-closure-contractible {b} univ₁ {A = A} {B} univ₂ contr =
    subst Contractible A→⊤≡[x:A]→Bx →⊤-contractible
    where
    const-⊤≡B : const (↑ b ⊤) ≡ B
    const-⊤≡B = extensionality univ₁ λ x →
      _≃_.from (≡≃≃ (univ₂ x)) $ Eq.↔⇒≃ $
        Bijection.contractible-isomorphic
          (↑-closure 0 ⊤-contractible) (contr x)

    A→⊤≡[x:A]→Bx : (A → ↑ b ⊤) ≡ ((x : A) → B x)
    A→⊤≡[x:A]→Bx = cong (λ X → (x : A) → X x) const-⊤≡B

    →⊤-contractible : Contractible (A → ↑ b ⊤)
    →⊤-contractible = (_ , λ _ → refl _)

  -- Thus we also get extensionality for dependent functions.

  dependent-extensionality′ :
    ∀ {b} → Univalence′ (Type b ²/≡) (Type b) →
    ∀ {a} {A : Type a} →
    (∀ {B : A → Type b} x → Univalence′ (↑ b ⊤) (B x)) →
    {B : A → Type b} → Extensionality′ A B
  dependent-extensionality′ univ₁ univ₂ =
    _⇔_.to Π-closure-contractible⇔extensionality
      (Π-closure-contractible univ₁ univ₂)

  dependent-extensionality :
    ∀ {b} →
    Univalence (lsuc b) →
    Univalence b →
    ∀ {a} → Extensionality a b
  apply-ext (dependent-extensionality univ₁ univ₂) =
    dependent-extensionality′ univ₁ (λ _ → univ₂)

------------------------------------------------------------------------
-- Pow and Fam

-- Slightly different variants of Pow and Fam are described in
-- "Specifying interactions with dependent types" by Peter Hancock and
-- Anton Setzer (in APPSEM Workshop on Subtyping & Dependent Types in
-- Programming, DTP'00). The fact that Pow and Fam are logically
-- equivalent is proved in "Programming Interfaces and Basic Topology"
-- by Peter Hancock and Pierre Hyvernat (Annals of Pure and Applied
-- Logic, 2006). The results may be older than this.

-- Pow.

Pow : ∀ ℓ {a} → Type a → Type (lsuc (a ⊔ ℓ))
Pow ℓ {a} A = A → Type (a ⊔ ℓ)

-- Fam.

Fam : ∀ ℓ {a} → Type a → Type (lsuc (a ⊔ ℓ))
Fam ℓ {a} A = ∃ λ (I : Type (a ⊔ ℓ)) → I → A

-- Pow and Fam are pointwise logically equivalent.

Pow⇔Fam : ∀ ℓ {a} {A : Type a} →
          Pow ℓ A ⇔ Fam ℓ A
Pow⇔Fam _ = record
  { to   = λ P → ∃ P , proj₁
  ; from = λ { (I , f) a → ∃ λ i → f i ≡ a }
  }

-- Pow and Fam are pointwise isomorphic (assuming extensionality and
-- univalence).

Pow↔Fam : ∀ ℓ {a} {A : Type a} →
          Extensionality a (lsuc (a ⊔ ℓ)) →
          Univalence (a ⊔ ℓ) →
          Pow ℓ A ↔ Fam ℓ A
Pow↔Fam ℓ {A = A} ext univ = record
  { surjection = record
    { logical-equivalence = Pow⇔Fam ℓ
    ; right-inverse-of    = λ { (I , f) →
        let lemma₁ =
              (∃ λ a → ∃ λ i → f i ≡ a)  ↔⟨ ∃-comm ⟩
              (∃ λ i → ∃ λ a → f i ≡ a)  ↔⟨ ∃-cong (λ _ → _⇔_.to contractible⇔↔⊤ (other-singleton-contractible _)) ⟩
              I × ⊤                      ↔⟨ ×-right-identity ⟩□
              I                          □

            lemma₂ =
              subst (λ I → I → A) (≃⇒≡ univ lemma₁) proj₁  ≡⟨ sym $ transport-theorem (λ I → I → A) (λ eq → _∘ _≃_.from eq) refl univ _ _ ⟩
              proj₁ ∘ _≃_.from lemma₁                      ≡⟨ refl _ ⟩∎
              f                                            ∎
        in
        (∃ λ a → ∃ λ i → f i ≡ a) , proj₁  ≡⟨ Σ-≡,≡→≡ (≃⇒≡ univ lemma₁) lemma₂ ⟩∎
        I                         , f      ∎ }
    }
  ; left-inverse-of = λ P →
      let lemma = λ a →
            (∃ λ (i : ∃ P) → proj₁ i ≡ a)  ↔⟨ inverse Σ-assoc ⟩
            (∃ λ a′ → P a′ × a′ ≡ a)       ↔⟨ inverse $ ∃-intro _ _ ⟩□
            P a                            □
      in
      (λ a → ∃ λ (i : ∃ P) → proj₁ i ≡ a)  ≡⟨ apply-ext ext (λ a → ≃⇒≡ univ (lemma a)) ⟩∎
      P                                    ∎
  }

-- An isomorphism that follows from Pow↔Fam.
--
-- This isomorphism was suggested to me by Paolo Capriotti.

→↔Σ≃Σ :
  ∀ ℓ {a b} {A : Type a} {B : Type b} →
  Extensionality (a ⊔ b ⊔ ℓ) (lsuc (a ⊔ b ⊔ ℓ)) →
  Univalence (a ⊔ b ⊔ ℓ) →
  (A → B) ↔ ∃ λ (P : B → Type (a ⊔ b ⊔ ℓ)) → A ≃ Σ B P
→↔Σ≃Σ ℓ {a} {b} {A} {B} ext univ =
  (A → B)                                                    ↝⟨ →-cong₁ (lower-extensionality lzero _ ext) (inverse Bijection.↑↔) ⟩
  (↑ (b ⊔ ℓ) A → B)                                          ↝⟨ inverse ×-left-identity ⟩
  ⊤ × (↑ _ A → B)                                            ↝⟨ inverse $ _⇔_.to contractible⇔↔⊤ (singleton-contractible _) ×-cong F.id ⟩
  (∃ λ (A′ : Type ℓ′) → A′ ≡ ↑ _ A) × (↑ _ A → B)            ↝⟨ inverse Σ-assoc ⟩
  (∃ λ (A′ : Type ℓ′) → A′ ≡ ↑ _ A × (↑ _ A → B))            ↝⟨ (∃-cong λ _ → ∃-cong λ eq → →-cong₁ (lower-extensionality lzero _ ext) (≡⇒≃ (sym eq))) ⟩
  (∃ λ (A′ : Type ℓ′) → A′ ≡ ↑ _ A × (A′ → B))               ↝⟨ (∃-cong λ _ → ×-comm) ⟩
  (∃ λ (A′ : Type ℓ′) → (A′ → B) × A′ ≡ ↑ _ A)               ↝⟨ Σ-assoc ⟩
  (∃ λ (p : ∃ λ (A′ : Type ℓ′) → A′ → B) → proj₁ p ≡ ↑ _ A)  ↝⟨ inverse $ Σ-cong (Pow↔Fam (a ⊔ ℓ) (lower-extensionality ℓ′ lzero ext) univ) (λ _ → F.id) ⟩
  (∃ λ (P : B → Type ℓ′) → ∃ P ≡ ↑ _ A)                      ↔⟨ (∃-cong λ _ → ≡≃≃ univ) ⟩
  (∃ λ (P : B → Type ℓ′) → ∃ P ≃ ↑ _ A)                      ↝⟨ (∃-cong λ _ → Groupoid.⁻¹-bijection (Eq.groupoid (lower-extensionality ℓ′ _ ext))) ⟩
  (∃ λ (P : B → Type ℓ′) → ↑ _ A ≃ ∃ P)                      ↔⟨ (∃-cong λ _ →
                                                                 Eq.≃-preserves (lower-extensionality lzero _ ext) (Eq.↔⇒≃ Bijection.↑↔) F.id) ⟩□
  (∃ λ (P : B → Type ℓ′) → A ≃ ∃ P)                          □
  where
  ℓ′ = a ⊔ b ⊔ ℓ

------------------------------------------------------------------------
-- More lemmas

abstract

  -- The univalence axiom is propositional (assuming extensionality).

  Univalence′-propositional :
    ∀ {ℓ} → Extensionality (lsuc ℓ) (lsuc ℓ) →
    {A B : Type ℓ} → Is-proposition (Univalence′ A B)
  Univalence′-propositional ext {A = A} {B = B} =          $⟨ Eq.propositional ext ≡⇒≃ ⟩
    Is-proposition (Is-equivalence (≡⇒≃ {A = A} {B = B}))  ↝⟨ H-level-cong _ 1 (inverse Univalence′≃Is-equivalence-≡⇒≃) ⦂ (_ → _) ⟩□
    Is-proposition (Univalence′ A B)                       □

  Univalence-propositional :
    ∀ {ℓ} → Extensionality (lsuc ℓ) (lsuc ℓ) →
    Is-proposition (Univalence ℓ)
  Univalence-propositional ext =
    implicit-Π-closure ext 1 λ _ →
    implicit-Π-closure ext 1 λ _ →
    Univalence′-propositional ext

  -- ≡⇒≃ commutes with sym/Eq.inverse (assuming extensionality).

  ≡⇒≃-sym :
    ∀ {ℓ} → Extensionality ℓ ℓ →
    {A B : Type ℓ} (A≡B : A ≡ B) →
    ≡⇒≃ (sym A≡B) ≡ Eq.inverse (≡⇒≃ A≡B)
  ≡⇒≃-sym ext = elim¹

    (λ eq → ≡⇒≃ (sym eq) ≡ Eq.inverse (≡⇒≃ eq))

    (≡⇒≃ (sym (refl _))         ≡⟨ cong ≡⇒≃ sym-refl ⟩
     ≡⇒≃ (refl _)               ≡⟨ ≡⇒≃-refl ⟩
     Eq.id                      ≡⟨ sym $ Groupoid.identity (Eq.groupoid ext) ⟩
     Eq.inverse Eq.id           ≡⟨ cong Eq.inverse $ sym ≡⇒≃-refl ⟩∎
     Eq.inverse (≡⇒≃ (refl _))  ∎)

  -- ≃⇒≡ univ commutes with Eq.inverse/sym (assuming extensionality).

  ≃⇒≡-inverse :
    ∀ {ℓ} (univ : Univalence ℓ) → Extensionality ℓ ℓ →
    {A B : Type ℓ} (A≃B : A ≃ B) →
    ≃⇒≡ univ (Eq.inverse A≃B) ≡ sym (≃⇒≡ univ A≃B)
  ≃⇒≡-inverse univ ext A≃B =
    ≃⇒≡ univ (Eq.inverse A≃B)                   ≡⟨ sym $ cong (λ p → ≃⇒≡ univ (Eq.inverse p)) (_≃_.right-inverse-of (≡≃≃ univ) _) ⟩
    ≃⇒≡ univ (Eq.inverse (≡⇒≃ (≃⇒≡ univ A≃B)))  ≡⟨ cong (≃⇒≡ univ) $ sym $ ≡⇒≃-sym ext _ ⟩
    ≃⇒≡ univ (≡⇒≃ (sym (≃⇒≡ univ A≃B)))         ≡⟨ _≃_.left-inverse-of (≡≃≃ univ) _ ⟩∎
    sym (≃⇒≡ univ A≃B)                          ∎

  -- ≡⇒≃ commutes with trans/_⊚_ (assuming extensionality).

  ≡⇒≃-trans :
    ∀ {ℓ} → Extensionality ℓ ℓ →
    {A B C : Type ℓ} (A≡B : A ≡ B) (B≡C : B ≡ C) →
    ≡⇒≃ (trans A≡B B≡C) ≡ ≡⇒≃ B≡C ⊚ ≡⇒≃ A≡B
  ≡⇒≃-trans ext A≡B = elim¹

    (λ eq → ≡⇒≃ (trans A≡B eq) ≡ ≡⇒≃ eq ⊚ ≡⇒≃ A≡B)

    (≡⇒≃ (trans A≡B (refl _))  ≡⟨ cong ≡⇒≃ $ trans-reflʳ _ ⟩
     ≡⇒≃ A≡B                   ≡⟨ sym $ Groupoid.left-identity (Eq.groupoid ext) _ ⟩
     Eq.id ⊚ ≡⇒≃ A≡B           ≡⟨ sym $ cong (λ eq → eq ⊚ ≡⇒≃ A≡B) ≡⇒≃-refl ⟩∎
     ≡⇒≃ (refl _) ⊚ ≡⇒≃ A≡B    ∎)

  -- ≃⇒≡ univ commutes with _⊚_/flip trans (assuming extensionality).

  ≃⇒≡-∘ :
    ∀ {ℓ} (univ : Univalence ℓ) → Extensionality ℓ ℓ →
    {A B C : Type ℓ} (A≃B : A ≃ B) (B≃C : B ≃ C) →
    ≃⇒≡ univ (B≃C ⊚ A≃B) ≡ trans (≃⇒≡ univ A≃B) (≃⇒≡ univ B≃C)
  ≃⇒≡-∘ univ ext A≃B B≃C =
    ≃⇒≡ univ (B≃C ⊚ A≃B)                                  ≡⟨ sym $ cong₂ (λ p q → ≃⇒≡ univ (p ⊚ q)) (_≃_.right-inverse-of (≡≃≃ univ) _)
                                                                                (_≃_.right-inverse-of (≡≃≃ univ) _) ⟩
    ≃⇒≡ univ (≡⇒≃ (≃⇒≡ univ B≃C) ⊚ ≡⇒≃ (≃⇒≡ univ A≃B))    ≡⟨ cong (≃⇒≡ univ) $ sym $ ≡⇒≃-trans ext _ _ ⟩
    ≃⇒≡ univ (≡⇒≃ (trans (≃⇒≡ univ A≃B) (≃⇒≡ univ B≃C)))  ≡⟨ _≃_.left-inverse-of (≡≃≃ univ) _ ⟩∎
    trans (≃⇒≡ univ A≃B) (≃⇒≡ univ B≃C)                   ∎

  -- A variant of the transport theorem.

  transport-theorem′ :
    ∀ {a p r} {A : Type a}
    (P : A → Type p) (R : A → A → Type r)
    (≡↠R : ∀ {x y} → (x ≡ y) ↠ R x y)
    (resp : ∀ {x y} → R x y → P x → P y) →
    (∀ x p → resp (_↠_.to ≡↠R (refl x)) p ≡ p) →
    ∀ {x y} (r : R x y) (p : P x) →
    resp r p ≡ subst P (_↠_.from ≡↠R r) p
  transport-theorem′ P R ≡↠R resp hyp r p =
    resp r p              ≡⟨ sym $ cong (λ r → resp r p) (right-inverse-of r) ⟩
    resp (to (from r)) p  ≡⟨ elim (λ {x y} x≡y → ∀ p →
                                     resp (_↠_.to ≡↠R x≡y) p ≡ subst P x≡y p)
                                  (λ x p →
                                     resp (_↠_.to ≡↠R (refl x)) p  ≡⟨ hyp x p ⟩
                                     p                             ≡⟨ sym $ subst-refl P p ⟩∎
                                     subst P (refl x) p            ∎) _ _ ⟩∎
    subst P (from r) p    ∎
    where open _↠_ ≡↠R

  -- Simplification (?) lemma for transport-theorem′.

  transport-theorem′-refl :
    ∀ {a p r} {A : Type a}
    (P : A → Type p) (R : A → A → Type r)
    (≡≃R : ∀ {x y} → (x ≡ y) ≃ R x y)
    (resp : ∀ {x y} → R x y → P x → P y) →
    (resp-refl : ∀ x p → resp (_≃_.to ≡≃R (refl x)) p ≡ p) →
    ∀ {x} (p : P x) →
    transport-theorem′ P R (_≃_.surjection ≡≃R) resp resp-refl
                       (_≃_.to ≡≃R (refl x)) p ≡
    trans (trans (resp-refl x p) (sym $ subst-refl P p))
          (sym $ cong (λ eq → subst P eq p)
                      (_≃_.left-inverse-of ≡≃R (refl x)))
  transport-theorem′-refl P R ≡≃R resp resp-refl {x} p =

    let body = λ x p → trans (resp-refl x p) (sym $ subst-refl P p)

        lemma =
          trans (sym $ cong (λ r → resp (to r) p) $ refl (refl x))
                (elim (λ {x y} x≡y →
                         ∀ p → resp (_≃_.to ≡≃R x≡y) p ≡ subst P x≡y p)
                      (λ x p → trans (resp-refl x p)
                                     (sym $ subst-refl P p))
                      (refl x) p)                                        ≡⟨ cong₂ (λ q r → trans q (r p))
                                                                                (sym $ cong-sym (λ r → resp (to r) p) _)
                                                                                (elim-refl (λ {x y} x≡y → ∀ p →
                                                                                resp (_≃_.to ≡≃R x≡y) p ≡ subst P x≡y p) _) ⟩
          trans (cong (λ r → resp (to r) p) $ sym $ refl (refl x))
                (body x p)                                               ≡⟨ cong (λ q → trans (cong (λ r → resp (to r) p) q) (body x p))
                                                                                sym-refl ⟩
          trans (cong (λ r → resp (to r) p) $ refl (refl x)) (body x p)  ≡⟨ cong (λ q → trans q (body x p)) $
                                                                                cong-refl (λ r → resp (to r) p) ⟩
          trans (refl (resp (to (refl x)) p)) (body x p)                 ≡⟨ trans-reflˡ _ ⟩

          body x p                                                       ≡⟨ sym $ trans-reflʳ _ ⟩

          trans (body x p) (refl (subst P (refl x) p))                   ≡⟨ cong (trans (body x p)) $ sym $
                                                                                cong-refl (λ eq → subst P eq p) ⟩
          trans (body x p)
                (cong (λ eq → subst P eq p) (refl (refl x)))             ≡⟨ cong (trans (body x p) ∘ cong (λ eq → subst P eq p)) $
                                                                                sym sym-refl ⟩
          trans (body x p)
                (cong (λ eq → subst P eq p) (sym (refl (refl x))))       ≡⟨ cong (trans (body x p)) $ cong-sym (λ eq → subst P eq p) _ ⟩∎

          trans (body x p)
                (sym $ cong (λ eq → subst P eq p) (refl (refl x)))       ∎
    in

    trans (sym $ cong (λ r → resp r p) $ right-inverse-of (to (refl x)))
          (elim (λ {x y} x≡y →
                   ∀ p → resp (_≃_.to ≡≃R x≡y) p ≡ subst P x≡y p)
                body (from (to (refl x))) p)                              ≡⟨ cong (λ eq → trans (sym $ cong (λ r → resp r p) eq)
                                                                                (elim (λ {x y} x≡y → ∀ p →
                                                                                resp (_≃_.to ≡≃R x≡y) p ≡ subst P x≡y p)
                                                                                body (from (to (refl x))) p)) $
                                                                                sym $ left-right-lemma (refl x) ⟩
    trans (sym $ cong (λ r → resp r p) $ cong to $
             left-inverse-of (refl x))
          (elim (λ {x y} x≡y →
                   ∀ p → resp (_≃_.to ≡≃R x≡y) p ≡ subst P x≡y p)
                body (from (to (refl x))) p)                              ≡⟨ cong (λ eq → trans (sym eq)
                                                                                (elim (λ {x y} x≡y → ∀ p →
                                                                                resp (_≃_.to ≡≃R x≡y) p ≡ subst P x≡y p)
                                                                                body (from (to (refl x))) p)) $
                                                                                cong-∘ (λ r → resp r p) to _ ⟩
    trans (sym $ cong (λ r → resp (to r) p) $ left-inverse-of (refl x))
          (elim (λ {x y} x≡y →
                   ∀ p → resp (_≃_.to ≡≃R x≡y) p ≡ subst P x≡y p)
                body (from (to (refl x))) p)                              ≡⟨ elim₁ (λ {q} eq → trans (sym $ cong (λ r → resp (to r) p) eq)
                                                                                (elim (λ {x y} x≡y → ∀ p →
                                                                                resp (_≃_.to ≡≃R x≡y) p ≡
                                                                                subst P x≡y p)
                                                                                body q p) ≡
                                                                                trans (body x p)
                                                                                (sym $ cong (λ eq → subst P eq p) eq))
                                                                                lemma
                                                                                (left-inverse-of (refl x)) ⟩∎

    trans (body x p)
          (sym $ cong (λ eq → subst P eq p) (left-inverse-of (refl x)))   ∎

    where open _≃_ ≡≃R

  -- Simplification (?) lemma for transport-theorem.

  transport-theorem-≡⇒≃-refl :
    ∀ {p₁ p₂} (P : Type p₁ → Type p₂)
    (resp : ∀ {A B} → A ≃ B → P A → P B)
    (resp-id : ∀ {A} (p : P A) → resp Eq.id p ≡ p)
    (univ : Univalence p₁) {A} (p : P A) →
    transport-theorem P resp resp-id univ (≡⇒≃ (refl A)) p ≡
    trans (trans (trans (cong (λ eq → resp eq p) ≡⇒≃-refl)
                    (resp-id p))
             (sym $ subst-refl P p))
      (sym $ cong (λ eq → subst P eq p)
                  (_≃_.left-inverse-of (≡≃≃ univ) (refl A)))
  transport-theorem-≡⇒≃-refl P resp resp-id univ {A} p =
    transport-theorem′-refl P _≃_ (≡≃≃ univ) resp
      (λ _ p → trans (cong (λ eq → resp eq p) ≡⇒≃-refl) (resp-id p)) p

  -- A variant of resp-is-equivalence.

  resp-is-equivalence′ :
    ∀ {a p r} {A : Type a}
    (P : A → Type p) (R : A → A → Type r)
    (≡↠R : ∀ {x y} → (x ≡ y) ↠ R x y)
    (resp : ∀ {x y} → R x y → P x → P y) →
    (∀ x p → resp (_↠_.to ≡↠R (refl x)) p ≡ p) →
    ∀ {x y} (r : R x y) → Is-equivalence (resp r)
  resp-is-equivalence′ P R ≡↠R resp hyp r =
    Eq.respects-extensional-equality
      (λ p → sym $ transport-theorem′ P R ≡↠R resp hyp r p)
      (Eq.subst-is-equivalence P (_↠_.from ≡↠R r))

  -- A lemma relating ≃⇒≡, →-cong and cong₂.

  ≃⇒≡-→-cong :
    ∀ {ℓ} {A₁ A₂ B₁ B₂ : Type ℓ}
    (ext : Extensionality ℓ ℓ) →
    (univ : Univalence ℓ)
    (A₁≃A₂ : A₁ ≃ A₂) (B₁≃B₂ : B₁ ≃ B₂) →
    ≃⇒≡ univ (→-cong ext A₁≃A₂ B₁≃B₂) ≡
      cong₂ (λ A B → A → B) (≃⇒≡ univ A₁≃A₂) (≃⇒≡ univ B₁≃B₂)
  ≃⇒≡-→-cong {A₂ = A₂} {B₁} ext univ A₁≃A₂ B₁≃B₂ =
    ≃⇒≡ univ (→-cong ext A₁≃A₂ B₁≃B₂)                        ≡⟨ cong (≃⇒≡ univ) (Eq.lift-equality ext lemma) ⟩

    ≃⇒≡ univ (≡⇒≃ (cong₂ (λ A B → A → B) (≃⇒≡ univ A₁≃A₂)
                                         (≃⇒≡ univ B₁≃B₂)))  ≡⟨ left-inverse-of (≡≃≃ univ) _ ⟩∎

    cong₂ (λ A B → A → B) (≃⇒≡ univ A₁≃A₂) (≃⇒≡ univ B₁≃B₂)  ∎
    where
    open _≃_

    lemma :
      (λ f → to B₁≃B₂ ∘ f ∘ from A₁≃A₂) ≡
      to (≡⇒≃ (cong₂ (λ A B → A → B) (≃⇒≡ univ A₁≃A₂)
                                     (≃⇒≡ univ B₁≃B₂)))
    lemma =
      (λ f → to B₁≃B₂ ∘ f ∘ from A₁≃A₂)                  ≡⟨ apply-ext ext (λ _ → transport-theorem (λ B → A₂ → B) (λ A≃B g → _≃_.to A≃B ∘ g)
                                                                                refl univ B₁≃B₂ _) ⟩
      subst (λ B → A₂ → B) (≃⇒≡ univ B₁≃B₂) ∘
      (λ f → f ∘ from A₁≃A₂)                             ≡⟨ cong (_∘_ (subst (λ B → A₂ → B) (≃⇒≡ univ B₁≃B₂))) (apply-ext ext λ f →
                                                              transport-theorem (λ A → A → B₁) (λ A≃B g → g ∘ _≃_.from A≃B) refl univ A₁≃A₂ f) ⟩
      subst (λ B → A₂ → B) (≃⇒≡ univ B₁≃B₂) ∘
      subst (λ A → A → B₁) (≃⇒≡ univ A₁≃A₂)              ≡⟨ cong₂ (λ g h f → g (h f))
                                                              (apply-ext ext $ subst-in-terms-of-≡⇒↝ equivalence _ (λ B → A₂ → B))
                                                              (apply-ext ext $ subst-in-terms-of-≡⇒↝ equivalence _ (λ A → A → B₁)) ⟩
      to (≡⇒≃ (cong (λ B → A₂ → B) (≃⇒≡ univ B₁≃B₂))) ∘
      to (≡⇒≃ (cong (λ A → A → B₁) (≃⇒≡ univ A₁≃A₂)))    ≡⟨⟩

      to (≡⇒≃ (cong (λ B → A₂ → B) (≃⇒≡ univ B₁≃B₂)) ⊚
          ≡⇒≃ (cong (λ A → A → B₁) (≃⇒≡ univ A₁≃A₂)))    ≡⟨ cong to $ sym $ ≡⇒≃-trans ext _ _ ⟩∎

      to (≡⇒≃ (cong₂ (λ A B → A → B) (≃⇒≡ univ A₁≃A₂)
                                     (≃⇒≡ univ B₁≃B₂)))  ∎

  -- One can sometimes push cong through ≃⇒≡ (assuming
  -- extensionality).

  cong-≃⇒≡ :
    ∀ {ℓ p} {A B : Type ℓ} {A≃B : A ≃ B} →
    Extensionality p p →
    (univ₁ : Univalence ℓ)
    (univ₂ : Univalence p)
    (P : Type ℓ → Type p)
    (P-cong : ∀ {A B} → A ≃ B → P A ≃ P B) →
    (∀ {A} (p : P A) → _≃_.to (P-cong Eq.id) p ≡ p) →
    cong P (≃⇒≡ univ₁ A≃B) ≡ ≃⇒≡ univ₂ (P-cong A≃B)
  cong-≃⇒≡ {A≃B = A≃B} ext univ₁ univ₂ P P-cong P-cong-id =
    cong P (≃⇒≡ univ₁ A≃B)                    ≡⟨ sym $ _≃_.left-inverse-of (≡≃≃ univ₂) _ ⟩
    ≃⇒≡ univ₂ (≡⇒≃ (cong P (≃⇒≡ univ₁ A≃B)))  ≡⟨ cong (≃⇒≡ univ₂) $ Eq.lift-equality ext lemma ⟩∎
    ≃⇒≡ univ₂ (P-cong A≃B)                    ∎
    where
    lemma : ≡⇒→ (cong P (≃⇒≡ univ₁ A≃B)) ≡ _≃_.to (P-cong A≃B)
    lemma = apply-ext ext λ x →
      ≡⇒→ (cong P (≃⇒≡ univ₁ A≃B)) x  ≡⟨ sym $ subst-in-terms-of-≡⇒↝ equivalence _ P x ⟩
      subst P (≃⇒≡ univ₁ A≃B) x       ≡⟨ sym $ transport-theorem P (_≃_.to ∘ P-cong) P-cong-id univ₁ A≃B x ⟩∎
      _≃_.to (P-cong A≃B) x           ∎

  -- Any "resp" function that preserves identity also preserves
  -- compositions (assuming univalence and extensionality).

  resp-preserves-compositions :
    ∀ {p₁ p₂} (P : Type p₁ → Type p₂) →
    (resp : ∀ {A B} → A ≃ B → P A → P B) →
    (∀ {A} (p : P A) → resp Eq.id p ≡ p) →
    Univalence p₁ → Extensionality p₁ p₁ →
    ∀ {A B C} (A≃B : A ≃ B) (B≃C : B ≃ C) p →
    resp (B≃C ⊚ A≃B) p ≡ (resp B≃C ∘ resp A≃B) p
  resp-preserves-compositions P resp resp-id univ ext A≃B B≃C p =
    resp (B≃C ⊚ A≃B) p                                 ≡⟨ transport-theorem P resp resp-id univ _ _ ⟩
    subst P (≃⇒≡ univ (B≃C ⊚ A≃B)) p                   ≡⟨ cong (λ eq → subst P eq p) $ ≃⇒≡-∘ univ ext A≃B B≃C ⟩
    subst P (trans (≃⇒≡ univ A≃B) (≃⇒≡ univ B≃C)) p    ≡⟨ sym $ subst-subst P _ _ _ ⟩
    subst P (≃⇒≡ univ B≃C) (subst P (≃⇒≡ univ A≃B) p)  ≡⟨ sym $ transport-theorem P resp resp-id univ _ _ ⟩
    resp B≃C (subst P (≃⇒≡ univ A≃B) p)                ≡⟨ sym $ cong (resp _) $ transport-theorem P resp resp-id univ _ _ ⟩∎
    resp B≃C (resp A≃B p)                              ∎

  -- Any "resp" function that preserves identity also preserves
  -- inverses (assuming univalence and extensionality).

  resp-preserves-inverses :
    ∀ {p₁ p₂} (P : Type p₁ → Type p₂) →
    (resp : ∀ {A B} → A ≃ B → P A → P B) →
    (∀ {A} (p : P A) → resp Eq.id p ≡ p) →
    Univalence p₁ → Extensionality p₁ p₁ →
    ∀ {A B} (A≃B : A ≃ B) p q →
    resp A≃B p ≡ q → resp (inverse A≃B) q ≡ p
  resp-preserves-inverses P resp resp-id univ ext A≃B p q eq =
    let lemma =
          q                                     ≡⟨ sym eq ⟩
          resp A≃B p                            ≡⟨ transport-theorem P resp resp-id univ _ _ ⟩
          subst P (≃⇒≡ univ A≃B) p              ≡⟨ cong (λ eq → subst P eq p) $ sym $ sym-sym _ ⟩∎
          subst P (sym (sym (≃⇒≡ univ A≃B))) p  ∎
    in

    resp (inverse A≃B) q                                                 ≡⟨ transport-theorem P resp resp-id univ _ _ ⟩
    subst P (≃⇒≡ univ (inverse A≃B)) q                                   ≡⟨ cong (λ eq → subst P eq q) $ ≃⇒≡-inverse univ ext A≃B ⟩
    subst P (sym (≃⇒≡ univ A≃B)) q                                       ≡⟨ cong (subst P (sym (≃⇒≡ univ A≃B))) lemma ⟩
    subst P (sym (≃⇒≡ univ A≃B)) (subst P (sym (sym (≃⇒≡ univ A≃B))) p)  ≡⟨ subst-subst-sym P _ _ ⟩∎
    p                                                                    ∎

-- Equality preserves equivalences (assuming extensionality and
-- univalence).

≡-preserves-≃ :
  ∀ {ℓ₁ ℓ₂}
    {A₁ : Type ℓ₁} {A₂ : Type ℓ₂} {B₁ : Type ℓ₁} {B₂ : Type ℓ₂} →
  Extensionality (ℓ₁ ⊔ ℓ₂) (ℓ₁ ⊔ ℓ₂) →
  Univalence′ A₁ B₁ →
  Univalence′ A₂ B₂ →
  A₁ ≃ A₂ → B₁ ≃ B₂ → (A₁ ≡ B₁) ≃ (A₂ ≡ B₂)
≡-preserves-≃ {ℓ₁} {ℓ₂} {A₁} {A₂} {B₁} {B₂}
              ext univ₁ univ₂ A₁≃A₂ B₁≃B₂ = Eq.↔⇒≃ (record
  { surjection = record
    { logical-equivalence = record
      { to   = to
      ; from = from
      }
    ; right-inverse-of = to∘from
    }
  ; left-inverse-of = from∘to
  })
  where
  to = λ A₁≡B₁ → ≃⇒≡ univ₂ (
    A₂  ↝⟨ inverse A₁≃A₂ ⟩
    A₁  ↝⟨ ≡⇒≃ A₁≡B₁ ⟩
    B₁  ↝⟨ B₁≃B₂ ⟩□
    B₂  □)

  from = λ A₂≡B₂ → ≃⇒≡ univ₁ (
    A₁  ↝⟨ A₁≃A₂ ⟩
    A₂  ↝⟨ ≡⇒≃ A₂≡B₂ ⟩
    B₂  ↝⟨ inverse B₁≃B₂ ⟩□
    B₁  □)

  abstract

    to∘from : ∀ eq → to (from eq) ≡ eq
    to∘from A₂≡B₂ =
      let ext₂ = lower-extensionality ℓ₁ ℓ₁ ext in

      _≃_.to (Eq.≃-≡ (≡≃≃ univ₂)) (Eq.lift-equality ext₂ (

        ≡⇒→ (≃⇒≡ univ₂ ((B₁≃B₂ ⊚ ≡⇒≃ (≃⇒≡ univ₁ ((inverse B₁≃B₂ ⊚
                             ≡⇒≃ A₂≡B₂) ⊚ A₁≃A₂))) ⊚ inverse A₁≃A₂))  ≡⟨ cong _≃_.to $ _≃_.right-inverse-of (≡≃≃ univ₂) _ ⟩

        (_≃_.to B₁≃B₂ ∘
         ≡⇒→ (≃⇒≡ univ₁ ((inverse B₁≃B₂ ⊚ ≡⇒≃ A₂≡B₂) ⊚ A₁≃A₂)) ∘
         _≃_.from A₁≃A₂)                                              ≡⟨ cong (λ eq → _≃_.to B₁≃B₂ ∘ _≃_.to eq ∘ _≃_.from A₁≃A₂) $
                                                                           _≃_.right-inverse-of (≡≃≃ univ₁) _ ⟩
        ((_≃_.to B₁≃B₂ ∘ _≃_.from B₁≃B₂) ∘ ≡⇒→ A₂≡B₂ ∘
         (_≃_.to A₁≃A₂ ∘ _≃_.from A₁≃A₂))                             ≡⟨ cong₂ (λ f g → f ∘ ≡⇒→ A₂≡B₂ ∘ g)
                                                                               (apply-ext ext₂ $ _≃_.right-inverse-of B₁≃B₂)
                                                                               (apply-ext ext₂ $ _≃_.right-inverse-of A₁≃A₂) ⟩∎
        ≡⇒→ A₂≡B₂                                                     ∎))

    from∘to : ∀ eq → from (to eq) ≡ eq
    from∘to A₁≡B₁ =
      let ext₁ = lower-extensionality ℓ₂ ℓ₂ ext in

      _≃_.to (Eq.≃-≡ (≡≃≃ univ₁)) (Eq.lift-equality ext₁ (

        ≡⇒→ (≃⇒≡ univ₁ ((inverse B₁≃B₂ ⊚ ≡⇒≃ (≃⇒≡ univ₂ ((B₁≃B₂ ⊚
                             ≡⇒≃ A₁≡B₁) ⊚ inverse A₁≃A₂))) ⊚ A₁≃A₂))  ≡⟨ cong _≃_.to $ _≃_.right-inverse-of (≡≃≃ univ₁) _ ⟩

        (_≃_.from B₁≃B₂ ∘
         ≡⇒→ (≃⇒≡ univ₂ ((B₁≃B₂ ⊚ ≡⇒≃ A₁≡B₁) ⊚ inverse A₁≃A₂)) ∘
         _≃_.to A₁≃A₂)                                                ≡⟨ cong (λ eq → _≃_.from B₁≃B₂ ∘ _≃_.to eq ∘ _≃_.to A₁≃A₂) $
                                                                           _≃_.right-inverse-of (≡≃≃ univ₂) _ ⟩
        ((_≃_.from B₁≃B₂ ∘ _≃_.to B₁≃B₂) ∘ ≡⇒→ A₁≡B₁ ∘
         (_≃_.from A₁≃A₂ ∘ _≃_.to A₁≃A₂))                             ≡⟨ cong₂ (λ f g → f ∘ ≡⇒→ A₁≡B₁ ∘ g)
                                                                               (apply-ext ext₁ $ _≃_.left-inverse-of B₁≃B₂)
                                                                               (apply-ext ext₁ $ _≃_.left-inverse-of A₁≃A₂) ⟩∎
        ≡⇒→ A₁≡B₁                                                     ∎))

-- Singletons expressed using equivalences instead of equalities,
-- where the types are required to live in the same universe, are
-- contractible (assuming univalence).

singleton-with-≃-contractible :
  ∀ {b} {B : Type b} →
  Univalence b →
  Contractible (∃ λ (A : Type b) → A ≃ B)
singleton-with-≃-contractible univ =
  H-level.respects-surjection
    (∃-cong λ _ → _≃_.surjection (≡≃≃ univ))
    0
    (singleton-contractible _)

other-singleton-with-≃-contractible :
  ∀ {a} {A : Type a} →
  Univalence a →
  Contractible (∃ λ (B : Type a) → A ≃ B)
other-singleton-with-≃-contractible univ =
  H-level.respects-surjection
    (∃-cong λ _ → _≃_.surjection (≡≃≃ univ))
    0
    (other-singleton-contractible _)

-- Singletons expressed using equivalences instead of equalities are
-- isomorphic to the unit type (assuming extensionality and
-- univalence).

singleton-with-≃-↔-⊤ :
  ∀ {a b} {B : Type b} →
  Extensionality (a ⊔ b) (a ⊔ b) →
  Univalence (a ⊔ b) →
  (∃ λ (A : Type (a ⊔ b)) → A ≃ B) ↔ ⊤
singleton-with-≃-↔-⊤ {a} {B = B} ext univ =
  (∃ λ A → A ≃ B)      ↝⟨ inverse (∃-cong λ _ → Eq.≃-preserves-bijections ext F.id Bijection.↑↔) ⟩
  (∃ λ A → A ≃ ↑ a B)  ↔⟨ inverse (∃-cong λ _ → ≡≃≃ univ) ⟩
  (∃ λ A → A ≡ ↑ a B)  ↝⟨ _⇔_.to contractible⇔↔⊤ (singleton-contractible _) ⟩□
  ⊤                    □

other-singleton-with-≃-↔-⊤ :
  ∀ {a b} {A : Type a} →
  Extensionality (a ⊔ b) (a ⊔ b) →
  Univalence (a ⊔ b) →
  (∃ λ (B : Type (a ⊔ b)) → A ≃ B) ↔ ⊤
other-singleton-with-≃-↔-⊤ {b = b} {A} ext univ =
  (∃ λ B → A ≃ B)  ↝⟨ (∃-cong λ _ → Eq.inverse-isomorphism ext) ⟩
  (∃ λ B → B ≃ A)  ↝⟨ singleton-with-≃-↔-⊤ {a = b} ext univ ⟩□
  ⊤                □

-- Variants of the two lemmas above.

singleton-with-Π-≃-≃-⊤ :
  ∀ {a q} {A : Type a} {Q : A → Type q} →
  Extensionality a (lsuc q) →
  Univalence q →
  (∃ λ (P : A → Type q) → ∀ x → P x ≃ Q x) ≃ ⊤
singleton-with-Π-≃-≃-⊤ {a = a} {q = q} {A = A} {Q = Q} ext univ =
  (∃ λ (P : A → Type q) → ∀ x → P x ≃ Q x)  ↝⟨ (inverse $ ∃-cong λ _ → ∀-cong ext λ _ → ≡≃≃ univ) ⟩
  (∃ λ (P : A → Type q) → ∀ x → P x ≡ Q x)  ↝⟨ (∃-cong λ _ → Eq.extensionality-isomorphism ext) ⟩
  (∃ λ (P : A → Type q) → P ≡ Q)            ↔⟨ _⇔_.to contractible⇔↔⊤ (singleton-contractible _) ⟩□
  ⊤                                         □

other-singleton-with-Π-≃-≃-⊤ :
  ∀ {a p} {A : Type a} {P : A → Type p} →
  Extensionality a (lsuc p) →
  Univalence p →
  (∃ λ (Q : A → Type p) → ∀ x → P x ≃ Q x) ≃ ⊤
other-singleton-with-Π-≃-≃-⊤ {a = a} {p = p} {A = A} {P = P} ext univ =
  (∃ λ (Q : A → Type p) → ∀ x → P x ≃ Q x)  ↝⟨ (inverse $ ∃-cong λ _ → ∀-cong ext λ _ → ≡≃≃ univ) ⟩
  (∃ λ (Q : A → Type p) → ∀ x → P x ≡ Q x)  ↝⟨ (∃-cong λ _ → Eq.extensionality-isomorphism ext) ⟩
  (∃ λ (Q : A → Type p) → P ≡ Q)            ↔⟨ _⇔_.to contractible⇔↔⊤ (other-singleton-contractible _) ⟩□
  ⊤                                         □

-- ∃ Contractible is isomorphic to the unit type (assuming
-- extensionality and univalence).

∃Contractible↔⊤ :
  ∀ {a} →
  Extensionality a a →
  Univalence a →
  (∃ λ (A : Type a) → Contractible A) ↔ ⊤
∃Contractible↔⊤ ext univ =
  (∃ λ A → Contractible A)  ↝⟨ (∃-cong λ _ → contractible↔≃⊤ ext) ⟩
  (∃ λ A → A ≃ ⊤)           ↝⟨ singleton-with-≃-↔-⊤ ext univ ⟩
  ⊤                         □

-- If two types have a certain h-level, then the type of equalities
-- between these types also has the given h-level (assuming
-- extensionality and univalence).

H-level-H-level-≡ :
  ∀ {a} {A₁ A₂ : Type a} →
  Extensionality a a →
  Univalence′ A₁ A₂ →
  ∀ n → H-level n A₁ → H-level n A₂ → H-level n (A₁ ≡ A₂)
H-level-H-level-≡ {A₁ = A₁} {A₂} ext univ n = curry (
  H-level n A₁ × H-level n A₂  ↝⟨ uncurry (Eq.h-level-closure ext n) ⟩
  H-level n (A₁ ≃ A₂)          ↝⟨ H-level.respects-surjection (_≃_.surjection $ inverse $ ≡≃≃ univ) n ⟩
  H-level n (A₁ ≡ A₂)          □)

-- If a type has a certain positive h-level, then the types of
-- equalities between this type and other types also has the given
-- h-level (assuming extensionality and univalence).

H-level-H-level-≡ˡ :
  ∀ {a} {A₁ A₂ : Type a} →
  Extensionality a a →
  Univalence′ A₁ A₂ →
  ∀ n → H-level (1 + n) A₁ → H-level (1 + n) (A₁ ≡ A₂)
H-level-H-level-≡ˡ {A₁ = A₁} {A₂} ext univ n =
  H-level (1 + n) A₁         ↝⟨ Eq.left-closure ext n ⟩
  H-level (1 + n) (A₁ ≃ A₂)  ↝⟨ H-level.respects-surjection (_≃_.surjection $ inverse $ ≡≃≃ univ) (1 + n) ⟩
  H-level (1 + n) (A₁ ≡ A₂)  □

H-level-H-level-≡ʳ :
  ∀ {a} {A₁ A₂ : Type a} →
  Extensionality a a →
  Univalence′ A₁ A₂ →
  ∀ n → H-level (1 + n) A₂ → H-level (1 + n) (A₁ ≡ A₂)
H-level-H-level-≡ʳ {A₁ = A₁} {A₂} ext univ n =
  H-level (1 + n) A₂         ↝⟨ Eq.right-closure ext n ⟩
  H-level (1 + n) (A₁ ≃ A₂)  ↝⟨ H-level.respects-surjection (_≃_.surjection $ inverse $ ≡≃≃ univ) (1 + n) ⟩
  H-level (1 + n) (A₁ ≡ A₂)  □

-- ∃ λ A → H-level n A has h-level 1 + n (assuming extensionality and
-- univalence).

∃-H-level-H-level-1+ :
  ∀ {a} →
  Extensionality a a →
  Univalence a →
  ∀ n → H-level (1 + n) (∃ λ (A : Type a) → H-level n A)
∃-H-level-H-level-1+ ext univ n = ≡↔+ _ _ λ { (A₁ , h₁) (A₂ , h₂) →
                                     $⟨ h₁ , h₂ ⟩
  H-level n A₁ × H-level n A₂        ↝⟨ uncurry (H-level-H-level-≡ ext univ n) ⟩
  H-level n (A₁ ≡ A₂)                ↝⟨ H-level.respects-surjection
                                          (_↔_.surjection $ ignore-propositional-component
                                                              (H-level-propositional ext _)) n ⟩□
  H-level n ((A₁ , h₁) ≡ (A₂ , h₂))  □ }

-- ∃ λ A → Is-proposition A is a set (assuming extensionality and
-- propositional extensionality).

Is-set-∃-Is-proposition :
  ∀ {a} →
  Extensionality (lsuc a) (lsuc a) →
  Propositional-extensionality a →
  Is-set (∃ λ (A : Type a) → Is-proposition A)
Is-set-∃-Is-proposition {a} ext prop-ext
                        {x = A₁ , A₁-prop} {y = A₂ , A₂-prop} =
                                                    $⟨ _≃_.to (Propositional-extensionality-is-univalence-for-propositions ext)
                                                            prop-ext A₁-prop A₂-prop ⟩
  Univalence′ A₁ A₂                                 ↝⟨ (λ univ → H-level-H-level-≡ ext′ univ 1 A₁-prop A₂-prop) ⟩
  Is-proposition (A₁ ≡ A₂)                          ↝⟨ H-level.respects-surjection
                                                         (_↔_.surjection $ ignore-propositional-component
                                                                             (H-level-propositional ext′ 1)) 1 ⟩□
  Is-proposition ((A₁ , A₁-prop) ≡ (A₂ , A₂-prop))  □
  where
  ext′ = lower-extensionality _ _ ext

-- ∃ λ A → H-level n A does not in general have h-level n.
--
-- (Kraus and Sattler show that, for all n,
-- ∃ λ (A : Set (# n)) → H-level (2 + n) A does not have h-level
-- 2 + n, assuming univalence. See "Higher Homotopies in a Hierarchy
-- of Univalent Universes".)

¬-∃-H-level-H-level :
  ∀ {a} →
  ∃ λ n → ¬ H-level n (∃ λ (A : Type a) → H-level n A)
¬-∃-H-level-H-level =
  1 ,
  ( Is-proposition (∃ λ A → Is-proposition A)               ↔⟨⟩
    ((p q : ∃ λ A → Is-proposition A) → p ≡ q)              ↝⟨ (λ f p q → cong proj₁ (f p q)) ⟩
    ((p q : ∃ λ A → Is-proposition A) → proj₁ p ≡ proj₁ q)  ↝⟨ (_$ (⊥ , ⊥-propositional)) ∘
                                                               (_$ (↑ _ ⊤ , ↑-closure 1 (mono₁ 0 ⊤-contractible))) ⟩
    ↑ _ ⊤ ≡ ⊥                                               ↝⟨ flip (subst id) _ ⟩
    ⊥                                                       ↝⟨ ⊥-elim ⟩□
    ⊥₀                                                      □)

-- A certain type of uninhabited types is isomorphic to the unit type
-- (assuming extensionality and univalence).

∃¬↔⊤ :
  ∀ {a} →
  Extensionality a a →
  Univalence a →
  (∃ λ (A : Type a) → ¬ A) ↔ ⊤
∃¬↔⊤ ext univ =
  (∃ λ A → ¬ A)     ↔⟨ inverse (∃-cong λ _ → ≃⊥≃¬ ext) ⟩
  (∃ λ A → A ≃ ⊥₀)  ↔⟨ singleton-with-≃-↔-⊤ ext univ ⟩
  ⊤                 □

-- The following three proofs are taken from or variants of proofs in
-- "Higher Homotopies in a Hierarchy of Univalent Universes" by Kraus
-- and Sattler (Section 3).

-- There is a function which, despite having the same type, is not
-- equal to a certain instance of reflexivity (assuming extensionality
-- and univalence).

∃≢refl :
  Extensionality (# 1) (# 1) →
  Univalence (# 0) →
  ∃ λ (A : Type₁) → ∃ λ (f : (x : A) → x ≡ x) → f ≢ refl
∃≢refl ext univ =
    (∃ λ (A : Type) → A ≡ A)
  , _↔_.from iso f
  , (_↔_.from iso f ≡ refl                                      ↝⟨ cong (_↔_.to iso) ⟩

     _↔_.to iso (_↔_.from iso f) ≡ _↔_.to iso refl              ↝⟨ (λ eq → f                            ≡⟨ sym (_↔_.right-inverse-of iso f) ⟩
                                                                           _↔_.to iso (_↔_.from iso f)  ≡⟨ eq ⟩∎
                                                                           _↔_.to iso refl              ∎) ⟩
     f ≡ _↔_.to iso refl                                        ↝⟨ cong (λ f → proj₁ (f Bool (swap-as-an-equality univ))) ⟩

     swap-as-an-equality univ ≡ proj₁ (_↔_.to iso refl Bool _)  ↝⟨ (λ eq → swap-as-an-equality univ        ≡⟨ eq ⟩
                                                                           proj₁ (_↔_.to iso refl Bool _)  ≡⟨ cong proj₁ Σ-≡,≡←≡-refl ⟩∎
                                                                           refl Bool                       ∎) ⟩

     swap-as-an-equality univ ≡ refl Bool                       ↝⟨ swap≢refl univ ⟩□

     ⊥                                                          □)
  where
  f = λ A p → p , refl (trans p p)

  iso =
    ((p : ∃ λ A → A ≡ A) → p ≡ p)                      ↝⟨ currying ⟩

    (∀ A (p : A ≡ A) → (A , p) ≡ (A , p))              ↝⟨ (∀-cong ext λ _ → ∀-cong ext λ _ →
                                                             inverse $ Bijection.Σ-≡,≡↔≡ {a = # 1}) ⟩
    ((A : Type) (p : A ≡ A) →
       ∃ λ (q : A ≡ A) → subst (λ A → A ≡ A) q p ≡ p)  ↝⟨ (∀-cong ext λ _ → ∀-cong ext λ _ →
                                                             ∃-cong λ _ → ≡⇒↝ _ [subst≡]≡[trans≡trans]) ⟩□
    ((A : Type) (p : A ≡ A) →
       ∃ λ (q : A ≡ A) → trans p q ≡ trans q p)        □

-- The type (a : A) → a ≡ a is not necessarily a proposition (assuming
-- extensionality and univalence).

¬-type-of-refl-propositional :
  Extensionality (# 1) (# 1) →
  Univalence (# 0) →
  ∃ λ (A : Type₁) → ¬ Is-proposition ((a : A) → a ≡ a)
¬-type-of-refl-propositional ext univ =
  let A , f , f≢refl = ∃≢refl ext univ in
  A ,
  (Is-proposition (∀ x → x ≡ x)  ↝⟨ (λ irr → irr _ _) ⟩
   f ≡ refl                      ↝⟨ f≢refl ⟩□
   ⊥                             □)

-- Type₁ does not have h-level 3 (assuming extensionality and
-- univalence).

¬-Type₁-groupoid :
  Extensionality (# 1) (# 1) →
  Univalence (# 1) →
  Univalence (# 0) →
  ¬ H-level 3 Type₁
¬-Type₁-groupoid ext univ₁ univ₀ =
  let L = _ in

  H-level 3 Type₁                       ↝⟨ (λ h → h) ⟩
  Is-set (L ≡ L)                        ↝⟨ H-level.respects-surjection (_≃_.surjection $ ≡≃≃ univ₁) 2 ⟩
  Is-set (L ≃ L)                        ↝⟨ (λ h → h) ⟩
  Is-proposition (F.id ≡ F.id)          ↝⟨ H-level.respects-surjection (_≃_.surjection $ inverse $ Eq.≃-≡ $ Eq.↔⇒≃ Eq.≃-as-Σ) 1 ⟩
  Is-proposition ((id , _) ≡ (id , _))  ↝⟨ H-level.respects-surjection
                                             (_↔_.surjection $ inverse $ ignore-propositional-component (Eq.propositional ext id)) 1 ⟩
  Is-proposition (id ≡ id)              ↝⟨ H-level.respects-surjection (_≃_.surjection $ inverse $ Eq.extensionality-isomorphism ext) 1 ⟩
  Is-proposition ((l : L) → l ≡ l)      ↝⟨ proj₂ $ ¬-type-of-refl-propositional ext univ₀ ⟩□
  ⊥                                     □

-- For propositional types there is a split surjection from equality
-- to logical equivalence (assuming univalence).

≡↠⇔ : ∀ {ℓ} {A B : Type ℓ} →
      Univalence′ A B →
      Is-proposition A → Is-proposition B →
      (A ≡ B) ↠ (A ⇔ B)
≡↠⇔ {A = A} {B} univ A-prop B-prop =
  A ≡ B  ↔⟨ ≡≃≃ univ ⟩
  A ≃ B  ↝⟨ Eq.≃↠⇔ A-prop B-prop ⟩□
  A ⇔ B  □

-- For propositional types logical equivalence is isomorphic to
-- equality (assuming extensionality and univalence).

⇔↔≡ : ∀ {ℓ} {A B : Type ℓ} →
      Extensionality ℓ ℓ →
      Univalence′ A B →
      Is-proposition A → Is-proposition B →
      (A ⇔ B) ↔ (A ≡ B)
⇔↔≡ {A = A} {B} ext univ A-prop B-prop =
  A ⇔ B  ↝⟨ Eq.⇔↔≃ ext A-prop B-prop ⟩
  A ≃ B  ↔⟨ inverse $ ≡≃≃ univ ⟩□
  A ≡ B  □

-- A variant of the previous statement.

⇔↔≡′ : ∀ {ℓ} {A B : Proposition ℓ} →
       Extensionality ℓ ℓ →
       Univalence′ (proj₁ A) (proj₁ B) →
       (proj₁ A ⇔ proj₁ B) ↔ (A ≡ B)
⇔↔≡′ {A = A} {B} ext univ =
  proj₁ A ⇔ proj₁ B  ↝⟨ ⇔↔≡ ext univ (proj₂ A) (proj₂ B) ⟩
  proj₁ A ≡ proj₁ B  ↝⟨ ignore-propositional-component (H-level-propositional ext 1) ⟩□
  A ≡ B              □

-- A variant of the previous statement.

⇔↔≡″ : ∀ {ℓ} {A B : Proposition ℓ} →
       Extensionality (lsuc ℓ) (lsuc ℓ) →
       Propositional-extensionality ℓ →
       (proj₁ A ⇔ proj₁ B) ↔ (A ≡ B)
⇔↔≡″ {ℓ} {A} {B} ext =
  Propositional-extensionality ℓ   ↝⟨ (λ prop-ext → _≃_.to (Propositional-extensionality-is-univalence-for-propositions ext)
                                                           prop-ext (proj₂ A) (proj₂ B)) ⟩
  Univalence′ (proj₁ A) (proj₁ B)  ↝⟨ ⇔↔≡′ (lower-extensionality _ _ ext) ⟩□
  (proj₁ A ⇔ proj₁ B) ↔ (A ≡ B)    □

------------------------------------------------------------------------
-- Variants of J for equivalences

-- Two variants of the J rule for equivalences, along with
-- "computation" rules.
--
-- The types of the eliminators are similar to the statement of
-- Corollary 5.8.5 from the HoTT book (where the motive takes two type
-- arguments). The type and code of ≃-elim₁ are based on code from the
-- cubical library written by Matthew Yacavone, which was possibly
-- based on code written by Anders Mörtberg.

≃-elim₁ :
  ∀ {ℓ p} {A B : Type ℓ} →
  Univalence ℓ →
  (P : {A : Type ℓ} → A ≃ B → Type p) →
  P (Eq.id {A = B}) →
  (A≃B : A ≃ B) → P A≃B
≃-elim₁ univ P p A≃B =
  subst
    (λ (_ , A≃B) → P A≃B)
    (mono₁ 0 (singleton-with-≃-contractible univ) _ _)
    p

≃-elim₁-id :
  ∀ {ℓ p} {B : Type ℓ}
  (univ : Univalence ℓ)
  (P : {A : Type ℓ} → A ≃ B → Type p)
  (p : P (Eq.id {A = B})) →
  ≃-elim₁ univ P p Eq.id ≡ p
≃-elim₁-id univ P p =
  subst
    (λ (_ , A≃B) → P A≃B)
    (mono₁ 0 (singleton-with-≃-contractible univ) _ _)
    p                                                   ≡⟨ cong (λ eq → subst (λ (_ , A≃B) → P A≃B) eq _) $
                                                           mono₁ 1 (mono₁ 0 (singleton-with-≃-contractible univ)) _ _ ⟩

  subst (λ (_ , A≃B) → P A≃B) (refl _) p                ≡⟨ subst-refl _ _ ⟩∎

  p                                                     ∎

≃-elim¹ :
  ∀ {ℓ p} {A B : Type ℓ} →
  Univalence ℓ →
  (P : {B : Type ℓ} → A ≃ B → Type p) →
  P (Eq.id {A = A}) →
  (A≃B : A ≃ B) → P A≃B
≃-elim¹ univ P p A≃B =
  subst
    (λ (_ , A≃B) → P A≃B)
    (mono₁ 0 (other-singleton-with-≃-contractible univ) _ _)
    p

≃-elim¹-id :
  ∀ {ℓ p} {A : Type ℓ}
  (univ : Univalence ℓ)
  (P : {B : Type ℓ} → A ≃ B → Type p)
  (p : P (Eq.id {A = A})) →
  ≃-elim¹ univ P p Eq.id ≡ p
≃-elim¹-id univ P p =
  subst
    (λ (_ , A≃B) → P A≃B)
    (mono₁ 0 (other-singleton-with-≃-contractible univ) _ _)
    p                                                         ≡⟨ cong (λ eq → subst (λ (_ , A≃B) → P A≃B) eq _) $
                                                                 mono₁ 1 (mono₁ 0 (other-singleton-with-≃-contractible univ)) _ _ ⟩

  subst (λ (_ , A≃B) → P A≃B) (refl _) p                      ≡⟨ subst-refl _ _ ⟩∎

  p                                                           ∎


------------------------------------------------------------------------
-- The Agda standard library
--
-- Level polymorphic Empty type
------------------------------------------------------------------------

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

module Data.Empty.Polymorphic where

open import Level

data ⊥ {ℓ : Level} : Set ℓ where

⊥-elim : ∀ {w ℓ} {Whatever : Set w} → ⊥ {ℓ} → Whatever
⊥-elim ()


-- Andreas, 2016-02-02 postpone type checking of extended lambda
-- See also issue 480 and 1159

open import Common.Maybe
open import Common.String

record ⊤ : Set where

record IOInterface : Set₁ where
  field  Command   :  Set
         Response  :  (m : Command) → Set
open IOInterface

data IO I A : Set where
  do'      :  (c : Command I) (f : Response I c → IO I A)  → IO I A
  return   :  (a : A)                                      → IO I A

-- Alias of constructor which is a function
do :  ∀{I A} (c : Command I) (f : Response I c → IO I A) → IO I A
do c f    =  do' c f

data C : Set where
  getLine   :  C
  putStrLn  :  String → C

R : C → Set
R  getLine      =  Maybe String
R (putStrLn s)  =  ⊤

I : IOInterface
Command   I  =  C
Response  I  =  R

works : IO I ⊤
works = do'  getLine        λ{ nothing → return _ ; (just line) →
        do (putStrLn line)  λ _ →
        return _            }

test : IO I ⊤
test = do  getLine         λ{ nothing → return _ ; (just line) →
       do (putStrLn line)  λ _ →
       return _            }