------------------------------------------------------------------------
-- Some negative results related to weak bisimilarity and expansion
------------------------------------------------------------------------

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

open import Prelude
open import Prelude.Size

module Delay-monad.Sized.Bisimilarity.Negative
  {a} {A : Size → Type a} where

open import Equality.Propositional
open import Logical-equivalence using (_⇔_)

open import Function-universe equality-with-J hiding (id; _∘_)

open import Delay-monad.Sized
open import Delay-monad.Sized.Bisimilarity
open import Delay-monad.Sized.Termination

------------------------------------------------------------------------
-- Lemmas stating that functions of certain types cannot be defined if
-- ∀ i → A i is inhabited

-- An abbreviation. (Note that, because pattern-matching lambdas like
-- the one in this definition are—at least at the time of
-- writing—compared by "name", Agda rejects the code that one gets if
-- this abbreviation is inlined below.)

later-now : (∀ i → A i) → ∀ {i} → Delay A i
later-now x = later λ { .force {j} → now (x j) }

-- If now (x ∞) is an expansion of later-now x for every
-- x : ∀ i → A i, then ∀ i → A i is uninhabited.

Now≳later-now = (x : ∀ i → A i) → now (x ∞) ≳ later-now x

now≳later-now→uninhabited : Now≳later-now → ¬ (∀ i → A i)
now≳later-now→uninhabited =
  Now≳later-now  ↝⟨ (λ hyp x → case hyp x of λ ()) ⟩□
  ¬ (∀ i → A i)  □

-- If a variant of laterˡ⁻¹ for (fully defined) expansion can be
-- defined, then ∀ i → A i is uninhabited.

Laterˡ⁻¹-≳ = ∀ {x} {y : Delay A ∞} → later x ≳ y → force x ≳ y

laterˡ⁻¹-≳→uninhabited : Laterˡ⁻¹-≳ → ¬ (∀ i → A i)
laterˡ⁻¹-≳→uninhabited =
  Laterˡ⁻¹-≳     ↝⟨ (λ hyp _ → hyp (reflexive _)) ⟩
  Now≳later-now  ↝⟨ now≳later-now→uninhabited ⟩□
  ¬ (∀ i → A i)  □

-- If the following variants of transitivity can be proved, then
-- ∀ i → A i is uninhabited.

Transitivity-≈≳≳ = {x y z : Delay A ∞} → x ≈ y → y ≳ z → x ≳ z
Transitivity-≳≈≳ = {x y z : Delay A ∞} → x ≳ y → y ≈ z → x ≳ z

transitive-≈≳≳→uninhabited : Transitivity-≈≳≳ → ¬ (∀ i → A i)
transitive-≈≳≳→uninhabited =
  Transitivity-≈≳≳  ↝⟨ (λ trans → trans (laterʳ (reflexive _))) ⟩
  Laterˡ⁻¹-≳        ↝⟨ laterˡ⁻¹-≳→uninhabited ⟩□
  ¬ (∀ i → A i)     □

transitive-≳≈≳→uninhabited : Transitivity-≳≈≳ → ¬ (∀ i → A i)
transitive-≳≈≳→uninhabited =
  Transitivity-≳≈≳  ↝⟨ (λ trans x → later⁻¹ {y = λ { .force → later-now x }}
                                            (trans (reflexive _) (laterʳ (reflexive _)))) ⟩
  Now≳later-now     ↝⟨ now≳later-now→uninhabited ⟩□
  ¬ (∀ i → A i)     □

------------------------------------------------------------------------
-- Lemmas stating that certain size-preserving functions cannot be
-- defined if ∀ i → A i is inhabited, and related results

-- If a variant of laterˡ⁻¹ in which one occurrence of weak
-- bisimilarity is replaced by strong bisimilarity, and both arguments
-- are specialised, can be made size-preserving, then ∀ i → A i is
-- uninhabited.
--
-- This lemma is used to prove all other similar results below
-- (directly or indirectly).

Laterˡ⁻¹-∼≈ = ∀ {i} (x : ∀ i → A i) →
              [ i ] later (λ { .force {j = j} → now (x j) }) ∼ never →
              [ i ] now {A = A} (x ∞)                        ≈ never

size-preserving-laterˡ⁻¹-∼≈→uninhabited :
  Laterˡ⁻¹-∼≈ → ¬ (∀ i → A i)
size-preserving-laterˡ⁻¹-∼≈→uninhabited laterˡ⁻¹-∼≈ x =
  contradiction ∞
  where

  mutual

    now≈never : ∀ {i} → [ i ] now (x ∞) ≈ never
    now≈never = laterˡ⁻¹-∼≈ x (later now∼never)

    now∼never : ∀ {i} → [ i ] now (x ∞) ∼′ never
    force now∼never {j = j} = ⊥-elim (contradiction j)

    contradiction : Size → ⊥
    contradiction i = now≉never (now≈never {i = i})

-- A logically equivalent variant of Laterˡ⁻¹-∼≈ which it is sometimes
-- easier to work with.

Laterˡ⁻¹-∼≈′ = ∀ {i} (x : ∀ i → A i) →
               [ i ] later (record { force = λ {j} → now (x j) }) ∼ never →
               [ i ] now {A = A} (x ∞)                            ≈ never

size-preserving-laterˡ⁻¹-∼≈⇔size-preserving-laterˡ⁻¹-∼≈′ :
  Laterˡ⁻¹-∼≈ ⇔ Laterˡ⁻¹-∼≈′
size-preserving-laterˡ⁻¹-∼≈⇔size-preserving-laterˡ⁻¹-∼≈′ = record
  { to   = λ laterˡ⁻¹ x → laterˡ⁻¹ x ∘ transitive-∼ˡ (later λ { .force → now })
  ; from = λ laterˡ⁻¹ x → laterˡ⁻¹ x ∘ transitive-∼ˡ (later λ { .force → now })
  }

-- The type Laterˡ⁻¹-∼≈′ is logically equivalent to the similar type
-- Laterʳ⁻¹-∼≈′.

Laterʳ⁻¹-∼≈′ = ∀ {i} (x : ∀ i → A i) →
               [ i ] never ∼ later (record { force = λ {j} → now (x j) }) →
               [ i ] never ≈ now {A = A} (x ∞)

size-preserving-laterˡ⁻¹-∼≈′⇔size-preserving-laterʳ⁻¹-∼≈′ :
  Laterˡ⁻¹-∼≈′ ⇔ Laterʳ⁻¹-∼≈′
size-preserving-laterˡ⁻¹-∼≈′⇔size-preserving-laterʳ⁻¹-∼≈′ =
  record { to   = λ laterˡ⁻¹ {_} _ → symmetric ∘ laterˡ⁻¹ _ ∘ symmetric
         ; from = λ laterʳ⁻¹ {_} _ → symmetric ∘ laterʳ⁻¹ _ ∘ symmetric
         }

-- The type Laterʳ⁻¹-∼≈′ is logically equivalent to the similar type
-- Laterʳ⁻¹-∼≳′.

Laterʳ⁻¹-∼≳′ = ∀ {i} (x : ∀ i → A i) →
               [ i ] never ∼ later (record { force = λ {j} → now (x j) }) →
               [ i ] never ≳ now {A = A} (x ∞)

size-preserving-laterʳ⁻¹-∼≈′⇔size-preserving-laterʳ⁻¹-∼≳′ :
  Laterʳ⁻¹-∼≈′ ⇔ Laterʳ⁻¹-∼≳′
size-preserving-laterʳ⁻¹-∼≈′⇔size-preserving-laterʳ⁻¹-∼≳′ =
  record { to   = λ laterʳ⁻¹ {_} _ → ≈→-now ∘ laterʳ⁻¹ _
         ; from = λ laterʳ⁻¹ {_} _ → ≳→     ∘ laterʳ⁻¹ _
         }

-- If Laterʳ⁻¹-∼≳′ is inhabited, then ∀ i → A i is uninhabited.

size-preserving-laterʳ⁻¹-∼≳′→uninhabited : Laterʳ⁻¹-∼≳′ → ¬ (∀ i → A i)
size-preserving-laterʳ⁻¹-∼≳′→uninhabited =
  Laterʳ⁻¹-∼≳′   ↝⟨ _⇔_.from size-preserving-laterʳ⁻¹-∼≈′⇔size-preserving-laterʳ⁻¹-∼≳′ ⟩
  Laterʳ⁻¹-∼≈′   ↝⟨ _⇔_.from size-preserving-laterˡ⁻¹-∼≈′⇔size-preserving-laterʳ⁻¹-∼≈′ ⟩
  Laterˡ⁻¹-∼≈′   ↝⟨ _⇔_.from size-preserving-laterˡ⁻¹-∼≈⇔size-preserving-laterˡ⁻¹-∼≈′ ⟩
  Laterˡ⁻¹-∼≈    ↝⟨ size-preserving-laterˡ⁻¹-∼≈→uninhabited ⟩□
  ¬ (∀ i → A i)  □

-- Having a size-preserving variant of laterˡ⁻¹ is logically
-- equivalent to having a size-preserving variant of laterʳ⁻¹ (for
-- weak bisimilarity).

Laterˡ⁻¹-≈ = ∀ {i x} {y : Delay A ∞} →
             [ i ] later x ≈ y →
             [ i ] force x ≈ y

Laterʳ⁻¹-≈ = ∀ {i} {x : Delay A ∞} {y} →
             [ i ] x ≈ later y →
             [ i ] x ≈ force y

size-preserving-laterˡ⁻¹-≈⇔size-preserving-laterʳ⁻¹-≈ :
  Laterˡ⁻¹-≈ ⇔ Laterʳ⁻¹-≈
size-preserving-laterˡ⁻¹-≈⇔size-preserving-laterʳ⁻¹-≈ = record
  { to   = λ laterʳ⁻¹ → symmetric ∘ laterʳ⁻¹ ∘ symmetric
  ; from = λ laterˡ⁻¹ → symmetric ∘ laterˡ⁻¹ ∘ symmetric
  }

-- If laterˡ⁻¹ can be made size-preserving, then ∀ i → A i is
-- uninhabited.

size-preserving-laterˡ⁻¹-≈→uninhabited : Laterˡ⁻¹-≈ → ¬ (∀ i → A i)
size-preserving-laterˡ⁻¹-≈→uninhabited =
  Laterˡ⁻¹-≈     ↝⟨ (λ laterˡ⁻¹ _ → laterˡ⁻¹ ∘ ∼→) ⟩
  Laterˡ⁻¹-∼≈    ↝⟨ size-preserving-laterˡ⁻¹-∼≈→uninhabited ⟩□
  ¬ (∀ i → A i)  □

-- If laterʳ⁻¹ can be made size-preserving for expansion, then
-- ∀ i → A i is uninhabited.

Laterʳ⁻¹-≳ = ∀ {i} {x : Delay A ∞} {y} →
             [ i ] x ≳ later y →
             [ i ] x ≳ force y

size-preserving-laterʳ⁻¹-≳→uninhabited : Laterʳ⁻¹-≳ → ¬ (∀ i → A i)
size-preserving-laterʳ⁻¹-≳→uninhabited =
  Laterʳ⁻¹-≳     ↝⟨ (λ laterʳ⁻¹ {_} _ p → laterʳ⁻¹ (∼→ p)) ⟩
  Laterʳ⁻¹-∼≳′   ↝⟨ size-preserving-laterʳ⁻¹-∼≳′→uninhabited ⟩□
  ¬ (∀ i → A i)  □

-- If a variant of ⇓-respects-≈ in which _≈_ is replaced by _∼_ can be
-- made size-preserving in the second argument, then ∀ i → A i is
-- uninhabited.

⇓-Respects-∼ʳ = ∀ {i} {x y : Delay A ∞} {z} →
                x ⇓ z → [ i ] x ∼ y → Terminates i y z

size-preserving-⇓-respects-∼ʳ→uninhabited :
  ⇓-Respects-∼ʳ → ¬ (∀ i → A i)
size-preserving-⇓-respects-∼ʳ→uninhabited =
  ⇓-Respects-∼ʳ  ↝⟨ (λ resp _ → resp (laterʳ now)) ⟩
  Laterˡ⁻¹-∼≈    ↝⟨ size-preserving-laterˡ⁻¹-∼≈→uninhabited ⟩□
  ¬ (∀ i → A i)  □

-- If ⇓-respects-≈ can be made size-preserving in the second argument,
-- then ∀ i → A i is uninhabited.

⇓-Respects-≈ʳ = ∀ {i} {x y : Delay A ∞} {z} →
                x ⇓ z → [ i ] x ≈ y → Terminates i y z

size-preserving-⇓-respects-≈ʳ→uninhabited :
  ⇓-Respects-≈ʳ → ¬ (∀ i → A i)
size-preserving-⇓-respects-≈ʳ→uninhabited =
  ⇓-Respects-≈ʳ  ↝⟨ (λ trans x⇓z → trans x⇓z ∘ ∼→) ⟩
  ⇓-Respects-∼ʳ  ↝⟨ size-preserving-⇓-respects-∼ʳ→uninhabited ⟩□
  ¬ (∀ i → A i)  □

-- Having a transitivity-like proof, taking weak bisimilarity and
-- strong bisimilarity to weak bisimilarity, that preserves the size
-- of the second argument, is logically equivalent to having a
-- transitivity-like proof, taking strong bisimilarity and weak
-- bisimilarity to weak bisimilarity, that preserves the size of the
-- first argument.

Transitivity-≈∼ʳ = ∀ {i} {x y z : Delay A ∞} →
                   x ≈ y → [ i ] y ∼ z → [ i ] x ≈ z

Transitivity-∼≈ˡ = ∀ {i} {x y z : Delay A ∞} →
                   [ i ] x ∼ y → y ≈ z → [ i ] x ≈ z

size-preserving-transitivity-≈∼ʳ⇔size-preserving-transitivity-∼≈ˡ :
  Transitivity-≈∼ʳ ⇔ Transitivity-∼≈ˡ
size-preserving-transitivity-≈∼ʳ⇔size-preserving-transitivity-∼≈ˡ =
  record
    { to   = λ trans p q → symmetric (trans (symmetric q) (symmetric p))
    ; from = λ trans p q → symmetric (trans (symmetric q) (symmetric p))
    }

-- If there is a transitivity-like proof, taking weak bisimilarity and
-- strong bisimilarity to weak bisimilarity, that preserves the size
-- of the second argument, then ∀ i → A i is uninhabited.

size-preserving-transitivity-≈∼ʳ→uninhabited :
  Transitivity-≈∼ʳ → ¬ (∀ i → A i)
size-preserving-transitivity-≈∼ʳ→uninhabited =
  Transitivity-≈∼ʳ  ↝⟨ (λ trans → trans) ⟩
  ⇓-Respects-∼ʳ     ↝⟨ size-preserving-⇓-respects-∼ʳ→uninhabited ⟩
  ¬ (∀ i → A i)     □

-- If there is a transitivity-like proof, taking strong bisimilarity
-- and expansion to expansion, that preserves the size of the first
-- argument, then ∀ i → A i is uninhabited.

Transitivity-∼≳ˡ = ∀ {i} {x y z : Delay A ∞} →
                   [ i ] x ∼ y → y ≳ z → [ i ] x ≳ z

size-preserving-transitivity-∼≳ˡ→uninhabited :
  Transitivity-∼≳ˡ → ¬ (∀ i → A i)
size-preserving-transitivity-∼≳ˡ→uninhabited =
  Transitivity-∼≳ˡ  ↝⟨ (λ trans _ p → trans p (laterˡ now)) ⟩
  Laterʳ⁻¹-∼≳′      ↝⟨ size-preserving-laterʳ⁻¹-∼≳′→uninhabited ⟩
  ¬ (∀ i → A i)     □

-- Having a transitivity proof for weak bisimilarity that preserves
-- the size of the first argument is logically equivalent to having
-- one that preserves the size of the second argument.

Transitivity-≈ˡ = ∀ {i} {x y z : Delay A ∞} →
                  [ i ] x ≈ y → y ≈ z → [ i ] x ≈ z

Transitivity-≈ʳ = ∀ {i} {x y z : Delay A ∞} →
                x ≈ y → [ i ] y ≈ z → [ i ] x ≈ z

size-preserving-transitivity-≈ˡ⇔size-preserving-transitivity-≈ʳ :
  Transitivity-≈ˡ ⇔ Transitivity-≈ʳ
size-preserving-transitivity-≈ˡ⇔size-preserving-transitivity-≈ʳ = record
  { to   = λ trans p q → symmetric (trans (symmetric q) (symmetric p))
  ; from = λ trans p q → symmetric (trans (symmetric q) (symmetric p))
  }

-- If there is a transitivity proof for weak bisimilarity that
-- preserves the size of the second argument, then ∀ i → A i is
-- uninhabited.

size-preserving-transitivity-≈ʳ→uninhabited :
  Transitivity-≈ʳ → ¬ (∀ i → A i)
size-preserving-transitivity-≈ʳ→uninhabited =
  Transitivity-≈ʳ  ↝⟨ (λ trans → trans) ⟩
  ⇓-Respects-≈ʳ    ↝⟨ size-preserving-⇓-respects-≈ʳ→uninhabited ⟩□
  ¬ (∀ i → A i)    □

-- If there is a transitivity proof for expansion that preserves the
-- size of the first argument, then ∀ i → A i is uninhabited.

Transitivity-≳ˡ = ∀ {i} {x y z : Delay A ∞} →
                  [ i ] x ≳ y → y ≳ z → [ i ] x ≳ z

size-preserving-transitivity-≳ˡ→uninhabited :
  Transitivity-≳ˡ → ¬ (∀ i → A i)
size-preserving-transitivity-≳ˡ→uninhabited =
  Transitivity-≳ˡ   ↝⟨ (λ trans → trans ∘ ∼→) ⟩
  Transitivity-∼≳ˡ  ↝⟨ size-preserving-transitivity-∼≳ˡ→uninhabited ⟩□
  ¬ (∀ i → A i)     □

-- If there is a fully size-preserving transitivity proof for weak
-- bisimilarity, then ∀ i → A i is uninhabited.

Transitivity-≈ = ∀ {i} {x y z : Delay A ∞} →
                 [ i ] x ≈ y → [ i ] y ≈ z → [ i ] x ≈ z

size-preserving-transitivity-≈→uninhabited :
  Transitivity-≈ → ¬ (∀ i → A i)
size-preserving-transitivity-≈→uninhabited =
  Transitivity-≈   ↝⟨ (λ trans → trans) ⟩
  Transitivity-≈ʳ  ↝⟨ size-preserving-transitivity-≈ʳ→uninhabited ⟩□
  ¬ (∀ i → A i)    □

-- If there is a fully size-preserving transitivity proof for
-- expansion, then ∀ i → A i is uninhabited.

Transitivity-≳ = ∀ {i} {x y z : Delay A ∞} →
                 [ i ] x ≳ y → [ i ] y ≳ z → [ i ] x ≳ z

size-preserving-transitivity-≳→uninhabited :
  Transitivity-≳ → ¬ (∀ i → A i)
size-preserving-transitivity-≳→uninhabited =
  Transitivity-≳   ↝⟨ (λ trans → trans) ⟩
  Transitivity-≳ˡ  ↝⟨ size-preserving-transitivity-≳ˡ→uninhabited ⟩□
  ¬ (∀ i → A i)    □

-- There is a transitivity-like proof, taking expansion and weak
-- bisimilarity to weak bisimilarity, that preserves the size of the
-- first argument, iff there is a transitivity-like proof, taking weak
-- bisimilarity and the converse of expansion to weak bisimilarity,
-- that preserves the size of the second argument.

Transitivity-≳≈ˡ = ∀ {i} {x y z : Delay A ∞} →
                   [ i ] x ≳ y → y ≈ z → [ i ] x ≈ z

Transitivity-≈≲ʳ = ∀ {i} {x y z : Delay A ∞} →
                   x ≈ y → [ i ] y ≲ z → [ i ] x ≈ z

size-preserving-transitivity-≳≈ˡ⇔size-preserving-transitivity-≈≲ʳ :
  Transitivity-≳≈ˡ ⇔ Transitivity-≈≲ʳ
size-preserving-transitivity-≳≈ˡ⇔size-preserving-transitivity-≈≲ʳ =
  record
    { to   = λ trans x≈y y≲z → symmetric (trans y≲z (symmetric x≈y))
    ; from = λ trans x≳y y≈z → symmetric (trans (symmetric y≈z) x≳y)
    }

-- If there is a transitivity-like proof, taking expansion and weak
-- bisimilarity to weak bisimilarity, that preserves the size of the
-- first argument, then ∀ i → A i is uninhabited.

size-preserving-transitivity-≳≈ˡ→uninhabited :
  Transitivity-≳≈ˡ → ¬ (∀ i → A i)
size-preserving-transitivity-≳≈ˡ→uninhabited =
  Transitivity-≳≈ˡ  ↝⟨ _∘ ∼→ ⟩
  Transitivity-∼≈ˡ  ↝⟨ _⇔_.from size-preserving-transitivity-≈∼ʳ⇔size-preserving-transitivity-∼≈ˡ ⟩
  Transitivity-≈∼ʳ  ↝⟨ size-preserving-transitivity-≈∼ʳ→uninhabited ⟩□
  ¬ (∀ i → A i)     □

-- There is a transitivity-like proof, taking expansion and weak
-- bisimilarity to weak bisimilarity, that preserves the size of both
-- arguments, iff there is a transitivity-like proof, taking weak
-- bisimilarity and the converse of expansion to weak bisimilarity,
-- that also preserves the size of both arguments.

Transitivity-≳≈ = ∀ {i} {x y z : Delay A ∞} →
                  [ i ] x ≳ y → [ i ] y ≈ z → [ i ] x ≈ z

Transitivity-≈≲ = ∀ {i} {x y z : Delay A ∞} →
                  [ i ] x ≈ y → [ i ] y ≲ z → [ i ] x ≈ z

size-preserving-transitivity-≳≈⇔size-preserving-transitivity-≈≲ :
  Transitivity-≳≈ ⇔ Transitivity-≈≲
size-preserving-transitivity-≳≈⇔size-preserving-transitivity-≈≲ =
  record
    { to   = λ trans x≈y y≲z → symmetric (trans y≲z (symmetric x≈y))
    ; from = λ trans x≳y y≈z → symmetric (trans (symmetric y≈z) x≳y)
    }

-- If there is a transitivity-like proof, taking expansion and weak
-- bisimilarity to weak bisimilarity, that preserves the size of both
-- arguments, then ∀ i → A i is uninhabited.

size-preserving-transitivity-≳≈→uninhabited :
  Transitivity-≳≈ → ¬ (∀ i → A i)
size-preserving-transitivity-≳≈→uninhabited =
  Transitivity-≳≈   ↝⟨ (λ trans → trans) ⟩
  Transitivity-≳≈ˡ  ↝⟨ size-preserving-transitivity-≳≈ˡ→uninhabited ⟩□
  ¬ (∀ i → A i)     □

-- If there is a transitivity-like proof, taking weak bisimilarity and
-- expansion to weak bisimilarity, that preserves the size of the
-- first argument, then ∀ i → A i is uninhabited.

Transitivity-≈≳ˡ = ∀ {i} {x y z : Delay A ∞} →
                   [ i ] x ≈ y → y ≳ z → [ i ] x ≈ z

size-preserving-transitivity-≈≳ˡ→uninhabited :
  Transitivity-≈≳ˡ → ¬ (∀ i → A i)
size-preserving-transitivity-≈≳ˡ→uninhabited =
  Transitivity-≈≳ˡ  ↝⟨ (λ trans {_ _ _} x≈ly → trans x≈ly (laterˡ (reflexive _))) ⟩
  Laterʳ⁻¹-≈        ↝⟨ _⇔_.from size-preserving-laterˡ⁻¹-≈⇔size-preserving-laterʳ⁻¹-≈ ⟩
  Laterˡ⁻¹-≈        ↝⟨ size-preserving-laterˡ⁻¹-≈→uninhabited ⟩
  ¬ (∀ i → A i)     □

------------------------------------------------------------------------
-- Lemmas stating that certain types are inhabited if A ∞ is
-- uninhabited

-- If A ∞ is uninhabited, then Now≳later-now is inhabited.

uninhabited→now≳later-now : ¬ A ∞ → Now≳later-now
uninhabited→now≳later-now =
  ¬ A ∞            ↝⟨ uninhabited→trivial ⟩
  (∀ x y → x ≳ y)  ↝⟨ (λ trivial _ → trivial _ _) ⟩□
  Now≳later-now    □

-- If A ∞ is uninhabited, then a variant of laterˡ⁻¹ for (fully
-- defined) expansion can be defined.

uninhabited→laterˡ⁻¹-≳ : ¬ A ∞ → Laterˡ⁻¹-≳
uninhabited→laterˡ⁻¹-≳ =
  ¬ A ∞            ↝⟨ uninhabited→trivial ⟩
  (∀ x y → x ≳ y)  ↝⟨ (λ trivial {_ _} _ → trivial _ _) ⟩□
  Laterˡ⁻¹-≳       □

-- If A ∞ is uninhabited, then a transitivity-like proof taking weak
-- bisimilarity and expansion to expansion can be defined.

uninhabited→transitivity-≈≳≳ : ¬ A ∞ → Transitivity-≈≳≳
uninhabited→transitivity-≈≳≳ =
  ¬ A ∞             ↝⟨ uninhabited→trivial ⟩
  (∀ x y → x ≳ y)   ↝⟨ (λ trivial {_ _ _} _ _ → trivial _ _) ⟩□
  Transitivity-≈≳≳  □

-- If A ∞ is uninhabited, then a transitivity-like proof taking
-- expansion and weak bisimilarity to expansion can be defined.

uninhabited→transitivity-≳≈≳ : ¬ A ∞ → Transitivity-≳≈≳
uninhabited→transitivity-≳≈≳ =
  ¬ A ∞             ↝⟨ uninhabited→trivial ⟩
  (∀ x y → x ≳ y)   ↝⟨ (λ trivial {_ _ _} _ _ → trivial _ _) ⟩□
  Transitivity-≳≈≳  □

-- If A ∞ is uninhabited, then Laterˡ⁻¹-∼≈ is inhabited.

uninhabited→size-preserving-laterˡ⁻¹-∼≈ : ¬ A ∞ → Laterˡ⁻¹-∼≈
uninhabited→size-preserving-laterˡ⁻¹-∼≈ =
  ¬ A ∞            ↝⟨ uninhabited→trivial ⟩
  (∀ x y → x ≈ y)  ↝⟨ (λ trivial {_} _ _ → trivial _ _) ⟩□
  Laterˡ⁻¹-∼≈      □

-- If A ∞ is uninhabited, then laterˡ⁻¹ can be made size-preserving.

uninhabited→size-preserving-laterˡ⁻¹ : ¬ A ∞ → Laterˡ⁻¹-≈
uninhabited→size-preserving-laterˡ⁻¹ =
  ¬ A ∞            ↝⟨ uninhabited→trivial ⟩
  (∀ x y → x ≈ y)  ↝⟨ (λ trivial {_ _ _} _ → trivial _ _) ⟩□
  Laterˡ⁻¹-≈       □

-- If A ∞ is uninhabited, then a variant of ⇓-respects-≈ in which _≈_
-- is replaced by _∼_ can be made size-preserving in the second
-- argument.

uninhabited→size-preserving-⇓-respects-∼ʳ : ¬ A ∞ → ⇓-Respects-∼ʳ
uninhabited→size-preserving-⇓-respects-∼ʳ =
  ¬ A ∞            ↝⟨ uninhabited→trivial ⟩
  (∀ x y → x ≈ y)  ↝⟨ (λ trivial {_ _ _ _} _ _ → trivial _ _) ⟩□
  ⇓-Respects-∼ʳ    □

-- If A ∞ is uninhabited, then ⇓-respects-≈ can be made
-- size-preserving in the second argument.

uninhabited→size-preserving-⇓-respects-≈ʳ : ¬ A ∞ → ⇓-Respects-≈ʳ
uninhabited→size-preserving-⇓-respects-≈ʳ =
  ¬ A ∞            ↝⟨ uninhabited→trivial ⟩
  (∀ x y → x ≈ y)  ↝⟨ (λ trivial {_ _ _ _} _ _ → trivial _ _) ⟩□
  ⇓-Respects-≈ʳ    □

-- If A ∞ is uninhabited, then there is a transitivity-like proof,
-- taking weak bisimilarity and strong bisimilarity to weak
-- bisimilarity, that preserves the size of the second argument.

uninhabited→size-preserving-transitivity-≈∼ʳ : ¬ A ∞ → Transitivity-≈∼ʳ
uninhabited→size-preserving-transitivity-≈∼ʳ =
  ¬ A ∞             ↝⟨ uninhabited→trivial ⟩
  (∀ x y → x ≈ y)   ↝⟨ (λ trivial {_ _ _ _} _ _ → trivial _ _) ⟩□
  Transitivity-≈∼ʳ  □

-- If A ∞ is uninhabited, then there is a transitivity-like proof,
-- taking strong bisimilarity and expansion to expansion, that
-- preserves the size of the first argument.

uninhabited→size-preserving-transitivity-∼≳ˡ : ¬ A ∞ → Transitivity-∼≳ˡ
uninhabited→size-preserving-transitivity-∼≳ˡ =
  ¬ A ∞             ↝⟨ uninhabited→trivial ⟩
  (∀ x y → x ≳ y)   ↝⟨ (λ trivial {_ _ _ _} _ _ → trivial _ _) ⟩□
  Transitivity-∼≳ˡ  □

-- If A ∞ is uninhabited, then there is a transitivity proof for weak
-- bisimilarity that preserves the size of the second argument.

uninhabited→size-preserving-transitivity-≈ʳ : ¬ A ∞ → Transitivity-≈ʳ
uninhabited→size-preserving-transitivity-≈ʳ =
  ¬ A ∞            ↝⟨ uninhabited→trivial ⟩
  (∀ x y → x ≈ y)  ↝⟨ (λ trivial {_ _ _ _} _ _ → trivial _ _) ⟩□
  Transitivity-≈ʳ  □

-- If A ∞ is uninhabited, then there is a transitivity proof for
-- expansion that preserves the size of the first argument.

uninhabited→size-preserving-transitivity-≳ˡ : ¬ A ∞ → Transitivity-≳ˡ
uninhabited→size-preserving-transitivity-≳ˡ =
  ¬ A ∞            ↝⟨ uninhabited→trivial ⟩
  (∀ x y → x ≳ y)  ↝⟨ (λ trivial {_ _ _ _} _ _ → trivial _ _) ⟩□
  Transitivity-≳ˡ  □

-- If A ∞ is uninhabited, then there is a fully size-preserving
-- transitivity proof for weak bisimilarity.

uninhabited→size-preserving-transitivity-≈ : ¬ A ∞ → Transitivity-≈
uninhabited→size-preserving-transitivity-≈ =
  ¬ A ∞            ↝⟨ uninhabited→trivial ⟩
  (∀ x y → x ≈ y)  ↝⟨ (λ trivial {_ _ _ _} _ _ → trivial _ _) ⟩□
  Transitivity-≈   □

-- If A ∞ is uninhabited, then there is a fully size-preserving
-- transitivity proof for expansion.

uninhabited→size-preserving-transitivity-≳ : ¬ A ∞ → Transitivity-≳
uninhabited→size-preserving-transitivity-≳ =
  ¬ A ∞            ↝⟨ uninhabited→trivial ⟩
  (∀ x y → x ≳ y)  ↝⟨ (λ trivial {_ _ _ _} _ _ → trivial _ _) ⟩□
  Transitivity-≳   □

-- If A ∞ is uninhabited, then there is a transitivity-like proof,
-- taking expansion and weak bisimilarity to weak bisimilarity, that
-- preserves the size of the first argument.

uninhabited→size-preserving-transitivity-≳≈ˡ : ¬ A ∞ → Transitivity-≳≈ˡ
uninhabited→size-preserving-transitivity-≳≈ˡ =
  ¬ A ∞             ↝⟨ uninhabited→trivial ⟩
  (∀ x y → x ≈ y)   ↝⟨ (λ trivial {_ _ _ _} _ _ → trivial _ _) ⟩□
  Transitivity-≳≈ˡ  □

-- If A ∞ is uninhabited, then there is a transitivity-like proof,
-- taking expansion and weak bisimilarity to weak bisimilarity, that
-- preserves the size of both arguments.

uninhabited→size-preserving-transitivity-≳≈ : ¬ A ∞ → Transitivity-≳≈
uninhabited→size-preserving-transitivity-≳≈ =
  ¬ A ∞            ↝⟨ uninhabited→trivial ⟩
  (∀ x y → x ≈ y)  ↝⟨ (λ trivial {_ _ _ _} _ _ → trivial _ _) ⟩□
  Transitivity-≳≈  □

-- If A ∞ is uninhabited, then there is a transitivity-like proof,
-- taking weak bisimilarity and expansion to weak bisimilarity, that
-- preserves the size of the first argument.

uninhabited→size-preserving-transitivity-≈≳ˡ : ¬ A ∞ → Transitivity-≈≳ˡ
uninhabited→size-preserving-transitivity-≈≳ˡ =
  ¬ A ∞             ↝⟨ uninhabited→trivial ⟩
  (∀ x y → x ≈ y)   ↝⟨ (λ trivial {_ _ _ _} _ _ → trivial _ _) ⟩□
  Transitivity-≈≳ˡ  □


-- ---------------------------------------------------------------------
--  Geometric Group Theory (topics from)
-- ------------------------------------------
-- actions are usually denoted as `·` (\cdot)
--  mimics structure in stdlib
-- ---------------------------------------------------------------------

module GGT where
open import GGT.Definitions public
open import GGT.Structures public
open import GGT.Bundles public


------------------------------------------------------------------------
-- Queue instances for the queues in Queue.Truncated
------------------------------------------------------------------------

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

import Equality.Path as P
open import Prelude
import Queue

module Queue.Truncated.Instances
  {e⁺}
  (eq : ∀ {a p} → P.Equality-with-paths a p e⁺)
  (open P.Derived-definitions-and-properties eq)

  {Q : ∀ {ℓ} → Type ℓ → Type ℓ}
  ⦃ is-queue :
      ∀ {ℓ} →
      Queue.Is-queue equality-with-J Q (λ _ → ↑ _ ⊤) ℓ ⦄
  ⦃ is-queue-with-map :
      ∀ {ℓ₁ ℓ₂} →
      Queue.Is-queue-with-map equality-with-J Q ℓ₁ ℓ₂ ⦄
  where

open Queue equality-with-J
open import Queue.Truncated eq as Q using (Queue)

open import Bijection equality-with-J using (_↔_)
open import Erased.Cubical eq hiding (map)
open import H-level.Closure equality-with-J
open import List equality-with-J as L hiding (map)
open import Maybe equality-with-J
open import Monad equality-with-J hiding (map)
import Nat equality-with-J as Nat

private

  variable
    a ℓ ℓ₁ ℓ₂ : Level
    A         : Type a
    xs        : List A

  module N = Q.Non-indexed

instance

  -- Instances.

  Queue-is-queue : Is-queue (Queue Q) Very-stableᴱ-≡ ℓ
  Queue-is-queue .Is-queue.to-List           = Q.to-List
  Queue-is-queue .Is-queue.from-List         = Q.from-List
  Queue-is-queue .Is-queue.to-List-from-List = _↔_.right-inverse-of
                                                 (Q.Queue↔List _) _
  Queue-is-queue .Is-queue.enqueue           = N.enqueue
  Queue-is-queue .Is-queue.to-List-enqueue   = N.to-List-enqueue
  Queue-is-queue .Is-queue.dequeue           = N.dequeue
  Queue-is-queue .Is-queue.to-List-dequeue   = N.to-List-dequeue
  Queue-is-queue .Is-queue.dequeue⁻¹         = N.dequeue⁻¹
  Queue-is-queue .Is-queue.to-List-dequeue⁻¹ = N.to-List-dequeue⁻¹

  Queue-is-queue-with-map : Is-queue-with-map (Queue Q) ℓ₁ ℓ₂
  Queue-is-queue-with-map .Is-queue-with-map.map         = N.map
  Queue-is-queue-with-map .Is-queue-with-map.to-List-map = N.to-List-map

  Queue-is-queue-with-unique-representations :
    Is-queue-with-unique-representations (Queue Q) ℓ
  Queue-is-queue-with-unique-representations
    .Is-queue-with-unique-representations.from-List-to-List =
    _↔_.left-inverse-of (Q.Queue↔List _) _

------------------------------------------------------------------------
-- Some examples

private

  ns       = Very-stable→Very-stableᴱ 1 $
             Decidable-equality→Very-stable-≡ Nat._≟_
  dequeue′ = dequeue ns
  to-List′ = to-List ns
  empty′   = empty ⦂ Queue Q ℕ

  example₁ : map suc (enqueue 3 empty) ≡ enqueue 4 empty′
  example₁ = _↔_.to Q.≡-for-indices↔≡ [ refl _ ]

  example₂ : dequeue′ (map (_* 2) (enqueue 3 (enqueue 5 empty))) ≡
             just (10 , enqueue 6 empty)
  example₂ =
    dequeue′ (map (_* 2) (enqueue 3 (enqueue 5 empty)))  ≡⟨ cong dequeue′ (_↔_.to Q.≡-for-indices↔≡ [ refl _ ]) ⟩
    dequeue′ (cons 10 (enqueue 6 empty))                 ≡⟨ _↔_.right-inverse-of (Queue↔Maybe[×Queue] _) _ ⟩∎
    just (10 , enqueue 6 empty)                          ∎

  example₃ :
    (do x , q ← dequeue′ (map (_* 2) (enqueue 3 (enqueue 5 empty)))
        return (enqueue (3 * x) q)) ≡
    just (enqueue 30 (enqueue 6 empty))
  example₃ =
    (do x , q ← dequeue′ (map (_* 2) (enqueue 3 (enqueue 5 empty)))
        return (enqueue (3 * x) q ⦂ Queue Q ℕ))                      ≡⟨ cong (_>>= λ _ → return (enqueue _ _)) example₂ ⟩

    (do x , q ← just (10 , enqueue 6 empty)
        return (enqueue (3 * x) (q ⦂ Queue Q ℕ)))                    ≡⟨⟩

    just (enqueue 30 (enqueue 6 empty))                              ∎

  example₄ :
    (do x , q ← dequeue′ (map (_* 2) (enqueue 3 (enqueue 5 empty)))
        let q = enqueue (3 * x) q
        return (to-List′ q)) ≡
    just (6 ∷ 30 ∷ [])
  example₄ =
    (do x , q ← dequeue′ (map (_* 2) (enqueue 3 (enqueue 5 empty)))
        return (to-List′ (enqueue (3 * x) q)))                       ≡⟨ cong (_>>= λ _ → return (to-List′ (enqueue _ _))) example₂ ⟩

    (do x , q ← just (10 , enqueue 6 empty)
        return (to-List′ (enqueue (3 * x) (q ⦂ Queue Q ℕ))))         ≡⟨⟩

    just (to-List′ (enqueue 30 (enqueue 6 empty)))                   ≡⟨ cong just $ to-List-foldl-enqueue-empty _ ⟩∎

    just (6 ∷ 30 ∷ [])                                               ∎

  example₅ :
    ∀ {xs} →
    dequeue′ (from-List (1 ∷ 2 ∷ 3 ∷ xs)) ≡
    just (1 , from-List (2 ∷ 3 ∷ xs))
  example₅ {xs = xs} =
    dequeue′ (from-List (1 ∷ 2 ∷ 3 ∷ xs))       ≡⟨ cong dequeue′ (_↔_.to Q.≡-for-indices↔≡ [ refl _ ]) ⟩
    dequeue′ (cons 1 (from-List (2 ∷ 3 ∷ xs)))  ≡⟨ _↔_.right-inverse-of (Queue↔Maybe[×Queue] _) _ ⟩∎
    just (1 , from-List (2 ∷ 3 ∷ xs))           ∎

  example₆ :
    foldr enqueue empty′ (3 ∷ 2 ∷ 1 ∷ []) ≡
    from-List (1 ∷ 2 ∷ 3 ∷ [])
  example₆ = _↔_.to Q.≡-for-indices↔≡ [ refl _ ]


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

open import Base
open import Homotopy.Pushout

module Homotopy.VanKampen {i} (d : pushout-diag i) where
open pushout-diag d

open import Homotopy.Truncation
open import Homotopy.PathTruncation
open import Homotopy.VanKampen.Guide

module _ (l : legend i C) where
  open legend l

  open import Homotopy.VanKampen.Code d l
  open import Homotopy.VanKampen.CodeToPath d l

  private
    refl⇒code : ∀ p → code p p
    refl⇒code = pushout-rec
      (λ p → code p p)
      (λ _ → ⟧a refl₀)
      (λ _ → ⟧b refl₀)
      (loc-fiber-rec l
        (λ c → transport (λ p → code p p) (glue c) (⟧a refl₀)
             ≡ ⟧b refl₀)
        ⦃ λ _ → b-code-b-is-set _ _ _ _ ⦄
        (λ n →
          transport (λ p → code p p) (glue $ loc n) (⟧a refl₀)
              ≡⟨ trans-diag code (glue $ loc n) $ ⟧a refl₀ ⟩
          transport (λ p → code p (right $ g $ loc n)) (glue $ loc n)
            (transport (a-code (f $ loc n)) (glue $ loc n) (⟧a refl₀))
              ≡⟨ ap (transport (λ p → code p (right $ g $ loc n)) (glue $ loc n))
                    $ trans-a-code-glue-loc n $ ⟧a refl₀ ⟩
          transport (λ p → code p (right $ g $ loc n)) (glue $ loc n) (aa⇒ab n (⟧a refl₀))
              ≡⟨ trans-glue-code-loc n {right $ g $ loc n} $ aa⇒ab n (⟧a refl₀) ⟩
          ab⇒bb n (aa⇒ab n (⟧a refl₀))
              ≡⟨ refl ⟩
          ⟧b refl₀ bb⟦ n ⟧a refl₀ ba⟦ n ⟧b refl₀
              ≡⟨ b-code-b-refl-refl _ _ ⟩∎
          ⟧b refl₀
              ∎))

  path⇒code : ∀ {p₁} {p₂} (q : p₁ ≡₀ p₂) → code p₁ p₂
  path⇒code {p₁} {p₂} = π₀-extend-nondep
    ⦃ code-is-set p₁ p₂ ⦄
    (λ q → transport (code p₁) q (refl⇒code p₁))

  private
    refl⇒code⇒path : ∀ p → code⇒path (refl⇒code p) ≡ refl₀ {a = p}
    refl⇒code⇒path = pushout-rec
      (λ p → code⇒path (refl⇒code p) ≡ refl₀)
      (λ _ → refl)
      (λ _ → refl)
      (λ _ → prop-has-all-paths (π₀-is-set _ _ _) _ _)

    path′⇒code⇒path : ∀ {p₁ p₂} (q : p₁ ≡ p₂) → code⇒path (path⇒code $ proj q) ≡ proj q
    path′⇒code⇒path refl = refl⇒code⇒path _

  path⇒code⇒path : ∀ {p₁ p₂} (q : p₁ ≡₀ p₂) → code⇒path (path⇒code q) ≡ q
  path⇒code⇒path {p₁} {p₂} = π₀-extend
    ⦃ λ _ → ≡-is-set $ π₀-is-set (p₁ ≡ p₂) ⦄
    (path′⇒code⇒path {p₁} {p₂})

  private
    pgl : ∀ n → _≡₀_ {A = P} (left (f $ loc n)) (right (g $ loc n))
    pgl n = proj (glue $ loc n)

    p!gl : ∀ n → _≡₀_ {A = P} (right (g $ loc n)) (left (f $ loc n))
    p!gl n = proj (! (glue $ loc n))

    ap₀l : ∀ {a₁ a₂} → a₁ ≡₀ a₂ → _≡₀_ {A = P} (left a₁) (left a₂)
    ap₀l p = ap₀ left p

    ap₀r : ∀ {b₁ b₂} → b₁ ≡₀ b₂ → _≡₀_ {A = P} (right b₁) (right b₂)
    ap₀r p = ap₀ right p

  private
    path⇒code-concat₀ : ∀ {p₁ p₂ p₃} (q : p₁ ≡₀ p₂) (r : p₂ ≡ p₃)
      → path⇒code (q ∘₀ proj r) ≡ transport (code p₁) r (path⇒code q)
    path⇒code-concat₀ q refl = ap path⇒code $ refl₀-right-unit q

    module _ {a₁} where
      ap⇒path⇒ap-split :
          (∀ {a₂} (co : a-code-a a₁ a₂) → path⇒code (aa⇒path co) ≡ co)
        × (∀ {b₂} (co : a-code-b a₁ b₂) → path⇒code (ab⇒path co) ≡ co)
      ap⇒path⇒ap-split = a-code-rec a₁
        (λ {a₂} (co : a-code-a a₁ a₂) → path⇒code (aa⇒path co) ≡ co)
        ⦃ λ {a₂} _ → ≡-is-set $ a-code-a-is-set a₁ a₂ ⦄
        (λ {b₂} (co : a-code-b a₁ b₂) → path⇒code (ab⇒path co) ≡ co)
        ⦃ λ {b₂} _ → ≡-is-set $ a-code-b-is-set a₁ b₂ ⦄
        (λ {a₂} p → π₀-extend
          {P = λ p → path⇒code (aa⇒path $ ⟧a p) ≡ ⟧a p}
          ⦃ λ _ → ≡-is-set $ a-code-a-is-set a₁ a₂ ⦄
          (λ p → let p′ = proj p in
            path⇒code (ap₀l p′)
              ≡⟨ refl ⟩
            transport (a-code a₁) (ap left p) (path⇒code $ refl₀ {a = left a₁})
              ≡⟨ trans-ap (a-code a₁) left p $ ⟧a refl₀ ⟩
            transport (a-code-a a₁) p (⟧a refl₀)
              ≡⟨ trans-a-code-a p refl₀ ⟩∎
            ⟧a proj p
              ∎) p)
        (λ {a₂} n {co} eq p → π₀-extend
          {P = λ p → path⇒code (aa⇒path $ co ab⟦ n ⟧a p) ≡ co ab⟦ n ⟧a p}
          ⦃ λ _ → ≡-is-set $ a-code-a-is-set a₁ a₂ ⦄
          (λ p → let p′ = proj p in
            path⇒code ((ab⇒path co ∘₀ p!gl n) ∘₀ ap₀l p′)
                ≡⟨ path⇒code-concat₀ (ab⇒path co ∘₀ p!gl n) (ap left p) ⟩
            transport (a-code a₁) (ap left p) (path⇒code (ab⇒path co ∘₀ p!gl n))
                ≡⟨ trans-ap (a-code a₁) left p $ path⇒code $ ab⇒path co ∘₀ p!gl n ⟩
            transport (a-code-a a₁) p (path⇒code (ab⇒path co ∘₀ p!gl n))
                ≡⟨ ap (transport (a-code-a a₁) p)
                      $ path⇒code-concat₀ (ab⇒path co) (! (glue $ loc n)) ⟩
            transport (a-code-a a₁) p (transport (a-code a₁) (! (glue $ loc n))
              $ path⇒code $ ab⇒path co)
                ≡⟨ ap (transport (a-code-a a₁) p ◯ transport (a-code a₁) (! (glue $ loc n))) eq ⟩
            transport (a-code-a a₁) p (transport (a-code a₁) (! (glue $ loc n)) co)
                ≡⟨ ap (transport (a-code-a a₁) p) $ trans-a-code-!glue-loc n co ⟩
            transport (a-code-a a₁) p (co ab⟦ n ⟧a refl₀)
                ≡⟨ trans-a-code-ba p n co refl₀ ⟩∎
            co ab⟦ n ⟧a p′
                ∎) p)
        (λ {b₂} n {co} eq p → π₀-extend
          {P = λ p → path⇒code (ab⇒path $ co aa⟦ n ⟧b p) ≡ co aa⟦ n ⟧b p}
          ⦃ λ _ → ≡-is-set $ a-code-b-is-set a₁ b₂ ⦄
          (λ p → let p′ = proj p in
            path⇒code ((aa⇒path co ∘₀ pgl n) ∘₀ ap₀r p′)
                ≡⟨ path⇒code-concat₀ (aa⇒path co ∘₀ pgl n) (ap right p) ⟩
            transport (a-code a₁) (ap right p) (path⇒code (aa⇒path co ∘₀ pgl n))
                ≡⟨ trans-ap (a-code a₁) right p $ path⇒code $ aa⇒path co ∘₀ pgl n ⟩
            transport (a-code-b a₁) p (path⇒code (aa⇒path co ∘₀ pgl n))
                ≡⟨ ap (transport (a-code-b a₁) p)
                      $ path⇒code-concat₀ (aa⇒path co) (glue $ loc n) ⟩
            transport (a-code-b a₁) p (transport (a-code a₁) (glue $ loc n)
              $ path⇒code $ aa⇒path co)
                ≡⟨ ap (transport (a-code-b a₁) p ◯ transport (a-code a₁) (glue $ loc n)) eq ⟩
            transport (a-code-b a₁) p (transport (a-code a₁) (glue $ loc n) co)
                ≡⟨ ap (transport (a-code-b a₁) p) $ trans-a-code-glue-loc n co ⟩
            transport (a-code-b a₁) p (co aa⟦ n ⟧b refl₀)
                ≡⟨ trans-a-code-ab p n co refl₀ ⟩∎
            co aa⟦ n ⟧b p′
                ∎) p)
        (λ _ _ → prop-has-all-paths (a-code-a-is-set a₁ _ _ _) _ _)
        (λ _ _ → prop-has-all-paths (a-code-b-is-set a₁ _ _ _) _ _)
        (λ _ _ _ _ → prop-has-all-paths (a-code-a-is-set a₁ _ _ _) _ _)

      ap⇒path⇒ap : ∀ {p₂} (co : a-code a₁ p₂) → path⇒code {left a₁} {p₂} (ap⇒path co) ≡ co
      ap⇒path⇒ap {p₂} = pushout-rec
        (λ x → ∀ (co : a-code a₁ x) → path⇒code {left a₁} {x} (ap⇒path co) ≡ co)
        (λ _ → π₁ ap⇒path⇒ap-split)
        (λ _ → π₂ ap⇒path⇒ap-split)
        (λ _ → funext λ _ → prop-has-all-paths (a-code-b-is-set a₁ _ _ _) _ _)
        p₂

    -- FIXME Duplicate code!
    -- Unless there's a way to handle type-conversion nicely
    -- (with definitional equality), I'd rather copy and paste.
    module _ {b₁} where
      bp⇒path⇒bp-split :
          (∀ {b₂} (co : b-code-b b₁ b₂) → path⇒code (bb⇒path co) ≡ co)
        × (∀ {a₂} (co : b-code-a b₁ a₂) → path⇒code (ba⇒path co) ≡ co)
      bp⇒path⇒bp-split = b-code-rec b₁
        (λ {b₂} (co : b-code-b b₁ b₂) → path⇒code (bb⇒path co) ≡ co)
        ⦃ λ {b₂} _ → ≡-is-set $ b-code-b-is-set b₁ b₂ ⦄
        (λ {a₂} (co : b-code-a b₁ a₂) → path⇒code (ba⇒path co) ≡ co)
        ⦃ λ {a₂} _ → ≡-is-set $ b-code-a-is-set b₁ a₂ ⦄
        (λ {b₂} p → π₀-extend
          {P = λ p → path⇒code (bb⇒path $ ⟧b p) ≡ ⟧b p}
          ⦃ λ _ → ≡-is-set $ b-code-b-is-set b₁ b₂ ⦄
          (λ p → let p′ = proj p in
            path⇒code (ap₀r p′)
              ≡⟨ refl ⟩
            transport (b-code b₁) (ap right p) (path⇒code $ refl₀ {a = right b₁})
              ≡⟨ trans-ap (b-code b₁) right p $ ⟧b refl₀ ⟩
            transport (b-code-b b₁) p (⟧b refl₀)
              ≡⟨ trans-b-code-b p refl₀ ⟩∎
            ⟧b proj p
              ∎) p)
        (λ {b₂} n {co} eq p → π₀-extend
          {P = λ p → path⇒code (bb⇒path $ co ba⟦ n ⟧b p) ≡ co ba⟦ n ⟧b p}
          ⦃ λ _ → ≡-is-set $ b-code-b-is-set b₁ b₂ ⦄
          (λ p → let p′ = proj p in
            path⇒code ((ba⇒path co ∘₀ pgl n) ∘₀ ap₀r p′)
                ≡⟨ path⇒code-concat₀ (ba⇒path co ∘₀ pgl n) (ap right p) ⟩
            transport (b-code b₁) (ap right p) (path⇒code (ba⇒path co ∘₀ pgl n))
                ≡⟨ trans-ap (b-code b₁) right p $ path⇒code $ ba⇒path co ∘₀ pgl n ⟩
            transport (b-code-b b₁) p (path⇒code (ba⇒path co ∘₀ pgl n))
                ≡⟨ ap (transport (b-code-b b₁) p)
                      $ path⇒code-concat₀ (ba⇒path co) (glue $ loc n) ⟩
            transport (b-code-b b₁) p (transport (b-code b₁) (glue $ loc n)
              $ path⇒code $ ba⇒path co)
                ≡⟨ ap (transport (b-code-b b₁) p ◯ transport (b-code b₁) (glue $ loc n)) eq ⟩
            transport (b-code-b b₁) p (transport (b-code b₁) (glue $ loc n) co)
                ≡⟨ ap (transport (b-code-b b₁) p) $ trans-b-code-glue-loc n co ⟩
            transport (b-code-b b₁) p (co ba⟦ n ⟧b refl₀)
                ≡⟨ trans-b-code-ab p n co refl₀ ⟩∎
            co ba⟦ n ⟧b p′
                ∎) p)
        (λ {a₂} n {co} eq p → π₀-extend
          {P = λ p → path⇒code (ba⇒path $ co bb⟦ n ⟧a p) ≡ co bb⟦ n ⟧a p}
          ⦃ λ _ → ≡-is-set $ b-code-a-is-set b₁ a₂ ⦄
          (λ p → let p′ = proj p in
            path⇒code ((bb⇒path co ∘₀ p!gl n) ∘₀ ap₀l p′)
                ≡⟨ path⇒code-concat₀ (bb⇒path co ∘₀ p!gl n) (ap left p) ⟩
            transport (b-code b₁) (ap left p) (path⇒code (bb⇒path co ∘₀ p!gl n))
                ≡⟨ trans-ap (b-code b₁) left p $ path⇒code $ bb⇒path co ∘₀ p!gl n ⟩
            transport (b-code-a b₁) p (path⇒code (bb⇒path co ∘₀ p!gl n))
                ≡⟨ ap (transport (b-code-a b₁) p)
                      $ path⇒code-concat₀ (bb⇒path co) (! (glue $ loc n)) ⟩
            transport (b-code-a b₁) p (transport (b-code b₁) (! (glue $ loc n))
              $ path⇒code $ bb⇒path co)
                ≡⟨ ap (transport (b-code-a b₁) p ◯ transport (b-code b₁) (! (glue $ loc n))) eq ⟩
            transport (b-code-a b₁) p (transport (b-code b₁) (! (glue $ loc n)) co)
                ≡⟨ ap (transport (b-code-a b₁) p) $ trans-b-code-!glue-loc n co ⟩
            transport (b-code-a b₁) p (co bb⟦ n ⟧a refl₀)
                ≡⟨ trans-b-code-ba p n co refl₀ ⟩∎
            co bb⟦ n ⟧a p′
                ∎) p)
        (λ _ _ → prop-has-all-paths (b-code-b-is-set b₁ _ _ _) _ _)
        (λ _ _ → prop-has-all-paths (b-code-a-is-set b₁ _ _ _) _ _)
        (λ _ _ _ _ → prop-has-all-paths (b-code-b-is-set b₁ _ _ _) _ _)

      bp⇒path⇒bp : ∀ {p₂} (co : b-code b₁ p₂) → path⇒code {right b₁} {p₂} (bp⇒path co) ≡ co
      bp⇒path⇒bp {p₂} = pushout-rec
        (λ x → ∀ (co : b-code b₁ x) → path⇒code {right b₁} {x} (bp⇒path co) ≡ co)
        (λ _ → π₂ bp⇒path⇒bp-split)
        (λ _ → π₁ bp⇒path⇒bp-split)
        (λ _ → funext λ _ → prop-has-all-paths (b-code-b-is-set b₁ _ _ _) _ _)
        p₂

  code⇒path⇒code : ∀ {p₁ p₂} (co : code p₁ p₂) → path⇒code {p₁} {p₂} (code⇒path co) ≡ co
  code⇒path⇒code {p₁} {p₂} = pushout-rec
    (λ p₁ → ∀ (co : code p₁ p₂) → path⇒code {p₁} {p₂} (code⇒path co) ≡ co)
    (λ a₁ → ap⇒path⇒ap {a₁} {p₂})
    (λ b₁ → bp⇒path⇒bp {b₁} {p₂})
    (λ c → funext λ co → prop-has-all-paths (b-code-is-set (g c) p₂ _ co) _ _)
    p₁

  van-kampen : ∀ {p₁ p₂} → (p₁ ≡₀ p₂) ≡ code p₁ p₂
  van-kampen {p₁} {p₂} =
    eq-to-path $ path⇒code {p₁} {p₂} ,
      iso-is-eq (path⇒code {p₁} {p₂}) (code⇒path {p₁} {p₂})
        (code⇒path⇒code {p₁} {p₂}) (path⇒code⇒path {p₁} {p₂})

module _ where
  open import Homotopy.VanKampen.Code d (id-legend C)

  naive-van-kampen : ∀ {p₁ p₂} → (p₁ ≡₀ p₂) ≡ code p₁ p₂
  naive-van-kampen = van-kampen (id-legend C)


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

open import HoTT
import homotopy.RelativelyConstantToSetExtendsViaSurjection as SurjExt

module homotopy.VanKampen {i j k l}
  (span : Span {i} {j} {k})
  {D : Type l} (h : D → Span.C span) (h-is-surj : is-surj h) where

  open Span span
  open import homotopy.vankampen.CodeAP span h h-is-surj
  open import homotopy.vankampen.CodeBP span h h-is-surj
  open import homotopy.vankampen.Code span h h-is-surj

  -- favonia: [pPP] means path from [P] to [P].
  encode-idp : ∀ p → code p p
  encode-idp = Pushout-elim {P = λ p → code p p}
    (λ a → q[ ⟧a idp₀ ]) (λ b → q[ ⟧b idp₀ ]) lemma where
    abstract
      lemma : ∀ c → q[ ⟧a idp₀ ] == q[ ⟧b idp₀ ] [ (λ p → code p p) ↓ glue c ]
      lemma = SurjExt.ext
        {{↓-preserves-level ⟨⟩}}
        h h-is-surj
        (λ d → from-transp (λ p → code p p) (glue (h d)) $
          transport (λ p → code p p) (glue (h d)) q[ ⟧a idp₀ ]
            =⟨ ap (λ pPP → coe pPP q[ pc-a idp₀ ]) ((! (ap2-diag code (glue (h d)))) ∙ ap2-out code (glue (h d)) (glue (h d))) ⟩
          coe (ap (λ p₀ → code p₀ (left (f (h d)))) (glue (h d)) ∙ ap (codeBP (g (h d))) (glue (h d))) q[ ⟧a idp₀ ]
            =⟨ coe-∙ (ap (λ p₀ → code p₀ (left (f (h d)))) (glue (h d))) (ap (codeBP (g (h d))) (glue (h d))) q[ pc-a idp₀ ] ⟩
          transport (codeBP (g (h d))) (glue (h d)) (transport (λ p₀ → code p₀ (left (f (h d)))) (glue (h d)) q[ ⟧a idp₀ ])
            =⟨ transp-cPA-glue d (⟧a idp₀) |in-ctx transport (λ p₁ → code (right (g (h d))) p₁) (glue (h d)) ⟩
          transport (codeBP (g (h d))) (glue (h d)) q[ ⟧b idp₀ bb⟦ d ⟧a idp₀ ]
            =⟨ transp-cBP-glue d (⟧b idp₀ bb⟦ d ⟧a idp₀) ⟩
          q[ ⟧b idp₀ bb⟦ d ⟧a idp₀ ba⟦ d ⟧b idp₀ ]
            =⟨ quot-rel (pcBBr-idp₀-idp₀ (pc-b idp₀)) ⟩
          q[ ⟧b idp₀ ]
            =∎)
        (λ _ _ _ → prop-has-all-paths-↓ {{↓-level ⟨⟩}})

  encode : ∀ {p₀ p₁} → p₀ =₀ p₁ → code p₀ p₁
  encode {p₀} {p₁} pPP = transport₀ (code p₀) {{code-is-set {p₀} {p₁}}} pPP (encode-idp p₀)

  abstract
    decode-encode-idp : ∀ p → decode {p} {p} (encode-idp p) == idp₀
    decode-encode-idp = Pushout-elim
      {P = λ p → decode {p} {p} (encode-idp p) == idp₀}
      (λ _ → idp) (λ _ → idp)
      (λ c → prop-has-all-paths-↓)

    decode-encode' : ∀ {p₀ p₁} (pPP : p₀ == p₁) → decode {p₀} {p₁} (encode [ pPP ]) == [ pPP ]
    decode-encode' idp = decode-encode-idp _

    decode-encode : ∀ {p₀ p₁} (pPP : p₀ =₀ p₁) → decode {p₀} {p₁} (encode pPP) == pPP
    decode-encode = Trunc-elim decode-encode'

  abstract
    transp-idcAA-r : ∀ {a₀ a₁} (p : a₀ == a₁) -- [idc] = identity code
      → transport (codeAA a₀) p q[ ⟧a idp₀ ] == q[ ⟧a [ p ] ]
    transp-idcAA-r idp = idp

    encode-decodeAA : ∀ {a₀ a₁} (c : precodeAA a₀ a₁)
      → encode (decodeAA q[ c ]) == q[ c ]
    encode-decodeAB : ∀ {a₀ b₁} (c : precodeAB a₀ b₁)
      → encode (decodeAB q[ c ]) == q[ c ]
    encode-decodeAA {a₀} (pc-a pA) = Trunc-elim
      {P = λ pA → encode (decodeAA q[ ⟧a pA ]) == q[ ⟧a pA ]}
      (λ pA →
        transport (codeAP a₀) (ap left pA) q[ ⟧a idp₀ ]
          =⟨ ap (λ e → coe e q[ ⟧a idp₀ ]) (∘-ap (codeAP a₀) left pA) ⟩
        transport (codeAA a₀) pA q[ ⟧a idp₀ ]
          =⟨ transp-idcAA-r pA ⟩
        q[ ⟧a [ pA ] ]
          =∎)
      pA
    encode-decodeAA {a₀} (pc-aba d pc pA) = Trunc-elim
      {P = λ pA → encode (decodeAA q[ pc ab⟦ d ⟧a pA ]) == q[ pc ab⟦ d ⟧a pA ]}
      (λ pA →
        encode (decodeAB q[ pc ] ∙₀' [ ! (glue (h d)) ∙' ap left pA ])
          =⟨ transp₀-∙₀' {{λ {p₁} → code-is-set {left a₀} {p₁}}} (decodeAB q[ pc ]) [ ! (glue (h d)) ∙' ap left pA ] (encode-idp (left a₀)) ⟩
        transport (codeAP a₀) (! (glue (h d)) ∙' ap left pA) (encode (decodeAB q[ pc ]))
          =⟨ ap (transport (codeAP a₀) (! (glue (h d)) ∙' ap left pA)) (encode-decodeAB pc) ⟩
        transport (codeAP a₀) (! (glue (h d)) ∙' ap left pA) q[ pc ]
          =⟨ transp-∙' {B = codeAP a₀} (! (glue (h d))) (ap left pA) q[ pc ] ⟩
        transport (codeAP a₀) (ap left pA) (transport (codeAP a₀) (! (glue (h d))) q[ pc ])
          =⟨ ap (transport (codeAP a₀) (ap left pA)) (transp-cAP-!glue d pc) ⟩
        transport (codeAP a₀) (ap left pA) q[ pc ab⟦ d ⟧a idp₀ ]
          =⟨ ap (λ e → coe e q[ pc ab⟦ d ⟧a idp₀ ]) (∘-ap (codeAP a₀) left pA) ⟩
        transport (codeAA a₀) pA q[ pc ab⟦ d ⟧a idp₀ ]
          =⟨ transp-cAA-r d pA (pc ab⟦ d ⟧a idp₀) ⟩
        q[ pc ab⟦ d ⟧a idp₀ aa⟦ d ⟧b idp₀ ab⟦ d ⟧a [ pA ] ]
          =⟨ quot-rel (pcAAr-cong (pcABr-idp₀-idp₀ pc) [ pA ]) ⟩
        q[ pc ab⟦ d ⟧a [ pA ] ]
          =∎)
      pA
    encode-decodeAB {a₀} (pc-aab d pc pB) = Trunc-elim
      {P = λ pB → encode (decodeAB q[ pc aa⟦ d ⟧b pB ]) == q[ pc aa⟦ d ⟧b pB ]}
      (λ pB →
        encode (decodeAA q[ pc ] ∙₀' [ glue (h d) ∙' ap right pB ])
          =⟨ transp₀-∙₀' {{λ {p₁} → code-is-set {left a₀} {p₁}}} (decodeAA q[ pc ]) [ glue (h d) ∙' ap right pB ] (encode-idp (left a₀)) ⟩
        transport (codeAP a₀) (glue (h d) ∙' ap right pB) (encode (decodeAA q[ pc ]))
          =⟨ ap (transport (codeAP a₀) (glue (h d) ∙' ap right pB)) (encode-decodeAA pc) ⟩
        transport (codeAP a₀) (glue (h d) ∙' ap right pB) q[ pc ]
          =⟨ transp-∙' {B = codeAP a₀} (glue (h d)) (ap right pB) q[ pc ] ⟩
        transport (codeAP a₀) (ap right pB) (transport (codeAP a₀) (glue (h d)) q[ pc ])
          =⟨ ap (transport (codeAP a₀) (ap right pB)) (transp-cAP-glue d pc) ⟩
        transport (codeAP a₀) (ap right pB) q[ pc aa⟦ d ⟧b idp₀ ]
          =⟨ ap (λ e → coe e q[ pc aa⟦ d ⟧b idp₀ ]) (∘-ap (codeAP a₀) right pB) ⟩
        transport (codeAB a₀) pB q[ pc aa⟦ d ⟧b idp₀ ]
          =⟨ transp-cAB-r d pB (pc aa⟦ d ⟧b idp₀) ⟩
        q[ pc aa⟦ d ⟧b idp₀ ab⟦ d ⟧a idp₀ aa⟦ d ⟧b [ pB ] ]
          =⟨ quot-rel (pcABr-cong (pcAAr-idp₀-idp₀ pc) [ pB ]) ⟩
        q[ pc aa⟦ d ⟧b [ pB ] ]
          =∎)
      pB

  abstract
    transp-idcBB-r : ∀ {b₀ b₁} (p : b₀ == b₁) -- [idc] = identity code
      → transport (codeBB b₀) p q[ ⟧b idp₀ ] == q[ ⟧b [ p ] ]
    transp-idcBB-r idp = idp

    encode-decodeBA : ∀ {b₀ a₁} (c : precodeBA b₀ a₁)
      → encode (decodeBA q[ c ]) == q[ c ]
    encode-decodeBB : ∀ {b₀ b₁} (c : precodeBB b₀ b₁)
      → encode (decodeBB q[ c ]) == q[ c ]
    encode-decodeBA {b₀} (pc-bba d pc pA) = Trunc-elim
      {P = λ pA → encode (decodeBA q[ pc bb⟦ d ⟧a pA ]) == q[ pc bb⟦ d ⟧a pA ]}
      (λ pA →
        encode (decodeBB q[ pc ] ∙₀' [ ! (glue (h d)) ∙' ap left pA ])
          =⟨ transp₀-∙₀' {{λ {p₁} → code-is-set {right b₀} {p₁}}} (decodeBB q[ pc ]) [ ! (glue (h d)) ∙' ap left pA ] (encode-idp (right b₀)) ⟩
        transport (codeBP b₀) (! (glue (h d)) ∙' ap left pA) (encode (decodeBB q[ pc ]))
          =⟨ ap (transport (codeBP b₀) (! (glue (h d)) ∙' ap left pA)) (encode-decodeBB pc) ⟩
        transport (codeBP b₀) (! (glue (h d)) ∙' ap left pA) q[ pc ]
          =⟨ transp-∙' {B = codeBP b₀} (! (glue (h d))) (ap left pA) q[ pc ] ⟩
        transport (codeBP b₀) (ap left pA) (transport (codeBP b₀) (! (glue (h d))) q[ pc ])
          =⟨ ap (transport (codeBP b₀) (ap left pA)) (transp-cBP-!glue d pc) ⟩
        transport (codeBP b₀) (ap left pA) q[ pc bb⟦ d ⟧a idp₀ ]
          =⟨ ap (λ e → coe e q[ pc bb⟦ d ⟧a idp₀ ]) (∘-ap (codeBP b₀) left pA) ⟩
        transport (codeBA b₀) pA q[ pc bb⟦ d ⟧a idp₀ ]
          =⟨ transp-cBA-r d pA (pc bb⟦ d ⟧a idp₀) ⟩
        q[ pc bb⟦ d ⟧a idp₀ ba⟦ d ⟧b idp₀ bb⟦ d ⟧a [ pA ] ]
          =⟨ quot-rel (pcBAr-cong (pcBBr-idp₀-idp₀ pc) [ pA ]) ⟩
        q[ pc bb⟦ d ⟧a [ pA ] ]
          =∎)
      pA
    encode-decodeBB {b₀} (pc-b pB) = Trunc-elim
      {P = λ pB → encode (decodeBB q[ ⟧b pB ]) == q[ ⟧b pB ]}
      (λ pB →
        transport (codeBP b₀) (ap right pB) q[ ⟧b idp₀ ]
          =⟨ ap (λ e → coe e q[ ⟧b idp₀ ]) (∘-ap (codeBP b₀) right pB) ⟩
        transport (codeBB b₀) pB q[ ⟧b idp₀ ]
          =⟨ transp-idcBB-r pB ⟩
        q[ ⟧b [ pB ] ]
          =∎)
      pB
    encode-decodeBB {b₀} (pc-bab d pc pB) = Trunc-elim
      {P = λ pB → encode (decodeBB q[ pc ba⟦ d ⟧b pB ]) == q[ pc ba⟦ d ⟧b pB ]}
      (λ pB →
        encode (decodeBA q[ pc ] ∙₀' [ glue (h d) ∙' ap right pB ])
          =⟨ transp₀-∙₀' {{λ {p₁} → code-is-set {right b₀} {p₁}}} (decodeBA q[ pc ]) [ glue (h d) ∙' ap right pB ] (encode-idp (right b₀)) ⟩
        transport (codeBP b₀) (glue (h d) ∙' ap right pB) (encode (decodeBA q[ pc ]))
          =⟨ ap (transport (codeBP b₀) (glue (h d) ∙' ap right pB)) (encode-decodeBA pc) ⟩
        transport (codeBP b₀) (glue (h d) ∙' ap right pB) q[ pc ]
          =⟨ transp-∙' {B = codeBP b₀} (glue (h d)) (ap right pB) q[ pc ] ⟩
        transport (codeBP b₀) (ap right pB) (transport (codeBP b₀) (glue (h d)) q[ pc ])
          =⟨ ap (transport (codeBP b₀) (ap right pB)) (transp-cBP-glue d pc) ⟩
        transport (codeBP b₀) (ap right pB) q[ pc ba⟦ d ⟧b idp₀ ]
          =⟨ ap (λ e → coe e q[ pc ba⟦ d ⟧b idp₀ ]) (∘-ap (codeBP b₀) right pB) ⟩
        transport (codeBB b₀) pB q[ pc ba⟦ d ⟧b idp₀ ]
          =⟨ transp-cBB-r d pB (pc ba⟦ d ⟧b idp₀) ⟩
        q[ pc ba⟦ d ⟧b idp₀ bb⟦ d ⟧a idp₀ ba⟦ d ⟧b [ pB ] ]
          =⟨ quot-rel (pcBBr-cong (pcBAr-idp₀-idp₀ pc) [ pB ]) ⟩
        q[ pc ba⟦ d ⟧b [ pB ] ]
          =∎)
      pB

  abstract
    encode-decode : ∀ {p₀ p₁} (cPP : code p₀ p₁)
      → encode {p₀} {p₁} (decode {p₀} {p₁} cPP) == cPP
    encode-decode {p₀} {p₁} = Pushout-elim
      {P = λ p₀ → ∀ p₁ → (cPP : code p₀ p₁) → encode (decode {p₀} {p₁} cPP) == cPP}
      (λ a₀ → Pushout-elim
        (λ a₁ → SetQuot-elim
          {P = λ cPP → encode (decodeAA cPP) == cPP}
          (encode-decodeAA {a₀} {a₁})
          (λ _ → prop-has-all-paths-↓))
        (λ b₁ → SetQuot-elim
          {P = λ cPP → encode (decodeAB cPP) == cPP}
          (encode-decodeAB {a₀} {b₁})
          (λ _ → prop-has-all-paths-↓))
        (λ _ → prop-has-all-paths-↓))
      (λ b₀ → Pushout-elim
        (λ a₁ → SetQuot-elim
          {P = λ cPP → encode (decodeBA cPP) == cPP}
          (encode-decodeBA {b₀} {a₁})
          (λ _ → prop-has-all-paths-↓))
        (λ b₁ → SetQuot-elim
          {P = λ cPP → encode (decodeBB cPP) == cPP}
          (encode-decodeBB {b₀} {b₁})
          (λ _ → prop-has-all-paths-↓))
        (λ _ → prop-has-all-paths-↓))
      (λ _ → prop-has-all-paths-↓ {{Π-level (λ p₁ → Π-level (λ cPP → has-level-apply (codeBP-is-set {p₁ = p₁}) _ _))}})
      p₀ p₁

  vankampen : ∀ p₀ p₁ → (p₀ =₀ p₁) ≃ code p₀ p₁
  vankampen p₀ p₁ = equiv (encode {p₀} {p₁}) (decode {p₀} {p₁}) (encode-decode {p₀} {p₁}) (decode-encode {p₀} {p₁})


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Algebra.Group.MorphismProperties where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Transport
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.SIP
open import Cubical.Foundations.Function using (_∘_)
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Functions.Embedding
open import Cubical.Data.Sigma

open import Cubical.Structures.Axioms
open import Cubical.Structures.Pointed
open import Cubical.Algebra.Semigroup
open import Cubical.Algebra.Monoid

open import Cubical.Algebra.Group.Base
open import Cubical.Algebra.Group.Properties
open import Cubical.Algebra.Group.Morphism

open import Cubical.Reflection.StrictEquiv

private
  variable
    ℓ ℓ' ℓ'' : Level

open Iso
open GroupStr
open GroupHom

isPropIsGroupHom : (G : Group {ℓ}) (H : Group {ℓ'}) {f : ⟨ G ⟩ → ⟨ H ⟩} → isProp (isGroupHom G H f)
isPropIsGroupHom G H {f} = isPropΠ2 λ a b → GroupStr.is-set (snd H) _ _

isSetGroupHom : {G : Group {ℓ}} {H : Group {ℓ'}} → isSet (GroupHom G H)
isSetGroupHom {G = G} {H = H} = isOfHLevelRespectEquiv 2 equiv (isSetΣ (isSetΠ λ _ → is-set (snd H)) λ _ → isProp→isSet (isPropIsGroupHom G H)) where
  equiv : (Σ[ g ∈ (⟨ G ⟩ → ⟨ H ⟩) ] (isGroupHom G H g)) ≃ (GroupHom G H)
  equiv =  isoToEquiv (iso (λ (g , m) → grouphom g m) (λ hom → fun hom , isHom hom) (λ _ → refl) λ _ → refl)

-- Morphism composition
isGroupHomComp : {F : Group {ℓ}} {G : Group {ℓ'}} {H : Group {ℓ''}} →
  (f : GroupHom F G) → (g : GroupHom G H) → isGroupHom F H (fun g ∘ fun f)
isGroupHomComp f g x y = cong (fun g) (isHom f _ _) ∙ isHom g _ _

compGroupHom : {F : Group {ℓ}} {G : Group {ℓ'}} {H : Group {ℓ''}} → GroupHom F G → GroupHom G H → GroupHom F H
fun (compGroupHom f g) = fun g ∘ fun f
isHom (compGroupHom f g) = isGroupHomComp f g

open GroupEquiv
compGroupEquiv : {F : Group {ℓ}} {G : Group {ℓ'}} {H : Group {ℓ''}} → GroupEquiv F G → GroupEquiv G H → GroupEquiv F H
eq (compGroupEquiv f g) = compEquiv (eq f) (eq g)
isHom (compGroupEquiv f g) = isHom (compGroupHom (hom f) (hom g))

idGroupEquiv : (G : Group {ℓ}) → GroupEquiv G G
eq (idGroupEquiv G) = idEquiv ⟨ G ⟩
isHom (idGroupEquiv G) = λ _ _ → refl

-- Isomorphism inversion
isGroupHomInv : {G : Group {ℓ}} {H : Group {ℓ'}} (f : GroupEquiv G H) → isGroupHom H G (invEq (GroupEquiv.eq f))
isGroupHomInv {G = G} {H = H}  f h h' = isInj-f _ _ (
  f' (g (h ⋆² h')) ≡⟨ retEq (eq f) _ ⟩
  (h ⋆² h') ≡⟨ sym (cong₂ _⋆²_ (retEq (eq f) h) (retEq (eq f) h')) ⟩
  (f' (g h) ⋆² f' (g h')) ≡⟨ sym (isHom (hom f) _ _) ⟩
  f' (g h ⋆¹ g h') ∎)
  where
  f' = fst (eq f)
  _⋆¹_ = _+_ (snd G)
  _⋆²_ = _+_ (snd H)
  g = invEq (eq f)

  isInj-f : (x y : ⟨ G ⟩) → f' x ≡ f' y → x ≡ y
  isInj-f x y = invEq (_ , isEquiv→isEmbedding (snd (eq f)) x y)

invGroupEquiv : {G : Group {ℓ}} {H : Group {ℓ'}} → GroupEquiv G H → GroupEquiv H G
eq (invGroupEquiv f) = invEquiv (eq f)
isHom (invGroupEquiv f) = isGroupHomInv f

dirProdEquiv : ∀ {ℓ ℓ' ℓ'' ℓ'''} {A : Group {ℓ}} {B : Group {ℓ'}} {C : Group {ℓ''}} {D : Group {ℓ'''}}
           → GroupEquiv A C → GroupEquiv B D
           → GroupEquiv (dirProd A B) (dirProd C D)
eq (dirProdEquiv eq1 eq2) = ≃-× (eq eq1) (eq eq2)
isHom (dirProdEquiv eq1 eq2) = isHom (×hom (GroupEquiv.hom eq1) (GroupEquiv.hom eq2))

groupHomEq : {G : Group {ℓ}} {H : Group {ℓ'}} {f g : GroupHom G H} → (fun f ≡ fun g) → f ≡ g
fun (groupHomEq p i) = p i
isHom (groupHomEq {G = G} {H = H} {f = f} {g = g} p i) = p-hom i
  where
  p-hom : PathP (λ i → isGroupHom G H (p i)) (isHom f) (isHom g)
  p-hom = toPathP (isPropIsGroupHom G H _ _)

groupEquivEq : {G : Group {ℓ}} {H : Group {ℓ'}} {f g : GroupEquiv G H} → (eq f ≡ eq g) → f ≡ g
eq (groupEquivEq {G = G} {H = H} {f} {g} p i) = p i
isHom (groupEquivEq {G = G} {H = H} {f} {g} p i) = p-hom i
  where
  p-hom : PathP (λ i → isGroupHom G H (p i .fst)) (isHom f) (isHom g)
  p-hom = toPathP (isPropIsGroupHom G H _ _)

module GroupΣTheory {ℓ} where

  RawGroupStructure : Type ℓ → Type ℓ
  RawGroupStructure = SemigroupΣTheory.RawSemigroupStructure

  RawGroupEquivStr : StrEquiv RawGroupStructure _
  RawGroupEquivStr = SemigroupΣTheory.RawSemigroupEquivStr

  rawGroupUnivalentStr : UnivalentStr RawGroupStructure _
  rawGroupUnivalentStr = SemigroupΣTheory.rawSemigroupUnivalentStr

  -- The neutral element and the inverse function will be derived from the
  -- axioms, instead of being defined in the RawGroupStructure in order
  -- to have that group equivalences are equivalences that preserves
  -- multiplication (so we don't have to show that they also preserve inversion
  -- and neutral element, although they will preserve them).
  GroupAxioms : (G : Type ℓ) → RawGroupStructure G → Type ℓ
  GroupAxioms G _·_ =
      IsSemigroup _·_
    × (Σ[ e ∈ G ] ((x : G) → (x · e ≡ x) × (e · x ≡ x))
                × ((x : G) → Σ[ x' ∈ G ] (x · x' ≡ e) × (x' · x ≡ e)))

  GroupStructure : Type ℓ → Type ℓ
  GroupStructure = AxiomsStructure RawGroupStructure GroupAxioms

  GroupΣ : Type (ℓ-suc ℓ)
  GroupΣ = TypeWithStr ℓ GroupStructure

  -- Structured equivalences for groups are those for monoids (but different axioms)
  GroupEquivStr : StrEquiv GroupStructure ℓ
  GroupEquivStr = AxiomsEquivStr RawGroupEquivStr GroupAxioms

  open MonoidTheory

  isSetGroupΣ : (G : GroupΣ)
               → isSet _
  isSetGroupΣ (_ , _ , (isSemigroup-G , _ , _)) = IsSemigroup.is-set isSemigroup-G

  isPropGroupAxioms : (G : Type ℓ)
                      → (s : RawGroupStructure G)
                      → isProp (GroupAxioms G s)
  isPropGroupAxioms G _+_ = isPropΣ (isPropIsSemigroup _) γ
    where
    γ : (h : IsSemigroup _+_) →
        isProp (Σ[ e ∈ G ] ((x : G) → (x + e ≡ x) × (e + x ≡ x))
                         × ((x : G) → Σ[ x' ∈ G ] (x + x' ≡ e) × (x' + x ≡ e)))
    γ h (e , P , _) (e' , Q , _) =
      Σ≡Prop (λ x → isPropΣ (isPropΠ λ _ → isProp× ((IsSemigroup.is-set h) _ _) ((IsSemigroup.is-set h) _ _)) (β x))
             (sym (fst (Q e)) ∙ snd (P e'))
      where
      β : (e : G) → ((x : G) → (x + e ≡ x) × (e + x ≡ x))
        → isProp ((x : G) → Σ[ x' ∈ G ] (x + x' ≡ e) × (x' + x ≡ e))
      β e He =
        isPropΠ λ { x (x' , _ , P) (x'' , Q , _) →
                Σ≡Prop (λ _ → isProp× ((IsSemigroup.is-set h) _ _) ((IsSemigroup.is-set h) _ _))
                       (inv-lemma ℳ x x' x'' P Q) }
        where
        ℳ : Monoid
        ℳ = makeMonoid e _+_ (IsSemigroup.is-set h) (IsSemigroup.assoc h) (λ x → He x .fst) (λ x → He x .snd)

  Group→GroupΣ : Group → GroupΣ
  Group→GroupΣ (G , GS) = _ , _ , (isSemigroup GS , _ , identity GS , λ x → (- GS) x , inverse GS x)

  GroupΣ→Group : GroupΣ → Group
  GroupΣ→Group (G , _ , SG , _ , H0g , invertible ) =
     group _ _ _ (λ x → invertible x .fst) (isgroup (ismonoid SG H0g) λ x → invertible x .snd)

  GroupIsoGroupΣ : Iso Group GroupΣ
  GroupIsoGroupΣ = iso Group→GroupΣ GroupΣ→Group (λ _ → refl) (λ _ → refl)

  groupUnivalentStr : UnivalentStr GroupStructure GroupEquivStr
  groupUnivalentStr = axiomsUnivalentStr _ isPropGroupAxioms rawGroupUnivalentStr

  GroupΣPath : (G H : GroupΣ) → (G ≃[ GroupEquivStr ] H) ≃ (G ≡ H)
  GroupΣPath = SIP groupUnivalentStr

  GroupEquivΣ : (G H : Group) → Type ℓ
  GroupEquivΣ G H = Group→GroupΣ G ≃[ GroupEquivStr ] Group→GroupΣ H

  GroupIsoΣPath : {G H : Group} → Iso (GroupEquiv G H) (GroupEquivΣ G H)
  fun GroupIsoΣPath f       = (eq f) , isHom f
  inv GroupIsoΣPath (e , h) = groupequiv e h
  rightInv GroupIsoΣPath _  = refl
  leftInv GroupIsoΣPath _   = refl

  GroupPath : (G H : Group) → (GroupEquiv G H) ≃ (G ≡ H)
  GroupPath G H =
    GroupEquiv G H                  ≃⟨ strictIsoToEquiv GroupIsoΣPath ⟩
    GroupEquivΣ G H                 ≃⟨ GroupΣPath _ _ ⟩
    Group→GroupΣ G ≡ Group→GroupΣ H ≃⟨ isoToEquiv (invIso (congIso GroupIsoGroupΣ)) ⟩
    G ≡ H ■

  RawGroupΣ : Type (ℓ-suc ℓ)
  RawGroupΣ = TypeWithStr ℓ RawGroupStructure

  Group→RawGroupΣ : Group → RawGroupΣ
  Group→RawGroupΣ (G , GS) = G , _+_ GS

  InducedGroup : (G : Group) (H : RawGroupΣ) (e : ⟨ G ⟩ ≃ H .fst)
               → RawGroupEquivStr (Group→RawGroupΣ G) H e → Group
  InducedGroup G H e r =
    GroupΣ→Group (inducedStructure rawGroupUnivalentStr (Group→GroupΣ G) H (e , r))

  InducedGroupPath : (G : Group {ℓ}) (H : RawGroupΣ) (e : ⟨ G ⟩ ≃ H .fst)
                     (E : RawGroupEquivStr (Group→RawGroupΣ G) H e)
                   → G ≡ InducedGroup G H e E
  InducedGroupPath G H e E =
    GroupPath G (InducedGroup G H e E) .fst (groupequiv e E)

-- Extract the characterization of equality of groups
GroupPath : (G H : Group {ℓ}) → (GroupEquiv G H) ≃ (G ≡ H)
GroupPath = GroupΣTheory.GroupPath

InducedGroup : (G : Group {ℓ}) (H : GroupΣTheory.RawGroupΣ) (e : ⟨ G ⟩ ≃ H .fst)
             → GroupΣTheory.RawGroupEquivStr (GroupΣTheory.Group→RawGroupΣ G) H e
             → Group
InducedGroup = GroupΣTheory.InducedGroup

InducedGroupPath : (G : Group {ℓ}) (H : GroupΣTheory.RawGroupΣ) (e : ⟨ G ⟩ ≃ H .fst)
                   (E : GroupΣTheory.RawGroupEquivStr (GroupΣTheory.Group→RawGroupΣ G) H e)
                 → G ≡ InducedGroup G H e E
InducedGroupPath = GroupΣTheory.InducedGroupPath

uaGroup : {G H : Group {ℓ}} → GroupEquiv G H → G ≡ H
uaGroup {G = G} {H = H} = equivFun (GroupPath G H)

carac-uaGroup : {G H : Group {ℓ}} (f : GroupEquiv G H) → cong ⟨_⟩ (uaGroup f) ≡ ua (GroupEquiv.eq f)
carac-uaGroup f = ua (eq f) ∙ refl ≡⟨ sym (rUnit _)  ⟩
                  ua (eq f) ∎

-- Group-ua functoriality

Group≡ : (G H : Group {ℓ}) → (
  Σ[ p ∈ ⟨ G ⟩ ≡ ⟨ H ⟩ ]
  Σ[ q ∈ PathP (λ i → p i) (0g (snd G)) (0g (snd H)) ]
  Σ[ r ∈ PathP (λ i → p i → p i → p i) (_+_ (snd G)) (_+_ (snd H)) ]
  Σ[ s ∈ PathP (λ i → p i → p i) (- snd G) (- snd H) ]
  PathP (λ i → IsGroup (q i) (r i) (s i)) (isGroup (snd G)) (isGroup (snd H)))
  ≃ (G ≡ H)
Group≡ G H = isoToEquiv theIso
  where
  theIso : Iso _ _
  fun theIso (p , q , r , s , t) i = p i , groupstr (q i) (r i) (s i) (t i)
  inv theIso x = cong ⟨_⟩ x , cong (0g ∘ snd) x , cong (_+_ ∘ snd) x , cong (-_ ∘ snd) x , cong (isGroup ∘ snd) x
  rightInv theIso _ = refl
  leftInv theIso _ = refl

caracGroup≡ : {G H : Group {ℓ}} (p q : G ≡ H) → cong ⟨_⟩ p ≡ cong ⟨_⟩ q → p ≡ q
caracGroup≡ {G = G} {H = H} p q P = sym (transportTransport⁻ (ua (Group≡ G H)) p)
                                 ∙∙ cong (transport (ua (Group≡ G H))) helper
                                 ∙∙ transportTransport⁻ (ua (Group≡ G H)) q
  where
  helper : transport (sym (ua (Group≡ G H))) p ≡ transport (sym (ua (Group≡ G H))) q
  helper = Σ≡Prop
             (λ _ → isPropΣ
                       (isOfHLevelPathP' 1 (is-set (snd H)) _ _)
                       λ _ → isPropΣ (isOfHLevelPathP' 1 (isSetΠ2 λ _ _ → is-set (snd H)) _ _)
                       λ _ → isPropΣ (isOfHLevelPathP' 1 (isSetΠ λ _ → is-set (snd H)) _ _)
                       λ _ → isOfHLevelPathP 1 (isPropIsGroup _ _ _) _ _)
             (transportRefl (cong ⟨_⟩ p) ∙ P ∙ sym (transportRefl (cong ⟨_⟩ q)))

uaGroupId : (G : Group {ℓ}) → uaGroup (idGroupEquiv G) ≡ refl
uaGroupId G = caracGroup≡ _ _ (carac-uaGroup (idGroupEquiv G) ∙ uaIdEquiv)

uaCompGroupEquiv : {F G H : Group {ℓ}} (f : GroupEquiv F G) (g : GroupEquiv G H) → uaGroup (compGroupEquiv f g) ≡ uaGroup f ∙ uaGroup g
uaCompGroupEquiv f g = caracGroup≡ _ _ (
  cong ⟨_⟩ (uaGroup (compGroupEquiv f g))
    ≡⟨ carac-uaGroup (compGroupEquiv f g) ⟩
  ua (eq (compGroupEquiv f g))
    ≡⟨ uaCompEquiv _ _ ⟩
  ua (eq f) ∙ ua (eq g)
    ≡⟨ cong (_∙ ua (eq g)) (sym (carac-uaGroup f)) ⟩
  cong ⟨_⟩ (uaGroup f) ∙ ua (eq g)
    ≡⟨ cong (cong ⟨_⟩ (uaGroup f) ∙_) (sym (carac-uaGroup g)) ⟩
  cong ⟨_⟩ (uaGroup f) ∙ cong ⟨_⟩ (uaGroup g)
    ≡⟨ sym (cong-∙ ⟨_⟩ (uaGroup f) (uaGroup g)) ⟩
  cong ⟨_⟩ (uaGroup f ∙ uaGroup g) ∎) where
  open GroupEquiv


{-# OPTIONS --omega-in-omega --no-termination-check --overlapping-instances #-}

module Light.Implementation.Standard.Data.Empty where

open import Light.Library.Data.Empty using (Library ; Dependencies)

instance dependencies : Dependencies
dependencies = record {}

instance library : Library dependencies
library = record { Implementation }
      where
      module Implementation where
            open import Data.Empty using () renaming (⊥ to Empty ; ⊥-elim to eliminate) public


{- Reported by Nils Anders Danielsson, 2011-07-06

From the release notes for Agda 2.2.10:

  "Projections now preserve sizes, both in patterns and expressions."

However, the following code is rejected:
-}

module Issue425 where

record _×_ (A B : Set) : Set where
  constructor _,_
  field
    proj₁ : A
    proj₂ : B

open _×_

id : {A : Set} → A → A
id x = x

data I : Set where
  c : I → I → I

data D : I → Set where
  d : (j : I × I)  → D (proj₁ j) → D (proj₂ j) → D (c (proj₁ j) (proj₂ j))

f : ∀ i → D i → Set
f .(c (proj₁ j) (proj₂ j)) (d j l r) = f (proj₁ j) (id l)

{- Is this intentional? I guess the issue here is the subterm relation
rather than the sizes. Should we modify the subterm relation?
-}
-- Andreas, 2011-07-07 this should termination check.


------------------------------------------------------------------------
-- The Agda standard library
--
-- This module is DEPRECATED. Please use
-- Data.Vec.Relation.Unary.All directly.
------------------------------------------------------------------------

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

module Data.Vec.All where

open import Data.Vec.Relation.Unary.All public


postulate
  Nat : Set
  Fin : Nat → Set
  Finnat : Nat → Set
  fortytwo : Nat
  finnatic : Finnat fortytwo
  _==_ : Finnat fortytwo → Finnat fortytwo → Set

record Fixer : Set where
  field fix : ∀ {x} → Finnat x → Finnat fortytwo
open Fixer {{...}}

postulate
  Fixidentity : {{_ : Fixer}} → Set
  instance
    fixidentity : {{fx : Fixer}} {{fxi : Fixidentity}} {f : Finnat fortytwo} → fix f == f

  InstanceWrapper : Set
  iwrap : InstanceWrapper
  instance
    IrrFixerInstance : .InstanceWrapper → Fixer

instance
  FixerInstance : Fixer
  FixerInstance = IrrFixerInstance iwrap

instance
  postulate FixidentityInstance : Fixidentity

it : ∀ {a} {A : Set a} {{x : A}} → A
it {{x}} = x

fails : Fixer.fix FixerInstance finnatic == finnatic
fails = fixidentity

works : Fixer.fix FixerInstance finnatic == finnatic
works = fixidentity {{fx = it}}

works₂ : Fixer.fix FixerInstance finnatic == finnatic
works₂ = fixidentity {{fxi = it}}


------------------------------------------------------------------------------
-- Testing the translation of definitions
------------------------------------------------------------------------------

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

module Definition07b where

open import Common.FOL

postulate
  P : D → Set

-- We test the translation of a definition where we need to erase
-- proof terms.
foo : ∀ {a} → P a → P a → a ≡ a
foo {a} Pa₁ Pa₂ = bar
  where
  c : D
  c = a
  {-# ATP definition c #-}

  postulate bar : c ≡ a
  {-# ATP prove bar #-}


-- 2011-08-22 Andreas (reported and fixed by Dominique Devriese)
{-# OPTIONS --no-universe-polymorphism #-}
module Issue427 where

data ⊥ : Set where

postulate f : {I : ⊥} (B : _) → ⊥

data A : Set where a : {x y : ⊥} → A

test : A → Set
test (a {x = x} {y = y}) with f {_}
test (a {x = x} {y = y}) | _ = A
{- old error message:
  ⊥ should be a function type, but it isn't
  when checking that {y} are valid arguments to a function of type ⊥
-}
-- new error message should be: Unresolved metas


open import Agda.Builtin.Equality
open import Agda.Builtin.List
open import Agda.Builtin.Reflection renaming (bindTC to _>>=_)
open import Agda.Builtin.Unit

macro
  pickWhatever : Term → TC ⊤
  pickWhatever hole@(meta m _) = do
    (cand ∷ _) ← getInstances m
      where [] -> typeError (strErr "No candidates!" ∷ [])
    unify hole cand
  pickWhatever _ = typeError (strErr "Already solved!" ∷ [])

-- Testing basic functionality
data YesNo : Set where instance yes no : YesNo

test₁ : YesNo
test₁ = pickWhatever

test₁-ok : test₁ ≡ yes
test₁-ok = refl

-- Testing if candidates are correctly filtered
data IsYesNo : YesNo → Set where instance
  isYes : IsYesNo yes
  isNo : IsYesNo no

test₂ : IsYesNo no
test₂ = pickWhatever

-- Testing local candidates
test₃ : {{YesNo}} → YesNo
test₃ = pickWhatever

test₃-ok : ∀ {x} → test₃ {{x}} ≡ x
test₃-ok = refl


record Unit : Set where
  instance
    constructor tt


{-# OPTIONS --safe #-}

module Definition.Conversion.Stability where

open import Definition.Untyped
open import Definition.Untyped.Properties
open import Definition.Typed
open import Definition.Typed.Weakening
open import Definition.Conversion
open import Definition.Typed.Consequences.Syntactic
open import Definition.Typed.Consequences.Substitution

open import Tools.Product
import Tools.PropositionalEquality as PE

-- Equality of contexts.
data ⊢_≡_ : (Γ Δ : Con Term) → Set where
  ε : ⊢ ε ≡ ε
  _∙_ : ∀ {Γ Δ A B r} → ⊢ Γ ≡ Δ → Γ ⊢ A ≡ B ^ r → ⊢ Γ ∙ A ^ r ≡ Δ ∙ B ^ r

mutual
  -- Syntactic validity and conversion substitution of a context equality.
  contextConvSubst : ∀ {Γ Δ} → ⊢ Γ ≡ Δ → ⊢ Γ × ⊢ Δ × Δ ⊢ˢ idSubst ∷ Γ
  contextConvSubst ε = ε , ε , id
  contextConvSubst (_∙_ {Γ} {Δ} {A} {B} Γ≡Δ A≡B) =
    let ⊢Γ , ⊢Δ , [σ] = contextConvSubst Γ≡Δ
        ⊢A , ⊢B = syntacticEq A≡B
        Δ⊢B = stability Γ≡Δ ⊢B
    in  ⊢Γ ∙ ⊢A , ⊢Δ ∙ Δ⊢B
        , (wk1Subst′ ⊢Γ ⊢Δ Δ⊢B [σ]
        , conv (var (⊢Δ ∙ Δ⊢B) here)
               (PE.subst (λ x → _ ⊢ _ ≡ x ^ _)
                         (wk1-tailId A)
                         (wkEq (step id) (⊢Δ ∙ Δ⊢B) (stabilityEq Γ≡Δ (sym A≡B)))))

  -- Stability of types under equal contexts.
  stability : ∀ {A rA Γ Δ} → ⊢ Γ ≡ Δ → Γ ⊢ A ^ rA → Δ ⊢ A ^ rA
  stability Γ≡Δ A =
    let ⊢Γ , ⊢Δ , σ = contextConvSubst Γ≡Δ
        q = substitution A σ ⊢Δ
    in  PE.subst (λ x → _ ⊢ x ^ _) (subst-id _) q

  -- Stability of type equality.
  stabilityEq : ∀ {A B rA Γ Δ} → ⊢ Γ ≡ Δ → Γ ⊢ A ≡ B ^ rA → Δ ⊢ A ≡ B ^ rA
  stabilityEq Γ≡Δ A≡B =
    let ⊢Γ , ⊢Δ , σ = contextConvSubst Γ≡Δ
        q = substitutionEq A≡B (substRefl σ) ⊢Δ
    in  PE.subst₂ (λ x y → _ ⊢ x ≡ y ^ _) (subst-id _) (subst-id _) q

-- Reflexivity of context equality.
reflConEq : ∀ {Γ} → ⊢ Γ → ⊢ Γ ≡ Γ
reflConEq ε = ε
reflConEq (⊢Γ ∙ ⊢A) = reflConEq ⊢Γ ∙ refl ⊢A

-- Symmetry of context equality.
symConEq : ∀ {Γ Δ} → ⊢ Γ ≡ Δ → ⊢ Δ ≡ Γ
symConEq ε = ε
symConEq (Γ≡Δ ∙ A≡B) = symConEq Γ≡Δ ∙ stabilityEq Γ≡Δ (sym A≡B)

-- Stability of terms.
stabilityTerm : ∀ {t A rA Γ Δ} → ⊢ Γ ≡ Δ → Γ ⊢ t ∷ A ^ rA → Δ ⊢ t ∷ A ^ rA
stabilityTerm Γ≡Δ t =
  let ⊢Γ , ⊢Δ , σ = contextConvSubst Γ≡Δ
      q = substitutionTerm t σ ⊢Δ
  in  PE.subst₂ (λ x y → _ ⊢ x ∷ y ^ _) (subst-id _) (subst-id _) q

-- Stability of term reduction.
stabilityRedTerm : ∀ {t u A Γ Δ l} → ⊢ Γ ≡ Δ → Γ ⊢ t ⇒ u ∷ A ^ l → Δ ⊢ t ⇒ u ∷ A ^ l
stabilityRedTerm Γ≡Δ (conv d x) =
  conv (stabilityRedTerm Γ≡Δ d) (stabilityEq Γ≡Δ x)
stabilityRedTerm Γ≡Δ (app-subst d x) =
  app-subst (stabilityRedTerm Γ≡Δ d) (stabilityTerm Γ≡Δ x)
stabilityRedTerm Γ≡Δ (β-red l< l<' x x₁ x₂) =
  β-red l< l<' (stability Γ≡Δ x) (stabilityTerm (Γ≡Δ ∙ refl x) x₁)
        (stabilityTerm Γ≡Δ x₂)
stabilityRedTerm Γ≡Δ (natrec-subst x x₁ x₂ d) =
  let ⊢Γ , _ , _ = contextConvSubst Γ≡Δ
  in  natrec-subst (stability (Γ≡Δ ∙ refl (univ (ℕⱼ ⊢Γ))) x) (stabilityTerm Γ≡Δ x₁)
                   (stabilityTerm Γ≡Δ x₂) (stabilityRedTerm Γ≡Δ d)
stabilityRedTerm Γ≡Δ (natrec-zero x x₁ x₂) =
  let ⊢Γ , _ , _ = contextConvSubst Γ≡Δ
  in  natrec-zero (stability (Γ≡Δ ∙ refl (univ (ℕⱼ ⊢Γ))) x) (stabilityTerm Γ≡Δ x₁)
                  (stabilityTerm Γ≡Δ x₂)
stabilityRedTerm Γ≡Δ (natrec-suc x x₁ x₂ x₃) =
  let ⊢Γ , _ , _ = contextConvSubst Γ≡Δ
  in  natrec-suc (stabilityTerm Γ≡Δ x) (stability (Γ≡Δ ∙ refl (univ (ℕⱼ ⊢Γ))) x₁)
                 (stabilityTerm Γ≡Δ x₂) (stabilityTerm Γ≡Δ x₃)
stabilityRedTerm Γ≡Δ (Id-subst X x x₁) = Id-subst (stabilityRedTerm Γ≡Δ X) (stabilityTerm Γ≡Δ x) (stabilityTerm Γ≡Δ x₁)
stabilityRedTerm Γ≡Δ (Id-ℕ-subst X x) = Id-ℕ-subst (stabilityRedTerm Γ≡Δ X) (stabilityTerm Γ≡Δ x)
stabilityRedTerm Γ≡Δ (Id-ℕ-0-subst X) = Id-ℕ-0-subst (stabilityRedTerm Γ≡Δ X)
stabilityRedTerm Γ≡Δ (Id-ℕ-S-subst x X) = Id-ℕ-S-subst (stabilityTerm Γ≡Δ x) (stabilityRedTerm Γ≡Δ X)
stabilityRedTerm Γ≡Δ (Id-U-subst X x) = Id-U-subst (stabilityRedTerm Γ≡Δ X) (stabilityTerm Γ≡Δ x)
stabilityRedTerm Γ≡Δ (Id-U-ℕ-subst X) = Id-U-ℕ-subst (stabilityRedTerm Γ≡Δ X)
stabilityRedTerm Γ≡Δ (Id-U-Π-subst x x₁ X) = Id-U-Π-subst (stabilityTerm Γ≡Δ x) (stabilityTerm (Γ≡Δ ∙ refl (univ x)) x₁) (stabilityRedTerm Γ≡Δ X)
stabilityRedTerm Γ≡Δ (Id-Π l< l<' x x₁ x₂ x₃) = Id-Π l< l<' (stabilityTerm Γ≡Δ x) (stabilityTerm (Γ≡Δ ∙ refl (univ x)) x₁) (stabilityTerm Γ≡Δ x₂) (stabilityTerm Γ≡Δ x₃)
stabilityRedTerm Γ≡Δ (Id-ℕ-00 x) = let _ , ⊢Δ , _ = contextConvSubst Γ≡Δ in Id-ℕ-00 ⊢Δ
stabilityRedTerm Γ≡Δ (Id-ℕ-SS x x₁) = Id-ℕ-SS (stabilityTerm Γ≡Δ x) (stabilityTerm Γ≡Δ x₁)
stabilityRedTerm Γ≡Δ (Id-U-ΠΠ x x₁ x₂ x₃) = Id-U-ΠΠ (stabilityTerm Γ≡Δ x) (stabilityTerm (Γ≡Δ ∙ refl (univ x)) x₁) (stabilityTerm Γ≡Δ x₂) (stabilityTerm (Γ≡Δ ∙ refl (univ x₂)) x₃)
stabilityRedTerm Γ≡Δ (Id-U-ℕℕ x) = let _ , ⊢Δ , _ = contextConvSubst Γ≡Δ in Id-U-ℕℕ ⊢Δ
stabilityRedTerm Γ≡Δ (Id-SProp x x₁) = Id-SProp (stabilityTerm Γ≡Δ x) (stabilityTerm Γ≡Δ x₁)
stabilityRedTerm Γ≡Δ (Id-ℕ-0S x) = Id-ℕ-0S (stabilityTerm Γ≡Δ x)
stabilityRedTerm Γ≡Δ (Id-ℕ-S0 x) = Id-ℕ-S0 (stabilityTerm Γ≡Δ x)
stabilityRedTerm Γ≡Δ (Id-U-ℕΠ x x₁) = Id-U-ℕΠ (stabilityTerm Γ≡Δ x) (stabilityTerm (Γ≡Δ ∙ refl (univ x)) x₁)
stabilityRedTerm Γ≡Δ (Id-U-Πℕ x x₁) = Id-U-Πℕ (stabilityTerm Γ≡Δ x) (stabilityTerm (Γ≡Δ ∙ refl (univ x)) x₁)
stabilityRedTerm Γ≡Δ (Id-U-ΠΠ!% x x₁ x₂ x₃ x₄) =
  Id-U-ΠΠ!% x (stabilityTerm Γ≡Δ x₁) (stabilityTerm (Γ≡Δ ∙ refl (univ x₁)) x₂) (stabilityTerm Γ≡Δ x₃) (stabilityTerm (Γ≡Δ ∙ refl (univ x₃)) x₄)
stabilityRedTerm Γ≡Δ (cast-subst X x x₁ x₂) = cast-subst (stabilityRedTerm Γ≡Δ X) (stabilityTerm Γ≡Δ x) (stabilityTerm Γ≡Δ x₁) (stabilityTerm Γ≡Δ x₂)
stabilityRedTerm Γ≡Δ (cast-ℕ-subst X x x₁) =
  cast-ℕ-subst (stabilityRedTerm Γ≡Δ X) (stabilityTerm Γ≡Δ x) (stabilityTerm Γ≡Δ x₁)
stabilityRedTerm Γ≡Δ (cast-Π-subst x x₁ X x₂ x₃) =
  cast-Π-subst (stabilityTerm Γ≡Δ x) (stabilityTerm (Γ≡Δ ∙ refl (univ x)) x₁) (stabilityRedTerm Γ≡Δ X) (stabilityTerm Γ≡Δ x₂) (stabilityTerm Γ≡Δ x₃)
stabilityRedTerm Γ≡Δ (cast-Π x x₁ x₂ x₃ x₄ x₅) =
  cast-Π (stabilityTerm Γ≡Δ x) (stabilityTerm (Γ≡Δ ∙ refl (univ x)) x₁) (stabilityTerm Γ≡Δ x₂) (stabilityTerm (Γ≡Δ ∙ refl (univ x₂)) x₃) (stabilityTerm Γ≡Δ x₄) (stabilityTerm Γ≡Δ x₅)
stabilityRedTerm Γ≡Δ (cast-ℕ-0 x) = cast-ℕ-0 (stabilityTerm Γ≡Δ x)
stabilityRedTerm Γ≡Δ (cast-ℕ-S x x₁) = cast-ℕ-S (stabilityTerm Γ≡Δ x) (stabilityTerm Γ≡Δ x₁)
stabilityRedTerm Γ≡Δ (cast-ℕ-cong x X) = cast-ℕ-cong (stabilityTerm Γ≡Δ x) (stabilityRedTerm Γ≡Δ X)

-- Stability of type reductions.
stabilityRed : ∀ {A B r Γ Δ} → ⊢ Γ ≡ Δ → Γ ⊢ A ⇒ B ^ r → Δ ⊢ A ⇒ B ^ r
stabilityRed Γ≡Δ (univ x) = univ (stabilityRedTerm Γ≡Δ x)

-- Stability of type reduction closures.
stabilityRed* : ∀ {A B r Γ Δ} → ⊢ Γ ≡ Δ → Γ ⊢ A ⇒* B ^ r → Δ ⊢ A ⇒* B ^ r
stabilityRed* Γ≡Δ (id x) = id (stability Γ≡Δ x)
stabilityRed* Γ≡Δ (x ⇨ D) = stabilityRed Γ≡Δ x ⇨ stabilityRed* Γ≡Δ D

-- Stability of term reduction closures.
stabilityRed*Term : ∀ {t u A Γ Δ l} → ⊢ Γ ≡ Δ → Γ ⊢ t ⇒* u ∷ A ^ l → Δ ⊢ t ⇒* u ∷ A ^ l
stabilityRed*Term Γ≡Δ (id x) = id (stabilityTerm Γ≡Δ x)
stabilityRed*Term Γ≡Δ (x ⇨ d) = stabilityRedTerm Γ≡Δ x ⇨ stabilityRed*Term Γ≡Δ d

mutual
  -- Stability of algorithmic equality of neutrals.
  stability~↑! : ∀ {k l A Γ Δ lA}
              → ⊢ Γ ≡ Δ
              → Γ ⊢ k ~ l ↑! A ^ lA
              → Δ ⊢ k ~ l ↑! A ^ lA
  stability~↑! Γ≡Δ (var-refl x x≡y) =
    var-refl (stabilityTerm Γ≡Δ x) x≡y
  stability~↑! Γ≡Δ (app-cong {rF = ! } k~l x) =
    app-cong (stability~↓! Γ≡Δ k~l) (stabilityConv↑Term Γ≡Δ x)
  stability~↑! Γ≡Δ (app-cong {rF = %} k~l x) =
    app-cong (stability~↓! Γ≡Δ k~l) (stability~↑% Γ≡Δ x)
  stability~↑! Γ≡Δ (natrec-cong x₁ x₂ x₃ k~l) =
    let ⊢Γ , _ , _ = contextConvSubst Γ≡Δ
    in natrec-cong (stabilityConv↑ (Γ≡Δ ∙ (refl (univ (ℕⱼ ⊢Γ)))) x₁)
                   (stabilityConv↑Term Γ≡Δ x₂)
                   (stabilityConv↑Term Γ≡Δ x₃)
                   (stability~↓! Γ≡Δ k~l)
  stability~↑! Γ≡Δ (Emptyrec-cong x₁ k~l) =
    Emptyrec-cong (stabilityConv↑ Γ≡Δ x₁)
                (stability~↑% Γ≡Δ k~l)
  stability~↑! Γ≡Δ (Id-cong X x x₁) = Id-cong (stability~↓! Γ≡Δ X) (stabilityConv↑Term Γ≡Δ x) (stabilityConv↑Term Γ≡Δ x₁)
  stability~↑! Γ≡Δ (Id-ℕ X x) = Id-ℕ (stability~↓! Γ≡Δ X) (stabilityConv↑Term Γ≡Δ x)
  stability~↑! Γ≡Δ (Id-ℕ0 X) = Id-ℕ0 (stability~↓! Γ≡Δ X)
  stability~↑! Γ≡Δ (Id-ℕS x X) = Id-ℕS (stabilityConv↑Term Γ≡Δ x) (stability~↓! Γ≡Δ X)
  stability~↑! Γ≡Δ (Id-U X x) = Id-U (stability~↓! Γ≡Δ X) (stabilityConv↑Term Γ≡Δ x)
  stability~↑! Γ≡Δ (Id-Uℕ X) = Id-Uℕ (stability~↓! Γ≡Δ X)
  stability~↑! Γ≡Δ (Id-UΠ x X) = Id-UΠ (stabilityConv↑Term Γ≡Δ x) (stability~↓! Γ≡Δ X)
  stability~↑! Γ≡Δ (cast-cong X x x₁ x₂ x₃) = cast-cong (stability~↓! Γ≡Δ X) (stabilityConv↑Term Γ≡Δ x) (stabilityConv↑Term Γ≡Δ x₁) (stabilityTerm Γ≡Δ x₂) (stabilityTerm Γ≡Δ x₃)
  stability~↑! Γ≡Δ (cast-ℕ X x x₁ x₂) = cast-ℕ (stability~↓! Γ≡Δ X) (stabilityConv↑Term Γ≡Δ x) (stabilityTerm Γ≡Δ x₁) (stabilityTerm Γ≡Δ x₂)
  stability~↑! Γ≡Δ (cast-ℕℕ X x x₁) = cast-ℕℕ (stability~↓! Γ≡Δ X) (stabilityTerm Γ≡Δ x) (stabilityTerm Γ≡Δ x₁)
  stability~↑! Γ≡Δ (cast-Π x X x₁ x₂ x₃) = cast-Π (stabilityConv↑Term Γ≡Δ x) (stability~↓! Γ≡Δ X) (stabilityConv↑Term Γ≡Δ x₁) (stabilityTerm Γ≡Δ x₂) (stabilityTerm Γ≡Δ x₃)
  stability~↑! Γ≡Δ (cast-Πℕ x x₁ x₂ x₃) = cast-Πℕ (stabilityConv↑Term Γ≡Δ x) (stabilityConv↑Term Γ≡Δ x₁) (stabilityTerm Γ≡Δ x₂) (stabilityTerm Γ≡Δ x₃)
  stability~↑! Γ≡Δ (cast-ℕΠ x x₁ x₂ x₃) = cast-ℕΠ (stabilityConv↑Term Γ≡Δ x) (stabilityConv↑Term Γ≡Δ x₁) (stabilityTerm Γ≡Δ x₂) (stabilityTerm Γ≡Δ x₃)
  stability~↑! Γ≡Δ (cast-ΠΠ%! x x₁ x₂ x₃ x₄) = cast-ΠΠ%! (stabilityConv↑Term Γ≡Δ x) (stabilityConv↑Term Γ≡Δ x₁) (stabilityConv↑Term Γ≡Δ x₂) (stabilityTerm Γ≡Δ x₃) (stabilityTerm Γ≡Δ x₄)
  stability~↑! Γ≡Δ (cast-ΠΠ!% x x₁ x₂ x₃ x₄) = cast-ΠΠ!% (stabilityConv↑Term Γ≡Δ x) (stabilityConv↑Term Γ≡Δ x₁) (stabilityConv↑Term Γ≡Δ x₂) (stabilityTerm Γ≡Δ x₃) (stabilityTerm Γ≡Δ x₄)

  stability~↑% : ∀ {k l A Γ Δ lA}
              → ⊢ Γ ≡ Δ
              → Γ ⊢ k ~ l ↑% A ^ lA
              → Δ ⊢ k ~ l ↑% A ^ lA
  stability~↑% Γ≡Δ (%~↑ ⊢k ⊢l) = %~↑ (stabilityTerm Γ≡Δ ⊢k) (stabilityTerm Γ≡Δ ⊢l)

  stability~↑ : ∀ {k l A rA lA Γ Δ}
              → ⊢ Γ ≡ Δ
              → Γ ⊢ k ~ l ↑ A ^ [ rA , lA ]
              → Δ ⊢ k ~ l ↑ A ^ [ rA , lA ]
  stability~↑ Γ≡Δ (~↑! x) = ~↑! (stability~↑! Γ≡Δ x)
  stability~↑ Γ≡Δ (~↑% x) = ~↑% (stability~↑% Γ≡Δ x)

  -- Stability of algorithmic equality of neutrals of types in WHNF.
  stability~↓! : ∀ {k l A lA Γ Δ}
              → ⊢ Γ ≡ Δ
              → Γ ⊢ k ~ l ↓! A ^ lA
              → Δ ⊢ k ~ l ↓! A ^ lA
  stability~↓! Γ≡Δ ([~] A D whnfA k~l) =
    [~] A (stabilityRed* Γ≡Δ D) whnfA (stability~↑! Γ≡Δ k~l)

  -- Stability of algorithmic equality of types.
  stabilityConv↑ : ∀ {A B r Γ Δ}
                 → ⊢ Γ ≡ Δ
                 → Γ ⊢ A [conv↑] B ^ r
                 → Δ ⊢ A [conv↑] B ^ r
  stabilityConv↑ Γ≡Δ ([↑] A′ B′ D D′ whnfA′ whnfB′ A′<>B′) =
    [↑] A′ B′ (stabilityRed* Γ≡Δ D) (stabilityRed* Γ≡Δ D′) whnfA′ whnfB′
        (stabilityConv↓ Γ≡Δ A′<>B′)

  -- Stability of algorithmic equality of types in WHNF.
  stabilityConv↓ : ∀ {A B r Γ Δ}
                 → ⊢ Γ ≡ Δ
                 → Γ ⊢ A [conv↓] B ^ r
                 → Δ ⊢ A [conv↓] B ^ r
  stabilityConv↓ Γ≡Δ (U-refl PE.refl x) =
    let _ , ⊢Δ , _ = contextConvSubst Γ≡Δ
    in  U-refl PE.refl ⊢Δ
  stabilityConv↓ Γ≡Δ (univ x) = univ (stabilityConv↓Term Γ≡Δ x)

  -- Stability of algorithmic equality of terms.
  stabilityConv↑Term : ∀ {t u A lA Γ Δ}
                     → ⊢ Γ ≡ Δ
                     → Γ ⊢ t [conv↑] u ∷ A ^ lA
                     → Δ ⊢ t [conv↑] u ∷ A ^ lA
  stabilityConv↑Term Γ≡Δ ([↑]ₜ B t′ u′ D d d′ whnfB whnft′ whnfu′ t<>u) =
    [↑]ₜ B t′ u′ (stabilityRed* Γ≡Δ D) (stabilityRed*Term Γ≡Δ d)
                 (stabilityRed*Term Γ≡Δ d′) whnfB whnft′ whnfu′
                 (stabilityConv↓Term Γ≡Δ t<>u)

  -- Stability of algorithmic equality of terms in WHNF.
  stabilityConv↓Term : ∀ {t u A lA Γ Δ}
                     → ⊢ Γ ≡ Δ
                     → Γ ⊢ t [conv↓] u ∷ A ^ lA
                     → Δ ⊢ t [conv↓] u ∷ A ^ lA
  stabilityConv↓Term Γ≡Δ (U-refl PE.refl x) =
    let _ , ⊢Δ , _ = contextConvSubst Γ≡Δ
    in  U-refl PE.refl ⊢Δ
  stabilityConv↓Term Γ≡Δ (ne x) = ne (stability~↓! Γ≡Δ x)
  stabilityConv↓Term Γ≡Δ (ℕ-refl x) =
    let _ , ⊢Δ , _ = contextConvSubst Γ≡Δ
    in  ℕ-refl ⊢Δ
  stabilityConv↓Term Γ≡Δ (Empty-refl x _) =
    let _ , ⊢Δ , _ = contextConvSubst Γ≡Δ
    in  Empty-refl x ⊢Δ
  stabilityConv↓Term Γ≡Δ (Π-cong PE.refl PE.refl PE.refl PE.refl l< l<' F A<>B A<>B₁) =
    Π-cong PE.refl PE.refl PE.refl PE.refl l< l<' (stability Γ≡Δ F) (stabilityConv↑Term Γ≡Δ A<>B)
           (stabilityConv↑Term (Γ≡Δ ∙ refl F) A<>B₁)
  stabilityConv↓Term Γ≡Δ (∃-cong PE.refl F A<>B A<>B₁) =
    ∃-cong PE.refl (stability Γ≡Δ F) (stabilityConv↑Term Γ≡Δ A<>B)
           (stabilityConv↑Term (Γ≡Δ ∙ refl F) A<>B₁)
  stabilityConv↓Term Γ≡Δ (ℕ-ins x) =
    ℕ-ins (stability~↓! Γ≡Δ x)
  -- stabilityConv↓Term Γ≡Δ (Empty-ins x) =
  --   Empty-ins (stability~↓% Γ≡Δ x)
  stabilityConv↓Term Γ≡Δ (ne-ins t u neN x) =
    ne-ins (stabilityTerm Γ≡Δ t) (stabilityTerm Γ≡Δ u) neN (stability~↓! Γ≡Δ x)
  stabilityConv↓Term Γ≡Δ (zero-refl x) =
    let _ , ⊢Δ , _ = contextConvSubst Γ≡Δ
    in  zero-refl ⊢Δ
  stabilityConv↓Term Γ≡Δ (suc-cong t<>u) = suc-cong (stabilityConv↑Term Γ≡Δ t<>u)
  stabilityConv↓Term Γ≡Δ (η-eq l< l<' F x x₁ y y₁ t<>u) =
    η-eq l< l<' (stability Γ≡Δ F) (stabilityTerm Γ≡Δ x) (stabilityTerm Γ≡Δ x₁)
         y y₁ (stabilityConv↑Term (Γ≡Δ ∙ refl F) t<>u)


-- named arguments should be allowed in module applications
module Issue420 where

module M {A : Set₁} where

open M {A = Set}


module Syntax where

open import Agda.Builtin.FromNat public
open import Agda.Builtin.FromNeg public

record plus-syntax (A : Set) (B : A → Set) (C : ∀ x → B x → Set) : Set where
  infixl 6 _+_
  field _+_ : ∀ x (y : B x) → C x y

plus-syntax-simple = λ A B C → plus-syntax A (λ _ → B) (λ _ _ → C)

open plus-syntax {{…}} public

record minus-syntax (A : Set) (B : A → Set) (C : ∀ x → B x → Set) : Set where
  infixl 6 _-_
  field _-_ : ∀ x (y : B x) → C x y

minus-syntax-simple = λ A B C → minus-syntax A (λ _ → B) (λ _ _ → C)

open minus-syntax {{…}} public

record times-syntax (A : Set) (B : A → Set) (C : ∀ x → B x → Set) : Set where
  infixl 7 _*_
  field _*_ : ∀ x (y : B x) → C x y

times-syntax-simple = λ A B C → times-syntax A (λ _ → B) (λ _ _ → C)

open times-syntax {{…}} public

record raise-syntax (A : Set) (B : A → Set) (C : ∀ x → B x → Set) : Set where
  infixl 8 _^_
  field _^_ : ∀ x (y : B x) → C x y

raise-syntax-simple = λ A B C → raise-syntax A (λ _ → B) (λ _ _ → C)

open raise-syntax {{…}} public


open import Mockingbird.Forest using (Forest)

-- Mockingbirds, Warblers, and Starlings
module Mockingbird.Problems.Chapter12 {b ℓ} (forest : Forest {b} {ℓ}) where

open import Data.Product using (_×_; _,_; proj₁; ∃-syntax)
open import Function using (_$_)

open import Mockingbird.Forest.Birds forest
import Mockingbird.Problems.Chapter11 forest as Chapter₁₁

open Forest forest

problem₁ : ⦃ _ : HasBluebird ⦄ ⦃ _ : HasMockingbird ⦄ → HasDoubleMockingbird
problem₁ = record
  { M₂ = B ∙ M
  ; isDoubleMockingbird = λ x y → begin
     B ∙ M ∙ x ∙ y    ≈⟨ isBluebird M x y ⟩
     M ∙ (x ∙ y)      ≈⟨ isMockingbird (x ∙ y) ⟩
     x ∙ y ∙ (x ∙ y)  ∎
  }

problem₂-BCM : ⦃ _ : HasBluebird ⦄ ⦃ _ : HasThrush ⦄ ⦃ _ : HasMockingbird ⦄ → HasLark
problem₂-BCM = record
  { L = C ∙ B ∙ M
  ; isLark = λ x y → begin
      C ∙ B ∙ M ∙ x ∙ y  ≈⟨ congʳ $ isCardinal B M x ⟩
      B ∙ x ∙ M ∙ y      ≈⟨ isBluebird x M y ⟩
      x ∙ (M ∙ y)        ≈⟨ congˡ $ isMockingbird y ⟩
      x ∙ (y ∙ y)        ∎
  } where instance hasCardinal = Chapter₁₁.problem₂₁′

problem₂-BRM : ⦃ _ : HasBluebird ⦄ ⦃ _ : HasThrush ⦄ ⦃ _ : HasMockingbird ⦄ → HasLark
problem₂-BRM = record
  { L = R ∙ M ∙ B
  ; isLark = λ x y → begin
      R ∙ M ∙ B ∙ x ∙ y  ≈⟨ congʳ $ isRobin M B x ⟩
      B ∙ x ∙ M ∙ y      ≈⟨ isBluebird x M y ⟩
      x ∙ (M ∙ y)        ≈⟨ congˡ $ isMockingbird y ⟩
      x ∙ (y ∙ y)        ∎
  } where instance hasRobin = Chapter₁₁.problem₂₀

problem₃ : ⦃ _ : HasBluebird ⦄ ⦃ _ : HasWarbler ⦄ → HasLark
problem₃ = record
  { L = B ∙ W ∙ B
  ; isLark = λ x y → begin
      B ∙ W ∙ B ∙ x ∙ y  ≈⟨ congʳ $ isBluebird W B x ⟩
      W ∙ (B ∙ x) ∙ y    ≈⟨ isWarbler (B ∙ x) y ⟩
      B ∙ x ∙ y ∙ y      ≈⟨ isBluebird x y y ⟩
      x ∙ (y ∙ y)        ∎
  }

problem₄ : ⦃ _ : HasMockingbird ⦄ ⦃ _ : HasQueerBird ⦄ → HasLark
problem₄ = record
  { L = Q ∙ M
  ; isLark = λ x y → begin
      Q ∙ M ∙ x ∙ y  ≈⟨ isQueerBird M x y ⟩
      x ∙ (M ∙ y)    ≈⟨ congˡ $ isMockingbird y ⟩
      x ∙ (y ∙ y)    ∎
  }

problem₅ : ⦃ _ : HasBluebird ⦄ ⦃ _ : HasRobin ⦄ ⦃ _ : HasMockingbird ⦄ → HasConverseWarbler
problem₅ = record
  { W′ = M₂ ∙ R
  ; isConverseWarbler = λ x y → begin
      M₂ ∙ R ∙ x ∙ y       ≈⟨ congʳ $ isDoubleMockingbird R x ⟩
      R ∙ x ∙ (R ∙ x) ∙ y  ≈⟨ isRobin x (R ∙ x) y ⟩
      R ∙ x ∙ y ∙ x        ≈⟨ isRobin x y x ⟩
      y ∙ x ∙ x            ∎
  } where instance hasDoubleMockingbird = problem₁

problem₆′ : ⦃ _ : HasCardinal ⦄ ⦃ _ : HasConverseWarbler ⦄ → HasWarbler
problem₆′ = record
  { W = C ∙ W′
  ; isWarbler = λ x y → begin
      C ∙ W′ ∙ x ∙ y ≈⟨ isCardinal W′ x y ⟩
      W′ ∙ y ∙ x     ≈⟨ isConverseWarbler y x ⟩
      x ∙ y ∙ y      ∎
  }

problem₆ : ⦃ _ : HasBluebird ⦄ ⦃ _ : HasRobin ⦄ ⦃ _ : HasCardinal ⦄ ⦃ _ : HasMockingbird ⦄ → HasWarbler
problem₆ = record
  { W = C ∙ (B ∙ M ∙ R)
  ; isWarbler = λ x y → begin
      C ∙ (B ∙ M ∙ R) ∙ x ∙ y  ≈⟨⟩
      C ∙ (M₂ ∙ R) ∙ x ∙ y     ≈⟨⟩
      C ∙ W′ ∙ x ∙ y           ≈⟨⟩
      W ∙ x ∙ y                ≈⟨ isWarbler x y ⟩
      x ∙ y ∙ y                ∎
  } where
  instance
    hasDoubleMockingbird = problem₁
    hasConverseWarbler = problem₅
    hasWarbler = problem₆′

problem₇ : ⦃ _ : HasBluebird ⦄ ⦃ _ : HasThrush ⦄ ⦃ _ : HasMockingbird ⦄ → HasWarbler
problem₇ = record
  { W = B ∙ (T ∙ (B ∙ M ∙ (B ∙ B ∙ T))) ∙ (B ∙ B ∙ T)
  ; isWarbler = λ x y → begin
      B ∙ (T ∙ (B ∙ M ∙ (B ∙ B ∙ T))) ∙ (B ∙ B ∙ T) ∙ x ∙ y  ≈˘⟨ congʳ $ congʳ $ isWarbler′ ⟩
      W ∙ x ∙ y                                              ≈⟨ isWarbler x y ⟩
      x ∙ y ∙ y                                              ∎
  } where
  instance
    hasRobin = Chapter₁₁.problem₂₀
    hasCardinal = Chapter₁₁.problem₂₁-bonus
    hasWarbler = problem₆

  isWarbler′ : W ≈ B ∙ (T ∙ (B ∙ M ∙ (B ∙ B ∙ T))) ∙ (B ∙ B ∙ T)
  isWarbler′ = begin
    W                                                            ≈⟨⟩
    C ∙ (B ∙ M ∙ R)                                              ≈⟨⟩
    C ∙ (B ∙ M ∙ (B ∙ B ∙ T))                                    ≈⟨⟩
    B ∙ (T ∙ (B ∙ B ∙ T)) ∙ (B ∙ B ∙ T) ∙ (B ∙ M ∙ (B ∙ B ∙ T))  ≈⟨ isBluebird (T ∙ (B ∙ B ∙ T)) (B ∙ B ∙ T) (B ∙ M ∙ (B ∙ B ∙ T)) ⟩
    T ∙ (B ∙ B ∙ T) ∙ (B ∙ B ∙ T ∙ (B ∙ M ∙ (B ∙ B ∙ T)))        ≈⟨ isThrush (B ∙ B ∙ T) (B ∙ B ∙ T ∙ (B ∙ M ∙ (B ∙ B ∙ T))) ⟩
    B ∙ B ∙ T ∙ (B ∙ M ∙ (B ∙ B ∙ T)) ∙ (B ∙ B ∙ T)              ≈⟨ congʳ $ isBluebird B T (B ∙ M ∙ (B ∙ B ∙ T)) ⟩
    B ∙ (T ∙ (B ∙ M ∙ (B ∙ B ∙ T))) ∙ (B ∙ B ∙ T)                ∎

-- TODO: other expression in problem 7.

-- NOTE: the bluebird B is not necessary.
problem₈ : ⦃ _ : HasThrush ⦄ ⦃ _ : HasWarbler ⦄ → HasMockingbird
problem₈ = record
  { M = W ∙ T
  ; isMockingbird = λ x → begin
      W ∙ T ∙ x  ≈⟨ isWarbler T x ⟩
      T ∙ x ∙ x  ≈⟨ isThrush x x ⟩
      x ∙ x      ∎
  }

problem₉-W* : ⦃ _ : HasBluebird ⦄ ⦃ _ : HasThrush ⦄ ⦃ _ : HasMockingbird ⦄ → HasWarblerOnceRemoved
problem₉-W* = record
  { W* = B ∙ W
  ; isWarblerOnceRemoved = λ x y z → begin
      B ∙ W ∙ x ∙ y ∙ z  ≈⟨ congʳ $ isBluebird W x y ⟩
      W ∙ (x ∙ y) ∙ z    ≈⟨ isWarbler (x ∙ y) z ⟩
      x ∙ y ∙ z ∙ z      ∎
  } where instance hasWarbler = problem₇

problem₉-W** : ⦃ _ : HasBluebird ⦄ ⦃ _ : HasThrush ⦄ ⦃ _ : HasMockingbird ⦄ → HasWarblerTwiceRemoved
problem₉-W** = record
  { W** = B ∙ W*
  ; isWarblerTwiceRemoved = λ x y z w → begin
      B ∙ W* ∙ x ∙ y ∙ z ∙ w  ≈⟨ congʳ $ congʳ $ isBluebird W* x y ⟩
      W* ∙ (x ∙ y) ∙ z ∙ w    ≈⟨ isWarblerOnceRemoved (x ∙ y) z w ⟩
      x ∙ y ∙ z ∙ w ∙ w       ∎
  } where
  instance
    hasWarbler = problem₇
    hasWarblerOnceRemoved = problem₉-W*

problem₁₀ : ⦃ _ : HasBluebird ⦄ ⦃ _ : HasCardinal ⦄ ⦃ _ : HasWarbler ⦄ → HasHummingbird
problem₁₀ = record
  { H = B ∙ W ∙ (B ∙ C)
  ; isHummingbird = λ x y z → begin
      B ∙ W ∙ (B ∙ C) ∙ x ∙ y ∙ z   ≈⟨ congʳ $ congʳ $ isBluebird W (B ∙ C) x ⟩
      W ∙ (B ∙ C ∙ x) ∙ y ∙ z       ≈⟨ congʳ $ isWarbler (B ∙ C ∙ x) y ⟩
      B ∙ C ∙ x ∙ y ∙ y ∙ z         ≈⟨ congʳ $ congʳ $ isBluebird C x y ⟩
      C ∙ (x ∙ y) ∙ y ∙ z           ≈⟨ isCardinal (x ∙ y) y z ⟩
      x ∙ y ∙ z ∙ y                 ∎
  }

problem₁₁ : ⦃ _ : HasRobin ⦄ ⦃ _ : HasHummingbird ⦄ → HasWarbler
problem₁₁ = problem₆′
  where
    instance
      hasCardinal = Chapter₁₁.problem₂₁

      hasConverseWarbler : HasConverseWarbler
      hasConverseWarbler = record
        { W′ = H ∙ R
        ; isConverseWarbler = λ x y → begin
            H ∙ R ∙ x ∙ y  ≈⟨ isHummingbird R x y ⟩
            R ∙ x ∙ y ∙ x  ≈⟨ isRobin x y x ⟩
            y ∙ x ∙ x      ∎
        }

problem₁₂ : ⦃ _ : HasBluebird ⦄ ⦃ _ : HasThrush ⦄ ⦃ _ : HasMockingbird ⦄ → HasStarling
problem₁₂ = record
  { S = W** ∙ G
  ; isStarling = λ x y z → begin
      W** ∙ G ∙ x ∙ y ∙ z  ≈⟨ isWarblerTwiceRemoved G x y z ⟩
      G ∙ x ∙ y ∙ z ∙ z    ≈⟨ isGoldfinch x y z z ⟩
      x ∙ z ∙ (y ∙ z)      ∎
  } where
  instance
    hasWarblerTwiceRemoved = problem₉-W**
    hasGoldfinch = Chapter₁₁.problem₄₇

problem₁₃ : ⦃ _ : HasStarling ⦄ ⦃ _ : HasRobin ⦄ → HasHummingbird
problem₁₃ = record
  { H = S ∙ R
  ; isHummingbird = λ x y z → begin
      S ∙ R ∙ x ∙ y ∙ z    ≈⟨ congʳ $ isStarling R x y ⟩
      R ∙ y ∙ (x ∙ y) ∙ z  ≈⟨ isRobin y (x ∙ y) z ⟩
      x ∙ y ∙ z ∙ y        ∎
  }

problem₁₄-SR : ⦃ _ : HasStarling ⦄ ⦃ _ : HasRobin ⦄ → HasWarbler
problem₁₄-SR = record
  { W = R ∙ (S ∙ R ∙ R) ∙ R
  ; isWarbler = λ x y → begin
      R ∙ (S ∙ R ∙ R) ∙ R ∙ x ∙ y      ≈˘⟨ congʳ $ congʳ $ isRobin R R (S ∙ R ∙ R) ⟩
      R ∙ R ∙ R ∙ (S ∙ R ∙ R) ∙ x ∙ y  ≈⟨⟩
      C ∙ (S ∙ R ∙ R) ∙ x ∙ y          ≈⟨⟩
      C ∙ (H ∙ R) ∙ x ∙ y              ≈⟨⟩
      W ∙ x ∙ y                        ≈⟨ isWarbler x y ⟩
      x ∙ y ∙ y                        ∎
  } where
  instance
    hasCardinal = Chapter₁₁.problem₂₁
    hasHummingbird = problem₁₃
    hasWarbler = problem₁₁

problem₁₄-SC : ⦃ _ : HasStarling ⦄ ⦃ _ : HasCardinal ⦄ → HasWarbler
problem₁₄-SC = record
  { W = C ∙ (S ∙ (C ∙ C) ∙ (C ∙ C))
  ; isWarbler = λ x y → begin
      C ∙ (S ∙ (C ∙ C) ∙ (C ∙ C)) ∙ x ∙ y  ≈⟨⟩
      C ∙ (S ∙ R ∙ R) ∙ x ∙ y              ≈⟨ isCardinal (S ∙ R ∙ R) x y ⟩
      S ∙ R ∙ R ∙ y ∙ x                    ≈⟨ congʳ $ isStarling R R y ⟩
      R ∙ y ∙ (R ∙ y) ∙ x                  ≈⟨ isRobin y (R ∙ y) x ⟩
      R ∙ y ∙ x ∙ y                        ≈⟨ isRobin y x y ⟩
      x ∙ y ∙ y                            ∎
  } where instance hasRobin = Chapter₁₁.problem₂₃

problem₁₅ : ⦃ _ : HasThrush ⦄ ⦃ _ : HasStarling ⦄ → HasWarbler
problem₁₅ = record
  { W = S ∙ T
  ; isWarbler = λ x y → begin
      S ∙ T ∙ x ∙ y    ≈⟨ isStarling T x y ⟩
      T ∙ y ∙ (x ∙ y)  ≈⟨ isThrush y (x ∙ y) ⟩
      x ∙ y ∙ y        ∎
  }

problem₁₆ : ⦃ _ : HasThrush ⦄ ⦃ _ : HasStarling ⦄ → HasMockingbird
problem₁₆ = record
  { M = S ∙ T ∙ T
  ; isMockingbird = λ x → begin
      S ∙ T ∙ T ∙ x    ≈⟨ isStarling T T x ⟩
      T ∙ x ∙ (T ∙ x)  ≈⟨ isThrush x (T ∙ x) ⟩
      T ∙ x ∙ x        ≈⟨ isThrush x x ⟩
      x ∙ x            ∎
  }

module Exercises where
  exercise₁-a : ⦃ _ : HasBluebird ⦄ ⦃ _ : HasThrush ⦄
    → ∃[ G₁ ] (∀ x y z w v → G₁ ∙ x ∙ y ∙ z ∙ w ∙ v ≈ x ∙ y ∙ v ∙ (z ∙ w))
  exercise₁-a =
    ( D₁ ∙ C*
    , λ x y z w v → begin
        D₁ ∙ C* ∙ x ∙ y ∙ z ∙ w ∙ v  ≈⟨ congʳ $ isDickcissel C* x y z w ⟩
        C* ∙ x ∙ y ∙ (z ∙ w) ∙ v     ≈⟨ isCardinalOnceRemoved x y (z ∙ w) v ⟩
        x ∙ y ∙ v ∙ (z ∙ w)          ∎
    )
    where
      instance
        hasCardinal = Chapter₁₁.problem₂₁′
        hasCardinalOnceRemoved = Chapter₁₁.problem₃₁
        hasDickcissel = Chapter₁₁.problem₉

  -- Note: in the solutions, the bluebird is used, but the exercise does not
  -- state that the bluebird may be used.
  exercise₁-b : ⦃ _ : HasBluebird ⦄ ⦃ _ : HasMockingbird ⦄
    → ∃[ G₁ ] (∀ x y z w v → G₁ ∙ x ∙ y ∙ z ∙ w ∙ v ≈ x ∙ y ∙ v ∙ (z ∙ w))
    → ∃[ G₂ ] (∀ x y z w → G₂ ∙ x ∙ y ∙ z ∙ w ≈ x ∙ w ∙ (x ∙ w) ∙ (y ∙ z))
  exercise₁-b (G₁ , isG₁) =
    ( G₁ ∙ (B ∙ M)
    , λ x y z w → begin
        G₁ ∙ (B ∙ M) ∙ x ∙ y ∙ z ∙ w  ≈⟨ isG₁ (B ∙ M) x y z w ⟩
        B ∙ M ∙ x ∙ w ∙ (y ∙ z)       ≈⟨ congʳ $ isBluebird M x w ⟩
        M ∙ (x ∙ w) ∙ (y ∙ z)         ≈⟨ congʳ $ isMockingbird (x ∙ w) ⟩
        x ∙ w ∙ (x ∙ w) ∙ (y ∙ z)     ∎
    )

  exercise₁-c : ⦃ _ : HasBluebird ⦄ ⦃ _ : HasThrush ⦄ ⦃ _ : HasIdentity ⦄
    → ∃[ I₂ ] (∀ x → I₂ ∙ x ≈ x ∙ I ∙ I)
  exercise₁-c =
    ( B ∙ (T ∙ I) ∙ (T ∙ I)
    , λ x → begin
        B ∙ (T ∙ I) ∙ (T ∙ I) ∙ x  ≈⟨ isBluebird (T ∙ I) (T ∙ I) x ⟩
        T ∙ I ∙ (T ∙ I ∙ x)        ≈⟨ isThrush I (T ∙ I ∙ x) ⟩
        T ∙ I ∙ x ∙ I              ≈⟨ congʳ $ isThrush I x ⟩
        x ∙ I ∙ I                  ∎
    )

  exercise₁-d : ⦃ _ : HasIdentity ⦄ ⦃ _ : HasFinch ⦄
    → (hasI₂ : ∃[ I₂ ] (∀ x → I₂ ∙ x ≈ x ∙ I ∙ I))
    → ∀ x → proj₁ hasI₂ ∙ (F ∙ x) ≈ x
  exercise₁-d (I₂ , isI₂) x = begin
    I₂ ∙ (F ∙ x)   ≈⟨ isI₂ (F ∙ x) ⟩
    F ∙ x ∙ I ∙ I  ≈⟨ isFinch x I I ⟩
    I ∙ I ∙ x      ≈⟨ congʳ $ isIdentity I ⟩
    I ∙ x          ≈⟨ isIdentity x ⟩
    x              ∎

  exercise₁-e : ⦃ _ : HasFinch ⦄ ⦃ _ : HasQueerBird ⦄ ⦃ _ : HasIdentity ⦄
    → (hasG₂ : ∃[ G₂ ] (∀ x y z w → G₂ ∙ x ∙ y ∙ z ∙ w ≈ x ∙ w ∙ (x ∙ w) ∙ (y ∙ z)))
    → (hasI₂ : ∃[ I₂ ] (∀ x → I₂ ∙ x ≈ x ∙ I ∙ I))
    → IsWarbler (proj₁ hasG₂ ∙ F ∙ (Q ∙ proj₁ hasI₂))
  exercise₁-e (G₂ , isG₂) (I₂ , isI₂) x y = begin
    G₂ ∙ F ∙ (Q ∙ I₂) ∙ x ∙ y       ≈⟨ isG₂ F (Q ∙ I₂) x y ⟩
    F ∙ y ∙ (F ∙ y) ∙ (Q ∙ I₂ ∙ x)  ≈⟨ isFinch y (F ∙ y) (Q ∙ I₂ ∙ x) ⟩
    Q ∙ I₂ ∙ x ∙ (F ∙ y) ∙ y        ≈⟨ congʳ $ isQueerBird I₂ x (F ∙ y) ⟩
    x ∙ (I₂ ∙ (F ∙ y)) ∙ y          ≈⟨ congʳ $ congˡ $ exercise₁-d (I₂ , isI₂) y ⟩
    x ∙ y ∙ y                       ∎

  exercise₂ : ⦃ _ : HasBluebird ⦄ ⦃ _ : HasCardinal ⦄ ⦃ _ : HasWarbler ⦄
    → IsStarling (B ∙ (B ∙ (B ∙ W) ∙ C) ∙ (B ∙ B))
  exercise₂ x y z = begin
    B ∙ (B ∙ (B ∙ W) ∙ C) ∙ (B ∙ B) ∙ x ∙ y ∙ z  ≈⟨ congʳ $ congʳ $ isBluebird (B ∙ (B ∙ W) ∙ C) (B ∙ B) x ⟩
    B ∙ (B ∙ W) ∙ C ∙ (B ∙ B ∙ x) ∙ y ∙ z        ≈⟨ congʳ $ congʳ $ isBluebird (B ∙ W) C (B ∙ B ∙ x) ⟩
    B ∙ W ∙ (C ∙ (B ∙ B ∙ x)) ∙ y ∙ z            ≈⟨ congʳ $ isBluebird W (C ∙ (B ∙ B ∙ x)) y ⟩
    W ∙ (C ∙ (B ∙ B ∙ x) ∙ y) ∙ z                ≈⟨ isWarbler (C ∙ (B ∙ B ∙ x) ∙ y) z ⟩
    C ∙ (B ∙ B ∙ x) ∙ y ∙ z ∙ z                  ≈⟨ congʳ $ isCardinal (B ∙ B ∙ x) y z ⟩
    B ∙ B ∙ x ∙ z ∙ y ∙ z                        ≈⟨ congʳ $ congʳ $ isBluebird B x z ⟩
    B ∙ (x ∙ z) ∙ y ∙ z                          ≈⟨ isBluebird (x ∙ z) y z ⟩
    x ∙ z ∙ (y ∙ z)                              ∎

  exercise₃ : ⦃ _ : HasStarling ⦄ ⦃ _ : HasBluebird ⦄ → HasPhoenix
  exercise₃ = record
    { Φ = B ∙ (B ∙ S) ∙ B
    ; isPhoenix = λ x y z w → begin
        B ∙ (B ∙ S) ∙ B ∙ x ∙ y ∙ z ∙ w  ≈⟨ congʳ $ congʳ $ congʳ $ isBluebird (B ∙ S) B x ⟩
        B ∙ S ∙ (B ∙ x) ∙ y ∙ z ∙ w      ≈⟨ congʳ $ congʳ $ isBluebird S (B ∙ x) y ⟩
        S ∙ (B ∙ x ∙ y) ∙ z ∙ w          ≈⟨ isStarling (B ∙ x ∙ y) z w ⟩
        B ∙ x ∙ y ∙ w ∙ (z ∙ w)          ≈⟨ congʳ $ isBluebird x y w ⟩
        x ∙ (y ∙ w) ∙ (z ∙ w)            ∎
    }

  exercise₄ : ⦃ _ : HasBluebird ⦄ ⦃ _ : HasCardinal ⦄ ⦃ _ : HasWarbler ⦄ → HasPsiBird
  exercise₄ = record
    { Ψ = H* ∙ D₂
    ; isPsiBird = λ x y z w → begin
        H* ∙ D₂ ∙ x ∙ y ∙ z ∙ w     ≈⟨⟩
        B ∙ H ∙ D₂ ∙ x ∙ y ∙ z ∙ w  ≈⟨ congʳ $ congʳ $ congʳ $ isBluebird H D₂ x ⟩
        H ∙ (D₂ ∙ x) ∙ y ∙ z ∙ w    ≈⟨ congʳ $ isHummingbird (D₂ ∙ x) y z ⟩
        D₂ ∙ x ∙ y ∙ z ∙ y ∙ w      ≈⟨ isDovekie x y z y w ⟩
        x ∙ (y ∙ z) ∙ (y ∙ w)       ∎
    } where
    instance
      hasHummingbird = problem₁₀
      hasDovekie = Chapter₁₁.problem₁₁
    H* = B ∙ H

  -- NOTE: my copy of the book contains a mistake (looking at the given
  -- solutions): it says Γxyzwv = y(zw)(xywv) instead of Γxyzwv = y(zw)(xyzwv).
  exercise₅-a : ⦃ _ : HasPhoenix ⦄ ⦃ _ : HasBluebird ⦄
    → ∃[ Γ ] (∀ x y z w v → Γ ∙ x ∙ y ∙ z ∙ w ∙ v ≈ y ∙ (z ∙ w) ∙ (x ∙ y ∙ z ∙ w ∙ v))
  exercise₅-a =
    ( Φ ∙ (Φ ∙ (Φ ∙ B)) ∙ B
    , λ x y z w v → begin
        Φ ∙ (Φ ∙ (Φ ∙ B)) ∙ B ∙ x ∙ y ∙ z ∙ w ∙ v    ≈⟨ congʳ $ congʳ $ congʳ $ isPhoenix (Φ ∙ (Φ ∙ B)) B x y ⟩
        Φ ∙ (Φ ∙ B) ∙ (B ∙ y) ∙ (x ∙ y) ∙ z ∙ w ∙ v  ≈⟨ congʳ $ congʳ $ isPhoenix (Φ ∙ B) (B ∙ y) (x ∙ y) z ⟩
        Φ ∙ B ∙ (B ∙ y ∙ z) ∙ (x ∙ y ∙ z) ∙ w ∙ v    ≈⟨ congʳ $ isPhoenix B (B ∙ y ∙ z) (x ∙ y ∙ z) w ⟩
        B ∙ (B ∙ y ∙ z ∙ w) ∙ (x ∙ y ∙ z ∙ w) ∙ v    ≈⟨ isBluebird (B ∙ y ∙ z ∙ w) (x ∙ y ∙ z ∙ w) v ⟩
        B ∙ y ∙ z ∙ w ∙ (x ∙ y ∙ z ∙ w ∙ v)          ≈⟨ congʳ $ isBluebird y z w ⟩
        y ∙ (z ∙ w) ∙ (x ∙ y ∙ z ∙ w ∙ v)            ∎
    )

  exercise₅-b : ⦃ _ : HasKestrel ⦄
    → ∃[ Γ ] (∀ x y z w v → Γ ∙ x ∙ y ∙ z ∙ w ∙ v ≈ y ∙ (z ∙ w) ∙ (x ∙ y ∙ z ∙ w ∙ v))
    → HasPsiBird
  exercise₅-b (Γ , isΓ) = record
    { Ψ = Γ ∙ (K ∙ K)
    ; isPsiBird = λ x y z w → begin
        Γ ∙ (K ∙ K) ∙ x ∙ y ∙ z ∙ w            ≈⟨ isΓ (K ∙ K) x y z w ⟩
        x ∙ (y ∙ z) ∙ (K ∙ K ∙ x ∙ y ∙ z ∙ w)  ≈⟨ congˡ $ congʳ $ congʳ $ congʳ $ isKestrel K x ⟩
        x ∙ (y ∙ z) ∙ (K ∙ y ∙ z ∙ w)          ≈⟨ congˡ $ congʳ $ isKestrel y z ⟩
        x ∙ (y ∙ z) ∙ (y ∙ w)                  ∎
    }

  exercise₅ : ⦃ _ : HasPhoenix ⦄ ⦃ _ : HasBluebird ⦄ ⦃ _ : HasKestrel ⦄ → HasPsiBird
  exercise₅ = exercise₅-b exercise₅-a

  exercise₆-a : ⦃ _ : HasStarling ⦄ ⦃ _ : HasBluebird ⦄ ⦃ _ : HasThrush ⦄
    → ∃[ S′ ] (∀ x y z → S′ ∙ x ∙ y ∙ z ≈ y ∙ z ∙ (x ∙ z))
  exercise₆-a =
    ( C ∙ S
    , λ x y z → begin
        C ∙ S ∙ x ∙ y ∙ z  ≈⟨ congʳ $ isCardinal S x y ⟩
        S ∙ y ∙ x ∙ z      ≈⟨ isStarling y x z ⟩
        y ∙ z ∙ (x ∙ z)    ∎
    )
    where instance hasCardinal = Chapter₁₁.problem₂₁′

  exercise₆-b : ⦃ _ : HasIdentity ⦄
    → ∃[ S′ ] (∀ x y z → S′ ∙ x ∙ y ∙ z ≈ y ∙ z ∙ (x ∙ z))
    → HasWarbler
  exercise₆-b (S′ , isS′) = record
    { W = S′ ∙ I
    ; isWarbler = λ x y → begin
        S′ ∙ I ∙ x ∙ y   ≈⟨ isS′ I x y ⟩
        x ∙ y ∙ (I ∙ y)  ≈⟨ congˡ $ isIdentity y ⟩
        x ∙ y ∙ y        ∎
    }

  exercise₇ : ⦃ _ : HasQueerBird ⦄ ⦃ _ : HasCardinal ⦄ ⦃ _ : HasWarbler ⦄
    → ∃[ Q̂ ] IsStarling (C ∙ Q̂ ∙ W)
  exercise₇ = let Q̂ = Q ∙ (Q ∙ Q ∙ (Q ∙ Q)) ∙ Q in
    ( Q̂
    , λ x y z → begin
        C ∙ Q̂ ∙ W ∙ x ∙ y ∙ z ≈⟨ congʳ $ congʳ $ isCardinal Q̂ W x ⟩
        Q̂ ∙ x ∙ W ∙ y ∙ z                          ≈⟨⟩
        Q ∙ (Q ∙ Q ∙ (Q ∙ Q)) ∙ Q ∙ x ∙ W ∙ y ∙ z  ≈⟨ congʳ $ congʳ $ congʳ $ isQueerBird (Q ∙ Q ∙ (Q ∙ Q)) Q  x ⟩
        Q ∙ (Q ∙ Q ∙ (Q ∙ Q) ∙ x) ∙ W ∙ y ∙ z      ≈⟨ congʳ $ isQueerBird (Q ∙ Q ∙ (Q ∙ Q) ∙ x) W y ⟩
        W ∙ (Q ∙ Q ∙ (Q ∙ Q) ∙ x ∙ y) ∙ z          ≈⟨ isWarbler (Q ∙ Q ∙ (Q ∙ Q) ∙ x ∙ y) z ⟩
        Q ∙ Q ∙ (Q ∙ Q) ∙ x ∙ y ∙ z ∙ z            ≈⟨ congʳ $ congʳ $ congʳ $ isQueerBird Q (Q ∙ Q) x ⟩
        Q ∙ Q ∙ (Q ∙ x) ∙ y ∙ z ∙ z                ≈⟨ congʳ $ congʳ $ isQueerBird Q (Q ∙ x) y ⟩
        Q ∙ x ∙ (Q ∙ y) ∙ z ∙ z                    ≈⟨ congʳ $ isQueerBird x (Q ∙ y) z ⟩
        Q ∙ y ∙ (x ∙ z) ∙ z                        ≈⟨ isQueerBird y (x ∙ z) z ⟩
        x ∙ z ∙ (y ∙ z)                            ∎
    )


{-# OPTIONS --rewriting #-}

data _≅_ {ℓ} {A : Set ℓ} (x : A) : {B : Set ℓ} → B → Set where
  refl : x ≅ x

{-# BUILTIN REWRITE _≅_ #-}


import Common
import Global
import Local
import Projection
import Soundness
import Completeness

import Example


postulate
  F : Set → Set

G : Set
G = {!F ?!}

-- KEEP COMMENTS AT THE END to not mess with the ranges in Issue2174.sh

-- Andreas, 2016-09-10, issue #2174 reported by Nisse

-- First infer, then give should goalify the questionmark


{- reported by Guillaume Brunerie on 2015-09-17 -}

{-# OPTIONS --rewriting #-}

data _==_ {A : Set} (a : A) : A → Set where
  idp : a == a
{-# BUILTIN REWRITE _==_ #-}

postulate
  A B : Set
  f g : A → B

module M (x : A) where

  postulate
    rx : f x == g x
  {-# REWRITE rx #-}

  -- This shouldn't work
  test : (y : A) → f y == g y
  test y = idp


module Issue478 where

record Ko (Q : Set) : Set₁ where
 field
  T : Set

module Bo (P : Set) (ko : Ko P) where
  open Ko ko

  err : T
  err = Set

{- The error message was:
  Set₁ !=< T P ko of type Set₂
  when checking that the expression Set has type T P ko

  We now get the desired error message:

  Set₁ !=< T of type Set₂
  when checking that the expression Set has type T

-}