/-
Copyright (c) 2023 Yaël Dillies, Sky Wilshaw. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Sky Wilshaw
-/
import group_theory.perm.basic
import logic.equiv.local_equiv

/-!
# Local equivalences

This files defines permutations on a set.

A local permutation on `α` is a domain `set α` and two functions `α → α` that map `domain` to
`domain` and are inverse to each other on `domain`.

## Main declarations

* `local_perm α`: The type of local permutations on `α`.
* `equiv.to_local_perm`: Reinter
-/

open function set

variables {α : Type*}

/-- A local permutation of a subset `domain` of `α`. The (global) maps `to_fun : α → α` and
`inv_fun : α → α` map `domain` to itself, and are inverse to each other there. The values of
`to_fun` and `inv_fun` outside of `domain` are irrelevant. -/
structure local_perm (α : Type*) :=
(to_fun inv_fun : α → α)
(domain : set α)
(to_fun_domain' : ∀ ⦃x⦄, x ∈ domain → to_fun x ∈ domain)
(inv_fun_domain' : ∀ ⦃x⦄, x ∈ domain → inv_fun x ∈ domain)
(left_inv' : ∀ ⦃x⦄, x ∈ domain → inv_fun (to_fun x) = x)
(right_inv' : ∀ ⦃x⦄, x ∈ domain → to_fun (inv_fun x) = x)

/-- A `perm` gives rise to a `local_perm` Associating a local_perm to an equiv -/
def equiv.perm.to_local_perm (π : equiv.perm α) : local_perm α :=
{ to_fun := π,
  inv_fun := π.symm,
  domain := univ,
  to_fun_domain' := λ x hx, mem_univ _,
  inv_fun_domain' := λ y hy, mem_univ _,
  left_inv' := λ x hx, π.left_inv x,
  right_inv' := λ x hx, π.right_inv x }

namespace local_perm
variables (π π' : local_perm α)

/-- The inverse of a local permutation. -/
protected def symm : local_perm α :=
{ to_fun := π.inv_fun,
  inv_fun := π.to_fun,
  domain := π.domain,
  to_fun_domain' := π.inv_fun_domain',
  inv_fun_domain' := π.to_fun_domain',
  left_inv' := π.right_inv',
  right_inv' := π.left_inv' }

instance : has_coe_to_fun (local_perm α) (λ _, α → α) := ⟨local_perm.to_fun⟩

/-- See Note [custom simps projection] -/
def simps.symm_apply (π : local_perm α) : α → α := π.symm

initialize_simps_projections local_perm (to_fun → apply, inv_fun → symm_apply)

@[simp] theorem coe_mk (f : α → α) (g s ml mr il ir) :
  (local_perm.mk f g s ml mr il ir : α → α) = f := rfl

@[simp] theorem coe_symm_mk (f : α → α) (g s ml mr il ir) :
  ((local_perm.mk f g s ml mr il ir).symm : α → α) = g := rfl

@[simp] lemma to_fun_as_coe : π.to_fun = π := rfl
@[simp] lemma inv_fun_as_coe : π.inv_fun = π.symm := rfl

@[simp] lemma map_domain {x : α} (h : x ∈ π.domain) : π x ∈ π.domain := π.to_fun_domain' h
@[simp] lemma iterate_domain {x : α} (h : x ∈ π.domain) {n : ℕ} : π^[n] x ∈ π.domain :=
begin
  induction n with n ih,
  exact h,
  rw function.iterate_succ',
  exact π.map_domain ih,
end

@[simp] lemma left_inv {x : α} (h : x ∈ π.domain) : π.symm (π x) = x := π.left_inv' h
@[simp] lemma right_inv {x : α} (h : x ∈ π.domain) : π (π.symm x) = x := π.right_inv' h

@[simp] lemma symm_domain : π.symm.domain = π.domain := rfl
@[simp] lemma symm_symm : π.symm.symm = π := by { cases π, refl }

lemma eq_symm_apply {x : α} {y : α} (hx : x ∈ π.domain) (hy : y ∈ π.domain) :
  x = π.symm y ↔ π x = y :=
⟨λ h, by rw [← π.right_inv hy, h], λ h, by rw [← π.left_inv hx, h]⟩

protected lemma maps_to : maps_to π π.domain π.domain := λ x, π.map_domain
protected lemma left_inv_on : left_inv_on π.symm π π.domain := λ x, π.left_inv
protected lemma right_inv_on : right_inv_on π.symm π π.domain := λ x, π.right_inv
protected lemma inv_on : inv_on π.symm π π.domain π.domain := ⟨π.left_inv_on, π.right_inv_on⟩
protected lemma inj_on : inj_on π π.domain := π.left_inv_on.inj_on
protected lemma bij_on : bij_on π π.domain π.domain := π.inv_on.bij_on π.maps_to π.symm.maps_to
protected lemma surj_on : surj_on π π.domain π.domain := π.bij_on.surj_on

/-- Create a copy of a `local_perm` providing better definitional equalities. -/
@[simps {fully_applied := ff}]
def copy (π : local_perm α) (f : α → α) (hf : ⇑π = f) (g : α → α) (hg : ⇑π.symm = g)
  (s : set α) (hs : π.domain = s) :
  local_perm α :=
{ to_fun := f,
  inv_fun := g,
  domain := s,
  to_fun_domain' := hs ▸ hf ▸ π.to_fun_domain',
  inv_fun_domain' := hs ▸ hg ▸ π.inv_fun_domain',
  left_inv' := λ x, hs ▸ hf ▸ hg ▸ π.left_inv,
  right_inv' := λ x, hs ▸ hf ▸ hg ▸ π.right_inv }

lemma copy_eq (π : local_perm α) (f : α → α) (hf : ⇑π = f) (g : α → α) (hg : ⇑π.symm = g)
  (s : set α) (hs : π.domain = s) :
  π.copy f hf g hg s hs = π :=
by { substs f g s, cases π, refl }

/-- Associating to a local_perm a permutation of the domain. -/
protected def to_perm : equiv.perm π.domain :=
{ to_fun := λ x, ⟨π x, π.map_domain x.mem⟩,
  inv_fun := λ y, ⟨π.symm y, π.symm.map_domain y.mem⟩,
  left_inv := λ ⟨x, hx⟩, subtype.eq $ π.left_inv hx,
  right_inv := λ ⟨y, hy⟩, subtype.eq $ π.right_inv hy }

@[simp] lemma image_domain : π '' π.domain = π.domain := π.bij_on.image_eq

lemma forall_mem_domain {p : α → Prop} : (∀ y ∈ π.domain, p y) ↔ ∀ x ∈ π.domain, p (π x) :=
by conv_lhs { rw [←image_domain, ball_image_iff] }

lemma exists_mem_domain {p : α → Prop} : (∃ y ∈ π.domain, p y) ↔ ∃ x ∈ π.domain, p (π x) :=
by conv_lhs { rw [←image_domain, bex_image_iff] }

/-- A set `s` is *stable* under a local equivalence `π` if it preserved by it. -/
def is_stable (s : set α) : Prop := ∀ ⦃x⦄, x ∈ π.domain → (π x ∈ s ↔ x ∈ s)

namespace is_stable

variables {π π'} {s : set α} {x y : α}

lemma apply_mem_iff (h : π.is_stable s) (hx : x ∈ π.domain) : π x ∈ s ↔ x ∈ s := h hx

lemma symm_apply_mem_iff (h : π.is_stable s) : ∀ ⦃y⦄, y ∈ π.domain → (π.symm y ∈ s ↔ y ∈ s) :=
π.forall_mem_domain.mpr $ λ x hx, by rw [π.left_inv hx, h hx]

protected lemma symm (h : π.is_stable s) : π.symm.is_stable s := h.symm_apply_mem_iff

@[simp] lemma symm_iff : π.symm.is_stable s ↔ π.is_stable s := ⟨λ h, h.symm, λ h, h.symm⟩

protected lemma maps_to (h : π.is_stable s) : maps_to π (π.domain ∩ s) (π.domain ∩ s) :=
λ x hx, ⟨π.maps_to hx.1, (h hx.1).2 hx.2⟩

lemma symm_maps_to (h : π.is_stable s) : maps_to π.symm (π.domain ∩ s) (π.domain ∩ s) :=
h.symm.maps_to

/-- Restrict a `local_perm` to a stable subset. -/
@[simps {fully_applied := ff}] def restr (h : π.is_stable s) : local_perm α :=
{ to_fun := π,
  inv_fun := π.symm,
  domain := π.domain ∩ s,
  to_fun_domain' := h.maps_to,
  inv_fun_domain' := h.symm_maps_to,
  left_inv' := π.left_inv_on.mono (inter_subset_left _ _),
  right_inv' := π.right_inv_on.mono (inter_subset_left _ _) }

lemma image_eq (h : π.is_stable s) : π '' (π.domain ∩ s) = π.domain ∩ s :=
h.restr.image_domain

lemma symm_image_eq (h : π.is_stable s) : π.symm '' (π.domain ∩ s) = π.domain ∩ s :=
h.symm.image_eq

lemma iff_preimage_eq : π.is_stable s ↔ π.domain ∩ π ⁻¹' s = π.domain ∩ s :=
by simp only [is_stable, set.ext_iff, mem_inter_iff, and.congr_right_iff, mem_preimage]

alias iff_preimage_eq ↔ preimage_eq of_preimage_eq

lemma iff_symm_preimage_eq : π.is_stable s ↔ π.domain ∩ π.symm ⁻¹' s = π.domain ∩ s :=
symm_iff.symm.trans iff_preimage_eq

alias iff_symm_preimage_eq ↔ symm_preimage_eq of_symm_preimage_eq

-- lemma of_image_eq (h : π '' (π.domain ∩ s) = π.domain ∩ s) : π.is_stable s :=
-- of_symm_preimage_eq $ eq.trans (of_symm_preimage_eq rfl).image_eq.symm h

-- lemma of_symm_image_eq (h : π.symm '' (π.domain ∩ s) = π.domain ∩ s) : π.is_stable s :=
-- of_preimage_eq $ eq.trans (of_preimage_eq rfl).symm_image_eq.symm h

protected lemma compl (h : π.is_stable s) : π.is_stable sᶜ := λ x hx, not_congr (h hx)

protected lemma inter {s'} (h : π.is_stable s) (h' : π.is_stable s') : π.is_stable (s ∩ s') :=
λ x hx, and_congr (h hx) (h' hx)

protected lemma union {s'} (h : π.is_stable s) (h' : π.is_stable s') : π.is_stable (s ∪ s') :=
λ x hx, or_congr (h hx) (h' hx)

protected lemma diff {s'} (h : π.is_stable s) (h' : π.is_stable s') : π.is_stable (s \ s') :=
h.inter h'.compl

lemma left_inv_on_piecewise {π' : local_perm α} [Π i, decidable (i ∈ s)]
  (h : π.is_stable s) (h' : π'.is_stable s) :
  left_inv_on (s.piecewise π.symm π'.symm) (s.piecewise π π') (s.ite π.domain π'.domain) :=
begin
  rintro x (⟨he, hs⟩ | ⟨he, hs : x ∉ s⟩),
  { rw [piecewise_eq_of_mem _ _ _ hs, piecewise_eq_of_mem _ _ _ ((h he).2 hs), π.left_inv he] },
  { rw [piecewise_eq_of_not_mem _ _ _ hs, piecewise_eq_of_not_mem _ _ _ ((h'.compl he).2 hs),
      π'.left_inv he] }
end

lemma inter_eq_of_inter_eq_of_eq_on {π' : local_perm α} (h : π.is_stable s)
  (h' : π'.is_stable s) (hs : π.domain ∩ s = π'.domain ∩ s) (Heq : eq_on π π' (π.domain ∩ s)) :
  π.domain ∩ s = π'.domain ∩ s :=
by rw [← h.image_eq, ← h'.image_eq, ← hs, Heq.image_eq]

lemma symm_eq_on_of_inter_eq_of_eq_on {π' : local_perm α} (h : π.is_stable s)
  (hs : π.domain ∩ s = π'.domain ∩ s) (Heq : eq_on π π' (π.domain ∩ s)) :
  eq_on π.symm π'.symm (π.domain ∩ s) :=
begin
  rw ←h.image_eq,
  rintro y ⟨x, hx, rfl⟩,
  have hx' := hx, rw hs at hx',
  rw [π.left_inv hx.1, Heq hx, π'.left_inv hx'.1]
end

end is_stable

lemma image_domain_inter_eq' (s : set α) :
  π '' (π.domain ∩ s) = π.domain ∩ π.symm ⁻¹' s :=
by rw [inter_comm, π.left_inv_on.image_inter', image_domain, inter_comm]

lemma image_domain_inter_eq (s : set α) :
  π '' (π.domain ∩ s) = π.domain ∩ π.symm ⁻¹' (π.domain ∩ s) :=
by rw [inter_comm, π.left_inv_on.image_inter, image_domain, inter_comm]

lemma image_eq_domain_inter_inv_preimage {s : set α} (h : s ⊆ π.domain) :
  π '' s = π.domain ∩ π.symm ⁻¹' s :=
by rw [← π.image_domain_inter_eq', inter_eq_self_of_subset_right h]

lemma symm_image_eq_domain_inter_preimage {s : set α} (h : s ⊆ π.domain) :
  π.symm '' s = π.domain ∩ π ⁻¹' s :=
π.symm.image_eq_domain_inter_inv_preimage h

lemma symm_image_domain_inter_eq (s : set α) :
  π.symm '' (π.domain ∩ s) = π.domain ∩ π ⁻¹' (π.domain ∩ s) :=
π.symm.image_domain_inter_eq _

lemma symm_image_domain_inter_eq' (s : set α) : π.symm '' (π.domain ∩ s) = π.domain ∩ π ⁻¹' s :=
π.symm.image_domain_inter_eq' _

lemma domain_inter_preimage_inv_preimage (s : set α) :
  π.domain ∩ π ⁻¹' (π.symm ⁻¹' s) = π.domain ∩ s :=
set.ext $ λ x, and.congr_right_iff.2 $ λ hx, by simp only [mem_preimage, π.left_inv hx]

lemma domain_inter_preimage_domain_inter (s : set α) :
  π.domain ∩ (π ⁻¹' (π.domain ∩ s)) = π.domain ∩ (π ⁻¹' s) :=
ext $ λ x, ⟨λ hx, ⟨hx.1, hx.2.2⟩, λ hx, ⟨hx.1, π.map_domain hx.1, hx.2⟩⟩

lemma domain_inter_inv_preimage_preimage (s : set α) :
  π.domain ∩ π.symm ⁻¹' (π ⁻¹' s) = π.domain ∩ s :=
π.symm.domain_inter_preimage_inv_preimage _

lemma symm_image_image_of_subset_domain {s : set α} (h : s ⊆ π.domain) : π.symm '' (π '' s) = s :=
(π.left_inv_on.mono h).image_image

lemma image_symm_image_of_subset_domain {s : set α} (h : s ⊆ π.domain) : π '' (π.symm '' s) = s :=
π.symm.symm_image_image_of_subset_domain h

variables {π π'}

lemma domain_subset_preimage_domain : π.domain ⊆ π ⁻¹' π.domain := π.maps_to
lemma symm_image_domain : π.symm '' π.domain = π.domain := π.symm.image_domain

/-- Two local equivs that have the same `domain`, same `to_fun` and same `inv_fun`, coincide. -/
@[ext]
protected lemma ext (h : ∀ x, π x = π' x)
  (hsymm : ∀ x, π.symm x = π'.symm x) (hs : π.domain = π'.domain) : π = π' :=
begin
  have A : (π : α → α) = π', by { ext x, exact h x },
  have B : (π.symm : α → α) = π'.symm, by { ext x, exact hsymm x },
  have I : π '' π.domain = π.domain := π.image_domain,
  have I' : π' '' π'.domain = π'.domain := π'.image_domain,
  rw [A, hs, I'] at I,
  cases π; cases π',
  simp only [*, coe_symm_mk, coe_mk, eq_self_iff_true, and_self] at *
end

/-- The identity local equivalence. -/
protected def refl (α : Type*) : local_perm α := equiv.perm.to_local_perm $ equiv.refl _

@[simp] lemma refl_domain : (local_perm.refl α).domain = univ := rfl
@[simp, norm_cast] lemma coe_refl : ⇑(local_perm.refl α) = id := rfl
@[simp] lemma symm_refl : (local_perm.refl α).symm = local_perm.refl α := rfl

instance : inhabited (local_perm α) := ⟨local_perm.refl _⟩

variables (π π')

-- TODO: Clean up these proofs
/-- Composing two local equivs if the domain of the first coincides with the domain of the
second. -/
@[simps]
protected def trans (π' : local_perm α) (h : π.domain = π'.domain) : local_perm α :=
{ to_fun := π' ∘ π,
  inv_fun := π.symm ∘ π'.symm,
  domain := π.domain,
  to_fun_domain' := λ x hx, begin
    rw h,
    refine map_domain _ _,
    have := map_domain π hx,
    rwa h at this,
  end,
  inv_fun_domain' := λ y hy, map_domain _ begin
    rw h at hy,
    have := map_domain π'.symm hy,
    rwa [symm_domain, ← h] at this,
  end,
  left_inv' := λ x hx, by simp [hx, h.symm],
  right_inv' := λ y hy, begin
    simp,
    rw h at hy,
    rw [right_inv π, right_inv π' hy],
    have := map_domain π'.symm hy,
    rwa [symm_domain, ← h] at this,
  end }

/-- The identity local equiv on a set `s` -/
def of_set (s : set α) : local_perm α :=
{ to_fun := id,
  inv_fun := id,
  domain := s,
  to_fun_domain' := λ x hx, hx,
  inv_fun_domain' := λ x hx, hx,
  left_inv' := λ x hx, rfl,
  right_inv' := λ x hx, rfl }

@[simp] lemma of_set_domain (s : set α) : (of_set s).domain = s := rfl
@[simp, norm_cast] lemma coe_of_set (s : set α) : (of_set s : α → α) = id := rfl
@[simp] lemma of_set_symm (s : set α) : (of_set s).symm = of_set s := rfl
@[simp] lemma of_set_trans_of_set (s : set α) : (of_set s).trans (of_set s) rfl = of_set s := rfl
@[simp] lemma of_set_univ : of_set univ = local_perm.refl α := rfl

/-- Reinterpret a local permutation as a local equivalence. -/
def to_local_equiv : local_equiv α α :=
{ to_fun := π,
  inv_fun := π.symm,
  source := π.domain,
  target := π.domain,
  map_source' := π.maps_to,
  map_target' := π.symm.maps_to,
  left_inv' := π.left_inv_on,
  right_inv' := π.right_inv_on }

@[simp] lemma coe_to_local_equiv : ⇑π.to_local_equiv = π := rfl
@[simp] lemma coe_to_local_equiv_symm : ⇑π.to_local_equiv.symm = π.symm := rfl
@[simp] lemma to_local_equiv_source : π.to_local_equiv.source = π.domain := rfl
@[simp] lemma to_local_equiv_target : π.to_local_equiv.target = π.domain := rfl

@[simp] lemma to_local_equiv_refl : (local_perm.refl α).to_local_equiv = local_equiv.refl _ := rfl
@[simp] lemma to_local_equiv_symm : π.symm.to_local_equiv = π.to_local_equiv.symm := rfl
@[simp] lemma to_local_equiv_trans (h) :
  (π.trans π' h).to_local_equiv = π.to_local_equiv.trans π'.to_local_equiv :=
begin
  ext,
  { simp },
  { simp },
  { simpa [←h] using λ hx, π.maps_to hx }
end

/-- `eq_on_domain π π'` means that `π` and `π'` have the same domain, and coincide there. Then `π`
and `π'` should really be considered the same local permutation. -/
def eq_on_domain : Prop := π.domain = π'.domain ∧ π.domain.eq_on π π'

/-- `eq_on_domain` is an equivalence relation -/
instance eq_on_domain_setoid : setoid (local_perm α) :=
{ r := eq_on_domain,
  iseqv := ⟨
    λ e, by simp [eq_on_domain],
    λ e e' h, by { simp [eq_on_domain, h.1.symm], exact λ x hx, (h.2 hx).symm },
    λ e e' e'' h h', ⟨by rwa [← h'.1, ← h.1], λ x hx, by { rw [← h'.2, h.2 hx], rwa ← h.1 }⟩⟩ }

variables {π π'}

lemma eq_on_domain_refl : π ≈ π := setoid.refl _

/-- Two equivalent local equivs have the same domain -/
lemma eq_on_domain.domain_eq (h : π ≈ π') : π.domain = π'.domain := h.1

/-- Two equivalent local equivs coincide on the domain -/
lemma eq_on_domain.eq_on (h : π ≈ π') : π.domain.eq_on π π' := h.2

/-- If two local equivs are equivalent, so are their inverses. -/
lemma eq_on_domain.symm' (h : π ≈ π') : π.symm ≈ π'.symm :=
begin
  refine ⟨h.domain_eq, eq_on_of_left_inv_on_of_right_inv_on π.left_inv_on _ _⟩;
    simp only [symm_domain, h.domain_eq, h.domain_eq, π'.symm.maps_to],
  exact π'.right_inv_on.congr_right π'.symm.maps_to (h.domain_eq ▸ h.eq_on.symm),
  exact π'.symm.maps_to,
end

/-- Two equivalent local equivs have coinciding inverses on the domain -/
lemma eq_on_domain.symm_eq_on (h : π ≈ π') : eq_on π.symm π'.symm π.domain := h.symm'.eq_on

/-- Preimages are respected by equivalence -/
lemma eq_on_domain.domain_inter_preimage_eq (hπ : π ≈ π') (s : set α) :
  π.domain ∩ π ⁻¹' s = π'.domain ∩ π' ⁻¹' s :=
by rw [hπ.eq_on.inter_preimage_eq, hπ.domain_eq]

/-- Two equivalent local equivs are equal when the domain and domain are univ -/
protected lemma eq_on_domain.eq (h : π ≈ π') (hπ : π.domain = univ) : π = π' :=
by apply local_perm.ext (λ x, h.2 _) (λ x, h.symm'.2 _) h.1; simp [hπ]

/-- We define a preorder on local permutations by saying `π ≤ π'` if the domain of `π` is contained
in the domain of `π'`, and the permutations agree on the domain of `π`. -/
instance : preorder (local_perm α) :=
{  le := λ π π', π.domain ⊆ π'.domain ∧ π.domain.eq_on π π',
  le_refl := λ a, ⟨subset_rfl, eq_on_refl _ _⟩,
  le_trans := λ a b c hab hbc, ⟨hab.1.trans hbc.1, hab.2.trans $ hbc.2.mono hab.1⟩ }

lemma domain_mono (h : π ≤ π') : π.domain ⊆ π'.domain := h.1
lemma eq_on_domain_of_le (h : π ≤ π') : π.domain.eq_on π π' := h.2
lemma le_of_eq_on_domain (h : π ≈ π') : π ≤ π' := ⟨subset_of_eq h.1, h.2⟩
lemma apply_eq_of_le (h : π ≤ π') {x : α} (hx : x ∈ π.domain) : π' x = π x :=
(eq_on_domain_of_le h hx).symm

section piecewise
variables (π π') [Π (j : α), decidable (j ∈ π.domain)] {h : disjoint π.domain π'.domain}

/-- Construct a local permutation from two local permutations with disjoint domains. -/
def piecewise (h : disjoint π.domain π'.domain) : local_perm α :=
{ to_fun := π.domain.piecewise π π',
  inv_fun := π.domain.piecewise π.symm π'.symm,
  domain := π.domain ∪ π'.domain,
  to_fun_domain' := begin
    rintro x (hx | hx),
    { rw piecewise_eq_on π.domain π π' hx,
      exact or.inl (π.map_domain hx) },
    { rw piecewise_eq_on_compl π.domain π π' (disjoint_right.mp h hx),
      exact or.inr (π'.map_domain hx) },
  end,
  inv_fun_domain' := begin
    rintro x (hx | hx),
    { rw piecewise_eq_on π.domain π.symm π'.symm hx,
      exact or.inl (π.symm.map_domain hx) },
    { rw piecewise_eq_on_compl π.domain π.symm π'.symm (disjoint_right.mp h hx),
      exact or.inr (π'.symm.map_domain hx) },
  end,
  left_inv' := begin
    rintro x (hx | hx),
    { rw [piecewise_eq_on π.domain π π' hx,
        piecewise_eq_on π.domain π.symm π'.symm (π.map_domain hx),
        π.left_inv hx] },
    { rw [piecewise_eq_on_compl π.domain π π' (disjoint_right.mp h hx),
        piecewise_eq_on_compl π.domain π.symm π'.symm (disjoint_right.mp h (π'.map_domain hx)),
        π'.left_inv hx] },
  end,
  right_inv' := begin
    rintro x (hx | hx),
    { rw [piecewise_eq_on π.domain π.symm π'.symm hx,
        piecewise_eq_on π.domain π π' (π.symm.map_domain hx),
        π.right_inv hx] },
    { rw [piecewise_eq_on_compl π.domain π.symm π'.symm (disjoint_right.mp h hx),
        piecewise_eq_on_compl π.domain π π' (disjoint_right.mp h (π'.symm.map_domain hx)),
        π'.right_inv hx] },
  end }

variables {π π' h}

@[simp] lemma piecewise_domain : (piecewise π π' h).domain = π.domain ∪ π'.domain := rfl
lemma mem_piecewise_domain_left {x : α} (hx : x ∈ π.domain) : x ∈ (piecewise π π' h).domain :=
mem_union_left _ hx
lemma mem_piecewise_domain_right {x : α} (hx : x ∈ π'.domain) : x ∈ (piecewise π π' h).domain :=
mem_union_right _ hx

lemma piecewise_apply_eq_left {x : α} (hx : x ∈ π.domain) : piecewise π π' h x = π x :=
piecewise_eq_on _ _ _ hx

lemma piecewise_apply_eq_right {x : α} (hx : x ∈ π'.domain) : piecewise π π' h x = π' x :=
piecewise_eq_on_compl _ _ _ (disjoint_right.mp h hx)

lemma le_piecewise_left : π ≤ piecewise π π' h :=
⟨subset_union_left _ _, λ x hx, (piecewise_apply_eq_left hx).symm⟩

lemma le_piecewise_right : π' ≤ piecewise π π' h :=
⟨subset_union_right _ _, λ x hx, (piecewise_apply_eq_right hx).symm⟩

end piecewise

end local_perm

namespace set

-- All arguments are explicit to avoid missing information in the pretty printer output
/-- A bijection between two sets `s : set α` and `t : set α` provides a local permutation on `α`. -/
@[simps {fully_applied := ff}]
noncomputable def bij_on.to_local_perm [nonempty α] (f : α → α) (s : set α) (hf : bij_on f s s) :
  local_perm α :=
{ to_fun := f,
  inv_fun := inv_fun_on f s,
  domain := s,
  to_fun_domain' := hf.maps_to,
  inv_fun_domain' := hf.surj_on.maps_to_inv_fun_on,
  left_inv' := hf.inv_on_inv_fun_on.1,
  right_inv' := hf.inv_on_inv_fun_on.2 }

end set

/-!
# `equiv.to_local_perm`

An `equiv` can be be interpreted give rise to local_perm. We set up simp lemmas to reduce most
properties of the local equiv to that of the equiv.
-/

open equiv

namespace equiv.perm
variables (π π' : perm α)

@[simp] lemma to_local_perm_one : to_local_perm (equiv.refl α) = local_perm.refl α := rfl
@[simp] lemma to_local_perm_inv : π⁻¹.to_local_perm = π.to_local_perm.symm := rfl
@[simp] lemma to_local_perm_mul :
  (π * π').to_local_perm = π'.to_local_perm.trans π.to_local_perm rfl :=
local_perm.ext (λ x, rfl) (λ x, rfl) rfl

@[simp] lemma to_local_equiv_to_local_perm : π.to_local_perm.to_local_equiv = π.to_local_equiv :=
rfl

end equiv.perm


--- All equality are heterogeneously equal to `rfl`.
lemma eq_irrel {α : Sort _} : ∀ {x y : α} (hxy : x = y), hxy == @rfl α x
| _ _ rfl := heq.rfl

--- Eliminator of `ite` of predicators.
lemma ite_pred_iff {α : Sort _} {p : Prop} [decidable p] {P : α → Prop} : ∀ {x y}, (p → P x) ∧ (¬p → P y) ↔ P (ite p x y) :=
  begin
    intros x y,
    split,
    show _ → P (ite p x y), {
      intros hxy,
      by_cases p,
      rw [if_pos h]; exact hxy.left h,
      rw [if_neg h]; exact hxy.right h
    },
    show P (ite p x y) → _, {
      intros hP,
      by_cases p,
      rw [if_pos h] at hP; exact ⟨(λ _,hP),λ hn, false.elim (hn h)⟩,
      rw [if_neg h] at hP; exact ⟨false.elim ∘ h, (λ_,hP)⟩
    }
  end

lemma whether_of_ite {α : Sort _} {p : Prop} [decidable p] {P : α → Prop} : ∀ {x y}, P (ite p x y) → P x ∨ P y :=
  begin
    intros x y hP,
    by_cases p,
    rw [if_pos h] at hP; exact or.inl hP,
    rw [if_neg h] at hP; exact or.inr hP
  end

attribute [simp]
definition ite_eval_true {p : Prop} [pdec : decidable p] {α : Type*} : p → ∀ (a b : α), ite p a b = a :=
  begin
    intros hp a b,
    delta ite,
    cases hd: pdec with h hn,
    case is_false { contradiction },
    case is_true { dsimp [], refl }
  end

attribute [simp]
definition ite_eval_false {p : Prop} [pdec : decidable p] {α : Type*} : (¬p) → ∀ (a b: α), ite p a b = b :=
  begin
    intros hnp a b,
    delta ite,
    cases hd: pdec with hp1 hnp1,
    case is_false { dsimp [], refl },
    case is_true { contradiction }
  end

definition xor_congr {p q p' q' : Prop} : (p ↔ p') → (q ↔ q') → (xor p q ↔ xor p' q') :=
  begin
    intros hp hq,
    have hnp : ¬p ↔ ¬p', from not_congr hp,
    have hnq : ¬q ↔ ¬q', from not_congr hq,
    apply or_congr; apply and_congr; try { assumption },
  end

definition xor_self (p : Prop) : xor p p ↔ false :=
  begin
    split; intros h; try { contradiction },
    apply or.elim h; try { exact (and_not_self p).mp }
  end

definition xor_comm (p q : Prop) : xor p q ↔ xor q p :=
  begin
    dunfold xor,
    exact or.comm,
  end

definition false_xor (p : Prop) : xor false p ↔ p :=
  begin
    split,
    show xor false p → p, {
      dunfold xor; intro h; apply or.elim h,
      exact (false.elim ∘ and.left),
      exact and.left
    },
    show p → xor false p, {
      dunfold xor; intro h,
      right,
      exact ⟨h, false.elim⟩
    }
  end

definition xor_false (p : Prop) : xor p false ↔ p :=
  by calc
    xor p false
        ↔ xor false p : xor_comm p false
    ... ↔ p : false_xor p

lemma not_or_distrib {p q : Prop} : ¬(p∨q) ↔ (¬p)∧(¬q) :=
  begin
    constructor,
    show ¬(p∨ q) → (¬p)∧(¬q), {
      intros hpq,
      split,
      show ¬p, { intros hp, have : p∨ q, by left; assumption, contradiction },
      show ¬q, { intros hq, have : p∨ q, by right; assumption, contradiction },
    },
    show (¬p)∧(¬q) → ¬(p∨ q), {
      intros hnpq hpq,
      exact or.elim hpq hnpq.left hnpq.right
    },
  end

lemma and_iff_left_of_imp {p q : Prop} : (p → q) → (p ∧ q ↔ p) :=
  λ hpq, iff.intro and.left (λ hp, ⟨hp,hpq hp⟩)

lemma and_iff_right_of_imp {p q : Prop} : (q → p) → (p ∧ q ↔ q) :=
  λ hqp, iff.intro and.right (λ hq, ⟨hqp hq, hq⟩)

lemma or_disproof_left {p q : Prop} (hnp : ¬p) : (p ∨ q) ↔ q :=
  iff.intro (or.rec (by intro; contradiction) id) or.inr

lemma or_disproof_right {p q : Prop} (hnp : ¬p) : (q∨ p) ↔ q :=
  iff.intro (or.rec id (by intro; contradiction)) or.inl

lemma or_and_distrib {p q r : Prop} : (p ∨ q) ∧ r ↔ (p ∧ r) ∨ (q ∧ r) :=
{
  mp :=
    λ hpqr,
      hpqr.left.elim
        (λ hp, or.inl ⟨hp,hpqr.right⟩)
        (λ hq, or.inr ⟨hq,hpqr.right⟩),
  mpr :=
    λ hprqr,
      hprqr.elim
        (λ hpr, ⟨or.inl hpr.left, hpr.right⟩)
        (λ hqr, ⟨or.inr hqr.left, hqr.right⟩)
}

--- The equality on Σ-type from equality and heterogeneous equality.
lemma sigma_eq_heq {α : Sort _} {β : α → Sort _} : ∀ {x y : sigma β}, x.fst = y.fst → x.snd == y.snd → x = y
| ⟨x,hx⟩ ⟨y,hy⟩ rfl heq.rfl := rfl

--- Variant of `funext` with heterogeneous dependent domain.
lemma funext_hdom {α : Sort _} {β : α → Sort _} {γ : Sort _} : ∀ {a₁ a₂ : α} {f : β a₁ → γ} {g : β a₂ → γ}, a₁ = a₂ → (∀ (x : β a₁) (y : β a₂), x == y → f x = g y) → f == g
| _ _ f g rfl hfg := heq_of_eq $ funext (λ x, hfg x x heq.rfl)


/-
Copyright (c) 2019 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau

! This file was ported from Lean 3 source module algebra.free
! leanprover-community/mathlib commit 6d0adfa76594f304b4650d098273d4366edeb61b
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Hom.Group
import Mathlib.Algebra.Hom.Equiv.Basic
import Mathlib.Control.Applicative
import Mathlib.Control.Traversable.Basic
import Mathlib.Logic.Equiv.Defs
import Mathlib.Data.List.Basic

/-!
# Free constructions

## Main definitions

* `FreeMagma α`: free magma (structure with binary operation without any axioms) over alphabet `α`,
  defined inductively, with traversable instance and decidable equality.
* `MagmaAssocQuotient α`: quotient of a magma `α` by the associativity equivalence relation.
* `FreeSemigroup α`: free semigroup over alphabet `α`, defined as a structure with two fields
  `head : α` and `tail : list α` (i.e. nonempty lists), with traversable instance and decidable
  equality.
* `FreeMagmaAssocQuotientEquiv α`: isomorphism between `MagmaAssocQuotient (FreeMagma α)` and
  `FreeSemigroup α`.
* `FreeMagma.lift`: the universal property of the free magma, expressing its adjointness.
-/

universe u v l

/-- Free nonabelian additive magma over a given alphabet. -/
inductive FreeAddMagma (α : Type u) : Type u
  | of : α → FreeAddMagma α
  | add : FreeAddMagma α → FreeAddMagma α → FreeAddMagma α
  deriving DecidableEq
#align free_add_magma FreeAddMagma

/-- Free magma over a given alphabet. -/
@[to_additive]
inductive FreeMagma (α : Type u) : Type u
  | of : α → FreeMagma α
  | mul : FreeMagma α → FreeMagma α → FreeMagma α
  deriving DecidableEq
#align free_magma FreeMagma

namespace FreeMagma

variable {α : Type u}

@[to_additive]
instance [Inhabited α] : Inhabited (FreeMagma α) := ⟨of default⟩

@[to_additive]
instance : Mul (FreeMagma α) := ⟨FreeMagma.mul⟩

-- Porting note: invalid attribute 'match_pattern', declaration is in an imported module
-- attribute [match_pattern] Mul.mul

@[to_additive (attr := simp)]
theorem mul_eq (x y : FreeMagma α) : mul x y = x * y := rfl
#align free_magma.mul_eq FreeMagma.mul_eq

/- Porting note: these lemmas are autogenerated by the inductive definition and due to
the existence of mul_eq not in simp normal form -/
attribute [nolint simpNF] FreeAddMagma.add.sizeOf_spec
attribute [nolint simpNF] FreeMagma.mul.sizeOf_spec
attribute [nolint simpNF] FreeAddMagma.add.injEq
attribute [nolint simpNF] FreeMagma.mul.injEq

/-- Recursor for `FreeMagma` using `x * y` instead of `FreeMagma.mul x y`. -/
@[to_additive (attr := elab_as_elim) "Recursor for `FreeAddMagma` using `x + y` instead of
`FreeAddMagma.add x y`."]
-- Porting note: added noncomputable
noncomputable def recOnMul {C : FreeMagma α → Sort l} (x) (ih1 : ∀ x, C (of x))
    (ih2 : ∀ x y, C x → C y → C (x * y)) : C x :=
  FreeMagma.recOn x ih1 ih2
#align free_magma.rec_on_mul FreeMagma.recOnMul

@[to_additive (attr := ext 1100)]
theorem hom_ext {β : Type v} [Mul β] {f g : FreeMagma α →ₙ* β} (h : f ∘ of = g ∘ of) : f = g :=
  (FunLike.ext _ _) fun x ↦ recOnMul x (congr_fun h) <| by intros ; simp only [map_mul, *]
#align free_magma.hom_ext FreeMagma.hom_ext

end FreeMagma

/-- Lifts a function `α → β` to a magma homomorphism `FreeMagma α → β` given a magma `β`. -/
def FreeMagma.liftAux {α : Type u} {β : Type v} [Mul β] (f : α → β) : FreeMagma α → β
  | FreeMagma.of x => f x
  | x * y => liftAux f x * liftAux f y
#align free_magma.lift_aux FreeMagma.liftAux

/-- Lifts a function `α → β` to an additive magma homomorphism `FreeAddMagma α → β` given
an additive magma `β`. -/
def FreeAddMagma.liftAux {α : Type u} {β : Type v} [Add β] (f : α → β) : FreeAddMagma α → β
  | FreeAddMagma.of x => f x
  | x + y => liftAux f x + liftAux f y
#align free_add_magma.lift_aux FreeAddMagma.liftAux

attribute [to_additive existing] FreeMagma.liftAux

namespace FreeMagma

section lift

variable {α : Type u} {β : Type v} [Mul β] (f : α → β)

/-- The universal property of the free magma expressing its adjointness. -/
@[to_additive (attr := simps symm_apply)
"The universal property of the free additive magma expressing its adjointness."]
def lift : (α → β) ≃ (FreeMagma α →ₙ* β) where
  toFun f :=
  { toFun := liftAux f
    map_mul' := fun x y ↦ rfl }
  invFun F := F ∘ of
  left_inv f := by rfl
-- Porting note: replaced ext by FreeMagma.hom_ext
  right_inv F := FreeMagma.hom_ext (rfl)
#align free_magma.lift FreeMagma.lift

@[to_additive (attr := simp)]
theorem lift_of (x) : lift f (of x) = f x := rfl
#align free_magma.lift_of FreeMagma.lift_of

@[to_additive (attr := simp)]
theorem lift_comp_of : lift f ∘ of = f := rfl
#align free_magma.lift_comp_of FreeMagma.lift_comp_of

@[to_additive (attr := simp)]
theorem lift_comp_of' (f : FreeMagma α →ₙ* β) : lift (f ∘ of) = f := lift.apply_symm_apply f
#align free_magma.lift_comp_of' FreeMagma.lift_comp_of'

end lift

section Map

variable {α : Type u} {β : Type v} (f : α → β)

/-- The unique magma homomorphism `FreeMagma α →ₙ* FreeMagma β` that sends
each `of x` to `of (f x)`. -/
@[to_additive "The unique additive magma homomorphism `FreeAddMagma α → FreeAddMagma β` that sends
each `of x` to `of (f x)`."]
def map (f : α → β) : FreeMagma α →ₙ* FreeMagma β := lift (of ∘ f)
#align free_magma.map FreeMagma.map

@[to_additive (attr := simp)]
theorem map_of (x) : map f (of x) = of (f x) := rfl
#align free_magma.map_of FreeMagma.map_of

end Map

section Category

variable {α β : Type u}

@[to_additive]
instance : Monad FreeMagma where
  pure := of
  bind x f := lift f x

/-- Recursor on `FreeMagma` using `pure` instead of `of`. -/
@[to_additive (attr := elab_as_elim) "Recursor on `FreeAddMagma` using `pure` instead of `of`."]
-- Porting note: added noncomputable
protected noncomputable def recOnPure {C : FreeMagma α → Sort l} (x) (ih1 : ∀ x, C (pure x))
    (ih2 : ∀ x y, C x → C y → C (x * y)) : C x :=
  FreeMagma.recOnMul x ih1 ih2
#align free_magma.rec_on_pure FreeMagma.recOnPure

-- Porting note: dsimp can not prove this
@[to_additive (attr := simp, nolint simpNF)]
theorem map_pure (f : α → β) (x) : (f <$> pure x : FreeMagma β) = pure (f x) := rfl
#align free_magma.map_pure FreeMagma.map_pure

@[to_additive (attr := simp)]
theorem map_mul' (f : α → β) (x y : FreeMagma α) : f <$> (x * y) = f <$> x * f <$> y := rfl
#align free_magma.map_mul' FreeMagma.map_mul'

-- Porting note: dsimp can not prove this
@[to_additive (attr := simp, nolint simpNF)]
theorem pure_bind (f : α → FreeMagma β) (x) : pure x >>= f = f x := rfl
#align free_magma.pure_bind FreeMagma.pure_bind

@[to_additive (attr := simp)]
theorem mul_bind (f : α → FreeMagma β) (x y : FreeMagma α) : x * y >>= f = (x >>= f) * (y >>= f) :=
  rfl
#align free_magma.mul_bind FreeMagma.mul_bind

@[to_additive (attr := simp)]
theorem pure_seq {α β : Type u} {f : α → β} {x : FreeMagma α} : pure f <*> x = f <$> x := rfl
#align free_magma.pure_seq FreeMagma.pure_seq

@[to_additive (attr := simp)]
theorem mul_seq {α β : Type u} {f g : FreeMagma (α → β)} {x : FreeMagma α} :
    f * g <*> x = (f <*> x) * (g <*> x) := rfl
#align free_magma.mul_seq FreeMagma.mul_seq

@[to_additive]
instance : LawfulMonad FreeMagma.{u} := LawfulMonad.mk'
  (pure_bind := fun f x ↦ rfl)
  (bind_assoc := fun x f g ↦ FreeMagma.recOnPure x (fun x ↦ rfl) fun x y ih1 ih2 ↦ by
    rw [mul_bind, mul_bind, mul_bind, ih1, ih2])
  (id_map := fun x ↦ FreeMagma.recOnPure x (fun _ ↦ rfl) fun x y ih1 ih2 ↦ by
    rw [map_mul', ih1, ih2])

end Category

end FreeMagma

/-- `FreeMagma` is traversable. -/
protected def FreeMagma.traverse {m : Type u → Type u} [Applicative m] {α β : Type u}
    (F : α → m β) : FreeMagma α → m (FreeMagma β)
  | FreeMagma.of x => FreeMagma.of <$> F x
  | x * y => (· * ·) <$> x.traverse F <*> y.traverse F
#align free_magma.traverse FreeMagma.traverse

/-- `FreeAddMagma` is traversable. -/
protected def FreeAddMagma.traverse {m : Type u → Type u} [Applicative m] {α β : Type u}
    (F : α → m β) : FreeAddMagma α → m (FreeAddMagma β)
  | FreeAddMagma.of x => FreeAddMagma.of <$> F x
  | x + y => (· + ·) <$> x.traverse F <*> y.traverse F
#align free_add_magma.traverse FreeAddMagma.traverse

attribute [to_additive existing] FreeMagma.traverse

namespace FreeMagma

variable {α : Type u}

section Category

variable {β : Type u}

@[to_additive]
instance : Traversable FreeMagma := ⟨@FreeMagma.traverse⟩

variable {m : Type u → Type u} [Applicative m] (F : α → m β)

@[to_additive (attr := simp)]
theorem traverse_pure (x) : traverse F (pure x : FreeMagma α) = pure <$> F x := rfl
#align free_magma.traverse_pure FreeMagma.traverse_pure

@[to_additive (attr := simp)]
theorem traverse_pure' : traverse F ∘ pure = fun x ↦ (pure <$> F x : m (FreeMagma β)) := rfl
#align free_magma.traverse_pure' FreeMagma.traverse_pure'

@[to_additive (attr := simp)]
theorem traverse_mul (x y : FreeMagma α) :
    traverse F (x * y) = (· * ·) <$> traverse F x <*> traverse F y := rfl
#align free_magma.traverse_mul FreeMagma.traverse_mul

@[to_additive (attr := simp)]
theorem traverse_mul' :
    Function.comp (traverse F) ∘ @Mul.mul (FreeMagma α) _ = fun x y ↦
      (· * ·) <$> traverse F x <*> traverse F y := rfl
#align free_magma.traverse_mul' FreeMagma.traverse_mul'

@[to_additive (attr := simp)]
theorem traverse_eq (x) : FreeMagma.traverse F x = traverse F x := rfl
#align free_magma.traverse_eq FreeMagma.traverse_eq

-- Porting note: dsimp can not prove this
@[to_additive (attr := simp, nolint simpNF)]
theorem mul_map_seq (x y : FreeMagma α) :
    ((· * ·) <$> x <*> y : Id (FreeMagma α)) = (x * y : FreeMagma α) := rfl
#align free_magma.mul_map_seq FreeMagma.mul_map_seq

@[to_additive]
instance : IsLawfulTraversable FreeMagma.{u} :=
  { instLawfulMonadFreeMagmaInstMonadFreeMagma with
    id_traverse := fun x ↦
      FreeMagma.recOnPure x (fun x ↦ rfl) fun x y ih1 ih2 ↦ by
        rw [traverse_mul, ih1, ih2, mul_map_seq]
    comp_traverse := fun f g x ↦
      FreeMagma.recOnPure x
        (fun x ↦ by simp only [(. ∘ .), traverse_pure, traverse_pure', functor_norm])
        (fun x y ih1 ih2 ↦ by
          rw [traverse_mul, ih1, ih2, traverse_mul];
          simp [Functor.Comp.map_mk, Functor.map_map, (. ∘ .), Comp.seq_mk, seq_map_assoc,
            map_seq, traverse_mul])
    naturality := fun η α β f x ↦
      FreeMagma.recOnPure x
        (fun x ↦ by simp only [traverse_pure, functor_norm, Function.comp_apply])
        (fun x y ih1 ih2 ↦ by simp only [traverse_mul, functor_norm, ih1, ih2])
    traverse_eq_map_id := fun f x ↦
      FreeMagma.recOnPure x (fun _ ↦ rfl) fun x y ih1 ih2 ↦ by
        rw [traverse_mul, ih1, ih2, map_mul', mul_map_seq]; rfl }

end Category

end FreeMagma

-- Porting note: changed String to Lean.Format
/-- Representation of an element of a free magma. -/
protected def FreeMagma.repr {α : Type u} [Repr α] : FreeMagma α → Lean.Format
  | FreeMagma.of x => repr x
  | x * y => "( " ++ x.repr ++ " * " ++ y.repr ++ " )"
#align free_magma.repr FreeMagma.repr

/-- Representation of an element of a free additive magma. -/
protected def FreeAddMagma.repr {α : Type u} [Repr α] : FreeAddMagma α → Lean.Format
  | FreeAddMagma.of x => repr x
  | x + y => "( " ++ x.repr ++ " + " ++ y.repr ++ " )"
#align free_add_magma.repr FreeAddMagma.repr

attribute [to_additive existing] FreeMagma.repr

@[to_additive]
instance {α : Type u} [Repr α] : Repr (FreeMagma α) := ⟨fun o _ => FreeMagma.repr o⟩

/-- Length of an element of a free magma. -/
def FreeMagma.length {α : Type u} : FreeMagma α → ℕ
  | FreeMagma.of _x => 1
  | x * y => x.length + y.length
#align free_magma.length FreeMagma.length

/-- Length of an element of a free additive magma. -/
def FreeAddMagma.length {α : Type u} : FreeAddMagma α → ℕ
  | FreeAddMagma.of _x => 1
  | x + y => x.length + y.length
#align free_add_magma.length FreeAddMagma.length

attribute [to_additive existing (attr := simp)] FreeMagma.length

/-- Associativity relations for an additive magma. -/
inductive AddMagma.AssocRel (α : Type u) [Add α] : α → α → Prop
  | intro : ∀ x y z, AddMagma.AssocRel α (x + y + z) (x + (y + z))
  | left : ∀ w x y z, AddMagma.AssocRel α (w + (x + y + z)) (w + (x + (y + z)))
#align add_magma.assoc_rel AddMagma.AssocRel

/-- Associativity relations for a magma. -/
@[to_additive AddMagma.AssocRel "Associativity relations for an additive magma."]
inductive Magma.AssocRel (α : Type u) [Mul α] : α → α → Prop
  | intro : ∀ x y z, Magma.AssocRel α (x * y * z) (x * (y * z))
  | left : ∀ w x y z, Magma.AssocRel α (w * (x * y * z)) (w * (x * (y * z)))
#align magma.assoc_rel Magma.AssocRel

namespace Magma

/-- Semigroup quotient of a magma. -/
@[to_additive AddMagma.FreeAddSemigroup "Additive semigroup quotient of an additive magma."]
def AssocQuotient (α : Type u) [Mul α] : Type u :=
  Quot <| AssocRel α
#align magma.assoc_quotient Magma.AssocQuotient

namespace AssocQuotient

variable {α : Type u} [Mul α]

@[to_additive]
theorem quot_mk_assoc (x y z : α) : Quot.mk (AssocRel α) (x * y * z) = Quot.mk _ (x * (y * z)) :=
  Quot.sound (AssocRel.intro _ _ _)
#align magma.assoc_quotient.quot_mk_assoc Magma.AssocQuotient.quot_mk_assoc

@[to_additive]
theorem quot_mk_assoc_left (x y z w : α) :
    Quot.mk (AssocRel α) (x * (y * z * w)) = Quot.mk _ (x * (y * (z * w))) :=
  Quot.sound (AssocRel.left _ _ _ _)
#align magma.assoc_quotient.quot_mk_assoc_left Magma.AssocQuotient.quot_mk_assoc_left

@[to_additive]
instance : Semigroup (AssocQuotient α) where
  mul x y := by
    refine' Quot.liftOn₂ x y (fun x y ↦ Quot.mk _ (x * y)) _ _
    · rintro a b₁ b₂ (⟨c, d, e⟩ | ⟨c, d, e, f⟩) <;> simp only
      · exact quot_mk_assoc_left _ _ _ _
      · rw [← quot_mk_assoc, quot_mk_assoc_left, quot_mk_assoc]
    · rintro a₁ a₂ b (⟨c, d, e⟩ | ⟨c, d, e, f⟩) <;> simp only
      · simp only [quot_mk_assoc, quot_mk_assoc_left]
      · rw [quot_mk_assoc, quot_mk_assoc, quot_mk_assoc_left, quot_mk_assoc_left,
          quot_mk_assoc_left, ← quot_mk_assoc c d, ← quot_mk_assoc c d, quot_mk_assoc_left]
  mul_assoc x y z :=
    Quot.induction_on₃ x y z fun a b c ↦ quot_mk_assoc a b c

/-- Embedding from magma to its free semigroup. -/
@[to_additive "Embedding from additive magma to its free additive semigroup."]
def of : α →ₙ* AssocQuotient α := ⟨Quot.mk _, fun _x _y ↦ rfl⟩
#align magma.assoc_quotient.of Magma.AssocQuotient.of

@[to_additive]
instance [Inhabited α] : Inhabited (AssocQuotient α) := ⟨of default⟩

@[to_additive (attr := elab_as_elim)]
protected theorem induction_on {C : AssocQuotient α → Prop} (x : AssocQuotient α)
    (ih : ∀ x, C (of x)) : C x := Quot.induction_on x ih
#align magma.assoc_quotient.induction_on Magma.AssocQuotient.induction_on

section lift

variable {β : Type v} [Semigroup β] (f : α →ₙ* β)

@[to_additive (attr := ext 1100)]
theorem hom_ext {f g : AssocQuotient α →ₙ* β} (h : f.comp of = g.comp of) : f = g :=
  (FunLike.ext _ _) fun x => AssocQuotient.induction_on x <| FunLike.congr_fun h
#align magma.assoc_quotient.hom_ext Magma.AssocQuotient.hom_ext

/-- Lifts a magma homomorphism `α → β` to a semigroup homomorphism `Magma.AssocQuotient α → β`
given a semigroup `β`. -/
@[to_additive (attr := simps symm_apply) "Lifts an additive magma homomorphism `α → β` to an
additive semigroup homomorphism `AddMagma.AssocQuotient α → β` given an additive semigroup `β`."]
def lift : (α →ₙ* β) ≃ (AssocQuotient α →ₙ* β) where
  toFun f :=
  { toFun := fun x ↦
      Quot.liftOn x f <| by rintro a b (⟨c, d, e⟩ | ⟨c, d, e, f⟩) <;> simp only [map_mul, mul_assoc]
    map_mul' := fun x y ↦ Quot.induction_on₂ x y (map_mul f) }
  invFun f := f.comp of
  left_inv f := (FunLike.ext _ _) fun x ↦ rfl
  right_inv f := hom_ext <| (FunLike.ext _ _) fun x ↦ rfl
#align magma.assoc_quotient.lift Magma.AssocQuotient.lift

@[to_additive (attr := simp)]
theorem lift_of (x : α) : lift f (of x) = f x := rfl
#align magma.assoc_quotient.lift_of Magma.AssocQuotient.lift_of

@[to_additive (attr := simp)]
theorem lift_comp_of : (lift f).comp of = f := lift.symm_apply_apply f
#align magma.assoc_quotient.lift_comp_of Magma.AssocQuotient.lift_comp_of

@[to_additive (attr := simp)]
theorem lift_comp_of' (f : AssocQuotient α →ₙ* β) : lift (f.comp of) = f := lift.apply_symm_apply f
#align magma.assoc_quotient.lift_comp_of' Magma.AssocQuotient.lift_comp_of'

end lift

variable {β : Type v} [Mul β] (f : α →ₙ* β)

/-- From a magma homomorphism `α →ₙ* β` to a semigroup homomorphism
`Magma.AssocQuotient α →ₙ* Magma.AssocQuotient β`. -/
@[to_additive "From an additive magma homomorphism `α → β` to an additive semigroup homomorphism
`AddMagma.AssocQuotient α → AddMagma.AssocQuotient β`."]
def map : AssocQuotient α →ₙ* AssocQuotient β := lift (of.comp f)
#align magma.assoc_quotient.map Magma.AssocQuotient.map

@[to_additive (attr := simp)]
theorem map_of (x) : map f (of x) = of (f x) := rfl
#align magma.assoc_quotient.map_of Magma.AssocQuotient.map_of

end AssocQuotient

end Magma

/-- Free additive semigroup over a given alphabet. -/
structure FreeAddSemigroup (α : Type u) where
/-- The head of the element -/
  head : α
/-- The tail of the element -/
  tail : List α
#align free_add_semigroup FreeAddSemigroup

/-- Free semigroup over a given alphabet. -/
@[to_additive (attr := ext)]
structure FreeSemigroup (α : Type u) where
/-- The head of the element -/
  head : α
/-- The tail of the element -/
  tail : List α
#align free_semigroup FreeSemigroup

namespace FreeSemigroup

variable {α : Type u}

@[to_additive]
instance : Semigroup (FreeSemigroup α) where
  mul L1 L2 := ⟨L1.1, L1.2 ++ L2.1 :: L2.2⟩
-- Porting note: replaced ext by FreeSemigroup.ext
  mul_assoc _L1 _L2 _L3 := FreeSemigroup.ext _ _ rfl <| List.append_assoc _ _ _

@[to_additive (attr := simp)]
theorem head_mul (x y : FreeSemigroup α) : (x * y).1 = x.1 := rfl
#align free_semigroup.head_mul FreeSemigroup.head_mul

@[to_additive (attr := simp)]
theorem tail_mul (x y : FreeSemigroup α) : (x * y).2 = x.2 ++ y.1 :: y.2 := rfl
#align free_semigroup.tail_mul FreeSemigroup.tail_mul

@[to_additive (attr := simp)]
theorem mk_mul_mk (x y : α) (L1 L2 : List α) : mk x L1 * mk y L2 = mk x (L1 ++ y :: L2) := rfl
#align free_semigroup.mk_mul_mk FreeSemigroup.mk_mul_mk

/-- The embedding `α → FreeSemigroup α`. -/
@[to_additive (attr := simps) "The embedding `α → free_add_semigroup α`."]
def of (x : α) : FreeSemigroup α := ⟨x, []⟩
#align free_semigroup.of FreeSemigroup.of

/-- Length of an element of free semigroup. -/
@[to_additive "Length of an element of free additive semigroup"]
def length (x : FreeSemigroup α) : ℕ := x.tail.length + 1
#align free_semigroup.length FreeSemigroup.length

@[to_additive (attr := simp)]
theorem length_mul (x y : FreeSemigroup α) : (x * y).length = x.length + y.length := by
  simp [length, ← add_assoc, add_right_comm, List.length, List.length_append]
#align free_semigroup.length_mul FreeSemigroup.length_mul

@[to_additive (attr := simp)]
theorem length_of (x : α) : (of x).length = 1 := rfl
#align free_semigroup.length_of FreeSemigroup.length_of

@[to_additive]
instance [Inhabited α] : Inhabited (FreeSemigroup α) := ⟨of default⟩

/-- Recursor for free semigroup using `of` and `*`. -/
@[to_additive (attr := elab_as_elim) "Recursor for free additive semigroup using `of` and `+`."]
-- Porting note: added noncomputable
protected noncomputable def recOnMul {C : FreeSemigroup α → Sort l} (x) (ih1 : ∀ x, C (of x))
    (ih2 : ∀ x y, C (of x) → C y → C (of x * y)) : C x :=
      FreeSemigroup.recOn x fun f s ↦
      List.recOn s ih1 (fun hd tl ih f ↦ ih2 f ⟨hd, tl⟩ (ih1 f) (ih hd)) f
#align free_semigroup.rec_on_mul FreeSemigroup.recOnMul

@[to_additive (attr := ext 1100)]
theorem hom_ext {β : Type v} [Mul β] {f g : FreeSemigroup α →ₙ* β} (h : f ∘ of = g ∘ of) : f = g :=
  (FunLike.ext _ _) fun x ↦
    FreeSemigroup.recOnMul x (congr_fun h) fun x y hx hy ↦ by simp only [map_mul, *]
#align free_semigroup.hom_ext FreeSemigroup.hom_ext

section lift

variable {β : Type v} [Semigroup β] (f : α → β)

/-- Lifts a function `α → β` to a semigroup homomorphism `FreeSemigroup α → β` given
a semigroup `β`. -/
@[to_additive (attr := simps symm_apply) "Lifts a function `α → β` to an additive semigroup
homomorphism `FreeAddSemigroup α → β` given an additive semigroup `β`."]
def lift : (α → β) ≃ (FreeSemigroup α →ₙ* β) where
  toFun f :=
    { toFun := fun x ↦ x.2.foldl (fun a b ↦ a * f b) (f x.1)
      map_mul' := fun x y ↦ by
        simp only [head_mul, tail_mul, ← List.foldl_map f, List.foldl_append, List.foldl_cons,
          List.foldl_assoc] }
  invFun f := f ∘ of
  left_inv f := rfl
  right_inv f := hom_ext rfl
#align free_semigroup.lift FreeSemigroup.lift

@[to_additive (attr := simp)]
theorem lift_of (x : α) : lift f (of x) = f x := rfl
#align free_semigroup.lift_of FreeSemigroup.lift_of

@[to_additive (attr := simp)]
theorem lift_comp_of : lift f ∘ of = f := rfl
#align free_semigroup.lift_comp_of FreeSemigroup.lift_comp_of

@[to_additive (attr := simp)]
theorem lift_comp_of' (f : FreeSemigroup α →ₙ* β) : lift (f ∘ of) = f := hom_ext rfl
#align free_semigroup.lift_comp_of' FreeSemigroup.lift_comp_of'

@[to_additive]
theorem lift_of_mul (x y) : lift f (of x * y) = f x * lift f y := by rw [map_mul, lift_of]
#align free_semigroup.lift_of_mul FreeSemigroup.lift_of_mul

end lift

section Map

variable {β : Type v} (f : α → β)

/-- The unique semigroup homomorphism that sends `of x` to `of (f x)`. -/
@[to_additive "The unique additive semigroup homomorphism that sends `of x` to `of (f x)`."]
def map : FreeSemigroup α →ₙ* FreeSemigroup β :=
  lift <| of ∘ f
#align free_semigroup.map FreeSemigroup.map

@[to_additive (attr := simp)]
theorem map_of (x) : map f (of x) = of (f x) := rfl
#align free_semigroup.map_of FreeSemigroup.map_of

@[to_additive (attr := simp)]
theorem length_map (x) : (map f x).length = x.length :=
  FreeSemigroup.recOnMul x (fun x ↦ rfl) (fun x y hx hy ↦ by simp only [map_mul, length_mul, *])
#align free_semigroup.length_map FreeSemigroup.length_map

end Map

section Category

variable {β : Type u}

@[to_additive]
instance : Monad FreeSemigroup where
  pure := of
  bind x f := lift f x

/-- Recursor that uses `pure` instead of `of`. -/
@[to_additive (attr := elab_as_elim) "Recursor that uses `pure` instead of `of`."]
-- Porting note: added noncomputable
noncomputable def recOnPure {C : FreeSemigroup α → Sort l} (x) (ih1 : ∀ x, C (pure x))
    (ih2 : ∀ x y, C (pure x) → C y → C (pure x * y)) : C x :=
  FreeSemigroup.recOnMul x ih1 ih2
#align free_semigroup.rec_on_pure FreeSemigroup.recOnPure

-- Porting note: dsimp can not prove this
@[to_additive (attr := simp, nolint simpNF)]
theorem map_pure (f : α → β) (x) : (f <$> pure x : FreeSemigroup β) = pure (f x) := rfl
#align free_semigroup.map_pure FreeSemigroup.map_pure

@[to_additive (attr := simp)]
theorem map_mul' (f : α → β) (x y : FreeSemigroup α) : f <$> (x * y) = f <$> x * f <$> y :=
  map_mul (map f) _ _
#align free_semigroup.map_mul' FreeSemigroup.map_mul'

-- Porting note: dsimp can not prove this
@[to_additive (attr := simp, nolint simpNF)]
theorem pure_bind (f : α → FreeSemigroup β) (x) : pure x >>= f = f x := rfl
#align free_semigroup.pure_bind FreeSemigroup.pure_bind

@[to_additive (attr := simp)]
theorem mul_bind (f : α → FreeSemigroup β) (x y : FreeSemigroup α) :
    x * y >>= f = (x >>= f) * (y >>= f) := map_mul (lift f) _ _
#align free_semigroup.mul_bind FreeSemigroup.mul_bind

@[to_additive (attr := simp)]
theorem pure_seq {f : α → β} {x : FreeSemigroup α} : pure f <*> x = f <$> x := rfl
#align free_semigroup.pure_seq FreeSemigroup.pure_seq

@[to_additive (attr := simp)]
theorem mul_seq {f g : FreeSemigroup (α → β)} {x : FreeSemigroup α} :
    f * g <*> x = (f <*> x) * (g <*> x) := mul_bind _ _ _
#align free_semigroup.mul_seq FreeSemigroup.mul_seq

@[to_additive]
instance : LawfulMonad FreeSemigroup.{u} := LawfulMonad.mk'
  (pure_bind := fun _ _ ↦ rfl)
  (bind_assoc := fun x g f ↦
    recOnPure x (fun x ↦ rfl) fun x y ih1 ih2 ↦ by rw [mul_bind, mul_bind, mul_bind, ih1, ih2])
  (id_map := fun x ↦ recOnPure x (fun _ ↦ rfl) fun x y ih1 ih2 ↦ by rw [map_mul', ih1, ih2])

/-- `FreeSemigroup` is traversable. -/
@[to_additive "`FreeAddSemigroup` is traversable."]
-- Porting note: added noncomputable
protected noncomputable def traverse {m : Type u → Type u} [Applicative m] {α β : Type u}
    (F : α → m β) (x : FreeSemigroup α) : m (FreeSemigroup β) :=
  recOnPure x (fun x ↦ pure <$> F x) fun _x _y ihx ihy ↦ (· * ·) <$> ihx <*> ihy
#align free_semigroup.traverse FreeSemigroup.traverse

@[to_additive]
-- Porting note: added noncomputable
noncomputable instance : Traversable FreeSemigroup := ⟨@FreeSemigroup.traverse⟩

variable {m : Type u → Type u} [Applicative m] (F : α → m β)

@[to_additive (attr := simp)]
theorem traverse_pure (x) : traverse F (pure x : FreeSemigroup α) = pure <$> F x := rfl
#align free_semigroup.traverse_pure FreeSemigroup.traverse_pure

@[to_additive (attr := simp)]
theorem traverse_pure' : traverse F ∘ pure = fun x ↦ (pure <$> F x : m (FreeSemigroup β)) := rfl
#align free_semigroup.traverse_pure' FreeSemigroup.traverse_pure'

section

variable [LawfulApplicative m]

@[to_additive (attr := simp)]
theorem traverse_mul (x y : FreeSemigroup α) :
    traverse F (x * y) = (· * ·) <$> traverse F x <*> traverse F y :=
  let ⟨x, L1⟩ := x
  let ⟨y, L2⟩ := y
  List.recOn L1 (fun x ↦ rfl)
    (fun hd tl ih x ↦ show
        (· * ·) <$> pure <$> F x <*> traverse F (mk hd tl * mk y L2) =
          (· * ·) <$> ((· * ·) <$> pure <$> F x <*> traverse F (mk hd tl)) <*> traverse F (mk y L2)
        by rw [ih] ; simp only [(· ∘ ·), (mul_assoc _ _ _).symm, functor_norm])
    x
#align free_semigroup.traverse_mul FreeSemigroup.traverse_mul

@[to_additive (attr := simp)]
theorem traverse_mul' :
    Function.comp (traverse F) ∘ @Mul.mul (FreeSemigroup α) _ = fun x y ↦
      (· * ·) <$> traverse F x <*> traverse F y := funext fun x ↦ funext fun y ↦ traverse_mul F x y
#align free_semigroup.traverse_mul' FreeSemigroup.traverse_mul'

end

@[to_additive (attr := simp)]
theorem traverse_eq (x) : FreeSemigroup.traverse F x = traverse F x := rfl
#align free_semigroup.traverse_eq FreeSemigroup.traverse_eq

-- Porting note: dsimp can not prove this
@[to_additive (attr := simp, nolint simpNF)]
theorem mul_map_seq (x y : FreeSemigroup α) :
    ((· * ·) <$> x <*> y : Id (FreeSemigroup α)) = (x * y : FreeSemigroup α) := rfl
#align free_semigroup.mul_map_seq FreeSemigroup.mul_map_seq

-- Porting note: Added noncomputable
@[to_additive]
noncomputable instance : IsLawfulTraversable FreeSemigroup.{u} :=
  { instLawfulMonadFreeSemigroupInstMonadFreeSemigroup with
    id_traverse := fun x ↦
      FreeSemigroup.recOnMul x (fun x ↦ rfl) fun x y ih1 ih2 ↦ by
        rw [traverse_mul, ih1, ih2, mul_map_seq]
    comp_traverse := fun f g x ↦
      recOnPure x (fun x ↦ by simp only [traverse_pure, functor_norm, (. ∘ .)])
        fun x y ih1 ih2 ↦ by (rw [traverse_mul, ih1, ih2,
          traverse_mul, Functor.Comp.map_mk]; simp only [Function.comp, functor_norm, traverse_mul])
    naturality := fun η α β f x ↦
      recOnPure x (fun x ↦ by simp only [traverse_pure, functor_norm, Function.comp])
          (fun x y ih1 ih2 ↦ by simp only [traverse_mul, functor_norm, ih1, ih2])
    traverse_eq_map_id := fun f x ↦
      FreeSemigroup.recOnMul x (fun _ ↦ rfl) fun x y ih1 ih2 ↦ by
        rw [traverse_mul, ih1, ih2, map_mul', mul_map_seq]; rfl }

end Category

@[to_additive]
instance [DecidableEq α] : DecidableEq (FreeSemigroup α) :=
  fun _ _ ↦ decidable_of_iff' _ (FreeSemigroup.ext_iff _ _)

end FreeSemigroup

namespace FreeMagma

variable {α : Type u} {β : Type v}

/-- The canonical multiplicative morphism from `FreeMagma α` to `FreeSemigroup α`. -/
@[to_additive "The canonical additive morphism from `FreeAddMagma α` to `FreeAddSemigroup α`."]
def toFreeSemigroup : FreeMagma α →ₙ* FreeSemigroup α := FreeMagma.lift FreeSemigroup.of
#align free_magma.to_free_semigroup FreeMagma.toFreeSemigroup

@[to_additive (attr := simp)]
theorem toFreeSemigroup_of (x : α) : toFreeSemigroup (of x) = FreeSemigroup.of x := rfl
#align free_magma.to_free_semigroup_of FreeMagma.toFreeSemigroup_of

@[to_additive (attr := simp)]
theorem toFreeSemigroup_comp_of : @toFreeSemigroup α ∘ of = FreeSemigroup.of := rfl
#align free_magma.to_free_semigroup_comp_of FreeMagma.toFreeSemigroup_comp_of

@[to_additive]
theorem toFreeSemigroup_comp_map (f : α → β) :
    toFreeSemigroup.comp (map f) = (FreeSemigroup.map f).comp toFreeSemigroup :=
  by ext1; rfl
#align free_magma.to_free_semigroup_comp_map FreeMagma.toFreeSemigroup_comp_map

@[to_additive]
theorem toFreeSemigroup_map (f : α → β) (x : FreeMagma α) :
    toFreeSemigroup (map f x) = FreeSemigroup.map f (toFreeSemigroup x) :=
  FunLike.congr_fun (toFreeSemigroup_comp_map f) x
#align free_magma.to_free_semigroup_map FreeMagma.toFreeSemigroup_map

@[to_additive (attr := simp)]
theorem length_toFreeSemigroup (x : FreeMagma α) : (toFreeSemigroup x).length = x.length :=
  FreeMagma.recOnMul x (fun x ↦ rfl) fun x y hx hy ↦ by
    rw [map_mul, FreeSemigroup.length_mul, hx, hy]; rfl
#align free_magma.length_to_free_semigroup FreeMagma.length_toFreeSemigroup

end FreeMagma

/-- Isomorphism between `Magma.AssocQuotient (FreeMagma α)` and `FreeSemigroup α`. -/
@[to_additive "Isomorphism between `AddMagma.AssocQuotient (FreeAddMagma α)` and
`FreeAddSemigroup α`."]
def FreeMagmaAssocQuotientEquiv (α : Type u) :
    Magma.AssocQuotient (FreeMagma α) ≃* FreeSemigroup α :=
      (Magma.AssocQuotient.lift FreeMagma.toFreeSemigroup).toMulEquiv
      (FreeSemigroup.lift (Magma.AssocQuotient.of ∘ FreeMagma.of))
      (by ext; rfl)
      (by ext1; rfl)
#align free_magma_assoc_quotient_equiv FreeMagmaAssocQuotientEquiv


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.limits.preserves.limits

/-!
# (Co)limits in functor categories.

We show that if `D` has limits, then the functor category `C ⥤ D` also has limits
(`category_theory.limits.functor_category_has_limits`),
and the evaluation functors preserve limits
(`category_theory.limits.evaluation_preserves_limits`)
(and similarly for colimits).

We also show that `F : D ⥤ K ⥤ C` preserves (co)limits if it does so for each `k : K`
(`category_theory.limits.preserves_limits_of_evaluation` and
`category_theory.limits.preserves_colimits_of_evaluation`).
-/

open category_theory category_theory.category

-- morphism levels before object levels. See note [category_theory universes].
universes v₁ v₂ u₁ u₂ v v' u u'

namespace category_theory.limits

variables {C : Type u} [category.{v} C] {D : Type u'} [category.{v'} D]

variables {J : Type u₁} [category.{v₁} J] {K : Type u₂} [category.{v₂} K]

@[simp, reassoc]
lemma limit.lift_π_app (H : J ⥤ K ⥤ C) [has_limit H] (c : cone H) (j : J) (k : K) :
  (limit.lift H c).app k ≫ (limit.π H j).app k = (c.π.app j).app k :=
congr_app (limit.lift_π c j) k

@[simp, reassoc]
lemma colimit.ι_desc_app (H : J ⥤ K ⥤ C) [has_colimit H] (c : cocone H) (j : J) (k : K) :
  (colimit.ι H j).app k ≫ (colimit.desc H c).app k = (c.ι.app j).app k :=
congr_app (colimit.ι_desc c j) k

/--
The evaluation functors jointly reflect limits: that is, to show a cone is a limit of `F`
it suffices to show that each evaluation cone is a limit. In other words, to prove a cone is
limiting you can show it's pointwise limiting.
-/
def evaluation_jointly_reflects_limits {F : J ⥤ K ⥤ C} (c : cone F)
  (t : Π (k : K), is_limit (((evaluation K C).obj k).map_cone c)) : is_limit c :=
{ lift := λ s,
  { app := λ k, (t k).lift ⟨s.X.obj k, whisker_right s.π ((evaluation K C).obj k)⟩,
    naturality' := λ X Y f, (t Y).hom_ext $ λ j,
    begin
      rw [assoc, (t Y).fac _ j],
      simpa using
        ((t X).fac_assoc ⟨s.X.obj X, whisker_right s.π ((evaluation K C).obj X)⟩ j _).symm,
    end },
  fac' := λ s j, nat_trans.ext _ _ $ funext $ λ k, (t k).fac _ j,
  uniq' := λ s m w, nat_trans.ext _ _ $ funext $ λ x, (t x).hom_ext $ λ j,
      (congr_app (w j) x).trans
        ((t x).fac ⟨s.X.obj _, whisker_right s.π ((evaluation K C).obj _)⟩ j).symm }

/--
Given a functor `F` and a collection of limit cones for each diagram `X ↦ F X k`, we can stitch
them together to give a cone for the diagram `F`.
`combined_is_limit` shows that the new cone is limiting, and `eval_combined` shows it is
(essentially) made up of the original cones.
-/
@[simps] def combine_cones (F : J ⥤ K ⥤ C) (c : Π (k : K), limit_cone (F.flip.obj k)) :
  cone F :=
{ X :=
  { obj := λ k, (c k).cone.X,
    map := λ k₁ k₂ f, (c k₂).is_limit.lift ⟨_, (c k₁).cone.π ≫ F.flip.map f⟩,
    map_id' := λ k, (c k).is_limit.hom_ext (λ j, by { dsimp, simp }),
    map_comp' := λ k₁ k₂ k₃ f₁ f₂, (c k₃).is_limit.hom_ext (λ j, by simp) },
  π :=
  { app := λ j, { app := λ k, (c k).cone.π.app j },
    naturality' := λ j₁ j₂ g, nat_trans.ext _ _ $ funext $ λ k, (c k).cone.π.naturality g } }

/-- The stitched together cones each project down to the original given cones (up to iso). -/
def evaluate_combined_cones (F : J ⥤ K ⥤ C) (c : Π (k : K), limit_cone (F.flip.obj k)) (k : K) :
  ((evaluation K C).obj k).map_cone (combine_cones F c) ≅ (c k).cone :=
cones.ext (iso.refl _) (by tidy)

/-- Stitching together limiting cones gives a limiting cone. -/
def combined_is_limit (F : J ⥤ K ⥤ C) (c : Π (k : K), limit_cone (F.flip.obj k)) :
  is_limit (combine_cones F c) :=
evaluation_jointly_reflects_limits _
  (λ k, (c k).is_limit.of_iso_limit (evaluate_combined_cones F c k).symm)

/--
The evaluation functors jointly reflect colimits: that is, to show a cocone is a colimit of `F`
it suffices to show that each evaluation cocone is a colimit. In other words, to prove a cocone is
colimiting you can show it's pointwise colimiting.
-/
def evaluation_jointly_reflects_colimits {F : J ⥤ K ⥤ C} (c : cocone F)
  (t : Π (k : K), is_colimit (((evaluation K C).obj k).map_cocone c)) : is_colimit c :=
{ desc := λ s,
  { app := λ k, (t k).desc ⟨s.X.obj k, whisker_right s.ι ((evaluation K C).obj k)⟩,
    naturality' := λ X Y f, (t X).hom_ext $ λ j,
    begin
      rw [(t X).fac_assoc _ j],
      erw ← (c.ι.app j).naturality_assoc f,
      erw (t Y).fac ⟨s.X.obj _, whisker_right s.ι _⟩ j,
      dsimp,
      simp,
    end },
  fac' := λ s j, nat_trans.ext _ _ $ funext $ λ k, (t k).fac _ j,
  uniq' := λ s m w, nat_trans.ext _ _ $ funext $ λ x, (t x).hom_ext $ λ j,
      (congr_app (w j) x).trans
        ((t x).fac ⟨s.X.obj _, whisker_right s.ι ((evaluation K C).obj _)⟩ j).symm }

/--
Given a functor `F` and a collection of colimit cocones for each diagram `X ↦ F X k`, we can stitch
them together to give a cocone for the diagram `F`.
`combined_is_colimit` shows that the new cocone is colimiting, and `eval_combined` shows it is
(essentially) made up of the original cocones.
-/
@[simps] def combine_cocones (F : J ⥤ K ⥤ C) (c : Π (k : K), colimit_cocone (F.flip.obj k)) :
  cocone F :=
{ X :=
  { obj := λ k, (c k).cocone.X,
    map := λ k₁ k₂ f, (c k₁).is_colimit.desc ⟨_, F.flip.map f ≫ (c k₂).cocone.ι⟩,
    map_id' := λ k, (c k).is_colimit.hom_ext (λ j, by { dsimp, simp }),
    map_comp' := λ k₁ k₂ k₃ f₁ f₂, (c k₁).is_colimit.hom_ext (λ j, by simp) },
  ι :=
  { app := λ j, { app := λ k, (c k).cocone.ι.app j },
    naturality' := λ j₁ j₂ g, nat_trans.ext _ _ $ funext $ λ k, (c k).cocone.ι.naturality g } }

/-- The stitched together cocones each project down to the original given cocones (up to iso). -/
def evaluate_combined_cocones
  (F : J ⥤ K ⥤ C) (c : Π (k : K), colimit_cocone (F.flip.obj k)) (k : K) :
  ((evaluation K C).obj k).map_cocone (combine_cocones F c) ≅ (c k).cocone :=
cocones.ext (iso.refl _) (by tidy)

/-- Stitching together colimiting cocones gives a colimiting cocone. -/
def combined_is_colimit (F : J ⥤ K ⥤ C) (c : Π (k : K), colimit_cocone (F.flip.obj k)) :
  is_colimit (combine_cocones F c) :=
evaluation_jointly_reflects_colimits _
  (λ k, (c k).is_colimit.of_iso_colimit (evaluate_combined_cocones F c k).symm)

noncomputable theory

instance functor_category_has_limits_of_shape
  [has_limits_of_shape J C] : has_limits_of_shape J (K ⥤ C) :=
{ has_limit := λ F, has_limit.mk
  { cone := combine_cones F (λ k, get_limit_cone _),
    is_limit := combined_is_limit _ _ } }

instance functor_category_has_colimits_of_shape
  [has_colimits_of_shape J C] : has_colimits_of_shape J (K ⥤ C) :=
{ has_colimit := λ F, has_colimit.mk
  { cocone := combine_cocones _ (λ k, get_colimit_cocone _),
    is_colimit := combined_is_colimit _ _ } }

instance functor_category_has_limits_of_size [has_limits_of_size.{v₁ u₁} C] :
  has_limits_of_size.{v₁ u₁} (K ⥤ C) := ⟨infer_instance⟩

instance functor_category_has_colimits_of_size [has_colimits_of_size.{v₁ u₁} C] :
  has_colimits_of_size.{v₁ u₁} (K ⥤ C) := ⟨infer_instance⟩

instance evaluation_preserves_limits_of_shape [has_limits_of_shape J C] (k : K) :
  preserves_limits_of_shape J ((evaluation K C).obj k) :=
{ preserves_limit :=
  λ F, preserves_limit_of_preserves_limit_cone (combined_is_limit _ _) $
    is_limit.of_iso_limit (limit.is_limit _)
      (evaluate_combined_cones F _ k).symm }

/--
If `F : J ⥤ K ⥤ C` is a functor into a functor category which has a limit,
then the evaluation of that limit at `k` is the limit of the evaluations of `F.obj j` at `k`.
-/
def limit_obj_iso_limit_comp_evaluation [has_limits_of_shape J C] (F : J ⥤ K ⥤ C) (k : K) :
  (limit F).obj k ≅ limit (F ⋙ ((evaluation K C).obj k)) :=
preserves_limit_iso ((evaluation K C).obj k) F

@[simp, reassoc]
lemma limit_obj_iso_limit_comp_evaluation_hom_π
  [has_limits_of_shape J C] (F : J ⥤ (K ⥤ C)) (j : J) (k : K) :
  (limit_obj_iso_limit_comp_evaluation F k).hom ≫ limit.π (F ⋙ ((evaluation K C).obj k)) j =
    (limit.π F j).app k :=
begin
  dsimp [limit_obj_iso_limit_comp_evaluation],
  simp,
end

@[simp, reassoc]
lemma limit_obj_iso_limit_comp_evaluation_inv_π_app
  [has_limits_of_shape J C] (F : J ⥤ (K ⥤ C)) (j : J) (k : K):
  (limit_obj_iso_limit_comp_evaluation F k).inv ≫ (limit.π F j).app k =
    limit.π (F ⋙ ((evaluation K C).obj k)) j :=
begin
  dsimp [limit_obj_iso_limit_comp_evaluation],
  rw iso.inv_comp_eq,
  simp,
end

@[simp, reassoc]
lemma limit_map_limit_obj_iso_limit_comp_evaluation_hom
  [has_limits_of_shape J C] {i j : K} (F : J ⥤ K ⥤ C) (f : i ⟶ j) :
  (limit F).map f ≫ (limit_obj_iso_limit_comp_evaluation _ _).hom =
  (limit_obj_iso_limit_comp_evaluation _ _).hom ≫
  lim_map (whisker_left _ ((evaluation _ _).map f)) :=
by { ext, dsimp, simp }

@[simp, reassoc]
lemma limit_obj_iso_limit_comp_evaluation_inv_limit_map
  [has_limits_of_shape J C] {i j : K} (F : J ⥤ K ⥤ C) (f : i ⟶ j) :
  (limit_obj_iso_limit_comp_evaluation _ _).inv ≫ (limit F).map f =
  lim_map (whisker_left _ ((evaluation _ _).map f)) ≫
  (limit_obj_iso_limit_comp_evaluation _ _).inv :=
by rw [iso.inv_comp_eq, ← category.assoc, iso.eq_comp_inv,
  limit_map_limit_obj_iso_limit_comp_evaluation_hom]

@[ext]
lemma limit_obj_ext {H : J ⥤ K ⥤ C} [has_limits_of_shape J C]
  {k : K} {W : C} {f g : W ⟶ (limit H).obj k}
  (w : ∀ j, f ≫ (limits.limit.π H j).app k = g ≫ (limits.limit.π H j).app k) : f = g :=
begin
  apply (cancel_mono (limit_obj_iso_limit_comp_evaluation H k).hom).1,
  ext,
  simpa using w j,
end

instance evaluation_preserves_colimits_of_shape [has_colimits_of_shape J C] (k : K) :
  preserves_colimits_of_shape J ((evaluation K C).obj k) :=
{ preserves_colimit :=
  λ F, preserves_colimit_of_preserves_colimit_cocone (combined_is_colimit _ _) $
    is_colimit.of_iso_colimit (colimit.is_colimit _)
      (evaluate_combined_cocones F _ k).symm }

/--
If `F : J ⥤ K ⥤ C` is a functor into a functor category which has a colimit,
then the evaluation of that colimit at `k` is the colimit of the evaluations of `F.obj j` at `k`.
-/
def colimit_obj_iso_colimit_comp_evaluation [has_colimits_of_shape J C] (F : J ⥤ K ⥤ C) (k : K) :
  (colimit F).obj k ≅ colimit (F ⋙ ((evaluation K C).obj k)) :=
preserves_colimit_iso ((evaluation K C).obj k) F

@[simp, reassoc]
lemma colimit_obj_iso_colimit_comp_evaluation_ι_inv
  [has_colimits_of_shape J C] (F : J ⥤ (K ⥤ C)) (j : J) (k : K) :
  colimit.ι (F ⋙ ((evaluation K C).obj k)) j ≫ (colimit_obj_iso_colimit_comp_evaluation F k).inv =
    (colimit.ι F j).app k :=
begin
  dsimp [colimit_obj_iso_colimit_comp_evaluation],
  simp,
end

@[simp, reassoc]
lemma colimit_obj_iso_colimit_comp_evaluation_ι_app_hom
  [has_colimits_of_shape J C] (F : J ⥤ (K ⥤ C)) (j : J) (k : K) :
  (colimit.ι F j).app k ≫ (colimit_obj_iso_colimit_comp_evaluation F k).hom =
     colimit.ι (F ⋙ ((evaluation K C).obj k)) j :=
begin
  dsimp [colimit_obj_iso_colimit_comp_evaluation],
  rw ←iso.eq_comp_inv,
  simp,
end

@[simp, reassoc]
lemma colimit_obj_iso_colimit_comp_evaluation_inv_colimit_map
  [has_colimits_of_shape J C] (F : J ⥤ K ⥤ C) {i j : K} (f : i ⟶ j) :
  (colimit_obj_iso_colimit_comp_evaluation _ _).inv ≫ (colimit F).map f =
  colim_map (whisker_left _ ((evaluation _ _).map f)) ≫
  (colimit_obj_iso_colimit_comp_evaluation _ _).inv :=
by { ext, dsimp, simp }

@[simp, reassoc]
lemma colimit_map_colimit_obj_iso_colimit_comp_evaluation_hom
  [has_colimits_of_shape J C] (F : J ⥤ K ⥤ C) {i j : K} (f : i ⟶ j) :
  (colimit F).map f ≫ (colimit_obj_iso_colimit_comp_evaluation _ _).hom =
  (colimit_obj_iso_colimit_comp_evaluation _ _).hom ≫
  colim_map (whisker_left _ ((evaluation _ _).map f)) :=
by rw [← iso.inv_comp_eq, ← category.assoc, ← iso.eq_comp_inv,
  colimit_obj_iso_colimit_comp_evaluation_inv_colimit_map]

@[ext]
lemma colimit_obj_ext {H : J ⥤ K ⥤ C} [has_colimits_of_shape J C]
  {k : K} {W : C} {f g : (colimit H).obj k ⟶ W}
  (w : ∀ j, (colimit.ι H j).app k ≫ f = (colimit.ι H j).app k ≫ g) : f = g :=
begin
  apply (cancel_epi (colimit_obj_iso_colimit_comp_evaluation H k).inv).1,
  ext,
  simpa using w j,
end

instance evaluation_preserves_limits [has_limits C] (k : K) :
  preserves_limits ((evaluation K C).obj k) :=
{ preserves_limits_of_shape := λ J 𝒥, by resetI; apply_instance }

/-- `F : D ⥤ K ⥤ C` preserves the limit of some `G : J ⥤ D` if it does for each `k : K`. -/
def preserves_limit_of_evaluation (F : D ⥤ K ⥤ C) (G : J ⥤ D)
  (H : Π (k : K), preserves_limit G (F ⋙ (evaluation K C).obj k : D ⥤ C)) :
  preserves_limit G F := ⟨λ c hc,
begin
  apply evaluation_jointly_reflects_limits,
  intro X,
  haveI := H X,
  change is_limit ((F ⋙ (evaluation K C).obj X).map_cone c),
  exact preserves_limit.preserves hc,
end⟩

/-- `F : D ⥤ K ⥤ C` preserves limits of shape `J` if it does for each `k : K`. -/
def preserves_limits_of_shape_of_evaluation (F : D ⥤ K ⥤ C) (J : Type*) [category J]
  (H : Π (k : K), preserves_limits_of_shape J (F ⋙ (evaluation K C).obj k)) :
  preserves_limits_of_shape J F :=
⟨λ G, preserves_limit_of_evaluation F G (λ k, preserves_limits_of_shape.preserves_limit)⟩

/-- `F : D ⥤ K ⥤ C` preserves all limits if it does for each `k : K`. -/
def {w' w} preserves_limits_of_evaluation (F : D ⥤ K ⥤ C)
  (H : Π (k : K), preserves_limits_of_size.{w' w} (F ⋙ (evaluation K C).obj k)) :
  preserves_limits_of_size.{w' w} F :=
⟨λ L hL, by exactI preserves_limits_of_shape_of_evaluation
    F L (λ k, preserves_limits_of_size.preserves_limits_of_shape)⟩

instance evaluation_preserves_colimits [has_colimits C] (k : K) :
  preserves_colimits ((evaluation K C).obj k) :=
{ preserves_colimits_of_shape := λ J 𝒥, by resetI; apply_instance }

/-- `F : D ⥤ K ⥤ C` preserves the colimit of some `G : J ⥤ D` if it does for each `k : K`. -/
def preserves_colimit_of_evaluation (F : D ⥤ K ⥤ C) (G : J ⥤ D)
  (H : Π (k), preserves_colimit G (F ⋙ (evaluation K C).obj k)) : preserves_colimit G F := ⟨λ c hc,
begin
  apply evaluation_jointly_reflects_colimits,
  intro X,
  haveI := H X,
  change is_colimit ((F ⋙ (evaluation K C).obj X).map_cocone c),
  exact preserves_colimit.preserves hc,
end⟩

/-- `F : D ⥤ K ⥤ C` preserves all colimits of shape `J` if it does for each `k : K`. -/
def preserves_colimits_of_shape_of_evaluation (F : D ⥤ K ⥤ C) (J : Type*) [category J]
  (H : Π (k : K), preserves_colimits_of_shape J (F ⋙ (evaluation K C).obj k)) :
  preserves_colimits_of_shape J F :=
⟨λ G, preserves_colimit_of_evaluation F G (λ k, preserves_colimits_of_shape.preserves_colimit)⟩

/-- `F : D ⥤ K ⥤ C` preserves all colimits if it does for each `k : K`. -/
def {w' w} preserves_colimits_of_evaluation (F : D ⥤ K ⥤ C)
  (H : Π (k : K), preserves_colimits_of_size.{w' w} (F ⋙ (evaluation K C).obj k)) :
  preserves_colimits_of_size.{w' w} F :=
⟨λ L hL, by exactI preserves_colimits_of_shape_of_evaluation
    F L (λ k, preserves_colimits_of_size.preserves_colimits_of_shape)⟩
open category_theory.prod

/-- The limit of a diagram `F : J ⥤ K ⥤ C` is isomorphic to the functor given by
the individual limits on objects. -/
@[simps]
def limit_iso_flip_comp_lim [has_limits_of_shape J C] (F : J ⥤ K ⥤ C) :
  limit F ≅ F.flip ⋙ lim :=
nat_iso.of_components (limit_obj_iso_limit_comp_evaluation F) $ by tidy

/-- A variant of `limit_iso_flip_comp_lim` where the arguemnts of `F` are flipped. -/
@[simps]
def limit_flip_iso_comp_lim [has_limits_of_shape J C] (F : K ⥤ J ⥤ C) :
  limit F.flip ≅ F ⋙ lim :=
nat_iso.of_components (λ k,
  limit_obj_iso_limit_comp_evaluation F.flip k ≪≫
  has_limit.iso_of_nat_iso (flip_comp_evaluation _ _)) $ by tidy

/--
For a functor `G : J ⥤ K ⥤ C`, its limit `K ⥤ C` is given by `(G' : K ⥤ J ⥤ C) ⋙ lim`.
Note that this does not require `K` to be small.
-/
@[simps] def limit_iso_swap_comp_lim [has_limits_of_shape J C] (G : J ⥤ K ⥤ C) :
  limit G ≅ curry.obj (swap K J ⋙ uncurry.obj G) ⋙ lim :=
limit_iso_flip_comp_lim G ≪≫ iso_whisker_right (flip_iso_curry_swap_uncurry _) _

/-- The colimit of a diagram `F : J ⥤ K ⥤ C` is isomorphic to the functor given by
the individual colimits on objects. -/
@[simps]
def colimit_iso_flip_comp_colim [has_colimits_of_shape J C] (F : J ⥤ K ⥤ C) :
  colimit F ≅ F.flip ⋙ colim :=
nat_iso.of_components (colimit_obj_iso_colimit_comp_evaluation F) $ by tidy

/-- A variant of `colimit_iso_flip_comp_colim` where the arguemnts of `F` are flipped. -/
@[simps]
def colimit_flip_iso_comp_colim [has_colimits_of_shape J C] (F : K ⥤ J ⥤ C) :
  colimit F.flip ≅ F ⋙ colim :=
nat_iso.of_components (λ k,
  colimit_obj_iso_colimit_comp_evaluation _ _ ≪≫
  has_colimit.iso_of_nat_iso (flip_comp_evaluation _ _)) $ by tidy

/--
For a functor `G : J ⥤ K ⥤ C`, its colimit `K ⥤ C` is given by `(G' : K ⥤ J ⥤ C) ⋙ colim`.
Note that this does not require `K` to be small.
-/
@[simps]
def colimit_iso_swap_comp_colim [has_colimits_of_shape J C] (G : J ⥤ K ⥤ C) :
  colimit G ≅ curry.obj (swap K J ⋙ uncurry.obj G) ⋙ colim :=
colimit_iso_flip_comp_colim G ≪≫ iso_whisker_right (flip_iso_curry_swap_uncurry _) _

end category_theory.limits


/-
Copyright (c) 2018 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot, Johannes Hölzl

Hausdorff completions of uniform spaces.

The goal is to construct a left-adjoint to the inclusion of complete Hausdorff uniform spaces
into all uniform spaces. Any uniform space `α` gets a completion `completion α` and a morphism
(ie. uniformly continuous map) `completion : α → completion α` which solves the universal
mapping problem of factorizing morphisms from `α` to any complete Hausdorff uniform space `β`.
It means any uniformly continuous `f : α → β` gives rise to a unique morphism
`completion.map f : completion α → β` such that `f = completion.extension f ∘ completion α`.
Actually `completion.extension f` is defined for all maps from `α` to `β` but it has the desired
properties only if `f` is uniformly continuous.

Beware that `completion α` is not injective if `α` is not Hausdorff. But its image is always
dense. The adjoint functor acting on morphisms is then constructed by the usual abstract nonsense.
For every uniform spaces `α` and `β`, it turns `f : α → β` into a morphism
  `completion.map f : completion α → completion β`
such that
  `coe ∘ f = (completion.map f) ∘ coe`
provided `f` is uniformly continuous. This construction is compatible with composition.

In this file we introduce the following concepts:

* `Cauchy α` the uniform completion of the uniform space `α` (using Cauchy filters). These are not
  minimal filters.

* `completion α := quotient (separation_setoid (Cauchy α))` the Hausdorff completion.

This formalization is mostly based on
  N. Bourbaki: General Topology
  I. M. James: Topologies and Uniformities
From a slightly different perspective in order to reuse material in topology.uniform_space.basic.
-/
import data.set.basic data.set.function
import topology.uniform_space.uniform_embedding topology.uniform_space.separation

noncomputable theory
local attribute [instance] classical.prop_decidable
open filter set
universes u v w x

local notation `𝓤` := uniformity

/-- Space of Cauchy filters

This is essentially the completion of a uniform space. The embeddings are the neighbourhood filters.
This space is not minimal, the separated uniform space (i.e. quotiented on the intersection of all
entourages) is necessary for this.
-/
def Cauchy (α : Type u) [uniform_space α] : Type u := { f : filter α // cauchy f }

namespace Cauchy

section
parameters {α : Type u} [uniform_space α]
variables {β : Type v} {γ : Type w}
variables [uniform_space β] [uniform_space γ]

def gen (s : set (α × α)) : set (Cauchy α × Cauchy α) :=
{p | s ∈ filter.prod (p.1.val) (p.2.val) }

lemma monotone_gen : monotone gen :=
monotone_set_of $ assume p, @monotone_mem_sets (α×α) (filter.prod (p.1.val) (p.2.val))

private lemma symm_gen : map prod.swap ((𝓤 α).lift' gen) ≤ (𝓤 α).lift' gen :=
calc map prod.swap ((𝓤 α).lift' gen) =
  (𝓤 α).lift' (λs:set (α×α), {p | s ∈ filter.prod (p.2.val) (p.1.val) }) :
  begin
    delta gen,
    simp [map_lift'_eq, monotone_set_of, monotone_mem_sets,
          function.comp, image_swap_eq_preimage_swap]
  end
  ... ≤ (𝓤 α).lift' gen :
    uniformity_lift_le_swap
      (monotone_comp (monotone_set_of $ assume p,
        @monotone_mem_sets (α×α) ((filter.prod ((p.2).val) ((p.1).val)))) monotone_principal)
      begin
        have h := λ(p:Cauchy α×Cauchy α), @filter.prod_comm _ _ (p.2.val) (p.1.val),
        simp [function.comp, h],
        exact le_refl _
      end

private lemma comp_rel_gen_gen_subset_gen_comp_rel {s t : set (α×α)} : comp_rel (gen s) (gen t) ⊆
  (gen (comp_rel s t) : set (Cauchy α × Cauchy α)) :=
assume ⟨f, g⟩ ⟨h, h₁, h₂⟩,
let ⟨t₁, (ht₁ : t₁ ∈ f.val), t₂, (ht₂ : t₂ ∈ h.val), (h₁ : set.prod t₁ t₂ ⊆ s)⟩ :=
  mem_prod_iff.mp h₁ in
let ⟨t₃, (ht₃ : t₃ ∈ h.val), t₄, (ht₄ : t₄ ∈ g.val), (h₂ : set.prod t₃ t₄ ⊆ t)⟩ :=
  mem_prod_iff.mp h₂ in
have t₂ ∩ t₃ ∈ h.val,
  from inter_mem_sets ht₂ ht₃,
let ⟨x, xt₂, xt₃⟩ :=
  inhabited_of_mem_sets (h.property.left) this in
(filter.prod f.val g.val).sets_of_superset
  (prod_mem_prod ht₁ ht₄)
  (assume ⟨a, b⟩ ⟨(ha : a ∈ t₁), (hb : b ∈ t₄)⟩,
    ⟨x,
      h₁ (show (a, x) ∈ set.prod t₁ t₂, from ⟨ha, xt₂⟩),
      h₂ (show (x, b) ∈ set.prod t₃ t₄, from ⟨xt₃, hb⟩)⟩)

private lemma comp_gen :
  ((𝓤 α).lift' gen).lift' (λs, comp_rel s s) ≤ (𝓤 α).lift' gen :=
calc ((𝓤 α).lift' gen).lift' (λs, comp_rel s s) =
    (𝓤 α).lift' (λs, comp_rel (gen s) (gen s)) :
  begin
    rw [lift'_lift'_assoc],
    exact monotone_gen,
    exact (monotone_comp_rel monotone_id monotone_id)
  end
  ... ≤ (𝓤 α).lift' (λs, gen $ comp_rel s s) :
    lift'_mono' $ assume s hs, comp_rel_gen_gen_subset_gen_comp_rel
  ... = ((𝓤 α).lift' $ λs:set(α×α), comp_rel s s).lift' gen :
  begin
    rw [lift'_lift'_assoc],
    exact (monotone_comp_rel monotone_id monotone_id),
    exact monotone_gen
  end
  ... ≤ (𝓤 α).lift' gen : lift'_mono comp_le_uniformity (le_refl _)

instance : uniform_space (Cauchy α) :=
uniform_space.of_core
{ uniformity  := (𝓤 α).lift' gen,
  refl        := principal_le_lift' $ assume s hs ⟨a, b⟩ (a_eq_b : a = b),
    a_eq_b ▸ a.property.right hs,
  symm        := symm_gen,
  comp        := comp_gen }

theorem mem_uniformity {s : set (Cauchy α × Cauchy α)} :
  s ∈ 𝓤 (Cauchy α) ↔ ∃ t ∈ 𝓤 α, gen t ⊆ s :=
mem_lift'_sets monotone_gen

theorem mem_uniformity' {s : set (Cauchy α × Cauchy α)} :
  s ∈ 𝓤 (Cauchy α) ↔ ∃ t ∈ 𝓤 α,
    ∀ f g : Cauchy α, t ∈ filter.prod f.1 g.1 → (f, g) ∈ s :=
mem_uniformity.trans $ bex_congr $ λ t h, prod.forall

/-- Embedding of `α` into its completion -/
def pure_cauchy (a : α) : Cauchy α :=
⟨pure a, cauchy_pure⟩

lemma uniform_embedding_pure_cauchy : uniform_embedding (pure_cauchy : α → Cauchy α) :=
⟨assume a₁ a₂ h,
  have (pure_cauchy a₁).val = (pure_cauchy a₂).val, from congr_arg _ h,
  have {a₁} = ({a₂} : set α),
    from principal_eq_iff_eq.mp this,
  by simp at this; assumption,

  have (preimage (λ (x : α × α), (pure_cauchy (x.fst), pure_cauchy (x.snd))) ∘ gen) = id,
    from funext $ assume s, set.ext $ assume ⟨a₁, a₂⟩,
      by simp [preimage, gen, pure_cauchy, prod_principal_principal],
  calc comap (λ (x : α × α), (pure_cauchy (x.fst), pure_cauchy (x.snd))) ((𝓤 α).lift' gen)
        = (𝓤 α).lift' (preimage (λ (x : α × α), (pure_cauchy (x.fst), pure_cauchy (x.snd))) ∘ gen) :
      comap_lift'_eq monotone_gen
    ... = 𝓤 α : by simp [this]⟩

lemma pure_cauchy_dense : ∀x, x ∈ closure (range pure_cauchy) :=
assume f,
have h_ex : ∀ s ∈ 𝓤 (Cauchy α), ∃y:α, (f, pure_cauchy y) ∈ s, from
  assume s hs,
  let ⟨t'', ht''₁, (ht''₂ : gen t'' ⊆ s)⟩ := (mem_lift'_sets monotone_gen).mp hs in
  let ⟨t', ht'₁, ht'₂⟩ := comp_mem_uniformity_sets ht''₁ in
  have t' ∈ filter.prod (f.val) (f.val),
    from f.property.right ht'₁,
  let ⟨t, ht, (h : set.prod t t ⊆ t')⟩ := mem_prod_same_iff.mp this in
  let ⟨x, (hx : x ∈ t)⟩ := inhabited_of_mem_sets f.property.left ht in
  have t'' ∈ filter.prod f.val (pure x),
    from mem_prod_iff.mpr ⟨t, ht, {y:α | (x, y) ∈ t'},
      assume y, begin simp, intro h, simp [h], exact refl_mem_uniformity ht'₁ end,
      assume ⟨a, b⟩ ⟨(h₁ : a ∈ t), (h₂ : (x, b) ∈ t')⟩,
        ht'₂ $ prod_mk_mem_comp_rel (@h (a, x) ⟨h₁, hx⟩) h₂⟩,
  ⟨x, ht''₂ $ by dsimp [gen]; exact this⟩,
begin
  simp [closure_eq_nhds, nhds_eq_uniformity, lift'_inf_principal_eq, set.inter_comm],
  exact (lift'_neq_bot_iff $ monotone_inter monotone_const monotone_preimage).mpr
    (assume s hs,
      let ⟨y, hy⟩ := h_ex s hs in
      have pure_cauchy y ∈ range pure_cauchy ∩ {y : Cauchy α | (f, y) ∈ s},
        from ⟨mem_range_self y, hy⟩,
      ne_empty_of_mem this)
end

lemma dense_embedding_pure_cauchy : dense_embedding pure_cauchy :=
uniform_embedding_pure_cauchy.dense_embedding pure_cauchy_dense

lemma nonempty_Cauchy_iff : nonempty (Cauchy α) ↔ nonempty α :=
begin
  split ; rintro ⟨c⟩,
  { have := eq_univ_iff_forall.1 dense_embedding_pure_cauchy.closure_range c,
    have := mem_closure_iff.1 this _ is_open_univ trivial,
    rcases exists_mem_of_ne_empty this with ⟨_, ⟨_, a, _⟩⟩,
    exact ⟨a⟩ },
  { exact ⟨pure_cauchy c⟩ }
end

section
set_option eqn_compiler.zeta true
instance : complete_space (Cauchy α) :=
complete_space_extension
  uniform_embedding_pure_cauchy
  pure_cauchy_dense $
  assume f hf,
  let f' : Cauchy α := ⟨f, hf⟩ in
  have map pure_cauchy f ≤ (𝓤 $ Cauchy α).lift' (preimage (prod.mk f')),
    from le_lift' $ assume s hs,
    let ⟨t, ht₁, (ht₂ : gen t ⊆ s)⟩ := (mem_lift'_sets monotone_gen).mp hs in
    let ⟨t', ht', (h : set.prod t' t' ⊆ t)⟩ := mem_prod_same_iff.mp (hf.right ht₁) in
    have t' ⊆ { y : α | (f', pure_cauchy y) ∈ gen t },
      from assume x hx, (filter.prod f (pure x)).sets_of_superset (prod_mem_prod ht' $ mem_pure hx) h,
    f.sets_of_superset ht' $ subset.trans this (preimage_mono ht₂),
  ⟨f', by simp [nhds_eq_uniformity]; assumption⟩
end

instance [inhabited α] : inhabited (Cauchy α) :=
⟨pure_cauchy $ default α⟩

instance [h : nonempty α] : nonempty (Cauchy α) :=
h.rec_on $ assume a, nonempty.intro $ Cauchy.pure_cauchy a

section extend
variables [_root_.complete_space β] [separated β]

def extend (f : α → β) : (Cauchy α → β) :=
if uniform_continuous f then
  dense_embedding_pure_cauchy.extend f
else
  λ x, f (classical.inhabited_of_nonempty $ nonempty_Cauchy_iff.1 ⟨x⟩).default

lemma extend_pure_cauchy {f : α → β} (hf : uniform_continuous f) (a : α) :
  extend f (pure_cauchy a) = f a :=
begin
  rw [extend, if_pos hf],
  exact uniformly_extend_of_emb uniform_embedding_pure_cauchy pure_cauchy_dense _
end

lemma uniform_continuous_extend {f : α → β} : uniform_continuous (extend f) :=
begin
  by_cases hf : uniform_continuous f,
  { rw [extend, if_pos hf],
    exact uniform_continuous_uniformly_extend uniform_embedding_pure_cauchy pure_cauchy_dense hf },
  { rw [extend, if_neg hf],
    exact uniform_continuous_of_const (assume a b, by congr) }
end

end extend

end

theorem Cauchy_eq
  {α : Type*} [inhabited α] [uniform_space α] [complete_space α] [separated α] {f g : Cauchy α} :
  lim f.1 = lim g.1 ↔ (f, g) ∈ separation_rel (Cauchy α) :=
begin
  split,
  { intros e s hs,
    rcases Cauchy.mem_uniformity'.1 hs with ⟨t, tu, ts⟩,
    apply ts,
    rcases comp_mem_uniformity_sets tu with ⟨d, du, dt⟩,
    refine mem_prod_iff.2
      ⟨_, le_nhds_lim_of_cauchy f.2 (mem_nhds_right (lim f.1) du),
       _, le_nhds_lim_of_cauchy g.2 (mem_nhds_left (lim g.1) du), λ x h, _⟩,
    cases x with a b, cases h with h₁ h₂,
    rw ← e at h₂,
    exact dt ⟨_, h₁, h₂⟩ },
  { intros H,
    refine separated_def.1 (by apply_instance) _ _ (λ t tu, _),
    rcases mem_uniformity_is_closed tu with ⟨d, du, dc, dt⟩,
    refine H {p | (lim p.1.1, lim p.2.1) ∈ t}
      (Cauchy.mem_uniformity'.2 ⟨d, du, λ f g h, _⟩),
    rcases mem_prod_iff.1 h with ⟨x, xf, y, yg, h⟩,
    have limc : ∀ (f : Cauchy α) (x ∈ f.1), lim f.1 ∈ closure x,
    { intros f x xf,
      rw closure_eq_nhds,
      exact lattice.neq_bot_of_le_neq_bot f.2.1
        (lattice.le_inf (le_nhds_lim_of_cauchy f.2) (le_principal_iff.2 xf)) },
    have := (closure_subset_iff_subset_of_is_closed dc).2 h,
    rw closure_prod_eq at this,
    refine dt (this ⟨_, _⟩); dsimp; apply limc; assumption }
end

section
local attribute [instance] uniform_space.separation_setoid

lemma injective_separated_pure_cauchy {α : Type*} [uniform_space α] [s : separated α] :
  function.injective (λa:α, ⟦pure_cauchy a⟧) | a b h :=
separated_def.1 s _ _ $ assume s hs,
let ⟨t, ht, hts⟩ :=
  by rw [← (@uniform_embedding_pure_cauchy α _).right, filter.mem_comap_sets] at hs; exact hs in
have (pure_cauchy a, pure_cauchy b) ∈ t, from quotient.exact h t ht,
@hts (a, b) this

end

section prod
variables {α : Type*} {β : Type*} [uniform_space α] [uniform_space β]

def prod : Cauchy α × Cauchy β → Cauchy (α × β) :=
dense_embedding.extend (dense_embedding_pure_cauchy.prod dense_embedding_pure_cauchy) pure_cauchy

lemma prod_pure_cauchy_pure_cauchy (a : α) (b :β) :
  prod (pure_cauchy a, pure_cauchy b) = pure_cauchy (a, b) :=
uniformly_extend_of_emb
  (uniform_embedding_pure_cauchy.prod uniform_embedding_pure_cauchy)
  (dense_embedding_pure_cauchy.prod dense_embedding_pure_cauchy).dense
  (a, b)

lemma uniform_continuous_prod : uniform_continuous (@prod α β _ _) :=
uniform_continuous_uniformly_extend
  (uniform_embedding_pure_cauchy.prod uniform_embedding_pure_cauchy)
  (dense_embedding_pure_cauchy.prod dense_embedding_pure_cauchy).dense
  uniform_embedding_pure_cauchy.uniform_continuous

end prod

end Cauchy

local attribute [instance] uniform_space.separation_setoid

open Cauchy set

namespace uniform_space
variables (α : Type*) [uniform_space α]
variables {β : Type*} [uniform_space β]
variables {γ : Type*} [uniform_space γ]

instance complete_space_separation [h : complete_space α] :
  complete_space (quotient (separation_setoid α)) :=
⟨assume f, assume hf : cauchy f,
  have cauchy (f.comap (λx, ⟦x⟧)), from
    cauchy_comap comap_quotient_le_uniformity hf $
      comap_neq_bot_of_surj hf.left $ assume b, quotient.exists_rep _,
  let ⟨x, (hx : f.comap (λx, ⟦x⟧) ≤ nhds x)⟩ := complete_space.complete this in
  ⟨⟦x⟧, calc f = map (λx, ⟦x⟧) (f.comap (λx, ⟦x⟧)) :
      (map_comap $ univ_mem_sets' $ assume b, quotient.exists_rep _).symm
    ... ≤ map (λx, ⟦x⟧) (nhds x) : map_mono hx
    ... ≤ _ : continuous_iff_continuous_at.mp uniform_continuous_quotient_mk.continuous _⟩⟩

/-- Hausdorff completion of `α` -/
def completion := quotient (separation_setoid $ Cauchy α)

namespace completion

@[priority 50]
instance : uniform_space (completion α) := by dunfold completion ; apply_instance

instance : complete_space (completion α) := by dunfold completion ; apply_instance

instance : separated (completion α) := by dunfold completion ; apply_instance

instance : t2_space (completion α) := separated_t2

instance : regular_space (completion α) := separated_regular

/-- Automatic coercion from `α` to its completion. Not always injective. -/
instance : has_coe α (completion α) := ⟨quotient.mk ∘ pure_cauchy⟩

protected lemma coe_eq : (coe : α → completion α) = quotient.mk ∘ pure_cauchy := rfl

lemma uniform_continuous_coe : uniform_continuous (coe : α → completion α) :=
uniform_continuous.comp uniform_embedding_pure_cauchy.uniform_continuous
  uniform_continuous_quotient_mk

lemma continuous_coe : continuous (coe : α → completion α) :=
uniform_continuous.continuous (uniform_continuous_coe α)

lemma comap_coe_eq_uniformity :
  (𝓤 _).comap (λ(p:α×α), ((p.1 : completion α), (p.2 : completion α))) = 𝓤 α :=
begin
  have : (λx:α×α, ((x.1 : completion α), (x.2 : completion α))) =
    (λx:(Cauchy α)×(Cauchy α), (⟦x.1⟧, ⟦x.2⟧)) ∘ (λx:α×α, (pure_cauchy x.1, pure_cauchy x.2)),
  { ext ⟨a, b⟩; simp; refl },
  rw [this, ← filter.comap_comap_comp],
  change filter.comap _ (filter.comap _ (𝓤 $ quotient $ separation_setoid $ Cauchy α)) = 𝓤 α,
  rw [comap_quotient_eq_uniformity, uniform_embedding_pure_cauchy.2]
end

variable {α}

lemma dense : closure (range (coe : α → completion α)) = univ :=
by rw [completion.coe_eq, range_comp]; exact quotient_dense_of_dense pure_cauchy_dense

lemma dense_embedding_coe [separated α]: dense_embedding (coe : α → completion α) :=
(uniform_embedding_coe α).dense_embedding (assume x, by rw [dense]; exact mem_univ _)

lemma dense₂ : closure (range (λx:α × β, ((x.1 : completion α), (x.2 : completion β)))) = univ :=
by rw [← set.prod_range_range_eq, closure_prod_eq, dense, dense, univ_prod_univ]

lemma dense₃ :
  closure (range (λx:α × (β × γ), ((x.1 : completion α), ((x.2.1 : completion β), (x.2.2 : completion γ))))) = univ :=
let a : α → completion α := coe, bc := λp:β × γ, ((p.1 : completion β), (p.2 : completion γ)) in
show closure (range (λx:α × (β × γ), (a x.1, bc x.2))) = univ,
begin
  rw [← set.prod_range_range_eq, @closure_prod_eq _ _ _ _ (range a) (range bc), ← univ_prod_univ],
  congr,
  exact dense,
  exact dense₂
end

@[elab_as_eliminator]
lemma induction_on {p : completion α → Prop}
  (a : completion α) (hp : is_closed {a | p a}) (ih : ∀a:α, p a) : p a :=
is_closed_property dense hp ih a

@[elab_as_eliminator]
lemma induction_on₂ {p : completion α → completion β → Prop}
  (a : completion α) (b : completion β)
  (hp : is_closed {x : completion α × completion β | p x.1 x.2})
  (ih : ∀(a:α) (b:β), p a b) : p a b :=
have ∀x : completion α × completion β, p x.1 x.2, from
  is_closed_property dense₂ hp $ assume ⟨a, b⟩, ih a b,
this (a, b)

@[elab_as_eliminator]
lemma induction_on₃ {p : completion α → completion β → completion γ → Prop}
  (a : completion α) (b : completion β) (c : completion γ)
  (hp : is_closed {x : completion α × completion β × completion γ | p x.1 x.2.1 x.2.2})
  (ih : ∀(a:α) (b:β) (c:γ), p a b c) : p a b c :=
have ∀x : completion α × completion β × completion γ, p x.1 x.2.1 x.2.2, from
  is_closed_property dense₃ hp $ assume ⟨a, b, c⟩, ih a b c,
this (a, b, c)

@[elab_as_eliminator]
lemma induction_on₄ {δ : Type*} [uniform_space δ]
  {p : completion α → completion β → completion γ → completion δ → Prop}
  (a : completion α) (b : completion β) (c : completion γ) (d : completion δ)
  (hp : is_closed {x : (completion α × completion β) × (completion γ × completion δ) | p x.1.1 x.1.2 x.2.1 x.2.2})
  (ih : ∀(a:α) (b:β) (c:γ) (d : δ), p ↑a ↑b ↑c ↑d) : p a b c d :=
let
  ab := λp:α × β, ((p.1 : completion α), (p.2 : completion β)),
  cd := λp:γ × δ, ((p.1 : completion γ), (p.2 : completion δ))
in
have dense₄ : closure (range (λx:(α × β) × (γ × δ), (ab x.1, cd x.2))) = univ,
begin
  rw [← set.prod_range_range_eq, @closure_prod_eq _ _ _ _ (range ab) (range cd), ← univ_prod_univ],
  congr,
  exact dense₂,
  exact dense₂
end,
have ∀x:(completion α × completion β) × (completion γ × completion δ), p x.1.1 x.1.2 x.2.1 x.2.2, from
  is_closed_property dense₄ hp (assume p:(α×β)×(γ×δ), ih p.1.1 p.1.2 p.2.1 p.2.2),
this ((a, b), (c, d))

lemma ext [t2_space β] {f g : completion α → β} (hf : continuous f) (hg : continuous g)
  (h : ∀a:α, f a = g a) : f = g :=
funext $ assume a, completion.induction_on a (is_closed_eq hf hg) h

section extension
variables {f : α → β}
variables [complete_space β] [separated β]

/-- "Extension" to the completion. Based on `Cauchy.extend`, which is defined for any map `f` but
returns an arbitrary constant value if `f` is not uniformly continuous -/
protected def extension (f : α → β) : completion α → β :=
quotient.lift (extend f) $ assume a b,
  eq_of_separated_of_uniform_continuous uniform_continuous_extend

lemma uniform_continuous_extension : uniform_continuous (completion.extension f) :=
uniform_continuous_quotient_lift uniform_continuous_extend

lemma continuous_extension : continuous (completion.extension f) :=
uniform_continuous_extension.continuous

@[simp] lemma extension_coe (hf : uniform_continuous f) (a : α) : (completion.extension f) a = f a :=
extend_pure_cauchy hf a

end extension

section map
variables {f : α → β}

/-- Completion functor acting on morphisms -/
protected def map (f : α → β) : completion α → completion β :=
completion.extension (coe ∘ f)

lemma uniform_continuous_map : uniform_continuous (completion.map f) :=
uniform_continuous_quotient_lift uniform_continuous_extend

lemma continuous_map : continuous (completion.map f) :=
uniform_continuous_extension.continuous

@[simp] lemma map_coe (hf : uniform_continuous f) (a : α) : (completion.map f) a = f a :=
by rw [completion.map, extension_coe]; from hf.comp (uniform_continuous_coe β)

lemma map_unique {f : α → β} {g : completion α → completion β}
  (hg : uniform_continuous g) (h : ∀a:α, ↑(f a) = g a) : completion.map f = g :=
completion.ext continuous_map hg.continuous $
begin
  intro a,
  simp only [completion.map, (∘), h],
  rw [extension_coe ((uniform_continuous_coe α).comp hg)]
end

lemma map_id : completion.map (@id α) = id :=
map_unique uniform_continuous_id (assume a, rfl)

lemma extension_map [complete_space γ] [separated γ] {f : β → γ} {g : α → β}
  (hf : uniform_continuous f) (hg : uniform_continuous g) :
  completion.extension f ∘ completion.map g = completion.extension (f ∘ g) :=
completion.ext (continuous_map.comp continuous_extension) continuous_extension $
  by intro a; simp only [hg, hf, hg.comp hf, (∘), map_coe, extension_coe]

lemma map_comp {f : α → β} {g : β → γ} (hf : uniform_continuous f) (hg : uniform_continuous g) :
  completion.map g ∘ completion.map f = completion.map (g ∘ f) :=
extension_map (hg.comp (uniform_continuous_coe _)) hf

end map

/- In this section we construct isomorphisms between the completion of a uniform space and the
completion of its separation quotient -/
section separation_quotient_completion

def completion_separation_quotient_equiv (α : Type u) [uniform_space α] :
  completion (separation_quotient α) ≃ completion α :=
begin
  refine ⟨completion.extension (separation_quotient.lift (coe : α → completion α)),
    completion.map quotient.mk, _, _⟩,
  { assume a,
    refine completion.induction_on a (is_closed_eq (continuous_extension.comp continuous_map) continuous_id) _,
    rintros ⟨a⟩,
    show completion.map quotient.mk (completion.extension (separation_quotient.lift coe) ↑⟦a⟧) = ↑⟦a⟧,
    rw [extension_coe (separation_quotient.uniform_continuous_lift _),
      separation_quotient.lift_mk (uniform_continuous_coe α),
      completion.map_coe uniform_continuous_quotient_mk] },
  { assume a,
    refine completion.induction_on a (is_closed_eq (continuous_map.comp continuous_extension) continuous_id) _,
    assume a,
    rw [map_coe uniform_continuous_quotient_mk,
      extension_coe (separation_quotient.uniform_continuous_lift _),
      separation_quotient.lift_mk (uniform_continuous_coe α) _] }
end

lemma uniform_continuous_completion_separation_quotient_equiv :
  uniform_continuous ⇑(completion_separation_quotient_equiv α) :=
uniform_continuous_extension

lemma uniform_continuous_completion_separation_quotient_equiv_symm :
  uniform_continuous ⇑(completion_separation_quotient_equiv α).symm :=
uniform_continuous_map

end separation_quotient_completion

section prod
variables [uniform_space β]
protected def prod {α β} [uniform_space α] [uniform_space β] (p : completion α × completion β) : completion (α × β) :=
quotient.lift_on₂ p.1 p.2 (λa b, ⟦Cauchy.prod (a, b)⟧) $ assume a b c d hab hcd,
  quotient.sound $ separated_of_uniform_continuous uniform_continuous_prod $
  separation_prod.2 ⟨hab, hcd⟩

lemma uniform_continuous_prod : uniform_continuous (@completion.prod α β _ _) :=
uniform_continuous_quotient_lift₂ $
  suffices uniform_continuous (quotient.mk ∘ Cauchy.prod),
  { convert this, ext ⟨a, b⟩, refl },
  Cauchy.uniform_continuous_prod.comp uniform_continuous_quotient_mk

lemma prod_coe_coe (a : α) (b : β) :
  completion.prod ((a : completion α), (b : completion β)) = (a, b) :=
congr_arg quotient.mk $ Cauchy.prod_pure_cauchy_pure_cauchy a b

end prod

section map₂

protected def map₂ (f : α → β → γ) (a : completion α) (b : completion β) : completion γ :=
completion.map (λp:α×β, f p.1 p.2) (completion.prod (a, b))

lemma uniform_continuous_map₂' (f : α → β → γ) :
  uniform_continuous (λp:completion α×completion β, completion.map₂ f p.1 p.2) :=
uniform_continuous.comp uniform_continuous_prod completion.uniform_continuous_map

lemma continuous_map₂ {δ} [topological_space δ] {f : α → β → γ}
  {a : δ → completion α} {b : δ → completion β} (ha : continuous a) (hb : continuous b) :
  continuous (λd:δ, completion.map₂ f (a d) (b d)) :=
(continuous.prod_mk ha hb).comp (uniform_continuous_map₂' f).continuous

lemma map₂_coe_coe (a : α) (b : β) (f : α → β → γ) (hf : uniform_continuous (λp:α×β, f p.1 p.2)) :
  completion.map₂ f (a : completion α) (b : completion β) = f a b :=
by rw [completion.map₂, completion.prod_coe_coe, completion.map_coe hf]

end map₂
end completion
end uniform_space