-- TODO -- make ZFC namespace and promise that everything in the namespace only
-- mentions Type and never mentions universes.
-- TODO ask Mario how close this is to ZFC

-- TODO see how much of "transport" made it into mathlib
import data.equiv.basic
--import analysis.real
--#check ℝ -- Type
namespace zfc
-- I sometimes write
-- import canonical_isomorphism.zfc_canonical_isomorphism
-- open zfc
-- could replace with "import data.equiv"

-- TODO
-- ask about function overloading with equiv

/-
Copyright (c) 2018 Kevin Buzzard.
Released under Apache 2.0 license as described in the file LICENSE.
Author : Kevin Buzzard

Two types are said to be *canonically isomorphic* if a mathematician
trained in the dark arts of ZFC can replace one type by another without
any fear of disruption.

This is an interesting notion, because it is "one concept" in mathematics, and
yet seems to manifest itself in several different ways when one tries to formalise it
in Lean's Dependent Type Theory.
-/

-- universe zfc_u -- no point doing this -- just use Type
--#print extfun_app

-- Here is a notion from dependent type theory.
/-- `α ≃ β` is the type of functions from `α → β` with a two-sided inverse. -/
-- [Is that right? Is the inverse uniquely specified?]

variables {α β : Type}

--#print distrib

--class distrib (α : Type u) extends has_mul α, has_add α :=
--(left_distrib : ∀ a b c : α, a * (b + c) = (a * b) + (a * c))
--(right_distrib : ∀ a b c : α, (a + b) * c = (a * c) + (b * c))

--#print has_mul
--structure has_mul : Type u → Type u
--fields:
--has_mul.mul : Π {α : Type u} [c : has_mul α], α → α → α

--#print equiv
--structure zfc.equiv : Type zfc → Type zfc → Type zfc
--fields:
--zfc.equiv.to_fun : Π {α β : Type zfc}, equiv α β → α → β
--zfc.equiv.inv_fun : Π {α β : Type zfc}, equiv α β → β → α
--zfc.equiv.left_inv : ∀ {α β : Type zfc} (c : equiv α β), function.left_inverse (c.inv_fun) (c.to_fun)
--zfc.equiv.right_inv : ∀ {α β : Type zfc} (c : equiv α β), function.right_inverse (c.inv_fun) (c.to_fun)
structure equiv (α β : Type) : Type :=
(to_fun : α → β)
(inv_fun : β → α)
(left_inv : function.left_inverse inv_fun to_fun)
(right_inv : function.right_inverse inv_fun to_fun)

-- Was my definition of equiv OK?
structure inverse_exists (α β : Type) : Type :=
(to_fun : α → β)
(inv_exists : ∃ inv_fun : β → α, function.left_inverse inv_fun to_fun ∧
function.right_inverse inv_fun to_fun)

definition to_fun (α β) : equiv α β → inverse_exists α β := λ ⟨f,g,hfg,hgf⟩,⟨f,⟨g,⟨hfg,hgf⟩⟩⟩
noncomputable definition inv_fun (α β) : inverse_exists α β → equiv α β :=
λ invfn,
{
    to_fun := inverse_exists.to_fun invfn,
    inv_fun := classical.some invfn.inv_exists,
    left_inv := (classical.some_spec invfn.inv_exists).1,-- : ∀ (x : α), inv_fun_aux.val (to_fun x) = x),--begin unfold function.left_inverse, sorry end,
    right_inv := (classical.some_spec invfn.inv_exists).2,
  }

noncomputable theorem docstring_is_correct (α β : Type) : equiv (equiv α β) (inverse_exists α β) :=
{to_fun := to_fun α β,
 inv_fun := inv_fun α β,
 left_inv := λ x,begin cases x, unfold to_fun,unfold inv_fun,congr,
  let mess := (classical.indefinite_description
       (λ (inv_fun : β → α), function.left_inverse inv_fun x_to_fun ∧ function.right_inverse inv_fun x_to_fun)
       _),
  funext b,
  show mess.val b = x_inv_fun b,
  have H := mess.property,
  have idea : b = x_to_fun (x_inv_fun b),
    exact (x_right_inv b).symm,
  rw idea,
  rw H.1 _,
  rw x_left_inv,
 end,
 right_inv := begin
   intro x,
   cases x,refl,
 end
}

--#exit

-- has_mul is a structure not a class
definition equiv_mul {α β : Type} : equiv α β → equiv (has_mul α) (has_mul β) := λ E,
{ to_fun :=  λ αmul,⟨λ b1 b2, E.to_fun (@has_mul.mul α αmul (E.inv_fun b1) (E.inv_fun b2))⟩,
  inv_fun := λ βmul,⟨λ a1 a2, E.inv_fun (@has_mul.mul β βmul (E.to_fun a1) (E.to_fun a2))⟩, -- didn't I just write that?
                                                                                -- should we introduce E-dual?
  left_inv := λ f, begin
    unfold function.left_inverse,
    cases f,
    simp,
    suffices : (λ (a1 a2 : α), E.inv_fun (E.to_fun (f (E.inv_fun (E.to_fun a1)) (E.inv_fun (E.to_fun a2))))) = (λ a1 a2, f a1 a2),
      funext,
      congr,
      exact this,
    funext,
    rw [E.left_inv,E.left_inv,E.left_inv]
   end,
  right_inv := begin
    intro m,
    dsimp,
    cases m,
    congr,
    funext,
    rw [E.right_inv,E.right_inv,E.right_inv]
  end
}

-- distrib is not a functor at all.
--definition distrib_is_a_functor {α β : Type} : (α → β) → (distrib α) → (distrib β) := sorry (can't be proved)

-- The notions of equiv and isom might be "identified" in ZFC.
-- In dependent type theory, they are same, but we can easily move between them.
-- at least if we are happy to assume quot.sound.
-- Several people have told me that in type theory, equiv is easier to work with than isom.
--(variable v : α → β)
#print distrib

-- I want my equiv to be better than theirs if one of my imports annoyingly imports data.equiv.
-- I am over-importing madly
/-- Kenny's definition -/
structure ring_equiv (α : Type) (β : Type) [comm_ring α] [comm_ring β] extends equiv α β :=
(is_ring_hom : is_ring_hom to_fun)

-- this is not even workable
definition fun_to_ring : (α → β) → (ring α → ring β) := λ f Hα,
{ -- this is the boring bit which needs to be automised
  one := f Hα.one,
  one_mul :=  _,--by rw [] at Hα.one_mul,

}

#exit

#exit

definition equiv_to_ring : equiv α β → equiv (ring α) (ring β) := λ H,
{ to_fun := λ R,_,
  inv_fun := _,
  left_inv := _,
  right_inv := _
}
#print is_ring_hom

#check @set.image -- (α → β) → set α → set β

-- instance : is_lawful_functor set :=

#exit

-- QUESTION. Using these three functions, defined in equiv I think,
-- can I write down a map between (equiv a b) and (equiv (set a) (set b))
-- and also a map between (equiv a b) and (equiv )

--still haven't gfot this straight

namespace subtype

/-- -- Restriction of a function to a function on subtypes. -/
-- set to subtype
def map {p : α → Prop} {q : β → Prop} (f : α → β) (h : ∀a, p a → q (f a)) :
  subtype p → subtype q
| ⟨v, hv⟩ := ⟨f v, h v hv⟩

-- should be a functor: or doesn't that make sense?

theorem map_comp {p : α → Prop} {q : β → Prop} {r : γ → Prop} {x : subtype p}
  (f : α → β) (h : ∀a, p a → q (f a)) (g : β → γ) (l : ∀a, q a → r (g a)) :
  map g l (map f h x) = map (g ∘ f) (assume a ha, l (f a) $ h a ha) x :=
by cases x with v h; refl

theorem map_id {p : α → Prop} {h : ∀a, p a → p (id a)} : map (@id α) h = id :=
funext $ assume ⟨v, h⟩, rfl

-- is that the proof that map is a functor?
end subtype

#exit
-- evil future plan
-- structure canonically_isomorphic (α : Type zfc) (β : Type zfc) extends equiv α β :=
--(

theorem set.image (X α β : Sort*) [H : equiv α β] (f : X → α) :
let g : X → β := H.to_fun ∘ f in
(set.image equiv.to_fun : set α → set β) $ set.range f
#print notation ''

end equiv

-- is this there?
instance group_of_equiv [group α] (H : equiv α β) : group β := sorry

instance set_equiv_of_equiv (H : equiv α β) : equiv (set α) (set β) := sorry

-- this is =
#check @eq α β
#check @eq
-- this is == but it doesn't typecheck -/
--#check @heq α β
#print heq


/-
Copyright (c) 2020 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson
-/
import ring_theory.int.basic
import field_theory.splitting_field
import ring_theory.localization.integral
import ring_theory.integrally_closed

/-!
# Gauss's Lemma

Gauss's Lemma is one of a few results pertaining to irreducibility of primitive polynomials.

## Main Results
 - `polynomial.monic.irreducible_iff_irreducible_map_fraction_map`:
  A monic polynomial over an integrally closed domain is irreducible iff it is irreducible in a
    fraction field
 - `is_integrally_closed_iff'`:
   Integrally closed domains are precisely the domains for in which Gauss's lemma holds
    for monic polynomials
 - `polynomial.is_primitive.irreducible_iff_irreducible_map_fraction_map`:
  A primitive polynomial over a GCD domain is irreducible iff it is irreducible in a fraction field
 - `polynomial.is_primitive.int.irreducible_iff_irreducible_map_cast`:
  A primitive polynomial over `ℤ` is irreducible iff it is irreducible over `ℚ`.
 - `polynomial.is_primitive.dvd_iff_fraction_map_dvd_fraction_map`:
  Two primitive polynomials over a GCD domain divide each other iff they do in a fraction field.
 - `polynomial.is_primitive.int.dvd_iff_map_cast_dvd_map_cast`:
  Two primitive polynomials over `ℤ` divide each other if they do in `ℚ`.

-/

open_locale non_zero_divisors polynomial

variables {R : Type*} [comm_ring R]

namespace polynomial

section
variables {S : Type*} [comm_ring S] [is_domain S]
variables {φ : R →+* S} (hinj : function.injective φ) {f : R[X]} (hf : f.is_primitive)
include hinj hf

lemma is_primitive.is_unit_iff_is_unit_map_of_injective :
  is_unit f ↔ is_unit (map φ f) :=
begin
  refine ⟨(map_ring_hom φ).is_unit_map, λ h, _⟩,
  rcases is_unit_iff.1 h with ⟨_, ⟨u, rfl⟩, hu⟩,
  have hdeg := degree_C u.ne_zero,
  rw [hu, degree_map_eq_of_injective hinj] at hdeg,
  rw [eq_C_of_degree_eq_zero hdeg] at hf ⊢,
  exact is_unit_C.mpr (is_primitive_iff_is_unit_of_C_dvd.mp hf (f.coeff 0) dvd_rfl),
end

lemma is_primitive.irreducible_of_irreducible_map_of_injective (h_irr : irreducible (map φ f)) :
  irreducible f :=
begin
  refine ⟨λ h, h_irr.not_unit (is_unit.map (map_ring_hom φ) h),
    λ a b h, (h_irr.is_unit_or_is_unit $ by rw [h, polynomial.map_mul]).imp _ _⟩,
  all_goals { apply ((is_primitive_of_dvd hf _).is_unit_iff_is_unit_map_of_injective hinj).mpr },
  exacts [(dvd.intro _ h.symm), dvd.intro_left _ h.symm],
end

end

section fraction_map

variables {K : Type*} [field K] [algebra R K] [is_fraction_ring R K]

lemma is_primitive.is_unit_iff_is_unit_map {p : R[X]} (hp : p.is_primitive) :
  is_unit p ↔ is_unit (p.map (algebra_map R K)) :=
hp.is_unit_iff_is_unit_map_of_injective (is_fraction_ring.injective _ _)

variable [is_domain R]

section is_integrally_closed

open is_integrally_closed

/-- **Gauss's Lemma** for integrally closed domains states that a monic polynomial is irreducible
  iff it is irreducible in the fraction field. -/

  obtain ⟨a', ha⟩ := eq_map_mul_C_of_dvd K h (dvd_of_mul_right_eq b H.symm),
  obtain ⟨b', hb⟩ := eq_map_mul_C_of_dvd K h (dvd_of_mul_left_eq a H.symm),

  have : a.leading_coeff * b.leading_coeff = 1,
  { rw [← leading_coeff_mul, ← H, monic.leading_coeff (h.map $ algebra_map R K)] },

  rw [← ha, ← hb, mul_comm _ (C b.leading_coeff), mul_assoc, ← mul_assoc (C a.leading_coeff),
    ← C_mul, this, C_1, one_mul, ← polynomial.map_mul] at H,
  rw [← hb, ← polynomial.coe_map_ring_hom],
  refine is_unit.mul
    (is_unit.map _ (or.resolve_left (hp.is_unit_or_is_unit _) (show ¬ is_unit a', from _)))
    (is_unit_iff_exists_inv'.mpr (exists.intro (C a.leading_coeff) $ by rwa [← C_mul, this, C_1])),
  { exact polynomial.map_injective _ (is_fraction_ring.injective R K) H },

  { by_contra h_contra,
    refine hₐ _,
    rw [← ha, ← polynomial.coe_map_ring_hom],
    exact is_unit.mul (is_unit.map _ h_contra) (is_unit_iff_exists_inv.mpr
      (exists.intro (C b.leading_coeff) $ by rwa [← C_mul, this, C_1])) },
end

/-- Integrally closed domains are precisely the domains for in which Gauss's lemma holds
    for monic polynomials -/
theorem is_integrally_closed_iff' : is_integrally_closed R ↔
  ∀ p : R[X], p.monic → (irreducible p ↔ irreducible (p.map $ algebra_map R K)) :=
begin
  split,
  { intros hR p hp, letI := hR, exact monic.irreducible_iff_irreducible_map_fraction_map hp },
  { intro H,
    refine (is_integrally_closed_iff K).mpr (λ x hx, ring_hom.mem_range.mp $
      minpoly.mem_range_of_degree_eq_one R x _),
    rw ← monic.degree_map (minpoly.monic hx) (algebra_map R K),
    apply degree_eq_one_of_irreducible_of_root ((H _ $ minpoly.monic hx).mp
      (minpoly.irreducible hx)),
    rw [is_root, eval_map, ← aeval_def, minpoly.aeval R x] },
end

theorem monic.dvd_of_fraction_map_dvd_fraction_map [is_integrally_closed R] {p q : R[X]}
  (hp : p.monic ) (hq : q.monic) (h : q.map (algebra_map R K) ∣ p.map (algebra_map R K)) : q ∣ p :=
begin
  obtain ⟨r, hr⟩ := h,
  obtain ⟨d', hr'⟩ := is_integrally_closed.eq_map_mul_C_of_dvd K hp (dvd_of_mul_left_eq _ hr.symm),
  rw [monic.leading_coeff, C_1, mul_one] at hr',
  rw [← hr', ← polynomial.map_mul] at hr,
  exact dvd_of_mul_right_eq _ (polynomial.map_injective _ (is_fraction_ring.injective R K) hr.symm),
   { exact monic.of_mul_monic_left (hq.map (algebra_map R K)) (by simpa [←hr] using hp.map _) },
end

theorem monic.dvd_iff_fraction_map_dvd_fraction_map [is_integrally_closed R] {p q : R[X]}
  (hp : p.monic ) (hq : q.monic) : q.map (algebra_map R K) ∣ p.map (algebra_map R K) ↔ q ∣ p :=
⟨λ h, hp.dvd_of_fraction_map_dvd_fraction_map hq h,
  λ ⟨a,b⟩, ⟨a.map (algebra_map R K), b.symm ▸ polynomial.map_mul (algebra_map R K)⟩⟩

end is_integrally_closed

open is_localization

section normalized_gcd_monoid

variable [normalized_gcd_monoid R]

lemma is_unit_or_eq_zero_of_is_unit_integer_normalization_prim_part
  {p : K[X]} (h0 : p ≠ 0) (h : is_unit (integer_normalization R⁰ p).prim_part) :
  is_unit p :=
begin
  rcases is_unit_iff.1 h with ⟨_, ⟨u, rfl⟩, hu⟩,
  obtain ⟨⟨c, c0⟩, hc⟩ := integer_normalization_map_to_map R⁰ p,
  rw [subtype.coe_mk, algebra.smul_def, algebra_map_apply] at hc,
  apply is_unit_of_mul_is_unit_right,
  rw [← hc, (integer_normalization R⁰ p).eq_C_content_mul_prim_part, ← hu,
    ← ring_hom.map_mul, is_unit_iff],
  refine ⟨algebra_map R K ((integer_normalization R⁰ p).content * ↑u),
    is_unit_iff_ne_zero.2 (λ con, _), by simp⟩,
  replace con := (injective_iff_map_eq_zero (algebra_map R K)).1
    (is_fraction_ring.injective _ _) _ con,
  rw [mul_eq_zero, content_eq_zero_iff, is_fraction_ring.integer_normalization_eq_zero_iff] at con,
  rcases con with con | con,
  { apply h0 con },
  { apply units.ne_zero _ con },
end

/-- **Gauss's Lemma** for GCD domains states that a primitive polynomial is irreducible iff it is
  irreducible in the fraction field. -/
theorem is_primitive.irreducible_iff_irreducible_map_fraction_map
  {p : R[X]} (hp : p.is_primitive) :
  irreducible p ↔ irreducible (p.map (algebra_map R K)) :=
begin
  refine ⟨λ hi, ⟨λ h, hi.not_unit (hp.is_unit_iff_is_unit_map.2 h), λ a b hab, _⟩,
    hp.irreducible_of_irreducible_map_of_injective (is_fraction_ring.injective _ _)⟩,
  obtain ⟨⟨c, c0⟩, hc⟩ := integer_normalization_map_to_map R⁰ a,
  obtain ⟨⟨d, d0⟩, hd⟩ := integer_normalization_map_to_map R⁰ b,
  rw [algebra.smul_def, algebra_map_apply, subtype.coe_mk] at hc hd,
  rw mem_non_zero_divisors_iff_ne_zero at c0 d0,
  have hcd0 : c * d ≠ 0 := mul_ne_zero c0 d0,
  rw [ne.def, ← C_eq_zero] at hcd0,
  have h1 : C c * C d * p = integer_normalization R⁰ a * integer_normalization R⁰ b,
  { apply map_injective (algebra_map R K) (is_fraction_ring.injective _ _) _,
    rw [polynomial.map_mul, polynomial.map_mul, polynomial.map_mul, hc, hd, map_C, map_C, hab],
    ring },
  obtain ⟨u, hu⟩ : associated (c * d) (content (integer_normalization R⁰ a) *
            content (integer_normalization R⁰ b)),
  { rw [← dvd_dvd_iff_associated, ← normalize_eq_normalize_iff, normalize.map_mul,
        normalize.map_mul, normalize_content, normalize_content,
        ← mul_one (normalize c * normalize d), ← hp.content_eq_one, ← content_C, ← content_C,
        ← content_mul, ← content_mul, ← content_mul, h1] },
  rw [← ring_hom.map_mul, eq_comm,
    (integer_normalization R⁰ a).eq_C_content_mul_prim_part,
    (integer_normalization R⁰ b).eq_C_content_mul_prim_part, mul_assoc,
    mul_comm _ (C _ * _), ← mul_assoc, ← mul_assoc, ← ring_hom.map_mul, ← hu, ring_hom.map_mul,
    mul_assoc, mul_assoc, ← mul_assoc (C ↑u)] at h1,
  have h0 : (a ≠ 0) ∧ (b ≠ 0),
  { classical,
    rw [ne.def, ne.def, ← decidable.not_or_iff_and_not, ← mul_eq_zero, ← hab],
    intro con,
    apply hp.ne_zero (map_injective (algebra_map R K) (is_fraction_ring.injective _ _) _),
    simp [con] },
  rcases hi.is_unit_or_is_unit (mul_left_cancel₀ hcd0 h1).symm with h | h,
  { right,
    apply is_unit_or_eq_zero_of_is_unit_integer_normalization_prim_part h0.2
      (is_unit_of_mul_is_unit_right h) },
  { left,
    apply is_unit_or_eq_zero_of_is_unit_integer_normalization_prim_part h0.1 h },
end

lemma is_primitive.dvd_of_fraction_map_dvd_fraction_map {p q : R[X]}
  (hp : p.is_primitive) (hq : q.is_primitive)
  (h_dvd : p.map (algebra_map R K) ∣ q.map (algebra_map R K)) : p ∣ q :=
begin
  rcases h_dvd with ⟨r, hr⟩,
  obtain ⟨⟨s, s0⟩, hs⟩ := integer_normalization_map_to_map R⁰ r,
  rw [subtype.coe_mk, algebra.smul_def, algebra_map_apply] at hs,
  have h : p ∣ q * C s,
  { use (integer_normalization R⁰ r),
    apply map_injective (algebra_map R K) (is_fraction_ring.injective _ _),
    rw [polynomial.map_mul, polynomial.map_mul, hs, hr, mul_assoc, mul_comm r],
    simp },
  rw [← hp.dvd_prim_part_iff_dvd, prim_part_mul, hq.prim_part_eq,
      associated.dvd_iff_dvd_right] at h,
  { exact h },
  { symmetry,
    rcases is_unit_prim_part_C s with ⟨u, hu⟩,
    use u,
    rw hu },
  iterate 2 { apply mul_ne_zero hq.ne_zero,
    rw [ne.def, C_eq_zero],
    contrapose! s0,
    simp [s0, mem_non_zero_divisors_iff_ne_zero] }
end

variables (K)

lemma is_primitive.dvd_iff_fraction_map_dvd_fraction_map {p q : R[X]}
  (hp : p.is_primitive) (hq : q.is_primitive) :
  (p ∣ q) ↔ (p.map (algebra_map R K) ∣ q.map (algebra_map R K)) :=
⟨λ ⟨a,b⟩, ⟨a.map (algebra_map R K), b.symm ▸ polynomial.map_mul (algebra_map R K)⟩,
  λ h, hp.dvd_of_fraction_map_dvd_fraction_map hq h⟩

end normalized_gcd_monoid

end fraction_map

/-- **Gauss's Lemma** for `ℤ` states that a primitive integer polynomial is irreducible iff it is
  irreducible over `ℚ`. -/
theorem is_primitive.int.irreducible_iff_irreducible_map_cast
  {p : ℤ[X]} (hp : p.is_primitive) :
  irreducible p ↔ irreducible (p.map (int.cast_ring_hom ℚ)) :=
hp.irreducible_iff_irreducible_map_fraction_map

lemma is_primitive.int.dvd_iff_map_cast_dvd_map_cast (p q : ℤ[X])
  (hp : p.is_primitive) (hq : q.is_primitive) :
  (p ∣ q) ↔ (p.map (int.cast_ring_hom ℚ) ∣ q.map (int.cast_ring_hom ℚ)) :=
hp.dvd_iff_fraction_map_dvd_fraction_map ℚ hq

end polynomial


/-
Copyright (c) 2021 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.epi_mono
import category_theory.limits.has_limits
import category_theory.limits.shapes.equalizers

/-!
# Wide equalizers and wide coequalizers

This file defines wide (co)equalizers as special cases of (co)limits.

A wide equalizer for the family of morphisms `X ⟶ Y` indexed by `J` is the categorical
generalization of the subobject `{a ∈ A | ∀ j₁ j₂, f(j₁, a) = f(j₂, a)}`. Note that if `J` has
fewer than two morphisms this condition is trivial, so some lemmas and definitions assume `J` is
nonempty.

## Main definitions

* `walking_parallel_family` is the indexing category used for wide (co)equalizer diagrams
* `parallel_family` is a functor from `walking_parallel_family` to our category `C`.
* a `trident` is a cone over a parallel family.
  * there is really only one interesting morphism in a trident: the arrow from the vertex of the
    trident to the domain of f and g. It is called `trident.ι`.
* a `wide_equalizer` is now just a `limit (parallel_family f)`

Each of these has a dual.

## Main statements

* `wide_equalizer.ι_mono` states that every wide_equalizer map is a monomorphism
* `is_iso_limit_cone_parallel_family_of_self` states that the identity on the domain of `f` is an
  equalizer of `f` and `f`.

## Implementation notes
As with the other special shapes in the limits library, all the definitions here are given as
`abbreviation`s of the general statements for limits, so all the `simp` lemmas and theorems about
general limits can be used.

## References

* [F. Borceux, *Handbook of Categorical Algebra 1*][borceux-vol1]
-/

noncomputable theory

namespace category_theory.limits

open category_theory

universes v u u₂

variables {J : Type v}

/-- The type of objects for the diagram indexing a wide (co)equalizer. -/
inductive walking_parallel_family (J : Type v) : Type v
| zero : walking_parallel_family
| one : walking_parallel_family

open walking_parallel_family

instance : decidable_eq (walking_parallel_family J)
| zero zero := is_true rfl
| zero one := is_false (λ t, walking_parallel_family.no_confusion t)
| one zero := is_false (λ t, walking_parallel_family.no_confusion t)
| one one := is_true rfl

instance : inhabited (walking_parallel_family J) := ⟨zero⟩

/-- The type family of morphisms for the diagram indexing a wide (co)equalizer. -/
@[derive decidable_eq] inductive walking_parallel_family.hom (J : Type v) :
  walking_parallel_family J → walking_parallel_family J → Type v
| id : Π X : walking_parallel_family.{v} J, walking_parallel_family.hom X X
| line : Π (j : J), walking_parallel_family.hom zero one

/-- Satisfying the inhabited linter -/
instance (J : Type v) : inhabited (walking_parallel_family.hom J zero zero) :=
{ default := hom.id _ }

open walking_parallel_family.hom

/-- Composition of morphisms in the indexing diagram for wide (co)equalizers. -/
def walking_parallel_family.hom.comp :
  Π (X Y Z : walking_parallel_family J)
    (f : walking_parallel_family.hom J X Y) (g : walking_parallel_family.hom J Y Z),
    walking_parallel_family.hom J X Z
  | _ _ _ (id _)   h := h
  | _ _ _ (line j) (id one) := line j.

local attribute [tidy] tactic.case_bash

instance walking_parallel_family.category : small_category (walking_parallel_family J) :=
{ hom  := walking_parallel_family.hom J,
  id   := walking_parallel_family.hom.id,
  comp := walking_parallel_family.hom.comp }

@[simp]
lemma walking_parallel_family.hom_id (X : walking_parallel_family J) :
  walking_parallel_family.hom.id X = 𝟙 X :=
rfl

variables {C : Type u} [category.{v} C]
variables {X Y : C} (f : J → (X ⟶ Y))

/--
`parallel_family f` is the diagram in `C` consisting of the given family of morphisms, each with
common domain and codomain.
-/
def parallel_family : walking_parallel_family J ⥤ C :=
{ obj := λ x, walking_parallel_family.cases_on x X Y,
  map := λ x y h, match x, y, h with
  | _, _, (id _) := 𝟙 _
  | _, _, (line j) := f j
  end,
  map_comp' :=
  begin
    rintro _ _ _ ⟨⟩ ⟨⟩;
    { unfold_aux, simp; refl },
  end }

@[simp] lemma parallel_family_obj_zero : (parallel_family f).obj zero = X := rfl
@[simp] lemma parallel_family_obj_one : (parallel_family f).obj one = Y := rfl

@[simp] lemma parallel_family_map_left {j : J} : (parallel_family f).map (line j) = f j := rfl

/-- Every functor indexing a wide (co)equalizer is naturally isomorphic (actually, equal) to a
    `parallel_family` -/
@[simps]
def diagram_iso_parallel_family (F : walking_parallel_family J ⥤ C) :
  F ≅ parallel_family (λ j, F.map (line j)) :=
nat_iso.of_components (λ j, eq_to_iso $ by cases j; tidy) $ by tidy

/-- `walking_parallel_pair` as a category is equivalent to a special case of
`walking_parallel_family`.  -/
@[simps]
def walking_parallel_family_equiv_walking_parallel_pair :
  walking_parallel_family.{v} (ulift bool) ≌ walking_parallel_pair.{v} :=
{ functor := parallel_family
      (λ p, cond p.down walking_parallel_pair_hom.left walking_parallel_pair_hom.right),
  inverse := parallel_pair (line (ulift.up tt)) (line (ulift.up ff)),
  unit_iso := nat_iso.of_components (λ X, eq_to_iso (by cases X; refl)) (by tidy),
  counit_iso := nat_iso.of_components (λ X, eq_to_iso (by cases X; refl)) (by tidy) }

/-- A trident on `f` is just a `cone (parallel_family f)`. -/
abbreviation trident := cone (parallel_family f)

/-- A cotrident on `f` and `g` is just a `cocone (parallel_family f)`. -/
abbreviation cotrident := cocone (parallel_family f)

variables {f}

/-- A trident `t` on the parallel family `f : J → (X ⟶ Y)` consists of two morphisms
    `t.π.app zero : t.X ⟶ X` and `t.π.app one : t.X ⟶ Y`. Of these, only the first one is
    interesting, and we give it the shorter name `trident.ι t`. -/
abbreviation trident.ι (t : trident f) := t.π.app zero

/-- A cotrident `t` on the parallel family `f : J → (X ⟶ Y)` consists of two morphisms
    `t.ι.app zero : X ⟶ t.X` and `t.ι.app one : Y ⟶ t.X`. Of these, only the second one is
    interesting, and we give it the shorter name `cotrident.π t`. -/
abbreviation cotrident.π (t : cotrident f) := t.ι.app one

@[simp] lemma trident.ι_eq_app_zero (t : trident f) : t.ι = t.π.app zero := rfl
@[simp] lemma cotrident.π_eq_app_one (t : cotrident f) : t.π = t.ι.app one := rfl

@[simp, reassoc] lemma trident.app_zero (s : trident f) (j : J) :
  s.π.app zero ≫ f j = s.π.app one :=
by rw [←s.w (line j), parallel_family_map_left]

@[simp, reassoc] lemma cotrident.app_one (s : cotrident f) (j : J) :
  f j ≫ s.ι.app one = s.ι.app zero :=
by rw [←s.w (line j), parallel_family_map_left]

/--
A trident on `f : J → (X ⟶ Y)` is determined by the morphism `ι : P ⟶ X` satisfying
`∀ j₁ j₂, ι ≫ f j₁ = ι ≫ f j₂`.
-/
@[simps]
def trident.of_ι [nonempty J] {P : C} (ι : P ⟶ X) (w : ∀ j₁ j₂, ι ≫ f j₁ = ι ≫ f j₂) :
  trident f :=
{ X := P,
  π :=
  { app := λ X, walking_parallel_family.cases_on X ι (ι ≫ f (classical.arbitrary J)),
    naturality' := λ i j f,
      begin
        dsimp,
        cases f with _ k,
        { simp },
        { simp [w (classical.arbitrary J) k] },
      end } }

/--
A cotrident on `f : J → (X ⟶ Y)` is determined by the morphism `π : Y ⟶ P` satisfying
`∀ j₁ j₂, f j₁ ≫ π = f j₂ ≫ π`.
-/
@[simps]
def cotrident.of_π [nonempty J] {P : C} (π : Y ⟶ P) (w : ∀ j₁ j₂, f j₁ ≫ π = f j₂ ≫ π) :
  cotrident f :=
{ X := P,
  ι :=
  { app := λ X, walking_parallel_family.cases_on X (f (classical.arbitrary J) ≫ π) π,
    naturality' := λ i j f,
      begin
        dsimp,
        cases f with _ k,
        { simp },
        { simp [w (classical.arbitrary J) k] }
      end } } -- See note [dsimp, simp]

lemma trident.ι_of_ι [nonempty J] {P : C} (ι : P ⟶ X) (w : ∀ j₁ j₂, ι ≫ f j₁ = ι ≫ f j₂) :
  (trident.of_ι ι w).ι = ι := rfl
lemma cotrident.π_of_π [nonempty J] {P : C} (π : Y ⟶ P) (w : ∀ j₁ j₂, f j₁ ≫ π = f j₂ ≫ π) :
  (cotrident.of_π π w).π = π := rfl

@[reassoc]
lemma trident.condition (j₁ j₂ : J) (t : trident f) : t.ι ≫ f j₁ = t.ι ≫ f j₂ :=
by rw [t.app_zero, t.app_zero]

@[reassoc]
lemma cotrident.condition (j₁ j₂ : J) (t : cotrident f) : f j₁ ≫ t.π = f j₂ ≫ t.π :=
by rw [t.app_one, t.app_one]

/-- To check whether two maps are equalized by both maps of a trident, it suffices to check it for
the first map -/
lemma trident.equalizer_ext [nonempty J] (s : trident f) {W : C} {k l : W ⟶ s.X}
  (h : k ≫ s.ι = l ≫ s.ι) : ∀ (j : walking_parallel_family J),
    k ≫ s.π.app j = l ≫ s.π.app j
| zero := h
| one := by rw [←s.app_zero (classical.arbitrary J), reassoc_of h]

/-- To check whether two maps are coequalized by both maps of a cotrident, it suffices to check it
for the second map -/
lemma cotrident.coequalizer_ext [nonempty J] (s : cotrident f) {W : C} {k l : s.X ⟶ W}
  (h : s.π ≫ k = s.π ≫ l) : ∀ (j : walking_parallel_family J),
    s.ι.app j ≫ k = s.ι.app j ≫ l
| zero := by rw [←s.app_one (classical.arbitrary J), category.assoc, category.assoc, h]
| one := h

lemma trident.is_limit.hom_ext [nonempty J] {s : trident f} (hs : is_limit s)
  {W : C} {k l : W ⟶ s.X} (h : k ≫ s.ι = l ≫ s.ι) :
  k = l :=
hs.hom_ext $ trident.equalizer_ext _ h

lemma cotrident.is_colimit.hom_ext [nonempty J] {s : cotrident f} (hs : is_colimit s)
  {W : C} {k l : s.X ⟶ W} (h : s.π ≫ k = s.π ≫ l) :
  k = l :=
hs.hom_ext $ cotrident.coequalizer_ext _ h

/-- If `s` is a limit trident over `f`, then a morphism `k : W ⟶ X` satisfying
    `∀ j₁ j₂, k ≫ f j₁ = k ≫ f j₂` induces a morphism `l : W ⟶ s.X` such that
    `l ≫ trident.ι s = k`. -/
def trident.is_limit.lift' [nonempty J] {s : trident f} (hs : is_limit s) {W : C} (k : W ⟶ X)
  (h : ∀ j₁ j₂, k ≫ f j₁ = k ≫ f j₂) :
  {l : W ⟶ s.X // l ≫ trident.ι s = k} :=
⟨hs.lift $ trident.of_ι _ h, hs.fac _ _⟩

/-- If `s` is a colimit cotrident over `f`, then a morphism `k : Y ⟶ W` satisfying
    `∀ j₁ j₂, f j₁ ≫ k = f j₂ ≫ k` induces a morphism `l : s.X ⟶ W` such that
    `cotrident.π s ≫ l = k`. -/
def cotrident.is_colimit.desc' [nonempty J] {s : cotrident f} (hs : is_colimit s) {W : C}
  (k : Y ⟶ W) (h : ∀ j₁ j₂, f j₁ ≫ k = f j₂ ≫ k) :
  {l : s.X ⟶ W // cotrident.π s ≫ l = k} :=
⟨hs.desc $ cotrident.of_π _ h, hs.fac _ _⟩

/-- This is a slightly more convenient method to verify that a trident is a limit cone. It
    only asks for a proof of facts that carry any mathematical content -/
def trident.is_limit.mk [nonempty J] (t : trident f)
  (lift : Π (s : trident f), s.X ⟶ t.X)
  (fac : ∀ (s : trident f), lift s ≫ t.ι = s.ι)
  (uniq : ∀ (s : trident f) (m : s.X ⟶ t.X)
  (w : ∀ j : walking_parallel_family J, m ≫ t.π.app j = s.π.app j), m = lift s) :
  is_limit t :=
{ lift := lift,
  fac' := λ s j, walking_parallel_family.cases_on j (fac s)
    (by rw [←t.w (line (classical.arbitrary J)), reassoc_of fac, s.w]),
  uniq' := uniq }

/-- This is another convenient method to verify that a trident is a limit cone. It
    only asks for a proof of facts that carry any mathematical content, and allows access to the
    same `s` for all parts. -/
def trident.is_limit.mk' [nonempty J] (t : trident f)
  (create : Π (s : trident f), {l // l ≫ t.ι = s.ι ∧ ∀ {m}, m ≫ t.ι = s.ι → m = l}) :
is_limit t :=
trident.is_limit.mk t
  (λ s, (create s).1)
  (λ s, (create s).2.1)
  (λ s m w, (create s).2.2 (w zero))

/-- This is a slightly more convenient method to verify that a cotrident is a colimit cocone. It
    only asks for a proof of facts that carry any mathematical content -/
def cotrident.is_colimit.mk [nonempty J] (t : cotrident f)
  (desc : Π (s : cotrident f), t.X ⟶ s.X)
  (fac : ∀ (s : cotrident f), t.π ≫ desc s = s.π)
  (uniq : ∀ (s : cotrident f) (m : t.X ⟶ s.X)
  (w : ∀ j : walking_parallel_family J, t.ι.app j ≫ m = s.ι.app j), m = desc s) :
  is_colimit t :=
{ desc := desc,
  fac' := λ s j, walking_parallel_family.cases_on j
    (by rw [←t.w_assoc (line (classical.arbitrary J)), fac, s.w]) (fac s),
  uniq' := uniq }

/-- This is another convenient method to verify that a cotrident is a colimit cocone. It
    only asks for a proof of facts that carry any mathematical content, and allows access to the
    same `s` for all parts. -/
def cotrident.is_colimit.mk' [nonempty J] (t : cotrident f)
  (create : Π (s : cotrident f), {l : t.X ⟶ s.X // t.π ≫ l = s.π ∧ ∀ {m}, t.π ≫ m = s.π → m = l}) :
  is_colimit t :=
cotrident.is_colimit.mk t
  (λ s, (create s).1)
  (λ s, (create s).2.1)
  (λ s m w, (create s).2.2 (w one))

/--
Given a limit cone for the family `f : J → (X ⟶ Y)`, for any `Z`, morphisms from `Z` to its point
are in bijection with morphisms `h : Z ⟶ X` such that `∀ j₁ j₂, h ≫ f j₁ = h ≫ f j₂`.
Further, this bijection is natural in `Z`: see `trident.is_limit.hom_iso_natural`.
-/
@[simps]
def trident.is_limit.hom_iso [nonempty J] {t : trident f} (ht : is_limit t) (Z : C) :
  (Z ⟶ t.X) ≃ {h : Z ⟶ X // ∀ j₁ j₂, h ≫ f j₁ = h ≫ f j₂} :=
{ to_fun := λ k, ⟨k ≫ t.ι, by simp⟩,
  inv_fun := λ h, (trident.is_limit.lift' ht _ h.prop).1,
  left_inv := λ k, trident.is_limit.hom_ext ht (trident.is_limit.lift' _ _ _).prop,
  right_inv := λ h, subtype.ext (trident.is_limit.lift' ht _ _).prop }

/-- The bijection of `trident.is_limit.hom_iso` is natural in `Z`. -/
lemma trident.is_limit.hom_iso_natural [nonempty J] {t : trident f} (ht : is_limit t)
  {Z Z' : C} (q : Z' ⟶ Z) (k : Z ⟶ t.X) :
  (trident.is_limit.hom_iso ht _ (q ≫ k) : Z' ⟶ X) =
  q ≫ (trident.is_limit.hom_iso ht _ k : Z ⟶ X) :=
category.assoc _ _ _

/--
Given a colimit cocone for the family `f : J → (X ⟶ Y)`, for any `Z`, morphisms from the cocone
point to `Z` are in bijection with morphisms `h : Z ⟶ X` such that
`∀ j₁ j₂, f j₁ ≫ h = f j₂ ≫ h`.  Further, this bijection is natural in `Z`: see
`cotrident.is_colimit.hom_iso_natural`.
-/
@[simps]
def cotrident.is_colimit.hom_iso [nonempty J] {t : cotrident f} (ht : is_colimit t) (Z : C) :
  (t.X ⟶ Z) ≃ {h : Y ⟶ Z // ∀ j₁ j₂, f j₁ ≫ h = f j₂ ≫ h} :=
{ to_fun := λ k, ⟨t.π ≫ k, by simp⟩,
  inv_fun := λ h, (cotrident.is_colimit.desc' ht _ h.prop).1,
  left_inv := λ k, cotrident.is_colimit.hom_ext ht (cotrident.is_colimit.desc' _ _ _).prop,
  right_inv := λ h, subtype.ext (cotrident.is_colimit.desc' ht _ _).prop }

/-- The bijection of `cotrident.is_colimit.hom_iso` is natural in `Z`. -/
lemma cotrident.is_colimit.hom_iso_natural [nonempty J] {t : cotrident f} {Z Z' : C}
  (q : Z ⟶ Z') (ht : is_colimit t) (k : t.X ⟶ Z) :
    (cotrident.is_colimit.hom_iso ht _ (k ≫ q) : Y ⟶ Z') =
    (cotrident.is_colimit.hom_iso ht _ k : Y ⟶ Z) ≫ q :=
(category.assoc _ _ _).symm

/-- This is a helper construction that can be useful when verifying that a category has certain wide
    equalizers. Given `F : walking_parallel_family ⥤ C`, which is really the same as
    `parallel_family (λ j, F.map (line j))`, and a trident on `λ j, F.map (line j)`, we get a cone
    on `F`.

    If you're thinking about using this, have a look at
    `has_wide_equalizers_of_has_limit_parallel_family`, which you may find to be an easier way of
    achieving your goal. -/
def cone.of_trident
  {F : walking_parallel_family J ⥤ C} (t : trident (λ j, F.map (line j))) : cone F :=
{ X := t.X,
  π :=
  { app := λ X, t.π.app X ≫ eq_to_hom (by tidy),
    naturality' := λ j j' g, by { cases g; { dsimp, simp } } } }

/-- This is a helper construction that can be useful when verifying that a category has all
    coequalizers. Given `F : walking_parallel_family ⥤ C`, which is really the same as
    `parallel_family (λ j, F.map (line j))`, and a cotrident on `λ j, F.map (line j)` we get a
    cocone on `F`.

    If you're thinking about using this, have a look at
    `has_wide_coequalizers_of_has_colimit_parallel_family`, which you may find to be an easier way
    of achieving your goal. -/
def cocone.of_cotrident
  {F : walking_parallel_family J ⥤ C} (t : cotrident (λ j, F.map (line j))) : cocone F :=
{ X := t.X,
  ι :=
  { app := λ X, eq_to_hom (by tidy) ≫ t.ι.app X,
    naturality' := λ j j' g, by { cases g; dsimp; simp [cotrident.app_one t] } } }

@[simp] lemma cone.of_trident_π
  {F : walking_parallel_family J ⥤ C} (t : trident (λ j, F.map (line j))) (j) :
  (cone.of_trident t).π.app j = t.π.app j ≫ eq_to_hom (by tidy) := rfl

@[simp] lemma cocone.of_cotrident_ι
  {F : walking_parallel_family J ⥤ C} (t : cotrident (λ j, F.map (line j))) (j) :
  (cocone.of_cotrident t).ι.app j = eq_to_hom (by tidy) ≫ t.ι.app j := rfl

/-- Given `F : walking_parallel_family ⥤ C`, which is really the same as
    `parallel_family (λ j, F.map (line j))` and a cone on `F`, we get a trident on
    `λ j, F.map (line j)`. -/
def trident.of_cone
  {F : walking_parallel_family J ⥤ C} (t : cone F) : trident (λ j, F.map (line j)) :=
{ X := t.X,
  π := { app := λ X, t.π.app X ≫ eq_to_hom (by tidy) } }

/-- Given `F : walking_parallel_family ⥤ C`, which is really the same as
    `parallel_family (F.map left) (F.map right)` and a cocone on `F`, we get a cotrident on
    `λ j, F.map (line j)`. -/
def cotrident.of_cocone
  {F : walking_parallel_family J ⥤ C} (t : cocone F) : cotrident (λ j, F.map (line j)) :=
{ X := t.X,
  ι := { app := λ X, eq_to_hom (by tidy) ≫ t.ι.app X } }

@[simp] lemma trident.of_cone_π {F : walking_parallel_family J ⥤ C} (t : cone F) (j) :
  (trident.of_cone t).π.app j = t.π.app j ≫ eq_to_hom (by tidy) := rfl
@[simp] lemma cotrident.of_cocone_ι {F : walking_parallel_family J ⥤ C} (t : cocone F) (j) :
  (cotrident.of_cocone t).ι.app j = eq_to_hom (by tidy) ≫ t.ι.app j := rfl

/--
Helper function for constructing morphisms between wide equalizer tridents.
-/
@[simps]
def trident.mk_hom [nonempty J] {s t : trident f} (k : s.X ⟶ t.X) (w : k ≫ t.ι = s.ι) : s ⟶ t :=
{ hom := k,
  w' :=
  begin
    rintro ⟨_|_⟩,
    { exact w },
    { simpa using w =≫ f (classical.arbitrary J) },
  end }

/--
To construct an isomorphism between tridents,
it suffices to give an isomorphism between the cone points
and check that it commutes with the `ι` morphisms.
-/
@[simps]
def trident.ext [nonempty J] {s t : trident f} (i : s.X ≅ t.X) (w : i.hom ≫ t.ι = s.ι) : s ≅ t :=
{ hom := trident.mk_hom i.hom w,
  inv := trident.mk_hom i.inv (by rw [← w, iso.inv_hom_id_assoc]) }

/--
Helper function for constructing morphisms between coequalizer cotridents.
-/
@[simps]
def cotrident.mk_hom [nonempty J] {s t : cotrident f} (k : s.X ⟶ t.X) (w : s.π ≫ k = t.π) :
  s ⟶ t :=
{ hom := k,
  w' :=
  begin
    rintro ⟨_|_⟩,
    { simpa using f (classical.arbitrary J) ≫= w },
    { exact w },
  end }

/--
To construct an isomorphism between cotridents,
it suffices to give an isomorphism between the cocone points
and check that it commutes with the `π` morphisms.
-/
def cotrident.ext [nonempty J] {s t : cotrident f} (i : s.X ≅ t.X) (w : s.π ≫ i.hom = t.π) :
  s ≅ t :=
{ hom := cotrident.mk_hom i.hom w,
  inv := cotrident.mk_hom i.inv (by rw [iso.comp_inv_eq, w]) }

variables (f)

section
/--
`has_wide_equalizer f` represents a particular choice of limiting cone for the parallel family of
morphisms `f`.
-/
abbreviation has_wide_equalizer := has_limit (parallel_family f)

variables [has_wide_equalizer f]

/-- If a wide equalizer of `f` exists, we can access an arbitrary choice of such by
    saying `wide_equalizer f`. -/
abbreviation wide_equalizer : C := limit (parallel_family f)

/-- If a wide equalizer of `f` exists, we can access the inclusion `wide_equalizer f ⟶ X` by
    saying `wide_equalizer.ι f`. -/
abbreviation wide_equalizer.ι : wide_equalizer f ⟶ X :=
limit.π (parallel_family f) zero

/--
A wide equalizer cone for a parallel family `f`.
-/
abbreviation wide_equalizer.trident : trident f := limit.cone (parallel_family f)

@[simp] lemma wide_equalizer.trident_ι :
  (wide_equalizer.trident f).ι = wide_equalizer.ι f := rfl

@[simp] lemma wide_equalizer.trident_π_app_zero :
  (wide_equalizer.trident f).π.app zero = wide_equalizer.ι f := rfl

@[reassoc] lemma wide_equalizer.condition (j₁ j₂ : J) :
  wide_equalizer.ι f ≫ f j₁ = wide_equalizer.ι f ≫ f j₂ :=
trident.condition j₁ j₂ $ limit.cone $ parallel_family f

/-- The wide_equalizer built from `wide_equalizer.ι f` is limiting. -/
def wide_equalizer_is_wide_equalizer [nonempty J] :
  is_limit (trident.of_ι (wide_equalizer.ι f) (wide_equalizer.condition f)) :=
is_limit.of_iso_limit (limit.is_limit _) (trident.ext (iso.refl _) (by tidy))

variables {f}

/-- A morphism `k : W ⟶ X` satisfying `∀ j₁ j₂, k ≫ f j₁ = k ≫ f j₂` factors through the
    wide equalizer of `f` via `wide_equalizer.lift : W ⟶ wide_equalizer f`. -/
abbreviation wide_equalizer.lift [nonempty J] {W : C} (k : W ⟶ X)
  (h : ∀ j₁ j₂, k ≫ f j₁ = k ≫ f j₂) :
  W ⟶ wide_equalizer f :=
limit.lift (parallel_family f) (trident.of_ι k h)

@[simp, reassoc]
lemma wide_equalizer.lift_ι [nonempty J] {W : C} (k : W ⟶ X) (h : ∀ j₁ j₂, k ≫ f j₁ = k ≫ f j₂) :
  wide_equalizer.lift k h ≫ wide_equalizer.ι f = k :=
limit.lift_π _ _

/-- A morphism `k : W ⟶ X` satisfying `∀ j₁ j₂, k ≫ f j₁ = k ≫ f j₂` induces a morphism
    `l : W ⟶ wide_equalizer f` satisfying `l ≫ wide_equalizer.ι f = k`. -/
def wide_equalizer.lift' [nonempty J] {W : C} (k : W ⟶ X) (h : ∀ j₁ j₂, k ≫ f j₁ = k ≫ f j₂) :
  {l : W ⟶ wide_equalizer f // l ≫ wide_equalizer.ι f = k} :=
⟨wide_equalizer.lift k h, wide_equalizer.lift_ι _ _⟩

/-- Two maps into a wide equalizer are equal if they are are equal when composed with the wide
    equalizer map. -/
@[ext] lemma wide_equalizer.hom_ext [nonempty J] {W : C} {k l : W ⟶ wide_equalizer f}
  (h : k ≫ wide_equalizer.ι f = l ≫ wide_equalizer.ι f) : k = l :=
trident.is_limit.hom_ext (limit.is_limit _) h

/-- A wide equalizer morphism is a monomorphism -/
instance wide_equalizer.ι_mono [nonempty J] : mono (wide_equalizer.ι f) :=
{ right_cancellation := λ Z h k w, wide_equalizer.hom_ext w }

end

section
variables {f}
/-- The wide equalizer morphism in any limit cone is a monomorphism. -/
lemma mono_of_is_limit_parallel_family [nonempty J] {c : cone (parallel_family f)}
  (i : is_limit c) :
  mono (trident.ι c) :=
{ right_cancellation := λ Z h k w, trident.is_limit.hom_ext i w }

end

section
/--
`has_wide_coequalizer f g` represents a particular choice of colimiting cocone
for the parallel family of morphisms `f`.
-/
abbreviation has_wide_coequalizer := has_colimit (parallel_family f)

variables [has_wide_coequalizer f]

/-- If a wide coequalizer of `f`, we can access an arbitrary choice of such by
    saying `wide_coequalizer f`. -/
abbreviation wide_coequalizer : C := colimit (parallel_family f)

/--  If a wide_coequalizer of `f` exists, we can access the corresponding projection by
    saying `wide_coequalizer.π f`. -/
abbreviation wide_coequalizer.π : Y ⟶ wide_coequalizer f :=
colimit.ι (parallel_family f) one

/--
An arbitrary choice of coequalizer cocone for a parallel family `f`.
-/
abbreviation wide_coequalizer.cotrident : cotrident f := colimit.cocone (parallel_family f)

@[simp] lemma wide_coequalizer.cotrident_π :
  (wide_coequalizer.cotrident f).π = wide_coequalizer.π f := rfl

@[simp] lemma wide_coequalizer.cotrident_ι_app_one :
  (wide_coequalizer.cotrident f).ι.app one = wide_coequalizer.π f := rfl

@[reassoc] lemma wide_coequalizer.condition (j₁ j₂ : J) :
  f j₁ ≫ wide_coequalizer.π f = f j₂ ≫ wide_coequalizer.π f :=
cotrident.condition j₁ j₂ $ colimit.cocone $ parallel_family f

/-- The cotrident built from `wide_coequalizer.π f` is colimiting. -/
def wide_coequalizer_is_wide_coequalizer [nonempty J] :
  is_colimit (cotrident.of_π (wide_coequalizer.π f) (wide_coequalizer.condition f)) :=
is_colimit.of_iso_colimit (colimit.is_colimit _) (cotrident.ext (iso.refl _) (by tidy))

variables {f}

/-- Any morphism `k : Y ⟶ W` satisfying `∀ j₁ j₂, f j₁ ≫ k = f j₂ ≫ k` factors through the
    wide coequalizer of `f` via `wide_coequalizer.desc : wide_coequalizer f ⟶ W`. -/
abbreviation wide_coequalizer.desc [nonempty J] {W : C} (k : Y ⟶ W)
  (h : ∀ j₁ j₂, f j₁ ≫ k = f j₂ ≫ k) :
  wide_coequalizer f ⟶ W :=
colimit.desc (parallel_family f) (cotrident.of_π k h)

@[simp, reassoc]
lemma wide_coequalizer.π_desc [nonempty J] {W : C} (k : Y ⟶ W) (h : ∀ j₁ j₂, f j₁ ≫ k = f j₂ ≫ k) :
  wide_coequalizer.π f ≫ wide_coequalizer.desc k h = k :=
colimit.ι_desc _ _

/-- Any morphism `k : Y ⟶ W` satisfying `∀ j₁ j₂, f j₁ ≫ k = f j₂ ≫ k` induces a morphism
    `l : wide_coequalizer f ⟶ W` satisfying `wide_coequalizer.π ≫ g = l`. -/
def wide_coequalizer.desc' [nonempty J] {W : C} (k : Y ⟶ W) (h : ∀ j₁ j₂, f j₁ ≫ k = f j₂ ≫ k) :
  {l : wide_coequalizer f ⟶ W // wide_coequalizer.π f ≫ l = k} :=
⟨wide_coequalizer.desc k h, wide_coequalizer.π_desc _ _⟩

/-- Two maps from a wide coequalizer are equal if they are equal when composed with the wide
    coequalizer map -/
@[ext] lemma wide_coequalizer.hom_ext [nonempty J] {W : C} {k l : wide_coequalizer f ⟶ W}
  (h : wide_coequalizer.π f ≫ k = wide_coequalizer.π f ≫ l) : k = l :=
cotrident.is_colimit.hom_ext (colimit.is_colimit _) h

/-- A wide coequalizer morphism is an epimorphism -/
instance wide_coequalizer.π_epi [nonempty J] : epi (wide_coequalizer.π f) :=
{ left_cancellation := λ Z h k w, wide_coequalizer.hom_ext w }

end

section
variables {f}

/-- The wide coequalizer morphism in any colimit cocone is an epimorphism. -/
lemma epi_of_is_colimit_parallel_family [nonempty J] {c : cocone (parallel_family f)}
  (i : is_colimit c) :
  epi (c.ι.app one) :=
{ left_cancellation := λ Z h k w, cotrident.is_colimit.hom_ext i w }

end

variables (C)

/-- `has_wide_equalizers` represents a choice of wide equalizer for every family of morphisms -/
abbreviation has_wide_equalizers := Π J, has_limits_of_shape (walking_parallel_family.{v} J) C

/-- `has_wide_coequalizers` represents a choice of wide coequalizer for every family of morphisms -/
abbreviation has_wide_coequalizers := Π J, has_colimits_of_shape (walking_parallel_family.{v} J) C

/-- If `C` has all limits of diagrams `parallel_family f`, then it has all wide equalizers -/
lemma has_wide_equalizers_of_has_limit_parallel_family
  [Π {J} {X Y : C} {f : J → (X ⟶ Y)}, has_limit (parallel_family f)] : has_wide_equalizers C :=
λ J, { has_limit := λ F, has_limit_of_iso (diagram_iso_parallel_family F).symm }

/-- If `C` has all colimits of diagrams `parallel_family f`, then it has all wide coequalizers -/
lemma has_wide_coequalizers_of_has_colimit_parallel_family
  [Π {J} {X Y : C} {f : J → (X ⟶ Y)}, has_colimit (parallel_family f)] : has_wide_coequalizers C :=
λ J, { has_colimit := λ F, has_colimit_of_iso (diagram_iso_parallel_family F) }

@[priority 10]
instance has_equalizers_of_has_wide_equalizers [has_wide_equalizers C] : has_equalizers C :=
has_limits_of_shape_of_equivalence walking_parallel_family_equiv_walking_parallel_pair

@[priority 10]
instance has_coequalizers_of_has_wide_coequalizers [has_wide_coequalizers C] : has_coequalizers C :=
has_colimits_of_shape_of_equivalence walking_parallel_family_equiv_walking_parallel_pair

end category_theory.limits


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.monoidal.Mon_
import Mathlib.PostPort

universes v₁ u₁ l

namespace Mathlib

/-!
# The category of module objects over a monoid object.
-/

/-- A module object for a monoid object, all internal to some monoidal category. -/
structure Mod {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] (A : Mon_ C)
where
  X : C
  act : Mon_.X A ⊗ X ⟶ X
  one_act' : autoParam ((Mon_.one A ⊗ 𝟙) ≫ act = category_theory.iso.hom λ_)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])
  assoc' : autoParam ((Mon_.mul A ⊗ 𝟙) ≫ act = category_theory.iso.hom α_ ≫ (𝟙 ⊗ act) ≫ act)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

@[simp] theorem Mod.one_act {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] {A : Mon_ C} (c : Mod A) : (Mon_.one A ⊗ 𝟙) ≫ Mod.act c = category_theory.iso.hom λ_ := sorry

@[simp] theorem Mod.assoc {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] {A : Mon_ C} (c : Mod A) : (Mon_.mul A ⊗ 𝟙) ≫ Mod.act c = category_theory.iso.hom α_ ≫ (𝟙 ⊗ Mod.act c) ≫ Mod.act c := sorry

@[simp] theorem Mod.one_act_assoc {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] {A : Mon_ C} (c : Mod A) {X' : C} (f' : Mod.X c ⟶ X') : (Mon_.one A ⊗ 𝟙) ≫ Mod.act c ≫ f' = category_theory.iso.hom λ_ ≫ f' := sorry

namespace Mod

theorem assoc_flip {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] {A : Mon_ C} (M : Mod A) : (𝟙 ⊗ act M) ≫ act M = category_theory.iso.inv α_ ≫ (Mon_.mul A ⊗ 𝟙) ≫ act M := sorry

/-- A morphism of module objects. -/
structure hom {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] {A : Mon_ C} (M : Mod A) (N : Mod A)
where
  hom : X M ⟶ X N
  act_hom' : autoParam (act M ≫ hom = (𝟙 ⊗ hom) ≫ act N)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

@[simp] theorem hom.act_hom {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] {A : Mon_ C} {M : Mod A} {N : Mod A} (c : hom M N) : act M ≫ hom.hom c = (𝟙 ⊗ hom.hom c) ≫ act N := sorry

@[simp] theorem hom.act_hom_assoc {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] {A : Mon_ C} {M : Mod A} {N : Mod A} (c : hom M N) {X' : C} (f' : X N ⟶ X') : act M ≫ hom.hom c ≫ f' = (𝟙 ⊗ hom.hom c) ≫ act N ≫ f' := sorry

/-- The identity morphism on a module object. -/
def id {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] {A : Mon_ C} (M : Mod A) : hom M M :=
  hom.mk 𝟙

protected instance hom_inhabited {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] {A : Mon_ C} (M : Mod A) : Inhabited (hom M M) :=
  { default := id M }

/-- Composition of module object morphisms. -/
def comp {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] {A : Mon_ C} {M : Mod A} {N : Mod A} {O : Mod A} (f : hom M N) (g : hom N O) : hom M O :=
  hom.mk (hom.hom f ≫ hom.hom g)

protected instance category_theory.category {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] {A : Mon_ C} : category_theory.category (Mod A) :=
  category_theory.category.mk

@[simp] theorem id_hom' {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] {A : Mon_ C} (M : Mod A) : hom.hom 𝟙 = 𝟙 :=
  rfl

@[simp] theorem comp_hom' {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] {A : Mon_ C} {M : Mod A} {N : Mod A} {K : Mod A} (f : M ⟶ N) (g : N ⟶ K) : hom.hom (f ≫ g) = hom.hom f ≫ hom.hom g :=
  rfl

/-- A monoid object as a module over itself. -/
@[simp] theorem regular_X {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] (A : Mon_ C) : X (regular A) = Mon_.X A :=
  Eq.refl (X (regular A))

protected instance inhabited {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] (A : Mon_ C) : Inhabited (Mod A) :=
  { default := regular A }

/-- The forgetful functor from module objects to the ambient category. -/
def forget {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] (A : Mon_ C) : Mod A ⥤ C :=
  category_theory.functor.mk (fun (A_1 : Mod A) => X A_1) fun (A_1 B : Mod A) (f : A_1 ⟶ B) => hom.hom f

/--
A morphism of monoid objects induces a "restriction" or "comap" functor
between the categories of module objects.
-/
@[simp] theorem comap_obj_act {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] {A : Mon_ C} {B : Mon_ C} (f : A ⟶ B) (M : Mod B) : act (category_theory.functor.obj (comap f) M) = (Mon_.hom.hom f ⊗ 𝟙) ≫ act M :=
  Eq.refl (act (category_theory.functor.obj (comap f) M))


/-
Copyright (c) 2021 David Wärn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: David Wärn, Joachim Breitner
-/
import algebra.free_monoid
import group_theory.congruence
import group_theory.is_free_group
import group_theory.subgroup.pointwise
import data.list.chain
import set_theory.cardinal.ordinal
/-!
# The free product of groups or monoids

Given an `ι`-indexed family `M` of monoids, we define their free product (categorical coproduct)
`free_product M`. When `ι` and all `M i` have decidable equality, the free product bijects with the
type `word M` of reduced words. This bijection is constructed by defining an action of
`free_product M` on `word M`.

When `M i` are all groups, `free_product M` is also a group (and the coproduct in the category of
groups).

## Main definitions

- `free_product M`: the free product, defined as a quotient of a free monoid.
- `free_product.of {i} : M i →* free_product M`.
- `free_product.lift : (Π {i}, M i →* N) ≃ (free_product M →* N)`: the universal property.
- `free_product.word M`: the type of reduced words.
- `free_product.word.equiv M : free_product M ≃ word M`.
- `free_product.neword M i j`: an inductive description of non-empty words with first letter from
  `M i` and last letter from `M j`, together with an API (`singleton`, `append`, `head`, `tail`,
  `to_word`, `prod`, `inv`). Used in the proof of the Ping-Pong-lemma.
- `free_product.lift_injective_of_ping_pong`: The Ping-Pong-lemma, proving injectivity of the
  `lift`. See the documentation of that theorem for more information.

## Remarks

There are many answers to the question "what is the free product of a family `M` of monoids?", and
they are all equivalent but not obviously equivalent. We provide two answers. The first, almost
tautological answer is given by `free_product M`, which is a quotient of the type of words in the
alphabet `Σ i, M i`. It's straightforward to define and easy to prove its universal property. But
this answer is not completely satisfactory, because it's difficult to tell when two elements
`x y : free_product M` are distinct since `free_product M` is defined as a quotient.

The second, maximally efficient answer is given by `word M`. An element of `word M` is a word in the
alphabet `Σ i, M i`, where the letter `⟨i, 1⟩` doesn't occur and no adjacent letters share an index
`i`. Since we only work with reduced words, there is no need for quotienting, and it is easy to tell
when two elements are distinct. However it's not obvious that this is even a monoid!

We prove that every element of `free_product M` can be represented by a unique reduced word, i.e.
`free_product M` and `word M` are equivalent types. This means that `word M` can be given a monoid
structure, and it lets us tell when two elements of `free_product M` are distinct.

There is also a completely tautological, maximally inefficient answer given by
`algebra.category.Mon.colimits`. Whereas `free_product M` at least ensures that (any instance of)
associativity holds by reflexivity, in this answer associativity holds because of quotienting. Yet
another answer, which is constructively more satisfying, could be obtained by showing that
`free_product.rel` is confluent.

## References

[van der Waerden, *Free products of groups*][MR25465]

-/

open set

variables {ι : Type*} (M : Π i : ι, Type*) [Π i, monoid (M i)]

/-- A relation on the free monoid on alphabet `Σ i, M i`, relating `⟨i, 1⟩` with `1` and
`⟨i, x⟩ * ⟨i, y⟩` with `⟨i, x * y⟩`. -/
inductive free_product.rel : free_monoid (Σ i, M i) → free_monoid (Σ i, M i) → Prop
| of_one (i : ι) : free_product.rel (free_monoid.of ⟨i, 1⟩) 1
| of_mul {i : ι} (x y : M i) : free_product.rel (free_monoid.of ⟨i, x⟩ * free_monoid.of ⟨i, y⟩)
  (free_monoid.of ⟨i, x * y⟩)

/-- The free product (categorical coproduct) of an indexed family of monoids. -/
@[derive [monoid, inhabited]]
def free_product : Type* := (con_gen (free_product.rel M)).quotient

namespace free_product

/-- The type of reduced words. A reduced word cannot contain a letter `1`, and no two adjacent
letters can come from the same summand. -/
@[ext] structure word :=
(to_list : list (Σ i, M i))
(ne_one : ∀ l ∈ to_list, sigma.snd l ≠ 1)
(chain_ne : to_list.chain' (λ l l', sigma.fst l ≠ sigma.fst l'))

variable {M}

/-- The inclusion of a summand into the free product. -/
def of {i : ι} : M i →* free_product M :=
{ to_fun   := λ x, con.mk' _ (free_monoid.of $ sigma.mk i x),
  map_one' := (con.eq _).mpr (con_gen.rel.of _ _ (free_product.rel.of_one i)),
  map_mul' := λ x y, eq.symm $ (con.eq _).mpr (con_gen.rel.of _ _ (free_product.rel.of_mul x y)) }

lemma of_apply {i} (m : M i) : of m = con.mk' _ (free_monoid.of $ sigma.mk i m) := rfl

variables {N : Type*} [monoid N]

/-- See note [partially-applied ext lemmas]. -/
@[ext] lemma ext_hom (f g : free_product M →* N) (h : ∀ i, f.comp (of : M i →* _) = g.comp of) :
  f = g :=
(monoid_hom.cancel_right con.mk'_surjective).mp $ free_monoid.hom_eq $ λ ⟨i, x⟩,
  by rw [monoid_hom.comp_apply, monoid_hom.comp_apply, ←of_apply,
    ←monoid_hom.comp_apply, ←monoid_hom.comp_apply, h]

/-- A map out of the free product corresponds to a family of maps out of the summands. This is the
universal property of the free product, charaterizing it as a categorical coproduct. -/
@[simps symm_apply]
def lift : (Π i, M i →* N) ≃ (free_product M →* N) :=
{ to_fun := λ fi, con.lift _ (free_monoid.lift $ λ p : Σ i, M i, fi p.fst p.snd) $ con.con_gen_le
    begin
      simp_rw [con.rel_eq_coe, con.ker_rel],
      rintros _ _ (i | ⟨i, x, y⟩),
      { change free_monoid.lift _ (free_monoid.of _) = free_monoid.lift _ 1,
        simp only [monoid_hom.map_one, free_monoid.lift_eval_of], },
      { change free_monoid.lift _ (free_monoid.of _ * free_monoid.of _) =
          free_monoid.lift _ (free_monoid.of _),
        simp only [monoid_hom.map_mul, free_monoid.lift_eval_of], }
    end,
  inv_fun := λ f i, f.comp of,
  left_inv := by { intro fi, ext i x,
    rw [monoid_hom.comp_apply, of_apply, con.lift_mk', free_monoid.lift_eval_of], },
  right_inv := by { intro f, ext i x,
    simp only [monoid_hom.comp_apply, of_apply, con.lift_mk', free_monoid.lift_eval_of], } }

@[simp] lemma lift_of {N} [monoid N] (fi : Π i, M i →* N) {i} (m : M i) :
  lift fi (of m) = fi i m :=
by conv_rhs { rw [←lift.symm_apply_apply fi, lift_symm_apply, monoid_hom.comp_apply] }

@[elab_as_eliminator]
lemma induction_on {C : free_product M → Prop}
  (m : free_product M)
  (h_one : C 1)
  (h_of : ∀ (i) (m : M i), C (of m))
  (h_mul : ∀ (x y), C x → C y → C (x * y)) :
  C m :=
begin
  let S : submonoid (free_product M) := submonoid.mk (set_of C) h_mul h_one,
  convert subtype.prop (lift (λ i, of.cod_restrict S (h_of i)) m),
  change monoid_hom.id _ m = S.subtype.comp _ m,
  congr,
  ext,
  simp [monoid_hom.cod_restrict],
end

lemma of_left_inverse [decidable_eq ι] (i : ι) :
  function.left_inverse (lift $ pi.mul_single i (monoid_hom.id (M i))) of :=
λ x, by simp only [lift_of, pi.mul_single_eq_same, monoid_hom.id_apply]

lemma of_injective (i : ι) : function.injective ⇑(of : M i →* _) :=
by { classical, exact (of_left_inverse i).injective }

lemma lift_mrange_le {N} [monoid N] (f : Π i, M i →* N) {s : submonoid N}
  (h : ∀ i, (f i).mrange ≤ s) : (lift f).mrange ≤ s :=
begin
  rintros _ ⟨x, rfl⟩,
  induction x using free_product.induction_on with i x x y hx hy,
  { exact s.one_mem, },
  { simp only [lift_of, set_like.mem_coe], exact h i (set.mem_range_self x), },
  { simp only [map_mul, set_like.mem_coe], exact s.mul_mem hx hy, },
end

lemma mrange_eq_supr {N} [monoid N] (f : Π i, M i →* N) :
  (lift f).mrange = ⨆ i, (f i).mrange :=
begin
  apply le_antisymm (lift_mrange_le f (λ i, le_supr _ i)),
  apply supr_le _,
  rintros i _ ⟨x, rfl⟩,
  exact ⟨of x, by simp only [lift_of]⟩
end

section group

variables (G : ι → Type*) [Π i, group (G i)]

instance : has_inv (free_product G) :=
{ inv := mul_opposite.unop ∘
    lift (λ i, (of : G i →* _).op.comp (mul_equiv.inv' (G i)).to_monoid_hom) }

lemma inv_def (x : free_product G) : x⁻¹ = mul_opposite.unop
  (lift (λ i, (of : G i →* _).op.comp (mul_equiv.inv' (G i)).to_monoid_hom) x) := rfl

instance : group (free_product G) :=
{ mul_left_inv := begin
    intro m,
    rw inv_def,
    apply m.induction_on,
    { rw [monoid_hom.map_one, mul_opposite.unop_one, one_mul], },
    { intros i m, change of m⁻¹ * of m = 1, rw [←of.map_mul, mul_left_inv, of.map_one], },
    { intros x y hx hy,
      rw [monoid_hom.map_mul, mul_opposite.unop_mul, mul_assoc, ← mul_assoc _ x y, hx,
        one_mul, hy], },
  end,
  ..free_product.has_inv G,
  ..free_product.monoid G }

lemma lift_range_le {N} [group N] (f : Π i, G i →* N) {s : subgroup N}
  (h : ∀ i, (f i).range ≤ s) : (lift f).range ≤ s :=
begin
  rintros _ ⟨x, rfl⟩,
  induction x using free_product.induction_on with i x x y hx hy,
  { exact s.one_mem, },
  { simp only [lift_of, set_like.mem_coe], exact h i (set.mem_range_self x), },
  { simp only [map_mul, set_like.mem_coe], exact s.mul_mem hx hy, },
end

lemma range_eq_supr {N} [group N] (f : Π i, G i →* N) :
  (lift f).range = ⨆ i, (f i).range :=
begin
  apply le_antisymm (lift_range_le _ f (λ i, le_supr _ i)),
  apply supr_le _,
  rintros i _ ⟨x, rfl⟩,
  exact ⟨of x, by simp only [lift_of]⟩
end

end group

namespace word

/-- The empty reduced word. -/
def empty : word M := { to_list := [], ne_one := λ _, false.elim, chain_ne := list.chain'_nil }

instance : inhabited (word M) := ⟨empty⟩

/-- A reduced word determines an element of the free product, given by multiplication. -/
def prod (w : word M) : free_product M :=
list.prod (w.to_list.map $ λ l, of l.snd)

@[simp] lemma prod_empty : prod (empty : word M) = 1 := rfl

/-- `fst_idx w` is `some i` if the first letter of `w` is `⟨i, m⟩` with `m : M i`. If `w` is empty
then it's `none`. -/
def fst_idx (w : word M) : option ι := w.to_list.head'.map sigma.fst

lemma fst_idx_ne_iff {w : word M} {i} :
  fst_idx w ≠ some i ↔ ∀ l ∈ w.to_list.head', i ≠ sigma.fst l :=
not_iff_not.mp $ by simp [fst_idx]

variable (M)

/-- Given an index `i : ι`, `pair M i` is the type of pairs `(head, tail)` where `head : M i` and
`tail : word M`, subject to the constraint that first letter of `tail` can't be `⟨i, m⟩`.
By prepending `head` to `tail`, one obtains a new word. We'll show that any word can be uniquely
obtained in this way. -/
@[ext] structure pair (i : ι) :=
(head : M i)
(tail : word M)
(fst_idx_ne : fst_idx tail ≠ some i)

instance (i : ι) : inhabited (pair M i) := ⟨⟨1, empty, by tauto⟩⟩

variable {M}

variables [∀ i, decidable_eq (M i)]

/-- Given a pair `(head, tail)`, we can form a word by prepending `head` to `tail`, except if `head`
is `1 : M i` then we have to just return `word` since we need the result to be reduced. -/
def rcons {i} (p : pair M i) : word M :=
if h : p.head = 1 then p.tail
else { to_list  := ⟨i, p.head⟩ :: p.tail.to_list,
       ne_one   := by { rintros l (rfl | hl), exact h, exact p.tail.ne_one l hl },
       chain_ne := p.tail.chain_ne.cons' (fst_idx_ne_iff.mp p.fst_idx_ne) }

/-- Given a word of the form `⟨l :: ls, h1, h2⟩`, we can form a word of the form `⟨ls, _, _⟩`,
dropping the first letter. -/
private def mk_aux {l} (ls : list (Σ i, M i)) (h1 : ∀ l' ∈ l :: ls, sigma.snd l' ≠ 1)
  (h2 : (l :: ls).chain' _) : word M :=
⟨ls, λ l' hl, h1 _ (list.mem_cons_of_mem _ hl), h2.tail⟩

lemma cons_eq_rcons {i} {m : M i} {ls h1 h2} :
  word.mk (⟨i, m⟩ :: ls) h1 h2 = rcons ⟨m, mk_aux ls h1 h2, fst_idx_ne_iff.mpr h2.rel_head'⟩ :=
by { rw [rcons, dif_neg], refl, exact h1 ⟨i, m⟩ (ls.mem_cons_self _) }

@[simp] lemma prod_rcons {i} (p : pair M i) :
  prod (rcons p) = of p.head * prod p.tail :=
if hm : p.head = 1 then by rw [rcons, dif_pos hm, hm, monoid_hom.map_one, one_mul]
else by rw [rcons, dif_neg hm, prod, list.map_cons, list.prod_cons, prod]

lemma rcons_inj {i} : function.injective (rcons : pair M i → word M) :=
begin
  rintros ⟨m, w, h⟩ ⟨m', w', h'⟩ he,
  by_cases hm : m = 1;
  by_cases hm' : m' = 1,
  { simp only [rcons, dif_pos hm, dif_pos hm'] at he, cc, },
  { exfalso, simp only [rcons, dif_pos hm, dif_neg hm'] at he, rw he at h, exact h rfl },
  { exfalso, simp only [rcons, dif_pos hm', dif_neg hm] at he, rw ←he at h', exact h' rfl, },
  { have : m = m' ∧ w.to_list = w'.to_list,
    { simpa only [rcons, dif_neg hm, dif_neg hm', true_and, eq_self_iff_true, subtype.mk_eq_mk,
      heq_iff_eq, ←subtype.ext_iff_val] using he },
    rcases this with ⟨rfl, h⟩,
    congr, exact word.ext _ _ h, }
end

variable [decidable_eq ι]

/-- Given `i : ι`, any reduced word can be decomposed into a pair `p` such that `w = rcons p`. -/
-- This definition is computable but not very nice to look at. Thankfully we don't have to inspect
-- it, since `rcons` is known to be injective.
private def equiv_pair_aux (i) : Π w : word M, { p : pair M i // rcons p = w }
| w@⟨[], _, _⟩             := ⟨⟨1, w, by rintro ⟨⟩⟩, dif_pos rfl⟩
| w@⟨⟨j, m⟩ :: ls, h1, h2⟩ := if ij : i = j then
  { val := { head := ij.symm.rec m,
             tail := mk_aux ls h1 h2,
             fst_idx_ne := by cases ij; exact fst_idx_ne_iff.mpr h2.rel_head' },
    property := by cases ij; exact cons_eq_rcons.symm }
else ⟨⟨1, w, (option.some_injective _).ne (ne.symm ij)⟩, dif_pos rfl⟩

/-- The equivalence between words and pairs. Given a word, it decomposes it as a pair by removing
the first letter if it comes from `M i`. Given a pair, it prepends the head to the tail. -/
def equiv_pair (i) : word M ≃ pair M i :=
{ to_fun := λ w, (equiv_pair_aux i w).val,
  inv_fun := rcons,
  left_inv := λ w, (equiv_pair_aux i w).property,
  right_inv := λ p, rcons_inj (equiv_pair_aux i _).property }

lemma equiv_pair_symm (i) (p : pair M i) : (equiv_pair i).symm p = rcons p := rfl

lemma equiv_pair_eq_of_fst_idx_ne {i} {w : word M} (h : fst_idx w ≠ some i) :
  equiv_pair i w = ⟨1, w, h⟩ :=
(equiv_pair i).apply_eq_iff_eq_symm_apply.mpr $ eq.symm (dif_pos rfl)

instance summand_action (i) : mul_action (M i) (word M) :=
{ smul     := λ m w, rcons { head := m * (equiv_pair i w).head, ..equiv_pair i w },
  one_smul := λ w, by { simp_rw [one_mul], apply (equiv_pair i).symm_apply_eq.mpr, ext; refl },
  mul_smul := λ m m' w, by simp only [mul_assoc, ←equiv_pair_symm, equiv.apply_symm_apply], }

instance : mul_action (free_product M) (word M) :=
mul_action.of_End_hom (lift (λ i, mul_action.to_End_hom))

lemma of_smul_def (i) (w : word M) (m : M i) :
  of m • w = rcons { head := m * (equiv_pair i w).head, ..equiv_pair i w } := rfl

lemma cons_eq_smul {i} {m : M i} {ls h1 h2} :
  word.mk (⟨i, m⟩ :: ls) h1 h2 = of m • mk_aux ls h1 h2 :=
by rw [cons_eq_rcons, of_smul_def, equiv_pair_eq_of_fst_idx_ne _]; simp only [mul_one]

lemma smul_induction {C : word M → Prop}
  (h_empty : C empty)
  (h_smul : ∀ i (m : M i) w, C w → C (of m • w))
  (w : word M) : C w :=
begin
  cases w with ls h1 h2,
  induction ls with l ls ih,
  { exact h_empty },
  cases l with i m,
  rw cons_eq_smul,
  exact h_smul _ _ _ (ih _ _),
end

@[simp] lemma prod_smul (m) : ∀ w : word M, prod (m • w) = m * prod w :=
begin
  apply m.induction_on,
  { intro, rw [one_smul, one_mul] },
  { intros, rw [of_smul_def, prod_rcons, of.map_mul, mul_assoc, ←prod_rcons,
      ←equiv_pair_symm, equiv.symm_apply_apply] },
  { intros x y hx hy w, rw [mul_smul, hx, hy, mul_assoc] },
end

/-- Each element of the free product corresponds to a unique reduced word. -/
def equiv : free_product M ≃ word M :=
{ to_fun := λ m, m • empty,
  inv_fun := λ w, prod w,
  left_inv := λ m, by dsimp only; rw [prod_smul, prod_empty, mul_one],
  right_inv := begin
    apply smul_induction,
    { dsimp only, rw [prod_empty, one_smul], },
    { dsimp only, intros i m w ih, rw [prod_smul, mul_smul, ih], },
  end }

instance : decidable_eq (word M) := function.injective.decidable_eq word.ext
instance : decidable_eq (free_product M) := word.equiv.decidable_eq

end word

variable (M)

/-- A `neword M i j` is a representation of a non-empty reduced words where the first letter comes
from `M i` and the last letter comes from `M j`. It can be constructed from singletons and via
concatentation, and thus provides a useful induction principle. -/
@[nolint has_inhabited_instance]
inductive neword : ι → ι → Type (max u_1 u_2)
| singleton : ∀ {i} (x : M i) (hne1 : x ≠ 1), neword i i
| append : ∀ {i j k l} (w₁ : neword i j) (hne : j ≠ k) (w₂ : neword k l), neword i l
variable {M}

namespace neword

open word

/-- The list represented by a given `neword` -/
@[simp]
def to_list : Π {i j} (w : neword M i j), list (Σ i, M i)
| i _ (singleton x hne1) := [⟨i, x⟩]
| _ _ (append w₁ hne w₂) := w₁.to_list ++ w₂.to_list

/--  The first letter of a `neword` -/
@[simp]
def head : Π {i j} (w : neword M i j), M i
| i _ (singleton x hne1) := x
| _ _ (append w₁ hne w₂) := w₁.head

/--  The last letter of a `neword` -/
@[simp]
def last : Π {i j} (w : neword M i j), M j
| i _ (singleton x hne1) := x
| _ _ (append w₁ hne w₂) := w₂.last

@[simp]
lemma to_list_head' {i j} (w : neword M i j) :
  w.to_list.head' = option.some ⟨i, w.head⟩ :=
begin
  rw ← option.mem_def,
  induction w,
  { rw option.mem_def, reflexivity, },
  { exact list.head'_append w_ih_w₁, },
end

@[simp]
lemma to_list_last' {i j} (w : neword M i j) :
  w.to_list.last' = option.some ⟨j, w.last⟩ :=
begin
  rw ← option.mem_def,
  induction w,
  { rw option.mem_def, reflexivity, },
  { exact list.last'_append w_ih_w₂, },
end

/-- The `word M` represented by a `neword M i j` -/
def to_word {i j} (w : neword M i j) : word M :=
{ to_list := w.to_list,
  ne_one :=
  begin
    induction w,
    { rintros ⟨k,x⟩ ⟨rfl, rfl⟩,
      exact w_hne1,
      exfalso, apply H, },
    { intros l h,
      simp only [to_list, list.mem_append] at h,
      cases h,
      { exact w_ih_w₁ _ h, },
      { exact w_ih_w₂ _ h, }, },
  end,
  chain_ne := begin
    induction w,
    { exact list.chain'_singleton _, },
    { apply list.chain'.append w_ih_w₁ w_ih_w₂,
      intros x hx y hy,
      rw [w_w₁.to_list_last', option.mem_some_iff] at hx,
      rw [w_w₂.to_list_head', option.mem_some_iff] at hy,
      subst hx, subst hy,
      exact w_hne, },
  end, }

/-- Every nonempty `word M` can be constructed as a `neword M i j` -/
lemma of_word (w : word M) (h : w ≠ empty) :
  ∃ i j (w' : neword M i j), w'.to_word = w :=
begin
  suffices : ∃ i j (w' : neword M i j), w'.to_word.to_list = w.to_list,
  { obtain ⟨i, j, w, h⟩ := this, refine ⟨i, j, w, _⟩, ext, rw h, },
  cases w with l hnot1 hchain,
  induction l with x l hi,
  { contradiction, },
  { rw list.forall_mem_cons at hnot1,
    cases l with y l,
    { refine ⟨x.1, x.1, singleton x.2 hnot1.1, _ ⟩,
      simp [to_word], },
    { rw list.chain'_cons at hchain,
      specialize hi hnot1.2 hchain.2 (by rintros ⟨rfl⟩),
      obtain ⟨i, j, w', hw' : w'.to_list = y :: l⟩ := hi,
      obtain rfl : y = ⟨i, w'.head⟩, by simpa [hw'] using w'.to_list_head',
      refine ⟨x.1, j, append (singleton x.2 hnot1.1) hchain.1 w', _⟩,
      { simpa [to_word] using hw', } } }
end

/-- A non-empty reduced word determines an element of the free product, given by multiplication. -/
def prod {i j} (w : neword M i j) := w.to_word.prod

@[simp]
lemma singleton_head {i} (x : M i) (hne_one : x ≠ 1) :
  (singleton x hne_one).head = x := rfl

@[simp]
lemma singleton_last {i} (x : M i) (hne_one : x ≠ 1) :
  (singleton x hne_one).last = x := rfl

@[simp] lemma prod_singleton {i} (x : M i) (hne_one : x ≠ 1) :
  (singleton x hne_one).prod = of x :=
by simp [to_word, prod, word.prod]

@[simp]
lemma append_head {i j k l} {w₁ : neword M i j} {hne : j ≠ k} {w₂ : neword M k l} :
  (append w₁ hne w₂).head = w₁.head := rfl

@[simp]
lemma append_last {i j k l} {w₁ : neword M i j} {hne : j ≠ k} {w₂ : neword M k l} :
  (append w₁ hne w₂).last = w₂.last := rfl

@[simp]
lemma append_prod {i j k l} {w₁ : neword M i j} {hne : j ≠ k} {w₂ : neword M k l} :
  (append w₁ hne w₂).prod = w₁.prod * w₂.prod :=
by simp [to_word, prod, word.prod]

/-- One can replace the first letter in a non-empty reduced word by an element of the same
group -/
def replace_head : Π {i j : ι} (x : M i) (hnotone : x ≠ 1) (w : neword M i j), neword M i j
| _ _ x h (singleton _ _) := singleton x h
| _ _ x h (append w₁ hne w₂) := append (replace_head x h w₁) hne w₂

@[simp]
lemma replace_head_head {i j : ι} (x : M i) (hnotone : x ≠ 1) (w : neword M i j) :
  (replace_head x hnotone w).head = x :=
by { induction w, refl, exact w_ih_w₁ _ _, }

/-- One can multiply an element from the left to a non-empty reduced word if it does not cancel
with the first element in the word. -/
def mul_head {i j : ι} (w : neword M i j) (x : M i) (hnotone : x * w.head ≠ 1) :
  neword M i j := replace_head (x * w.head) hnotone w

@[simp]
lemma mul_head_head {i j : ι} (w : neword M i j) (x : M i) (hnotone : x * w.head ≠ 1) :
   (mul_head w x hnotone).head = x * w.head :=
by { induction w, refl, exact w_ih_w₁ _ _, }

@[simp]
lemma mul_head_prod {i j : ι} (w : neword M i j) (x : M i) (hnotone : x * w.head ≠ 1) :
  (mul_head w x hnotone).prod = of x * w.prod :=
begin
  unfold mul_head,
  induction w,
  { simp [mul_head, replace_head], },
  { specialize w_ih_w₁ _ hnotone, clear w_ih_w₂,
    simp [replace_head, ← mul_assoc] at *,
    congr' 1, }
end

section group

variables {G : ι → Type*} [Π i, group (G i)]

/-- The inverse of a non-empty reduced word -/
def inv : Π {i j} (w : neword G i j), neword G j i
| _ _ (singleton x h) := singleton x⁻¹ (mt inv_eq_one.mp h)
| _ _ (append w₁ h w₂) := append w₂.inv h.symm w₁.inv

@[simp]
lemma inv_prod {i j} (w : neword G i j) : w.inv.prod = w.prod⁻¹ :=
by induction w; simp [inv, *]

@[simp]
lemma inv_head {i j} (w : neword G i j) : w.inv.head = w.last⁻¹ :=
by induction w; simp [inv, *]

@[simp]
lemma inv_last {i j} (w : neword G i j) : w.inv.last = w.head⁻¹ :=
by induction w; simp [inv, *]

end group

end neword

section ping_pong_lemma

open_locale pointwise
open_locale cardinal

variables [hnontriv : nontrivial ι]
variables {G : Type*} [group G]
variables {H : ι → Type*} [∀ i, group (H i)]
variables (f : Π i, H i →* G)

-- We need many groups or one group with many elements
variables (hcard : 3 ≤ # ι ∨ ∃ i, 3 ≤ # (H i))

-- A group action on α, and the ping-pong sets
variables {α : Type*} [mul_action G α]
variables (X : ι → set α)
variables (hXnonempty : ∀ i, (X i).nonempty)
variables (hXdisj : pairwise (λ i j, disjoint (X i) (X j)))
variables (hpp : pairwise (λ i j, ∀ h : H i, h ≠ 1 → f i h • X j ⊆ X i))

include hpp

lemma lift_word_ping_pong {i j k} (w : neword H i j) (hk : j ≠ k) :
  lift f w.prod • X k ⊆ X i :=
begin
  rename [i → i', j → j', k → m, hk → hm],
  induction w with i x hne_one i j k l w₁ hne w₂  hIw₁ hIw₂ generalizing m; clear i' j',
  { simpa using hpp _ _ hm _ hne_one, },
  { calc lift f (neword.append w₁ hne w₂).prod • X m
        = lift f w₁.prod • lift f w₂.prod • X m : by simp [mul_action.mul_smul]
    ... ⊆ lift f w₁.prod • X k : set_smul_subset_set_smul_iff.mpr (hIw₂ hm)
    ... ⊆ X i : hIw₁ hne },
end

include X hXnonempty hXdisj

lemma lift_word_prod_nontrivial_of_other_i {i j k} (w : neword H i j)
  (hhead : k ≠ i) (hlast : k ≠ j) : lift f w.prod ≠ 1 :=
begin
  intro heq1,
  have : X k ⊆ X i,
    by simpa [heq1] using lift_word_ping_pong f X hpp w hlast.symm,
  obtain ⟨x, hx⟩ := hXnonempty k,
  exact hXdisj k i hhead ⟨hx, this hx⟩,
end

include hnontriv

lemma lift_word_prod_nontrivial_of_head_eq_last {i} (w : neword H i i) :
  lift f w.prod ≠ 1 :=
begin
  obtain ⟨k, hk⟩ := exists_ne i,
  exact lift_word_prod_nontrivial_of_other_i f X hXnonempty hXdisj hpp w hk hk,
end

lemma lift_word_prod_nontrivial_of_head_card {i j} (w : neword H i j)
  (hcard : 3 ≤ # (H i)) (hheadtail : i ≠ j) : lift f w.prod ≠ 1 :=
begin
  obtain ⟨h, hn1, hnh⟩ := cardinal.three_le hcard 1 (w.head⁻¹),
  have hnot1 : h * w.head ≠ 1, by { rw ← div_inv_eq_mul, exact div_ne_one_of_ne hnh },
  let w' : neword H i i := neword.append
    (neword.mul_head w h hnot1) hheadtail.symm
    (neword.singleton h⁻¹ (inv_ne_one.mpr hn1)),
  have hw' : lift f w'.prod ≠ 1 :=
    lift_word_prod_nontrivial_of_head_eq_last f X hXnonempty hXdisj hpp w',
  intros heq1, apply hw', simp [w', heq1]
end

include hcard
lemma lift_word_prod_nontrivial_of_not_empty {i j} (w : neword H i j) :
  lift f w.prod ≠ 1 :=
begin
  classical,
  cases hcard,
  { obtain ⟨i, h1, h2⟩ := cardinal.three_le hcard i j,
    exact lift_word_prod_nontrivial_of_other_i f X hXnonempty hXdisj hpp w h1 h2, },
  { cases hcard with k hcard,
    by_cases hh : i = k; by_cases hl : j = k,
    { subst hh, subst hl,
      exact lift_word_prod_nontrivial_of_head_eq_last f X hXnonempty hXdisj hpp w, },
    { subst hh,
      change j ≠ i at hl,
      exact lift_word_prod_nontrivial_of_head_card f X hXnonempty hXdisj hpp w hcard hl.symm, },
    { subst hl,
      change i ≠ j at hh,
      have : lift f w.inv.prod ≠ 1 :=
        lift_word_prod_nontrivial_of_head_card f X hXnonempty hXdisj hpp w.inv hcard hh.symm,
      intros heq, apply this, simpa using heq, },
    { change i ≠ k at hh,
      change j ≠ k at hl,
      obtain ⟨h, hn1, -⟩ := cardinal.three_le hcard 1 1,
      let w' : neword H k k := neword.append
        (neword.append (neword.singleton h hn1) hh.symm w)
        hl (neword.singleton h⁻¹ (inv_ne_one.mpr hn1)) ,
      have hw' : lift f w'.prod ≠ 1 :=
        lift_word_prod_nontrivial_of_head_eq_last f X hXnonempty hXdisj hpp w',
      intros heq1, apply hw', simp [w', heq1], }, }
end

lemma empty_of_word_prod_eq_one {w : word H} (h : lift f w.prod = 1) :
  w = word.empty :=
begin
  by_contradiction hnotempty,
  obtain ⟨i, j, w, rfl⟩ := neword.of_word w hnotempty,
  exact lift_word_prod_nontrivial_of_not_empty f hcard X hXnonempty hXdisj hpp w h,
end

/--
The Ping-Pong-Lemma.

Given a group action of `G` on `X` so that the `H i` acts in a specific way on disjoint subsets
`X i` we can prove that `lift f` is injective, and thus the image of `lift f` is isomorphic to the
direct product of the `H i`.

Often the Ping-Pong-Lemma is stated with regard to subgroups `H i` that generate the whole group;
we generalize to arbitrary group homomorphisms `f i : H i →* G` and do not require the group to be
generated by the images.

Usually the Ping-Pong-Lemma requires that one group `H i` has at least three elements. This
condition is only needed if `# ι = 2`, and we accept `3 ≤ # ι` as an alternative.
-/
theorem lift_injective_of_ping_pong:
  function.injective (lift f) :=
begin
  classical,
  apply (injective_iff_map_eq_one (lift f)).mpr,
  rw (free_product.word.equiv : _ ≃ word H).forall_congr_left',
  { intros w Heq,
    dsimp [word.equiv] at *,
    { rw empty_of_word_prod_eq_one f hcard X hXnonempty hXdisj hpp Heq,
      reflexivity, }, },
end

end ping_pong_lemma

/-- The free product of free groups is itself a free group -/
@[simps]
instance {ι : Type*} (G : ι → Type*) [∀ i, group (G i)] [hG : ∀ i, is_free_group (G i)] :
  is_free_group (free_product G) :=
{ generators := Σ i, is_free_group.generators (G i),
  mul_equiv :=
  monoid_hom.to_mul_equiv
    (free_group.lift (λ (x : Σ i, is_free_group.generators (G i)),
      free_product.of (is_free_group.of x.2 : G x.1)))
    (free_product.lift (λ (i : ι),
      (is_free_group.lift (λ (x : is_free_group.generators (G i)),
        free_group.of (⟨i, x⟩ : Σ i, is_free_group.generators (G i)))
        : G i →* (free_group (Σ i, is_free_group.generators (G i))))))
    (by {ext, simp, })
   (by {ext, simp, }) }

/-- A free group is a free product of copies of the free_group over one generator. -/

-- NB: One might expect this theorem to be phrased with ℤ, but ℤ is an additive group,
-- and using `multiplicative ℤ` runs into diamond issues.
@[simps]
def _root_.free_group_equiv_free_product {ι : Type u_1} :
  free_group ι ≃* free_product (λ (_ : ι), free_group unit) :=
begin
  refine monoid_hom.to_mul_equiv _ _ _ _,
  exact free_group.lift (λ i, @free_product.of ι _ _ i (free_group.of unit.star)),
  exact free_product.lift (λ i, free_group.lift (λ pstar, free_group.of i)),
  { ext i, refl, },
  { ext i a, cases a, refl, },
end

section ping_pong_lemma

open_locale pointwise cardinal

variables [nontrivial ι]
variables {G : Type u_1} [group G] (a : ι → G)

-- A group action on α, and the ping-pong sets
variables {α : Type*} [mul_action G α]
variables (X Y : ι → set α)
variables (hXnonempty : ∀ i, (X i).nonempty)
variables (hXdisj : pairwise (λ i j, disjoint (X i) (X j)))
variables (hYdisj : pairwise (λ i j, disjoint (Y i) (Y j)))
variables (hXYdisj : ∀ i j, disjoint (X i) (Y j))
variables (hX : ∀ i, a i • (Y i)ᶜ ⊆ X i)
variables (hY : ∀ i, a⁻¹ i • (X i)ᶜ ⊆ Y i)

include hXnonempty hXdisj hYdisj hXYdisj hX hY

/--
The Ping-Pong-Lemma.

Given a group action of `G` on `X` so that the generators of the free groups act in specific
ways on disjoint subsets `X i` and `Y i` we can prove that `lift f` is injective, and thus the image
of `lift f` is isomorphic to the free group.

Often the Ping-Pong-Lemma is stated with regard to group elements that generate the whole group;
we generalize to arbitrary group homomorphisms from the free group to `G`  and do not require the
group to be generated by the elements.
-/
theorem _root_.free_group.injective_lift_of_ping_pong :
  function.injective (free_group.lift a) :=
begin
  -- Step one: express the free group lift via the free product lift
  have : free_group.lift a =
    (free_product.lift (λ i, free_group.lift (λ _, a i))).comp
    (((@free_group_equiv_free_product ι)).to_monoid_hom),
  { ext i, simp, },
  rw this, clear this,
  refine function.injective.comp _ (mul_equiv.injective _),

  -- Step two: Invoke the ping-pong lemma for free products
  show function.injective (lift (λ (i : ι), free_group.lift (λ _, a i))),

  -- Prepare to instantiate lift_injective_of_ping_pong
  let H : ι → Type _ := λ i, free_group unit,
  let f : Π i, H i →* G := λ i, free_group.lift (λ _, a i),
  let X' : ι → set α := λ i, X i ∪ Y i,

  apply lift_injective_of_ping_pong f _ X',

  show _ ∨ ∃ i, 3 ≤ # (H i),
  { inhabit ι,
    right, use arbitrary ι,
    simp only [H],
    rw [free_group.free_group_unit_equiv_int.cardinal_eq, cardinal.mk_denumerable],
    apply le_of_lt,
    simp },

  show ∀ i, (X' i).nonempty,
  { exact (λ i, set.nonempty.inl (hXnonempty i)), },

  show pairwise (λ i j, disjoint (X' i) (X' j)),
  { intros i j hij,
    simp only [X'],
    apply disjoint.union_left; apply disjoint.union_right,
    { exact hXdisj i j hij, },
    { exact hXYdisj i j, },
    { exact (hXYdisj j i).symm, },
    { exact hYdisj i j hij, }, },

  show pairwise (λ i j, ∀ h : H i, h ≠ 1 → f i h • X' j ⊆ X' i),
  { rintros i j hij,
    -- use free_group unit ≃ ℤ
    refine free_group.free_group_unit_equiv_int.forall_congr_left'.mpr _,
    intros n hne1,
    change free_group.lift (λ _, a i) (free_group.of () ^ n) • X' j ⊆ X' i,
    simp only [map_zpow, free_group.lift.of],
    change a i ^ n • X' j ⊆ X' i,
    have hnne0 : n ≠ 0, { rintro rfl, apply hne1, simpa, }, clear hne1,
    simp only [X'],

    -- Positive and negative powers separately
    cases (lt_or_gt_of_ne hnne0).swap with hlt hgt,
    { have h1n : 1 ≤ n := hlt,
      calc a i ^ n • X' j ⊆ a i ^ n • (Y i)ᶜ : set_smul_subset_set_smul_iff.mpr $
        set.disjoint_iff_subset_compl_right.mp $
          disjoint.union_left (hXYdisj j i) (hYdisj j i hij.symm)
      ... ⊆ X i :
      begin
        refine int.le_induction _ _ _ h1n,
        { rw zpow_one, exact hX i, },
        { intros n hle hi,
          calc (a i ^ (n + 1)) • (Y i)ᶜ
                = (a i ^ n * a i) • (Y i)ᶜ : by rw [zpow_add, zpow_one]
            ... = a i ^ n • (a i • (Y i)ᶜ) : mul_action.mul_smul _ _ _
            ... ⊆ a i ^ n • X i : set_smul_subset_set_smul_iff.mpr $ hX i
            ... ⊆ a i ^ n • (Y i)ᶜ : set_smul_subset_set_smul_iff.mpr $
              set.disjoint_iff_subset_compl_right.mp (hXYdisj i i)
            ... ⊆ X i : hi, },
      end
      ... ⊆ X' i : set.subset_union_left _ _, },
    { have h1n : n ≤ -1, { apply int.le_of_lt_add_one, simpa using hgt, },
      calc a i ^ n • X' j ⊆ a i ^ n • (X i)ᶜ : set_smul_subset_set_smul_iff.mpr $
        set.disjoint_iff_subset_compl_right.mp $
          disjoint.union_left (hXdisj j i hij.symm) (hXYdisj i j).symm
      ... ⊆ Y i :
      begin
        refine int.le_induction_down _ _ _ h1n,
        { rw [zpow_neg, zpow_one], exact hY i, },
        { intros n hle hi,
          calc (a i ^ (n - 1)) • (X i)ᶜ
                = (a i ^ n * (a i)⁻¹) • (X i)ᶜ : by rw [zpow_sub, zpow_one]
            ... = a i ^ n • ((a i)⁻¹ • (X i)ᶜ) : mul_action.mul_smul _ _ _
            ... ⊆ a i ^ n • Y i : set_smul_subset_set_smul_iff.mpr $ hY i
            ... ⊆ a i ^ n • (X i)ᶜ : set_smul_subset_set_smul_iff.mpr $
              set.disjoint_iff_subset_compl_right.mp (hXYdisj i i).symm
            ... ⊆ Y i : hi, },
      end
      ... ⊆ X' i : set.subset_union_right _ _, }, },
end

end ping_pong_lemma

end free_product


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Johannes Hölzl, Simon Hudon, Kenny Lau
-/
import data.multiset.basic
import control.traversable.lemmas
import control.traversable.instances

/-!
# Functoriality of `multiset`.
-/

universes u

namespace multiset

open list

instance : functor multiset :=
{ map := @map }

@[simp] lemma fmap_def {α' β'} {s : multiset α'} (f : α' → β') : f <$> s = s.map f := rfl

instance : is_lawful_functor multiset :=
by refine { .. }; intros; simp

open is_lawful_traversable is_comm_applicative

variables {F : Type u → Type u} [applicative F] [is_comm_applicative F]
variables {α' β' : Type u} (f : α' → F β')

def traverse : multiset α' → F (multiset β') :=
quotient.lift (functor.map coe ∘ traversable.traverse f)
begin
  introv p, unfold function.comp,
  induction p,
  case perm.nil { refl },
  case perm.cons {
    have : multiset.cons <$> f p_x <*> (coe <$> traverse f p_l₁) =
      multiset.cons <$> f p_x <*> (coe <$> traverse f p_l₂),
    { rw [p_ih] },
    simpa with functor_norm },
  case perm.swap {
    have : (λa b (l:list β'), (↑(a :: b :: l) : multiset β')) <$> f p_y <*> f p_x =
      (λa b l, ↑(a :: b :: l)) <$> f p_x <*> f p_y,
    { rw [is_comm_applicative.commutative_map],
      congr, funext a b l, simpa [flip] using perm.swap b a l },
    simp [(∘), this] with functor_norm },
  case perm.trans { simp [*] }
end

instance : monad multiset :=
{ pure := λ α x, x ::ₘ 0,
  bind := @bind,
  .. multiset.functor }

@[simp] lemma pure_def {α} : (pure : α → multiset α) = (λ x, x ::ₘ 0) := rfl
@[simp] lemma bind_def {α β} : (>>=) = @bind α β := rfl

instance : is_lawful_monad multiset :=
{ bind_pure_comp_eq_map := λ α β f s, multiset.induction_on s rfl $ λ a s ih, by simp,
  pure_bind := λ α β x f, by simp,
  bind_assoc := @bind_assoc }

open functor
open traversable is_lawful_traversable

@[simp]
lemma lift_coe {α β : Type*} (x : list α) (f : list α → β)
  (h : ∀ a b : list α, a ≈ b → f a = f b) :
  quotient.lift f h (x : multiset α) = f x :=
quotient.lift_mk _ _ _

@[simp]
lemma map_comp_coe {α β} (h : α → β) :
  functor.map h ∘ coe = (coe ∘ functor.map h : list α → multiset β) :=
by funext; simp [functor.map]

lemma id_traverse {α : Type*} (x : multiset α) :
  traverse id.mk x = x :=
quotient.induction_on x begin intro, simp [traverse], refl end

lemma comp_traverse {G H : Type* → Type*}
               [applicative G] [applicative H]
               [is_comm_applicative G] [is_comm_applicative H]
               {α β γ : Type*}
               (g : α → G β) (h : β → H γ) (x : multiset α) :
  traverse (comp.mk ∘ functor.map h ∘ g) x =
  comp.mk (functor.map (traverse h) (traverse g x)) :=
quotient.induction_on x
(by intro;
    simp [traverse,comp_traverse] with functor_norm;
    simp [(<$>),(∘)] with functor_norm)

lemma map_traverse {G : Type* → Type*}
               [applicative G] [is_comm_applicative G]
               {α β γ : Type*}
               (g : α → G β) (h : β → γ)
               (x : multiset α) :
  functor.map (functor.map h) (traverse g x) =
  traverse (functor.map h ∘ g) x :=
quotient.induction_on x
(by intro; simp [traverse] with functor_norm;
    rw [is_lawful_functor.comp_map, map_traverse])

lemma traverse_map {G : Type* → Type*}
               [applicative G] [is_comm_applicative G]
               {α β γ : Type*}
               (g : α → β) (h : β → G γ)
               (x : multiset α) :
  traverse h (map g x) =
  traverse (h ∘ g) x :=
quotient.induction_on x
(by intro; simp [traverse];
    rw [← traversable.traverse_map h g];
    [ refl, apply_instance ])

lemma naturality {G H : Type* → Type*}
                [applicative G] [applicative H]
                [is_comm_applicative G] [is_comm_applicative H]
                (eta : applicative_transformation G H)
                {α β : Type*} (f : α → G β) (x : multiset α) :
  eta (traverse f x) = traverse (@eta _ ∘ f) x :=
quotient.induction_on x
(by intro; simp [traverse,is_lawful_traversable.naturality] with functor_norm)

end multiset


/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang

! This file was ported from Lean 3 source module topology.quasi_separated
! leanprover-community/mathlib commit ac34df03f74e6f797efd6991df2e3b7f7d8d33e0
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Topology.SubsetProperties
import Mathbin.Topology.Separation
import Mathbin.Topology.NoetherianSpace

/-!
# Quasi-separated spaces

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

A topological space is quasi-separated if the intersections of any pairs of compact open subsets
are still compact.
Notable examples include spectral spaces, Noetherian spaces, and Hausdorff spaces.

A non-example is the interval `[0, 1]` with doubled origin: the two copies of `[0, 1]` are compact
open subsets, but their intersection `(0, 1]` is not.

## Main results

- `is_quasi_separated`: A subset `s` of a topological space is quasi-separated if the intersections
of any pairs of compact open subsets of `s` are still compact.
- `quasi_separated_space`: A topological space is quasi-separated if the intersections of any pairs
of compact open subsets are still compact.
- `quasi_separated_space.of_open_embedding`: If `f : α → β` is an open embedding, and `β` is
  a quasi-separated space, then so is `α`.
-/

open TopologicalSpace

variable {α β : Type _} [TopologicalSpace α] [TopologicalSpace β] {f : α → β}

#print IsQuasiSeparated /-
/-- A subset `s` of a topological space is quasi-separated if the intersections of any pairs of
compact open subsets of `s` are still compact.

Note that this is equivalent to `s` being a `quasi_separated_space` only when `s` is open. -/
def IsQuasiSeparated (s : Set α) : Prop :=
  ∀ U V : Set α, U ⊆ s → IsOpen U → IsCompact U → V ⊆ s → IsOpen V → IsCompact V → IsCompact (U ∩ V)
#align is_quasi_separated IsQuasiSeparated
-/

#print QuasiSeparatedSpace /-
/-- A topological space is quasi-separated if the intersections of any pairs of compact open
subsets are still compact. -/
@[mk_iff]
class QuasiSeparatedSpace (α : Type _) [TopologicalSpace α] : Prop where
  inter_isCompact :
    ∀ U V : Set α, IsOpen U → IsCompact U → IsOpen V → IsCompact V → IsCompact (U ∩ V)
#align quasi_separated_space QuasiSeparatedSpace
-/

#print isQuasiSeparated_univ_iff /-
theorem isQuasiSeparated_univ_iff {α : Type _} [TopologicalSpace α] :
    IsQuasiSeparated (Set.univ : Set α) ↔ QuasiSeparatedSpace α :=
  by
  rw [quasiSeparatedSpace_iff]
  simp [IsQuasiSeparated]
#align is_quasi_separated_univ_iff isQuasiSeparated_univ_iff
-/

#print isQuasiSeparated_univ /-
theorem isQuasiSeparated_univ {α : Type _} [TopologicalSpace α] [QuasiSeparatedSpace α] :
    IsQuasiSeparated (Set.univ : Set α) :=
  isQuasiSeparated_univ_iff.mpr inferInstance
#align is_quasi_separated_univ isQuasiSeparated_univ
-/

/- warning: is_quasi_separated.image_of_embedding -> IsQuasiSeparated.image_of_embedding is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : TopologicalSpace.{u1} α] [_inst_2 : TopologicalSpace.{u2} β] {f : α -> β} {s : Set.{u1} α}, (IsQuasiSeparated.{u1} α _inst_1 s) -> (Embedding.{u1, u2} α β _inst_1 _inst_2 f) -> (IsQuasiSeparated.{u2} β _inst_2 (Set.image.{u1, u2} α β f s))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : TopologicalSpace.{u2} α] [_inst_2 : TopologicalSpace.{u1} β] {f : α -> β} {s : Set.{u2} α}, (IsQuasiSeparated.{u2} α _inst_1 s) -> (Embedding.{u2, u1} α β _inst_1 _inst_2 f) -> (IsQuasiSeparated.{u1} β _inst_2 (Set.image.{u2, u1} α β f s))
Case conversion may be inaccurate. Consider using '#align is_quasi_separated.image_of_embedding IsQuasiSeparated.image_of_embeddingₓ'. -/
theorem IsQuasiSeparated.image_of_embedding {s : Set α} (H : IsQuasiSeparated s) (h : Embedding f) :
    IsQuasiSeparated (f '' s) := by
  intro U V hU hU' hU'' hV hV' hV''
  convert(H (f ⁻¹' U) (f ⁻¹' V) _ (h.continuous.1 _ hU') _ _ (h.continuous.1 _ hV') _).image
      h.continuous
  · symm
    rw [← Set.preimage_inter, Set.image_preimage_eq_inter_range, Set.inter_eq_left_iff_subset]
    exact (Set.inter_subset_left _ _).trans (hU.trans (Set.image_subset_range _ _))
  · intro x hx
    rw [← (h.inj.inj_on _).mem_image_iff (Set.subset_univ _) trivial]
    exact hU hx
  · rw [h.is_compact_iff_is_compact_image]
    convert hU''
    rw [Set.image_preimage_eq_inter_range, Set.inter_eq_left_iff_subset]
    exact hU.trans (Set.image_subset_range _ _)
  · intro x hx
    rw [← (h.inj.inj_on _).mem_image_iff (Set.subset_univ _) trivial]
    exact hV hx
  · rw [h.is_compact_iff_is_compact_image]
    convert hV''
    rw [Set.image_preimage_eq_inter_range, Set.inter_eq_left_iff_subset]
    exact hV.trans (Set.image_subset_range _ _)
#align is_quasi_separated.image_of_embedding IsQuasiSeparated.image_of_embedding

/- warning: open_embedding.is_quasi_separated_iff -> OpenEmbedding.isQuasiSeparated_iff is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : TopologicalSpace.{u1} α] [_inst_2 : TopologicalSpace.{u2} β] {f : α -> β}, (OpenEmbedding.{u1, u2} α β _inst_1 _inst_2 f) -> (forall {s : Set.{u1} α}, Iff (IsQuasiSeparated.{u1} α _inst_1 s) (IsQuasiSeparated.{u2} β _inst_2 (Set.image.{u1, u2} α β f s)))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : TopologicalSpace.{u2} α] [_inst_2 : TopologicalSpace.{u1} β] {f : α -> β}, (OpenEmbedding.{u2, u1} α β _inst_1 _inst_2 f) -> (forall {s : Set.{u2} α}, Iff (IsQuasiSeparated.{u2} α _inst_1 s) (IsQuasiSeparated.{u1} β _inst_2 (Set.image.{u2, u1} α β f s)))
Case conversion may be inaccurate. Consider using '#align open_embedding.is_quasi_separated_iff OpenEmbedding.isQuasiSeparated_iffₓ'. -/
theorem OpenEmbedding.isQuasiSeparated_iff (h : OpenEmbedding f) {s : Set α} :
    IsQuasiSeparated s ↔ IsQuasiSeparated (f '' s) :=
  by
  refine' ⟨fun hs => hs.image_of_embedding h.to_embedding, _⟩
  intro H U V hU hU' hU'' hV hV' hV''
  rw [h.to_embedding.is_compact_iff_is_compact_image, Set.image_inter h.inj]
  exact
    H (f '' U) (f '' V) (Set.image_subset _ hU) (h.is_open_map _ hU') (hU''.image h.continuous)
      (Set.image_subset _ hV) (h.is_open_map _ hV') (hV''.image h.continuous)
#align open_embedding.is_quasi_separated_iff OpenEmbedding.isQuasiSeparated_iff

#print isQuasiSeparated_iff_quasiSeparatedSpace /-
theorem isQuasiSeparated_iff_quasiSeparatedSpace (s : Set α) (hs : IsOpen s) :
    IsQuasiSeparated s ↔ QuasiSeparatedSpace s :=
  by
  rw [← isQuasiSeparated_univ_iff]
  convert hs.open_embedding_subtype_coe.is_quasi_separated_iff.symm <;> simp
#align is_quasi_separated_iff_quasi_separated_space isQuasiSeparated_iff_quasiSeparatedSpace
-/

#print IsQuasiSeparated.of_subset /-
theorem IsQuasiSeparated.of_subset {s t : Set α} (ht : IsQuasiSeparated t) (h : s ⊆ t) :
    IsQuasiSeparated s := by
  intro U V hU hU' hU'' hV hV' hV''
  exact ht U V (hU.trans h) hU' hU'' (hV.trans h) hV' hV''
#align is_quasi_separated.of_subset IsQuasiSeparated.of_subset
-/

#print T2Space.to_quasiSeparatedSpace /-
instance (priority := 100) T2Space.to_quasiSeparatedSpace [T2Space α] : QuasiSeparatedSpace α :=
  ⟨fun U V hU hU' hV hV' => hU'.inter hV'⟩
#align t2_space.to_quasi_separated_space T2Space.to_quasiSeparatedSpace
-/

#print NoetherianSpace.to_quasiSeparatedSpace /-
instance (priority := 100) NoetherianSpace.to_quasiSeparatedSpace [NoetherianSpace α] :
    QuasiSeparatedSpace α :=
  ⟨fun _ _ _ _ _ _ => NoetherianSpace.isCompact _⟩
#align noetherian_space.to_quasi_separated_space NoetherianSpace.to_quasiSeparatedSpace
-/

#print IsQuasiSeparated.of_quasiSeparatedSpace /-
theorem IsQuasiSeparated.of_quasiSeparatedSpace (s : Set α) [QuasiSeparatedSpace α] :
    IsQuasiSeparated s :=
  isQuasiSeparated_univ.of_subset (Set.subset_univ _)
#align is_quasi_separated.of_quasi_separated_space IsQuasiSeparated.of_quasiSeparatedSpace
-/

/- warning: quasi_separated_space.of_open_embedding -> QuasiSeparatedSpace.of_openEmbedding is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : TopologicalSpace.{u1} α] [_inst_2 : TopologicalSpace.{u2} β] {f : α -> β}, (OpenEmbedding.{u1, u2} α β _inst_1 _inst_2 f) -> (forall [_inst_3 : QuasiSeparatedSpace.{u2} β _inst_2], QuasiSeparatedSpace.{u1} α _inst_1)
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : TopologicalSpace.{u2} α] [_inst_2 : TopologicalSpace.{u1} β] {f : α -> β}, (OpenEmbedding.{u2, u1} α β _inst_1 _inst_2 f) -> (forall [_inst_3 : QuasiSeparatedSpace.{u1} β _inst_2], QuasiSeparatedSpace.{u2} α _inst_1)
Case conversion may be inaccurate. Consider using '#align quasi_separated_space.of_open_embedding QuasiSeparatedSpace.of_openEmbeddingₓ'. -/
theorem QuasiSeparatedSpace.of_openEmbedding (h : OpenEmbedding f) [QuasiSeparatedSpace β] :
    QuasiSeparatedSpace α :=
  isQuasiSeparated_univ_iff.mp
    (h.isQuasiSeparated_iff.mpr <| IsQuasiSeparated.of_quasiSeparatedSpace _)
#align quasi_separated_space.of_open_embedding QuasiSeparatedSpace.of_openEmbedding