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

open import HoTT
open import lib.cubical.elims.CubeMove
open import lib.cubical.elims.CofWedge

module lib.cubical.elims.SuspSmash where

module _ {i j k} {X : Ptd i} {Y : Ptd j} {C : Type k}
  (f : Suspension (X ∧ Y) → C) (g : Suspension (X ∧ Y) → C)
  (north* : f (north _) == g (north _))
  (south* : f (south _) == g (south _))
  (cod* : (s : fst X × fst Y) → Square north* (ap f (merid _ (cfcod _ s)))
                                (ap g (merid _ (cfcod _ s))) south*)
  where

  private
    base* = transport
      (λ κ → Square north* (ap f (merid _ κ)) (ap g (merid _ κ)) south*)
      (! (cfglue _ (winl (snd X))))
      (cod* (snd X , snd Y))

    CubeType : (w : X ∨ Y)
      → Square north* (ap f (merid _ (cfcod _ (∨-in-× X Y w))))
               (ap g (merid _ (cfcod _ (∨-in-× X Y w)))) south*
      → Type _
    CubeType w sq =
      Cube base* sq
        (natural-square (λ _ → north*) (cfglue _ w))
        (natural-square (ap f ∘ merid _) (cfglue _ w))
        (natural-square (ap g ∘ merid _) (cfglue _ w))
        (natural-square (λ _ → south*) (cfglue _ w))

    fill : (w : X ∨ Y)
      (sq : Square north* (ap f (merid _ (cfcod _ (∨-in-× X Y w))))
                   (ap g (merid _ (cfcod _ (∨-in-× X Y w)))) south*)
      → Σ (Square north* idp idp north*) (λ p → CubeType w (p ⊡h sq))
    fill w sq =
      (fst fill' ,
       cube-right-from-front (fst fill') sq (snd fill'))
      where
      fill' = fill-cube-right _ _ _ _ _

    fill0 = fill (winl (snd X)) (cod* (snd X , snd Y))
    fillX = λ x → fill (winl x) (fst fill0 ⊡h cod* (x , snd Y))
    fillY = λ y → fill (winr y) (fst fill0 ⊡h cod* (snd X , y))

    fillX0 : fst (fillX (snd X)) == hid-square
    fillX0 = ⊡h-unit-l-unique _ (fst fill0 ⊡h cod* (snd X , snd Y))
               (fill-cube-right-unique (snd (fillX (snd X)))
                ∙ ! (fill-cube-right-unique (snd fill0)))

    fillY0 : fst (fillY (snd Y)) == hid-square
    fillY0 = ⊡h-unit-l-unique _ (fst fill0 ⊡h cod* (snd X , snd Y))
               (fill-cube-right-unique (snd (fillY (snd Y)))
                ∙ ! (fill-cube-right-unique
                       (snd (fill (winr (snd Y)) (cod* (snd X , snd Y)))))
                ∙ ! (ap (λ w → fst (fill w (cod* (∨-in-× X Y w)))
                                ⊡h cod* (snd X , snd Y))
                     wglue))
      where
      fill-square : (w : X ∨ Y)
        → Square north* (ap f (merid _ (cfcod _ (∨-in-× X Y w))))
                 (ap g (merid _ (cfcod _ (∨-in-× X Y w)))) south*
      fill-square w =
        fst (fill-cube-right base*
              (natural-square (λ _ → north*) (cfglue _ w))
              (natural-square (ap f ∘ merid _) (cfglue _ w))
              (natural-square (ap g ∘ merid _) (cfglue _ w))
              (natural-square (λ _ → south*) (cfglue _ w)))

    abstract
      coh : (s : X ∧ Y)
        → north* == south* [ (λ z → f z == g z) ↓ merid _ s ]
      coh = ↓-='-from-square ∘ cof-wedge-square-elim _ _ _ _
        base*
        (λ {(x , y) →
          fst (fillX x) ⊡h fst (fillY y) ⊡h fst fill0 ⊡h cod* (x , y)})
        (λ x → transport (λ sq → CubeType (winl x) (fst (fillX x) ⊡h sq))
          (! (ap (λ sq' → sq' ⊡h fst fill0 ⊡h cod* (x , snd Y)) fillY0
              ∙ ⊡h-unit-l (fst fill0 ⊡h cod* (x , snd Y))))
          (snd (fillX x)))
        (λ y → transport (CubeType (winr y))
          (! (ap (λ sq' → sq' ⊡h fst (fillY y) ⊡h fst fill0 ⊡h cod* (snd X , y))
                 fillX0
              ∙ ⊡h-unit-l (fst (fillY y) ⊡h fst fill0 ⊡h cod* (snd X , y))))
        (snd (fillY y)))

  susp-smash-path-elim : ((σ : Suspension (X ∧ Y)) → f σ == g σ)
  susp-smash-path-elim = Suspension-elim _ north* south* coh


{-# OPTIONS --rewriting #-}

open import Agda.Builtin.Equality

postulate
  A : Set
  x0 : A
  f : A → A → A

{-# BUILTIN REWRITE _≡_ #-}

postulate
  fxx : (x : A) → (f x x) ≡ x

{-# REWRITE fxx #-}

meta : A
meta-reveal : meta ≡ x0
test : f x0 meta ≡ x0

meta = _
test = refl
meta-reveal = refl


module PatternShadowsConstructor2 where

module A where

  data A (X : Set) : Set where
    c : A X → A X
    x : A X

open A using (A; c)

f : ∀ {X} → A X → A X → A X
f (c y) x = x
f A.x   _ = A.x


module Types where

open import Data.Bool
open import Data.Fin using (Fin)
import      Data.Fin as F
open import Data.Nat renaming (_≟_ to _≟N_)
open import Data.Vec hiding (head; tail)
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary

infixl 80 _∙_

data Type : Set where
  𝔹  : Type
  𝔹⁺ : ℕ → Type
  ℂ  : Type → Type
  _⇒_ : Type → Type → Type
  _×_ : Type → Type → Type

data Syntax : Set where
  bitI   : Syntax
  bitO   : Syntax
  []     : Syntax
  _∷_    : Syntax → Syntax → Syntax
  _nand_ : Syntax → Syntax → Syntax
  reg    : Syntax → Syntax → Syntax
  pair   : Syntax → Syntax → Syntax
  latest : Syntax → Syntax
  head   : Syntax → Syntax
  tail   : Syntax → Syntax
  var    : ℕ → Syntax
  _∙_    : Syntax → Syntax → Syntax
  lam    : Type → Syntax → Syntax

Ctx : ℕ → Set
Ctx = Vec Type

data Term {n} (Γ : Ctx n) : Type → Set where
  bitI   : Term Γ 𝔹
  bitO   : Term Γ 𝔹
  []     : Term Γ (𝔹⁺ 0)
  _∷_    : ∀ {n} → Term Γ 𝔹 → Term Γ (𝔹⁺ n) → Term Γ (𝔹⁺ (suc n))
  _nand_ : Term Γ 𝔹 → Term Γ 𝔹 → Term Γ 𝔹
  reg    : ∀ {τ σ} → Term Γ τ → Term Γ (τ ⇒ (τ × σ)) → Term Γ (ℂ σ)
  pair   : ∀ {σ τ} → Term Γ σ → Term Γ τ → Term Γ (σ × τ)
  latest : ∀ {τ} → Term Γ (ℂ τ) → Term Γ τ
  head   : ∀ {n} → Term Γ (𝔹⁺ (suc n)) → Term Γ 𝔹
  tail   : ∀ {n} → Term Γ (𝔹⁺ (suc n)) → Term Γ (𝔹⁺ n)
  var    : ∀ {τ} (i : Fin n) → (lookup i Γ ≡ τ) → Term Γ τ
  _∙_    : ∀ {σ τ} → Term Γ (σ ⇒ τ) → Term Γ σ → Term Γ τ
  lam    : ∀ {σ τ} → Term (σ ∷ Γ) τ → Term Γ (σ ⇒ τ)

Closed : Type → Set
Closed τ = ∀ {n} {ctx : Ctx n} → Term ctx τ

≡𝔹⁺ : ∀ {n m} → 𝔹⁺ n ≡ 𝔹⁺ m → n ≡ m
≡𝔹⁺ refl = refl

≡ℂ : ∀ {τ σ} → ℂ τ ≡ ℂ σ → τ ≡ σ
≡ℂ refl = refl

≡⇒₁ : ∀ {σ σ′ τ τ′} → σ ⇒ τ ≡ σ′ ⇒ τ′ → σ ≡ σ′
≡⇒₁ refl = refl

≡⇒₂ : ∀ {σ σ′ τ τ′} → σ ⇒ τ ≡ σ′ ⇒ τ′ → τ ≡ τ′
≡⇒₂ refl = refl

≡×₁ : ∀ {σ σ′ τ τ′} → σ × τ ≡ σ′ × τ′ → σ ≡ σ′
≡×₁ refl = refl

≡×₂ : ∀ {σ σ′ τ τ′} → σ × τ ≡ σ′ × τ′ → τ ≡ τ′
≡×₂ refl = refl

_≟T_ : (σ τ : Type) → Dec (σ ≡ τ)
𝔹 ≟T 𝔹 = yes refl
𝔹 ≟T 𝔹⁺ _ = no (λ ())
𝔹 ≟T ℂ _ = no (λ ())
𝔹 ≟T (_ ⇒ _) = no (λ ())
𝔹 ≟T (_ × _) = no (λ ())
𝔹⁺ _ ≟T 𝔹 = no (λ ())
𝔹⁺ n ≟T 𝔹⁺ m with n ≟N m
𝔹⁺ n ≟T 𝔹⁺ .n | yes refl = yes refl
𝔹⁺ n ≟T 𝔹⁺ m  | no ¬p = no (λ x → ¬p (≡𝔹⁺ x))
𝔹⁺ _ ≟T ℂ _ = no (λ ())
𝔹⁺ _ ≟T (y ⇒ y₁) = no (λ ())
𝔹⁺ _ ≟T (y × y₁) = no (λ ())
ℂ _ ≟T 𝔹 = no (λ ())
ℂ _ ≟T 𝔹⁺ n = no (λ ())
ℂ τ ≟T ℂ σ with τ ≟T σ
ℂ τ ≟T ℂ .τ | yes refl = yes refl
ℂ τ ≟T ℂ σ | no ¬p = no (λ x → ¬p (≡ℂ x))
ℂ _ ≟T (_ ⇒ _) = no (λ ())
ℂ _ ≟T (_ × _) = no (λ ())
(_ ⇒ _) ≟T 𝔹 = no (λ ())
(σ ⇒ τ) ≟T 𝔹⁺ x₂ = no (λ ())
(_ ⇒ _) ≟T ℂ _ = no (λ ())
(σ ⇒ τ) ≟T (σ₁ ⇒ τ₁) with σ ≟T σ₁ | τ ≟T τ₁
(σ ⇒ τ) ≟T (σ₁ ⇒ τ₁) | yes p | yes p₁ = yes (cong₂ _⇒_ p p₁)
(σ ⇒ τ) ≟T (σ₁ ⇒ τ₁) |     _ | no  ¬p = no (λ x → ¬p (≡⇒₂ x))
(σ ⇒ τ) ≟T (σ₁ ⇒ τ₁) | no ¬p |      _ = no (λ x → ¬p (≡⇒₁ x))
(_ ⇒ _) ≟T (_ × _) = no (λ ())
(_ × _) ≟T 𝔹 = no (λ ())
(_ × _) ≟T 𝔹⁺ _ = no (λ ())
(_ × _) ≟T ℂ _ = no (λ ())
(_ × _) ≟T (_ ⇒ _) = no (λ ())
(σ × τ) ≟T (σ₁ × τ₁) with σ ≟T σ₁ | τ ≟T τ₁
(σ × τ) ≟T (σ₁ × τ₁) | yes p | yes p₁ = yes (cong₂ _×_ p p₁)
(σ × τ) ≟T (σ₁ × τ₁) | _ | no ¬p = no (λ x → ¬p (≡×₂ x))
(σ × τ) ≟T (σ₁ × τ₁) | no ¬p | _ = no (λ x → ¬p (≡×₁ x))

erase : ∀ {n} {Γ : Ctx n} {τ} → Term Γ τ → Syntax
erase bitI        = bitI
erase bitO        = bitO
erase []          = []
erase (x ∷ xs)    = erase x ∷ erase xs
erase (x nand y)  = erase x nand erase y
erase (reg x t)   = reg (erase x) (erase t)
erase (pair x y)  = pair (erase x) (erase y)
erase (latest x)  = latest (erase x)
erase (head x)    = head (erase x)
erase (tail x)    = tail (erase x)
erase (var v _)   = var (F.toℕ v)
erase (t ∙ u)     = erase t ∙ erase u
erase (lam {σ} t) = lam σ (erase t)


------------------------------------------------------------------------
-- The Eilenberg-MacLane space K(G, 1)
------------------------------------------------------------------------

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

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

import Equality.Path as P

module Eilenberg-MacLane-space
  {e⁺} (eq : ∀ {a p} → P.Equality-with-paths a p e⁺) where

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

open import Logical-equivalence using (_⇔_)
open import Prelude as P hiding (id) renaming (_∘_ to _⊚_)

open import Bijection equality-with-J as B using (_↔_)
open import Embedding equality-with-J using (Embedding; Is-embedding)
import Equality.Groupoid equality-with-J as EG
open import Equality.Path.Isomorphisms eq
open import Equivalence equality-with-J as Eq
  using (_≃_; Is-equivalence)
import Equivalence P.equality-with-J as PEq
open import Function-universe equality-with-J hiding (id; _∘_)
open import Group equality-with-J
open import H-level equality-with-J as H-level
import H-level P.equality-with-J as PH
open import H-level.Closure equality-with-J
open import H-level.Truncation eq as T using (∥_∥[1+_]; ∣_∣)
open import H-level.Truncation.Propositional eq as TP using (Surjective)
open import Pointed-type equality-with-J
open import Pointed-type.Connected eq
open import Pointed-type.Homotopy-group eq
open import Univalence-axiom equality-with-J

private
  variable
    a p     : Level
    A       : Type a
    P       : A → Type p
    e g x y : A
    G G₁ G₂ : Group g

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

-- The Eilenberg-MacLane space K(G, 1).
--
-- This definition is taken from "Eilenberg-MacLane Spaces in Homotopy
-- Type Theory" by Licata and Finster.

data K[_]1 (G : Group g) : Type g where
  base        : K[ G ]1
  loopᴾ        : Group.Carrier G → base P.≡ base
  loop-idᴾ     : loopᴾ (Group.id G) P.≡ P.refl
  loop-∘ᴾ      : loopᴾ (Group._∘_ G x y) P.≡ P.trans (loopᴾ x) (loopᴾ y)
  is-groupoidᴾ : PH.H-level 3 K[ G ]1

-- Variants of the higher constructors.

loop : Group.Carrier G → base ≡ base
loop {G = G} = _↔_.from ≡↔≡ ⊚ loopᴾ {G = G}

loop-id : loop {G = G} (Group.id G) ≡ refl base
loop-id {G = G} =
  loop id              ≡⟨ _≃_.from (Eq.≃-≡ (Eq.↔⇒≃ (inverse ≡↔≡))) (_↔_.from ≡↔≡ loop-idᴾ) ⟩
  _↔_.from ≡↔≡ P.refl  ≡⟨ from-≡↔≡-refl ⟩∎
  refl base            ∎
  where
  open Group G

loop-∘ : loop {G = G} (Group._∘_ G x y) ≡ trans (loop x) (loop y)
loop-∘ {G = G} {x = x} {y = y} =
  loop (Group._∘_ G x y)                      ≡⟨ _≃_.from (Eq.≃-≡ (Eq.↔⇒≃ (inverse ≡↔≡))) (_↔_.from ≡↔≡ loop-∘ᴾ) ⟩
  _↔_.from ≡↔≡ (P.trans (loopᴾ x) (loopᴾ y))  ≡⟨ sym trans≡trans ⟩∎
  trans (loop x) (loop y)                     ∎

is-groupoid : H-level 3 K[ G ]1
is-groupoid = _↔_.from (H-level↔H-level 3) is-groupoidᴾ

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

-- A dependent eliminator, expressed using paths.
--
-- This eliminator is based on one from "Eilenberg-MacLane Spaces in
-- Homotopy Type Theory" by Licata and Finster.

record Elimᴾ {G : Group g} (P : K[ G ]1 → Type p) : Type (g ⊔ p) where
  no-eta-equality
  open Group G
  field
    baseʳ        : P base
    loopʳ        : ∀ g → P.[ (λ i → P (loopᴾ g i)) ] baseʳ ≡ baseʳ
    loop-idʳ     : P.[ (λ i → P.[ (λ j → P (loop-idᴾ i j)) ]
                                baseʳ ≡ baseʳ) ]
                     loopʳ id ≡ P.refl {x = baseʳ}
    loop-∘ʳ      : P.[ (λ i →
                          P.[ (λ j → P (loop-∘ᴾ {x = x} {y = y} i j)) ]
                            baseʳ ≡ baseʳ) ]
                     loopʳ (x ∘ y) ≡ P.htrans P (loopʳ x) (loopʳ y)
    is-groupoidʳ : ∀ x → PH.H-level 3 (P x)

open Elimᴾ public

elimᴾ : Elimᴾ P → (x : K[ G ]1) → P x
elimᴾ {G = G} {P = P} e = helper
  where
  module E = Elimᴾ e

  helper : (x : K[ G ]1) → P x
  helper base                     = E.baseʳ
  helper (loopᴾ x i)              = E.loopʳ x i
  helper (loop-idᴾ i j)           = E.loop-idʳ i j
  helper (loop-∘ᴾ i j)            = E.loop-∘ʳ i j
  helper (is-groupoidᴾ p q i j k) =
    P.heterogeneous-UIP₃ E.is-groupoidʳ (is-groupoidᴾ p q)
      (λ j k → helper (p j k)) (λ j k → helper (q j k)) i j k

-- A non-dependent eliminator, expressed using paths.
--
-- This eliminator is based on one from "Eilenberg-MacLane Spaces in
-- Homotopy Type Theory" by Licata and Finster.

record Recᴾ (G : Group g) (A : Type a) : Type (g ⊔ a) where
  no-eta-equality
  open Group G
  field
    baseʳ        : A
    loopʳ        : Carrier → baseʳ P.≡ baseʳ
    loop-idʳ     : loopʳ id P.≡ P.refl
    loop-∘ʳ      : loopʳ (x ∘ y) P.≡ P.trans (loopʳ x) (loopʳ y)
    is-groupoidʳ : PH.H-level 3 A

open Recᴾ public

recᴾ : Recᴾ G A → K[ G ]1 → A
recᴾ {G = G} {A = A} r = elimᴾ λ where
    .is-groupoidʳ _          → R.is-groupoidʳ
    .baseʳ                   → R.baseʳ
    .loopʳ                   → R.loopʳ
    .loop-idʳ                → R.loop-idʳ
    .loop-∘ʳ {x = x} {y = y} →
      R.loopʳ (x ∘ y)                                             P.≡⟨ R.loop-∘ʳ ⟩

      P.trans (R.loopʳ x) (R.loopʳ y)                             P.≡⟨ P.sym $ P.htrans-const (loopᴾ {G = G} x) (loopᴾ y) (R.loopʳ x) ⟩∎

      P.htrans {x≡y = loopᴾ {G = G} x} {y≡z = loopᴾ y} (const A)
        (R.loopʳ x) (R.loopʳ y)                                   ∎
  where
  open Group G
  module R = Recᴾ r

-- A non-dependent eliminator.
--
-- This eliminator is based on one from "Eilenberg-MacLane Spaces in
-- Homotopy Type Theory" by Licata and Finster.

record Rec (G : Group g) (A : Type a) : Type (g ⊔ a) where
  no-eta-equality
  open Group G
  field
    baseʳ        : A
    loopʳ        : Carrier → baseʳ ≡ baseʳ
    loop-idʳ     : loopʳ id ≡ refl baseʳ
    loop-∘ʳ      : loopʳ (x ∘ y) ≡ trans (loopʳ x) (loopʳ y)
    is-groupoidʳ : H-level 3 A

open Rec public

rec : Rec G A → K[ G ]1 → A
rec {G = G} {A = A} r = recᴾ λ where
    .is-groupoidʳ            → _↔_.to (H-level↔H-level 3) R.is-groupoidʳ
    .baseʳ                   → R.baseʳ
    .loopʳ                   → _↔_.to ≡↔≡ ⊚ R.loopʳ
    .loop-idʳ                →
      _↔_.to ≡↔≡ (R.loopʳ id)    P.≡⟨ P.cong (_↔_.to ≡↔≡) $ _↔_.to ≡↔≡ R.loop-idʳ ⟩
      _↔_.to ≡↔≡ (refl R.baseʳ)  P.≡⟨ _↔_.to ≡↔≡ to-≡↔≡-refl ⟩∎
      P.refl                     ∎
    .loop-∘ʳ {x = x} {y = y} →
      _↔_.to ≡↔≡ (R.loopʳ (x ∘ y))                                 P.≡⟨ P.cong (_↔_.to ≡↔≡) $ _↔_.to ≡↔≡ R.loop-∘ʳ ⟩

      _↔_.to ≡↔≡ (trans (R.loopʳ x) (R.loopʳ y))                   P.≡⟨ _↔_.to ≡↔≡ $ sym $ cong₂ (λ p q → _↔_.to ≡↔≡ (trans p q))
                                                                          (_↔_.left-inverse-of ≡↔≡ _)
                                                                          (_↔_.left-inverse-of ≡↔≡ _) ⟩
      _↔_.to ≡↔≡ (trans (_↔_.from ≡↔≡ (_↔_.to ≡↔≡ (R.loopʳ x)))
                        (_↔_.from ≡↔≡ (_↔_.to ≡↔≡ (R.loopʳ y))))   P.≡⟨ P.cong (_↔_.to ≡↔≡) $ _↔_.to ≡↔≡ trans≡trans ⟩

      (_↔_.to ≡↔≡ $ _↔_.from ≡↔≡ $
       P.trans (_↔_.to ≡↔≡ (R.loopʳ x)) (_↔_.to ≡↔≡ (R.loopʳ y)))  P.≡⟨ _↔_.to ≡↔≡ $ _↔_.right-inverse-of ≡↔≡ _ ⟩∎

      P.trans (_↔_.to ≡↔≡ (R.loopʳ x)) (_↔_.to ≡↔≡ (R.loopʳ y))    ∎
  where
  open Group G
  module R = Rec r

-- A "computation" rule.

rec-loop : cong (rec e) (loop g) ≡ e .loopʳ g
rec-loop = cong-≡↔≡ (refl _)

-- A dependent eliminator that can be used when eliminating into sets,
-- expressed using paths.

record Elim-setᴾ {G : Group g}
                 (P : K[ G ]1 → Type p) : Type (g ⊔ p) where
  no-eta-equality
  open Group G
  field
    baseʳ   : P base
    loopʳ   : ∀ g → P.[ (λ i → P (loopᴾ g i)) ] baseʳ ≡ baseʳ
    is-setʳ : ∀ x → P.Is-set (P x)

open Elim-setᴾ public

elim-setᴾ : Elim-setᴾ P → (x : K[ G ]1) → P x
elim-setᴾ e = elimᴾ λ where
    .baseʳ        → E.baseʳ
    .loopʳ        → E.loopʳ
    .loop-idʳ     → P.heterogeneous-UIP E.is-setʳ _ _ _
    .loop-∘ʳ      → P.heterogeneous-UIP E.is-setʳ _ _ _
    .is-groupoidʳ → PH.mono₁ 2 ⊚ E.is-setʳ
  where
  module E = Elim-setᴾ e

-- A dependent eliminator that can be used when eliminating into sets.

record Elim-set {G : Group g}
                (P : K[ G ]1 → Type p) : Type (g ⊔ p) where
  no-eta-equality
  open Group G
  field
    baseʳ   : P base
    loopʳ   : ∀ g → subst P (loop g) baseʳ ≡ baseʳ
    is-setʳ : ∀ x → Is-set (P x)

open Elim-set public

elim-set : Elim-set P → (x : K[ G ]1) → P x
elim-set e = elim-setᴾ λ where
    .baseʳ   → E.baseʳ
    .loopʳ   → subst≡→[]≡ ⊚ E.loopʳ
    .is-setʳ → _↔_.to (H-level↔H-level 2) ⊚ E.is-setʳ
  where
  module E = Elim-set e

-- A "computation" rule.

elim-set-loop : dcong (elim-set e) (loop g) ≡ e .loopʳ g
elim-set-loop = dcong-subst≡→[]≡ (refl _)

-- A non-dependent eliminator that can be used when eliminating into
-- sets, expressed using paths.

record Rec-setᴾ (G : Group g) (A : Type a) : Type (g ⊔ a) where
  no-eta-equality
  open Group G
  field
    baseʳ   : A
    loopʳ   : Carrier → baseʳ P.≡ baseʳ
    is-setʳ : P.Is-set A

open Rec-setᴾ public

rec-setᴾ : Rec-setᴾ G A → K[ G ]1 → A
rec-setᴾ r = elim-setᴾ λ where
    .baseʳ     → R.baseʳ
    .loopʳ     → R.loopʳ
    .is-setʳ _ → R.is-setʳ
  where
  module R = Rec-setᴾ r

-- A non-dependent eliminator that can be used when eliminating into
-- sets.

record Rec-set (G : Group g) (A : Type a) : Type (g ⊔ a) where
  no-eta-equality
  open Group G
  field
    baseʳ   : A
    loopʳ   : Carrier → baseʳ ≡ baseʳ
    is-setʳ : Is-set A

open Rec-set public

rec-set : Rec-set G A → K[ G ]1 → A
rec-set r = rec-setᴾ λ where
    .baseʳ   → R.baseʳ
    .loopʳ   → _↔_.to ≡↔≡ ⊚ R.loopʳ
    .is-setʳ → _↔_.to (H-level↔H-level 2) R.is-setʳ
  where
  module R = Rec-set r

-- A "computation" rule.

rec-set-loop : cong (rec-set e) (loop g) ≡ e .loopʳ g
rec-set-loop = cong-≡↔≡ (refl _)

-- A dependent eliminator that can be used when eliminating into
-- propositions.

record Elim-prop {G : Group g} (P : K[ G ]1 → Type p) :
                 Type (g ⊔ p) where
  no-eta-equality
  field
    baseʳ           : P base
    is-propositionʳ : ∀ x → Is-proposition (P x)

open Elim-prop public

elim-prop : Elim-prop P → (x : K[ G ]1) → P x
elim-prop e = elim-set λ where
    .baseʳ   → E.baseʳ
    .loopʳ _ → E.is-propositionʳ _ _ _
    .is-setʳ → mono₁ 1 ⊚ E.is-propositionʳ
  where
  module E = Elim-prop e

------------------------------------------------------------------------
-- Universal properties

-- A dependent universal property, restricted to families of sets.
--
-- This property is expressed using P.[_]_≡_.

universal-property-Π-setᴾ :
  (∀ x → P.Is-set (P x)) →
  ((x : K[ G ]1) → P x) ≃
  (∃ λ (x : P base) → ∀ g → P.[ (λ i → P (loopᴾ g i)) ] x ≡ x)
universal-property-Π-setᴾ {G = G} {P = P} P-set =
  _↔_.from ≃↔≃ $
  PEq.↔→≃
    (λ f → f base , P.hcong f ⊚ loopᴾ)
    (λ (x , f) → elim-setᴾ λ where
       .baseʳ   → x
       .loopʳ   → f
       .is-setʳ → P-set)
    (λ _ → P.refl)
    (λ f → P.⟨ext⟩ $ elim-setᴾ λ where
       .baseʳ     → P.refl
       .loopʳ _ _ → P.refl
       .is-setʳ _ → PH.mono₁ 2 (P-set _))

-- A variant of the dependent universal property, restricted to
-- families of sets.
--
-- This property is expressed using subst.

universal-property-Π-set :
  (∀ x → Is-set (P x)) →
  ((x : K[ G ]1) → P x) ≃
  (∃ λ (x : P base) → ∀ g → subst P (loop g) x ≡ x)
universal-property-Π-set {G = G} {P = P} P-set =
  ((x : K[ G ]1) → P x)                                         ↝⟨ universal-property-Π-setᴾ (_↔_.to (H-level↔H-level 2) ⊚ P-set) ⟩
  (∃ λ (x : P base) → ∀ g → P.[ (λ i → P (loopᴾ g i)) ] x ≡ x)  ↔⟨ (∃-cong λ _ → ∀-cong ext λ _ → inverse subst≡↔[]≡) ⟩□
  (∃ λ (x : P base) → ∀ g → subst P (loop g) x ≡ x)             □

-- A non-dependent universal property, restricted to sets.

universal-property-set :
  Is-set A →
  (K[ G ]1 → A) ≃ (∃ λ (x : A) → Group.Carrier G → x ≡ x)
universal-property-set {A = A} {G = G} A-set =
  (K[ G ]1 → A)                      ↝⟨ universal-property-Π-setᴾ (λ _ → _↔_.to (H-level↔H-level 2) A-set) ⟩
  (∃ λ (x : A) → Carrier → x P.≡ x)  ↔⟨ (∃-cong λ _ → ∀-cong ext λ _ → inverse ≡↔≡) ⟩□
  (∃ λ (x : A) → Carrier → x ≡ x)    □
  where
  open Group G

------------------------------------------------------------------------
-- Some conversion functions

-- A map function.
--
-- The existence of such a function was suggested to me by Christian
-- Sattler.

map : G₁ →ᴳ G₂ → K[ G₁ ]1 → K[ G₂ ]1
map {G₁ = G₁} {G₂ = G₂} h = rec λ where
    .is-groupoidʳ → is-groupoid
    .baseʳ        → base
    .loopʳ x      → loop (to x)
    .loop-idʳ     →
      loop (to G₁.id)  ≡⟨ cong loop (→ᴳ-id h) ⟩
      loop G₂.id       ≡⟨ loop-id ⟩∎
      refl _           ∎
    .loop-∘ʳ {x = x} {y = y} →
      loop (to (x G₁.∘ y))               ≡⟨ cong loop (h .homomorphic x y) ⟩
      loop (to x G₂.∘ to y)              ≡⟨ loop-∘ ⟩∎
      trans (loop (to x)) (loop (to y))  ∎
  where
  module G₁ = Group G₁
  module G₂ = Group G₂
  open Homomorphic h using (to)

-- If G₁ and G₂ are isomorphic groups, then K[ G₁ ]1 and K[ G₂ ]1 are
-- equivalent.

cong-≃ : G₁ ≃ᴳ G₂ → K[ G₁ ]1 ≃ K[ G₂ ]1
cong-≃ G₁≃G₂ = Eq.↔→≃
  (map (↝ᴳ→→ᴳ G₁≃G₂))
  (map (↝ᴳ→→ᴳ (≃ᴳ-sym G₁≃G₂)))
  (lemma (↝ᴳ→→ᴳ G₁≃G₂) (↝ᴳ→→ᴳ (≃ᴳ-sym G₁≃G₂))
     (_≃_.right-inverse-of (related G₁≃G₂)))
  (lemma (↝ᴳ→→ᴳ (≃ᴳ-sym G₁≃G₂)) (↝ᴳ→→ᴳ G₁≃G₂)
     (_≃_.left-inverse-of (related G₁≃G₂)))
  where
  open Homomorphic using (to)

  lemma :
    (f₁ : G₁ →ᴳ G₂) (f₂ : G₂ →ᴳ G₁) →
    (∀ x → to f₁ (to f₂ x) ≡ x) →
    ∀ x → map f₁ (map f₂ x) ≡ x
  lemma f₁ f₂ hyp = elim-set λ where
    .is-setʳ _ → is-groupoid
    .baseʳ     → refl _
    .loopʳ g   →
      subst (λ x → map f₁ (map f₂ x) ≡ x) (loop g) (refl _)          ≡⟨ subst-in-terms-of-trans-and-cong ⟩

      trans (sym $ cong (map f₁ ⊚ map f₂) (loop g))
        (trans (refl _) (cong P.id (loop g)))                        ≡⟨ cong₂ (trans ⊚ sym)
                                                                          (sym $ cong-∘ _ _ _)
                                                                          (trans (trans-reflˡ _) $
                                                                           sym $ cong-id _) ⟩

      trans (sym $ cong (map f₁) $ cong (map f₂) (loop g)) (loop g)  ≡⟨ cong (flip trans (loop g) ⊚ sym) $
                                                                        trans (cong (cong _) rec-loop)
                                                                        rec-loop ⟩

      trans (sym $ loop (to f₁ (to f₂ g))) (loop g)                  ≡⟨ cong (flip trans _ ⊚ sym ⊚ loop) $ hyp _ ⟩

      trans (sym $ loop g) (loop g)                                  ≡⟨ trans-symˡ _ ⟩∎

      refl _                                                         ∎

------------------------------------------------------------------------
-- A lemma

-- The pointed type (K[ G ]1 , base) is connected.
--
-- This result was pointed out to me by Christian Sattler.

connected : Connected (K[ G ]1 , base)
connected = elim-prop λ where
  .is-propositionʳ _ → TP.truncation-is-proposition
  .baseʳ             → TP.∣ refl _ ∣

------------------------------------------------------------------------
-- Some lemmas related to the fundamental group of (K[ G ]1 , base)

-- A variant of the fundamental group of (K[ G ]1 , base) is
-- isomorphic to G (assuming univalence).
--
-- The proof is based on the one given in "Eilenberg-MacLane Spaces in
-- Homotopy Type Theory" by Licata and Finster.

Fundamental-group′[K1]≃ᴳ :
  {G : Group g} →
  Univalence g →
  (s : Is-set (proj₁ (Ω (K[ G ]1 , base)))) →
  Fundamental-group′ (K[ G ]1 , base) s ≃ᴳ G
Fundamental-group′[K1]≃ᴳ {g = g} {G = G} univ _ = λ where
    .related     → equiv
    .homomorphic → hom
  where
  module FG = Group (Fundamental-group′ (K[ G ]1 , base) is-groupoid)
  open Group G

  -- Postcomposition is an equivalence.

  to-≃ : Carrier → Carrier ≃ Carrier
  to-≃ x = Eq.↔→≃
    (_∘ x)
    (_∘ x ⁻¹)
    (λ y →
       (y ∘ x ⁻¹) ∘ x  ≡⟨ sym $ assoc _ _ _ ⟩
       y ∘ (x ⁻¹ ∘ x)  ≡⟨ cong (y ∘_) $ left-inverse _ ⟩
       y ∘ id          ≡⟨ right-identity _ ⟩∎
       y               ∎)
    (λ y →
       (y ∘ x) ∘ x ⁻¹  ≡⟨ sym $ assoc _ _ _ ⟩
       y ∘ (x ∘ x ⁻¹)  ≡⟨ cong (y ∘_) $ right-inverse _ ⟩
       y ∘ id          ≡⟨ right-identity _ ⟩∎
       y               ∎)

  -- A family of codes.

  Code : K[ G ]1 → Set g
  Code = rec λ where
    .is-groupoidʳ → ∃-H-level-H-level-1+ ext univ 2
    .baseʳ        → Carrier , Carrier-is-set
    .loopʳ x      → Σ-≡,≡→≡ (≃⇒≡ univ (to-≃ x))
                      (H-level-propositional ext 2 _ _)
    .loop-idʳ     →
      Σ-≡,≡→≡ (≃⇒≡ univ (to-≃ id)) _     ≡⟨ _≃_.from (Eq.≃-≡ $ Eq.↔⇒≃ B.Σ-≡,≡↔≡) $
                                            Σ-≡,≡→≡
                                              (
          ≃⇒≡ univ (to-≃ id)                   ≡⟨ cong (≃⇒≡ univ) $ Eq.lift-equality ext $ ⟨ext⟩
                                                  right-identity ⟩
          ≃⇒≡ univ Eq.id                       ≡⟨ ≃⇒≡-id univ ⟩∎
          refl _                               ∎)
                                              (H-level.⇒≡ 1 (H-level-propositional ext 2) _ _) ⟩

      Σ-≡,≡→≡ (refl _) (subst-refl _ _)  ≡⟨ Σ-≡,≡→≡-refl-subst-refl ⟩∎

      refl _                             ∎
    .loop-∘ʳ {x = x} {y = y} →
      Σ-≡,≡→≡ (≃⇒≡ univ (to-≃ (x ∘ y))) _                        ≡⟨ _≃_.from (Eq.≃-≡ $ Eq.↔⇒≃ B.Σ-≡,≡↔≡) $
                                                                    Σ-≡,≡→≡
                                                                      (
          ≃⇒≡ univ (to-≃ (x ∘ y))                                      ≡⟨ (cong (≃⇒≡ univ) $ Eq.lift-equality ext $ ⟨ext⟩ λ _ →
                                                                           assoc _ _ _) ⟩
          ≃⇒≡ univ (to-≃ y Eq.∘ to-≃ x)                                ≡⟨ ≃⇒≡-∘ univ ext _ _ ⟩∎
          trans (≃⇒≡ univ (to-≃ x)) (≃⇒≡ univ (to-≃ y))                ∎)
                                                                      (H-level.⇒≡ 1 (H-level-propositional ext 2) _ _) ⟩

      Σ-≡,≡→≡ (trans (≃⇒≡ univ (to-≃ x)) (≃⇒≡ univ (to-≃ y))) _  ≡⟨ sym $ trans-Σ-≡,≡→≡ _ _ _ _ ⟩∎

      trans (Σ-≡,≡→≡ (≃⇒≡ univ (to-≃ x)) _)
        (Σ-≡,≡→≡ (≃⇒≡ univ (to-≃ y)) _)                          ∎

  -- Some "computation" rules.

  ≡⇒≃-cong-Code-loop :
    ≡⇒≃ (cong (proj₁ ⊚ Code) (loop x)) ≡ to-≃ x
  ≡⇒≃-cong-Code-loop {x = x} =
    ≡⇒≃ (cong (proj₁ ⊚ Code) (loop x))         ≡⟨ cong ≡⇒≃ $ sym $ cong-∘ proj₁ Code (loop x) ⟩

    ≡⇒≃ (cong proj₁ (cong Code (loop x)))      ≡⟨ cong (≡⇒≃ ⊚ cong proj₁) rec-loop ⟩

    ≡⇒≃ (cong proj₁ $
         Σ-≡,≡→≡ (≃⇒≡ univ (to-≃ x))
           (H-level-propositional ext 2 _ _))  ≡⟨ cong ≡⇒≃ $ proj₁-Σ-≡,≡→≡ _ _ ⟩

    ≡⇒≃ (≃⇒≡ univ (to-≃ x))                    ≡⟨ _≃_.right-inverse-of (≡≃≃ univ) _ ⟩∎

    to-≃ x                                     ∎

  subst-Code-loop :
    subst (proj₁ ⊚ Code) (loop x) ≡ _∘ x
  subst-Code-loop {x = x} = ⟨ext⟩ λ y →
    subst (proj₁ ⊚ Code) (loop x) y                ≡⟨ subst-in-terms-of-≡⇒↝ equivalence _ _ _ ⟩
    _≃_.to (≡⇒≃ (cong (proj₁ ⊚ Code) (loop x))) y  ≡⟨ cong (λ eq → _≃_.to eq y) ≡⇒≃-cong-Code-loop ⟩∎
    _≃_.to (to-≃ x) y                              ∎

  subst-Code-sym-loop :
    subst (proj₁ ⊚ Code) (sym (loop x)) ≡ _∘ x ⁻¹
  subst-Code-sym-loop {x = x} = ⟨ext⟩ λ y →
    subst (proj₁ ⊚ Code) (sym (loop x)) y            ≡⟨ subst-in-terms-of-inverse∘≡⇒↝ equivalence _ _ _ ⟩
    _≃_.from (≡⇒≃ (cong (proj₁ ⊚ Code) (loop x))) y  ≡⟨ cong (λ eq → _≃_.from eq y) ≡⇒≃-cong-Code-loop ⟩∎
    _≃_.from (to-≃ x) y                              ∎

  -- An equivalence.

  to : base ≡ x → proj₁ (Code x)
  to eq = subst (proj₁ ⊚ Code) eq id

  from : ∀ x → proj₁ (Code x) → base ≡ x
  from = elim-set λ where
    .is-setʳ _ → Π-closure ext 2 λ _ →
                 is-groupoid
    .baseʳ     → loop
    .loopʳ x   → ⟨ext⟩ λ y →
      subst (λ x → proj₁ (Code x) → base ≡ x) (loop x) loop y        ≡⟨ subst-→ ⟩

      subst (base ≡_) (loop x)
        (loop (subst (proj₁ ⊚ Code) (sym (loop x)) y))               ≡⟨ sym trans-subst ⟩

      trans (loop (subst (proj₁ ⊚ Code) (sym (loop x)) y)) (loop x)  ≡⟨ cong (flip trans (loop x) ⊚ loop ⊚ (_$ y))
                                                                        subst-Code-sym-loop ⟩

      trans (loop (y ∘ x ⁻¹)) (loop x)                               ≡⟨ cong (flip trans _) loop-∘ ⟩

      trans (trans (loop y) (loop (x ⁻¹))) (loop x)                  ≡⟨ trans-assoc _ _ _ ⟩

      trans (loop y) (trans (loop (x ⁻¹)) (loop x))                  ≡⟨ cong (trans _) $ sym loop-∘ ⟩

      trans (loop y) (loop (x ⁻¹ ∘ x))                               ≡⟨ cong (trans (loop y) ⊚ loop) $ left-inverse _ ⟩

      trans (loop y) (loop id)                                       ≡⟨ cong (trans _) loop-id ⟩

      trans (loop y) (refl base)                                     ≡⟨ trans-reflʳ _ ⟩∎

      loop y                                                         ∎

  to-loop : ∀ x → to (loop x) ≡ x
  to-loop x =
    subst (proj₁ ⊚ Code) (loop x) id  ≡⟨ cong (_$ id) subst-Code-loop ⟩
    id ∘ x                            ≡⟨ left-identity _ ⟩∎
    x                                 ∎

  from-to : ∀ eq → from x (to eq) ≡ eq
  from-to = elim¹ (λ {x} eq → from x (to eq) ≡ eq)
    (loop (subst (proj₁ ⊚ Code) (refl base) id)  ≡⟨ cong loop $ subst-refl _ _ ⟩
     loop id                                     ≡⟨ loop-id ⟩∎
     refl base                                   ∎)

  equiv : proj₁ (Ω (K[ G ]1 , base)) ≃ Carrier
  equiv =
    base ≡ base  ↝⟨ Eq.↔→≃ to loop to-loop from-to ⟩□
    Carrier      □

  -- The equivalence is homomorphic.

  hom′ :
    ∀ x y →
    _≃_.from equiv (x ∘ y) ≡
    _≃_.from equiv x FG.∘ _≃_.from equiv y
  hom′ x y =
    loop (x ∘ y)             ≡⟨ loop-∘ ⟩∎
    trans (loop x) (loop y)  ∎

  hom :
    ∀ p q →
    _≃_.to equiv (p FG.∘ q) ≡
    _≃_.to equiv p ∘ _≃_.to equiv q
  hom p q = _≃_.from-to equiv
    (_≃_.from equiv (_≃_.to equiv p ∘ _≃_.to equiv q)  ≡⟨ hom′ _ _ ⟩

     _≃_.from equiv (_≃_.to equiv p) FG.∘
     _≃_.from equiv (_≃_.to equiv q)                   ≡⟨ cong₂ FG._∘_
                                                            (_≃_.left-inverse-of equiv p)
                                                            (_≃_.left-inverse-of equiv q) ⟩∎
     p FG.∘ q                                          ∎)

-- The right-to-left direction of Fundamental-group′[K1]≃ᴳ is loop.

_ :
  {G : Group g} {univ : Univalence g} {s : Is-set _} →
  _≃_.from (Fundamental-group′[K1]≃ᴳ {G = G} univ s .related) ≡
  loop
_ = refl _

-- The fundamental group of (K[ G ]1 , base) is isomorphic to G
-- (assuming univalence).
--
-- The proof is based on the one given in "Eilenberg-MacLane Spaces in
-- Homotopy Type Theory" by Licata and Finster.

Fundamental-group[K1]≃ᴳ :
  {G : Group g} →
  Univalence g →
  Fundamental-group (K[ G ]1 , base) ≃ᴳ G
Fundamental-group[K1]≃ᴳ univ =
  ↝ᴳ-trans (≃ᴳ-sym Homotopy-group-[1+]′≃ᴳHomotopy-group-[1+])
    (Fundamental-group′[K1]≃ᴳ univ is-groupoid)

-- If G is abelian, then the fundamental group of (K[ G ]1 , base) is
-- abelian.

Abelian→Abelian-Fundamental-group′ :
  Abelian G → Abelian (Fundamental-group′ (K[ G ]1 , base) is-groupoid)
Abelian→Abelian-Fundamental-group′ {G = G} abelian =
  flip $ EG.Transitivity-commutative.commutative base _∙_ ∙-base base-∙
  where
  open Group G

  lemma : Carrier → (x : K[ G ]1) → x ≡ x
  lemma g₁ = elim-set λ where
    .is-setʳ  → λ _ → is-groupoid
    .baseʳ    → loop g₁
    .loopʳ g₂ → ≡⇒↝ _ (sym [subst≡]≡[trans≡trans])
      (trans (loop g₁) (loop g₂)  ≡⟨ sym loop-∘ ⟩
       loop (g₁ ∘ g₂)             ≡⟨ cong loop (abelian g₁ g₂) ⟩
       loop (g₂ ∘ g₁)             ≡⟨ loop-∘ ⟩∎
       trans (loop g₂) (loop g₁)  ∎)

  lemma-id : ∀ x → lemma id x ≡ refl x
  lemma-id = elim-prop λ where
    .is-propositionʳ _ → is-groupoid
    .baseʳ →
      loop id    ≡⟨ loop-id ⟩∎
      refl base  ∎

  lemma-∘ :
    ∀ g₁ g₂ x → lemma (g₁ ∘ g₂) x ≡ trans (lemma g₁ x) (lemma g₂ x)
  lemma-∘ g₁ g₂ = elim-prop λ where
    .is-propositionʳ _ → is-groupoid
    .baseʳ →
      loop (g₁ ∘ g₂)             ≡⟨ loop-∘ ⟩∎
      trans (loop g₁) (loop g₂)  ∎

  _∙_ : K[ G ]1 → K[ G ]1 → K[ G ]1
  _∙_ x = rec λ where
    .is-groupoidʳ → is-groupoid
    .baseʳ    → x
    .loopʳ g  → lemma g x
    .loop-idʳ → lemma-id x
    .loop-∘ʳ  → lemma-∘ _ _ x

  base-∙ : ∀ x → x ∙ base ≡ x
  base-∙ _ = refl _

  ∙-base : ∀ y → base ∙ y ≡ y
  ∙-base = elim-set λ where
    .is-setʳ _ → is-groupoid
    .baseʳ     → refl _
    .loopʳ y   →
      subst (λ y → base ∙ y ≡ y) (loop y) (refl _)    ≡⟨ subst-in-terms-of-trans-and-cong ⟩

      trans (sym (cong (base ∙_) (loop y)))
        (trans (refl _) (cong P.id (loop y)))         ≡⟨ cong (trans _) $
                                                         trans (trans-reflˡ _) $
                                                         sym $ cong-id _ ⟩

      trans (sym (cong (base ∙_) (loop y))) (loop y)  ≡⟨ cong (flip trans (loop y) ⊚ sym) $
                                                         rec-loop ⟩

      trans (sym (loop y)) (loop y)                   ≡⟨ trans-symˡ _ ⟩∎

      refl _                                          ∎

-- If P is a groupoid, then there is a based embedding from
-- (K[ Fundamental-group′ P s ]1 , base) to P (assuming univalence).
--
-- Christian Sattler showed me a similar proof of this result.

K[Fundamental-group′]1↣ᴮ :
  {P : Pointed-type p} {s : Is-set (proj₁ (Ω P))} →
  Univalence p →
  H-level 3 (proj₁ P) →
  (K[ Fundamental-group′ P s ]1 , base) ↝[ embedding ]ᴮ P
K[Fundamental-group′]1↣ᴮ {P = P@(A , a)} {s = s} univ g =
  record { to = to; is-embedding = emb } , refl _
  where
  to : K[ Fundamental-group′ P s ]1 → A
  to = rec λ where
    .baseʳ        → a
    .loopʳ        → P.id
    .loop-idʳ     → refl _
    .loop-∘ʳ      → refl _
    .is-groupoidʳ → g

  iso :
    Fundamental-group′ P s ≃ᴳ
    Fundamental-group′ (K[ Fundamental-group′ P s ]1 , base) is-groupoid
  iso = ≃ᴳ-sym $ Fundamental-group′[K1]≃ᴳ univ is-groupoid

  cong-to-iso : cong to ⊚ Homomorphic.to iso ≡ P.id
  cong-to-iso = ⟨ext⟩ λ eq →
    cong to (loop eq)  ≡⟨ rec-loop ⟩∎
    eq                 ∎

  cong-to-equivalence :
    Eq.Is-equivalence (cong {x = base} {y = base} to)
  cong-to-equivalence = Eq.Two-out-of-three.g∘f-f
    (Eq.two-out-of-three _ _)
    (Is-equivalence-cong _ (ext⁻¹ (sym cong-to-iso))
       (_≃_.is-equivalence Eq.id))
    (_≃_.is-equivalence (iso .related))

  emb : Is-embedding to
  emb = elim-prop λ where
    .is-propositionʳ _ →
      Π-closure ext 1 λ _ →
      Eq.propositional ext _
    .baseʳ → elim-prop λ where
      .is-propositionʳ _ → Eq.propositional ext _
      .baseʳ             → cong-to-equivalence

-- If P is a connected groupoid, then there is a based equivalence
-- from (K[ Fundamental-group′ P s ]1 , base) to P (assuming
-- univalence).
--
-- Christian Sattler showed me a similar proof of this result.

K[Fundamental-group′]1≃ᴮ :
  {P : Pointed-type p} {s : Is-set (proj₁ (Ω P))} →
  Univalence p →
  H-level 3 (proj₁ P) →
  Connected P →
  (K[ Fundamental-group′ P s ]1 , base) ≃ᴮ P
K[Fundamental-group′]1≃ᴮ {P = P@(A , a)} {s = s} univ g conn =
    Eq.⟨ Embedding.to (proj₁ f)
       , _≃_.to TP.surjective×embedding≃equivalence
           (surj , Embedding.is-embedding (proj₁ f)) ⟩
  , proj₂ f
  where
  f = K[Fundamental-group′]1↣ᴮ univ g

  surj : Surjective (Embedding.to (proj₁ f))
  surj x = flip TP.∥∥-map (conn x) λ a≡x →
      base
    , (Embedding.to (proj₁ f) base  ≡⟨⟩
       a                            ≡⟨ a≡x ⟩∎
       x                            ∎)

------------------------------------------------------------------------
-- Another result related to a fundamental group

-- If G is abelian, then the fundamental group of
-- (K[ G ]1 ≃ K[ G ]1 , Eq.id) is isomorphic to G (assuming
-- univalence).
--
-- I was informed of a related result by Christian Sattler.

Fundamental-group′[K1≃K1]≃ᴳ :
  {G : Group g} {s : Is-set _} →
  Univalence g →
  Abelian G →
  Fundamental-group′ ((K[ G ]1 ≃ K[ G ]1) , Eq.id) s ≃ᴳ G
Fundamental-group′[K1≃K1]≃ᴳ {G = G} univ abelian = λ where
    .related →
      _≡_ {A = K[ G ]1 ≃ K[ G ]1} Eq.id Eq.id  ↝⟨ inverse $ ≃-to-≡≃≡ ext ext ⟩
      ((x : K[ G ]1) → x ≡ x)                  ↝⟨ Eq.↔→≃ to from to-from from-to ⟩□
      Carrier                                  □
    .homomorphic p q →
      Homomorphic.to iso (cong (λ eq → _≃_.to eq base) (trans p q))  ≡⟨ cong (Homomorphic.to iso) $
                                                                        cong-trans _ _ _ ⟩
      Homomorphic.to iso
        (trans (cong (λ eq → _≃_.to eq base) p)
               (cong (λ eq → _≃_.to eq base) q))                     ≡⟨ Homomorphic.homomorphic iso _ _ ⟩∎

      Homomorphic.to iso (cong (λ eq → _≃_.to eq base) p) ∘
      Homomorphic.to iso (cong (λ eq → _≃_.to eq base) q)            ∎
  where
  open Group G

  iso = Fundamental-group′[K1]≃ᴳ {G = G} univ is-groupoid

  to : ((x : K[ G ]1) → x ≡ x) → Carrier
  to f = Homomorphic.to iso (f base)

  from : Carrier → (x : K[ G ]1) → x ≡ x
  from x = elim-set λ where
    .is-setʳ _ → is-groupoid
    .baseʳ     → loop x
    .loopʳ y   → ≡⇒↝ _ (sym [subst≡]≡[trans≡trans])
      (trans (loop x) (loop y)  ≡⟨ sym loop-∘ ⟩
       loop (x ∘ y)             ≡⟨ cong loop $ abelian x y ⟩
       loop (y ∘ x)             ≡⟨ loop-∘ ⟩∎
       trans (loop y) (loop x)  ∎)

  to-from : ∀ p → to (from p) ≡ p
  to-from x =
    Homomorphic.to iso (loop x)  ≡⟨ _≃_.right-inverse-of (Homomorphic.related iso) _ ⟩∎
    x                            ∎

  from-to : ∀ f → from (to f) ≡ f
  from-to f = ⟨ext⟩ $ elim-prop λ where
    .is-propositionʳ _ → is-groupoid
    .baseʳ             →
      loop (Homomorphic.to iso (f base))  ≡⟨ _≃_.left-inverse-of (Homomorphic.related iso) _ ⟩∎
      f base                              ∎


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

module Categories.Diagram.End.Properties where

open import Level
open import Data.Product using (Σ; _,_)
open import Function using (_$_)

open import Categories.Category
open import Categories.Category.Product
open import Categories.Category.Construction.Functors
open import Categories.Category.Construction.TwistedArrow
open import Categories.Category.Equivalence
open import Categories.Category.Equivalence.Preserves
open import Categories.Diagram.Cone
open import Categories.Diagram.End as ∫
open import Categories.Diagram.Limit
open import Categories.Diagram.Wedge
open import Categories.Diagram.Wedge.Properties
open import Categories.Functor hiding (id)
open import Categories.Functor.Bifunctor
open import Categories.Functor.Instance.Twisted
import Categories.Morphism as M
open import Categories.NaturalTransformation hiding (id)
open import Categories.NaturalTransformation.Dinatural
open import Categories.Object.Terminal as Terminal

import Categories.Category.Construction.Wedges as Wedges
open import Categories.Object.Terminal

import Categories.Morphism.Reasoning as MR

private
  variable
    o ℓ e : Level
    C D E : Category o ℓ e

module _ {o ℓ e o′ ℓ′ e′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′}
  (F : Bifunctor (Category.op C) C D) where
  open Wedges F

  -- Being an End is the same as being a Terminal object in the category of Wedges
  End⇒Terminal : End F → Terminal Wedges
  End⇒Terminal c =  record
    { ⊤ = wedge
    ; ⊤-is-terminal = record
      { ! = λ {A} → record { u = factor A ; commute = universal }
      ; !-unique = λ {A} f → unique {A} (Wedge-Morphism.commute f)
      }
    }
    where
    open End c

  Terminal⇒End : Terminal Wedges → End F
  Terminal⇒End i = record
    { wedge = ⊤
    ; factor = λ W → u {W₁ = W} !
    ; universal = commute !
    ; unique = λ {_} {g} x → !-unique (record { u = g ; commute = x })
    }
    where
    open Terminal.Terminal i
    open Wedge-Morphism

module _ {C : Category o ℓ e}
         (F : Functor E (Functors (Product (Category.op C) C) D)) where
  private
    module C = Category C
    module D = Category D
    module E = Category E
    module NT = NaturalTransformation
  open D
  open HomReasoning

  open MR D
  open Functor F
  open End hiding (E)
  open NT using (η)

  EndF : (∀ X → End (F₀ X)) → Functor E D
  EndF end = record
    { F₀           = λ X → End.E (end X)
    ; F₁           = F₁′
    ; identity     = λ {A} → unique (end A) (id-comm ○ ∘-resp-≈ˡ (⟺ identity))
    ; homomorphism = λ {A B C} {f g} → unique (end C) $ λ {Z} → begin
      dinatural.α (end C) Z ∘ F₁′ g ∘ F₁′ f                       ≈⟨ pullˡ (universal (end C)) ⟩
      (η (F₁ g) (Z , Z) ∘ dinatural.α (end B) Z) ∘ F₁′ f          ≈⟨ pullʳ (universal (end B)) ⟩
      η (F₁ g) (Z , Z) ∘ η (F₁ f) (Z , Z) ∘ dinatural.α (end A) Z ≈˘⟨ pushˡ homomorphism ⟩
      η (F₁ (g E.∘ f)) (Z , Z) ∘ dinatural.α (end A) Z            ∎
    ; F-resp-≈     = λ {A B f g} eq → unique (end B) $ λ {Z} → begin
      dinatural.α (end B) Z ∘ F₁′ g                               ≈⟨ universal (end B) ⟩
      η (F₁ g) (Z , Z) ∘ dinatural.α (end A) Z                    ≈˘⟨ F-resp-≈ eq ⟩∘⟨refl ⟩
      η (F₁ f) (Z , Z) ∘ dinatural.α (end A) Z                    ∎
    }
    where F₁′ : ∀ {X Y} → X E.⇒ Y → End.E (end X) ⇒ End.E (end Y)
          F₁′ {X} {Y} f = factor (end Y) $ record
            { E         = End.E (end X)
            ; dinatural = F₁ f <∘ dinatural (end X)
            }

-- A Natural Transformation between two functors induces an arrow between the
-- (object part of) the respective ends.
module _ {P Q : Functor (Product (Category.op C) C) D} (P⇒Q : NaturalTransformation P Q) where
  open End renaming (E to end)
  open Category D

  end-η : {ep : End P} {eq : End Q} → end ep ⇒ end eq
  end-η {ep} {eq} = factor eq (record
    { E = End.E ep
    ; dinatural = dtHelper record
      { α = λ c → η (c , c) ∘ dinatural.α ep c
      ; commute = λ {C} {C′} f → begin
        Q.₁ (C.id , f) ∘ (η (C , C) ∘ αp C) ∘ D.id       ≈⟨ pullˡ sym-assoc ⟩
        ((Q.₁ (C.id , f) ∘ η (C , C)) ∘ αp C) ∘ D.id     ≈⟨ (nt.sym-commute (C.id , f) ⟩∘⟨refl ⟩∘⟨refl) ⟩
        ((η (C , C′) ∘ P.₁ (C.id , f)) ∘ αp C) ∘ D.id    ≈⟨ assoc² ⟩
        η (C , C′) ∘ (P.₁ (C.id , f) ∘ αp C ∘ D.id)      ≈⟨ (refl⟩∘⟨ αp-comm f) ⟩
        η (C , C′) ∘ P.₁ (f , C.id) ∘ αp C′ ∘ D.id       ≈˘⟨ assoc² ⟩
        ((η (C , C′) ∘ P.₁ (f , C.id)) ∘ αp C′) ∘ D.id   ≈⟨ (nt.commute (f , C.id) ⟩∘⟨refl ⟩∘⟨refl) ⟩
        ((Q.₁ (f , C.id) ∘ η (C′ , C′)) ∘ αp C′) ∘ D.id  ≈⟨ pushˡ assoc ⟩
        Q.₁ (f , C.id) ∘ (η (C′ , C′) ∘ αp C′) ∘ D.id    ∎
      }
    })
    where
    module nt = NaturalTransformation P⇒Q
    open nt using (η)
    open HomReasoning
    module C = Category C
    module D = Category D
    module P = Functor P
    module Q = Functor Q
    open DinaturalTransformation (dinatural ep) renaming (α to αp; commute to αp-comm)
    open DinaturalTransformation (dinatural eq) renaming (α to αq; commute to αq-comm)
    open Wedge
    open MR D

-- The real start of the End Calculus. Maybe need to move such properties elsewhere?
-- This is an unpacking of the lhs of Eq. (25) of Loregian's book.
module _ {o ℓ e o′ ℓ′ e′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′}
  (F : Bifunctor (Category.op C) C D) where
  private
    Eq = ConesTwist≅Wedges F
    module O = M D
  open M (Wedges.Wedges F)
  open Functor

  open StrongEquivalence Eq renaming (F to F⇒)

  -- Ends and Limits are equivalent, in the category Wedge F
  End-as-Limit : (end : End F) → (l : Limit (Twist C D F)) → End.wedge end ≅ F₀ F⇒ (Limit.terminal.⊤ l)
  End-as-Limit end l = Terminal.up-to-iso (Wedges.Wedges F) (End⇒Terminal F end) (pres-Terminal Eq terminal)
    where
    open Limit l

  -- Which then induces that the objects, in D, are also equivalent.
  End-as-Limit-on-Obj : (end : End F) → (l : Limit (Twist C D F)) → End.E end O.≅ Limit.apex l
  End-as-Limit-on-Obj end l = record
    { from = Wedge-Morphism.u (M._≅_.from X≅Y)
    ; to = Wedge-Morphism.u (M._≅_.to X≅Y)
    ; iso = record
      { isoˡ = M._≅_.isoˡ X≅Y
      ; isoʳ = M._≅_.isoʳ X≅Y
      }
    }
    where
      X≅Y = End-as-Limit end l
      open Category D


module Data.Vec.Membership.Propositional.Distinct where

open import Data.Vec as Vec using (Vec; [];  _∷_; _++_)

open import Data.Vec.Membership.Propositional
open import Data.Vec.Any hiding (map; index; head; tail)
open import Data.List as List using (List)
open import Relation.Binary.PropositionalEquality as P using (_≡_; _≢_; _≗_ )
open import Relation.Binary.HeterogeneousEquality as H using (_≅_; _≇_)
import Data.List.Membership.Propositional.Distinct as ListDistinct
open import Data.Product as Prod hiding (map)
open import Data.Sum     hiding (map)
open import Data.Empty   using (⊥-elim)
open import Relation.Nullary
open import Data.Fin as Fin
open import Data.Fin.Properties using (suc-injective)
open import Data.Nat as ℕ
open import Function using (_∘_)
open import Function.Equivalence using (_⇔_; equivalence)
open import Function.Equality as F using (_⟨$⟩_)
open import Function.Injection using (_↣_; Injection)

data Distinct {a}{A : Set a} : ∀ {n} → Vec A n → Set a where
  distinct-[] : Distinct []
  _distinct-∷_by_ : ∀ {n} x {xs : Vec A n} → Distinct xs → x ∉ xs → Distinct (x ∷ xs)

head : ∀ {a}{A : Set a} {n} {x}{xs : Vec A n} → Distinct (x ∷ xs) → A
head (x distinct-∷ _ by _) = x

tail : ∀ {a}{A : Set a} {n} {x}{xs : Vec A n} → Distinct (x ∷ xs) → Distinct xs
tail (_ distinct-∷ dis by _) = dis

head∉tail : ∀ {a}{A : Set a} {n} {x}{xs : Vec A n} → Distinct (x ∷ xs) → x ∉ xs
head∉tail (_ distinct-∷ _ by x∉xs) = x∉xs

[_] : ∀{a}{A : Set a}(x : A) → Distinct Vec.[ x ]
[ x ] = x distinct-∷ distinct-[] by (λ ())

{-
_distinct-∷ʳ_by_ : ∀ {a}{A : Set a} {n} {xs : Vec A n} → Distinct xs → (x : A) → x ∉ xs → Distinct (xs Vec.∷ʳ x)
distinct-[] distinct-∷ʳ x by x∉xs = x distinct-∷ distinct-[] by x∉xs
(y distinct-∷ dxs by y∉xs) distinct-∷ʳ x by x∉yxs = y distinct-∷ dxs distinct-∷ʳ x by (x∉yxs ∘ there) by lemma y∉xs x∉yxs
  where
    lemma : ∀ {a}{A : Set a} {n} {xs : Vec A n} {x y} → y ∉ xs → x ∉ y Vec.∷ xs → y ∉ xs Vec.∷ʳ x
    lemma {xs = []} y∉xs x∉y∷xs (here P.refl) = x∉y∷xs (here P.refl)
    lemma {xs = []} y∉xs x∉y∷xs (there ())
    lemma {xs = _ ∷ xs} y∉xs x∉y∷xs (here P.refl) = y∉xs (here P.refl)
    lemma {xs = x₁ ∷ xs}{x}{y} y∉xs x∉y∷xs (there y∈xs∷ʳx) = {!!}
-}
initLast : ∀ {a n} {A : Set a}{xs : Vec A (suc n)} → Distinct xs →
  let (ys , y , xs≡ysy) = Vec.initLast xs in Distinct ys × y ∉ ys
initLast {n = zero} {xs = x ∷ []} (.x distinct-∷ distinct-[] by x∉[]) = distinct-[] , x∉[]
initLast {n = suc n} {xs = x ∷ xs} (.x distinct-∷ dxs by x∉xs) with Vec.initLast xs | initLast dxs
initLast {_} {suc n} {_} {x ∷ .(ys Vec.∷ʳ y)} (.x distinct-∷ dxs by x∉xs) | ys , y , P.refl | dys , y∉ys =
             x distinct-∷ dys by (x∉xs ∘ ∈-∷ʳ) , λ { (here P.refl) → x∉xs (∷ʳ-∈ y ys)
                                                  ; ( there p) → y∉ys p }
         where
           ∈-∷ʳ : ∀ {a n} {A : Set a}{xs : Vec A n}{x y} → x ∈ xs → x ∈ xs Vec.∷ʳ y
           ∈-∷ʳ {xs = []} ()
           ∈-∷ʳ {xs = x ∷ xs} (here eq) = here eq
           ∈-∷ʳ {xs = x ∷ xs} (there x∈xs) = there (∈-∷ʳ x∈xs)
           ∷ʳ-∈ : ∀ {a n} {A : Set a} x (xs : Vec A n) → x ∈ xs Vec.∷ʳ x
           ∷ʳ-∈ x [] = here P.refl
           ∷ʳ-∈ x (y ∷ xs) = there (∷ʳ-∈ x xs)

private
  initLast₁≡init  : ∀ {a n} {A : Set a}(xs : Vec A (suc n)) → proj₁ (Vec.initLast xs) ≡ Vec.init xs
  initLast₁≡init xs with Vec.initLast xs
  initLast₁≡init .(ys Vec.∷ʳ y) | ys , y , P.refl = P.refl

  initLast₂≡last  : ∀ {a n} {A : Set a}(xs : Vec A (suc n)) → proj₁ (proj₂ (Vec.initLast xs)) ≡ Vec.last xs
  initLast₂≡last xs with Vec.initLast xs
  initLast₂≡last .(ys Vec.∷ʳ y) | ys , y , P.refl = P.refl

init : ∀ {a n} {A : Set a}{xs : Vec A (suc n)} → Distinct xs → Distinct (Vec.init xs)
init {xs = xs} dxs with initLast dxs
... | dys , y∉ys rewrite initLast₁≡init xs = dys

last : ∀ {a n} {A : Set a}{xs : Vec A (suc n)} → Distinct xs → Vec.last xs ∉ Vec.init xs
last {xs = xs} dxs with initLast dxs
... | dys , y∉ys rewrite initLast₁≡init xs | initLast₂≡last xs = y∉ys

map : ∀ {a b}{A : Set a}{B : Set b} → (f : A ↣ B) → ∀ {n}{xs : Vec A n} → Distinct xs → Distinct (Vec.map (Injection.to f ⟨$⟩_) xs)
map f {0}{[]} distinct-[] = distinct-[]
map {A = A} f {ℕ.suc _} {x ∷ xs} (.x distinct-∷ dis by x∉xs) = fx distinct-∷ map f dis by fx∉mapfxs
    where

      fx = Injection.to f ⟨$⟩ x
      -- missing
      ∈-map⁻ : ∀{a b}{A : Set a}{B : Set b}(f : A → B){m}{xs : Vec A m}{y} →
        y ∈ Vec.map f xs → ∃ λ x → x ∈ xs × y ≡ f x
      ∈-map⁻ f {xs = []} ()
      ∈-map⁻ f {xs = x ∷ xs} (here P.refl) = x , here P.refl , P.refl
      ∈-map⁻ f {xs = x ∷ xs} (there y∈mapfxs) with ∈-map⁻ _ y∈mapfxs
      ... | v , v∈xs , eq = v , there v∈xs , eq

      fx∉mapfxs : fx ∉ Vec.map (Injection.to f ⟨$⟩_) xs
      fx∉mapfxs fx∈mapfxs with ∈-map⁻ _ fx∈mapfxs
      ... | v , v∈xs , fx≡fv with Injection.injective f fx≡fv
      fx∉mapfxs fx∈mapfxs | v , v∈xs , fx≡fv | P.refl = x∉xs v∈xs

private
  injection : ∀ {a b}{A : Set a}{B : Set b} {f : A → B} → (∀ {x y} → f x ≡ f y → x ≡ y) → A ↣ B
  Injection.to (injection {f = f} inj) = P.→-to-⟶ f
  Injection.injective (injection inj) = inj

tabulate : ∀ {a}{A : Set a}{n} → (f : Fin n ↣ A) → Distinct (Vec.tabulate (Injection.to f ⟨$⟩_))
tabulate {n = zero} f = distinct-[]
tabulate {n = suc n} f = (Injection.to f ⟨$⟩ zero) distinct-∷ tabulate (f ⟨∘⟩ injection suc-injective) by lemma
  where
    open import Function.Injection using () renaming (_∘_ to _⟨∘⟩_)
    open import Data.Vec.Membership.Propositional.Properties
    ∈-tabulateˡ : ∀ {a}{A : Set a}{n}{x}(f : Fin n → A) → x ∈ Vec.tabulate f →
      ∃ λ i → x ≡ f i
    ∈-tabulateˡ {n = zero} f ()
    ∈-tabulateˡ {n = suc n} f (here P.refl) = _ , P.refl
    ∈-tabulateˡ {n = suc n} f (there x∈tabf) with ∈-tabulateˡ _ x∈tabf
    ... | i , eq = suc i , eq

    lemma : (Injection.to f ⟨$⟩ zero) ∉ Vec.tabulate ((Injection.to f ⟨$⟩_) ∘ Fin.suc)
    lemma p with ∈-tabulateˡ _ p
    lemma p | i , fi≡f0 with Injection.injective f fi≡f0
    lemma p | i , fi≡f0 | ()

allFin : ∀ n → Distinct (Vec.allFin n)
allFin n = tabulate ⟨id⟩
  where
    open import Function.Injection using () renaming (id to ⟨id⟩)

private
  ∈-zipˡ : ∀ {a b n}{A : Set a}{B : Set b}{xs : Vec A n}{ys : Vec B n} {x y} →
    (x , y) ∈ Vec.zip xs ys → x ∈ xs
  ∈-zipˡ {xs = []} {[]} ()
  ∈-zipˡ {xs = x ∷ xs} {y ∷ ys} (here P.refl) = here P.refl
  ∈-zipˡ {xs = x ∷ xs} {y ∷ ys} (there p) = there (∈-zipˡ p)

  ∈-zipʳ : ∀ {a b n}{A : Set a}{B : Set b}{xs : Vec A n}{ys : Vec B n} {x y} →
    (x , y) ∈ Vec.zip xs ys → y ∈ ys
  ∈-zipʳ {xs = []} {[]} ()
  ∈-zipʳ {xs = x ∷ xs} {y ∷ ys} (here P.refl) = here P.refl
  ∈-zipʳ {xs = x ∷ xs} {y ∷ ys} (there p) = there (∈-zipʳ p)

zipˡ : ∀ {a b n}{A : Set a}{B : Set b}{xs : Vec A n} →
     Distinct xs → (ys : Vec B n) → Distinct (Vec.zip xs ys)
zipˡ distinct-[] [] = distinct-[]
zipˡ (x distinct-∷ dxs by x∉xs) (y ∷ ys) = (x , y) distinct-∷ zipˡ dxs ys
  by λ p → x∉xs (∈-zipˡ p)

zipʳ : ∀ {a b n}{A : Set a}{B : Set b}(xs : Vec A n){ys : Vec B n} →
  Distinct ys → Distinct (Vec.zip xs ys)
zipʳ [] distinct-[] = distinct-[]
zipʳ (x ∷ xs) (y distinct-∷ dys by y∉ys) = (x , y) distinct-∷ zipʳ xs dys
  by λ p → y∉ys (∈-zipʳ p)

toList : ∀ {a n}{A : Set a}{xs : Vec A n} → Distinct xs → ListDistinct.Distinct (Vec.toList xs)
toList distinct-[] = ListDistinct.distinct-[]
toList (x distinct-∷ dxs by x∉xs) = x ListDistinct.distinct-∷ toList dxs
  by λ x∈xs → x∉xs (lemma x∈xs)
  where
    import Data.List.Membership.Propositional as ListMem
    import Data.List.Any as ListAny
    lemma : ∀ {a n}{A : Set a}{x}{xs : Vec A n} → x ListMem.∈ Vec.toList xs → x ∈ xs
    lemma {xs = []} ()
    lemma {xs = x ∷ xs} (ListAny.here P.refl) = here P.refl
    lemma {xs = x ∷ xs} (ListAny.there p) = there (lemma p)

fromList : ∀ {a}{A : Set a}{xs : List A} → ListDistinct.Distinct xs → Distinct (Vec.fromList xs)
fromList ListDistinct.distinct-[] = distinct-[]
fromList (x ListDistinct.distinct-∷ dxs by x∉xs) =
  x distinct-∷ fromList dxs by λ x∈xs → x∉xs (lemma x∈xs)
    where
      import Data.List.Membership.Propositional as ListMem
      import Data.List.Any as ListAny
      lemma : ∀ {a}{A : Set a}{x}{xs : List A} → x ∈ Vec.fromList xs →
        x ListMem.∈ xs
      lemma {xs = List.[]} ()
      lemma {xs = x List.∷ xs} (here P.refl) = ListAny.here P.refl
      lemma {xs = x List.∷ xs} (there p) = ListAny.there (lemma p)