------------------------------------------------------------------------
-- A variant of the set quotients from Quotient
------------------------------------------------------------------------

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

-- Partly following the HoTT book.
--
-- Unlike the HoTT book, but following the cubical library (in which
-- set quotients were implemented by Zesen Qian and Anders Mörtberg),
-- the quotienting relations are not always required to be
-- propositional. Furthermore, unlike the code in the cubical library,
-- the set truncation constructor takes an argument stating that the
-- quotienting relation is propositional.

-- The module is parametrised by a notion of equality. The higher
-- constructors of the HIT defining quotients use path equality, but
-- the supplied notion of equality is used for many other things.

import Equality.Path as P

module Quotient.Set-truncated-if-propositional
  {e⁺} (eq : ∀ {a p} → P.Equality-with-paths a p e⁺) where

private
  open module D = P.Derived-definitions-and-properties eq hiding (elim)

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

open import Bijection equality-with-J using (_↔_)
open import Equality.Decidable-UIP equality-with-J
open import Equality.Path.Isomorphisms eq
open import Equivalence equality-with-J as Eq using (_≃_)
open import Equivalence-relation equality-with-J
open import Function-universe equality-with-J as F hiding (_∘_; id)
open import H-level equality-with-J as H
import H-level P.equality-with-J as PH
open import H-level.Closure equality-with-J
import H-level.Truncation.Church equality-with-J as Trunc
open import H-level.Truncation.Propositional eq as TruncP
  using (∥_∥; ∣_∣; Surjective; Axiom-of-countable-choice)
open import Preimage equality-with-J using (_⁻¹_)
import Quotient eq as Quotient
import Quotient.Families-of-equivalence-classes equality-with-J as QF
open import Sum equality-with-J
open import Surjection equality-with-J using (_↠_)
open import Univalence-axiom equality-with-J

private
  variable
    a a₁ a₂ b p     : Level
    k               : Isomorphism-kind
    A A₁ A₂ B       : Type a
    P               : A → Type p
    e f r r₁ r₂ x y : A
    R R₁ R₂         : A → A → Type r

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

-- The quotient type constructor.

infix 5 _/_

data _/_ (A : Type a) (R : A → A → Type r) : Type (a ⊔ r) where
  [_]                   : A → A / R
  []-respects-relationᴾ : R x y → [ x ] P.≡ [ y ]
  /-is-setᴾ             : (∀ x y → Is-proposition (R x y)) →
                          P.Is-set (A / R)

-- [_] respects the quotient relation.

[]-respects-relation : R x y → _≡_ {A = A / R} [ x ] [ y ]
[]-respects-relation = _↔_.from ≡↔≡ ∘ []-respects-relationᴾ

-- If R is pointwise propositional, then A / R is a set.

/-is-set : (∀ x y → Is-proposition (R x y)) → Is-set (A / R)
/-is-set = _↔_.from (H-level↔H-level 2) ∘ /-is-setᴾ

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

-- An eliminator, expressed using paths.

record Elimᴾ′ {A : Type a} {R : A → A → Type r} (P : A / R → Type p) :
              Type (a ⊔ r ⊔ p) where
  no-eta-equality
  field
    []ʳ : ∀ x → P [ x ]

    []-respects-relationʳ :
      (r : R x y) →
      P.[ (λ i → P ([]-respects-relationᴾ r i)) ] []ʳ x ≡ []ʳ y

    is-setʳ :
      (prop : ∀ x y → Is-proposition (R x y))
      {eq₁ eq₂ : x P.≡ y} {p : P x} {q : P y}
      (eq₃ : P.[ (λ i → P (eq₁ i)) ] p ≡ q)
      (eq₄ : P.[ (λ i → P (eq₂ i)) ] p ≡ q) →
      P.[ (λ i → P.[ (λ j → P (/-is-setᴾ prop eq₁ eq₂ i j)) ] p ≡ q) ]
        eq₃ ≡ eq₄

open Elimᴾ′ public

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

  helper : (x : A / R) → P x
  helper [ x ]                       = E.[]ʳ x
  helper ([]-respects-relationᴾ r i) = E.[]-respects-relationʳ r i
  helper (/-is-setᴾ prop p q i j)    =
    E.is-setʳ prop (λ i → helper (p i)) (λ i → helper (q i)) i j

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

record Elimᴾ {A : Type a} {R : A → A → Type r} (P : A / R → Type p) :
             Type (a ⊔ r ⊔ p) where
  no-eta-equality
  field
    []ʳ : ∀ x → P [ x ]

    []-respects-relationʳ :
      (r : R x y) →
      P.[ (λ i → P ([]-respects-relationᴾ r i)) ] []ʳ x ≡ []ʳ y

    is-setʳ :
      (∀ x y → Is-proposition (R x y)) →
      ∀ x → P.Is-set (P x)

open Elimᴾ public

elimᴾ : Elimᴾ P → (x : A / R) → P x
elimᴾ e = elimᴾ′ λ where
    .[]ʳ                   → E.[]ʳ
    .[]-respects-relationʳ → E.[]-respects-relationʳ
    .is-setʳ prop          → P.heterogeneous-UIP (E.is-setʳ prop) _
  where
  module E = Elimᴾ e

private

  -- One can define elimᴾ′ using elimᴾ.

  elimᴾ′₂ : Elimᴾ′ P → (x : A / R) → P x
  elimᴾ′₂ {P = P} e = elimᴾ λ where
      .[]ʳ                        → E.[]ʳ
      .[]-respects-relationʳ      → E.[]-respects-relationʳ
      .is-setʳ prop x {y} {z} p q →                                $⟨ E.is-setʳ prop p q ⟩
        P.[ (λ i →
               P.[ (λ j → P (/-is-setᴾ prop P.refl P.refl i j)) ]
                 y ≡ z) ]
          p ≡ q                                                    ↝⟨ P.subst (λ eq → P.[ (λ i → P.[ (λ j → P (eq i j)) ] y ≡ z) ] p ≡ q)
                                                                              (PH.mono₁ 2 (/-is-setᴾ prop) _ _) ⟩
        P.[ (λ _ → P.[ (λ _ → P x) ] y ≡ z) ] p ≡ q                ↔⟨⟩

        p P.≡ q                                                    □
    where
    module E = Elimᴾ′ e

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

record Recᴾ {A : Type a} (R : A → A → Type r) (B : Type b) :
            Type (a ⊔ r ⊔ b) where
  no-eta-equality
  field
    []ʳ                   : A → B
    []-respects-relationʳ : (r : R x y) → []ʳ x P.≡ []ʳ y
    is-setʳ               : (∀ x y → Is-proposition (R x y)) →
                            P.Is-set B

open Recᴾ public

recᴾ : Recᴾ R B → A / R → B
recᴾ r = elimᴾ λ where
    .[]ʳ                   → R.[]ʳ
    .[]-respects-relationʳ → R.[]-respects-relationʳ
    .is-setʳ prop _        → R.is-setʳ prop
  where
  module R = Recᴾ r

-- An eliminator.

record Elim {A : Type a} {R : A → A → Type r} (P : A / R → Type p) :
            Type (a ⊔ r ⊔ p) where
  no-eta-equality
  field
    []ʳ : ∀ x → P [ x ]

    []-respects-relationʳ :
      (r : R x y) →
      subst P ([]-respects-relation r) ([]ʳ x) ≡ []ʳ y

    is-setʳ : (∀ x y → Is-proposition (R x y)) → ∀ x → Is-set (P x)

open Elim public

elim : Elim P → (x : A / R) → P x
elim e = elimᴾ λ where
    .[]ʳ                   → E.[]ʳ
    .[]-respects-relationʳ → subst≡→[]≡ ∘ E.[]-respects-relationʳ
    .is-setʳ prop          →
      _↔_.to (H-level↔H-level 2) ∘ E.is-setʳ prop
  where
  module E = Elim e

-- A computation rule.

elim-[]-respects-relation :
  dcong (elim e) ([]-respects-relation r) ≡ e .[]-respects-relationʳ r
elim-[]-respects-relation = dcong-subst≡→[]≡ (refl _)

-- A non-dependent eliminator.

record Rec {A : Type a} (R : A → A → Type r) (B : Type b) :
           Type (a ⊔ r ⊔ b) where
  no-eta-equality
  field
    []ʳ                   : A → B
    []-respects-relationʳ : (r : R x y) → []ʳ x ≡ []ʳ y
    is-setʳ               : (∀ x y → Is-proposition (R x y)) → Is-set B

open Rec public

rec : Rec R B → A / R → B
rec r = recᴾ λ where
    .[]ʳ                   → R.[]ʳ
    .[]-respects-relationʳ → _↔_.to ≡↔≡ ∘ R.[]-respects-relationʳ
    .is-setʳ               → _↔_.to (H-level↔H-level 2) ∘ R.is-setʳ
  where
  module R = Rec r

-- A computation rule.

rec-[]-respects-relation :
  cong (rec {R = R} {B = B} r₁)
       ([]-respects-relation {x = x} {y = y} r₂) ≡
  r₁ .[]-respects-relationʳ r₂
rec-[]-respects-relation = cong-≡↔≡ (refl _)

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

record Elim-prop
         {A : Type a} {R : A → A → Type r} (P : A / R → Type p) :
         Type (a ⊔ r ⊔ p) where
  no-eta-equality
  field
    []ʳ             : ∀ x → P [ x ]
    is-propositionʳ : ∀ x → Is-proposition (P [ x ])

open Elim-prop public

elim-prop : Elim-prop P → (x : A / R) → P x
elim-prop e = elim λ where
    .[]ʳ                     → E.[]ʳ
    .[]-respects-relationʳ _ → E.is-propositionʳ _ _ _
    .is-setʳ _               → elim λ where
      .[]ʳ                     → mono₁ 1 ∘ E.is-propositionʳ
      .[]-respects-relationʳ _ → H-level-propositional ext 2 _ _
      .is-setʳ _ _             → mono₁ 1 (H-level-propositional ext 2)
  where
  module E = Elim-prop e

-- A variant of rec that can be used if the motive is a proposition.

record Rec-prop (A : Type a) (B : Type b) : Type (a ⊔ b) where
  no-eta-equality
  field
    []ʳ             : A → B
    is-propositionʳ : Is-proposition B

open Rec-prop public

rec-prop : Rec-prop A B → A / R → B
rec-prop r = elim-prop λ where
    .[]ʳ               → R.[]ʳ
    .is-propositionʳ _ → R.is-propositionʳ
  where
  module R = Rec-prop r

------------------------------------------------------------------------
-- Some properties

-- [_] is surjective.

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

-- If the relation is a propositional equivalence relation, then it is
-- equivalent to equality under [_] (assuming propositional
-- extensionality).
--
-- The basic structure of this proof is that of Proposition 2 in
-- "Quotienting the Delay Monad by Weak Bisimilarity" by Chapman,
-- Uustalu and Veltri.

related≃[equal] :
  {R : A → A → Type r} →
  Propositional-extensionality r →
  Is-equivalence-relation R →
  (∀ {x y} → Is-proposition (R x y)) →
  ∀ {x y} → R x y ≃ _≡_ {A = A / R} [ x ] [ y ]
related≃[equal] {A = A} {r = r} {R = R}
                prop-ext R-equiv R-prop {x = x} {y = y} =
  _↠_.from (Eq.≃↠⇔ R-prop (/-is-set λ _ _ → R-prop))
    (record
       { to   = []-respects-relation
       ; from = λ [x]≡[y] →
                               $⟨ reflexive ⟩
           proj₁ (R′ x [ x ])  ↝⟨ ≡⇒→ (cong (proj₁ ∘ R′ x) [x]≡[y]) ⟩
           proj₁ (R′ x [ y ])  ↝⟨ id ⟩□
           R x y               □
       })
  where
  open Is-equivalence-relation R-equiv

  lemma : ∀ {x y z} → R y z → (R x y , R-prop) ≡ (R x z , R-prop)
  lemma {x} {y} {z} =
    R y z                                ↝⟨ (λ r → record
                                               { to   = flip transitive r
                                               ; from = flip transitive (symmetric r)
                                               }) ⟩
    R x y ⇔ R x z                        ↔⟨ ⇔↔≡″ ext prop-ext ⟩□
    (R x y , R-prop) ≡ (R x z , R-prop)  □

  R′ : A → A / R → Proposition r
  R′ x = rec λ where
    .[]ʳ y                 → R x y , R-prop
    .[]-respects-relationʳ → lemma
    .is-setʳ _             → Is-set-∃-Is-proposition ext prop-ext

-- Quotienting with equality (for a set) amounts to the same thing as
-- not quotienting at all.

/≡↔ : Is-set A → A / _≡_ ↔ A
/≡↔ A-set = record
  { surjection = record
    { logical-equivalence = record
      { from = [_]
      ; to   = rec λ where
          .[]ʳ                   → id
          .[]-respects-relationʳ → id
          .is-setʳ prop          → prop _ _
      }
    ; right-inverse-of = λ _ → refl _
    }
  ; left-inverse-of = elim λ where
      .[]ʳ _ → refl _

      .is-setʳ prop _ → mono₁ 2 (/-is-set prop)

      .[]-respects-relationʳ _ →
        /-is-set (λ _ _ → A-set) _ _
  }

-- Quotienting with a trivial, pointwise propositional relation
-- amounts to the same thing as using the propositional truncation
-- operator.

/trivial↔∥∥ :
  (∀ x y → R x y) →
  (∀ {x y} → Is-proposition (R x y)) →
  A / R ↔ ∥ A ∥
/trivial↔∥∥ {A = A} {R = R} trivial prop = record
  { surjection = record
    { logical-equivalence = record
      { from = TruncP.rec /-prop [_]
      ; to   = rec-prop λ where
          .[]ʳ             → ∣_∣
          .is-propositionʳ → TruncP.truncation-is-proposition
      }
    ; right-inverse-of = TruncP.elim
        _
        (λ _ → ⇒≡ 1 TruncP.truncation-is-proposition)
        (λ _ → refl _)
    }
  ; left-inverse-of = elim-prop λ where
      .[]ʳ _             → refl _
      .is-propositionʳ _ → /-is-set λ _ _ → prop
  }
  where
  /-prop : Is-proposition (A / R)
  /-prop = elim-prop λ where
    .[]ʳ x → elim-prop λ where
      .[]ʳ y             → []-respects-relation (trivial x y)
      .is-propositionʳ _ → /-is-set λ _ _ → prop
    .is-propositionʳ _ →
      Π-closure ext 1 λ _ →
      /-is-set λ _ _ → prop

-- The previous property gives us an alternative to
-- constant-function≃∥inhabited∥⇒inhabited.

constant-function↔∥inhabited∥⇒inhabited :
  Is-set B →
  (∃ λ (f : A → B) → Constant f) ↔ (∥ A ∥ → B)
constant-function↔∥inhabited∥⇒inhabited {B = B} {A = A} B-set =
  (∃ λ (f : A → B) → Constant f)  ↝⟨ record
                                       { surjection = record
                                         { logical-equivalence = record
                                           { to   = λ { (f , c) → rec λ where
                                                        .[]ʳ                     → f
                                                        .[]-respects-relationʳ _ → c _ _
                                                        .is-setʳ _               → B-set }
                                           ; from = λ f → (f ∘ [_])
                                                        , (λ _ _ → cong f ([]-respects-relation _))
                                           }
                                         ; right-inverse-of = λ f → ⟨ext⟩ $ elim λ where
                                             .[]ʳ _                   → refl _
                                             .[]-respects-relationʳ _ → B-set _ _
                                             .is-setʳ _ _             → mono₁ 2 B-set
                                         }
                                       ; left-inverse-of = λ _ → Σ-≡,≡→≡
                                           (refl _)
                                           ((Π-closure ext 1 λ _ →
                                             Π-closure ext 1 λ _ →
                                             B-set) _ _)
                                       } ⟩
  (A / (λ _ _ → ⊤) → B)           ↝⟨ →-cong₁ ext (/trivial↔∥∥ _ (mono₁ 0 ⊤-contractible)) ⟩□
  (∥ A ∥ → B)                     □

-- The two directions of the proposition above compute in the
-- "right" way. Note that (at the time of writing) an analogue of
-- the second property below fails to hold definitionally for
-- constant-function≃∥inhabited∥⇒inhabited.

_ :
  {B-set : Is-set B} →
  _↔_.to (constant-function↔∥inhabited∥⇒inhabited B-set) f ∣ x ∣ ≡
  proj₁ f x
_ = refl _

_ :
  {B-set : Is-set B} →
  proj₁ (_↔_.from (constant-function↔∥inhabited∥⇒inhabited B-set) f)
        x ≡
  f ∣ x ∣
_ = refl _

------------------------------------------------------------------------
-- Preservation lemmas

-- A preservation lemma for functions.

/-map :
  ((∀ x y → Is-proposition (R₁ x y)) →
   (∀ x y → Is-proposition (R₂ x y))) →
  (A₁→A₂ : A₁ → A₂) →
  (∀ x y → R₁ x y → R₂ (A₁→A₂ x) (A₁→A₂ y)) →
  A₁ / R₁ → A₂ / R₂
/-map {R₁ = R₁} {R₂ = R₂} prop A₁→A₂ R₁→R₂ = rec λ where
  .[]ʳ → [_] ∘ A₁→A₂

  .is-setʳ → /-is-set ∘ prop

  .[]-respects-relationʳ {x = x} {y = y} →
     R₁ x y                     ↝⟨ R₁→R₂ _ _ ⟩
     R₂ (A₁→A₂ x) (A₁→A₂ y)     ↝⟨ []-respects-relation ⟩□
     [ A₁→A₂ x ] ≡ [ A₁→A₂ y ]  □

-- A preservation lemma for logical equivalences.

/-cong-⇔ :
  ((∀ x y → Is-proposition (R₁ x y)) ⇔
   (∀ x y → Is-proposition (R₂ x y))) →
  (A₁⇔A₂ : A₁ ⇔ A₂) →
  (∀ x y → R₁ x y → R₂ (_⇔_.to   A₁⇔A₂ x) (_⇔_.to   A₁⇔A₂ y)) →
  (∀ x y → R₂ x y → R₁ (_⇔_.from A₁⇔A₂ x) (_⇔_.from A₁⇔A₂ y)) →
  A₁ / R₁ ⇔ A₂ / R₂
/-cong-⇔ prop A₁⇔A₂ R₁→R₂ R₂→R₁ = record
  { to   = /-map (_⇔_.to   prop) (_⇔_.to   A₁⇔A₂) R₁→R₂
  ; from = /-map (_⇔_.from prop) (_⇔_.from A₁⇔A₂) R₂→R₁
  }

-- A preservation lemma for split surjections.

/-cong-↠ :
  ((∀ x y → Is-proposition (R₁ x y)) ⇔
   (∀ x y → Is-proposition (R₂ x y))) →
  (A₁↠A₂ : A₁ ↠ A₂) →
  (∀ x y → R₁ x y ↠ R₂ (_↠_.to A₁↠A₂ x) (_↠_.to A₁↠A₂ y)) →
  A₁ / R₁ ↠ A₂ / R₂
/-cong-↠ {R₁ = R₁} {R₂ = R₂} prop A₁↠A₂ R₁↠R₂ = record
  { logical-equivalence = /-cong-⇔
      prop
      (_↠_.logical-equivalence A₁↠A₂)
      (λ x y → _↠_.to (R₁↠R₂ x y))
      (λ x y → R₂ x y                          ↝⟨ ≡⇒↝ _ (sym $ cong₂ R₂ (right-inverse-of x) (right-inverse-of y)) ⟩
               R₂ (to (from x)) (to (from y))  ↝⟨ _↠_.from (R₁↠R₂ _ _) ⟩□
               R₁ (from x) (from y)            □)
  ; right-inverse-of = elim λ where
      .[]ʳ x →
        [ to (from x) ]  ≡⟨ cong [_] $ right-inverse-of x ⟩∎
        [ x ]            ∎

      .is-setʳ prop _ → mono₁ 1 (/-is-set prop)

      .[]-respects-relationʳ {x = x} {y = y} r →
        let tr = λ x y → _↠_.to (R₁↠R₂ x y)

            fr = λ x y →
                   _↠_.from (R₁↠R₂ (from x) (from y)) ∘
                   ≡⇒↝ _
                     (sym (cong₂ R₂ (right-inverse-of x)
                                    (right-inverse-of y)))

            t = /-map (_⇔_.to prop) to tr

            f = /-map (_⇔_.from prop) from fr
        in
        subst (λ x → t (f x) ≡ x)
          ([]-respects-relation r)
          (cong [_] (right-inverse-of x))                       ≡⟨ subst-in-terms-of-trans-and-cong ⟩

        trans
          (sym (cong (t ∘ f) ([]-respects-relation r)))
          (trans (cong [_] (right-inverse-of x))
             (cong id ([]-respects-relation r)))                ≡⟨ cong₂ (λ eq₁ eq₂ → trans (sym eq₁)
                                                                                (trans (cong [_] (right-inverse-of x)) eq₂))
                                                                     (sym $ cong-∘ _ _ _)
                                                                     (sym $ cong-id _) ⟩
        trans
          (sym (cong t (cong f ([]-respects-relation r))))
          (trans (cong [_] (right-inverse-of x))
             ([]-respects-relation r))                          ≡⟨ cong (λ eq → trans (sym (cong t eq))
                                                                                (trans (cong [_] (right-inverse-of x))
                                                                                ([]-respects-relation r))) $
                                                                   rec-[]-respects-relation ⟩
        trans
          (sym (cong t ([]-respects-relation (fr _ _ r))))
          (trans (cong [_] (right-inverse-of x))
             ([]-respects-relation r))                          ≡⟨ cong (λ eq → trans (sym eq)
                                                                                (trans (cong [_] (right-inverse-of x))
                                                                                ([]-respects-relation r))) $
                                                                   rec-[]-respects-relation ⟩
        trans
          (sym ([]-respects-relation (tr _ _ (fr _ _ r))))
          (trans (cong [_] (right-inverse-of x))
             ([]-respects-relation r))                          ≡⟨ cong (λ r′ → trans (sym ([]-respects-relation r′))
                                                                                (trans (cong [_] (right-inverse-of x))
                                                                                ([]-respects-relation r))) $
                                                                   _↠_.right-inverse-of (R₁↠R₂ _ _) _ ⟩
        trans
          (sym ([]-respects-relation
                  (≡⇒↝ _ (sym (cong₂ R₂ (right-inverse-of x)
                                        (right-inverse-of y)))
                     r)))
          (trans (cong [_] (right-inverse-of x))
             ([]-respects-relation r))                          ≡⟨ lemma _ _ _ ⟩∎

        cong [_] (right-inverse-of y)                           ∎
  }
  where
  open _↠_ A₁↠A₂

  lemma : ∀ _ _ _ → _
  lemma x y r =
    elim₁
      (λ eq →
         trans
           (sym ([]-respects-relation
                   (≡⇒↝ _ (sym (cong₂ R₂ (right-inverse-of x) eq)) r)))
           (trans (cong [_] (right-inverse-of x))
              ([]-respects-relation r)) ≡
         cong [_] eq)
      (elim₁
         (λ eq →
            trans
              (sym ([]-respects-relation
                      (≡⇒↝ _ (sym (cong₂ R₂ eq (refl _))) r)))
              (trans (cong [_] eq) ([]-respects-relation r)) ≡
            cong [_] (refl _))
         (trans
            (sym ([]-respects-relation
                    (≡⇒↝ _ (sym (cong₂ R₂ (refl _) (refl _))) r)))
            (trans (cong [_] (refl _)) ([]-respects-relation r))    ≡⟨ cong₂ (λ eq₁ eq₂ →
                                                                                trans (sym ([]-respects-relation (≡⇒↝ _ eq₁ r)))
                                                                                (trans eq₂ ([]-respects-relation r)))
                                                                         (trans (cong sym $ cong₂-refl R₂) sym-refl)
                                                                         (cong-refl _) ⟩
          trans
            (sym ([]-respects-relation (≡⇒↝ _ (refl _) r)))
            (trans (refl _) ([]-respects-relation r))               ≡⟨ cong₂ (λ eq₁ eq₂ → trans (sym ([]-respects-relation eq₁)) eq₂)
                                                                         (cong (_$ r) ≡⇒↝-refl)
                                                                         (trans-reflˡ _) ⟩
          trans
            (sym ([]-respects-relation r))
            ([]-respects-relation r)                                ≡⟨ trans-symˡ _ ⟩

          refl _                                                    ≡⟨ sym $ cong-refl _ ⟩∎

          cong [_] (refl _)                                         ∎)
         (right-inverse-of x))
      (right-inverse-of y)

private

  -- A preservation lemma for equivalences.

  /-cong-≃ :
    ((∀ x y → Is-proposition (R₁ x y)) ⇔
     (∀ x y → Is-proposition (R₂ x y))) →
    (A₁≃A₂ : A₁ ≃ A₂) →
    (∀ x y →
       R₁ x y ≃ R₂ (to-implication A₁≃A₂ x) (to-implication A₁≃A₂ y)) →
    A₁ / R₁ ≃ A₂ / R₂
  /-cong-≃ {R₁ = R₁} {R₂ = R₂} prop A₁≃A₂ R₁≃R₂ = Eq.↔⇒≃ (record
    { surjection = /-cong-↠ prop (_≃_.surjection A₁≃A₂) λ x y →
        R₁ x y            ↔⟨ R₁≃R₂ x y ⟩□
        R₂ (to x) (to y)  □
    ; left-inverse-of = elim λ where
        .[]ʳ x →
          [ from (to x) ]  ≡⟨ cong [_] $ left-inverse-of x ⟩∎
          [ x ]            ∎

        .is-setʳ prop _ → mono₁ 1 (/-is-set prop)

        .[]-respects-relationʳ {x = x} {y = y} r →
          let tr = λ x y → _≃_.to (R₁≃R₂ x y)

              fr = λ x y →
                     _≃_.from (R₁≃R₂ (from x) (from y)) ∘
                     ≡⇒↝ _
                       (sym (cong₂ R₂ (right-inverse-of x)
                                      (right-inverse-of y)))

              t = /-map (_⇔_.to prop) to tr

              f = /-map (_⇔_.from prop) from fr
          in
          subst (λ x → f (t x) ≡ x)
            ([]-respects-relation r)
            (cong [_] (left-inverse-of x))                       ≡⟨ subst-in-terms-of-trans-and-cong ⟩

          trans
            (sym (cong (f ∘ t) ([]-respects-relation r)))
            (trans (cong [_] (left-inverse-of x))
               (cong id ([]-respects-relation r)))               ≡⟨ cong₂ (λ eq₁ eq₂ → trans (sym eq₁)
                                                                                (trans (cong [_] (left-inverse-of x)) eq₂))
                                                                      (sym $ cong-∘ _ _ _)
                                                                      (sym $ cong-id _) ⟩
          trans
            (sym (cong f (cong t ([]-respects-relation r))))
            (trans (cong [_] (left-inverse-of x))
               ([]-respects-relation r))                         ≡⟨ cong (λ eq → trans (sym (cong f eq))
                                                                                (trans (cong [_] (left-inverse-of x))
                                                                                ([]-respects-relation r))) $
                                                                    rec-[]-respects-relation ⟩
          trans
            (sym (cong f ([]-respects-relation (tr _ _ r))))
            (trans (cong [_] (left-inverse-of x))
               ([]-respects-relation r))                         ≡⟨ cong (λ eq → trans (sym eq)
                                                                                (trans (cong [_] (left-inverse-of x))
                                                                                ([]-respects-relation r))) $
                                                                    rec-[]-respects-relation ⟩
          trans
            (sym ([]-respects-relation (fr _ _ (tr _ _ r))))
            (trans (cong [_] (left-inverse-of x))
               ([]-respects-relation r))                         ≡⟨ cong (λ r′ → trans (sym ([]-respects-relation r′))
                                                                                (trans (cong [_] (left-inverse-of x))
                                                                                ([]-respects-relation r))) $
                                                                    lemma₁ _ _ _ ⟩
          trans
            (sym ([]-respects-relation
                    (≡⇒↝ _ (sym (cong₂ R₁ (left-inverse-of x)
                                          (left-inverse-of y)))
                       r)))
            (trans (cong [_] (left-inverse-of x))
               ([]-respects-relation r))                         ≡⟨ lemma₂ _ _ _ ⟩∎

          cong [_] (left-inverse-of y)                           ∎
    })
    where
    open _≃_ A₁≃A₂

    lemma₀ : ∀ _ _ _ → _
    lemma₀ x y r =
      elim₁
        (λ eq →
           _≃_.from (R₁≃R₂ (from (to x)) _)
             (≡⇒↝ _ (sym (cong₂ (λ x y → R₂ (to x) (to y))
                            (left-inverse-of x) eq))
                (_≃_.to (R₁≃R₂ x y) r)) ≡
           ≡⇒↝ _ (sym (cong₂ R₁ (left-inverse-of x) eq)) r)
        (elim₁
           (λ eq →
              _≃_.from (R₁≃R₂ _ _)
                (≡⇒↝ _ (sym (cong₂ (λ x y → R₂ (to x) (to y))
                               eq (refl _)))
                   (_≃_.to (R₁≃R₂ x y) r)) ≡
              ≡⇒↝ _ (sym (cong₂ R₁ eq (refl _))) r)
           (_≃_.from (R₁≃R₂ _ _)
              (≡⇒↝ _ (sym (cong₂ (λ x y → R₂ (to x) (to y))
                             (refl _) (refl _)))
                 (_≃_.to (R₁≃R₂ x y) r))                                  ≡⟨ cong (λ eq → _≃_.from (R₁≃R₂ _ _) (≡⇒↝ _ eq (_≃_.to (R₁≃R₂ x y) r))) $
                                                                             trans (cong sym $ cong₂-refl _) sym-refl ⟩

            _≃_.from (R₁≃R₂ _ _) (≡⇒↝ _ (refl _) (_≃_.to (R₁≃R₂ x y) r))  ≡⟨ cong (_≃_.from (R₁≃R₂ _ _)) $ cong (_$ _≃_.to (R₁≃R₂ x y) r)
                                                                             ≡⇒↝-refl ⟩

            _≃_.from (R₁≃R₂ _ _) (_≃_.to (R₁≃R₂ x y) r)                   ≡⟨ _≃_.left-inverse-of (R₁≃R₂ _ _) _ ⟩

            r                                                             ≡⟨ sym $ cong (_$ r) ≡⇒↝-refl ⟩

            ≡⇒↝ _ (refl _) r                                              ≡⟨ cong (λ eq → ≡⇒↝ _ eq r) $ sym $
                                                                             trans (cong sym $ cong₂-refl _) sym-refl ⟩∎
            ≡⇒↝ _ (sym (cong₂ R₁ (refl _) (refl _))) r                    ∎)
           (left-inverse-of x))
        (left-inverse-of y)

    lemma₁ : ∀ _ _ _ → _
    lemma₁ x y r =
      _≃_.from (R₁≃R₂ (from (to x)) (from (to y)))
        (≡⇒↝ _ (sym (cong₂ R₂ (right-inverse-of (to x))
                              (right-inverse-of (to y))))
           (_≃_.to (R₁≃R₂ x y) r))                                       ≡⟨⟩

      _≃_.from (R₁≃R₂ (from (to x)) (from (to y)))
        (≡⇒↝ _ (sym (trans (cong (flip R₂ _) (right-inverse-of (to x)))
                       (cong (R₂ _) (right-inverse-of (to y)))))
           (_≃_.to (R₁≃R₂ x y) r))                                       ≡⟨ cong₂ (λ eq₁ eq₂ →
                                                                                _≃_.from (R₁≃R₂ (from (to x)) (from (to y)))
                                                                                (≡⇒↝ _ (sym (trans eq₁ eq₂)) (_≃_.to (R₁≃R₂ x y) r)))
                                                                              (trans (cong (cong _) $ sym $ left-right-lemma _) (cong-∘ _ _ _))
                                                                              (trans (cong (cong _) $ sym $ left-right-lemma _) (cong-∘ _ _ _)) ⟩
      _≃_.from (R₁≃R₂ (from (to x)) (from (to y)))
        (≡⇒↝ _ (sym (trans (cong (flip R₂ _ ∘ to) (left-inverse-of x))
                       (cong (R₂ _ ∘ to) (left-inverse-of y))))
           (_≃_.to (R₁≃R₂ x y) r))                                       ≡⟨⟩

      _≃_.from (R₁≃R₂ (from (to x)) (from (to y)))
        (≡⇒↝ _ (sym (cong₂ (λ x y → R₂ (to x) (to y))
                       (left-inverse-of x)
                       (left-inverse-of y)))
           (_≃_.to (R₁≃R₂ x y) r))                                       ≡⟨ lemma₀ _ _ _ ⟩∎

      ≡⇒↝ _ (sym (cong₂ R₁ (left-inverse-of x) (left-inverse-of y))) r   ∎

    lemma₂ : ∀ _ _ _ → _
    lemma₂ x y r =
      elim₁
        (λ eq →
           trans
             (sym ([]-respects-relation
                     (≡⇒↝ _ (sym (cong₂ R₁ (left-inverse-of x) eq)) r)))
             (trans (cong [_] (left-inverse-of x))
                ([]-respects-relation r)) ≡
           cong [_] eq)
        (elim₁
           (λ eq →
              trans
                (sym ([]-respects-relation
                        (≡⇒↝ _ (sym (cong₂ R₁ eq (refl _))) r)))
                (trans (cong [_] eq) ([]-respects-relation r)) ≡
              cong [_] (refl _))
           (trans
              (sym ([]-respects-relation
                      (≡⇒↝ _ (sym (cong₂ R₁ (refl _) (refl _))) r)))
              (trans (cong [_] (refl _)) ([]-respects-relation r))    ≡⟨ cong₂ (λ eq₁ eq₂ →
                                                                                trans (sym ([]-respects-relation (≡⇒↝ _ eq₁ r)))
                                                                                (trans eq₂ ([]-respects-relation r)))
                                                                           (trans (cong sym $ cong₂-refl R₁) sym-refl)
                                                                           (cong-refl _) ⟩
            trans
              (sym ([]-respects-relation (≡⇒↝ _ (refl _) r)))
              (trans (refl _) ([]-respects-relation r))               ≡⟨ cong₂ (λ eq₁ eq₂ → trans (sym ([]-respects-relation eq₁)) eq₂)
                                                                           (cong (_$ r) ≡⇒↝-refl)
                                                                           (trans-reflˡ _) ⟩
            trans
              (sym ([]-respects-relation r))
              ([]-respects-relation r)                                ≡⟨ trans-symˡ _ ⟩

            refl _                                                    ≡⟨ sym $ cong-refl _ ⟩∎

            cong [_] (refl _)                                         ∎)
           (left-inverse-of x))
        (left-inverse-of y)

-- A preservation lemma for isomorphisms.

/-cong-↔ :
  {A₁ : Type a₁} {R₁ : A₁ → A₁ → Type r₁}
  {A₂ : Type a₂} {R₂ : A₂ → A₂ → Type r₂} →
  ((∀ x y → Is-proposition (R₁ x y)) ⇔
   (∀ x y → Is-proposition (R₂ x y))) →
  (A₁↔A₂ : A₁ ↔[ k ] A₂) →
  (∀ x y →
     R₁ x y ↔[ k ]
     R₂ (to-implication A₁↔A₂ x) (to-implication A₁↔A₂ y)) →
  A₁ / R₁ ↔[ k ] A₂ / R₂
/-cong-↔ {k = k} {R₁ = R₁} {R₂ = R₂} prop A₁↔A₂ R₁↔R₂ =
  from-isomorphism $
  /-cong-≃ prop A₁≃A₂ λ x y →
    R₁ x y                                                ↔⟨ R₁↔R₂ x y ⟩
    R₂ (to-implication A₁↔A₂ x) (to-implication A₁↔A₂ y)  ↝⟨ ≡⇒↝ _ $ cong₂ (λ f g → R₂ (f x) (g y))
                                                                       (to-implication∘from-isomorphism k equivalence)
                                                                       (to-implication∘from-isomorphism k equivalence) ⟩□
    R₂ (_≃_.to A₁≃A₂ x) (_≃_.to A₁≃A₂ y)                  □
  where
  A₁≃A₂ = from-isomorphism A₁↔A₂

------------------------------------------------------------------------
-- The quotients defined here can be related to the ones defined in
-- Quotient

-- If the quotient relation is propositional, then the definition of
-- quotients given in Quotient is equivalent to the one given here.

/≃/ :
  (∀ {x y} → Is-proposition (R x y)) →
  A / R ≃ A Quotient./ R
/≃/ R-prop = Eq.↔⇒≃ (record
  { surjection = record
    { logical-equivalence = record
      { to = rec (λ where
          .[]ʳ → Quotient.[_]

          .[]-respects-relationʳ → Quotient.[]-respects-relation

          .is-setʳ _ → Quotient./-is-set)
      ; from = Quotient.rec λ where
          .Quotient.Rec.[]ʳ → [_]

          .Quotient.Rec.[]-respects-relationʳ → []-respects-relation

          .Quotient.Rec.is-setʳ → /-is-set λ _ _ → R-prop
      }
    ; right-inverse-of = Quotient.elim-prop λ where
        .Quotient.Elim-prop.[]ʳ _ → refl _

        .Quotient.Elim-prop.is-propositionʳ _ → Quotient./-is-set
    }
  ; left-inverse-of = elim-prop λ where
        .Elim-prop.[]ʳ _ → refl _

        .Elim-prop.is-propositionʳ _ → /-is-set λ _ _ → R-prop
  })

------------------------------------------------------------------------
-- The quotients defined here can be related to the ones defined in
-- QF.Families-of-equivalence-classes

private

  -- An alternative definition of the quotients from
  -- QF.Families-of-equivalence-classes.

  infix 5 _/′_

  _/′_ : (A : Type a) → (A → A → Type a) → Type (lsuc a)
  _/′_ {a = a} A R = ∃ λ (P : A → Type a) → ∥ (∃ λ x → R x ≡ P) ∥

  /↔/′ : A QF./ R ↔ A /′ R
  /↔/′ {A = A} {R = R} =
    A QF./ R                                                  ↔⟨⟩
    (∃ λ (P : A → Type _) → Trunc.∥ (∃ λ x → R x ≡ P) ∥ 1 _)  ↝⟨ (∃-cong λ _ → inverse $ TruncP.∥∥↔∥∥ lzero) ⟩
    (∃ λ (P : A → Type _) → ∥ (∃ λ x → R x ≡ P) ∥)            ↔⟨⟩
    A /′ R                                                    □

  [_]′ : A → A /′ R
  [_]′ = _↔_.to /↔/′ ∘ QF.[_]

  rec′ :
    {A : Type a} {R : A → A → Type a} →
    (∀ {x} → R x x) →
    (B : Type a) →
    Is-set B →
    (f : A → B) →
    (∀ {x y} → R x y → f x ≡ f y) →
    A /′ R → B
  rec′ refl B B-set f R⇒≡ =
    QF.rec ext refl B B-set f R⇒≡ ∘
    _↔_.from /↔/′

  elim-Prop′ :
    {A : Type a} {R : A → A → Type a} →
    QF.Strong-equivalence-with surjection R →
    (B : A /′ R → Type (lsuc a)) →
    (∀ x → Is-proposition (B [ x ]′)) →
    (f : ∀ x → B [ x ]′) →
    ∀ x → B x
  elim-Prop′ strong-equivalence B B-prop f x =
    subst B (_↔_.right-inverse-of /↔/′ _) $
      QF.elim-Prop
        ext
        strong-equivalence
        (B ∘ _↔_.to /↔/′)
        B-prop
        f
        (_↔_.from /↔/′ x)

-- If the relation is a propositional equivalence relation of a
-- certain size, then the quotients defined above are isomorphic to
-- families of equivalence relations, defined in a certain way
-- (assuming univalence).

/↔ :
  {A : Type a} {R : A → A → Type a} →
  Univalence a →
  Univalence lzero →
  Is-equivalence-relation R →
  (∀ {x y} → Is-proposition (R x y)) →
  A / R ↔ ∃ λ (P : A → Type a) → ∥ (∃ λ x → R x ≡ P) ∥
/↔ {a = a} {A = A} {R = R} univ univ₀ R-equiv R-prop = record
  { surjection = record
    { logical-equivalence = record
      { to   = to
      ; from = from
      }
    ; right-inverse-of = to∘from
    }
  ; left-inverse-of = from∘to
  }
  where
  R-is-strong-equivalence : QF.Strong-equivalence R
  R-is-strong-equivalence =
    QF.propositional-equivalence⇒strong-equivalence
      ext univ R-equiv (λ _ _ → R-prop)

  to : A / R → A /′ R
  to = rec λ where
    .[]ʳ → [_]′

    .[]-respects-relationʳ {x = x} {y = y} →
      R x y                ↝⟨ _≃_.to (QF.related↝[equal] ext R-is-strong-equivalence) ⟩
      QF.[ x ] ≡ QF.[ y ]  ↝⟨ cong (_↔_.to /↔/′) ⟩□
      [ x ]′ ≡ [ y ]′      □

    .is-setʳ prop →      $⟨ (λ {_ _} → QF.quotient's-h-level-is-1-+-relation's-h-level
                                         ext univ univ₀ 1 (λ _ _ → R-prop)) ⟩
      Is-set (A QF./ R)  ↝⟨ H.respects-surjection (_↔_.surjection /↔/′) 2 ⟩□
      Is-set (A /′ R)    □

  from : A /′ R → A / R
  from = rec′
    (Is-equivalence-relation.reflexive R-equiv)
    _
    (/-is-set λ _ _ → R-prop)
    [_]
    []-respects-relation

  to∘from : ∀ x → to (from x) ≡ x
  to∘from = elim-Prop′
    (QF.strong-equivalence⇒strong-equivalence-with
       R-is-strong-equivalence)
    _
    (λ x →                                         $⟨ (λ {_ _} → QF.quotient's-h-level-is-1-+-relation's-h-level
                                                                   ext univ univ₀ 1 λ _ _ → R-prop) ⟩
       Is-set (A QF./ R)                           ↝⟨ H.respects-surjection (_↔_.surjection /↔/′) 2 ⟩
       Is-set (A /′ R)                             ↝⟨ +⇒≡ {n = 1} ⟩□
       Is-proposition (to (from [ x ]′) ≡ [ x ]′)  □)
    (λ _ → refl _)

  from∘to : ∀ x → from (to x) ≡ x
  from∘to = elim-prop λ where
    .[]ʳ _             → refl _
    .is-propositionʳ _ → /-is-set λ _ _ → R-prop

-- If the relation is a propositional equivalence relation of a
-- certain size, then the definition of quotients given in
-- QF.Families-of-equivalence-classes is isomorphic to the one given
-- here (assuming univalence).

/↔/ :
  {A : Type a} {R : A → A → Type a} →
  Univalence a →
  Univalence lzero →
  Is-equivalence-relation R →
  (R-prop : ∀ {x y} → Is-proposition (R x y)) →
  A QF./ R ↔ A / R
/↔/ {a = a} {A = A} {R = R} univ univ₀ R-equiv R-prop =
  A QF./ R                                                         ↔⟨⟩
  (∃ λ (P : A → Type a) → Trunc.∥ (∃ λ x → R x ≡ P) ∥ 1 (lsuc a))  ↝⟨ (∃-cong λ _ → inverse $ TruncP.∥∥↔∥∥ lzero) ⟩
  (∃ λ (P : A → Type a) →       ∥ (∃ λ x → R x ≡ P) ∥)             ↝⟨ inverse $ /↔ univ univ₀ R-equiv R-prop ⟩□
  A / R                                                            □

------------------------------------------------------------------------
-- Various type formers commute with quotients

-- _⊎_ commutes with quotients if the relations are pointwise
-- propositional.

⊎/-comm :
  (∀ {x y} → Is-proposition (R₁ x y)) →
  (∀ {x y} → Is-proposition (R₂ x y)) →
  (A₁ ⊎ A₂) / (R₁ ⊎ᴾ R₂) ↔ A₁ / R₁ ⊎ A₂ / R₂
⊎/-comm R₁-prop R₂-prop = record
  { surjection = record
    { logical-equivalence = record
      { to = rec λ where
          .[]ʳ          → ⊎-map [_] [_]
          .is-setʳ prop → ⊎-closure 0 is-set₁ is-set₂

          .[]-respects-relationʳ {x = inj₁ _} {y = inj₁ _} →
            cong inj₁ ∘ []-respects-relation
          .[]-respects-relationʳ {x = inj₂ _} {y = inj₂ _} →
            cong inj₂ ∘ []-respects-relation

      ; from = Prelude.[ rec (λ where
                           .[]ʳ                   → [_] ∘ inj₁
                           .[]-respects-relationʳ → []-respects-relation
                           .is-setʳ prop          → is-set₁₂)
                       , rec (λ where
                           .[]ʳ                   → [_] ∘ inj₂
                           .[]-respects-relationʳ → []-respects-relation
                           .is-setʳ prop          → is-set₁₂)
                       ]
      }
    ; right-inverse-of =
        Prelude.[ elim-prop (λ where
                    .[]ʳ _             → refl _
                    .is-propositionʳ _ → ⊎-closure 0 is-set₁ is-set₂)
                , elim-prop (λ where
                    .[]ʳ _             → refl _
                    .is-propositionʳ _ → ⊎-closure 0 is-set₁ is-set₂)
                ]
    }
  ; left-inverse-of = elim-prop λ where
      .[]ʳ               → Prelude.[ (λ _ → refl _) , (λ _ → refl _) ]
      .is-propositionʳ _ → is-set₁₂
  }
  where
  is-set₁  = /-is-set λ _ _ → R₁-prop
  is-set₂  = /-is-set λ _ _ → R₂-prop
  is-set₁₂ = /-is-set λ x y → ⊎ᴾ-preserves-Is-proposition
                                R₁-prop R₂-prop {x = x} {y = y}

-- Maybe commutes with quotients if the relation is pointwise
-- propositional.
--
-- Chapman, Uustalu and Veltri mention a similar result in
-- "Quotienting the Delay Monad by Weak Bisimilarity".

Maybe/-comm :
  (∀ {x y} → Is-proposition (R x y)) →
  Maybe A / Maybeᴾ R ↔ Maybe (A / R)
Maybe/-comm {A = A} {R = R} R-prop =
  Maybe A / Maybeᴾ R   ↝⟨ ⊎/-comm (↑-closure 1 (mono₁ 0 ⊤-contractible)) R-prop ⟩
  ⊤ / Trivial ⊎ A / R  ↝⟨ /trivial↔∥∥ _ (↑-closure 1 (mono₁ 0 ⊤-contractible)) ⊎-cong F.id ⟩
  ∥ ⊤ ∥ ⊎ A / R        ↝⟨ TruncP.∥∥↔ (mono₁ 0 ⊤-contractible) ⊎-cong F.id ⟩□
  Maybe (A / R)        □

-- A simplification lemma for Maybe/-comm.

Maybe/-comm-[] :
  {R : A → A → Type r}
  {R-prop : ∀ {x y} → Is-proposition (R x y)} →
  _↔_.to (Maybe/-comm {R = R} R-prop) ∘ [_] ≡ ⊎-map id [_]
Maybe/-comm-[] {R-prop = R-prop} =
  _↔_.to (Maybe/-comm R-prop) ∘ [_]        ≡⟨⟩
  ⊎-map _ id ∘ ⊎-map _ id ∘ ⊎-map [_] [_]  ≡⟨ cong (_∘ ⊎-map [_] [_]) $ sym $ ⟨ext⟩ ⊎-map-∘ ⟩
  ⊎-map _ id ∘ ⊎-map [_] [_]               ≡⟨ sym $ ⟨ext⟩ ⊎-map-∘ ⟩∎
  ⊎-map id [_]                             ∎

-- The sigma type former commutes (kind of) with quotients, assuming
-- that certain families are propositional.

Σ/-comm :
  {P : A / R → Type p} →
  (∀ {x} → Is-proposition (P x)) →
  (∀ {x y} → Is-proposition (R x y)) →
  Σ (A / R) P ↔ Σ A (P ∘ [_]) / (R on proj₁)
Σ/-comm {A = A} {R = R} {P = P} P-prop R-prop = record
  { surjection = record
    { logical-equivalence = record
      { to =
          uncurry $
          elim λ where
            .[]ʳ → curry [_]
            .[]-respects-relationʳ {x = x} {y = y} r → ⟨ext⟩ λ P[y] →
              subst (λ x → P x → Σ A (P ∘ [_]) / (R on proj₁))
                    ([]-respects-relation r)
                    (curry [_] x) P[y]                               ≡⟨ subst-→-domain P {f = curry [_] _} ([]-respects-relation r) ⟩

              [ (x , subst P (sym $ []-respects-relation r) P[y]) ]  ≡⟨ []-respects-relation r ⟩∎

              [ (y , P[y]) ]                                         ∎
            .is-setʳ prop _ →
              Π-closure ext 2 λ _ →
              /-is-set λ _ _ → prop _ _
      ; from = rec λ where
          .[]ʳ       → Σ-map [_] id
          .is-setʳ _ →
            Σ-closure 2 (/-is-set λ _ _ → R-prop) (λ _ → mono₁ 1 P-prop)

          .[]-respects-relationʳ {x = (x₁ , x₂)} {y = (y₁ , y₂)} →
            R x₁ y₁                        ↝⟨ []-respects-relation ⟩
            [ x₁ ] ≡ [ y₁ ]                ↔⟨ ignore-propositional-component P-prop ⟩
            ([ x₁ ] , x₂) ≡ ([ y₁ ] , y₂)  □
      }
    ; right-inverse-of = elim-prop λ where
        .[]ʳ _             → refl _
        .is-propositionʳ _ → /-is-set λ _ _ → R-prop
    }
  ; left-inverse-of = uncurry $ elim-prop λ where
      .[]ʳ _ _           → refl _
      .is-propositionʳ _ →
        Π-closure ext 1 λ _ →
        Σ-closure 2 (/-is-set λ _ _ → R-prop) (λ _ → mono₁ 1 P-prop)
  }

-- The type former λ X → ℕ → X commutes with quotients, assuming that
-- the quotient relation is a propositional equivalence relation, and
-- also assuming countable choice and propositional extensionality.
--
-- This result is very similar to Proposition 5 in "Quotienting the
-- Delay Monad by Weak Bisimilarity" by Chapman, Uustalu and Veltri.

-- The forward component of the isomorphism. This component can be
-- defined without any extra assumptions.

ℕ→/-comm-to : (ℕ → A) / (ℕ →ᴾ R) → (ℕ → A / R)
ℕ→/-comm-to {A = A} = rec λ where
    .[]ʳ f n → [ f n ]

    .[]-respects-relationʳ r →
      ⟨ext⟩ ([]-respects-relation ∘ r)

    .is-setʳ prop →
      Π-closure ext 2 λ _ →
      /-is-set (prop⇒prop prop)
  where
  prop⇒prop :
    ((f g : ℕ → A) → Is-proposition ((ℕ →ᴾ R) f g)) →
    ((x y : A) → Is-proposition (R x y))
  prop⇒prop prop x y p q =
    cong (_$ 0) $ prop (λ _ → x) (λ _ → y) (λ _ → p) (λ _ → q)

-- The isomorphism.

ℕ→/-comm :
  {A : Type a} {R : A → A → Type r} →
  Axiom-of-countable-choice (a ⊔ r) →
  Propositional-extensionality r →
  Is-equivalence-relation R →
  (∀ {x y} → Is-proposition (R x y)) →
  (ℕ → A) / (ℕ →ᴾ R) ↔ (ℕ → A / R)
ℕ→/-comm {A = A} {R = R} cc prop-ext R-equiv R-prop = record
  { surjection = record
    { logical-equivalence = record
      { to   = ℕ→/-comm-to
      ; from = from unit
      }
    ; right-inverse-of = to∘from unit
    }
  ; left-inverse-of = from∘to unit
  }
  where
  [_]→ : (ℕ → A) → (ℕ → A / R)
  [ f ]→ n = [ f n ]

  -- A module that is introduced to ensure that []→-surjective is not
  -- in the same abstract block as the abstract definitions below.

  module Dummy where

    abstract

      []→-surjective : Surjective [_]→
      []→-surjective f =                    $⟨ []-surjective ⟩
        Surjective [_]                      ↝⟨ (λ surj → surj ∘ f) ⦂ (_ → _) ⟩
        (∀ n → ∥ (∃ λ x → [ x ] ≡ f n) ∥)   ↔⟨ TruncP.countable-choice-bijection cc ⟩
        ∥ (∀ n → ∃ λ x → [ x ] ≡ f n) ∥     ↔⟨ TruncP.∥∥-cong ΠΣ-comm ⟩
        ∥ (∃ λ g → ∀ n → [ g n ] ≡ f n) ∥   ↔⟨⟩
        ∥ (∃ λ g → ∀ n → [ g ]→ n ≡ f n) ∥  ↔⟨ TruncP.∥∥-cong (∃-cong λ _ → Eq.extensionality-isomorphism ext) ⟩□
        ∥ (∃ λ g → [ g ]→ ≡ f) ∥            □

  open Dummy

  from₁ : ∀ f → [_]→ ⁻¹ f → ℕ→/-comm-to ⁻¹ f
  from₁ f (g , [g]→≡f) =
      [ g ]
    , (ℕ→/-comm-to [ g ]  ≡⟨⟩
       [ g ]→             ≡⟨ [g]→≡f ⟩∎
       f                  ∎)

  from₁-constant : ∀ f → Constant (from₁ f)
  from₁-constant f (g₁ , [g₁]→≡f) (g₂ , [g₂]→≡f) =
                                             $⟨ (λ n → cong (_$ n) (
        [ g₁ ]→                                    ≡⟨ [g₁]→≡f ⟩
        f                                          ≡⟨ sym [g₂]→≡f ⟩∎
        [ g₂ ]→                                    ∎)) ⟩

    (∀ n → [ g₁ ]→ n ≡ [ g₂ ]→ n)            ↔⟨⟩

    (∀ n → [ g₁ n ] ≡ [ g₂ n ])              ↔⟨ ∀-cong ext (λ _ → inverse $ related≃[equal] prop-ext R-equiv R-prop) ⟩

    (∀ n → R (g₁ n) (g₂ n))                  ↔⟨⟩

    (ℕ →ᴾ R) g₁ g₂                           ↝⟨ []-respects-relation ⟩

    [ g₁ ] ≡ [ g₂ ]                          ↔⟨ ignore-propositional-component
                                                  (Π-closure ext 2 λ _ →
                                                   /-is-set λ _ _ → R-prop) ⟩□
    ([ g₁ ] , [g₁]→≡f) ≡ ([ g₂ ] , [g₂]→≡f)  □

  from₂ : Unit → ∀ f → ∥ [_]→ ⁻¹ f ∥ → ℕ→/-comm-to ⁻¹ f
  from₂ unit f =
    _≃_.to
      (TruncP.constant-function≃∥inhabited∥⇒inhabited
         (Σ-closure 2
            (/-is-set λ _ _ →
               →ᴾ-preserves-Is-proposition R ext R-prop) λ _ →
            mono₁ 1 (Π-closure ext 2 (λ _ → /-is-set λ _ _ → R-prop))))
      (from₁ f , from₁-constant f)

  unblock-from₂ : ∀ x f p → from₂ x f ∣ p ∣ ≡ from₁ f p
  unblock-from₂ unit _ _ = refl _

  abstract

    from₃ : Unit → (f : ℕ → A / R) → ℕ→/-comm-to ⁻¹ f
    from₃ x f = from₂ x f ([]→-surjective f)

    from : Unit → (ℕ → A / R) → (ℕ → A) / (ℕ →ᴾ R)
    from x f = proj₁ (from₃ x f)

    to∘from : ∀ x f → ℕ→/-comm-to (from x f) ≡ f
    to∘from x f = proj₂ (from₃ x f)

    from∘to : ∀ x f → from x (ℕ→/-comm-to f) ≡ f
    from∘to x = elim-prop λ where
      .[]ʳ f →
        from x (ℕ→/-comm-to [ f ])                      ≡⟨⟩
        proj₁ (from₂ x [ f ]→ ([]→-surjective [ f ]→))  ≡⟨ cong (proj₁ ∘ from₂ x [ f ]→) $ TruncP.truncation-is-proposition _ _ ⟩
        proj₁ (from₂ x [ f ]→ ∣ f , refl _ ∣)           ≡⟨ cong proj₁ $ unblock-from₂ x _ (f , refl _) ⟩
        proj₁ (from₁ [ f ]→ (f , refl _))               ≡⟨⟩
        [ f ]                                           ∎
      .is-propositionʳ _ →
        /-is-set λ _ _ →
          →ᴾ-preserves-Is-proposition R ext R-prop

------------------------------------------------------------------------
-- Quotient-like eliminators

-- If there is a split surjection from a quotient type to some other
-- type, then one can construct a quotient-like eliminator for the
-- other type.
--
-- This kind of construction is used in "Quotienting the Delay Monad
-- by Weak Bisimilarity" by Chapman, Uustalu and Veltri.

↠-eliminator :
  (surj : A / R ↠ B)
  (P : B → Type p)
  (p-[] : ∀ x → P (_↠_.to surj [ x ])) →
  (∀ {x y} (r : R x y) →
   subst P (cong (_↠_.to surj) ([]-respects-relation r)) (p-[] x) ≡
   p-[] y) →
  ((∀ x y → Is-proposition (R x y)) → ∀ x → Is-set (P x)) →
  ∀ x → P x
↠-eliminator surj P p-[] ok P-set x =
  subst P (_↠_.right-inverse-of surj x) p′
  where
  p′ : P (_↠_.to surj (_↠_.from surj x))
  p′ = elim
    (λ where
       .[]ʳ                                     → p-[]
       .[]-respects-relationʳ {x = x} {y = y} r →
         subst (P ∘ _↠_.to surj) ([]-respects-relation r) (p-[] x)       ≡⟨ subst-∘ P (_↠_.to surj) ([]-respects-relation r) ⟩
         subst P (cong (_↠_.to surj) ([]-respects-relation r)) (p-[] x)  ≡⟨ ok r ⟩∎
         p-[] y                                                          ∎
       .is-setʳ prop _ → P-set prop _)
    (_↠_.from surj x)

-- The eliminator "computes" in the "right" way for elements that
-- satisfy a certain property, assuming that the quotient relation is
-- pointwise propositional.

↠-eliminator-[] :
  ∀ (surj : A / R ↠ B)
  (P : B → Type p)
  (p-[] : ∀ x → P (_↠_.to surj [ x ]))
  (ok : ∀ {x y} (r : R x y) →
        subst P (cong (_↠_.to surj) ([]-respects-relation r)) (p-[] x) ≡
        p-[] y)
  (P-set : (∀ x y → Is-proposition (R x y)) → ∀ x → Is-set (P x))
  x →
  (∀ {x y} → Is-proposition (R x y)) →
  _↠_.from surj (_↠_.to surj [ x ]) ≡ [ x ] →
  ↠-eliminator surj P p-[] ok P-set (_↠_.to surj [ x ]) ≡ p-[] x
↠-eliminator-[] {R = R} surj P p-[] ok P-set x R-prop hyp =
  subst P (_↠_.right-inverse-of surj (_↠_.to surj [ x ]))
    (elim e′ (_↠_.from surj (_↠_.to surj [ x ])))          ≡⟨ cong (λ p → subst P p (elim e′ _)) $
                                                              H.respects-surjection surj 2 (/-is-set λ _ _ → R-prop)
                                                                (_↠_.right-inverse-of surj (_↠_.to surj [ x ]))
                                                                (cong (_↠_.to surj) hyp) ⟩
  subst P (cong (_↠_.to surj) hyp)
    (elim e′ (_↠_.from surj (_↠_.to surj [ x ])))          ≡⟨ D.elim
                                                                (λ {x y} p → subst P (cong (_↠_.to surj) p) (elim e′ x) ≡ elim e′ y)
                                                                (λ y →
      subst P (cong (_↠_.to surj) (refl _)) (elim e′ y)            ≡⟨ cong (λ p → subst P p (elim e′ _)) $ cong-refl (_↠_.to surj) ⟩
      subst P (refl _) (elim e′ y)                                 ≡⟨ subst-refl P _ ⟩∎
      elim e′ y                                                    ∎)
                                                                hyp ⟩
  elim e′ [ x ]                                            ≡⟨⟩

  p-[] x                                                   ∎
  where
  e′ = _

-- If there is a bijection from a quotient type to some other type,
-- then one can also construct a quotient-like eliminator for the
-- other type.

↔-eliminator :
  (bij : A / R ↔ B)
  (P : B → Type p)
  (p-[] : ∀ x → P (_↔_.to bij [ x ])) →
  (∀ {x y} (r : R x y) →
   subst P (cong (_↔_.to bij) ([]-respects-relation r)) (p-[] x) ≡
   p-[] y) →
  ((∀ x y → Is-proposition (R x y)) → ∀ x → Is-set (P x)) →
  ∀ x → P x
↔-eliminator bij = ↠-eliminator (_↔_.surjection bij)

-- This latter eliminator always "computes" in the "right" way,
-- assuming that the quotient relation is pointwise propositional.

↔-eliminator-[] :
  ∀ (bij : A / R ↔ B)
  (P : B → Type p)
  (p-[] : ∀ x → P (_↔_.to bij [ x ]))
  (ok : ∀ {x y} (r : R x y) →
        subst P (cong (_↔_.to bij) ([]-respects-relation r)) (p-[] x) ≡
        p-[] y)
  (P-set : (∀ x y → Is-proposition (R x y)) → ∀ x → Is-set (P x)) x →
  (∀ {x y} → Is-proposition (R x y)) →
  ↔-eliminator bij P p-[] ok P-set (_↔_.to bij [ x ]) ≡ p-[] x
↔-eliminator-[] bij P p-[] ok P-set x R-prop =
  ↠-eliminator-[] (_↔_.surjection bij) P p-[] ok P-set x
    R-prop
    (_↔_.left-inverse-of bij [ x ])

-- A quotient-like eliminator for functions of type ℕ → A / R, where R
-- is a propositional equivalence relation. Defined using countable
-- choice and propositional extensionality.
--
-- This eliminator is taken from Corollary 1 in "Quotienting the Delay
-- Monad by Weak Bisimilarity" by Chapman, Uustalu and Veltri.

ℕ→/-elim :
  {A : Type a} {R : A → A → Type r} →
  Axiom-of-countable-choice (a ⊔ r) →
  Propositional-extensionality r →
  Is-equivalence-relation R →
  (∀ {x y} → Is-proposition (R x y)) →
  (P : (ℕ → A / R) → Type p)
  (p-[] : ∀ f → P (λ n → [ f n ])) →
  (∀ {f g} (r : (ℕ →ᴾ R) f g) →
   subst P (cong ℕ→/-comm-to ([]-respects-relation r)) (p-[] f) ≡
   p-[] g) →
  (∀ f → Is-set (P f)) →
  ∀ f → P f
ℕ→/-elim cc prop-ext R-equiv R-prop P p-[] ok P-set =
  ↔-eliminator
    (ℕ→/-comm cc prop-ext R-equiv R-prop)
    P p-[] ok (λ _ → P-set)

-- The eliminator "computes" in the "right" way.

ℕ→/-elim-[] :
  ∀ {A : Type a} {R : A → A → Type r}
  (cc : Axiom-of-countable-choice (a ⊔ r))
  (prop-ext : Propositional-extensionality r)
  (R-equiv : Is-equivalence-relation R)
  (R-prop : ∀ {x y} → Is-proposition (R x y))
  (P : (ℕ → A / R) → Type p)
  (p-[] : ∀ f → P (λ n → [ f n ]))
  (ok : ∀ {f g} (r : (ℕ →ᴾ R) f g) →
        subst P (cong ℕ→/-comm-to ([]-respects-relation r)) (p-[] f) ≡
        p-[] g)
  (P-set : ∀ f → Is-set (P f)) f →
  ℕ→/-elim cc prop-ext R-equiv R-prop P p-[] ok P-set (λ n → [ f n ]) ≡
  p-[] f
ℕ→/-elim-[] {R = R} cc prop-ext R-equiv R-prop P p-[] ok P-set f =
  ↔-eliminator-[]
    (ℕ→/-comm cc prop-ext R-equiv R-prop)
    P p-[] ok (λ _ → P-set) f
    (→ᴾ-preserves-Is-proposition R ext R-prop)


module PatternSynonymMutualBlock where

data D : Set where
  c : D

mutual
  pattern p = c


-- Andreas, 2022-03-07, issue #5809 reported by jamestmartin
-- Regression in Agda 2.6.1.
-- Not reducing irrelevant projections lead to non-inferable elim-terms
-- and consequently to internal errors.
--
-- The fix is to treat irrelevant projections as just functions,
-- retaining their parameters, so that they remain inferable
-- even if not in normal form.

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

-- {-# OPTIONS --no-double-check #-}
-- {-# OPTIONS -v impossible:100 #-}
-- {-# OPTIONS -v tc:40 #-}

open import Agda.Builtin.Equality

record Squash {ℓ} (A : Set ℓ) : Set ℓ where
  constructor squash
  field
    .unsquash : A
open Squash

.test : ∀ {ℓ} {A : Set ℓ} (x : A) (y : Squash A) → {!!}
test x y = {!!}
  where
    help : unsquash (squash x) ≡ unsquash y
    help = refl

-- WAS: internal error.
-- Should succeed with unsolved metas.


module bohm-out where
open import lib
open import general-util
open import cedille-types
open import syntax-util

{- Implementation of the Böhm-Out Algorithm -}

private

  nfoldr : ℕ → ∀ {ℓ} {X : Set ℓ} → X → (ℕ → X → X) → X
  nfoldr zero    z s = z
  nfoldr (suc n) z s = s n (nfoldr n z s)

  nfoldl : ℕ → ∀ {ℓ} {X : Set ℓ} → X → (ℕ → X → X) → X
  nfoldl zero    z s = z
  nfoldl (suc n) z s = nfoldl n (s n z) s

  set-nth : ∀ {ℓ} {X : Set ℓ} → ℕ → X → 𝕃 X → 𝕃 X
  set-nth n x [] = []
  set-nth zero x (x' :: xs) = x :: xs
  set-nth (suc n) x (x' :: xs) = x' :: set-nth n x xs

  -- Böhm Tree
  data BT : Set where
    Node : (n i : ℕ) → 𝕃 BT → BT
  -- n: number of lambdas currently bound
  -- i: head variable
  -- 𝕃 BT: list of arguments

  -- Path to difference
  data path : Set where
    hd : path                  -- Difference in heads
    as : path                  -- Difference in number of arguments
    ps : (n : ℕ) → path → path -- Difference in nth subtrees (recursive)

  -- η functions
  η-expand'' : ℕ → 𝕃 BT → 𝕃 BT
  η-expand'' g [] = []
  η-expand'' g (Node n i b :: bs) =
    Node (suc n) (if i ≥ g then suc i else i) (η-expand'' g b) :: η-expand'' g bs

  η-expand' : ℕ → BT → BT
  η-expand' g (Node n i b) = Node (suc n) (if i ≥ g then suc i else i) (η-expand'' g b)

  η-expand : BT → BT
  η-expand t @ (Node n _ _) with η-expand' (suc n) t
  ...| Node n' i' b' = Node n' i' (b' ++ [ Node n' n' [] ])

  bt-n : BT → ℕ
  bt-n (Node n i b) = n

  η-equate : BT → BT → BT × BT
  η-equate t₁ t₂ =
    nfoldr (bt-n t₂ ∸ bt-n t₁) t₁ (λ _ → η-expand) ,
    nfoldr (bt-n t₁ ∸ bt-n t₂) t₂ (λ _ → η-expand)

  -- η-equates all nodes along path to difference
  η-equate-path : BT → BT → path → BT × BT
  η-equate-path (Node n₁ i₁ b₁) (Node n₂ i₂ b₂) (ps d p) =
    let b-b = h d b₁ b₂ in
    η-equate (Node n₁ i₁ (fst b-b)) (Node n₂ i₂ (snd b-b))
    where
    h : ℕ → 𝕃 BT → 𝕃 BT → 𝕃 BT × 𝕃 BT
    h zero (b₁ :: bs₁) (b₂ :: bs₂) with η-equate-path b₁ b₂ p
    ...| b₁' , b₂' = b₁' :: bs₁ , b₂' :: bs₂
    h (suc d) (b₁ :: bs₁) (b₂ :: bs₂) with h d bs₁ bs₂
    ...| bs₁' , bs₂' = b₁ :: bs₁' , b₂ :: bs₂'
    h d b₁ b₂ = b₁ , b₂
  η-equate-path t₁ t₂ p = η-equate t₁ t₂

  -- Rotation functions
  rotate : (k : ℕ) → BT
  rotate k =
    Node (suc k) (suc k) (nfoldl k [] (λ k' → Node (suc k) (suc k') [] ::_))

  rotate-BT' : ℕ → 𝕃 BT → 𝕃 BT
  rotate-BT' k [] = []
  rotate-BT' k (Node n i b :: bs) with i =ℕ k
  ...| ff = Node n i (rotate-BT' k b) :: rotate-BT' k bs
  ...| tt = Node (suc n) (suc n) (η-expand'' (suc n) (rotate-BT' k b)) :: rotate-BT' k bs
  rotate-BT : ℕ → BT → BT
  rotate-BT k (Node n i b) with i =ℕ k
  ...| ff = Node n i (rotate-BT' k b)
  ...| tt = Node (suc n) (suc n) (η-expand'' (suc n) (rotate-BT' k b))

  -- Returns the greatest number of arguments k ever has at each node it where it is the head
  greatest-apps' : ℕ → 𝕃 BT → ℕ
  greatest-apps' k [] = zero
  greatest-apps' k (Node n k' bs' :: bs) with k =ℕ k'
  ...| ff = max (greatest-apps' k bs') (greatest-apps' k bs)
  ...| tt = max (length bs') (max (greatest-apps' k bs') (greatest-apps' k bs))
  greatest-apps : ℕ → BT → ℕ
  greatest-apps k (Node n i b) with k =ℕ i
  ...| ff = greatest-apps' k b
  ...| tt = max (length b) (greatest-apps' k b)
  greatest-η' : ℕ → ℕ → 𝕃 BT → 𝕃 BT
  greatest-η' k m [] = []
  greatest-η' k m (Node n i bs :: bs') with k =ℕ i
  ...| ff = Node n i (greatest-η' k m bs) :: greatest-η' k m bs'
  ...| tt = nfoldr (m ∸ length bs) (Node n i (greatest-η' k m bs)) (λ _ → η-expand) :: greatest-η' k m bs'
  greatest-η : ℕ → ℕ → BT → BT
  greatest-η k m (Node n i b) with k =ℕ i
  ...| ff = Node n i (greatest-η' k m b)
  ...| tt = nfoldr (m ∸ length b) (Node n i (greatest-η' k m b)) (λ _ → η-expand)

  -- Returns tt if k ever is at the head of a node along the path to the difference
  occurs-in-path : ℕ → BT → path → 𝔹
  occurs-in-path k (Node n i b) (ps d p) =
    k =ℕ i || maybe-else ff (λ t → occurs-in-path k t p) (nth d b)
  occurs-in-path k (Node n i b) p = k =ℕ i

  adjust-path : ℕ → BT → path → path
  adjust-path k (Node n i b) (ps d p) = maybe-else' (nth d b) (ps d p) λ n → ps d (adjust-path k n p)
  adjust-path k (Node n i b) as with k =ℕ i
  ...| tt = hd
  ...| ff = as
  adjust-path k (Node n i b) hd = hd

  -- Δ functions
  construct-BT : term → maybe BT
  construct-BT = h zero empty-trie Node where
    h : ℕ → trie ℕ → ((n i : ℕ) → 𝕃 BT → BT) → term → maybe BT
    h n vm f (Var _ x) = just (f n (trie-lookup-else zero vm x) [])
    h n vm f (App t NotErased t') =
      h n vm Node t' ≫=maybe λ t' →
      h n vm (λ n i b → f n i (b ++ [ t' ])) t
    h n vm f (Lam _ NotErased _ x NoClass t) = h (suc n) (trie-insert vm x (suc n)) f t
    h n vm f t = nothing

  {-# TERMINATING #-}
  construct-path' : BT → BT → maybe (path × BT × BT)
  construct-path : BT → BT → maybe (path × BT × BT)
  construct-path (Node _ zero _) _ = nothing
  construct-path _ (Node _ zero _) = nothing
  construct-path t₁ t₂ = uncurry construct-path' (η-equate t₁ t₂)
  construct-path' t₁ @ (Node n₁ i₁ b₁) t₂ @ (Node n₂ i₂ b₂) =
    if ~ i₁ =ℕ i₂
      then just (hd , t₁ , t₂)
      else if length b₁ =ℕ length b₂
        then maybe-map (λ {(p , b₁ , b₂) → p , Node n₁ i₁ b₁ , Node n₂ i₂ b₂}) (h zero b₁ b₂)
        else just (as , t₁ , t₂)
    where
    h : ℕ → 𝕃 BT → 𝕃 BT → maybe (path × 𝕃 BT × 𝕃 BT)
    h n (b₁ :: bs₁) (b₂ :: bs₂) =
      maybe-else
        (maybe-map (λ {(p , bs₁ , bs₂) → p , b₁ :: bs₁ , b₂ :: bs₂}) (h (suc n) bs₁ bs₂))
        (λ {(p , b₁ , b₂) → just (ps n p , b₁ :: bs₁ , b₂ :: bs₂)})
        (construct-path b₁ b₂)
    h _ _ _ = nothing

  {-# TERMINATING #-}
  construct-Δ : BT → BT → path → 𝕃 BT
  construct-Δ (Node n₁ i₁ b₁) (Node n₂ i₂ b₂) hd =
    nfoldl n₁ [] λ m → _::_
      (if suc m =ℕ i₁
        then Node (2 + length b₁) (1 + length b₁) []
        else if suc m =ℕ i₂
          then Node (2 + length b₂) (2 + length b₂) []
          else Node 1 1 [])
  construct-Δ (Node n₁ i₁ b₁) (Node n₂ i₂ b₂) as =
    let l₁ = length b₁
        l₂ = length b₂
        d = l₁ > l₂
        lM = if d then l₁ else l₂
        lm = if d then l₂ else l₁
        l = lM ∸ lm in
    nfoldl n₁
      (nfoldr l [ Node (2 + l) ((if d then 1 else 2) + l) [] ]
         λ l' → _++
           [ if suc l' =ℕ l
               then Node 2 (if d then 2 else 1) []
               else Node 1 1 [] ])
     (λ n' → _::_
       (if suc n' =ℕ i₁
         then Node (suc lM) (suc lM) []
         else Node 1 1 []))
  construct-Δ t₁ @ (Node n₁ i₁ b₁) t₂ @ (Node n₂ i₂ b₂) (ps d p)
    with nth d b₁ ≫=maybe λ b₁ → nth d b₂ ≫=maybe λ b₂ → just (b₁ , b₂)
  ...| nothing = [] -- Shouldn't happen
  ...| just (t₁' @ (Node n₁' i₁' b₁') , t₂' @ (Node n₂' i₂' b₂'))
    with occurs-in-path i₁ t₁' p || occurs-in-path i₂ t₂' p
  ...| ff = set-nth (pred i₁) (Node (length b₁) (suc d) []) (construct-Δ t₁' t₂' p)
  ...| tt with max (greatest-apps i₁ t₁) (greatest-apps i₂ t₂)
  ...| kₘ with η-equate-path (rotate-BT i₁ (greatest-η i₁ kₘ t₁))
                             (rotate-BT i₂ (greatest-η i₂ kₘ t₂)) (ps d p)
  ...| t₁'' , t₂'' = set-nth (pred i₁) (rotate kₘ) (construct-Δ t₁'' t₂'' (ps d $ adjust-path i₁ t₁' p))

  reconstruct : BT → term
  reconstruct = h zero where
    mkvar : ℕ → var
    mkvar n = "x" ^ ℕ-to-string n
    h : ℕ → BT → term
    a : ℕ → term → 𝕃 BT → term
    a n t [] = t
    a n t (b :: bs) = a n (mapp t (h n b)) bs
    h m (Node n i b) = nfoldl (n ∸ m) (a n (mvar (mkvar i)) b) (λ nm → mlam (mkvar (suc (m + nm))))

-- Returns a term f such that f t₁ ≃ λ t. λ f. t and f t₂ ≃ λ t. λ f. f, assuming two things:
-- 1. t₁ ≄ t₂
-- 2. The head of each node along the path to the difference between t₁ and t₂ is bound
--    withing the terms (so λ x. λ y. y y (x y) and λ x. λ y. y y (x x) works, but not
--    λ x. λ y. y y (f y), where f is already declared/defined)
make-contradiction : (t₁ t₂ : term) → maybe term
make-contradiction t₁ t₂ =
  construct-BT t₁ ≫=maybe λ t₁ →
  construct-BT t₂ ≫=maybe λ t₂ →
  construct-path t₁ t₂ ≫=maybe λ {(p , t₁ , t₂) →
  just (reconstruct (Node (suc zero) (suc zero)
    (map (η-expand' zero) (construct-Δ t₁ t₂ p))))}

-- Returns tt if the two terms are provably not equal
is-contradiction : term → term → 𝔹
is-contradiction t₁ t₂ = isJust (make-contradiction t₁ t₂)


open import Agda.Builtin.Unit
open import Agda.Builtin.Bool
open import Agda.Builtin.Sigma

data ⊥ : Set where

type : Bool → Set
type true = ⊤
type false = ⊥

record Bad : Set where
  constructor b
  field
    .f : Σ Bool type

test : Bad → Bool
test (b (x , y)) = x


------------------------------------------------------------------------
-- The parser equivalence proof language is sound
------------------------------------------------------------------------

module TotalParserCombinators.Congruence.Sound where

open import Category.Monad
open import Codata.Musical.Notation
open import Data.List
open import Data.List.Membership.Propositional using (_∈_)
import Data.List.Categorical as ListMonad
open import Data.List.Relation.Binary.BagAndSetEquality
  renaming (_∼[_]_ to _List-∼[_]_)
open import Data.Maybe hiding (_>>=_)
open import Data.Product
open import Function
import Function.Related as Related
open import Level
open import Relation.Binary
import Relation.Binary.PropositionalEquality as P

open Related using (SK-sym)
open Related.EquationalReasoning
  renaming (_∼⟨_⟩_ to _∼⟨_⟩′_; _∎ to _∎′)
open RawMonad {f = zero} ListMonad.monad
  using () renaming (_⊛_ to _⊛′_; _>>=_ to _>>=′_)
private
  module BSOrd {k} {A : Set} = Preorder ([ k ]-Order A)

open import TotalParserCombinators.Derivative using (D)
open import TotalParserCombinators.CoinductiveEquality as CE
  using (_∼[_]c_; _∷_)
open import TotalParserCombinators.Congruence
open import TotalParserCombinators.Laws
open import TotalParserCombinators.Lib using (return⋆)
open import TotalParserCombinators.Parser
open import TotalParserCombinators.Semantics using (_∼[_]_)

------------------------------------------------------------------------
-- Some lemmas

private

  ⊛flatten-lemma : ∀ {k} {R₁ R₂ : Set} {fs₁ fs₂ : List (R₁ → R₂)}
                   (xs₁ xs₂ : Maybe (List R₁)) →
                   fs₁ List-∼[ k ] fs₂ →
                   flatten xs₁ List-∼[ k ] flatten xs₂ →
                   fs₁ ⊛flatten xs₁ List-∼[ k ] fs₂ ⊛flatten xs₂
  ⊛flatten-lemma {k} {fs₁ = fs₁} {fs₂} xs₁ xs₂ fs₁≈fs₂ = helper xs₁ xs₂
    where
    helper : ∀ xs₁ xs₂ →
             flatten xs₁ List-∼[ k ] flatten xs₂ →
             fs₁ ⊛flatten xs₁ List-∼[ k ] fs₂ ⊛flatten xs₂
    helper nothing    nothing     []∼[]      = BSOrd.refl
    helper (just xs₁) (just xs₂) xs₁≈xs₂     = ⊛-cong fs₁≈fs₂ xs₁≈xs₂
    helper nothing    (just xs₂)  []≈xs₂ {x} =
      x ∈ []            ↔⟨ BSOrd.reflexive $ P.sym $
                             ListMonad.Applicative.right-zero fs₂ ⟩
      x ∈ (fs₂ ⊛′ [])   ∼⟨ ⊛-cong (BSOrd.refl {x = fs₂}) []≈xs₂ ⟩′
      x ∈ (fs₂ ⊛′ xs₂)  ∎′
    helper (just xs₁) nothing    xs₁∼[]  {x} =
      x ∈ (fs₁ ⊛′ xs₁)  ∼⟨ ⊛-cong (BSOrd.refl {x = fs₁}) xs₁∼[] ⟩′
      x ∈ (fs₁ ⊛′ [])   ↔⟨ BSOrd.reflexive $
                             ListMonad.Applicative.right-zero fs₁ ⟩
      x ∈ []            ∎′

  []-⊛flatten : ∀ {A B : Set} (xs : Maybe (List A)) →
                [] ⊛flatten xs List-∼[ bag ] [] {A = B}
  []-⊛flatten nothing   = BSOrd.refl
  []-⊛flatten (just xs) = BSOrd.refl

  bind-lemma : ∀ {k} {R₁ R₂ : Set} {xs₁ xs₂ : Maybe (List R₁)}
               (f₁ f₂ : Maybe (R₁ → List R₂)) →
               flatten xs₁ List-∼[ k ] flatten xs₂ →
               (∀ x → apply f₁ x List-∼[ k ] apply f₂ x) →
               bind xs₁ f₁ List-∼[ k ] bind xs₂ f₂
  bind-lemma {k} {xs₁ = xs₁} {xs₂} f₁ f₂ xs₁≈xs₂ = helper f₁ f₂
    where
    helper : ∀ f₁ f₂ →
             (∀ x → apply f₁ x List-∼[ k ] apply f₂ x) →
             bind xs₁ f₁ List-∼[ k ] bind xs₂ f₂
    helper nothing   nothing   []∼[]     = BSOrd.refl
    helper (just f₁) (just f₂) f₁≈f₂     = >>=-cong xs₁≈xs₂ f₁≈f₂
    helper nothing   (just f₂) []≈f₂ {x} =
      x ∈ []                           ∼⟨ BSOrd.reflexive $ P.sym $
                                             ListMonad.MonadProperties.right-zero (flatten xs₂) ⟩′
      x ∈ (flatten xs₂ >>=′ λ _ → [])  ∼⟨ >>=-cong (BSOrd.refl {x = flatten xs₂}) []≈f₂ ⟩′
      x ∈ (flatten xs₂ >>=′ f₂)        ∎′
    helper (just f₁) nothing   f₁∼[] {x} =
      x ∈ (flatten xs₁ >>=′ f₁)        ∼⟨ >>=-cong (BSOrd.refl {x = flatten xs₁}) f₁∼[] ⟩′
      x ∈ (flatten xs₁ >>=′ λ _ → [])  ∼⟨ BSOrd.reflexive $
                                            ListMonad.MonadProperties.right-zero (flatten xs₁) ⟩′
      x ∈ []                           ∎′

  bind-nothing : ∀ {A B : Set} (f : Maybe (A → List B)) →
                 bind nothing f List-∼[ bag ] []
  bind-nothing nothing  = BSOrd.refl
  bind-nothing (just f) = BSOrd.refl

------------------------------------------------------------------------
-- Equality is closed under initial-bag

initial-bag-cong :
  ∀ {k Tok R xs₁ xs₂} {p₁ : Parser Tok R xs₁} {p₂ : Parser Tok R xs₂} →
  p₁ ∼[ k ]P p₂ → initial-bag p₁ List-∼[ k ] initial-bag p₂
initial-bag-cong (xs₁≈xs₂ ∷ Dp₁≈Dp₂)   = xs₁≈xs₂
initial-bag-cong (p ∎)                 = BSOrd.refl
initial-bag-cong (p₁ ∼⟨ p₁≈p₂ ⟩ p₂≈p₃) = _ ∼⟨ initial-bag-cong p₁≈p₂ ⟩′ initial-bag-cong p₂≈p₃
initial-bag-cong (p₁ ≅⟨ p₁≅p₂ ⟩ p₂≈p₃) = _ ↔⟨ initial-bag-cong p₁≅p₂ ⟩  initial-bag-cong p₂≈p₃
initial-bag-cong (sym p₁≈p₂)           = SK-sym (initial-bag-cong p₁≈p₂)
initial-bag-cong (return x₁≡x₂)        = BSOrd.reflexive $ P.cong [_] x₁≡x₂
initial-bag-cong fail                  = BSOrd.refl
initial-bag-cong token                 = BSOrd.refl
initial-bag-cong (p₁≈p₃ ∣ p₂≈p₄)       = ++-cong (initial-bag-cong p₁≈p₃) (initial-bag-cong p₂≈p₄)
initial-bag-cong (f₁≗f₂ <$> p₁≈p₂)     = map-cong f₁≗f₂ $ initial-bag-cong p₁≈p₂
initial-bag-cong (nonempty p₁≈p₂)      = BSOrd.refl

initial-bag-cong (cast {xs₁  = xs₁}  {xs₂  = xs₂}
                       {xs₁′ = xs₁′} {xs₂′ = xs₂′}
                       {xs₁≈xs₁′ = xs₁≈xs₁′} {xs₂≈xs₂′ = xs₂≈xs₂′}
                       p₁≈p₂) {x} =
  x ∈ xs₁′  ↔⟨ SK-sym xs₁≈xs₁′ ⟩
  x ∈ xs₁   ∼⟨ initial-bag-cong p₁≈p₂ ⟩′
  x ∈ xs₂   ↔⟨ xs₂≈xs₂′ ⟩
  x ∈ xs₂′  ∎′

initial-bag-cong ([ nothing          - _       ] p₁≈p₃ ⊛ p₂≈p₄)     = BSOrd.refl
initial-bag-cong ([ just (xs₁ , xs₂) - just _  ] p₁≈p₃ ⊛ p₂≈p₄)     = ⊛flatten-lemma xs₁ xs₂
                                                                        (initial-bag-cong p₁≈p₃) (initial-bag-cong p₂≈p₄)
initial-bag-cong ([ just (xs₁ , xs₂) - nothing ] p₁≈p₃ ⊛ p₂≈p₄) {x} =
  x ∈ [] ⊛flatten xs₁  ↔⟨ []-⊛flatten xs₁ ⟩
  x ∈ []               ↔⟨ SK-sym $ []-⊛flatten xs₂ ⟩
  x ∈ [] ⊛flatten xs₂  ∎′

initial-bag-cong ([ nothing        - _       ] p₁≈p₃ >>= p₂≈p₄)     = BSOrd.refl
initial-bag-cong ([ just (f₁ , f₂) - just _  ] p₁≈p₃ >>= p₂≈p₄)     = bind-lemma f₁ f₂
                                                                        (initial-bag-cong p₁≈p₃) (λ x → initial-bag-cong (p₂≈p₄ x))
initial-bag-cong ([ just (f₁ , f₂) - nothing ] p₁≈p₃ >>= p₂≈p₄) {x} =
  x ∈ bind nothing f₁  ↔⟨ bind-nothing f₁ ⟩
  x ∈ []               ↔⟨ SK-sym $ bind-nothing f₂ ⟩
  x ∈ bind nothing f₂  ∎′

------------------------------------------------------------------------
-- Equality is closed under D

D-cong : ∀ {k Tok R xs₁ xs₂}
           {p₁ : Parser Tok R xs₁} {p₂ : Parser Tok R xs₂} →
         p₁ ∼[ k ]P p₂ → ∀ {t} → D t p₁ ∼[ k ]P D t p₂
D-cong (xs₁≈xs₂ ∷ Dp₁≈Dp₂)   {t} = ♭ (Dp₁≈Dp₂ t)
D-cong (p ∎)                 {t} = D t p ∎
D-cong (p₁ ∼⟨ p₁≈p₂ ⟩ p₂≈p₃) {t} = D t p₁ ∼⟨ D-cong p₁≈p₂ ⟩ D-cong p₂≈p₃
D-cong (p₁ ≅⟨ p₁≅p₂ ⟩ p₂≈p₃) {t} = D t p₁ ≅⟨ D-cong p₁≅p₂ ⟩ D-cong p₂≈p₃
D-cong (sym p₁≈p₂)               = _∼[_]P_.sym (D-cong p₁≈p₂)
D-cong (return x₁≡x₂)            = fail ∎
D-cong fail                      = fail ∎
D-cong token                 {t} = return t ∎
D-cong (p₁≈p₃ ∣ p₂≈p₄)           = D-cong p₁≈p₃ ∣ D-cong p₂≈p₄
D-cong (f₁≗f₂ <$> p₁≈p₂)         = f₁≗f₂ <$> D-cong p₁≈p₂
D-cong (nonempty p₁≈p₂)          = D-cong p₁≈p₂
D-cong (cast p₁≈p₂)              = D-cong p₁≈p₂

D-cong ([_-_]_⊛_ nothing nothing {p₁} {p₂} {p₃} {p₄} p₁≈p₃ p₂≈p₄) {t} =
  D t (p₁ ⊛ p₂)  ∼⟨ [ nothing - just (○ , ○) ] ♯ D-cong (♭ p₁≈p₃) ⊛ ♭ p₂≈p₄ ⟩
  D t (p₃ ⊛ p₄)  ∎
D-cong ([_-_]_⊛_ nothing (just (fs₁ , fs₂)) {p₁} {p₂} {p₃} {p₄} p₁≈p₃ p₂≈p₄) {t} =
  D t (p₁ ⊛ p₂)                                               ≅⟨ D.D-⊛ p₁ p₂ ⟩
    D t (♭ p₁) ⊛ ♭? p₂ ∣ return⋆ (flatten fs₁) ⊛ D t (♭? p₂)  ≅⟨ [ ○ - ◌ - ○ - ○ ] D t (♭ p₁) ∎ ⊛ (♭? p₂ ∎) ∣ (_ ∎) ⟩
  ♯ D t (♭ p₁) ⊛ ♭? p₂ ∣ return⋆ (flatten fs₁) ⊛ D t (♭? p₂)  ∼⟨ [ nothing - just (○ , ○) ] ♯ D-cong (♭ p₁≈p₃) ⊛ p₂≈p₄ ∣
                                                                 [ just (○ , ○) - just (○ , ○) ]
                                                                   Return⋆.cong (initial-bag-cong (♭ p₁≈p₃)) ⊛ D-cong p₂≈p₄ ⟩
  ♯ D t (♭ p₃) ⊛ ♭? p₄ ∣ return⋆ (flatten fs₂) ⊛ D t (♭? p₄)  ≅⟨ [ ◌ - ○ - ○ - ○ ] D t (♭ p₃) ∎ ⊛ (♭? p₄ ∎) ∣ (_ ∎) ⟩
    D t (♭ p₃) ⊛ ♭? p₄ ∣ return⋆ (flatten fs₂) ⊛ D t (♭? p₄)  ≅⟨ _∼[_]P_.sym $ D.D-⊛ p₃ p₄ ⟩
  D t (p₃ ⊛ p₄)                                               ∎
D-cong ([_-_]_⊛_ (just _) nothing {p₁} {p₂} {p₃} {p₄} p₁≈p₃ p₂≈p₄) {t} =
  D t (p₁ ⊛ p₂)                                   ≅⟨ D.D-⊛ p₁ p₂ ⟩
  D t (♭? p₁) ⊛ ♭ p₂ ∣ return⋆ [] ⊛   D t (♭ p₂)  ≅⟨ (D t (♭? p₁) ⊛ ♭ p₂ ∎) ∣
                                                     [ ○ - ○ - ○ - ◌ ] return⋆ [] ∎ ⊛ (D t (♭ p₂) ∎) ⟩
  D t (♭? p₁) ⊛ ♭ p₂ ∣ return⋆ [] ⊛ ♯ D t (♭ p₂)  ∼⟨ [ just (○ , ○) - just (○ , ○) ] D-cong p₁≈p₃ ⊛ ♭ p₂≈p₄ ∣
                                                     [ just (○ , ○) - nothing ] (return⋆ [] ∎) ⊛ ♯ D-cong (♭ p₂≈p₄) ⟩
  D t (♭? p₃) ⊛ ♭ p₄ ∣ return⋆ [] ⊛ ♯ D t (♭ p₄)  ≅⟨ (D t (♭? p₃) ⊛ ♭ p₄ ∎) ∣
                                                     [ ○ - ○ - ◌ - ○ ] return⋆ [] ∎ ⊛ (D t (♭ p₄) ∎) ⟩
  D t (♭? p₃) ⊛ ♭ p₄ ∣ return⋆ [] ⊛   D t (♭ p₄)  ≅⟨ _∼[_]P_.sym $ D.D-⊛ p₃ p₄ ⟩
  D t (p₃ ⊛ p₄)                                   ∎
D-cong ([_-_]_⊛_ (just _) (just (fs₁ , fs₂)) {p₁} {p₂} {p₃} {p₄} p₁≈p₃ p₂≈p₄) {t} =
  D t (p₁ ⊛ p₂)                                              ≅⟨ D.D-⊛ p₁ p₂ ⟩
  D t (♭? p₁) ⊛ ♭? p₂ ∣ return⋆ (flatten fs₁) ⊛ D t (♭? p₂)  ∼⟨ [ just (○ , ○) - just (○ , ○) ] D-cong p₁≈p₃ ⊛ p₂≈p₄ ∣
                                                                [ just (○ , ○) - just (○ , ○) ] Return⋆.cong (initial-bag-cong p₁≈p₃) ⊛
                                                                                D-cong p₂≈p₄ ⟩
  D t (♭? p₃) ⊛ ♭? p₄ ∣ return⋆ (flatten fs₂) ⊛ D t (♭? p₄)  ≅⟨ _∼[_]P_.sym $ D.D-⊛ p₃ p₄ ⟩
  D t (p₃ ⊛ p₄)                                              ∎

D-cong ([_-_]_>>=_ nothing nothing {p₁} {p₂} {p₃} {p₄} p₁≈p₃ p₂≈p₄) {t} =
  D t (p₁ >>= p₂)  ∼⟨ [ nothing - just (○ , ○) ] ♯ D-cong (♭ p₁≈p₃) >>= (♭ ∘ p₂≈p₄) ⟩
  D t (p₃ >>= p₄)  ∎
D-cong ([_-_]_>>=_ nothing (just (xs₁ , xs₂)) {p₁} {p₂} {p₃} {p₄} p₁≈p₃ p₂≈p₄) {t} =
  D t (p₁ >>= p₂)                                                         ≅⟨ D.D->>= p₁ p₂ ⟩
    D t (♭ p₁) >>= (♭? ∘ p₂) ∣ return⋆ (flatten xs₁) >>= (D t ∘ ♭? ∘ p₂)  ≅⟨ [ ○ - ◌ - ○ - ○ ] D t (♭ p₁) ∎ >>= (λ x → ♭? (p₂ x) ∎) ∣
                                                                             (_ ∎) ⟩
  ♯ D t (♭ p₁) >>= (♭? ∘ p₂) ∣ return⋆ (flatten xs₁) >>= (D t ∘ ♭? ∘ p₂)  ∼⟨ [ nothing - just (○ , ○) ] ♯ D-cong (♭ p₁≈p₃) >>= p₂≈p₄ ∣
                                                                             [ just (○ , ○) - just (○ , ○) ]
                                                                               Return⋆.cong (initial-bag-cong (♭ p₁≈p₃)) >>=
                                                                               (λ x → D-cong (p₂≈p₄ x)) ⟩
  ♯ D t (♭ p₃) >>= (♭? ∘ p₄) ∣ return⋆ (flatten xs₂) >>= (D t ∘ ♭? ∘ p₄)  ≅⟨ [ ◌ - ○ - ○ - ○ ] D t (♭ p₃) ∎ >>= (λ x → ♭? (p₄ x) ∎) ∣
                                                                             (_ ∎) ⟩
    D t (♭ p₃) >>= (♭? ∘ p₄) ∣ return⋆ (flatten xs₂) >>= (D t ∘ ♭? ∘ p₄)  ≅⟨ _∼[_]P_.sym $ D.D->>= p₃ p₄ ⟩
  D t (p₃ >>= p₄)                                                         ∎
D-cong ([_-_]_>>=_ (just _) nothing {p₁} {p₂} {p₃} {p₄} p₁≈p₃ p₂≈p₄) {t} =
  D t (p₁ >>= p₂)                                                     ≅⟨ D.D->>= p₁ p₂ ⟩
  D t (♭? p₁) >>= (♭ ∘ p₂) ∣ return⋆ [] >>= (D t ∘ ♭ ∘ p₂)            ≅⟨ (D t (♭? p₁) >>= (♭ ∘ p₂) ∎) ∣
                                                                         [ ○ - ○ - ○ - ◌ ] return⋆ [] ∎ >>= (λ x → D t (♭ (p₂ x)) ∎) ⟩
  D t (♭? p₁) >>= (♭ ∘ p₂) ∣ return⋆ [] >>= (λ x → ♯ D t (♭ (p₂ x)))  ∼⟨ [ just (○ , ○) - just (○ , ○) ] D-cong p₁≈p₃ >>= (♭ ∘ p₂≈p₄) ∣
                                                                         [ just (○ , ○) - nothing ] (return⋆ [] ∎) >>=
                                                                                (λ x → ♯ D-cong (♭ (p₂≈p₄ x))) ⟩
  D t (♭? p₃) >>= (♭ ∘ p₄) ∣ return⋆ [] >>= (λ x → ♯ D t (♭ (p₄ x)))  ≅⟨ (D t (♭? p₃) >>= (♭ ∘ p₄) ∎) ∣
                                                                         [ ○ - ○ - ◌ - ○ ] return⋆ [] ∎ >>= (λ x → D t (♭ (p₄ x)) ∎) ⟩
  D t (♭? p₃) >>= (♭ ∘ p₄) ∣ return⋆ [] >>= (D t ∘ ♭ ∘ p₄)            ≅⟨ _∼[_]P_.sym $ D.D->>= p₃ p₄ ⟩
  D t (p₃ >>= p₄)                                                     ∎
D-cong ([_-_]_>>=_ (just _) (just (xs₁ , xs₂)) {p₁} {p₂} {p₃} {p₄} p₁≈p₃ p₂≈p₄) {t} =
  D t (p₁ >>= p₂)                                                        ≅⟨ D.D->>= p₁ p₂ ⟩
  D t (♭? p₁) >>= (♭? ∘ p₂) ∣ return⋆ (flatten xs₁) >>= (D t ∘ ♭? ∘ p₂)  ∼⟨ [ just (○ , ○) - just (○ , ○) ] D-cong p₁≈p₃ >>= p₂≈p₄ ∣
                                                                            [ just (○ , ○) - just (○ , ○) ]
                                                                              Return⋆.cong (initial-bag-cong p₁≈p₃) >>=
                                                                              (λ x → D-cong (p₂≈p₄ x)) ⟩
  D t (♭? p₃) >>= (♭? ∘ p₄) ∣ return⋆ (flatten xs₂) >>= (D t ∘ ♭? ∘ p₄)  ≅⟨ _∼[_]P_.sym $ D.D->>= p₃ p₄ ⟩
  D t (p₃ >>= p₄)                                                        ∎

------------------------------------------------------------------------
-- Soundness

sound : ∀ {k Tok R xs₁ xs₂}
          {p₁ : Parser Tok R xs₁}
          {p₂ : Parser Tok R xs₂} →
        p₁ ∼[ k ]P p₂ → p₁ ∼[ k ] p₂
sound = CE.sound ∘ sound′
  where
  sound′ : ∀ {k Tok R xs₁ xs₂}
             {p₁ : Parser Tok R xs₁}
             {p₂ : Parser Tok R xs₂} →
           p₁ ∼[ k ]P p₂ → p₁ ∼[ k ]c p₂
  sound′ p₁≈p₂ = initial-bag-cong p₁≈p₂ ∷ λ t → ♯ sound′ (D-cong p₁≈p₂)


open import Prelude

module Implicits.Resolution.Deterministic.Resolution where

open import Data.Fin.Substitution
open import Data.List
open import Data.List.All

open import Implicits.Syntax
open import Implicits.Syntax.Type.Unification
open import Implicits.Substitutions
open import Extensions.ListFirst

infixl 4 _⊢ᵣ_ _⊢_↓_ _⟨_⟩=_
infixl 6 _◁_

data _◁_ {ν} : Type ν → SimpleType ν → Set where
  m-simp : ∀ {a} → simpl a ◁ a
  m-tabs   : ∀ {a r} b → r tp[/tp b ] ◁ a → ∀' r ◁ a
  m-iabs   : ∀ {a b r} → r ◁ a → b ⇒ r ◁ a

_⟨_⟩=_ : ∀ {ν} (Δ : ICtx ν) → SimpleType ν → Type ν → Set
Δ ⟨ τ ⟩= r = first r ∈ Δ ⇔ (flip _◁_ τ)

mutual
  data _⊢_↓_ {ν} (K : ICtx ν) : Type ν → SimpleType ν → Set where
    i-simp : ∀ a → K ⊢ simpl a ↓ a
    i-iabs : ∀ {ρ₁ ρ₂ a} → K ⊢ᵣ ρ₁ → K ⊢ ρ₂ ↓ a → K ⊢ ρ₁ ⇒ ρ₂ ↓ a
    i-tabs : ∀ {ρ a} b → K ⊢ ρ tp[/tp b ] ↓ a → K ⊢ ∀' ρ ↓ a

  data _⊢ᵣ_ {ν} (K : ICtx ν) : Type ν → Set where
    r-simp : ∀ {τ ρ} → K ⟨ τ ⟩= ρ → K ⊢ ρ ↓ τ → K ⊢ᵣ simpl τ
    r-iabs : ∀ ρ₁ {ρ₂} → ρ₁ ∷ K ⊢ᵣ ρ₂ → K ⊢ᵣ ρ₁ ⇒ ρ₂
    r-tabs : ∀ {ρ} → ictx-weaken K ⊢ᵣ ρ → K ⊢ᵣ ∀' ρ

_⊢ᵣ[_] : ∀ {ν} → (K : ICtx ν) → List (Type ν) → Set
_⊢ᵣ[_] K ρs = All (λ r → K ⊢ᵣ r) ρs

r↓a⟶r◁a : ∀ {ν} {K : ICtx ν} {r a} → K ⊢ r ↓ a → r ◁ a
r↓a⟶r◁a (i-simp a) = m-simp
r↓a⟶r◁a (i-iabs _ x) = m-iabs (r↓a⟶r◁a x)
r↓a⟶r◁a (i-tabs b x) = m-tabs b (r↓a⟶r◁a x)


-- Hilbert-style formalisation of closed syntax.
-- Sequences of terms.

module OldBasicILP.UntypedSyntax.ClosedHilbertSequential where

open import OldBasicILP.UntypedSyntax.Common public

-- Closed, untyped representations.

data Rep : ℕ → Set where
  NIL   : Rep zero
  MP    : ∀ {n} → Fin n → Fin n → Rep n → Rep (suc n)
  CI    : ∀ {n} → Rep n → Rep (suc n)
  CK    : ∀ {n} → Rep n → Rep (suc n)
  CS    : ∀ {n} → Rep n → Rep (suc n)
  NEC   : ∀ {n} → ∀ {`n} → Rep (suc `n) → Rep n → Rep (suc n)
  CDIST : ∀ {n} → Rep n → Rep (suc n)
  CUP   : ∀ {n} → Rep n → Rep (suc n)
  CDOWN : ∀ {n} → Rep n → Rep (suc n)
  CPAIR : ∀ {n} → Rep n → Rep (suc n)
  CFST  : ∀ {n} → Rep n → Rep (suc n)
  CSND  : ∀ {n} → Rep n → Rep (suc n)
  UNIT  : ∀ {n} → Rep n → Rep (suc n)

-- Anti-bug wrappers.

record Proof : Set where
  constructor [_]
  field
    {len} : ℕ
    rep   : Rep (suc len)

open ClosedSyntax (Proof) public

-- Concatenation of representations.

_⧺ᴿ_ : ∀ {n₁ n₂} → Rep n₁ → Rep n₂ → Rep (n₁ + n₂)
r₁ ⧺ᴿ NIL       = r₁
r₁ ⧺ᴿ MP i j r₂ = MP (monoFin weak≤+₂ i) (monoFin weak≤+₂ j) (r₁ ⧺ᴿ r₂)
r₁ ⧺ᴿ CI r₂     = CI (r₁ ⧺ᴿ r₂)
r₁ ⧺ᴿ CK r₂     = CK (r₁ ⧺ᴿ r₂)
r₁ ⧺ᴿ CS r₂     = CS (r₁ ⧺ᴿ r₂)
r₁ ⧺ᴿ NEC `r r₂ = NEC `r (r₁ ⧺ᴿ r₂)
r₁ ⧺ᴿ CDIST r₂  = CDIST (r₁ ⧺ᴿ r₂)
r₁ ⧺ᴿ CUP r₂    = CUP (r₁ ⧺ᴿ r₂)
r₁ ⧺ᴿ CDOWN r₂  = CDOWN (r₁ ⧺ᴿ r₂)
r₁ ⧺ᴿ CPAIR r₂  = CPAIR (r₁ ⧺ᴿ r₂)
r₁ ⧺ᴿ CFST r₂   = CFST (r₁ ⧺ᴿ r₂)
r₁ ⧺ᴿ CSND r₂   = CSND (r₁ ⧺ᴿ r₂)
r₁ ⧺ᴿ UNIT r₂   = UNIT (r₁ ⧺ᴿ r₂)

-- Modus ponens and necessitation in nested form.

APP : ∀ {n₁ n₂} → Rep (suc n₁) → Rep (suc n₂) → Rep (suc (suc n₂ + suc n₁))
APP {n₁} {n₂} r₁ r₂ = MP zero (monoFin (weak≤+₁ (suc n₁)) zero) (r₂ ⧺ᴿ r₁)

BOX : ∀ {n} → Rep (suc n) → Rep (suc zero)
BOX {n} r = NEC r NIL

-- Derivations.

mutual
  infix 3 ⊢ᴰ_
  data ⊢ᴰ_ : Cx Ty → Set where
    nil   : ⊢ᴰ ∅
    mp    : ∀ {Ξ A B}   → A ▻ B ∈ Ξ → A ∈ Ξ → ⊢ᴰ Ξ → ⊢ᴰ Ξ , B
    ci    : ∀ {Ξ A}     → ⊢ᴰ Ξ → ⊢ᴰ Ξ , A ▻ A
    ck    : ∀ {Ξ A B}   → ⊢ᴰ Ξ → ⊢ᴰ Ξ , A ▻ B ▻ A
    cs    : ∀ {Ξ A B C} → ⊢ᴰ Ξ → ⊢ᴰ Ξ , (A ▻ B ▻ C) ▻ (A ▻ B) ▻ A ▻ C

    nec   : ∀ {Ξ A}     → ∀ {`Ξ} → (d : ⊢ᴰ `Ξ , A)
                        → ⊢ᴰ Ξ → ⊢ᴰ Ξ , [ ᴿ⌊ d ⌋ ] ⦂ A

    cdist : ∀ {Ξ A B}   → ∀ {n₁ n₂} → {r₁ : Rep (suc n₁)} → {r₂ : Rep (suc n₂)}
                        → ⊢ᴰ Ξ → ⊢ᴰ Ξ , [ r₁ ] ⦂ (A ▻ B) ▻ [ r₂ ] ⦂ A ▻ [ APP r₁ r₂ ] ⦂ B

    cup   : ∀ {Ξ A}     → ∀ {n} → {r : Rep (suc n)}
                        → ⊢ᴰ Ξ → ⊢ᴰ Ξ , [ r ] ⦂ A ▻ [ BOX r ] ⦂ [ r ] ⦂ A

    cdown : ∀ {Ξ A}     → ∀ {n} → {r : Rep (suc n)}
                        → ⊢ᴰ Ξ → ⊢ᴰ Ξ , [ r ] ⦂ A ▻ A

    cpair : ∀ {Ξ A B}   → ⊢ᴰ Ξ → ⊢ᴰ Ξ , A ▻ B ▻ A ∧ B
    cfst  : ∀ {Ξ A B}   → ⊢ᴰ Ξ → ⊢ᴰ Ξ , A ∧ B ▻ A
    csnd  : ∀ {Ξ A B}   → ⊢ᴰ Ξ → ⊢ᴰ Ξ , A ∧ B ▻ B
    unit  : ∀ {Ξ}       → ⊢ᴰ Ξ → ⊢ᴰ Ξ , ⊤

  -- Projection from derivations to representations.

  ᴿ⌊_⌋ : ∀ {Ξ} → ⊢ᴰ Ξ → Rep ᴺ⌊ Ξ ⌋
  ᴿ⌊ nil ⌋      = NIL
  ᴿ⌊ mp i j d ⌋ = MP ⁱ⌊ i ⌋ ⁱ⌊ j ⌋ ᴿ⌊ d ⌋
  ᴿ⌊ ci d ⌋     = CI ᴿ⌊ d ⌋
  ᴿ⌊ ck d ⌋     = CK ᴿ⌊ d ⌋
  ᴿ⌊ cs d ⌋     = CS ᴿ⌊ d ⌋
  ᴿ⌊ nec `d d ⌋ = NEC ᴿ⌊ `d ⌋ ᴿ⌊ d ⌋
  ᴿ⌊ cdist d ⌋  = CDIST ᴿ⌊ d ⌋
  ᴿ⌊ cup d ⌋    = CUP ᴿ⌊ d ⌋
  ᴿ⌊ cdown d ⌋  = CDOWN ᴿ⌊ d ⌋
  ᴿ⌊ cpair d ⌋  = CPAIR ᴿ⌊ d ⌋
  ᴿ⌊ cfst d ⌋   = CFST ᴿ⌊ d ⌋
  ᴿ⌊ csnd d ⌋   = CSND ᴿ⌊ d ⌋
  ᴿ⌊ unit d ⌋   = UNIT ᴿ⌊ d ⌋

-- Anti-bug wrappers.

infix 3 ⊢_
⊢_ : Ty → Set
⊢ A = ∃ (λ Ξ → ⊢ᴰ Ξ , A)

-- Concatenation of derivations.

_⧺ᴰ_ : ∀ {Ξ₁ Ξ₂} → ⊢ᴰ Ξ₁ → ⊢ᴰ Ξ₂ → ⊢ᴰ Ξ₁ ⧺ Ξ₂
d₁ ⧺ᴰ nil       = d₁
d₁ ⧺ᴰ mp i j d₂ = mp (mono∈ weak⊆⧺₂ i) (mono∈ weak⊆⧺₂ j) (d₁ ⧺ᴰ d₂)
d₁ ⧺ᴰ ci d₂     = ci (d₁ ⧺ᴰ d₂)
d₁ ⧺ᴰ ck d₂     = ck (d₁ ⧺ᴰ d₂)
d₁ ⧺ᴰ cs d₂     = cs (d₁ ⧺ᴰ d₂)
d₁ ⧺ᴰ nec `d d₂ = nec `d (d₁ ⧺ᴰ d₂)
d₁ ⧺ᴰ cdist d₂  = cdist (d₁ ⧺ᴰ d₂)
d₁ ⧺ᴰ cup d₂    = cup (d₁ ⧺ᴰ d₂)
d₁ ⧺ᴰ cdown d₂  = cdown (d₁ ⧺ᴰ d₂)
d₁ ⧺ᴰ cpair d₂  = cpair (d₁ ⧺ᴰ d₂)
d₁ ⧺ᴰ cfst d₂   = cfst (d₁ ⧺ᴰ d₂)
d₁ ⧺ᴰ csnd d₂   = csnd (d₁ ⧺ᴰ d₂)
d₁ ⧺ᴰ unit d₂   = unit (d₁ ⧺ᴰ d₂)

-- Modus ponens and necessitation in nested form.

app : ∀ {A B} → ⊢ A ▻ B → ⊢ A → ⊢ B
app {A} {B} (Ξ₁ , d₁) (Ξ₂ , d₂) = Ξ₃ , d₃
  where Ξ₃ = (Ξ₂ , A) ⧺ (Ξ₁ , A ▻ B)
        d₃ = mp top (mono∈ (weak⊆⧺₁ (Ξ₁ , A ▻ B)) top) (d₂ ⧺ᴰ d₁)

box : ∀ {A} → (t : ⊢ A) → ⊢ [ ᴿ⌊ π₂ t ⌋ ] ⦂ A
box (Ξ , d) = ∅ , nec d nil


open import Nat
open import Prelude
open import contexts
open import core
open import type-assignment-unicity

module canonical-indeterminate-forms where

  -- this type gives somewhat nicer syntax for the output of the canonical
  -- forms lemma for indeterminates at base type
  data cif-base : (Δ : hctx) (d : ihexp) → Set where
    CIFBEHole : ∀ {Δ d} →
      Σ[ u ∈ Nat ] Σ[ σ ∈ env ] Σ[ Γ ∈ tctx ]
        ((d == ⦇-⦈⟨ u , σ ⟩) ×
         ((u :: b [ Γ ]) ∈ Δ) ×
         (Δ , ∅ ⊢ σ :s: Γ)
        )
       → cif-base Δ d
    CIFBNEHole : ∀ {Δ d} →
      Σ[ u ∈ Nat ] Σ[ σ ∈ env ] Σ[ Γ ∈ tctx ] Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ]
        ((d == ⦇⌜ d' ⌟⦈⟨ u , σ ⟩) ×
         (Δ , ∅ ⊢ d' :: τ') ×
         (d' final) ×
         ((u :: b [ Γ ]) ∈ Δ) ×
         (Δ , ∅ ⊢ σ :s: Γ)
        )
        → cif-base Δ d
    CIFBAp : ∀ {Δ d} →
      Σ[ d1 ∈ ihexp ] Σ[ d2 ∈ ihexp ] Σ[ τ2 ∈ htyp ]
        ((d == d1 ∘ d2) ×
         (Δ , ∅ ⊢ d1 :: τ2 ==> b) ×
         (Δ , ∅ ⊢ d2 :: τ2) ×
         (d1 indet) ×
         (d2 final) ×
         ((τ3 τ4 τ3' τ4' : htyp) (d1' : ihexp) → d1 ≠ (d1' ⟨ τ3 ==> τ4 ⇒ τ3' ==> τ4' ⟩))
        )
        → cif-base Δ d
    CIFBCast : ∀ {Δ d} →
      Σ[ d' ∈ ihexp ]
        ((d == d' ⟨ ⦇-⦈ ⇒ b ⟩) ×
         (Δ , ∅ ⊢ d' :: ⦇-⦈) ×
         (d' indet) ×
         ((d'' : ihexp) (τ' : htyp) → d' ≠ (d'' ⟨ τ' ⇒ ⦇-⦈ ⟩))
        )
        → cif-base Δ d
    CIFBFailedCast : ∀ {Δ d} →
      Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ]
        ((d == d' ⟨ τ' ⇒⦇-⦈⇏ b ⟩) ×
         (Δ , ∅ ⊢ d' :: τ') ×
         (τ' ground) ×
         (τ' ≠ b)
        )
       → cif-base Δ d

  canonical-indeterminate-forms-base : ∀{Δ d} →
                                       Δ , ∅ ⊢ d :: b →
                                       d indet →
                                       cif-base Δ d
  canonical-indeterminate-forms-base TAConst ()
  canonical-indeterminate-forms-base (TAVar x₁) ()
  canonical-indeterminate-forms-base (TAAp wt wt₁) (IAp x ind x₁) = CIFBAp (_ , _ , _ , refl , wt , wt₁ , ind , x₁ , x)
  canonical-indeterminate-forms-base (TAEHole x x₁) IEHole = CIFBEHole (_ , _ , _ , refl , x , x₁)
  canonical-indeterminate-forms-base (TANEHole x wt x₁) (INEHole x₂) = CIFBNEHole (_ , _ , _ , _ , _ , refl , wt , x₂ , x , x₁)
  canonical-indeterminate-forms-base (TACast wt x) (ICastHoleGround x₁ ind x₂) = CIFBCast (_ , refl , wt , ind , x₁)
  canonical-indeterminate-forms-base (TAFailedCast x x₁ x₂ x₃) (IFailedCast x₄ x₅ x₆ x₇) = CIFBFailedCast (_ , _ , refl , x , x₅ , x₇)

  -- this type gives somewhat nicer syntax for the output of the canonical
  -- forms lemma for indeterminates at arrow type
  data cif-arr : (Δ : hctx) (d : ihexp) (τ1 τ2 : htyp) → Set where
    CIFAEHole : ∀{d Δ τ1 τ2} →
      Σ[ u ∈ Nat ] Σ[ σ ∈ env ] Σ[ Γ ∈ tctx ]
        ((d == ⦇-⦈⟨ u , σ ⟩) ×
         ((u :: (τ1 ==> τ2) [ Γ ]) ∈ Δ) ×
         (Δ , ∅ ⊢ σ :s: Γ)
        )
      → cif-arr Δ d τ1 τ2
    CIFANEHole : ∀{d Δ τ1 τ2} →
      Σ[ u ∈ Nat ] Σ[ σ ∈ env ] Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ] Σ[ Γ ∈ tctx ]
        ((d == ⦇⌜ d' ⌟⦈⟨ u , σ ⟩) ×
         (Δ , ∅ ⊢ d' :: τ') ×
         (d' final) ×
         ((u :: (τ1 ==> τ2) [ Γ ]) ∈ Δ) ×
         (Δ , ∅ ⊢ σ :s: Γ)
        )
        → cif-arr Δ d τ1 τ2
    CIFAAp : ∀{d Δ τ1 τ2} →
      Σ[ d1 ∈ ihexp ] Σ[ d2 ∈ ihexp ] Σ[ τ2' ∈ htyp ] Σ[ τ1 ∈ htyp ] Σ[ τ2 ∈ htyp ]
        ((d == d1 ∘ d2) ×
         (Δ , ∅ ⊢ d1 :: τ2' ==> (τ1 ==> τ2)) ×
         (Δ , ∅ ⊢ d2 :: τ2') ×
         (d1 indet) ×
         (d2 final) ×
         ((τ3 τ4 τ3' τ4' : htyp) (d1' : ihexp) → d1 ≠ (d1' ⟨ τ3 ==> τ4 ⇒ τ3' ==> τ4' ⟩))
        )
        → cif-arr Δ d τ1 τ2
    CIFACast : ∀{d Δ τ1 τ2} →
      Σ[ d' ∈ ihexp ] Σ[ τ1 ∈ htyp ] Σ[ τ2 ∈ htyp ] Σ[ τ1' ∈ htyp ] Σ[ τ2' ∈ htyp ]
        ((d == d' ⟨ (τ1' ==> τ2') ⇒ (τ1 ==> τ2) ⟩) ×
          (Δ , ∅ ⊢ d' :: τ1' ==> τ2') ×
          (d' indet) ×
          ((τ1' ==> τ2') ≠ (τ1 ==> τ2))
        )
       → cif-arr Δ d τ1 τ2
    CIFACastHole : ∀{d Δ τ1 τ2} →
      Σ[ d' ∈ ihexp ]
        ((d == (d' ⟨ ⦇-⦈ ⇒ ⦇-⦈ ==> ⦇-⦈ ⟩)) ×
         (τ1 == ⦇-⦈) ×
         (τ2 == ⦇-⦈) ×
         (Δ , ∅ ⊢ d' :: ⦇-⦈) ×
         (d' indet) ×
         ((d'' : ihexp) (τ' : htyp) → d' ≠ (d'' ⟨ τ' ⇒ ⦇-⦈ ⟩))
        )
        → cif-arr Δ d τ1 τ2
    CIFAFailedCast : ∀{d Δ τ1 τ2} →
      Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ]
          ((d == (d' ⟨ τ' ⇒⦇-⦈⇏ ⦇-⦈ ==> ⦇-⦈ ⟩) ) ×
           (τ1 == ⦇-⦈) ×
           (τ2 == ⦇-⦈) ×
           (Δ , ∅ ⊢ d' :: τ') ×
           (τ' ground) ×
           (τ' ≠ (⦇-⦈ ==> ⦇-⦈))
           )
          → cif-arr Δ d τ1 τ2

  canonical-indeterminate-forms-arr : ∀{Δ d τ1 τ2 } →
                                       Δ , ∅ ⊢ d :: (τ1 ==> τ2) →
                                       d indet →
                                       cif-arr Δ d τ1 τ2
  canonical-indeterminate-forms-arr (TAVar x₁) ()
  canonical-indeterminate-forms-arr (TALam _ wt) ()
  canonical-indeterminate-forms-arr (TAAp wt wt₁) (IAp x ind x₁) = CIFAAp (_ , _ , _ , _ , _ , refl , wt , wt₁ , ind , x₁ , x)
  canonical-indeterminate-forms-arr (TAEHole x x₁) IEHole = CIFAEHole (_ , _ , _ , refl , x , x₁)
  canonical-indeterminate-forms-arr (TANEHole x wt x₁) (INEHole x₂) = CIFANEHole (_ , _ , _ , _ , _ , refl , wt , x₂ , x , x₁)
  canonical-indeterminate-forms-arr (TACast wt x) (ICastArr x₁ ind) = CIFACast (_ , _ , _ , _ , _ , refl , wt , ind , x₁)
  canonical-indeterminate-forms-arr (TACast wt TCHole2) (ICastHoleGround x₁ ind GHole) = CIFACastHole (_ , refl , refl , refl , wt , ind , x₁)
  canonical-indeterminate-forms-arr (TAFailedCast x x₁ GHole x₃) (IFailedCast x₄ x₅ GHole x₇) = CIFAFailedCast (_ , _ , refl , refl , refl , x , x₅ , x₇)

  -- this type gives somewhat nicer syntax for the output of the canonical
  -- forms lemma for indeterminates at hole type
  data cif-hole : (Δ : hctx) (d : ihexp) → Set where
    CIFHEHole : ∀ {Δ d} →
      Σ[ u ∈ Nat ] Σ[ σ ∈ env ] Σ[ Γ ∈ tctx ]
        ((d == ⦇-⦈⟨ u , σ ⟩) ×
         ((u :: ⦇-⦈ [ Γ ]) ∈ Δ) ×
         (Δ , ∅ ⊢ σ :s: Γ)
        )
      → cif-hole Δ d
    CIFHNEHole : ∀ {Δ d} →
      Σ[ u ∈ Nat ] Σ[ σ ∈ env ] Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ] Σ[ Γ ∈ tctx ]
        ((d == ⦇⌜ d' ⌟⦈⟨ u , σ ⟩) ×
         (Δ , ∅ ⊢ d' :: τ') ×
         (d' final) ×
         ((u :: ⦇-⦈ [ Γ ]) ∈ Δ) ×
         (Δ , ∅ ⊢ σ :s: Γ)
        )
      → cif-hole Δ d
    CIFHAp : ∀ {Δ d} →
      Σ[ d1 ∈ ihexp ] Σ[ d2 ∈ ihexp ] Σ[ τ2 ∈ htyp ]
        ((d == d1 ∘ d2) ×
         (Δ , ∅ ⊢ d1 :: (τ2 ==> ⦇-⦈)) ×
         (Δ , ∅ ⊢ d2 :: τ2) ×
         (d1 indet) ×
         (d2 final) ×
         ((τ3 τ4 τ3' τ4' : htyp) (d1' : ihexp) → d1 ≠ (d1' ⟨ τ3 ==> τ4 ⇒ τ3' ==> τ4' ⟩))
        )
      → cif-hole Δ d
    CIFHCast : ∀ {Δ d} →
      Σ[ d' ∈ ihexp ] Σ[ τ' ∈ htyp ]
        ((d == d' ⟨ τ' ⇒ ⦇-⦈ ⟩) ×
         (Δ , ∅ ⊢ d' :: τ') ×
         (τ' ground) ×
         (d' indet)
        )
      → cif-hole Δ d

  canonical-indeterminate-forms-hole : ∀{Δ d} →
                                       Δ , ∅ ⊢ d :: ⦇-⦈ →
                                       d indet →
                                       cif-hole Δ d
  canonical-indeterminate-forms-hole (TAVar x₁) ()
  canonical-indeterminate-forms-hole (TAAp wt wt₁) (IAp x ind x₁) = CIFHAp (_ , _ , _ , refl , wt , wt₁ , ind , x₁ , x)
  canonical-indeterminate-forms-hole (TAEHole x x₁) IEHole = CIFHEHole (_ , _ , _ , refl , x , x₁)
  canonical-indeterminate-forms-hole (TANEHole x wt x₁) (INEHole x₂) = CIFHNEHole (_ , _ , _ , _ , _ , refl , wt , x₂ , x , x₁)
  canonical-indeterminate-forms-hole (TACast wt x) (ICastGroundHole x₁ ind) = CIFHCast (_ , _ , refl , wt , x₁ , ind)
  canonical-indeterminate-forms-hole (TACast wt x) (ICastHoleGround x₁ ind ())
  canonical-indeterminate-forms-hole (TAFailedCast x x₁ () x₃) (IFailedCast x₄ x₅ x₆ x₇)

  canonical-indeterminate-forms-coverage : ∀{Δ d τ} →
                                           Δ , ∅ ⊢ d :: τ →
                                           d indet →
                                           τ ≠ b →
                                           ((τ1 : htyp) (τ2 : htyp) → τ ≠ (τ1 ==> τ2)) →
                                           τ ≠ ⦇-⦈ →
                                           ⊥
  canonical-indeterminate-forms-coverage TAConst () nb na nh
  canonical-indeterminate-forms-coverage (TAVar x₁) () nb na nh
  canonical-indeterminate-forms-coverage (TALam _ wt) () nb na nh
  canonical-indeterminate-forms-coverage {τ = b} (TAAp wt wt₁) (IAp x ind x₁) nb na nh = nb refl
  canonical-indeterminate-forms-coverage {τ = ⦇-⦈} (TAAp wt wt₁) (IAp x ind x₁) nb na nh = nh refl
  canonical-indeterminate-forms-coverage {τ = τ ==> τ₁} (TAAp wt wt₁) (IAp x ind x₁) nb na nh = na τ τ₁ refl
  canonical-indeterminate-forms-coverage {τ = b} (TAEHole x x₁) IEHole nb na nh = nb refl
  canonical-indeterminate-forms-coverage {τ = ⦇-⦈} (TAEHole x x₁) IEHole nb na nh = nh refl
  canonical-indeterminate-forms-coverage {τ = τ ==> τ₁} (TAEHole x x₁) IEHole nb na nh = na τ τ₁ refl
  canonical-indeterminate-forms-coverage {τ = b} (TANEHole x wt x₁) (INEHole x₂) nb na nh = nb refl
  canonical-indeterminate-forms-coverage {τ = ⦇-⦈} (TANEHole x wt x₁) (INEHole x₂) nb na nh = nh refl
  canonical-indeterminate-forms-coverage {τ = τ ==> τ₁} (TANEHole x wt x₁) (INEHole x₂) nb na nh = na τ τ₁ refl
  canonical-indeterminate-forms-coverage (TACast wt x) (ICastArr x₁ ind) nb na nh = na _ _ refl
  canonical-indeterminate-forms-coverage (TACast wt x) (ICastGroundHole x₁ ind) nb na nh = nh refl
  canonical-indeterminate-forms-coverage {τ = b} (TACast wt x) (ICastHoleGround x₁ ind x₂) nb na nh = nb refl
  canonical-indeterminate-forms-coverage {τ = ⦇-⦈} (TACast wt x) (ICastHoleGround x₁ ind x₂) nb na nh = nh refl
  canonical-indeterminate-forms-coverage {τ = τ ==> τ₁} (TACast wt x) (ICastHoleGround x₁ ind x₂) nb na nh = na τ τ₁ refl
  canonical-indeterminate-forms-coverage {τ = b} (TAFailedCast x x₁ x₂ x₃) (IFailedCast x₄ x₅ x₆ x₇) = λ z _ _₁ → z refl
  canonical-indeterminate-forms-coverage {τ = ⦇-⦈} (TAFailedCast x x₁ x₂ x₃) (IFailedCast x₄ x₅ x₆ x₇) = λ _ _₁ z → z refl
  canonical-indeterminate-forms-coverage {τ = τ ==> τ₁} (TAFailedCast x x₁ x₂ x₃) (IFailedCast x₄ x₅ x₆ x₇) = λ _ z _₁ → z τ τ₁ refl


open import Agda.Primitive using (lzero; lsuc; _⊔_)
open import Relation.Binary.PropositionalEquality
open import Relation.Binary using (Setoid)

import SecondOrder.Arity
import SecondOrder.Signature
import SecondOrder.Metavariable

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

  open SecondOrder.Signature.Signature Σ
  open SecondOrder.Metavariable Σ

  -- The term judgement
  data Term (Θ : MContext) : ∀ (Γ : VContext) (A : sort) → Set ℓ

  Arg : ∀ (Θ : MContext) (Γ : VContext) (A : sort) (Δ : VContext) → Set ℓ
  Arg Θ Γ A Δ = Term Θ (Γ ,, Δ) A

  data Term Θ where
    tm-var : ∀ {Γ} {A} (x : A ∈ Γ) → Term Θ Γ A
    tm-meta : ∀ {Γᴹ A} {Γ} (M : [ Γᴹ , A ]∈ Θ)
                (ts : ∀ {B} (i : B ∈ Γᴹ) → Term Θ Γ B)
                → Term Θ Γ A
    tm-oper : ∀ {Γ} (f : oper) (es : ∀ (i : oper-arg f) → Arg Θ Γ (arg-sort f i) (arg-bind f i))
                → Term Θ Γ (oper-sort f)

  -- Syntactic equality of terms

  infix 4 _≈_

  data _≈_ {Θ : MContext} : ∀ {Γ : VContext} {A : sort} → Term Θ Γ A → Term Θ Γ A → Set ℓ where
    ≈-≡ : ∀ {Γ A} {t u : Term Θ Γ A} (ξ : t ≡ u) → t ≈ u
    ≈-meta : ∀ {Γ} {α A} {M : [ α , A ]∈ Θ} {ts us : ∀ {B} (i : B ∈ α) → Term Θ Γ B}
               (ξ : ∀ {B} i → ts {B} i ≈ us {B} i) → tm-meta M ts ≈ tm-meta M us
    ≈-oper : ∀ {Γ} {f : oper} {ds es : ∀ (i : oper-arg f) → Arg Θ Γ (arg-sort f i)  (arg-bind f i)}
               (ξ : ∀ i → ds i ≈ es i) → tm-oper f ds ≈ tm-oper f es

  -- Syntactic equality of terms is an equivalence relation

  ≈-refl : ∀ {Θ Γ A} {t : Term Θ Γ A} → t ≈ t
  ≈-refl = ≈-≡ refl

  ≈-sym : ∀ {Θ Γ A} {t u : Term Θ Γ A} → t ≈ u → u ≈ t
  ≈-sym (≈-≡ refl) = ≈-≡ refl
  ≈-sym (≈-meta ξ) = ≈-meta λ i → ≈-sym (ξ i)
  ≈-sym (≈-oper ξ) = ≈-oper (λ i → ≈-sym (ξ i))

  ≈-trans : ∀ {Θ Γ A} {t u v : Term Θ Γ A} → t ≈ u → u ≈ v → t ≈ v
  ≈-trans (≈-≡ refl) ξ = ξ
  ≈-trans (≈-meta ζ) (≈-≡ refl) = ≈-meta ζ
  ≈-trans (≈-meta ζ) (≈-meta ξ) = ≈-meta (λ i → ≈-trans (ζ i) (ξ i))
  ≈-trans (≈-oper ζ) (≈-≡ refl) = ≈-oper ζ
  ≈-trans (≈-oper ζ) (≈-oper ξ) = ≈-oper (λ i → ≈-trans (ζ i) (ξ i))

  Term-setoid : ∀ (Θ : MContext) (Γ : VContext)  (A : sort) → Setoid ℓ ℓ
  Term-setoid Θ Γ A =
    record
      { Carrier = Term Θ Γ A
      ; _≈_ = _≈_
      ; isEquivalence = record { refl = ≈-refl ; sym = ≈-sym ; trans = ≈-trans } }