------------------------------------------------------------------------
-- A variant of the propositional truncation operator with an erased
-- truncation constructor
------------------------------------------------------------------------

-- Partly following the HoTT book, but adapted for erasure.

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

-- The module is parametrised by a notion of equality. The higher
-- constructor of the HIT defining the propositional truncation
-- operator uses path equality, but the supplied notion of equality is
-- used for many other things.

import Equality.Path as P

module H-level.Truncation.Propositional.Erased
  {e⁺} (eq : ∀ {a p} → P.Equality-with-paths a p e⁺) where

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

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

open import Bijection equality-with-J as Bijection using (_↔_)
import Colimit.Sequential.Very-erased eq as C
open import Embedding equality-with-J as Emb using (Is-embedding)
open import Equality.Decidable-UIP equality-with-J
open import Equality.Path.Isomorphisms eq
open import Equivalence equality-with-J as Eq
  using (_≃_; Is-equivalence)
open import Equivalence.Erased equality-with-J as EEq
  using (_≃ᴱ_; Is-equivalenceᴱ)
open import Equivalence.Erased.Contractible-preimages equality-with-J
  as ECP using (Contractibleᴱ; _⁻¹ᴱ_)
open import Equivalence-relation equality-with-J
open import Erased.Cubical eq as Er
  using (Erased; [_]; erased; Very-stableᴱ-≡; Erased-singleton)
open import Function-universe equality-with-J as F hiding (id; _∘_)
open import H-level equality-with-J as H-level
open import H-level.Closure equality-with-J
open import H-level.Truncation.Propositional.One-step eq as O
  using (∥_∥¹-out-^)
import H-level.Truncation.Propositional.Non-recursive.Erased eq as N
open import Monad equality-with-J
open import Preimage equality-with-J using (_⁻¹_)
open import Surjection equality-with-J as S
  using (_↠_; Split-surjective)

private
  variable
    a b ℓ p r         : Level
    A A₁ A₂ B B₁ B₂ C : Type a
    P Q               : A → Type p
    R                 : A → A → Type r
    f g k x y         : A

------------------------------------------------------------------------
-- The type former

-- A propositional truncation operator with an erased higher
-- constructor.

data ∥_∥ᴱ (A : Type a) : Type a where
  ∣_∣                           : A → ∥ A ∥ᴱ
  @0 truncation-is-propositionᴾ : P.Is-proposition ∥ A ∥ᴱ

-- The truncation produces propositions (in erased contexts).

@0 truncation-is-proposition : Is-proposition ∥ A ∥ᴱ
truncation-is-proposition =
  _↔_.from (H-level↔H-level 1) truncation-is-propositionᴾ

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

-- A dependent eliminator, expressed using paths.

record Elimᴾ′ {A : Type a} (P : ∥ A ∥ᴱ → Type p) : Type (a ⊔ p) where
  no-eta-equality
  field
    ∣∣ʳ : (x : A) → P ∣ x ∣

    @0 truncation-is-propositionʳ :
      (p : P x) (q : P y) →
      P.[ (λ i → P (truncation-is-propositionᴾ x y i)) ] p ≡ q

open Elimᴾ′ public

elimᴾ′ : Elimᴾ′ P → (x : ∥ A ∥ᴱ) → P x
elimᴾ′ {A = A} {P = P} e = helper
  where
  module E = Elimᴾ′ e

  helper : (x : ∥ A ∥ᴱ) → P x
  helper ∣ x ∣                              = E.∣∣ʳ x
  helper (truncation-is-propositionᴾ x y i) =
    E.truncation-is-propositionʳ (helper x) (helper y) i

-- A possibly more useful dependent eliminator, expressed using paths.

record Elimᴾ {A : Type a} (P : ∥ A ∥ᴱ → Type p) : Type (a ⊔ p) where
  no-eta-equality
  field
    ∣∣ʳ : (x : A) → P ∣ x ∣

    @0 truncation-is-propositionʳ :
      (x : ∥ A ∥ᴱ) → P.Is-proposition (P x)

open Elimᴾ public

elimᴾ : Elimᴾ P → (x : ∥ A ∥ᴱ) → P x
elimᴾ e = elimᴾ′ λ where
    .∣∣ʳ                            → E.∣∣ʳ
    .truncation-is-propositionʳ _ _ →
      P.heterogeneous-irrelevance E.truncation-is-propositionʳ
  where
  module E = Elimᴾ e

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

record Recᴾ (A : Type a) (B : Type b) : Type (a ⊔ b) where
  no-eta-equality
  field
    ∣∣ʳ                           : A → B
    @0 truncation-is-propositionʳ : P.Is-proposition B

open Recᴾ public

recᴾ : Recᴾ A B → ∥ A ∥ᴱ → B
recᴾ r = elimᴾ λ where
    .∣∣ʳ                          → R.∣∣ʳ
    .truncation-is-propositionʳ _ → R.truncation-is-propositionʳ
  where
  module R = Recᴾ r

-- A dependently typed eliminator.

record Elim {A : Type a} (P : ∥ A ∥ᴱ → Type p) : Type (a ⊔ p) where
  no-eta-equality
  field
    ∣∣ʳ : (x : A) → P ∣ x ∣

    @0 truncation-is-propositionʳ :
      (x : ∥ A ∥ᴱ) → Is-proposition (P x)

open Elim public

elim : Elim P → (x : ∥ A ∥ᴱ) → P x
elim e = elimᴾ λ where
    .∣∣ʳ                        → E.∣∣ʳ
    .truncation-is-propositionʳ →
      _↔_.to (H-level↔H-level 1) ∘ E.truncation-is-propositionʳ
  where
  module E = Elim e

-- Primitive "recursion".

record Rec (A : Type a) (B : Type b) : Type (a ⊔ b) where
  no-eta-equality
  field
    ∣∣ʳ                           : A → B
    @0 truncation-is-propositionʳ : Is-proposition B

open Rec public

rec : Rec A B → ∥ A ∥ᴱ → B
rec r = recᴾ λ where
    .∣∣ʳ                        → R.∣∣ʳ
    .truncation-is-propositionʳ →
      _↔_.to (H-level↔H-level 1) R.truncation-is-propositionʳ
  where
  module R = Rec r

------------------------------------------------------------------------
-- Conversion functions

-- ∥_∥ᴱ is pointwise equivalent to N.∥_∥ᴱ.

∥∥ᴱ≃∥∥ᴱ : ∥ A ∥ᴱ ≃ N.∥ A ∥ᴱ
∥∥ᴱ≃∥∥ᴱ = Eq.↔→≃
  (rec λ where
     .∣∣ʳ                        → N.∣_∣
     .truncation-is-propositionʳ → N.∥∥ᴱ-proposition)
  (N.elim λ where
     .N.∣∣ʳ               → ∣_∣
     .N.is-propositionʳ _ → truncation-is-proposition)
  (N.elim λ where
     .N.∣∣ʳ _             → refl _
     .N.is-propositionʳ _ → mono₁ 1 N.∥∥ᴱ-proposition)
  (elim λ where
     .∣∣ʳ _                        → refl _
     .truncation-is-propositionʳ _ → mono₁ 1 truncation-is-proposition)

------------------------------------------------------------------------
-- Some preservation lemmas and related results

-- A map function.

∥∥ᴱ-map : (A → B) → ∥ A ∥ᴱ → ∥ B ∥ᴱ
∥∥ᴱ-map f = rec λ where
  .∣∣ʳ                        → ∣_∣ ∘ f
  .truncation-is-propositionʳ → truncation-is-proposition

mutual

  -- If A and B are logically equivalent, then there is an equivalence
  -- with erased proofs between ∥ A ∥ᴱ and ∥ B ∥ᴱ.

  ∥∥ᴱ-cong-⇔ : A ⇔ B → ∥ A ∥ᴱ ≃ᴱ ∥ B ∥ᴱ
  ∥∥ᴱ-cong-⇔ A⇔B = ∥∥ᴱ-cong-⇔′ (∣_∣ ∘ _⇔_.to A⇔B) (∣_∣ ∘ _⇔_.from A⇔B)

  -- A variant of the previous result.

  ∥∥ᴱ-cong-⇔′ : (A → ∥ B ∥ᴱ) → (B → ∥ A ∥ᴱ) → ∥ A ∥ᴱ ≃ᴱ ∥ B ∥ᴱ
  ∥∥ᴱ-cong-⇔′ A→∥B∥ B→∥A∥ = EEq.⇔→≃ᴱ
    truncation-is-proposition
    truncation-is-proposition
    (rec λ where
       .∣∣ʳ                        → A→∥B∥
       .truncation-is-propositionʳ → truncation-is-proposition)
    (rec λ where
       .∣∣ʳ                        → B→∥A∥
       .truncation-is-propositionʳ → truncation-is-proposition)

-- If there is a split surjection from A to B, then there is a split
-- surjection from ∥ A ∥ᴱ to ∥ B ∥ᴱ.

∥∥ᴱ-cong-↠ : A ↠ B → ∥ A ∥ᴱ ↠ ∥ B ∥ᴱ
∥∥ᴱ-cong-↠ A↠B = record
  { logical-equivalence = record
    { to   = ∥∥ᴱ-map (_↠_.to   A↠B)
    ; from = ∥∥ᴱ-map (_↠_.from A↠B)
    }
  ; right-inverse-of = elim λ where
      .∣∣ʳ x →
        ∣ _↠_.to A↠B (_↠_.from A↠B x) ∣  ≡⟨ cong ∣_∣ (_↠_.right-inverse-of A↠B x) ⟩∎
        ∣ x ∣                            ∎
      .truncation-is-propositionʳ _ →
        mono₁ 1 truncation-is-proposition
  }

private

  ∥∥ᴱ-cong-↔ : A ↔ B → ∥ A ∥ᴱ ↔ ∥ B ∥ᴱ
  ∥∥ᴱ-cong-↔ A↔B = record
    { surjection      = ∥∥ᴱ-cong-↠ (_↔_.surjection A↔B)
    ; left-inverse-of = elim λ where
        .∣∣ʳ x →
          ∣ _↔_.from A↔B (_↔_.to A↔B x) ∣  ≡⟨ cong ∣_∣ (_↔_.left-inverse-of A↔B x) ⟩∎
          ∣ x ∣                            ∎
        .truncation-is-propositionʳ _ →
          mono₁ 1 truncation-is-proposition
    }

-- The truncation operator preserves "symmetric" functions.

∥∥ᴱ-cong : A ↝[ ⌊ k ⌋-sym ] B → ∥ A ∥ᴱ ↝[ ⌊ k ⌋-sym ] ∥ B ∥ᴱ
∥∥ᴱ-cong {k = logical-equivalence} = _≃ᴱ_.logical-equivalence ∘
                                     ∥∥ᴱ-cong-⇔
∥∥ᴱ-cong {k = bijection}           = ∥∥ᴱ-cong-↔
∥∥ᴱ-cong {k = equivalence}         = from-isomorphism ∘ ∥∥ᴱ-cong-↔ ∘
                                     from-isomorphism
∥∥ᴱ-cong {k = equivalenceᴱ}        = ∥∥ᴱ-cong-⇔ ∘
                                     _≃ᴱ_.logical-equivalence

------------------------------------------------------------------------
-- Some bijections/erased equivalences

-- If the underlying type is a proposition, then truncations of the
-- type are isomorphic to the type itself.

∥∥ᴱ↔ : @0 Is-proposition A → ∥ A ∥ᴱ ↔ A
∥∥ᴱ↔ A-prop = record
  { surjection = record
    { logical-equivalence = record
      { to   = rec λ where
          .∣∣ʳ                        → id
          .truncation-is-propositionʳ → A-prop
      ; from = ∣_∣
      }
    ; right-inverse-of = λ _ → refl _
    }
  ; left-inverse-of = elim λ where
      .∣∣ʳ _                        → refl _
      .truncation-is-propositionʳ _ → mono₁ 1 truncation-is-proposition
  }

-- If A is merely inhabited, then the truncation of A is equivalent
-- (with erased proofs) to the unit type.

inhabited⇒∥∥ᴱ≃ᴱ⊤ : ∥ A ∥ᴱ → ∥ A ∥ᴱ ≃ᴱ ⊤
inhabited⇒∥∥ᴱ≃ᴱ⊤ ∥a∥ =
  EEq.inhabited→Is-proposition→≃ᴱ⊤ ∥a∥ truncation-is-proposition

-- If A is not inhabited, then the propositional truncation of A is
-- isomorphic to the empty type.

not-inhabited⇒∥∥ᴱ↔⊥ : ¬ A → ∥ A ∥ᴱ ↔ ⊥ {ℓ = ℓ}
not-inhabited⇒∥∥ᴱ↔⊥ {A = A} =
  ¬ A         ↝⟨ (λ ¬a → rec λ where
                           .∣∣ʳ                        → ¬a
                           .truncation-is-propositionʳ → ⊥-propositional) ⟩
  ¬ ∥ A ∥ᴱ    ↝⟨ inverse ∘ Bijection.⊥↔uninhabited ⟩□
  ∥ A ∥ᴱ ↔ ⊥  □

-- The negation of the truncation of A is isomorphic to the negation
-- of A.

¬∥∥ᴱ↔¬ : ¬ ∥ A ∥ᴱ ↔ ¬ A
¬∥∥ᴱ↔¬ {A = A} = record
  { surjection = record
    { logical-equivalence = record
      { to   = λ f → f ∘ ∣_∣
      ; from = λ ¬A → rec λ where
                        .∣∣ʳ                        → ¬A
                        .truncation-is-propositionʳ → ⊥-propositional
      }
    ; right-inverse-of = λ _ → ¬-propositional ext _ _
    }
  ; left-inverse-of = λ _ → ¬-propositional ext _ _
  }

-- A form of idempotence for binary sums.

idempotent : ∥ A ⊎ A ∥ᴱ ≃ᴱ ∥ A ∥ᴱ
idempotent = ∥∥ᴱ-cong-⇔ (record { to = P.[ id , id ]; from = inj₁ })

------------------------------------------------------------------------
-- The universal property, and some related results

mutual

  -- The propositional truncation operator's universal property.
  --
  -- See also Quotient.Erased.Σ→Erased-Constant≃∥∥ᴱ→.

  universal-property :
    @0 Is-proposition B →
    (∥ A ∥ᴱ → B) ≃ (A → B)
  universal-property B-prop = universal-property-Π (λ _ → B-prop)

  -- A generalisation of the universal property.

  universal-property-Π :
    @0 (∀ x → Is-proposition (P x)) →
    ((x : ∥ A ∥ᴱ) → P x) ≃ ((x : A) → P ∣ x ∣)
  universal-property-Π {A = A} {P = P} P-prop =
    ((x : ∥ A ∥ᴱ) → P x)      ↝⟨ Eq.↔⇒≃ (record
                                   { surjection = record
                                     { logical-equivalence = record
                                       { to   = λ f → ∣ f ∘ ∣_∣ ∣
                                       ; from = rec λ where
                                           .∣∣ʳ f → elim λ where
                                             .∣∣ʳ                        → f
                                             .truncation-is-propositionʳ → P-prop
                                           .truncation-is-propositionʳ →
                                             Π-closure ext 1 λ _ → P-prop _
                                       }
                                     ; right-inverse-of = elim λ where
                                         .∣∣ʳ _                        → refl _
                                         .truncation-is-propositionʳ _ →
                                           mono₁ 1 truncation-is-proposition
                                     }
                                   ; left-inverse-of = λ f → ⟨ext⟩ $ elim λ where
                                       .∣∣ʳ _                        → refl _
                                       .truncation-is-propositionʳ _ →
                                         mono₁ 1 (P-prop _)
                                   }) ⟩
    ∥ ((x : A) → P ∣ x ∣) ∥ᴱ  ↔⟨ ∥∥ᴱ↔ (Π-closure ext 1 λ _ → P-prop _) ⟩□
    ((x : A) → P ∣ x ∣)       □

-- The universal property computes in the "right" way.

_ :
  (@0 B-prop : Is-proposition B)
  (f : ∥ A ∥ᴱ → B) →
  _≃_.to (universal-property B-prop) f ≡ f ∘ ∣_∣
_ = λ _ _ → refl _

_ :
  (@0 B-prop : Is-proposition B)
  (f : A → B) (x : A) →
  _≃_.from (universal-property B-prop) f ∣ x ∣ ≡ f x
_ = λ _ _ _ → refl _

-- Functions from ∥ A ∥ᴱ can be expressed as functions from A along
-- with some erased data.

∥∥ᴱ→≃ :
  (∥ A ∥ᴱ → B)
    ≃
  (∃ λ (f : A → B) →
     Erased (∃ λ (g : ∀ n → ∥ A ∥¹-out-^ (suc n) → B) →
               (∀ x → g zero O.∣ x ∣ ≡ f x) ×
               (∀ n x → g (suc n) O.∣ x ∣ ≡ g n x)))
∥∥ᴱ→≃ {A = A} {B = B} =
  (∥ A ∥ᴱ → B)                                           ↝⟨ →-cong ext ∥∥ᴱ≃∥∥ᴱ F.id ⟩

  (N.∥ A ∥ᴱ → B)                                         ↝⟨ C.universal-property ⟩□

  (∃ λ (f : A → B) →
     Erased (∃ λ (g : ∀ n → ∥ A ∥¹-out-^ (suc n) → B) →
               (∀ x → g zero O.∣ x ∣ ≡ f x) ×
               (∀ n x → g (suc n) O.∣ x ∣ ≡ g n x)))     □

-- A function of type (x : ∥ A ∥ᴱ) → P x, along with an erased proof
-- showing that the function is equal to some erased function, is
-- equivalent to a function of type (x : A) → P ∣ x ∣, along with an
-- erased equality proof.

Σ-Π-∥∥ᴱ-Erased-≡-≃ :
  {@0 g : (x : ∥ A ∥ᴱ) → P x} →
  (∃ λ (f : (x : ∥ A ∥ᴱ) → P x) → Erased (f ≡ g)) ≃
  (∃ λ (f : (x : A) → P ∣ x ∣) → Erased (f ≡ g ∘ ∣_∣))
Σ-Π-∥∥ᴱ-Erased-≡-≃ {A = A} {P = P} {g = g} =
  (∃ λ (f : (x : ∥ A ∥ᴱ) → P x) → Erased (f ≡ g))       ↝⟨ (Σ-cong lemma λ _ → Er.Erased-cong (inverse $ Eq.≃-≡ lemma)) ⟩

  (∃ λ (f : (x : N.∥ A ∥ᴱ) → P (_≃_.from ∥∥ᴱ≃∥∥ᴱ x)) →
     Erased (f ≡ g ∘ _≃_.from ∥∥ᴱ≃∥∥ᴱ))                 ↝⟨ N.Σ-Π-∥∥ᴱ-Erased-≡-≃ ⟩□

  (∃ λ (f : (x : A) → P ∣ x ∣) → Erased (f ≡ g ∘ ∣_∣))  □
  where
  lemma = Π-cong-contra ext (inverse ∥∥ᴱ≃∥∥ᴱ) λ _ → Eq.id

------------------------------------------------------------------------
-- Some results based on "Generalizations of Hedberg's Theorem" by
-- Kraus, Escardó, Coquand and Altenkirch

-- Types with constant endofunctions are "h-stable" (meaning that
-- "mere inhabitance" implies inhabitance).

constant-endofunction⇒h-stable :
  {f : A → A} → @0 Constant f → ∥ A ∥ᴱ → A
constant-endofunction⇒h-stable {A = A} {f = f} c =
  ∥ A ∥ᴱ                            ↝⟨ (rec λ where
                                          .∣∣ʳ x → f x , [ c (f x) x ]
                                          .truncation-is-propositionʳ → prop) ⟩
  (∃ λ (x : A) → Erased (f x ≡ x))  ↝⟨ proj₁ ⟩□
  A                                 □
  where
  @0 prop : _
  prop =                                       $⟨ fixpoint-lemma f c ⟩
    Is-proposition (∃ λ x → f x ≡ x)           ↝⟨ H-level-cong _ 1 (∃-cong λ _ → inverse $ Er.erased Er.Erased↔) ⦂ (_ → _) ⟩□
    Is-proposition (∃ λ x → Erased (f x ≡ x))  □

-- Having a constant endofunction is logically equivalent to being
-- h-stable.

constant-endofunction⇔h-stable :
  (∃ λ (f : A → A) → Erased (Constant f)) ⇔ (∥ A ∥ᴱ → A)
constant-endofunction⇔h-stable = record
  { to   = λ (_ , [ c ]) → constant-endofunction⇒h-stable c
  ; from = λ f → f ∘ ∣_∣
         , [ (λ x y →
                f ∣ x ∣  ≡⟨ cong f $ truncation-is-proposition _ _ ⟩∎
                f ∣ y ∣  ∎)
           ]
  }

------------------------------------------------------------------------
-- Some results related to _×_

-- The cartesian product of the truncation of A and A is equivalent
-- (with erased "proofs") to A.

∥∥ᴱ×≃ᴱ : (∥ A ∥ᴱ × A) ≃ᴱ A
∥∥ᴱ×≃ᴱ = EEq.↔→≃ᴱ
  proj₂
  (λ x → ∣ x ∣ , x)
  refl
  (λ _ → cong (_, _) (truncation-is-proposition _ _))

-- The application _≃ᴱ_.right-inverse-of ∥∥ᴱ×≃ᴱ x computes in a
-- certain way.

_ : _≃ᴱ_.right-inverse-of ∥∥ᴱ×≃ᴱ x ≡ refl _
_ = refl _

-- ∥_∥ᴱ commutes with _×_.

∥∥ᴱ×∥∥ᴱ↔∥×∥ᴱ : (∥ A ∥ᴱ × ∥ B ∥ᴱ) ↔ ∥ A × B ∥ᴱ
∥∥ᴱ×∥∥ᴱ↔∥×∥ᴱ = record
  { surjection = record
    { logical-equivalence = record
      { from = λ p → ∥∥ᴱ-map proj₁ p , ∥∥ᴱ-map proj₂ p
      ; to   = uncurry $ rec λ where
                 .∣∣ʳ x → rec λ where
                   .∣∣ʳ y                      → ∣ x , y ∣
                   .truncation-is-propositionʳ →
                     truncation-is-proposition
                 .truncation-is-propositionʳ →
                   Π-closure ext 1 λ _ →
                   truncation-is-proposition
      }
    ; right-inverse-of = elim λ where
        .∣∣ʳ _                        → refl _
        .truncation-is-propositionʳ _ →
          mono₁ 1 truncation-is-proposition
    }
  ; left-inverse-of = uncurry $ elim λ where
      .∣∣ʳ _ → elim λ where
        .∣∣ʳ _ → refl _
        .truncation-is-propositionʳ _ →
          mono₁ 1 $
          ×-closure 1 truncation-is-proposition
                      truncation-is-proposition
      .truncation-is-propositionʳ _ →
        Π-closure ext 1 λ _ →
        mono₁ 1 $
        ×-closure 1 truncation-is-proposition
                    truncation-is-proposition
  }

------------------------------------------------------------------------
-- Some results related to h-levels

-- Variants of proj₁-closure.

private

  H-level-×₁-lemma :
    (A → ∥ B ∥ᴱ) →
    ∀ n → H-level (suc n) (A × B) → H-level (suc n) A
  H-level-×₁-lemma inhabited n h =
    [inhabited⇒+]⇒+ n λ a →
    flip rec (inhabited a) λ where
      .∣∣ʳ b →
        proj₁-closure (λ _ → b) (suc n) h
      .truncation-is-propositionʳ →
        H-level-propositional ext (suc n)

H-level-×₁ :
  (A → ∥ B ∥ᴱ) →
  ∀ n → H-level n (A × B) → H-level n A
H-level-×₁ inhabited zero h =
  propositional⇒inhabited⇒contractible
    (H-level-×₁-lemma inhabited 0 (mono₁ 0 h))
    (proj₁ (proj₁ h))
H-level-×₁ inhabited (suc n) =
  H-level-×₁-lemma inhabited n

H-level-×₂ :
  (B → ∥ A ∥ᴱ) →
  ∀ n → H-level n (A × B) → H-level n B
H-level-×₂ {B = B} {A = A} inhabited n =
  H-level n (A × B)  ↝⟨ H-level.respects-surjection (from-bijection ×-comm) n ⟩
  H-level n (B × A)  ↝⟨ H-level-×₁ inhabited n ⟩□
  H-level n B        □

------------------------------------------------------------------------
-- Flattening

-- A generalised flattening lemma.

flatten′ :
  (F : (Type ℓ → Type ℓ) → Type f)
  (map : ∀ {G H} → (∀ {A} → G A → H A) → F G → F H)
  (f : F ∥_∥ᴱ → ∥ F id ∥ᴱ) →
  (∀ x → f (map ∣_∣ x) ≡ ∣ x ∣) →
  (∀ x → ∥∥ᴱ-map (map ∣_∣) (f x) ≡ ∣ x ∣) →
  ∥ F ∥_∥ᴱ ∥ᴱ ↔ ∥ F id ∥ᴱ
flatten′ _ map f f-map map-f = record
  { surjection = record
    { logical-equivalence = record
      { to   = rec λ where
                 .∣∣ʳ                        → f
                 .truncation-is-propositionʳ → truncation-is-proposition
      ; from = ∥∥ᴱ-map (map ∣_∣)
      }
    ; right-inverse-of = elim λ where
        .∣∣ʳ                          → f-map
        .truncation-is-propositionʳ _ →
          mono₁ 1 truncation-is-proposition
    }
  ; left-inverse-of = elim λ where
      .∣∣ʳ                          → map-f
      .truncation-is-propositionʳ _ →
        mono₁ 1 truncation-is-proposition
  }

-- Nested truncations can be flattened.

flatten : ∥ ∥ A ∥ᴱ ∥ᴱ ↔ ∥ A ∥ᴱ
flatten {A = A} = flatten′
  (λ F → F A)
  (λ f → f)
  id
  (λ _ → refl _)
  (elim λ where
     .∣∣ʳ _                        → refl _
     .truncation-is-propositionʳ _ → mono₁ 1 truncation-is-proposition)

private

  -- Another flattening lemma, given as an example of how flatten′ can
  -- be used.

  ∥∃∥∥ᴱ∥ᴱ↔∥∃∥ᴱ : ∥ ∃ (∥_∥ᴱ ∘ P) ∥ᴱ ↔ ∥ ∃ P ∥ᴱ
  ∥∃∥∥ᴱ∥ᴱ↔∥∃∥ᴱ {P = P} = flatten′
    (λ F → ∃ (F ∘ P))
    (λ f → Σ-map id f)
    (uncurry λ x → ∥∥ᴱ-map (x ,_))
    (λ _ → refl _)
    (uncurry λ _ → elim λ where
       .∣∣ʳ _ → refl _
       .truncation-is-propositionʳ _ →
         mono₁ 1 truncation-is-proposition)

-- A variant of flatten′ with _≃ᴱ_ instead of _↔_.

flatten-≃ᴱ :
  (F : (Type ℓ → Type ℓ) → Type f)
  (map : ∀ {G H} → (∀ {A} → G A → H A) → F G → F H)
  (f : F ∥_∥ᴱ → ∥ F id ∥ᴱ) →
  @0 (∀ x → f (map ∣_∣ x) ≡ ∣ x ∣) →
  @0 (∀ x → ∥∥ᴱ-map (map ∣_∣) (f x) ≡ ∣ x ∣) →
  ∥ F ∥_∥ᴱ ∥ᴱ ≃ᴱ ∥ F id ∥ᴱ
flatten-≃ᴱ _ map f f-map map-f = EEq.↔→≃ᴱ
  (rec λ where
     .∣∣ʳ                        → f
     .truncation-is-propositionʳ → truncation-is-proposition)
  (∥∥ᴱ-map (map ∣_∣))
  (elim λ @0 where
     .∣∣ʳ                          → f-map
     .truncation-is-propositionʳ _ →
       mono₁ 1 truncation-is-proposition)
  (elim λ @0 where
     .∣∣ʳ                          → map-f
     .truncation-is-propositionʳ _ →
       mono₁ 1 truncation-is-proposition)

------------------------------------------------------------------------
-- The propositional truncation operator is a monad

-- A universe-polymorphic variant of bind.

infixl 5 _>>=′_

_>>=′_ : ∥ A ∥ᴱ → (A → ∥ B ∥ᴱ) → ∥ B ∥ᴱ
x >>=′ f = _↔_.to flatten (∥∥ᴱ-map f x)

-- The universe-polymorphic variant of bind is associative.

>>=′-associative :
  (x : ∥ A ∥ᴱ) →
  x >>=′ (λ x → f x >>=′ g) ≡ x >>=′ f >>=′ g
>>=′-associative = elim λ where
  .∣∣ʳ _                        → refl _
  .truncation-is-propositionʳ _ → ⇒≡ 1 truncation-is-proposition

instance

  -- The propositional truncation operator is a monad.

  raw-monad : Raw-monad (∥_∥ᴱ {a = a})
  Raw-monad.return raw-monad = ∣_∣
  Raw-monad._>>=_  raw-monad = _>>=′_

  monad : Monad (∥_∥ᴱ {a = a})
  Monad.raw-monad monad           = raw-monad
  Monad.left-identity monad _ _   = refl _
  Monad.associativity monad x _ _ = >>=′-associative x
  Monad.right-identity monad      = elim λ where
    .∣∣ʳ                        _ → refl _
    .truncation-is-propositionʳ _ → ⇒≡ 1 truncation-is-proposition

------------------------------------------------------------------------
-- Surjectivity

-- A variant of surjectivity with "erased proofs".

Surjectiveᴱ :
  {A : Type a} {B : Type b} →
  (A → B) → Type (a ⊔ b)
Surjectiveᴱ f = ∀ y → ∥ f ⁻¹ᴱ y ∥ᴱ

-- The property Surjectiveᴱ f is a proposition (in erased contexts).

@0 Surjectiveᴱ-propositional : Is-proposition (Surjectiveᴱ f)
Surjectiveᴱ-propositional =
  Π-closure ext 1 λ _ →
  truncation-is-proposition

-- The function ∣_∣ is surjective (with erased proofs).

∣∣-surjective : Surjectiveᴱ (∣_∣ {A = A})
∣∣-surjective = elim λ where
  .∣∣ʳ x                        → ∣ x , [ refl _ ] ∣
  .truncation-is-propositionʳ _ → truncation-is-proposition

-- Split surjective functions are surjective (with erased proofs).

Split-surjective→Surjectiveᴱ :
  Split-surjective f → Surjectiveᴱ f
Split-surjective→Surjectiveᴱ s = λ y → ∣ ECP.⁻¹→⁻¹ᴱ (s y) ∣

-- Being both surjective (with erased proofs) and an embedding
-- (completely erased) is equivalent to being an equivalence (with
-- erased proofs).
--
-- This result, without erasure, is Corollary 4.6.4 from the first
-- edition of the HoTT book.

Surjectiveᴱ×Erased-Is-embedding≃ᴱIs-equivalenceᴱ :
  (Surjectiveᴱ f × Erased (Is-embedding f)) ≃ᴱ Is-equivalenceᴱ f
Surjectiveᴱ×Erased-Is-embedding≃ᴱIs-equivalenceᴱ {f = f} = EEq.⇔→≃ᴱ
  (×-closure 1
     Surjectiveᴱ-propositional
     (Er.H-level-Erased 1
        (Emb.Is-embedding-propositional ext)))
  (EEq.Is-equivalenceᴱ-propositional ext f)
  (λ (is-surj , is-emb) →
     _⇔_.from EEq.Is-equivalenceᴱ⇔Is-equivalenceᴱ-CP $ λ y →
                              $⟨ is-surj y ⟩
     ∥ f ⁻¹ᴱ y ∥ᴱ             ↝⟨ (rec λ where
                                    .∣∣ʳ p → ECP.inhabited→Is-proposition→Contractibleᴱ p
                                               (H-level-cong _ 1
                                                  ECP.⁻¹≃⁻¹ᴱ
                                                  (Emb.embedding→⁻¹-propositional (Er.erased is-emb) _))
                                    .truncation-is-propositionʳ →
                                      ECP.Contractibleᴱ-propositional ext) ⟩□
     Contractibleᴱ (f ⁻¹ᴱ y)  □)
  (λ is-eq@(inv , [ r-inv , _ ]) →
       (λ y →           $⟨ inv y , [ r-inv y ] ⟩
          f ⁻¹ᴱ y       ↝⟨ ∣_∣ ⟩
          ∥ f ⁻¹ᴱ y ∥ᴱ  □)

     ,                            ($⟨ is-eq ⟩
       Is-equivalenceᴱ f           ↝⟨ Er.[_]→ ⟩
       Erased (Is-equivalenceᴱ f)  ↝⟨ Er.map EEq.Is-equivalenceᴱ→Is-equivalence ⟩
       Erased (Is-equivalence f)   ↝⟨ Er.map Emb.Is-equivalence→Is-embedding ⟩□
       Erased (Is-embedding f)     □))

------------------------------------------------------------------------
-- Another lemma

-- The function λ R x y → ∥ R x y ∥ᴱ preserves Is-equivalence-relation.

∥∥ᴱ-preserves-Is-equivalence-relation :
  Is-equivalence-relation R →
  Is-equivalence-relation (λ x y → ∥ R x y ∥ᴱ)
∥∥ᴱ-preserves-Is-equivalence-relation R-equiv = record
  { reflexive  = ∣ reflexive ∣
  ; symmetric  = symmetric ⟨$⟩_
  ; transitive = λ p q → transitive ⟨$⟩ p ⊛ q
  }
  where
  open Is-equivalence-relation R-equiv

------------------------------------------------------------------------
-- Definitions related to truncated binary sums

-- Truncated binary sums.

infixr 1 _∥⊎∥ᴱ_

_∥⊎∥ᴱ_ : Type a → Type b → Type (a ⊔ b)
A ∥⊎∥ᴱ B = ∥ A ⊎ B ∥ᴱ

-- Introduction rules.

∣inj₁∣ : A → A ∥⊎∥ᴱ B
∣inj₁∣ = ∣_∣ ∘ inj₁

∣inj₂∣ : B → A ∥⊎∥ᴱ B
∣inj₂∣ = ∣_∣ ∘ inj₂

-- In erased contexts _∥⊎∥ᴱ_ is pointwise propositional.

@0 ∥⊎∥ᴱ-propositional : Is-proposition (A ∥⊎∥ᴱ B)
∥⊎∥ᴱ-propositional = truncation-is-proposition

-- The _∥⊎∥ᴱ_ operator preserves "symmetric" functions.

infixr 1 _∥⊎∥ᴱ-cong_

_∥⊎∥ᴱ-cong_ :
  A₁ ↝[ ⌊ k ⌋-sym ] A₂ → B₁ ↝[ ⌊ k ⌋-sym ] B₂ →
  (A₁ ∥⊎∥ᴱ B₁) ↝[ ⌊ k ⌋-sym ] (A₂ ∥⊎∥ᴱ B₂)
A₁↝A₂ ∥⊎∥ᴱ-cong B₁↝B₂ = ∥∥ᴱ-cong (A₁↝A₂ ⊎-cong B₁↝B₂)

-- _∥⊎∥ᴱ_ is commutative.

∥⊎∥ᴱ-comm : A ∥⊎∥ᴱ B ↔ B ∥⊎∥ᴱ A
∥⊎∥ᴱ-comm = ∥∥ᴱ-cong ⊎-comm

-- If one truncates the types to the left or right of _∥⊎∥ᴱ_, then one
-- ends up with an isomorphic type.

truncate-left-∥⊎∥ᴱ : A ∥⊎∥ᴱ B ↔ ∥ A ∥ᴱ ∥⊎∥ᴱ B
truncate-left-∥⊎∥ᴱ =
  inverse $
  flatten′
    (λ F → F _ ⊎ _)
    (λ f → ⊎-map f id)
    P.[ ∥∥ᴱ-map inj₁ , ∣inj₂∣ ]
    P.[ (λ _ → refl _) , (λ _ → refl _) ]
    P.[ (elim λ where
           .∣∣ʳ _ → refl _
           .truncation-is-propositionʳ _ →
             mono₁ 1 ∥⊎∥ᴱ-propositional)
      , (λ _ → refl _)
      ]

truncate-right-∥⊎∥ᴱ : A ∥⊎∥ᴱ B ↔ A ∥⊎∥ᴱ ∥ B ∥ᴱ
truncate-right-∥⊎∥ᴱ {A = A} {B = B} =
  A ∥⊎∥ᴱ B       ↝⟨ ∥⊎∥ᴱ-comm ⟩
  B ∥⊎∥ᴱ A       ↝⟨ truncate-left-∥⊎∥ᴱ ⟩
  ∥ B ∥ᴱ ∥⊎∥ᴱ A  ↝⟨ ∥⊎∥ᴱ-comm ⟩□
  A ∥⊎∥ᴱ ∥ B ∥ᴱ  □

-- _∥⊎∥ᴱ_ is associative.

∥⊎∥ᴱ-assoc : A ∥⊎∥ᴱ (B ∥⊎∥ᴱ C) ↔ (A ∥⊎∥ᴱ B) ∥⊎∥ᴱ C
∥⊎∥ᴱ-assoc {A = A} {B = B} {C = C} =
  ∥ A ⊎ ∥ B ⊎ C ∥ᴱ ∥ᴱ  ↝⟨ inverse truncate-right-∥⊎∥ᴱ ⟩
  ∥ A ⊎ B ⊎ C ∥ᴱ       ↝⟨ ∥∥ᴱ-cong ⊎-assoc ⟩
  ∥ (A ⊎ B) ⊎ C ∥ᴱ     ↝⟨ truncate-left-∥⊎∥ᴱ ⟩□
  ∥ ∥ A ⊎ B ∥ᴱ ⊎ C ∥ᴱ  □

-- ⊥ is a left and right identity of _∥⊎∥ᴱ_ if the other argument is a
-- proposition.

∥⊎∥ᴱ-left-identity : @0 Is-proposition A → ⊥ {ℓ = ℓ} ∥⊎∥ᴱ A ↔ A
∥⊎∥ᴱ-left-identity {A = A} A-prop =
  ∥ ⊥ ⊎ A ∥ᴱ  ↝⟨ ∥∥ᴱ-cong ⊎-left-identity ⟩
  ∥ A ∥ᴱ      ↝⟨ ∥∥ᴱ↔ A-prop ⟩□
  A          □

∥⊎∥ᴱ-right-identity : @0 Is-proposition A → A ∥⊎∥ᴱ ⊥ {ℓ = ℓ} ↔ A
∥⊎∥ᴱ-right-identity {A = A} A-prop =
  A ∥⊎∥ᴱ ⊥  ↔⟨ ∥⊎∥ᴱ-comm ⟩
  ⊥ ∥⊎∥ᴱ A  ↔⟨ ∥⊎∥ᴱ-left-identity A-prop ⟩□
  A         □

-- _∥⊎∥ᴱ_ is idempotent for propositions (up to equivalences with
-- erased proofs).

∥⊎∥ᴱ-idempotent : @0 Is-proposition A → (A ∥⊎∥ᴱ A) ≃ᴱ A
∥⊎∥ᴱ-idempotent {A = A} A-prop =
  ∥ A ⊎ A ∥ᴱ  ↝⟨ idempotent ⟩
  ∥ A ∥ᴱ      ↔⟨ ∥∥ᴱ↔ A-prop ⟩□
  A           □

-- Sometimes a truncated binary sum is equivalent (with erased proofs)
-- to one of its summands.

drop-left-∥⊎∥ᴱ :
  @0 Is-proposition B → (A → B) → (A ∥⊎∥ᴱ B) ≃ᴱ B
drop-left-∥⊎∥ᴱ B-prop A→B = EEq.⇔→≃ᴱ
  ∥⊎∥ᴱ-propositional
  B-prop
  (rec λ where
     .∣∣ʳ → P.[ A→B , id ]
     .truncation-is-propositionʳ → B-prop)
  ∣inj₂∣

drop-right-∥⊎∥ᴱ :
  @0 Is-proposition A → (B → A) → (A ∥⊎∥ᴱ B) ≃ᴱ A
drop-right-∥⊎∥ᴱ {A = A} {B = B} A-prop B→A =
  A ∥⊎∥ᴱ B  ↔⟨ ∥⊎∥ᴱ-comm ⟩
  B ∥⊎∥ᴱ A  ↝⟨ drop-left-∥⊎∥ᴱ A-prop B→A ⟩□
  A        □

-- Sometimes a truncated binary sum is isomorphic to one of its
-- summands.

drop-⊥-right-∥⊎∥ᴱ :
  @0 Is-proposition A → ¬ B → A ∥⊎∥ᴱ B ↔ A
drop-⊥-right-∥⊎∥ᴱ A-prop ¬B = record
  { surjection = record
    { logical-equivalence = record
      { to = rec λ where
          .∣∣ʳ → P.[ id , ⊥-elim ∘ ¬B ]
          .truncation-is-propositionʳ → A-prop
      ; from = ∣inj₁∣
      }
    ; right-inverse-of = refl
    }
  ; left-inverse-of = elim λ where
      .∣∣ʳ → P.[ (λ _ → refl _) , ⊥-elim ∘ ¬B ]
      .truncation-is-propositionʳ _ →
        mono₁ 1 ∥⊎∥ᴱ-propositional
  }

drop-⊥-left-∥⊎∥ᴱ :
  @0 Is-proposition B → ¬ A → A ∥⊎∥ᴱ B ↔ B
drop-⊥-left-∥⊎∥ᴱ B-prop ¬A = record
  { surjection = record
    { logical-equivalence = record
      { to = rec λ where
          .∣∣ʳ → P.[ ⊥-elim ∘ ¬A , id ]
          .truncation-is-propositionʳ → B-prop
      ; from = ∣inj₂∣
      }
    ; right-inverse-of = refl
    }
  ; left-inverse-of = elim λ where
      .∣∣ʳ → P.[ ⊥-elim ∘ ¬A , (λ _ → refl _) ]
      .truncation-is-propositionʳ _ →
        mono₁ 1 ∥⊎∥ᴱ-propositional
  }

-- A type of functions from a truncated binary sum to a family of
-- propositions can be expressed as a binary product of function
-- types.

Π∥⊎∥ᴱ↔Π×Π :
  @0 (∀ x → Is-proposition (P x)) →
  ((x : A ∥⊎∥ᴱ B) → P x)
    ↔
  ((x : A) → P (∣inj₁∣ x)) × ((y : B) → P (∣inj₂∣ y))
Π∥⊎∥ᴱ↔Π×Π {A = A} {B = B} {P = P} P-prop =
  ((x : A ∥⊎∥ᴱ B) → P x)                               ↔⟨ universal-property-Π P-prop ⟩
  ((x : A ⊎ B) → P ∣ x ∣)                              ↝⟨ Π⊎↔Π×Π ext ⟩□
  ((x : A) → P (∣inj₁∣ x)) × ((y : B) → P (∣inj₂∣ y))  □

-- Two distributivity laws for Σ and _∥⊎∥ᴱ_.

Σ-∥⊎∥ᴱ-distrib-left :
  @0 Is-proposition A →
  Σ A (λ x → P x ∥⊎∥ᴱ Q x) ↔ Σ A P ∥⊎∥ᴱ Σ A Q
Σ-∥⊎∥ᴱ-distrib-left {P = P} {Q = Q} A-prop =
  (∃ λ x → ∥ P x ⊎ Q x ∥ᴱ)       ↝⟨ inverse $ ∥∥ᴱ↔ (Σ-closure 1 A-prop λ _ → ∥⊎∥ᴱ-propositional) ⟩
  ∥ (∃ λ x → ∥ P x ⊎ Q x ∥ᴱ) ∥ᴱ  ↝⟨ flatten′
                                      (λ F → (∃ λ x → F (P x ⊎ Q x)))
                                      (λ f → Σ-map id f)
                                      (uncurry λ x → ∥∥ᴱ-map (x ,_))
                                      (λ _ → refl _)
                                      (uncurry λ _ → elim λ where
                                         .∣∣ʳ _ → refl _
                                         .truncation-is-propositionʳ _ →
                                           mono₁ 1 truncation-is-proposition) ⟩
  ∥ (∃ λ x → P x ⊎ Q x) ∥ᴱ       ↝⟨ ∥∥ᴱ-cong ∃-⊎-distrib-left ⟩□
  ∥ ∃ P ⊎ ∃ Q ∥ᴱ                 □

Σ-∥⊎∥ᴱ-distrib-right :
  @0 (∀ x → Is-proposition (P x)) →
  Σ (A ∥⊎∥ᴱ B) P ↔ Σ A (P ∘ ∣inj₁∣) ∥⊎∥ᴱ Σ B (P ∘ ∣inj₂∣)
Σ-∥⊎∥ᴱ-distrib-right {A = A} {B = B} {P = P} P-prop = record
  { surjection = record
    { logical-equivalence = record
      { to = uncurry $ elim λ where
          .∣∣ʳ → curry (∣_∣ ∘ _↔_.to ∃-⊎-distrib-right)
          .truncation-is-propositionʳ _ →
            Π-closure ext 1 λ _ →
            ∥⊎∥ᴱ-propositional
      ; from = rec λ where
          .∣∣ʳ → Σ-map ∣_∣ id ∘ _↔_.from ∃-⊎-distrib-right
          .truncation-is-propositionʳ → prop
      }
    ; right-inverse-of = elim λ where
      .∣∣ʳ → P.[ (λ _ → refl _) , (λ _ → refl _) ]
      .truncation-is-propositionʳ _ →
        mono₁ 1 ∥⊎∥ᴱ-propositional
    }
  ; left-inverse-of = uncurry $ elim λ where
      .∣∣ʳ → P.[ (λ _ _ → refl _) , (λ _ _ → refl _) ]
      .truncation-is-propositionʳ _ →
        Π-closure ext 1 λ _ →
        mono₁ 1 prop
  }
  where
  @0 prop : _
  prop = Σ-closure 1 ∥⊎∥ᴱ-propositional P-prop

-- A variant of one of De Morgan's laws.

¬∥⊎∥ᴱ¬↔¬× :
  Dec (¬ A) → Dec (¬ B) →
  (¬ A ∥⊎∥ᴱ ¬ B) ≃ᴱ (¬ (A × B))
¬∥⊎∥ᴱ¬↔¬× {A = A} {B = B} dec-¬A dec-¬B = EEq.⇔→≃ᴱ
  ∥⊎∥ᴱ-propositional
  (¬-propositional ext)
  (rec λ where
     .∣∣ʳ → ¬⊎¬→×¬
     .truncation-is-propositionʳ → ¬-propositional ext)
  (∣_∣ ∘ _↠_.from (¬⊎¬↠¬× ext dec-¬A dec-¬B))

------------------------------------------------------------------------
-- Code related to Erased-singleton

-- A corollary of erased-singleton-with-erased-center-propositional.

↠→↠Erased-singleton :
  {@0 y : B}
  (A↠B : A ↠ B) →
  ∥ (∃ λ (x : A) → Erased (_↠_.to A↠B x ≡ y)) ∥ᴱ ↠ Erased-singleton y
↠→↠Erased-singleton {A = A} {y = y} A↠B =
  ∥ (∃ λ (x : A) → Erased (_↠_.to A↠B x ≡ y)) ∥ᴱ  ↝⟨ ∥∥ᴱ-cong-↠ (S.Σ-cong A↠B λ _ → F.id) ⟩
  ∥ Erased-singleton y ∥ᴱ                         ↔⟨ ∥∥ᴱ↔
                                                       (Er.erased-singleton-with-erased-center-propositional $
                                                        Er.Very-stable→Very-stableᴱ 1 $
                                                        Er.Very-stable→Very-stable-≡ 0 $
                                                        erased Er.Erased-Very-stable) ⟩□
  Erased-singleton y                              □

-- Another corollary of
-- erased-singleton-with-erased-center-propositional.

↠→≃ᴱErased-singleton :
  {@0 y : B}
  (A↠B : A ↠ B) →
  ∥ (∃ λ (x : A) → Erased (_↠_.to A↠B x ≡ y)) ∥ᴱ ≃ᴱ Erased-singleton y
↠→≃ᴱErased-singleton {A = A} {y = y} A↠B =
  ∥ (∃ λ (x : A) → Erased (_↠_.to A↠B x ≡ y)) ∥ᴱ  ↝⟨ ∥∥ᴱ-cong-⇔ (S.Σ-cong-⇔ A↠B λ _ → F.id) ⟩
  ∥ Erased-singleton y ∥ᴱ                         ↔⟨ ∥∥ᴱ↔
                                                       (Er.erased-singleton-with-erased-center-propositional $
                                                        Er.Very-stable→Very-stableᴱ 1 $
                                                        Er.Very-stable→Very-stable-≡ 0 $
                                                        erased Er.Erased-Very-stable) ⟩□
  Erased-singleton y                              □

-- A corollary of Σ-Erased-Erased-singleton↔ and ↠→≃ᴱErased-singleton.

Σ-Erased-∥-Σ-Erased-≡-∥≃ᴱ :
  (A↠B : A ↠ B) →
  (∃ λ (x : Erased B) →
     ∥ (∃ λ (y : A) → Erased (_↠_.to A↠B y ≡ erased x)) ∥ᴱ) ≃ᴱ
  B
Σ-Erased-∥-Σ-Erased-≡-∥≃ᴱ {A = A} {B = B} A↠B =
  (∃ λ (x : Erased B) →
     ∥ (∃ λ (y : A) → Erased (_↠_.to A↠B y ≡ erased x)) ∥ᴱ)  ↝⟨ (∃-cong λ _ → ↠→≃ᴱErased-singleton A↠B) ⟩

  (∃ λ (x : Erased B) → Erased-singleton (erased x))         ↔⟨ Er.Σ-Erased-Erased-singleton↔ ⟩□

  B                                                          □

-- In an erased context the left-to-right direction of
-- Σ-Erased-∥-Σ-Erased-≡-∥≃ᴱ returns the erased first component.

@0 to-Σ-Erased-∥-Σ-Erased-≡-∥≃ᴱ≡ :
  ∀ (A↠B : A ↠ B) x →
  _≃ᴱ_.to (Σ-Erased-∥-Σ-Erased-≡-∥≃ᴱ A↠B) x ≡ erased (proj₁ x)
to-Σ-Erased-∥-Σ-Erased-≡-∥≃ᴱ≡ A↠B ([ x ] , y) =
  _≃ᴱ_.to (Σ-Erased-∥-Σ-Erased-≡-∥≃ᴱ A↠B) ([ x ] , y)  ≡⟨⟩
  proj₁ (_≃ᴱ_.to (↠→≃ᴱErased-singleton A↠B) y)         ≡⟨ erased (proj₂ (_≃ᴱ_.to (↠→≃ᴱErased-singleton A↠B) y)) ⟩∎
  x                                                    ∎


module Issue293b where

module M₁ (_ : Set₁) where

  postulate P : Set

module M₂ (_ : Set) where

  open M₁ Set

  p : P
  p = {!!}

  -- Previous agda2-goal-and-context:

  -- ------------------------
  -- Goal: M₁.P Set

  -- Current agda2-goal-and-context:

  -- ------------------------
  -- Goal: P


{-# OPTIONS --prop --rewriting --confluence-check #-}

open import Agda.Primitive
open import Agda.Builtin.Equality
open import Agda.Builtin.Nat renaming (Nat to ℕ; _+_ to _+ℕ_)

infix 4 _≐_
data _≐_ {ℓ} {A : Set ℓ} (x : A) : A → Prop ℓ where
  refl : x ≐ x

{-# BUILTIN REWRITE _≐_ #-}

variable
  ℓ : Level
  A B C : Set ℓ
  x y z : A

cong : (f : A → B) → x ≐ y → f x ≐ f y
cong f refl = refl

data ℤ : Set where
  zero : ℤ
  pred suc : ℤ → ℤ

postulate
  pred-suc : (x : ℤ) → pred (suc x) ≐ x
  suc-pred : (x : ℤ) → suc (pred x) ≐ x

{-# REWRITE pred-suc suc-pred #-}

count-suc : ℤ → ℕ
count-suc zero = 0
count-suc (pred x) = count-suc x
count-suc (suc x) = 1 +ℕ count-suc x


------------------------------------------------------------------------
-- The Agda standard library
--
-- Pointwise lifting of relations to vectors
------------------------------------------------------------------------

module Relation.Binary.Vec.Pointwise where

open import Category.Applicative.Indexed
open import Data.Fin
open import Data.Nat
open import Data.Plus as Plus hiding (equivalent; map)
open import Data.Vec as Vec hiding ([_]; head; tail; map)
import Data.Vec.Properties as VecProp
open import Function
open import Function.Equality using (_⟨$⟩_)
open import Function.Equivalence as Equiv
  using (_⇔_; ⇔-setoid; module Equivalence)
import Level
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as P using (_≡_)
open import Relation.Nullary
import Relation.Nullary.Decidable as Dec

-- Functional definition.

record Pointwise {ℓ} {A B : Set ℓ} (_∼_ : REL A B ℓ)
                 {n} (xs : Vec A n) (ys : Vec B n) : Set ℓ where
  constructor ext
  field app : ∀ i → lookup i xs ∼ lookup i ys

-- Inductive definition.

infixr 5 _∷_

data Pointwise′ {ℓ} {A B : Set ℓ} (_∼_ : REL A B ℓ) :
                ∀ {n} (xs : Vec A n) (ys : Vec B n) → Set ℓ where
  []  : Pointwise′ _∼_ [] []
  _∷_ : ∀ {n x y} {xs : Vec A n} {ys : Vec B n}
        (x∼y : x ∼ y) (xs∼ys : Pointwise′ _∼_ xs ys) →
        Pointwise′ _∼_ (x ∷ xs) (y ∷ ys)

-- The two definitions are equivalent.

equivalent : ∀ {ℓ} {A B : Set ℓ} {_∼_ : REL A B ℓ} {n}
               {xs : Vec A n} {ys : Vec B n} →
             Pointwise _∼_ xs ys ⇔ Pointwise′ _∼_ xs ys
equivalent {A = A} {B} {_∼_} = Equiv.equivalence (to _ _) from
  where
  to : ∀ {n} (xs : Vec A n) (ys : Vec B n) →
       Pointwise _∼_ xs ys → Pointwise′ _∼_ xs ys
  to []       []       xs∼ys = []
  to (x ∷ xs) (y ∷ ys) xs∼ys =
    Pointwise.app xs∼ys zero ∷
    to xs ys (ext (Pointwise.app xs∼ys ∘ suc))

  nil : Pointwise _∼_ [] []
  nil = ext λ()

  cons : ∀ {n x y} {xs : Vec A n} {ys : Vec B n} →
         x ∼ y → Pointwise _∼_ xs ys → Pointwise _∼_ (x ∷ xs) (y ∷ ys)
  cons {x = x} {y} {xs} {ys} x∼y xs∼ys = ext helper
    where
    helper : ∀ i → lookup i (x ∷ xs) ∼ lookup i (y ∷ ys)
    helper zero    = x∼y
    helper (suc i) = Pointwise.app xs∼ys i

  from : ∀ {n} {xs : Vec A n} {ys : Vec B n} →
         Pointwise′ _∼_ xs ys → Pointwise _∼_ xs ys
  from []            = nil
  from (x∼y ∷ xs∼ys) = cons x∼y (from xs∼ys)

-- Some destructors.

head : ∀ {ℓ} {A B : Set ℓ} {_∼_ : REL A B ℓ} {n x y xs} {ys : Vec B n} →
       Pointwise′ _∼_ (x ∷ xs) (y ∷ ys) → x ∼ y
head (x∼y ∷ xs∼ys) = x∼y

tail : ∀ {ℓ} {A B : Set ℓ} {_∼_ : REL A B ℓ} {n x y xs} {ys : Vec B n} →
       Pointwise′ _∼_ (x ∷ xs) (y ∷ ys) → Pointwise′ _∼_ xs ys
tail (x∼y ∷ xs∼ys) = xs∼ys

-- Pointwise preserves reflexivity.

refl : ∀ {ℓ} {A : Set ℓ} {_∼_ : Rel A ℓ} {n} →
       Reflexive _∼_ → Reflexive (Pointwise _∼_ {n = n})
refl rfl = ext (λ _ → rfl)

-- Pointwise preserves symmetry.

sym : ∀ {ℓ} {A B : Set ℓ} {P : REL A B ℓ} {Q : REL B A ℓ} {n} →
      Sym P Q → Sym (Pointwise P) (Pointwise Q {n = n})
sym sm xs∼ys = ext λ i → sm (Pointwise.app xs∼ys i)

-- Pointwise preserves transitivity.

trans : ∀ {ℓ} {A B C : Set ℓ}
          {P : REL A B ℓ} {Q : REL B C ℓ} {R : REL A C ℓ} {n} →
        Trans P Q R →
        Trans (Pointwise P) (Pointwise Q) (Pointwise R {n = n})
trans trns xs∼ys ys∼zs = ext λ i →
  trns (Pointwise.app xs∼ys i) (Pointwise.app ys∼zs i)

-- Pointwise preserves equivalences.

isEquivalence :
  ∀ {ℓ} {A : Set ℓ} {_∼_ : Rel A ℓ} {n} →
  IsEquivalence _∼_ → IsEquivalence (Pointwise _∼_ {n = n})
isEquivalence equiv = record
  { refl  = refl  (IsEquivalence.refl  equiv)
  ; sym   = sym   (IsEquivalence.sym   equiv)
  ; trans = trans (IsEquivalence.trans equiv)
  }

-- Pointwise preserves decidability.

decidable : ∀ {ℓ} {A B : Set ℓ} {_∼_ : REL A B ℓ} →
            Decidable _∼_ → ∀ {n} → Decidable (Pointwise _∼_ {n = n})
decidable {_∼_ = _∼_} dec xs ys =
  Dec.map (Setoid.sym (⇔-setoid _) equivalent) (decidable′ xs ys)
  where
  decidable′ : ∀ {n} → Decidable (Pointwise′ _∼_ {n = n})
  decidable′ []       []       = yes []
  decidable′ (x ∷ xs) (y ∷ ys) with dec x y
  ... | no ¬x∼y = no (¬x∼y ∘ head)
  ... | yes x∼y with decidable′ xs ys
  ...   | no ¬xs∼ys = no (¬xs∼ys ∘ tail)
  ...   | yes xs∼ys = yes (x∼y ∷ xs∼ys)

-- Pointwise _≡_ is equivalent to _≡_.

Pointwise-≡ : ∀ {ℓ} {A : Set ℓ} {n} {xs ys : Vec A n} →
              Pointwise _≡_ xs ys ⇔ xs ≡ ys
Pointwise-≡ {ℓ} {A} =
  Equiv.equivalence
    (to ∘ _⟨$⟩_ {f₂ = ℓ} (Equivalence.to equivalent))
    (λ xs≡ys → P.subst (Pointwise _≡_ _) xs≡ys (refl P.refl))
  where
  to : ∀ {n} {xs ys : Vec A n} → Pointwise′ _≡_ xs ys → xs ≡ ys
  to []               = P.refl
  to (P.refl ∷ xs∼ys) = P.cong (_∷_ _) $ to xs∼ys

-- Pointwise and Plus commute when the underlying relation is
-- reflexive.

⁺∙⇒∙⁺ : ∀ {ℓ} {A : Set ℓ} {_∼_ : Rel A ℓ} {n} {xs ys : Vec A n} →
        Plus (Pointwise _∼_) xs ys → Pointwise (Plus _∼_) xs ys
⁺∙⇒∙⁺ [ ρ≈ρ′ ]             = ext (λ x → [ Pointwise.app ρ≈ρ′ x ])
⁺∙⇒∙⁺ (ρ ∼⁺⟨ ρ≈ρ′ ⟩ ρ′≈ρ″) =
  ext (λ x → _ ∼⁺⟨ Pointwise.app (⁺∙⇒∙⁺ ρ≈ρ′ ) x ⟩
                   Pointwise.app (⁺∙⇒∙⁺ ρ′≈ρ″) x)

∙⁺⇒⁺∙ : ∀ {ℓ} {A : Set ℓ} {_∼_ : Rel A ℓ} {n} {xs ys : Vec A n} →
        Reflexive _∼_ →
        Pointwise (Plus _∼_) xs ys → Plus (Pointwise _∼_) xs ys
∙⁺⇒⁺∙ {ℓ} {A} {_∼_} x∼x =
  Plus.map (_⟨$⟩_ {f₂ = ℓ} (Equivalence.from equivalent)) ∘
  helper ∘
  _⟨$⟩_ {f₂ = ℓ} (Equivalence.to equivalent)
  where
  helper : ∀ {n} {xs ys : Vec A n} →
           Pointwise′ (Plus _∼_) xs ys → Plus (Pointwise′ _∼_) xs ys
  helper []                                                  = [ [] ]
  helper (_∷_ {x = x} {y = y} {xs = xs} {ys = ys} x∼y xs∼ys) =
    x ∷ xs  ∼⁺⟨ Plus.map (λ x∼y   → x∼y ∷ xs∼xs) x∼y ⟩
    y ∷ xs  ∼⁺⟨ Plus.map (λ xs∼ys → x∼x ∷ xs∼ys) (helper xs∼ys) ⟩∎
    y ∷ ys  ∎
    where
    xs∼xs : Pointwise′ _∼_ xs xs
    xs∼xs = _⟨$⟩_ {f₂ = ℓ} (Equivalence.to equivalent) (refl x∼x)

-- Note that ∙⁺⇒⁺∙ cannot be defined if the requirement of reflexivity
-- is dropped.

private

 module Counterexample where

  data D : Set where
    i j x y z : D

  data _R_ : Rel D Level.zero where
    iRj : i R j
    xRy : x R y
    yRz : y R z

  xR⁺z : x [ _R_ ]⁺ z
  xR⁺z =
    x  ∼⁺⟨ [ xRy ] ⟩
    y  ∼⁺⟨ [ yRz ] ⟩∎
    z  ∎

  ix : Vec D 2
  ix = i ∷ x ∷ []

  jz : Vec D 2
  jz = j ∷ z ∷ []

  ix∙⁺jz : Pointwise′ (Plus _R_) ix jz
  ix∙⁺jz = [ iRj ] ∷ xR⁺z ∷ []

  ¬ix⁺∙jz : ¬ Plus′ (Pointwise′ _R_) ix jz
  ¬ix⁺∙jz [ iRj ∷ () ∷ [] ]
  ¬ix⁺∙jz ((iRj ∷ xRy ∷ []) ∷ [ () ∷ yRz ∷ [] ])
  ¬ix⁺∙jz ((iRj ∷ xRy ∷ []) ∷ (() ∷ yRz ∷ []) ∷ _)

  counterexample :
    ¬ (∀ {n} {xs ys : Vec D n} →
         Pointwise (Plus _R_) xs ys →
         Plus (Pointwise _R_) xs ys)
  counterexample ∙⁺⇒⁺∙ =
    ¬ix⁺∙jz (Equivalence.to Plus.equivalent ⟨$⟩
               Plus.map (_⟨$⟩_ (Equivalence.to equivalent))
                 (∙⁺⇒⁺∙ (Equivalence.from equivalent ⟨$⟩ ix∙⁺jz)))

-- Map.

map : ∀ {ℓ} {A : Set ℓ} {_R_ _R′_ : Rel A ℓ} {n} →
      _R_ ⇒ _R′_ → Pointwise _R_ ⇒ Pointwise _R′_ {n}
map R⇒R′ xsRys = ext λ i →
  R⇒R′ (Pointwise.app xsRys i)

-- A variant.

gmap : ∀ {ℓ} {A A′ : Set ℓ}
         {_R_ : Rel A ℓ} {_R′_ : Rel A′ ℓ} {f : A → A′} {n} →
       _R_ =[ f ]⇒ _R′_ →
       Pointwise _R_ =[ Vec.map {n = n} f ]⇒ Pointwise _R′_
gmap {_R′_ = _R′_} {f} R⇒R′ {i = xs} {j = ys} xsRys = ext λ i →
  let module M = Morphism (VecProp.lookup-morphism i) in
  P.subst₂ _R′_ (P.sym $ M.op-<$> f xs)
                (P.sym $ M.op-<$> f ys)
                (R⇒R′ (Pointwise.app xsRys i))


------------------------------------------------------------------------
-- Some definitions related to and properties of booleans
------------------------------------------------------------------------

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

open import Equality

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

open import Logical-equivalence using (_⇔_)
open import Prelude hiding (id; _∘_; swap)

open import Bijection eq as Bijection using (_↔_)
open Derived-definitions-and-properties eq
open import Equality.Decision-procedures eq
open import Equivalence eq using (_≃_; ↔⇒≃; lift-equality)
open import Function-universe eq
open import H-level eq
open import H-level.Closure eq

-- The not function is involutive.

not-involutive : (b : Bool) → not (not b) ≡ b
not-involutive true  = refl _
not-involutive false = refl _

-- Bool is isomorphic to Fin 2.

Bool↔Fin2 : Bool ↔ Fin 2
Bool↔Fin2 =
  ⊤ ⊎ ⊤      ↝⟨ inverse $ id ⊎-cong ⊎-right-identity ⟩□
  ⊤ ⊎ ⊤ ⊎ ⊥  □

-- A non-trivial automorphism on Bool.

swap : Bool ↔ Bool
swap = record
  { surjection = record
    { logical-equivalence = record
      { to   = not
      ; from = not
      }
    ; right-inverse-of = not-involutive
    }
  ; left-inverse-of = not-involutive
  }

private

  non-trivial : _↔_.to swap ≢ id
  non-trivial not≡id = Bool.true≢false (cong (_$ false) not≡id)

-- Equality rearrangement lemmas.

not≡⇒≢ : (b₁ b₂ : Bool) → not b₁ ≡ b₂ → b₁ ≢ b₂
not≡⇒≢ true  true  f≡t _   = Bool.true≢false (sym f≡t)
not≡⇒≢ true  false _   t≡f = Bool.true≢false t≡f
not≡⇒≢ false true  _   f≡t = Bool.true≢false (sym f≡t)
not≡⇒≢ false false t≡f _   = Bool.true≢false t≡f

≢⇒not≡ : (b₁ b₂ : Bool) → b₁ ≢ b₂ → not b₁ ≡ b₂
≢⇒not≡ true  true  t≢t = ⊥-elim (t≢t (refl _))
≢⇒not≡ true  false _   = refl _
≢⇒not≡ false true  _   = refl _
≢⇒not≡ false false f≢f = ⊥-elim (f≢f (refl _))

not≡↔≡not : {b₁ b₂ : Bool} → not b₁ ≡ b₂ ↔ b₁ ≡ not b₂
not≡↔≡not {true} {true} =
  false ≡ true  ↝⟨ inverse $ Bijection.⊥↔uninhabited (Bool.true≢false ∘ sym) ⟩
  ⊥₀            ↝⟨ Bijection.⊥↔uninhabited Bool.true≢false ⟩□
  true ≡ false  □
not≡↔≡not {true} {false} =
  false ≡ false  ↝⟨ inverse Bijection.≡↔inj₂≡inj₂ ⟩
  tt ≡ tt        ↝⟨ Bijection.≡↔inj₁≡inj₁ ⟩□
  true ≡ true    □
not≡↔≡not {false} {true} =
  true ≡ true    ↝⟨ inverse Bijection.≡↔inj₁≡inj₁ ⟩
  tt ≡ tt        ↝⟨ Bijection.≡↔inj₂≡inj₂ ⟩□
  false ≡ false  □
not≡↔≡not {false} {false} =
  true ≡ false  ↝⟨ inverse $ Bijection.⊥↔uninhabited Bool.true≢false ⟩
  ⊥₀            ↝⟨ Bijection.⊥↔uninhabited (Bool.true≢false ∘ sym) ⟩□
  false ≡ true  □

-- Some lemmas related to T.

T↔≡true : {b : Bool} → T b ↔ b ≡ true
T↔≡true {false} =   $⟨ Bool.true≢false ⟩
  true ≢ false      ↝⟨ (_∘ sym) ⟩
  false ≢ true      ↝⟨ Bijection.⊥↔uninhabited ⟩□
  ⊥ ↔ false ≡ true  □
T↔≡true {true} =              $⟨ refl true ⟩
  true ≡ true                 ↝⟨ propositional⇒inhabited⇒contractible Bool-set ⟩
  Contractible (true ≡ true)  ↝⟨ _⇔_.to contractible⇔↔⊤ ⟩
  true ≡ true ↔ ⊤             ↝⟨ inverse ⟩□
  ⊤ ↔ true ≡ true             □

T-not↔≡false : ∀ {b} → T (not b) ↔ b ≡ false
T-not↔≡false {b} =
  T (not b)     ↝⟨ T↔≡true ⟩
  not b ≡ true  ↝⟨ not≡↔≡not ⟩□
  b ≡ false     □

T-not⇔¬T :
  (b : Bool) → T (not b) ⇔ ¬ T b
T-not⇔¬T true =
  ⊥        ↔⟨ Bijection.⊥↔uninhabited (_$ _) ⟩
  (⊤ → ⊥)  □
T-not⇔¬T false =
  ⊤    ↝⟨ record { to = λ _ → id } ⟩□
  ¬ ⊥  □

T-not↔¬T : (b : Bool) → T (not b) ↝[ lzero ∣ lzero ] ¬ T b
T-not↔¬T true _ =
  ⊥        ↔⟨ Bijection.⊥↔uninhabited (_$ _) ⟩
  (⊤ → ⊥)  □
T-not↔¬T false ext =
  ⊤    ↝⟨ inverse-ext? ¬⊥↔⊤ ext ⟩□
  ¬ ⊥  □

¬T⇔≡false : ∀ {b} → ¬ T b ⇔ b ≡ false
¬T⇔≡false {b} =
  ¬ T b      ↝⟨ inverse $ T-not⇔¬T b ⟩
  T (not b)  ↔⟨ T-not↔≡false ⟩□
  b ≡ false  □

¬T↔≡false : ∀ {b} → ¬ T b ↝[ lzero ∣ lzero ] b ≡ false
¬T↔≡false {b = b} ext =
  ¬ T b      ↝⟨ inverse-ext? (T-not↔¬T b) ext ⟩
  T (not b)  ↔⟨ T-not↔≡false ⟩□
  b ≡ false  □

T-∧↔T×T : ∀ b₁ {b₂} → T (b₁ ∧ b₂) ↔ T b₁ × T b₂
T-∧↔T×T true {b₂} =
  T b₂      ↝⟨ inverse ×-left-identity ⟩□
  ⊤ × T b₂  □
T-∧↔T×T false {b₂} =
  ⊥         ↝⟨ inverse ×-left-zero ⟩□
  ⊥ × T b₂  □

T-∨⇔T⊎T : ∀ b₁ {b₂} → T (b₁ ∨ b₂) ⇔ T b₁ ⊎ T b₂
T-∨⇔T⊎T true       = record { to = inj₁ }
T-∨⇔T⊎T false {b₂} =
  T b₂      ↔⟨ inverse ⊎-left-identity ⟩□
  ⊥ ⊎ T b₂  □

-- Bool ≃ Bool is isomorphic to Bool (assuming extensionality).

[Bool≃Bool]↔Bool₁ : Extensionality lzero lzero →
                    (Bool ≃ Bool) ↔ Bool
[Bool≃Bool]↔Bool₁ ext = record
  { surjection = record
    { logical-equivalence = record
      { to   = λ eq → _≃_.to eq true
      ; from = if_then id else ↔⇒≃ swap
      }
    ; right-inverse-of = λ { true → refl _; false → refl _ }
    }
  ; left-inverse-of = λ eq →
      lift-equality ext (apply-ext ext (lemma₂ eq))
  }
  where
  lemma₁ : ∀ b → _≃_.to (if b then id else ↔⇒≃ swap) false ≡ not b
  lemma₁ true  = refl _
  lemma₁ false = refl _

  lemma₂ : ∀ eq b →
           _≃_.to (if _≃_.to eq true then id else ↔⇒≃ swap) b ≡
           _≃_.to eq b
  lemma₂ eq true  with _≃_.to eq true
  ...             | true  = refl _
  ...             | false = refl _
  lemma₂ eq false =
    _≃_.to (if _≃_.to eq true then id else ↔⇒≃ swap) false  ≡⟨ lemma₁ (_≃_.to eq true) ⟩
    not (_≃_.to eq true)                                    ≡⟨ ≢⇒not≡ _ _ (Bool.true≢false ∘ _≃_.injective eq) ⟩∎
    _≃_.to eq false                                         ∎

-- Another proof showing that Bool ≃ Bool is isomorphic to Bool
-- (assuming extensionality).

[Bool≃Bool]↔Bool₂ : Extensionality lzero lzero →
                    (Bool ≃ Bool) ↔ Bool
[Bool≃Bool]↔Bool₂ ext = record
  { surjection = record
    { logical-equivalence = record
      { to   = λ eq → _≃_.to eq false
      ; from = if_then ↔⇒≃ swap else id
      }
    ; right-inverse-of = λ { true → refl _; false → refl _ }
    }
  ; left-inverse-of = λ eq →
      lift-equality ext (apply-ext ext (lemma₂ eq))
  }
  where
  lemma₁ : ∀ b → _≃_.to (if b then ↔⇒≃ swap else id) true ≡ not b
  lemma₁ true  = refl _
  lemma₁ false = refl _

  lemma₂ : ∀ eq b →
           _≃_.to (if _≃_.to eq false then ↔⇒≃ swap else id) b ≡
           _≃_.to eq b
  lemma₂ eq false with _≃_.to eq false
  ...             | true  = refl _
  ...             | false = refl _
  lemma₂ eq true  =
    _≃_.to (if _≃_.to eq false then ↔⇒≃ swap else id) true  ≡⟨ lemma₁ (_≃_.to eq false) ⟩
    not (_≃_.to eq false)                                   ≡⟨ ≢⇒not≡ _ _ (Bool.true≢false ∘ sym ∘ _≃_.injective eq) ⟩∎
    _≃_.to eq true                                          ∎

private

  -- The two proofs are not equal.

  distinct : {ext : Extensionality lzero lzero} →
             [Bool≃Bool]↔Bool₁ ext ≢ [Bool≃Bool]↔Bool₂ ext
  distinct =
    Bool.true≢false ∘ cong (λ iso → _≃_.to (_↔_.from iso true) true)


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

module Lecture7 where

import Lecture6
open Lecture6 public

-- Section 7.1 Fiberwise equivalences
tot : {i j k : Level} {A : UU i} {B : A → UU j} {C : A → UU k} → ((x : A) → B x → C x) → ( Σ A B → Σ A C)
tot f (dpair x y) = dpair x (f x y)

-- There is a function from the fibers of the induced map on total spaces, to the fibers of the fiberwise transformation
fib-ftr-fib-tot : {i j k : Level} {A : UU i} {B : A → UU j} {C : A → UU k} → (f : (x : A) → B x → C x) → (t : Σ A C) → fib (tot f) t → fib (f (pr1 t)) (pr2 t)
fib-ftr-fib-tot f .(dpair x (f x y)) (dpair (dpair x y) refl) = dpair y refl

-- This function has a converse
fib-tot-fib-ftr : {i j k : Level} {A : UU i} {B : A → UU j} {C : A → UU k} → (f : (x : A) → B x → C x) → (t : Σ A C) → fib (f (pr1 t)) (pr2 t) → fib (tot f) t
fib-tot-fib-ftr F (dpair a .(F a y)) (dpair y refl) = dpair (dpair a y) refl

issec-fib-tot-fib-ftr : {i j k : Level} {A : UU i} {B : A → UU j} {C : A → UU k} → (f : (x : A) → B x → C x) → (t : Σ A C) → ((fib-ftr-fib-tot f t) ∘ (fib-tot-fib-ftr f t)) ~ id
issec-fib-tot-fib-ftr f (dpair x .(f x y)) (dpair y refl) = refl

isretr-fib-tot-fib-ftr : {i j k : Level} {A : UU i} {B : A → UU j} {C : A → UU k} → (f : (x : A) → B x → C x) → (t : Σ A C) → ((fib-tot-fib-ftr f t) ∘ (fib-ftr-fib-tot f t)) ~ id
isretr-fib-tot-fib-ftr f .(dpair x (f x y)) (dpair (dpair x y) refl) = refl

-- We establish that the fibers of the induced map on total spaces are equivalent to the fibers of the fiberwise transformation.
is-equiv-fib-ftr-fib-tot : {i j k : Level} {A : UU i} {B : A → UU j} {C : A → UU k} → (f : (x : A) → B x → C x) → (t : Σ A C) → is-equiv (fib-ftr-fib-tot f t)
is-equiv-fib-ftr-fib-tot f t =
  pair
    (dpair (fib-tot-fib-ftr f t) (issec-fib-tot-fib-ftr f t))
    (dpair (fib-tot-fib-ftr f t) (isretr-fib-tot-fib-ftr f t))

-- Any fiberwise equivalence induces an equivalence on total spaces
is-equiv-tot-is-equiv-ftr :
  {i j k : Level} {A : UU i} {B : A → UU j} {C : A → UU k} →
  (f : (x : A) → B x → C x) → ((x : A) → is-equiv (f x)) →
  is-equiv (tot f )
is-equiv-tot-is-equiv-ftr f H =
  is-equiv-is-contr-map
    (λ t → is-contr-is-equiv
      (fib-ftr-fib-tot f t)
      (is-equiv-fib-ftr-fib-tot f t)
      (is-contr-map-is-equiv (H _) (pr2 t)))

-- Convesely, any fiberwise transformation that induces an equivalence on total spaces is a fiberwise equivalence.
is-equiv-ftr-is-equiv-tot :
  {i j k : Level} {A : UU i} {B : A → UU j} {C : A → UU k} →
  (f : (x : A) → B x → C x) → is-equiv (tot f) →
  (x : A) → is-equiv (f x)
is-equiv-ftr-is-equiv-tot f H x =
  is-equiv-is-contr-map
    (λ z → is-contr-is-equiv'
      (fib-ftr-fib-tot f (dpair x z))
      (is-equiv-fib-ftr-fib-tot f (dpair x z))
      (is-contr-map-is-equiv H (dpair x z)))

-- Section 7.2 The fundamental theorem

-- The general form of the fundamental theorem of identity types
id-fundamental-gen : {i j : Level} {A : UU i} {B : A → UU j} (a : A) (b : B a) → is-contr (Σ A B) → (f : (x : A) → Id a x → B x) → (x : A) → is-equiv (f x)
id-fundamental-gen {_} {_} {A} {B} a b C f x =
  is-equiv-ftr-is-equiv-tot f
    (is-equiv-is-contr _ (is-contr-total-path A a) C) x

-- The canonical form of the fundamental theorem of identity types
id-fundamental : {i j : Level} {A : UU i} {B : A → UU j} (a : A) (b : B a) →
  is-contr (Σ A B) →
  (x : A) → is-equiv (ind-Id (λ x p → B x) b x)
id-fundamental {i} {j} {A} {B} a b H =
  id-fundamental-gen a b H (ind-Id (λ x p → B x) b)

-- The converse of the fundamental theorem of identity types
id-fundamental' : {i j : Level} {A : UU i} {B : A → UU j} (a : A) (b : B a) →
  ((x : A) → is-equiv (ind-Id (λ x p → B x) b x)) → is-contr (Σ A B)
id-fundamental' {i} {j} {A} {B} a b H =
  is-contr-is-equiv'
    (tot (ind-Id (λ x p → B x) b))
    (is-equiv-tot-is-equiv-ftr _ H)
    (is-contr-total-path A a)

-- As an application we show that equivalences are embeddings.
is-emb : {i j : Level} {A : UU i} {B : UU j} (f : A → B) → UU (i ⊔ j)
is-emb f = (x y : _) → is-equiv (ap f {x} {y})

is-emb-is-equiv : {i j : Level} {A : UU i} {B : UU j} (f : A → B) → is-equiv f → is-emb f
is-emb-is-equiv {i} {j} {A} {B} f E x =
  id-fundamental-gen x refl
    (is-contr-is-equiv' (tot (λ y (p : Id (f y) (f x)) → inv p))
        (is-equiv-tot-is-equiv-ftr _ (λ y → is-equiv-inv (f y) (f x)))
      (is-contr-map-is-equiv E (f x)))
    (λ y p → ap f p)

-- Exercises

-- Exercise 7.1

tot-htpy : {i j k : Level} {A : UU i} {B : A → UU j} {C : A → UU k}
  {f g : (x : A) → B x → C x} → (H : (x : A) → f x ~ g x) → tot f ~ tot g
tot-htpy H (dpair x y) = eq-pair (dpair refl (H x y))

tot-id : {i j : Level} {A : UU i} (B : A → UU j) →
  (tot (λ x (y : B x) → y)) ~ id
tot-id B (dpair x y) = refl

tot-comp : {i j j' j'' : Level} {A : UU i} {B : A → UU j} {B' : A → UU j'} {B'' : A → UU j''} (f : (x : A) → B x → B' x) (g : (x : A) → B' x → B'' x) →
  tot (λ x → (g x) ∘ (f x)) ~ ((tot g) ∘ (tot f))
tot-comp f g (dpair x y) = refl

-- Exercise 7.7
id-fundamental-retr : {i j : Level} {A : UU i} {B : A → UU j} (a : A) →
  (i : (x : A) → B x → Id a x) → (R : (x : A) → retr (i x)) →
  (x : A) → is-equiv (i x)
id-fundamental-retr {_} {_} {A} {B} a i R =
  is-equiv-ftr-is-equiv-tot i
    (is-equiv-is-contr (tot i)
      (is-contr-retract-of (Σ _ (λ y → Id a y))
        (dpair (tot i)
          (dpair (tot λ x → pr1 (R x))
            (htpy-concat
              (tot (λ x → pr1 (R x) ∘ i x))
              (htpy-inv (tot-comp i (λ x → pr1 (R x))))
                (htpy-concat (tot (λ x → id))
                  (tot-htpy λ x → pr2 (R x))
                  (tot-id B)))))
        (is-contr-total-path _ a))
      (is-contr-total-path _ a))


{-# OPTIONS --rewriting        #-}
{-# OPTIONS --confluence-check #-}

open import Agda.Builtin.Equality
open import Agda.Builtin.Equality.Rewrite

record R : Set where
  eta-equality
  constructor c

R' = R

postulate
  D : Set
  d : D
  f : R' → D -- = R → D
  x : R
  r : f x ≡ d

{-# REWRITE r #-}

-- SUCCEEDS:
_ : f c ≡ d
_ = refl

-- FAILS:
_ : f x ≡ d
_ = refl -- (*)

cong : (y : R') → x ≡ y → f x ≡ f y
cong _ refl = refl

-- SUCCEEDS:
_ : f x ≡ f c
_ = cong c refl

-- FAILS:
_ : f x ≡ f c
_ = refl -- = cong c refl


open import Agda.Builtin.List
open import Agda.Builtin.Nat
open import Agda.Builtin.Unit
open import Agda.Builtin.Reflection

pattern vArg x = arg (arg-info visible (modality relevant quantity-ω)) x

make2 : Term → TC ⊤
make2 hole = bindTC (normalise (def (quote _+_) (vArg (lit (nat 1)) ∷ vArg (lit (nat 1)) ∷ []))) (unify hole)

macro
  tester : Term → TC ⊤
  tester hole = onlyReduceDefs (quote _+_ ∷ []) (make2 hole)

_ = tester


{-# OPTIONS --no-positivity-check #-}

module Section7 where

open import Section6 public

-- 7. Correspondence between proof trees and terms
-- ===============================================
--
-- We define a function that translates the proof trees to the corresponding untyped terms nad
-- likewise for the substitutions, we write `M ⁻` and `γ ⁻ˢ` for these operations.  The definitions
-- are:

mutual
  _⁻ : ∀ {Γ A} → Γ ⊢ A → 𝕋
  (ν x i) ⁻ = ν x
  (ƛ x M) ⁻ = ƛ x (M ⁻)
  (M ∙ N) ⁻ = (M ⁻) ∙ (N ⁻)
  (M ▶ γ) ⁻ = (M ⁻) ▶ (γ ⁻ˢ)

  _⁻ˢ : ∀ {Δ Γ} → Δ ⋙ Γ → 𝕊
  π⟨ c ⟩ ⁻ˢ        = []
  (γ ● γ′) ⁻ˢ      = (γ ⁻ˢ) ● (γ′ ⁻ˢ)
  [ γ , x ≔ M ] ⁻ˢ = [ γ ⁻ˢ , x ≔ M ⁻ ]

-- It is easy to prove that the translation of a proof tree is well-typed:

-- Lemma 12.
mutual
  lem₁₂ : ∀ {Γ A} → (M : Γ ⊢ A) → Γ ⊢ M ⁻ ∷ A
  lem₁₂ (ν x i) = ν x i
  lem₁₂ (ƛ x M) = ƛ x (lem₁₂ M)
  lem₁₂ (M ∙ N) = lem₁₂ M ∙ lem₁₂ N
  lem₁₂ (M ▶ γ) = lem₁₂ M ▶ lem₁₂ₛ γ

  lem₁₂ₛ : ∀ {Γ Γ′} → (γ : Γ′ ⋙ Γ) → Γ′ ⋙ γ ⁻ˢ ∷ Γ
  lem₁₂ₛ π⟨ c ⟩        = ↑⟨ c ⟩ refl⋙∷
  lem₁₂ₛ (γ ● γ′)      = lem₁₂ₛ γ ● lem₁₂ₛ γ′
  lem₁₂ₛ [ γ , x ≔ M ] = [ lem₁₂ₛ γ , x ≔ lem₁₂ M ]

-- In general, we may have `M ⁻ ≡ N ⁻` but `M` different from `N`.  Take for example
-- `(λ(y : B ⊃ B).z) ∙ λ(x : B).x : [ z : A ] ⊢ A` and `(λ(y : C ⊃ C).z ∙ λ(x : C).x : [ z : A ] ⊢ A`
-- which are both
-- translated into `(λ y.z) ∙ λ x.x`.  This shows that a given term can be decorated into different
-- proof trees.
--
-- We define a relation between terms and their possible decorations (and likewise for the
-- substitutions) as an inductively defined set.  (…)
--
-- The introduction rules are:  (…)

mutual
  infix 3 _𝒟_
  data _𝒟_ : ∀ {Γ A} → 𝕋 → Γ ⊢ A → Set where
    ν    : ∀ {Γ A} →
             (x : Name) (i : Γ ∋ x ∷ A) →
             ν x 𝒟 ν x i
    _∙_  : ∀ {Γ A B t₁ t₂} {M : Γ ⊢ A ⊃ B} {N : Γ ⊢ A} →
             t₁ 𝒟 M → t₂ 𝒟 N →
             t₁ ∙ t₂ 𝒟 M ∙ N
    π⟨_⟩ : ∀ {Γ Δ A t} {M : Δ ⊢ A} →
             (c : Γ ⊇ Δ) → t 𝒟 M →
             t 𝒟 M ▶ π⟨ c ⟩
    _▶_  : ∀ {Γ Δ A s t} {M : Δ ⊢ A} {γ : Γ ⋙ Δ} →
             t 𝒟 M → s 𝒟ₛ γ →
             t ▶ s 𝒟 M ▶ γ
    ƛ    : ∀ {Γ A B t} →
             (x : Name) {{_ : T (fresh x Γ)}} {M : [ Γ , x ∷ A ] ⊢ B} → t 𝒟 M →
             ƛ x t 𝒟 ƛ x M

  infix 3 _𝒟ₛ_
  data _𝒟ₛ_ : ∀ {Γ Δ} → 𝕊 → Γ ⋙ Δ → Set where
    π⟨_⟩    : ∀ {Γ Δ} →
                (c : Γ ⊇ Δ) →
                [] 𝒟ₛ π⟨ c ⟩
    [_,_≔_] : ∀ {Γ Δ A s t} {γ : Δ ⋙ Γ} {M : Δ ⊢ A} →
                s 𝒟ₛ γ → (x : Name) {{_ : T (fresh x Γ)}} → t 𝒟 M →
                [ s , x ≔ t ] 𝒟ₛ [ γ , x ≔ M ]
    ↓⟨_⟩𝒟ₛ  : ∀ {Γ Δ Θ s} {γ : Θ ⋙ Γ} →
                (c : Γ ⊇ Δ) → s 𝒟ₛ γ →
                s 𝒟ₛ ↓⟨ c ⟩ γ
    ↑⟨_⟩𝒟ₛ  : ∀ {Γ Δ Θ s} {γ : Γ ⋙ Δ} →
                (c : Θ ⊇ Γ) → s 𝒟ₛ γ →
                s 𝒟ₛ ↑⟨ c ⟩ γ
    _●_     : ∀ {Γ Δ Θ s₁ s₂} {γ₂ : Γ ⋙ Δ} {γ₁ : Θ ⋙ Γ} →
                s₂ 𝒟ₛ γ₂ → s₁ 𝒟ₛ γ₁ →
                s₂ ● s₁ 𝒟ₛ γ₂ ● γ₁

-- It is straightforward to prove Lemma 13
-- mutually with a corresponding lemma for substitutions.

-- Lemma 13.
mutual
  lem₁₃ : ∀ {Γ A} → (M : Γ ⊢ A) → M ⁻ 𝒟 M
  lem₁₃ (ν x i) = ν x i
  lem₁₃ (ƛ x M) = ƛ x (lem₁₃ M)
  lem₁₃ (M ∙ N) = lem₁₃ M ∙ lem₁₃ N
  lem₁₃ (M ▶ γ) = lem₁₃ M ▶ lem₁₃ₛ γ

  lem₁₃ₛ : ∀ {Γ Γ′} → (γ : Γ′ ⋙ Γ) → γ ⁻ˢ 𝒟ₛ γ
  lem₁₃ₛ π⟨ c ⟩        = π⟨ c ⟩
  lem₁₃ₛ (γ ● γ′)      = lem₁₃ₛ γ ● lem₁₃ₛ γ′
  lem₁₃ₛ [ γ , x ≔ M ] = [ lem₁₃ₛ γ , x ≔ lem₁₃ M ]

-- Using the discussion in Section 3.3 on how to define the monotonicity and projection
-- rules with `π⟨_⟩` we can find a proof tree that corresponds to a well-typed term:

-- Lemma 14.
postulate
  lem₁₄ : ∀ {Γ A t} → Γ ⊢ t ∷ A → Σ (Γ ⊢ A) (λ M → M ⁻ ≡ t)

-- As a direct consequence of this lemma and Lemma 13 we know that every well-typed term
-- has a decoration.

-- Lemma 15.
lem₁₅ : ∀ {Γ A t} → Γ ⊢ t ∷ A → Σ (Γ ⊢ A) (λ M → t 𝒟 M)
lem₁₅ D with lem₁₄ D
…           | (M , refl) = M , lem₁₃ M

-- As a consequence of this lemma we can now define the semantics of a well-typed term in
-- a Kripke model as the semantics of the decorated term.  In the remaining text, however, we
-- study only the correspondence between terms and proof trees since the translation to the
-- semantics is direct.
--
-- TODO: What to do about the above paragraph?
--
-- As we mentioned above a well-typed term may be decorated to several proof trees.  We
-- can however prove that if two proof trees are in η-normal form and they are decorations of
-- the same term, then the two proof trees are convertible.  We prove Lemma 16
-- together with two corresponding lemmas for proof trees in applicative normal form:

-- Lemma 16.
mutual
  postulate
    lem₁₆ : ∀ {Γ A t} {M M′ : Γ ⊢ A} {{_ : enf M}} {{_ : enf M′}} →
              t 𝒟 M → t 𝒟 M′ →
              M ≡ M′

  postulate
    lem₁₆′ : ∀ {Γ A A′ t} {M : Γ ⊢ A} {N : Γ ⊢ A′} {{_ : anf M}} {{_ : anf N}} →
               t 𝒟 M → t 𝒟 N →
               A ≡ A′

-- TODO: Uh oh. Heterogeneous equality?
-- postulate
--   lem₁₆″ : ∀ {Γ A A′ t} {M : Γ ⊢ A} {M′ : Γ ⊢ A′} {{_ : anf M}} {{_ : anf M′}} →
--              t 𝒟 M → t 𝒟 M′ →
--              M ≡ M′

  postulate
    lem₁₆″ : ∀ {Γ A t} {M M′ : Γ ⊢ A} {{_ : anf M}} {{_ : anf M′}} →
               t 𝒟 M → t 𝒟 M′ →
               M ≡ M′

-- As a consequence we get that if `nf M ⁻` and `nf N ⁻` are the same, then `M ≅ N`.

-- Corollary 2.
postulate
  cor₂ : ∀ {Γ A} → (M M′ : Γ ⊢ A) → nf M ⁻ ≡ nf M′ ⁻ → M ≅ M′

-- Proof: By Lemma 16 and Theorem 7 we get `nf N ≡ nf M` and by Theorem 5 we get `M ≅ N`.

-- 7.1. Reduction
-- --------------
--
-- We mutually inductively define when a term is in weak head normal form (abbreviated
-- `whnf`) and in weak head applicative normal form (abbreviated `whanf`) by:

mutual
  data whnf : 𝕋 → Set where
    ƛ : ∀ {t} →
          (x : Name) → whnf t →
          whnf (ƛ x t)
    α : ∀ {t} → whanf t →
          whnf t

  data whanf : 𝕋 → Set where
    ν   : (x : Name) →
          whanf (ν x)
    _∙_ : ∀ {t u} →
          whanf t → whnf u →
          whanf (t ∙ u)

-- We inductively define a deterministic untyped one-step reduction on terms and
-- substitutions:  (…)

mutual
  infix 3 _⟶_
  data _⟶_ : 𝕋 → 𝕋 → Set where
    red₁ : ∀ {a s t x} →
             (ƛ x t ▶ s) ∙ a ⟶ t ▶ [ s , x ≔ a ]
    red₂ : ∀ {t t₁ t₂} →
             t₁ ⟶ t₂ →
             t₁ ∙ t ⟶ t₂ ∙ t
    red₃ : ∀ {s t x} →
             ν x ▶ [ s , x ≔ t ] ⟶ t
    red₄ : ∀ {s t x y} {{_ : x ≢ y}} →
             ν x ▶ [ s , y ≔ t ] ⟶ ν x ▶ s
    red₅ : ∀ {x} →
             ν x ▶ [] ⟶ ν x
    red₆ : ∀ {s₁ s₂ x} →
             s₁ ⟶ₛ s₂ →
             x ▶ s₁ ⟶ x ▶ s₂
    red₇ : ∀ {s t₁ t₂} →
             (t₁ ∙ t₂) ▶ s ⟶ (t₁ ▶ s) ∙ (t₂ ▶ s)
    red₈ : ∀ {s₁ s₂ t} →
             (t ▶ s₁) ▶ s₂ ⟶ t ▶ (s₁ ● s₂)

  infix 3 _⟶ₛ_
  data _⟶ₛ_ : 𝕊 → 𝕊 → Set where
    red₁ₛ : ∀ {s₀ s₁ t x} →
              [ s₀ , x ≔ t ] ● s₁ ⟶ₛ [ s₀ ● s₁ , x ≔ t ▶ s₁ ]
    red₂ₛ : ∀ {s₁ s₂ s₃} →
              (s₁ ● s₂) ● s₃ ⟶ₛ s₁ ● (s₂ ● s₃)
    red₃ₛ : ∀ {s} →
              [] ● s ⟶ₛ s

-- The untyped evaluation to `whnf`, `_⟹_`, is inductively defined by:

infix 3 _⟹_
data _⟹_ : 𝕋 → 𝕋 → Set where
  eval₁ : ∀ {t} {{_ : whnf t}} →
            t ⟹ t
  eval₂ : ∀ {t₁ t₂ t₃} →
            t₁ ⟶ t₂ → t₂ ⟹ t₃ →
            t₁ ⟹ t₃

-- It is easy to see that this relation is deterministic.
--
-- TODO: What to do about the above paragraph?
--
-- In order to define a deterministic reduction that gives a term on long η-normal form
-- we need to use its type.  We define this typed reduction, `_⊢_↓_∷_`, simultaneously with `_⊢_↓ₛ_∷_` which
-- η-expands the arguments in an application on `whnf`:

mutual
  infix 3 _⊢_↓_∷_
  data _⊢_↓_∷_ : 𝒞 → 𝕋 → 𝕋 → 𝒯 → Set where
    red₁ : ∀ {Γ t₀ t₂} →
             Σ 𝕋 (λ t₁ → t₀ ⟹ t₁ × Γ ⊢ t₁ ↓ₛ t₂ ∷ •) →
             Γ ⊢ t₀ ↓ t₂ ∷ •
    red₂ : ∀ {Γ A B t₁ t₂} →
             let z , φ = gensym Γ in
             let instance _ = φ in
             [ Γ , z ∷ A ] ⊢ t₁ ∙ ν z ↓ t₂ ∷ B →
             Γ ⊢ t₁ ↓ ƛ z t₂ ∷ A ⊃ B

  infix 3 _⊢_↓ₛ_∷_
  data _⊢_↓ₛ_∷_ : 𝒞 → 𝕋 → 𝕋 → 𝒯 → Set where
    red₁ₛ : ∀ {Γ A x} →
              Γ ∋ x ∷ A →
              Γ ⊢ ν x ↓ₛ ν x ∷ A
    red₂ₛ : ∀ {Γ B t₁ t₂ t₁′ t₂′} →
              Σ 𝒯 (λ A → Γ ⊢ t₁ ↓ₛ t₁′ ∷ A ⊃ B × Γ ⊢ t₂ ↓ t₂′ ∷ A) →
              Γ ⊢ t₁ ∙ t₂ ↓ₛ t₁′ ∙ t₂′ ∷ B

-- Finally we define `Γ ⊢ t ⇓ t′ ∷ A` to hold if `Γ ⊢ t [] ↓ t′ ∷ A`.

_⊢_⇓_∷_ : 𝒞 → 𝕋 → 𝕋 → 𝒯 → Set
Γ ⊢ t ⇓ t′ ∷ A = Γ ⊢ t ▶ [] ↓ t′ ∷ A

-- 7.2. Equivalence between proof trees and terms
-- ----------------------------------------------
--
-- We can prove that if `M : Γ ⊢ A`, then `Γ ⊢ M ⁻ ⇓ nf M ⁻ ∷ A`.  This we do by defining a
-- Kripke logical relation, `_ℛ_`.  (…)
--
-- When `f : Γ ⊩ •` we intuitively have that `t ℛ f` holds if `Γ ⊢ t ↓ f ⁻`.
--
-- When `f : Γ ⊩ A ⊃ B`, then `t ℛ f` holds if for all `t′` and `a : Γ ⊩ A` such that `t′ ℛ a`, we
-- have that `t ∙ t′ ℛ f ⟦∙⟧ a`.

infix 3 _ℛ_
data _ℛ_ : ∀ {Γ A} → 𝕋 → Γ ⊩ A → Set where
  𝓇• : ∀ {Δ} →
         (t : 𝕋) (f : Δ ⊩ •) →
         (∀ {Γ} →
            (c : Γ ⊇ Δ) (t′ : 𝕋) → t′ 𝒟 f ⟦g⟧⟨ c ⟩ →
            Γ ⊢ t ↓ t′ ∷ •) →
         t ℛ f
  𝓇⊃ : ∀ {Δ A B} →
         (t : 𝕋) (f : Δ ⊩ A ⊃ B) →
         (∀ {Γ} →
           (c : Γ ⊇ Δ) (a : Γ ⊩ A) (t′ : 𝕋) → Γ ⊢ t′ ∷ A → t′ ℛ a →
           t ∙ t′ ℛ f ⟦∙⟧⟨ c ⟩ a) →
         t ℛ f

-- For the substitutions we define correspondingly:

infix 3 _ℛₛ_
data _ℛₛ_ : ∀ {Γ Δ} → 𝕊 → Γ ⊩⋆ Δ → Set where
  𝓇ₛ[] : ∀ {Δ s} →
           Δ ⋙ s ∷ [] →
           s ℛₛ ([] {w = Δ})
  -- NOTE: Mistake in paper?  Changed `v : Δ ⊩ A` to `a : Γ ⊩ A`.
  rₛ≔  : ∀ {Γ Δ A s x} {{_ : T (fresh x Γ)}} {{_ : T (fresh x Δ)}} →
           Δ ⋙ s ∷ [ Γ , x ∷ A ] → (ρ : Γ ⊩⋆ Δ) (a : Γ ⊩ A) → s ℛₛ ρ → ν x ▶ s ℛ a →
           s ℛₛ [ ρ , x ≔ a ]

-- The following lemmas are straightforward to prove:

postulate
  aux₇₂₁ : ∀ {Γ A t₁ t₂} →
             (a : Γ ⊩ A) → t₁ ℛ a → t₂ ⟶ t₁ →
             t₂ ℛ a

postulate
  aux₇₂₂ : ∀ {Γ Δ s₁ s₂} →
             (ρ : Γ ⊩⋆ Δ) → Δ ⋙ s₁ ∷ Γ → s₁ ⟶ₛ s₂ → s₂ ℛₛ ρ →
             s₁ ℛₛ ρ

-- NOTE: Mistake in paper?  Changed `Occur(x, A, Γ)` to `Δ ∋ x ∷ A`.
postulate
  aux₇₂₃ : ∀ {Γ Δ A s x} →
             (ρ : Γ ⊩⋆ Δ) (i : Δ ∋ x ∷ A) → Δ ⋙ s ∷ Γ →
             ν x ▶ s ℛ lookup ρ i

postulate
  aux₇₂₄⟨_⟩ : ∀ {Γ Δ A t} →
                (c : Γ ⊇ Δ) (a : Δ ⊩ A) → t ℛ a →
                t ℛ ↑⟨ c ⟩ a

-- NOTE: Mistake in paper?  Changed `ρ ∈ Γ ⊩ Δ` to `ρ : Δ ⊩⋆ Γ`.
postulate
  aux₇₂₅⟨_⟩ : ∀ {Γ Δ Θ s} →
                (c : Θ ⊇ Δ) → Δ ⋙ s ∷ Γ → (ρ : Δ ⊩⋆ Γ) → s ℛₛ ρ →
                s ℛₛ ↑⟨ c ⟩ ρ

-- NOTE: Mistake in paper?  Changed `ρ ∈ Γ ⊩ Δ` to `ρ : Δ ⊩⋆ Γ`.
postulate
  aux₇₂₆⟨_⟩ : ∀ {Γ Δ Θ s} →
                (c : Γ ⊇ Θ) → Δ ⋙ s ∷ Γ → (ρ : Δ ⊩⋆ Γ) → s ℛₛ ρ →
                s ℛₛ ↓⟨ c ⟩ ρ

postulate
  aux₇₂₇ : ∀ {Γ Δ A s t x} →
             Γ ⊢ t ∷ A → Γ ⋙ s ∷ Δ → (ρ : Γ ⊩⋆ Δ) → s ℛₛ ρ →
             [ s , x ≔ t ] ℛₛ ρ

-- Using these lemmas we can prove by mutual induction on the proof tree of terms and
-- substitutions that:

-- NOTE: Mistake in paper?  Changed `ρ ∈ Γ ⊩ Δ` to `ρ : Δ ⊩⋆ Γ`.
postulate
  aux₇₂₈ : ∀ {Γ Δ A s t} →
             (M : Γ ⊢ A) (ρ : Δ ⊩⋆ Γ) → Δ ⋙ s ∷ Γ → t 𝒟 M → s ℛₛ ρ →
             t ▶ s ℛ ⟦ M ⟧ ρ

postulate
  aux₇₂₉ : ∀ {Γ Δ Θ s₁ s₂} →
             (γ : Γ ⋙ Θ) (ρ : Δ ⊩⋆ Γ) → Δ ⋙ s₂ ∷ Γ → s₁ 𝒟ₛ γ → s₂ ℛₛ ρ →
             s₂ ● s₁ ℛₛ ⟦ γ ⟧ₛ ρ

-- We also show, intuitively, that if `t ℛ a`, `a : Γ ⊩ A`, then `Γ ⊢ t ↓ reify a ⁻ ∷ A`
-- together with a corresponding lemma for `val`:

-- Lemma 17.
mutual
  postulate
    lem₁₇ : ∀ {Γ A t₀ t₁} →
              Γ ⊢ t₀ ∷ A → (a : Γ ⊩ A) → t₀ ℛ a → t₁ 𝒟 reify a →
              Γ ⊢ t₀ ↓ t₁ ∷ A

  -- NOTE: Mistake in paper?  Changed `t ℛ val(f)` to `t₀ ℛ val f`.
  postulate
    aux₇₂₁₀ : ∀ {Γ A t₀} →
                Γ ⊢ t₀ ∷ A → whanf t₀ →
                (f : ∀ {Δ} → (c : Δ ⊇ Γ) → Δ ⊢ A) →
                (∀ {Δ} → (c : Δ ⊇ Γ) → Δ ⊢ t₀ ↓ₛ f c ⁻ ∷ A) →
                t₀ ℛ val f

-- The proof that the translation of proof trees reduces to the translation of its normal form
-- follows directly:

-- Theorem 8.
postulate
  thm₈ : ∀ {Γ A t} →
           (M : Γ ⊢ A) → t 𝒟 M →
           Γ ⊢ t ⇓ nf M ⁻ ∷ A

-- As a consequence we get that if two proof trees are decorations of the same term, then they
-- are convertible with each other:

-- Corollary 3.
postulate
  cor₃ : ∀ {Γ A t} →
           (M N : Γ ⊢ A) → t 𝒟 M → t 𝒟 N →
           M ≅ N

-- Proof: By Theorem 8 we get that `Γ ⊢ t ⇓ nf M ⁻ ∷ A` and `Γ ⊢ t ⇓ nf N ⁻ ∷ A`.  Since
-- the reduction is deterministic we get `nf M ⁻ ≡ nf N ⁻` and by Corollary 2 we get that
-- `M ≅ N`.


{- Name: Bowornmet (Ben) Hudson

-- define the source language from the paper

-}

open import Preliminaries
open import Preorder-withmax

module Proofs where

  -- define the source language from the paper
  -- we want to focus on arrow, cross, and nat types
  data Tp : Set where
    unit : Tp
    nat : Tp
    susp : Tp → Tp
    _->s_ : Tp → Tp → Tp
    _×s_ : Tp → Tp → Tp

  data Cost : Set where
    0c : Cost
    1c : Cost
    _+c_ : Cost → Cost → Cost

  data Equals0c : Cost → Set where
    Eq0-0c : Equals0c 0c
    Eq0-+c : ∀ {c c'} → Equals0c c → Equals0c c' → Equals0c (c +c c')

  -- represent a context as a list of types
  Ctx = List Tp

  -- de Bruijn indices (for free variables)
  data _∈_ : Tp → Ctx → Set where
    i0 : ∀ {Γ τ}
       → τ ∈ (τ :: Γ)
    iS : ∀ {Γ τ τ1}
       → τ ∈ Γ
       → τ ∈ (τ1 :: Γ)

  data _|-_ : Ctx → Tp → Set where
    unit : ∀ {Γ}
         → Γ |- unit
    var : ∀ {Γ τ}
        → τ ∈ Γ
        → Γ |- τ
    z : ∀ {Γ}
      → Γ |- nat
    suc : ∀ {Γ}
        → (e : Γ |- nat)
        → Γ |- nat
    rec : ∀ {Γ τ}
        → Γ |- nat
        → Γ |- τ
        → (nat :: (susp τ :: Γ)) |- τ
        → Γ |- τ
    lam : ∀ {Γ τ ρ}
        → (ρ :: Γ) |- τ
        → Γ |- (ρ ->s τ)
    app : ∀ {Γ τ1 τ2}
        → Γ |- (τ2 ->s τ1)
        → Γ |- τ2
        → Γ |- τ1
    prod : ∀ {Γ τ1 τ2}
         → Γ |- τ1
         → Γ |- τ2
         → Γ |- (τ1 ×s τ2)
    l-proj : ∀ {Γ τ1 τ2}
           → Γ |- (τ1 ×s τ2)
           → Γ |- τ1
    r-proj : ∀ {Γ τ1 τ2}
           → Γ |- (τ1 ×s τ2)
           → Γ |- τ2
    -- include split, delay/susp/force instead of usual elim rules for products
    delay : ∀ {Γ τ}
          → Γ |- τ
          → Γ |- susp τ
    force : ∀ {Γ τ}
          → Γ |- susp τ
          → Γ |- τ
    split : ∀ {Γ τ τ1 τ2}
          → Γ |- (τ1 ×s τ2)
          → (τ1 :: (τ2 :: Γ)) |- τ
          → Γ |- τ

------weakening and substitution lemmas

 -- renaming function
  rctx : Ctx → Ctx → Set
  rctx Γ Γ' = ∀ {τ} → τ ∈ Γ' → τ ∈ Γ

  -- re: transferring variables in contexts
  lem1 : ∀ {Γ Γ' τ} → rctx Γ Γ' → rctx (τ :: Γ) (τ :: Γ')
  lem1 d i0 = i0
  lem1 d (iS x) = iS (d x)

  -- renaming lemma
  ren : ∀ {Γ Γ' τ} → Γ' |- τ → rctx Γ Γ' → Γ |- τ
  ren unit d = unit
  ren (var x) d = var (d x)
  ren z d = z
  ren (suc e) d = suc (ren e d)
  ren (rec e e0 e1) d = rec (ren e d) (ren e0 d) (ren e1 (lem1 (lem1 d)))
  ren (lam e) d = lam (ren e (lem1 d))
  ren (app e1 e2) d = app (ren e1 d) (ren e2 d)
  ren (prod e1 e2) d = prod (ren e1 d) (ren e2 d)
  ren (l-proj e) d = l-proj (ren e d)
  ren (r-proj e) d = r-proj (ren e d)
  ren (delay e) d = delay (ren e d)
  ren (force e) d = force (ren e d)
  ren (split e e1) d = split (ren e d) (ren e1 (lem1 (lem1 d)))

  -- substitution
  sctx : Ctx → Ctx → Set
  sctx Γ Γ' = ∀ {τ} → τ ∈ Γ' → Γ |- τ

  -- weakening a context
  wkn : ∀ {Γ τ1 τ2} → Γ |- τ2 → (τ1 :: Γ) |- τ2
  wkn e = ren e iS

  -- weakening also works with substitution
  wkn-s : ∀ {Γ τ1 Γ'} → sctx Γ Γ' → sctx (τ1 :: Γ) Γ'
  wkn-s d = λ f → wkn (d f)

  wkn-r : ∀ {Γ τ1 Γ'} → rctx Γ Γ' → rctx (τ1 :: Γ) Γ'
  wkn-r d = λ x → iS (d x)

  -- lem2 (need a lemma for subst like we did for renaming)
  lem2 : ∀ {Γ Γ' τ} → sctx Γ Γ' → sctx (τ :: Γ) (τ :: Γ')
  lem2 d i0 = var i0
  lem2 d (iS i) = wkn (d i)

  -- another substitution lemma
  lem3 : ∀ {Γ τ} → Γ |- τ → sctx Γ (τ :: Γ)
  lem3 e i0 = e
  lem3 e (iS i) = var i

  lem3' : ∀ {Γ Γ' τ} → sctx Γ Γ' → Γ |- τ → sctx Γ (τ :: Γ')
  lem3' Θ e i0 = e
  lem3' Θ e (iS i) = Θ i

  -- one final lemma needed for the last stepping rule. Thank you Professor Licata!
  lem4 : ∀ {Γ τ1 τ2} → Γ |- τ1 → Γ |- τ2 → sctx Γ (τ1 :: (τ2 :: Γ))
  lem4 e1 e2 i0 = e1
  lem4 e1 e2 (iS i0) = e2
  lem4 e1 e2 (iS (iS i)) = var i

  lem4' : ∀ {Γ Γ' τ1 τ2} → sctx Γ Γ' → Γ |- τ1 → Γ |- τ2 → sctx Γ (τ1 :: (τ2 :: Γ'))
  lem4' Θ a b i0 = a
  lem4' Θ a b (iS i0) = b
  lem4' Θ a b (iS (iS i)) = Θ i

  lem5 : ∀ {Γ τ1 τ2} → Γ |- (τ1 ×s τ2) → sctx Γ ((τ1 ×s τ2) :: (τ1 :: (τ2 :: Γ)))
  lem5 e i0 = e
  lem5 e (iS i0) = l-proj e
  lem5 e (iS (iS i0)) = r-proj e
  lem5 e (iS (iS (iS i))) = var i

  -- the 'real' substitution lemma (if (x : τ') :: Γ |- (e : τ) and Γ |- (e : τ') , then Γ |- e[x -> e'] : τ)
  subst : ∀ {Γ Γ' τ} → sctx Γ Γ' → Γ' |- τ → Γ |- τ
  subst d unit = unit
  subst d (var x) = d x
  subst d z = z
  subst d (suc x) = suc (subst d x)
  subst d (rec e e0 e1) = rec (subst d e) (subst d e0) (subst (lem2 (lem2 d)) e1)
  subst d (lam e) = lam (subst (lem2 d) e)
  subst d (app e1 e2) = app (subst d e1) (subst d e2)
  subst d (prod e1 e2) = prod (subst d e1) (subst d e2)
  subst d (l-proj e) = l-proj (subst d e)
  subst d (r-proj e) = r-proj (subst d e)
  subst d (delay e) = delay (subst d e)
  subst d (force e) = force (subst d e)
  subst d (split e e1) = split (subst d e) (subst (lem2 (lem2 d)) e1)

  subst-compose : ∀ {Γ Γ' τ τ1} (Θ : sctx Γ Γ') (v : Γ |- τ) (e : (τ :: Γ' |- τ1) )
                → subst (lem3 v) (subst (lem2 Θ) e) == subst (lem3' Θ v) e
  subst-compose Θ unit e = {!!}
  subst-compose Θ (var x) e = {!!}
  subst-compose Θ z e = {!!}
  subst-compose Θ (suc v) e = {!!}
  subst-compose Θ (rec v v₁ v₂) e = {!!}
  subst-compose Θ (lam v) e = {!!}
  subst-compose Θ (app v v₁) e = {!!}
  subst-compose Θ (prod v v₁) e = {!!}
  subst-compose Θ (l-proj v) e = {!!}
  subst-compose Θ (r-proj v) e = {!!}
  subst-compose Θ (delay v) e = {!!}
  subst-compose Θ (force v) e = {!!}
  subst-compose Θ (split v v₁) e = {!!}


-- Jesper, 2019-05-28: test case for #3812

{-# OPTIONS --rewriting #-}

open import Agda.Builtin.Equality
open import Agda.Builtin.Equality.Rewrite

record Box (A : Set) : Set where
  constructor box
  field unbox : A

open Box

postulate
  A : Set
  r s : Box A
  rew₂ : r .unbox ≡ s .unbox

{-# REWRITE rew₂ #-}

Box-η : {x y : Box A} → x .unbox ≡ y .unbox → x ≡ y
Box-η refl = refl

-- WAS: `ext` reduces to `refl`, but giving `ext = refl` directly
-- leads to a type error.
ext : r ≡ s
ext = Box-η refl

ext' : r ≡ s
ext' = refl


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

module Issue942  where

record Sigma (A : Set)(P : A → Set) : Set where
  constructor _,_
  field
    fst : A
    snd : P fst
open Sigma

postulate
  A : Set
  x : A
  P Q : A → Set
  Px : P x
  f  : ∀ {x} → P x → Q x

ex : Sigma A Q
ex = record
       { fst = x
       ; snd = f {!!} -- goal: P x
       }

ex' : Sigma A Q
ex' = x , f {!!} -- goal: P x

ex'' : Sigma A Q
fst ex'' = x
snd ex'' = f {!!} -- goal: P (fst ex'')

-- should termination check


module Functional where

import      Lvl
open import Type

infixl 10000 _∘_
infixl 10000 _⩺_
infixl 10000 _⩹_
infixl 30 _→ᶠ_ _←_ _←ᶠ_
infixr 0 _$_

private variable ℓ ℓ₁ ℓ₂ : Lvl.Level
private variable T X X₁ X₂ X₃ X₄ Y Y₁ Y₂ Y₃ Y₄ Z : Type{ℓ}

-- Converse of a function type
_←_ : Type{ℓ₁} → Type{ℓ₂} → Type{ℓ₁ Lvl.⊔ ℓ₂}
Y ← X = X → Y

-- Function type as a function
_→ᶠ_ : Type{ℓ₁} → Type{ℓ₂} → Type{ℓ₁ Lvl.⊔ ℓ₂}
X →ᶠ Y = X → Y

-- Converse function type as a function
_←ᶠ_ : Type{ℓ₁} → Type{ℓ₂} → Type{ℓ₁ Lvl.⊔ ℓ₂}
Y ←ᶠ X = Y ← X

-- The identity function.
-- Returns the applied argument.
id : T → T
id(x) = x
{-# INLINE id #-}

-- The constant function.
-- Returns the first argument independent of the second.
const : let _ = X in Y → (X → Y)
const(x)(_) = x

-- Function application as a function.
-- Applies the first argument on the function on the second argument.
apply : X → (X → Y) → Y
apply(x)(f) = f(x)
{-# INLINE apply #-}

-- Function application as an operator
_$_ : (X → Y) → X → Y
_$_ = id
{-# INLINE _$_ #-}

_$ᵢₘₚₗ_ : ({ _ : X } → Y) → (X → Y)
f $ᵢₘₚₗ x = f{x}
{-# INLINE _$ᵢₘₚₗ_ #-}

_$ᵢₙₛₜ_ : (⦃ _ : X ⦄ → Y) → (X → Y)
f $ᵢₙₛₜ x = f ⦃ x ⦄
{-# INLINE _$ᵢₙₛₜ_ #-}

-- Function application as an operator. Function to the left, value to the right.
_⩹_ : (X → Y) → X → Y
f ⩹ x = f(x)
{-# INLINE _⩹_ #-}

-- Function application as an operator. Value to the left, function to the right.
_⩺_ : X → (X → Y) → Y
x ⩺ f = f(x)
{-# INLINE _⩺_ #-}

-- Swapping the arguments of a binary operation
swap : (X → Y → Z) → (Y → X → Z)
swap f(y)(x) = f(x)(y)
{-# INLINE swap  #-}

-- Function composition
_∘_ : let _ = X in (Y → Z) → (X → Y) → (X → Z)
(f ∘ g)(x) = f(g(x))

-- Function composition on implicit argument
_∘ᵢₘₚₗ_ : let _ = X in ({Y} → Z) → ({X} → Y) → ({X} → Z)
(f ∘ᵢₘₚₗ g){x} = f{g{x}}

-- Function composition on instance argument
_∘ᵢₙₛₜ_ : let _ = X in (⦃ Y ⦄ → Z) → (⦃ X ⦄ → Y) → (⦃ X ⦄ → Z)
(f ∘ᵢₙₛₜ g) ⦃ x ⦄ = f ⦃ g ⦃ x ⦄ ⦄

-- The S-combinator from combinatory logic.
-- It is sometimes described as a generalized version of the application operator or the composition operator.
-- Note: TODO: Applicative instance
_∘ₛ_ : (X → Y → Z) → (X → Y) → (X → Z)
(f ∘ₛ g)(x) = (f x) (g x)

_on₀_ : let _ = X in Z → (X → Y) → Z
((▫) on₀ f) = ▫ -- const

_on₁_ : let _ = X in (Y → Z) → (X → Y) → (X → Z)
((_▫) on₁ f)(y₁) = (f(y₁) ▫) on₀ f -- f(y₁) ▫

-- Function composition on a binary operator
-- A function is composed on every argument of the binary operator.
_on₂_ : let _ = X in (Y → Y → Z) → (X → Y) → (X → X → Z)
((_▫_) on₂ f)(y₁) = (f(y₁) ▫_) on₁ f -- f(y₁) ▫ f(y₂)

_on₃_ : let _ = X in (Y → Y → Y → Z) → (X → Y) → (X → X → X → Z)
((_▫_▫_) on₃ f)(y₁) = (f(y₁) ▫_▫_) on₂ f -- f(y₁) ▫ f(y₂) ▫ f(y₃)

-- TODO: Move these to Function.Multi
_∘₀_ : (Y → Z) → Y → Z
_∘₀_ = id

_∘₁_ : let _ = X₁ in (Y → Z) → (X₁ → Y) → (X₁ → Z)
_∘₁_ f = (f ∘₀_) ∘_

-- (f ∘₂ g)(x)(y) = f(g(x)(y))
_∘₂_ : let _ = X₁ ; _ = X₂ in (Y → Z) → (X₁ → X₂ → Y) → (X₁ → X₂ → Z)
_∘₂_ f = (f ∘₁_) ∘_

-- (f ∘₃ g)(x)(y)(z) = f(g(x)(y)(z))
_∘₃_ : let _ = X₁ ; _ = X₂ ; _ = X₃ in (Y → Z) → (X₁ → X₂ → X₃ → Y) → (X₁ → X₂ → X₃ → Z)
_∘₃_ f = (f ∘₂_) ∘_

-- (f ∘₄ g)(x)(y)(z)(w) = f(g(x)(y)(z)(w))
_∘₄_ : let _ = X₁ ; _ = X₂ ; _ = X₃ ; _ = X₄ in (Y → Z) → (X₁ → X₂ → X₃ → X₄ → Y) → (X₁ → X₂ → X₃ → X₄ → Z)
_∘₄_ f = (f ∘₃_) ∘_

-- map₂Arg₁ : let _ = X in (Y₁ → Y₂ → Z) → (X → Y₁) → (X → Y₂) → (X → Z)
-- map₂Arg₁ f g₁ g₂ x = f(g₁ x)(g₂ x)

-- map₂Arg₂ : let _ = X₁ ; _ = X₂ in (Y₁ → Y₂ → Z) → (X₁ → Y₁) → (X₂ → Y₂) → (X₁ → X₂ → Z)
-- map₂Arg₂ f g₁ g₂ x₁ x₂ = f(g₁ x₁)(g₂ x₂)

-- Function lifting //TODO: Consider removing because it is the same as _∘_
liftₗ : (X → Y) → ((Z → X) → (Z → Y))
liftₗ = _∘_ -- liftₗ(f) = f ∘_

liftᵣ : (X → Y) → ((Y → Z) → (X → Z))
liftᵣ = swap(_∘_) -- liftᵣ(f) = _∘ f

-- Applies an argument to two arguments of a binary function.
_$₂_ : (X → X → Y) → (X → Y)
f $₂ x = f x x

apply₂ : X → (X → X → Y) → Y
apply₂ x f = f x x

proj₂ₗ : X → Y → X
proj₂ₗ = const

proj₂ᵣ : X → Y → Y
proj₂ᵣ = const id

open import Syntax.Function public


{-

This file contains:

- Properties of set truncations

-}
{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.SetTruncation.Properties where

open import Cubical.HITs.SetTruncation.Base

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Univalence
open import Cubical.Data.Sigma

private
  variable
    ℓ : Level
    A B C D : Type ℓ

rec : isSet B → (A → B) → ∥ A ∥₂ → B
rec Bset f ∣ x ∣₂ = f x
rec Bset f (squash₂ x y p q i j) =
  Bset _ _ (cong (rec Bset f) p) (cong (rec Bset f) q) i j

-- lemma 6.9.1 in HoTT book
elim : {B : ∥ A ∥₂ → Type ℓ}
       (Bset : (x : ∥ A ∥₂) → isSet (B x))
       (g : (a : A) → B (∣ a ∣₂))
       (x : ∥ A ∥₂) → B x
elim Bset g ∣ a ∣₂ = g a
elim Bset g (squash₂ x y p q i j) =
  isOfHLevel→isOfHLevelDep 2 Bset _ _
    (cong (elim Bset g) p) (cong (elim Bset g) q) (squash₂ x y p q) i j

setTruncUniversal : isSet B → (∥ A ∥₂ → B) ≃ (A → B)
setTruncUniversal {B = B} Bset =
  isoToEquiv (iso (λ h x → h ∣ x ∣₂) (rec Bset) (λ _ → refl) rinv)
  where
  rinv : (f : ∥ A ∥₂ → B) → rec Bset (λ x → f ∣ x ∣₂) ≡ f
  rinv f i x =
    elim (λ x → isProp→isSet (Bset (rec Bset (λ x → f ∣ x ∣₂) x) (f x)))
         (λ _ → refl) x i

elim2 : {B : ∥ A ∥₂ → ∥ A ∥₂ → Type ℓ}
        (Bset : ((x y : ∥ A ∥₂) → isSet (B x y)))
        (g : (a b : A) → B ∣ a ∣₂ ∣ b ∣₂)
        (x y : ∥ A ∥₂) → B x y
elim2 Bset g = elim (λ _ → isSetΠ (λ _ → Bset _ _))
                    (λ a → elim (λ _ → Bset _ _) (g a))

elim3 : {B : (x y z : ∥ A ∥₂) → Type ℓ}
        (Bset : ((x y z : ∥ A ∥₂) → isSet (B x y z)))
        (g : (a b c : A) → B ∣ a ∣₂ ∣ b ∣₂ ∣ c ∣₂)
        (x y z : ∥ A ∥₂) → B x y z
elim3 Bset g = elim2 (λ _ _ → isSetΠ (λ _ → Bset _ _ _))
                     (λ a b → elim (λ _ → Bset _ _ _) (g a b))

setTruncIsSet : isSet ∥ A ∥₂
setTruncIsSet a b p q = squash₂ a b p q

setTruncIdempotent≃ : isSet A → ∥ A ∥₂ ≃ A
setTruncIdempotent≃ {A = A} hA = isoToEquiv f
  where
  f : Iso ∥ A ∥₂ A
  Iso.fun f = rec hA (idfun A)
  Iso.inv f x = ∣ x ∣₂
  Iso.rightInv f _ = refl
  Iso.leftInv f = elim (λ _ → isSet→isGroupoid setTruncIsSet _ _) (λ _ → refl)

setTruncIdempotent : isSet A → ∥ A ∥₂ ≡ A
setTruncIdempotent hA = ua (setTruncIdempotent≃ hA)

isContr→isContrSetTrunc : isContr A → isContr (∥ A ∥₂)
isContr→isContrSetTrunc contr = ∣ fst contr ∣₂
                                , elim (λ _ → isOfHLevelPath 2 (setTruncIsSet) _ _)
                                       λ a → cong ∣_∣₂ (snd contr a)

setTruncIso : Iso A B → Iso ∥ A ∥₂ ∥ B ∥₂
Iso.fun (setTruncIso is) = rec setTruncIsSet (λ x → ∣ Iso.fun is x ∣₂)
Iso.inv (setTruncIso is) = rec setTruncIsSet (λ x → ∣ Iso.inv is x ∣₂)
Iso.rightInv (setTruncIso is) =
  elim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
        λ a → cong ∣_∣₂ (Iso.rightInv is a)
Iso.leftInv (setTruncIso is) =
  elim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
        λ a → cong ∣_∣₂ (Iso.leftInv is a)

setSigmaIso : ∀ {ℓ} {B : A → Type ℓ} → Iso ∥ Σ A B ∥₂ ∥ Σ A (λ x → ∥ B x ∥₂) ∥₂
setSigmaIso {A = A} {B = B} = iso fun funinv sect retr
  where
  {- writing it out explicitly to avoid yellow highlighting -}
  fun : ∥ Σ A B ∥₂ → ∥ Σ A (λ x → ∥ B x ∥₂) ∥₂
  fun = rec setTruncIsSet λ {(a , p) → ∣ a , ∣ p ∣₂ ∣₂}
  funinv : ∥ Σ A (λ x → ∥ B x ∥₂) ∥₂ → ∥ Σ A B ∥₂
  funinv = rec setTruncIsSet (λ {(a , p) → rec setTruncIsSet (λ p → ∣ a , p ∣₂) p})
  sect : section fun funinv
  sect = elim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
              λ { (a , p) → elim {B = λ p → fun (funinv ∣ a , p ∣₂) ≡ ∣ a , p ∣₂}
              (λ p → isOfHLevelPath 2 setTruncIsSet _ _) (λ _ → refl) p }
  retr : retract fun funinv
  retr = elim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
              λ { _ → refl }

sigmaElim : ∀ {ℓ ℓ'} {B : ∥ A ∥₂ → Type ℓ} {C : Σ ∥ A ∥₂ B  → Type ℓ'}
            (Bset : (x : Σ ∥ A ∥₂ B) → isSet (C x))
            (g : (a : A) (b : B ∣ a ∣₂) → C (∣ a ∣₂ , b))
            (x : Σ ∥ A ∥₂ B) → C x
sigmaElim {B = B} {C = C} set g (x , y) = elim {B = λ x → (y : B x) → C (x , y)}
                                               (λ _ → isOfHLevelΠ 2 λ _ → set (_ , _))
                                               g x y

sigmaProdElim : ∀ {ℓ ℓ'} {C : ∥ A ∥₂ × ∥ B ∥₂ → Type ℓ} {D : Σ (∥ A ∥₂ × ∥ B ∥₂) C  → Type ℓ'}
             (Bset : (x : Σ (∥ A ∥₂ × ∥ B ∥₂) C) → isSet (D x))
             (g : (a : A) (b : B) (c : C (∣ a ∣₂ , ∣ b ∣₂)) → D ((∣ a ∣₂ , ∣ b ∣₂) , c))
             (x : Σ (∥ A ∥₂ × ∥ B ∥₂) C) → D x
sigmaProdElim {B = B} {C = C} {D = D} set g ((x , y) , c) =
  elim {B = λ x → (y : ∥ B ∥₂) (c : C (x , y)) → D ((x , y) , c)}
       (λ _ → isOfHLevelΠ 2 λ _ → isOfHLevelΠ 2 λ _ → set _)
       (λ x → elim (λ _ → isOfHLevelΠ 2 λ _ → set _)
                    λ y c → g x y c)
       x y c

prodElim : ∀ {ℓ} {C : ∥ A ∥₂ × ∥ B ∥₂ → Type ℓ}
        → ((x : ∥ A ∥₂ × ∥ B ∥₂) → isOfHLevel 2 (C x))
        → ((a : A) (b : B) → C (∣ a ∣₂ , ∣ b ∣₂))
        → (x : ∥ A ∥₂ × ∥ B ∥₂) → C x
prodElim {A = A} {B = B} {C = C} hlevel ind (a , b) = schonf a b
  where
  schonf : (a : ∥ A ∥₂) (b : ∥ B ∥₂) → C (a , b)
  schonf = elim (λ x → isOfHLevelΠ 2 λ y → hlevel (_ , _)) λ a → elim (λ x → hlevel (_ , _))
                 λ b → ind a b

prodElim2 : ∀ {ℓ} {E : (∥ A ∥₂ × ∥ B ∥₂) → (∥ C ∥₂ × ∥ D ∥₂) → Type ℓ}
         → ((x : ∥ A ∥₂ × ∥ B ∥₂) (y : ∥ C ∥₂ × ∥ D ∥₂) → isOfHLevel 2 (E x y))
         → ((a : A) (b : B) (c : C) (d : D) → E (∣ a ∣₂ , ∣ b ∣₂) (∣ c ∣₂ , ∣ d ∣₂))
         → ((x : ∥ A ∥₂ × ∥ B ∥₂) (y : ∥ C ∥₂ × ∥ D ∥₂) → (E x y))
prodElim2 isset f = prodElim (λ _ → isOfHLevelΠ 2 λ _ → isset _ _)
                             λ a b → prodElim (λ _ → isset _ _)
                                     λ c d → f a b c d

setTruncOfProdIso :  Iso ∥ A × B ∥₂ (∥ A ∥₂ × ∥ B ∥₂)
Iso.fun setTruncOfProdIso = rec (isOfHLevelΣ 2 setTruncIsSet (λ _ → setTruncIsSet)) λ { (a , b) → ∣ a ∣₂ , ∣ b ∣₂ }
Iso.inv setTruncOfProdIso = prodElim (λ _ → setTruncIsSet) λ a b → ∣ a , b ∣₂
Iso.rightInv setTruncOfProdIso =
  prodElim (λ _ → isOfHLevelPath 2 (isOfHLevelΣ 2 setTruncIsSet (λ _ → setTruncIsSet)) _ _)
           λ _ _ → refl
Iso.leftInv setTruncOfProdIso =
  elim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
        λ {(a , b) → refl}


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

module Spaces where

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

private
  variable
    ℓ ℓ' ℓ'' : Level

open import Cubical.Foundations.Everything renaming (_⁻¹ to _⁻¹ᵖ; assoc to ∙-assoc)
open import Cubical.Structures.CommRing
open import Cubical.Relation.Nullary.Base -- ¬_
open import Cubical.Relation.Binary.Base
open import Cubical.Data.Sum.Base renaming (_⊎_ to infixr 4 _⊎_)
open import Cubical.Data.Sigma.Base renaming (_×_ to infixr 4 _×_)
open import Cubical.Data.Empty renaming (elim to ⊥-elim) -- `⊥` and `elim`
-- open import Cubical.Structures.Poset
open import Cubical.Foundations.Function
open import Cubical.Structures.Ring
open import Cubical.Structures.AbGroup
open import Cubical.Foundations.Logic renaming (¬_ to ¬ᵖ_)

open import Function.Base using (_∋_)
-- open import Function.Reasoning using (∋-syntax)
open import Function.Base using (it) -- instance search

{-
| name                                    | carrier | module | metric | norm | inner | basis | cauchy |
|-----------------------------------------|---------|--------|--------|------|-------|-------|--------|
| VectorSpace                             |   any   |   K    |        |      |       |       |        |
| FiniteDimVectorSpace                    |   any   |   K    |        |      |       |   ✓   |        |
| NormedVectorSpace                       |   any   |   K    |   (✓)  |   ✓  |       |       |        |
| FiniteDimNormedVectorSpace              |   any   |   K    |   (✓)  |   ✓  |       |   ✓   |        |
| CompleteNormedVectorSpace               |   any   |   K    |   (✓)  |   ✓  |       |       |   ✓    |
| FiniteDimCompleteNormedVectorSpace      |   any   |   K    |   (✓)  |   ✓  |       |   ✓   |   ✓    |
| InnerProductSpace                       |   any   |   K    |   (✓)  |  (✓) |   ✓   |       |        |
| FiniteDimInnerProductSpace              |   any   |   K    |   (✓)  |  (✓) |   ✓   |   ✓   |        |
| CompleteInnerProductSpace               |   any   |   K    |   (✓)  |  (✓) |   ✓   |       |   ✓    |
| FiniteDimCompleteInnerProductSpace      |   any   |   K    |   (✓)  |  (✓) |   ✓   |   ✓   |   ✓    |
| FiniteDimCompleteInnerProductSpaceOverℝ |    ℝ    |   ℝ    |   (✓)  |  (✓) |   ✓   |   ✓   |   ✓    |
-}


-- Exploit by Jesper Cockx

open import Agda.Builtin.Equality

data Bool : Set where
  tt ff : Bool

const : Bool → (Bool → Bool)
const = λ x _ → x

mutual
  Bool→cBool : Set
  Bool→cBool = _

  const-tt : Bool→cBool
  const-tt = const tt

constant : (f : Bool→cBool) (x y : Bool) → f x ≡ f y
constant f x y = refl

constant' : (f : Bool → Bool) (x y : Bool) → f x ≡ f y
constant' = constant

swap : Bool → Bool
swap tt = ff
swap ff = tt

fireworks : tt ≡ ff
fireworks = constant' swap ff tt


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

open import HoTT
open import groups.Cokernel
open import cw.WedgeOfCells
open import cohomology.Theory

open import cw.CW

module cw.cohomology.reconstructed.HigherCoboundary {i} (OT : OrdinaryTheory i)
  {n} (⊙skel : ⊙Skeleton {i} (S (S n))) where

open OrdinaryTheory OT
open import cw.cohomology.grid.LongExactSequence cohomology-theory
  (ℕ-to-ℤ (S n)) (⊙cw-incl-last (⊙cw-init ⊙skel)) (⊙cw-incl-last ⊙skel)
open import cw.cohomology.WedgeOfCells OT

cw-co∂-last : CXₙ/Xₙ₋₁ (⊙cw-init ⊙skel) (ℕ-to-ℤ (S n)) →ᴳ CXₙ/Xₙ₋₁ ⊙skel (ℕ-to-ℤ (S (S n)))
cw-co∂-last = grid-co∂

cw-∂-before-Susp : Xₙ/Xₙ₋₁ (⊙Skeleton.skel ⊙skel) → Susp (Xₙ/Xₙ₋₁ (cw-init (⊙Skeleton.skel ⊙skel)))
cw-∂-before-Susp = grid-∂-before-Susp

⊙cw-∂-before-Susp : ⊙Xₙ/Xₙ₋₁ (⊙Skeleton.skel ⊙skel) ⊙→ ⊙Susp (⊙Xₙ/Xₙ₋₁ (cw-init (⊙Skeleton.skel ⊙skel)))
⊙cw-∂-before-Susp = ⊙grid-∂-before-Susp

cw-∂-before-Susp-glue-β = grid-∂-before-Susp-glue-β
cw-co∂-last-β = grid-co∂-β

module CokerCo∂ where
  grp = Coker cw-co∂-last (CXₙ/Xₙ₋₁-is-abelian ⊙skel (ℕ-to-ℤ (S (S n))))
  open Group grp public

CokerCo∂ = CokerCo∂.grp


open import FRP.JS.Bool using ( Bool ; not )
open import FRP.JS.Maybe using ( Maybe ; just ; nothing ) renaming ( _≟[_]_  to _≟?[_]_ )
open import FRP.JS.Nat using ( ℕ ; zero ; suc ; _≟_ ; _<_ )
open import FRP.JS.Object using ( Object ; IObject ; [] ; _↦_∷_ ; object ; ⟪⟫ ; ⟪_ ; _↦_,_ ; _↦_⟫ ; _≟[_]_ ; _⊆[_]_ ; lookup ; lookup? ; map ; filter )
open import FRP.JS.QUnit using ( TestSuite ; ok ; test ; _,_ )

module FRP.JS.Test.Object where

_≟*_ : Object ℕ → Object ℕ → Bool
xs ≟* ys = xs ≟[ _≟_ ] ys

_⊆*_ : Object ℕ → Object ℕ → Bool
xs ⊆* ys = xs ⊆[ _≟_ ] ys

_≟?_ : Maybe ℕ → Maybe ℕ → Bool
xs ≟? ys = xs ≟?[ _≟_ ] ys

_≟??_ : Maybe (Maybe ℕ) → Maybe (Maybe ℕ) → Bool
xs ≟?? ys = xs ≟?[ _≟?_ ] ys

iincr : ∀ {ks ks✓} → IObject ℕ ks ks✓ → IObject ℕ ks ks✓
iincr []           = []
iincr (k ↦ n ∷ ns) = k ↦ suc n ∷ iincr ns

incr : Object ℕ → Object ℕ
incr (object ns) = object (iincr ns)

⟪a↦0⟫     = ⟪ "a" ↦ 0 ⟫
⟪a↦1⟫     = ⟪ "a" ↦ 1 ⟫
⟪a↦0,b↦1⟫ = ⟪ "a" ↦ 0 , "b" ↦ 1 ⟫
⟪a↦1,b↦2⟫ = ⟪ "a" ↦ 1 , "b" ↦ 2 ⟫
⟪b↦0⟫     = ⟪ "b" ↦ 0 ⟫
⟪b↦2⟫     = ⟪ "b" ↦ 2 ⟫
⟪a↦n⟫     = ⟪ "a" ↦ nothing {A = ℕ} ⟫
⟪a↦j0⟫    = ⟪ "a" ↦ just 0 ⟫

tests : TestSuite
tests =
  ( test "≟"
    ( ok "⟪⟫ ≟ ⟪⟫" (⟪⟫ ≟* ⟪⟫)
    , ok "⟪a↦0⟫ ≟ ⟪⟫" (not (⟪a↦0⟫ ≟* ⟪⟫))
    , ok "⟪⟫ ≟ ⟪a↦0⟫" (not (⟪⟫ ≟* ⟪a↦0⟫))
    , ok "⟪a↦0⟫ ≟ ⟪a↦0⟫" (⟪a↦0⟫ ≟* ⟪a↦0⟫)
    , ok "⟪a↦0⟫ ≟ ⟪a↦1⟫" (not (⟪a↦0⟫ ≟* ⟪a↦1⟫))
    , ok "⟪a↦0⟫ ≟ ⟪a↦0,b↦1⟫" (not (⟪a↦0⟫ ≟* ⟪a↦0,b↦1⟫))
    , ok "⟪a↦0,b↦1⟫ ≟ ⟪a↦0⟫" (not (⟪a↦0,b↦1⟫ ≟* ⟪a↦0⟫))
    , ok "⟪a↦0,b↦1⟫ ≟ ⟪a↦0,b↦1⟫" (⟪a↦0,b↦1⟫ ≟* ⟪a↦0,b↦1⟫) )
  , test "⊆"
    ( ok "⟪⟫ ⊆ ⟪⟫" (⟪⟫ ⊆* ⟪⟫)
    , ok "⟪a↦0⟫ ⊆ ⟪⟫" (not (⟪a↦0⟫ ⊆* ⟪⟫))
    , ok "⟪⟫ ⊆ ⟪a↦0⟫" (⟪⟫ ⊆* ⟪a↦0⟫)
    , ok "⟪a↦0⟫ ⊆ ⟪a↦0⟫" (⟪a↦0⟫ ⊆* ⟪a↦0⟫)
    , ok "⟪a↦0⟫ ⊆ ⟪a↦1⟫" (not (⟪a↦0⟫ ⊆* ⟪a↦1⟫))
    , ok "⟪a↦0⟫ ⊆ ⟪a↦0,b↦1⟫" (⟪a↦0⟫ ⊆* ⟪a↦0,b↦1⟫)
    , ok "⟪a↦0,b↦1⟫ ⊆ ⟪a↦0⟫" (not (⟪a↦0,b↦1⟫ ⊆* ⟪a↦0⟫))
    , ok "⟪a↦0,b↦1⟫ ⊆ ⟪a↦0,b↦1⟫" (⟪a↦0,b↦1⟫ ⊆* ⟪a↦0,b↦1⟫) )
  , test "lookup"
    ( ok "lookup ⟪a↦0⟫ a" (lookup ⟪a↦0⟫ "a" ≟ 0)
    , ok "lookup ⟪a↦0,b↦1⟫ a" (lookup ⟪a↦0,b↦1⟫ "b" ≟ 1)
    , ok "lookup ⟪a↦0,b↦1⟫ a" (lookup ⟪a↦0,b↦1⟫ "a" ≟ 0)
    , ok "lookup ⟪a↦0,b↦1⟫ b" (lookup ⟪a↦0,b↦1⟫ "b" ≟ 1)
    , ok "lookup ⟪a↦j0⟫ a" (lookup ⟪a↦j0⟫ "a" ≟? just 0)
    , ok "lookup ⟪a↦n⟫ a" (lookup ⟪a↦n⟫ "a" ≟? nothing)
    , ok "lookup? ⟪⟫    a" (lookup? ⟪⟫ "a" ≟? nothing)
    , ok "lookup? ⟪a↦0⟫ a" (lookup? ⟪a↦0⟫ "a" ≟? just 0)
    , ok "lookup? ⟪a↦0⟫ b" (lookup? ⟪a↦0⟫ "b" ≟? nothing)
    , ok "lookup? ⟪a↦0,b↦1⟫ a" (lookup? ⟪a↦0,b↦1⟫ "a" ≟? just 0)
    , ok "lookup? ⟪a↦0,b↦1⟫ b" (lookup? ⟪a↦0,b↦1⟫ "b" ≟? just 1)
    , ok "lookup? ⟪a↦0,b↦1⟫ c" (lookup? ⟪a↦0,b↦1⟫ "c" ≟? nothing)
    , ok "lookup? ⟪a↦j0⟫ a" (lookup? ⟪a↦j0⟫ "a" ≟?? just (just 0))
    , ok "lookup? ⟪a↦n⟫ a" (lookup? ⟪a↦n⟫ "a" ≟?? just nothing) )
  , test "map"
    ( ok "map suc ⟪⟫" (map suc ⟪⟫ ≟* ⟪⟫)
    , ok "map suc ⟪a↦0⟫" (map suc ⟪a↦0⟫ ≟* ⟪a↦1⟫)
    , ok "map suc ⟪a↦0,b↦1⟫" (map suc ⟪a↦0,b↦1⟫ ≟* ⟪a↦1,b↦2⟫)
    , ok "incr ⟪⟫" (map suc ⟪⟫ ≟* incr ⟪⟫)
    , ok "incr ⟪a↦0⟫" (map suc ⟪a↦0⟫ ≟* incr ⟪a↦0⟫)
    , ok "incr ⟪a↦0,b↦1⟫" (map suc ⟪a↦0,b↦1⟫ ≟* incr ⟪a↦0,b↦1⟫) )
  , test "filter"
    ( ok "filter 0< ⟪a↦1,b↦2⟫" (filter (_<_ 0) ⟪a↦1,b↦2⟫ ≟* ⟪a↦1,b↦2⟫)
    , ok "filter 1< ⟪a↦1,b↦2⟫" (filter (_<_ 1) ⟪a↦1,b↦2⟫ ≟* ⟪b↦2⟫)
    , ok "filter 2< ⟪a↦1,b↦2⟫" (filter (_<_ 2) ⟪a↦1,b↦2⟫ ≟* ⟪⟫) ) )