/-
Copyright (c) 2021 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz
-/
import category_theory.limits.shapes.products
import category_theory.limits.shapes.equalizers
import category_theory.limits.cone_category

/-!

# Multi-(co)equalizers

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

A *multiequalizer* is an equalizer of two morphisms between two products.
Since both products and equalizers are limits, such an object is again a limit.
This file provides the diagram whose limit is indeed such an object.
In fact, it is well-known that any limit can be obtained as a multiequalizer.
The dual construction (multicoequalizers) is also provided.

## Projects

Prove that a multiequalizer can be identified with
an equalizer between products (and analogously for multicoequalizers).

Prove that the limit of any diagram is a multiequalizer (and similarly for colimits).

-/

namespace category_theory.limits

open category_theory

universes w v u

/-- The type underlying the multiequalizer diagram. -/
@[nolint unused_arguments]
inductive walking_multicospan {L R : Type w} (fst snd : R → L) : Type w
| left : L → walking_multicospan
| right : R → walking_multicospan

/-- The type underlying the multiecoqualizer diagram. -/
@[nolint unused_arguments]
inductive walking_multispan {L R : Type w} (fst snd : L → R) : Type w
| left : L → walking_multispan
| right : R → walking_multispan

namespace walking_multicospan

variables {L R : Type w} {fst snd : R → L}

instance [inhabited L] : inhabited (walking_multicospan fst snd) :=
⟨left default⟩

/-- Morphisms for `walking_multicospan`. -/
inductive hom : Π (a b : walking_multicospan fst snd), Type w
| id (A)  : hom A A
| fst (b) : hom (left (fst b)) (right b)
| snd (b) : hom (left (snd b)) (right b)

instance {a : walking_multicospan fst snd} : inhabited (hom a a) :=
⟨hom.id _⟩

/-- Composition of morphisms for `walking_multicospan`. -/
def hom.comp : Π {A B C : walking_multicospan fst snd} (f : hom A B) (g : hom B C),
  hom A C
| _ _ _ (hom.id X) f := f
| _ _ _ (hom.fst b) (hom.id X) := hom.fst b
| _ _ _ (hom.snd b) (hom.id X) := hom.snd b

instance : small_category (walking_multicospan fst snd) :=
{ hom := hom,
  id := hom.id,
  comp := λ X Y Z, hom.comp,
  id_comp' := by { rintro (_|_) (_|_) (_|_|_), tidy },
  comp_id' := by { rintro (_|_) (_|_) (_|_|_), tidy },
  assoc' := by { rintro (_|_) (_|_) (_|_) (_|_) (_|_|_) (_|_|_) (_|_|_), tidy } }

end walking_multicospan

namespace walking_multispan

variables {L R : Type v} {fst snd : L → R}

instance [inhabited L] : inhabited (walking_multispan fst snd) :=
⟨left default⟩

/-- Morphisms for `walking_multispan`. -/
inductive hom : Π (a b : walking_multispan fst snd), Type v
| id (A)  : hom A A
| fst (a) : hom (left a) (right (fst a))
| snd (a) : hom (left a) (right (snd a))

instance {a : walking_multispan fst snd} : inhabited (hom a a) :=
⟨hom.id _⟩

/-- Composition of morphisms for `walking_multispan`. -/
def hom.comp : Π {A B C : walking_multispan fst snd} (f : hom A B) (g : hom B C),
  hom A C
| _ _ _ (hom.id X) f := f
| _ _ _ (hom.fst a) (hom.id X) := hom.fst a
| _ _ _ (hom.snd a) (hom.id X) := hom.snd a

instance : small_category (walking_multispan fst snd) :=
{ hom := hom,
  id := hom.id,
  comp := λ X Y Z, hom.comp,
  id_comp' := by { rintro (_|_) (_|_) (_|_|_), tidy },
  comp_id' := by { rintro (_|_) (_|_) (_|_|_), tidy },
  assoc' := by { rintro (_|_) (_|_) (_|_) (_|_) (_|_|_) (_|_|_) (_|_|_), tidy } }

end walking_multispan

/-- This is a structure encapsulating the data necessary to define a `multicospan`. -/
@[nolint has_nonempty_instance]
structure multicospan_index (C : Type u) [category.{v} C] :=
(L R : Type w)
(fst_to snd_to : R → L)
(left : L → C)
(right : R → C)
(fst : Π b, left (fst_to b) ⟶ right b)
(snd : Π b, left (snd_to b) ⟶ right b)

/-- This is a structure encapsulating the data necessary to define a `multispan`. -/
@[nolint has_nonempty_instance]
structure multispan_index (C : Type u) [category.{v} C] :=
(L R : Type w)
(fst_from snd_from : L → R)
(left : L → C)
(right : R → C)
(fst : Π a, left a ⟶ right (fst_from a))
(snd : Π a, left a ⟶ right (snd_from a))

namespace multicospan_index

variables {C : Type u} [category.{v} C] (I : multicospan_index C)

/-- The multicospan associated to `I : multicospan_index`. -/
def multicospan : walking_multicospan I.fst_to I.snd_to ⥤ C :=
{ obj := λ x,
  match x with
  | walking_multicospan.left a := I.left a
  | walking_multicospan.right b := I.right b
  end,
  map := λ x y f,
  match x, y, f with
  | _, _, walking_multicospan.hom.id x := 𝟙 _
  | _, _, walking_multicospan.hom.fst b := I.fst _
  | _, _, walking_multicospan.hom.snd b := I.snd _
  end,
  map_id' := by { rintros (_|_), tidy },
  map_comp' := by { rintros (_|_) (_|_) (_|_) (_|_|_) (_|_|_), tidy } }

@[simp] lemma multicospan_obj_left (a) :
  I.multicospan.obj (walking_multicospan.left a) = I.left a := rfl

@[simp] lemma multicospan_obj_right (b) :
  I.multicospan.obj (walking_multicospan.right b) = I.right b := rfl

@[simp] lemma multicospan_map_fst (b) :
  I.multicospan.map (walking_multicospan.hom.fst b) = I.fst b := rfl

@[simp] lemma multicospan_map_snd (b) :
  I.multicospan.map (walking_multicospan.hom.snd b) = I.snd b := rfl

variables [has_product I.left] [has_product I.right]

/-- The induced map `∏ I.left ⟶ ∏ I.right` via `I.fst`. -/
noncomputable
def fst_pi_map : ∏ I.left ⟶ ∏ I.right := pi.lift (λ b, pi.π I.left (I.fst_to b) ≫ I.fst b)

/-- The induced map `∏ I.left ⟶ ∏ I.right` via `I.snd`. -/
noncomputable
def snd_pi_map : ∏ I.left ⟶ ∏ I.right := pi.lift (λ b, pi.π I.left (I.snd_to b) ≫ I.snd b)

@[simp, reassoc]
lemma fst_pi_map_π (b) : I.fst_pi_map ≫ pi.π I.right b = pi.π I.left _ ≫ I.fst b :=
by simp [fst_pi_map]

@[simp, reassoc]
lemma snd_pi_map_π (b) : I.snd_pi_map ≫ pi.π I.right b = pi.π I.left _ ≫ I.snd b :=
by simp [snd_pi_map]

/--
Taking the multiequalizer over the multicospan index is equivalent to taking the equalizer over
the two morphsims `∏ I.left ⇉ ∏ I.right`. This is the diagram of the latter.
-/
@[simps] protected noncomputable
def parallel_pair_diagram := parallel_pair I.fst_pi_map I.snd_pi_map

end multicospan_index

namespace multispan_index

variables {C : Type u} [category.{v} C] (I : multispan_index C)

/-- The multispan associated to `I : multispan_index`. -/
def multispan : walking_multispan I.fst_from I.snd_from ⥤ C :=
{ obj := λ x,
  match x with
  | walking_multispan.left a := I.left a
  | walking_multispan.right b := I.right b
  end,
  map := λ x y f,
  match x, y, f with
  | _, _, walking_multispan.hom.id x := 𝟙 _
  | _, _, walking_multispan.hom.fst b := I.fst _
  | _, _, walking_multispan.hom.snd b := I.snd _
  end,
  map_id' := by { rintros (_|_), tidy },
  map_comp' := by { rintros (_|_) (_|_) (_|_) (_|_|_) (_|_|_), tidy } }

@[simp] lemma multispan_obj_left (a) :
  I.multispan.obj (walking_multispan.left a) = I.left a := rfl

@[simp] lemma multispan_obj_right (b) :
  I.multispan.obj (walking_multispan.right b) = I.right b := rfl

@[simp] lemma multispan_map_fst (a) :
  I.multispan.map (walking_multispan.hom.fst a) = I.fst a := rfl

@[simp] lemma multispan_map_snd (a) :
  I.multispan.map (walking_multispan.hom.snd a) = I.snd a := rfl

variables [has_coproduct I.left] [has_coproduct I.right]

/-- The induced map `∐ I.left ⟶ ∐ I.right` via `I.fst`. -/
noncomputable
def fst_sigma_map : ∐ I.left ⟶ ∐ I.right := sigma.desc (λ b, I.fst b ≫ sigma.ι _ (I.fst_from b))

/-- The induced map `∐ I.left ⟶ ∐ I.right` via `I.snd`. -/
noncomputable
def snd_sigma_map : ∐ I.left ⟶ ∐ I.right := sigma.desc (λ b, I.snd b ≫ sigma.ι _ (I.snd_from b))

@[simp, reassoc]
lemma ι_fst_sigma_map (b) : sigma.ι I.left b ≫ I.fst_sigma_map = I.fst b ≫ sigma.ι I.right _ :=
by simp [fst_sigma_map]

@[simp, reassoc]
lemma ι_snd_sigma_map (b) : sigma.ι I.left b ≫ I.snd_sigma_map = I.snd b ≫ sigma.ι I.right _ :=
by simp [snd_sigma_map]

/--
Taking the multicoequalizer over the multispan index is equivalent to taking the coequalizer over
the two morphsims `∐ I.left ⇉ ∐ I.right`. This is the diagram of the latter.
-/
protected noncomputable
abbreviation parallel_pair_diagram := parallel_pair I.fst_sigma_map I.snd_sigma_map

end multispan_index

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

/-- A multifork is a cone over a multicospan. -/
@[nolint has_nonempty_instance]
abbreviation multifork (I : multicospan_index C) := cone I.multicospan

/-- A multicofork is a cocone over a multispan. -/
@[nolint has_nonempty_instance]
abbreviation multicofork (I : multispan_index C) := cocone I.multispan

namespace multifork

variables {I : multicospan_index C} (K : multifork I)

/-- The maps from the cone point of a multifork to the objects on the left. -/
def ι (a : I.L) : K.X ⟶ I.left a := K.π.app (walking_multicospan.left _)

@[simp] lemma app_left_eq_ι (a) : K.π.app (walking_multicospan.left a) = K.ι a := rfl

@[simp] lemma app_right_eq_ι_comp_fst (b) :
  K.π.app (walking_multicospan.right b) = K.ι (I.fst_to b) ≫ I.fst b :=
by { rw ← K.w (walking_multicospan.hom.fst b), refl }

@[reassoc] lemma app_right_eq_ι_comp_snd (b) :
  K.π.app (walking_multicospan.right b) =  K.ι (I.snd_to b) ≫ I.snd b :=
by { rw ← K.w (walking_multicospan.hom.snd b), refl }

@[simp, reassoc] lemma hom_comp_ι (K₁ K₂ : multifork I) (f : K₁ ⟶ K₂) (j : I.L) :
  f.hom ≫ K₂.ι j = K₁.ι j := f.w (walking_multicospan.left j)

/-- Construct a multifork using a collection `ι` of morphisms. -/
@[simps]
def of_ι (I : multicospan_index C) (P : C) (ι : Π a, P ⟶ I.left a)
  (w : ∀ b, ι (I.fst_to b) ≫ I.fst b = ι (I.snd_to b) ≫ I.snd b) :
  multifork I :=
{ X := P,
  π :=
  { app := λ x,
    match x with
    | walking_multicospan.left a := ι _
    | walking_multicospan.right b := ι (I.fst_to b) ≫ I.fst b
    end,
    naturality' := begin
      rintros (_|_) (_|_) (_|_|_),
      any_goals { symmetry, dsimp, rw category.id_comp, apply category.comp_id },
      { dsimp, rw category.id_comp, refl },
      { dsimp, rw category.id_comp, apply w }
    end } }

@[simp, reassoc]
lemma condition (b) :
  K.ι (I.fst_to b) ≫ I.fst b = K.ι (I.snd_to b) ≫ I.snd b :=
by rw [←app_right_eq_ι_comp_fst, ←app_right_eq_ι_comp_snd]

/-- This definition provides a convenient way to show that a multifork is a limit. -/
@[simps]
def is_limit.mk
  (lift : Π (E : multifork I), E.X ⟶ K.X)
  (fac : ∀ (E : multifork I) (i : I.L), lift E ≫ K.ι i = E.ι i)
  (uniq : ∀ (E : multifork I) (m : E.X ⟶ K.X),
    (∀ i : I.L, m ≫ K.ι i = E.ι i) → m = lift E) : is_limit K :=
{ lift := lift,
  fac' := begin
    rintros E (a|b),
    { apply fac },
    { rw [← E.w (walking_multicospan.hom.fst b), ← K.w (walking_multicospan.hom.fst b),
        ← category.assoc],
      congr' 1,
      apply fac }
  end,
  uniq' := begin
    rintros E m hm,
    apply uniq,
    intros i,
    apply hm,
  end }

variables [has_product I.left] [has_product I.right]

@[simp, reassoc]
lemma pi_condition : pi.lift K.ι ≫ I.fst_pi_map = pi.lift K.ι ≫ I.snd_pi_map :=
by { ext, discrete_cases, simp, }

/-- Given a multifork, we may obtain a fork over `∏ I.left ⇉ ∏ I.right`. -/
@[simps X] noncomputable
def to_pi_fork (K : multifork I) : fork I.fst_pi_map I.snd_pi_map :=
{ X := K.X,
  π :=
  { app := λ x,
    match x with
    | walking_parallel_pair.zero := pi.lift K.ι
    | walking_parallel_pair.one := pi.lift K.ι ≫ I.fst_pi_map
    end,
    naturality' :=
    begin
      rintros (_|_) (_|_) (_|_|_),
      any_goals { symmetry, dsimp, rw category.id_comp, apply category.comp_id },
      all_goals { change 𝟙 _ ≫ _ ≫ _ = pi.lift _ ≫ _, simp }
    end } }

@[simp] lemma to_pi_fork_π_app_zero : K.to_pi_fork.ι = pi.lift K.ι := rfl

@[simp] lemma to_pi_fork_π_app_one :
  K.to_pi_fork.π.app walking_parallel_pair.one = pi.lift K.ι ≫ I.fst_pi_map := rfl

variable (I)

/-- Given a fork over `∏ I.left ⇉ ∏ I.right`, we may obtain a multifork. -/
@[simps X] noncomputable
def of_pi_fork (c : fork I.fst_pi_map I.snd_pi_map) : multifork I :=
{ X := c.X,
  π :=
  { app := λ x,
    match x with
    | walking_multicospan.left a := c.ι ≫ pi.π _ _
    | walking_multicospan.right b := c.ι ≫ I.fst_pi_map ≫ pi.π _ _
    end,
    naturality' :=
    begin
      rintros (_|_) (_|_) (_|_|_),
      any_goals { symmetry, dsimp, rw category.id_comp, apply category.comp_id },
      { change 𝟙 _ ≫ _ ≫ _ = (_ ≫ _) ≫ _, simp },
      { change 𝟙 _ ≫ _ ≫ _ = (_ ≫ _) ≫ _, rw c.condition_assoc, simp }
    end } }

@[simp] lemma of_pi_fork_π_app_left (c : fork I.fst_pi_map I.snd_pi_map) (a) :
  (of_pi_fork I c).ι a = c.ι ≫ pi.π _ _ := rfl

@[simp] lemma of_pi_fork_π_app_right (c : fork I.fst_pi_map I.snd_pi_map) (a) :
  (of_pi_fork I c).π.app (walking_multicospan.right a) = c.ι ≫ I.fst_pi_map ≫ pi.π _ _ := rfl

end multifork

namespace multicospan_index

variables (I : multicospan_index C) [has_product I.left] [has_product I.right]

local attribute [tidy] tactic.case_bash

/-- `multifork.to_pi_fork` is functorial. -/
@[simps] noncomputable
def to_pi_fork_functor : multifork I ⥤ fork I.fst_pi_map I.snd_pi_map :=
{ obj := multifork.to_pi_fork,
  map := λ K₁ K₂ f,
  { hom := f.hom,
    w' := begin
      rintro (_|_),
      { ext, dsimp, simp },
      { ext,
        simp only [multifork.to_pi_fork_π_app_one, multifork.pi_condition, category.assoc],
        dsimp [snd_pi_map],
        simp },
    end } }

/-- `multifork.of_pi_fork` is functorial. -/
@[simps] noncomputable
def of_pi_fork_functor : fork I.fst_pi_map I.snd_pi_map ⥤ multifork I :=
{ obj := multifork.of_pi_fork I, map := λ K₁ K₂ f, { hom := f.hom, w' := by rintros (_|_); simp } }

/--
The category of multiforks is equivalent to the category of forks over `∏ I.left ⇉ ∏ I.right`.
It then follows from `category_theory.is_limit_of_preserves_cone_terminal` (or `reflects`) that it
preserves and reflects limit cones.
-/
@[simps] noncomputable
def multifork_equiv_pi_fork : multifork I ≌ fork I.fst_pi_map I.snd_pi_map :=
{ functor := to_pi_fork_functor I,
  inverse := of_pi_fork_functor I,
  unit_iso := nat_iso.of_components (λ K, cones.ext (iso.refl _)
    (by { rintros (_|_); dsimp; simp[←fork.app_one_eq_ι_comp_left, -fork.app_one_eq_ι_comp_left] }))
    (λ K₁ K₂ f, by { ext, simp }),
  counit_iso := nat_iso.of_components (λ K, fork.ext (iso.refl _) (by { ext ⟨j⟩, dsimp, simp }))
    (λ K₁ K₂ f, by { ext, simp }) }

end multicospan_index

namespace multicofork

variables {I : multispan_index C} (K : multicofork I)

/-- The maps to the cocone point of a multicofork from the objects on the right. -/
def π (b : I.R) : I.right b ⟶ K.X :=
K.ι.app (walking_multispan.right _)

@[simp] lemma π_eq_app_right (b) : K.ι.app (walking_multispan.right _) = K.π b := rfl

@[simp] lemma fst_app_right (a) :
  K.ι.app (walking_multispan.left a) = I.fst a ≫ K.π _ :=
by { rw ← K.w (walking_multispan.hom.fst a), refl }

@[reassoc] lemma snd_app_right (a) :
  K.ι.app (walking_multispan.left a) = I.snd a ≫ K.π _ :=
by { rw ← K.w (walking_multispan.hom.snd a), refl }

/-- Construct a multicofork using a collection `π` of morphisms. -/
@[simps]
def of_π (I : multispan_index C) (P : C) (π : Π b, I.right b ⟶ P)
  (w : ∀ a, I.fst a ≫ π (I.fst_from a) = I.snd a ≫ π (I.snd_from a)) :
  multicofork I :=
{ X := P,
  ι :=
  { app := λ x,
    match x with
    | walking_multispan.left a := I.fst a ≫ π _
    | walking_multispan.right b := π _
    end,
    naturality' := begin
      rintros (_|_) (_|_) (_|_|_),
      any_goals { dsimp, rw category.comp_id, apply category.id_comp },
      { dsimp, rw category.comp_id, refl },
      { dsimp, rw category.comp_id, apply (w _).symm }
    end } }

@[simp, reassoc]
lemma condition (a) : I.fst a ≫ K.π (I.fst_from a) = I.snd a ≫ K.π (I.snd_from a) :=
by rw [←K.snd_app_right, ←K.fst_app_right]

/-- This definition provides a convenient way to show that a multicofork is a colimit. -/
@[simps]
def is_colimit.mk
  (desc : Π (E : multicofork I), K.X ⟶ E.X)
  (fac : ∀ (E : multicofork I) (i : I.R), K.π i ≫ desc E = E.π i)
  (uniq : ∀ (E : multicofork I) (m : K.X ⟶ E.X),
    (∀ i : I.R, K.π i ≫ m = E.π i) → m = desc E) : is_colimit K :=
{ desc := desc,
  fac' := begin
    rintros S (a|b),
    { rw [← K.w (walking_multispan.hom.fst a), ← S.w (walking_multispan.hom.fst a),
        category.assoc],
      congr' 1,
      apply fac },
    { apply fac },
  end,
  uniq' := begin
    intros S m hm,
    apply uniq,
    intros i,
    apply hm
  end }

variables [has_coproduct I.left] [has_coproduct I.right]

@[simp, reassoc]
lemma sigma_condition :
  I.fst_sigma_map ≫ sigma.desc K.π = I.snd_sigma_map ≫ sigma.desc K.π :=
by { ext, discrete_cases, simp, }

/-- Given a multicofork, we may obtain a cofork over `∐ I.left ⇉ ∐ I.right`. -/
@[simps X] noncomputable
def to_sigma_cofork (K : multicofork I) : cofork I.fst_sigma_map I.snd_sigma_map :=
{ X := K.X,
  ι :=
  { app := λ x,
    match x with
    | walking_parallel_pair.zero := I.fst_sigma_map ≫ sigma.desc K.π
    | walking_parallel_pair.one := sigma.desc K.π
    end,
    naturality' :=
    begin
      rintros (_|_) (_|_) (_|_|_),
      any_goals { dsimp, rw category.comp_id, apply category.id_comp },
      all_goals { change _ ≫ sigma.desc _ = (_ ≫ _) ≫ 𝟙 _, simp }
    end } }

@[simp] lemma to_sigma_cofork_π : K.to_sigma_cofork.π = sigma.desc K.π := rfl

variable (I)

/-- Given a cofork over `∐ I.left ⇉ ∐ I.right`, we may obtain a multicofork. -/
@[simps X] noncomputable
def of_sigma_cofork (c : cofork I.fst_sigma_map I.snd_sigma_map) : multicofork I :=
{ X := c.X,
  ι :=
  { app := λ x,
    match x with
    | walking_multispan.left a := (sigma.ι I.left a : _) ≫ I.fst_sigma_map ≫ c.π
    | walking_multispan.right b := (sigma.ι I.right b : _) ≫ c.π
    end,
    naturality' :=
    begin
      rintros (_|_) (_|_) (_|_|_),
      any_goals { dsimp, rw category.comp_id, apply category.id_comp },
      { change _ ≫ _ ≫ _ = (_ ≫ _) ≫ _, dsimp,
        simp only [cofork.condition, category.comp_id],
        rw [←I.ι_fst_sigma_map_assoc, c.condition] },
      { change _ ≫ _ ≫ _ = (_ ≫ _) ≫ 𝟙 _,
        rw c.condition, simp }
    end } }

@[simp] lemma of_sigma_cofork_ι_app_left (c : cofork I.fst_sigma_map I.snd_sigma_map) (a) :
  (of_sigma_cofork I c).ι.app (walking_multispan.left a) =
    (sigma.ι I.left a : _) ≫ I.fst_sigma_map ≫ c.π := rfl

@[simp] lemma of_sigma_cofork_ι_app_right (c : cofork I.fst_sigma_map I.snd_sigma_map) (b) :
  (of_sigma_cofork I c).ι.app (walking_multispan.right b) = (sigma.ι I.right b : _) ≫ c.π := rfl

end multicofork

namespace multispan_index

variables (I : multispan_index C) [has_coproduct I.left] [has_coproduct I.right]

local attribute [tidy] tactic.case_bash

/-- `multicofork.to_sigma_cofork` is functorial. -/
@[simps] noncomputable
def to_sigma_cofork_functor : multicofork I ⥤ cofork I.fst_sigma_map I.snd_sigma_map :=
{ obj := multicofork.to_sigma_cofork, map := λ K₁ K₂ f, { hom := f.hom } }

/-- `multicofork.of_sigma_cofork` is functorial. -/
@[simps] noncomputable
def of_sigma_cofork_functor : cofork I.fst_sigma_map I.snd_sigma_map ⥤ multicofork I :=
{ obj := multicofork.of_sigma_cofork I,
  map := λ K₁ K₂ f, { hom := f.hom, w' := by rintros (_|_); simp } }

/--
The category of multicoforks is equivalent to the category of coforks over `∐ I.left ⇉ ∐ I.right`.
It then follows from `category_theory.is_colimit_of_preserves_cocone_initial` (or `reflects`) that
it preserves and reflects colimit cocones.
-/
@[simps] noncomputable
def multicofork_equiv_sigma_cofork : multicofork I ≌ cofork I.fst_sigma_map I.snd_sigma_map :=
{ functor := to_sigma_cofork_functor I,
  inverse := of_sigma_cofork_functor I,
  unit_iso := nat_iso.of_components (λ K, cocones.ext (iso.refl _)
      (by { rintros (_|_); dsimp; simp }))
    (λ K₁ K₂ f, by { ext, simp }),
  counit_iso := nat_iso.of_components (λ K, cofork.ext (iso.refl _)
      (by { ext ⟨j⟩, dsimp, simp only [category.comp_id, colimit.ι_desc, cofan.mk_ι_app], refl }))
    (λ K₁ K₂ f, by { ext, dsimp, simp, }) }

end multispan_index

/-- For `I : multicospan_index C`, we say that it has a multiequalizer if the associated
  multicospan has a limit. -/
abbreviation has_multiequalizer (I : multicospan_index C) :=
  has_limit I.multicospan

noncomputable theory

/-- The multiequalizer of `I : multicospan_index C`. -/
abbreviation multiequalizer (I : multicospan_index C) [has_multiequalizer I] : C :=
  limit I.multicospan

/-- For `I : multispan_index C`, we say that it has a multicoequalizer if
  the associated multicospan has a limit. -/
abbreviation has_multicoequalizer (I : multispan_index C) :=
  has_colimit I.multispan

/-- The multiecoqualizer of `I : multispan_index C`. -/
abbreviation multicoequalizer (I : multispan_index C) [has_multicoequalizer I] : C :=
  colimit I.multispan

namespace multiequalizer

variables (I : multicospan_index C) [has_multiequalizer I]

/-- The canonical map from the multiequalizer to the objects on the left. -/
abbreviation ι (a : I.L) : multiequalizer I ⟶ I.left a :=
limit.π _ (walking_multicospan.left a)

/-- The multifork associated to the multiequalizer. -/
abbreviation multifork : multifork I :=
limit.cone _

@[simp]
lemma multifork_ι (a) :
  (multiequalizer.multifork I).ι a = multiequalizer.ι I a := rfl

@[simp]
lemma multifork_π_app_left (a) :
  (multiequalizer.multifork I).π.app (walking_multicospan.left a) =
  multiequalizer.ι I a := rfl

@[reassoc]
lemma condition (b) :
  multiequalizer.ι I (I.fst_to b) ≫ I.fst b =
  multiequalizer.ι I (I.snd_to b) ≫ I.snd b :=
multifork.condition _ _

/-- Construct a morphism to the multiequalizer from its universal property. -/
abbreviation lift (W : C) (k : Π a, W ⟶ I.left a)
  (h : ∀ b, k (I.fst_to b) ≫ I.fst b = k (I.snd_to b) ≫ I.snd b) :
  W ⟶ multiequalizer I :=
limit.lift _ (multifork.of_ι I _ k h)

@[simp, reassoc]
lemma lift_ι (W : C) (k : Π a, W ⟶ I.left a)
  (h : ∀ b, k (I.fst_to b) ≫ I.fst b = k (I.snd_to b) ≫ I.snd b) (a) :
  multiequalizer.lift I _ k h ≫ multiequalizer.ι I a = k _ :=
limit.lift_π _ _

@[ext]
lemma hom_ext {W : C} (i j : W ⟶ multiequalizer I)
  (h : ∀ a, i ≫ multiequalizer.ι I a =
  j ≫ multiequalizer.ι I a) :
  i = j :=
limit.hom_ext
begin
  rintro (a|b),
  { apply h },
  simp_rw [← limit.w I.multicospan (walking_multicospan.hom.fst b),
    ← category.assoc, h],
end

variables [has_product I.left] [has_product I.right]

instance : has_equalizer I.fst_pi_map I.snd_pi_map :=
⟨⟨⟨_,is_limit.of_preserves_cone_terminal
  I.multifork_equiv_pi_fork.functor (limit.is_limit _)⟩⟩⟩

/-- The multiequalizer is isomorphic to the equalizer of `∏ I.left ⇉ ∏ I.right`. -/
def iso_equalizer : multiequalizer I ≅ equalizer I.fst_pi_map I.snd_pi_map :=
limit.iso_limit_cone ⟨_, is_limit.of_preserves_cone_terminal
  I.multifork_equiv_pi_fork.inverse (limit.is_limit _)⟩

/-- The canonical injection `multiequalizer I ⟶ ∏ I.left`. -/
def ι_pi : multiequalizer I ⟶ ∏ I.left :=
  (iso_equalizer I).hom ≫ equalizer.ι I.fst_pi_map I.snd_pi_map

@[simp, reassoc]
lemma ι_pi_π (a) : ι_pi I ≫ pi.π I.left a = ι I a :=
by { rw [ι_pi, category.assoc, ← iso.eq_inv_comp, iso_equalizer], simpa }

instance : mono (ι_pi I) := @@mono_comp _ _ _ _ equalizer.ι_mono

end multiequalizer

namespace multicoequalizer

variables (I : multispan_index C) [has_multicoequalizer I]

/-- The canonical map from the multiequalizer to the objects on the left. -/
abbreviation π (b : I.R) : I.right b ⟶ multicoequalizer I :=
colimit.ι I.multispan (walking_multispan.right _)

/-- The multicofork associated to the multicoequalizer. -/
abbreviation multicofork : multicofork I :=
colimit.cocone _

@[simp]
lemma multicofork_π (b) :
  (multicoequalizer.multicofork I).π b = multicoequalizer.π I b := rfl

@[simp]
lemma multicofork_ι_app_right (b) :
  (multicoequalizer.multicofork I).ι.app (walking_multispan.right b) =
  multicoequalizer.π I b := rfl

@[reassoc]
lemma condition (a) :
  I.fst a ≫ multicoequalizer.π I (I.fst_from a) =
  I.snd a ≫ multicoequalizer.π I (I.snd_from a) :=
multicofork.condition _ _

/-- Construct a morphism from the multicoequalizer from its universal property. -/
abbreviation desc (W : C) (k : Π b, I.right b ⟶ W)
  (h : ∀ a, I.fst a ≫  k (I.fst_from a) = I.snd a ≫ k (I.snd_from a)) :
  multicoequalizer I ⟶ W :=
colimit.desc _ (multicofork.of_π I _ k h)

@[simp, reassoc]
lemma π_desc (W : C) (k : Π b, I.right b ⟶ W)
  (h : ∀ a, I.fst a ≫  k (I.fst_from a) = I.snd a ≫ k (I.snd_from a)) (b) :
  multicoequalizer.π I b ≫ multicoequalizer.desc I _ k h = k _ :=
colimit.ι_desc _ _

@[ext]
lemma hom_ext {W : C} (i j : multicoequalizer I ⟶ W)
  (h : ∀ b, multicoequalizer.π I b ≫ i = multicoequalizer.π I b ≫ j) :
  i = j :=
colimit.hom_ext
begin
  rintro (a|b),
  { simp_rw [← colimit.w I.multispan (walking_multispan.hom.fst a),
    category.assoc, h] },
  { apply h },
end

variables [has_coproduct I.left] [has_coproduct I.right]

instance : has_coequalizer I.fst_sigma_map I.snd_sigma_map :=
⟨⟨⟨_,is_colimit.of_preserves_cocone_initial
  I.multicofork_equiv_sigma_cofork.functor (colimit.is_colimit _)⟩⟩⟩

/-- The multicoequalizer is isomorphic to the coequalizer of `∐ I.left ⇉ ∐ I.right`. -/
def iso_coequalizer : multicoequalizer I ≅ coequalizer I.fst_sigma_map I.snd_sigma_map :=
colimit.iso_colimit_cocone ⟨_, is_colimit.of_preserves_cocone_initial
  I.multicofork_equiv_sigma_cofork.inverse (colimit.is_colimit _)⟩

/-- The canonical projection `∐ I.right ⟶ multicoequalizer I`. -/
def sigma_π : ∐ I.right ⟶ multicoequalizer I :=
  coequalizer.π I.fst_sigma_map I.snd_sigma_map ≫ (iso_coequalizer I).inv

@[simp, reassoc]
lemma ι_sigma_π (b) : sigma.ι I.right b ≫ sigma_π I = π I b :=
by { rw [sigma_π, ← category.assoc, iso.comp_inv_eq, iso_coequalizer], simpa }

instance : epi (sigma_π I) := @@epi_comp _ _ coequalizer.π_epi _ _

end multicoequalizer

end category_theory.limits


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Jakob von Raumer
-/
import category_theory.limits.has_limits
import category_theory.thin

/-!
# Wide pullbacks

We define the category `wide_pullback_shape`, (resp. `wide_pushout_shape`) which is the category
obtained from a discrete category of type `J` by adjoining a terminal (resp. initial) element.
Limits of this shape are wide pullbacks (pushouts).
The convenience method `wide_cospan` (`wide_span`) constructs a functor from this category, hitting
the given morphisms.

We use `wide_pullback_shape` to define ordinary pullbacks (pushouts) by using `J := walking_pair`,
which allows easy proofs of some related lemmas.
Furthermore, wide pullbacks are used to show the existence of limits in the slice category.
Namely, if `C` has wide pullbacks then `C/B` has limits for any object `B` in `C`.

Typeclasses `has_wide_pullbacks` and `has_finite_wide_pullbacks` assert the existence of wide
pullbacks and finite wide pullbacks.
-/

universes w w' v u

open category_theory category_theory.limits opposite

namespace category_theory.limits

variable (J : Type w)

/-- A wide pullback shape for any type `J` can be written simply as `option J`. -/
@[derive inhabited]
def wide_pullback_shape := option J

/-- A wide pushout shape for any type `J` can be written simply as `option J`. -/
@[derive inhabited]
def wide_pushout_shape := option J

namespace wide_pullback_shape

variable {J}

/-- The type of arrows for the shape indexing a wide pullback. -/
@[derive decidable_eq]
inductive hom : wide_pullback_shape J → wide_pullback_shape J → Type w
| id : Π X, hom X X
| term : Π (j : J), hom (some j) none

attribute [nolint unused_arguments] hom.decidable_eq

instance struct : category_struct (wide_pullback_shape J) :=
{ hom := hom,
  id := λ j, hom.id j,
  comp := λ j₁ j₂ j₃ f g,
  begin
    cases f,
      exact g,
    cases g,
    apply hom.term _
  end }

instance hom.inhabited : inhabited (hom none none) := ⟨hom.id (none : wide_pullback_shape J)⟩

local attribute [tidy] tactic.case_bash

instance subsingleton_hom (j j' : wide_pullback_shape J) : subsingleton (j ⟶ j') :=
⟨by tidy⟩

instance category : small_category (wide_pullback_shape J) := thin_category

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

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

/--
Construct a functor out of the wide pullback shape given a J-indexed collection of arrows to a
fixed object.
-/
@[simps]
def wide_cospan (B : C) (objs : J → C) (arrows : Π (j : J), objs j ⟶ B) :
  wide_pullback_shape J ⥤ C :=
{ obj := λ j, option.cases_on j B objs,
  map := λ X Y f,
  begin
    cases f with _ j,
    { apply (𝟙 _) },
    { exact arrows j }
  end,
  map_comp' := λ _ _ _ f g,
  begin
    cases f,
    { simpa },
    cases g,
    simp
  end }

/-- Every diagram is naturally isomorphic (actually, equal) to a `wide_cospan` -/
def diagram_iso_wide_cospan (F : wide_pullback_shape J ⥤ C) :
  F ≅ wide_cospan (F.obj none) (λ j, F.obj (some j)) (λ j, F.map (hom.term j)) :=
nat_iso.of_components (λ j, eq_to_iso $ by tidy) $ by tidy

/-- Construct a cone over a wide cospan. -/
@[simps]
def mk_cone {F : wide_pullback_shape J ⥤ C} {X : C}
  (f : X ⟶ F.obj none) (π : Π j, X ⟶ F.obj (some j))
  (w : ∀ j, π j ≫ F.map (hom.term j) = f) : cone F :=
{ X := X,
  π :=
  { app := λ j, match j with
    | none := f
    | (some j) := π j
    end,
    naturality' := λ j j' f, by { cases j; cases j'; cases f; unfold_aux; dsimp; simp [w], }, } }

/-- Wide pullback diagrams of equivalent index types are equivlent. -/
def equivalence_of_equiv (J' : Type w') (h : J ≃ J') :
  wide_pullback_shape J ≌ wide_pullback_shape J' :=
{ functor := wide_cospan none (λ j, some (h j)) (λ j, hom.term (h j)),
  inverse := wide_cospan none (λ j, some (h.inv_fun j)) (λ j, hom.term (h.inv_fun j)),
  unit_iso := nat_iso.of_components (λ j, by cases j; simp)
    (λ j k f, by { simp only [eq_iff_true_of_subsingleton]}),
  counit_iso := nat_iso.of_components (λ j, by cases j; simp)
    (λ j k f, by { simp only [eq_iff_true_of_subsingleton]}) }

/-- Lifting universe and morphism levels preserves wide pullback diagrams. -/
def ulift_equivalence :
  ulift_hom.{w'} (ulift.{w'} (wide_pullback_shape J)) ≌ wide_pullback_shape (ulift J) :=
(ulift_hom_ulift_category.equiv.{w' w' w w} (wide_pullback_shape J)).symm.trans
  (equivalence_of_equiv _ (equiv.ulift.{w' w}.symm : J ≃ ulift.{w'} J))

end wide_pullback_shape

namespace wide_pushout_shape

variable {J}

/-- The type of arrows for the shape indexing a wide psuhout. -/
@[derive decidable_eq]
inductive hom : wide_pushout_shape J → wide_pushout_shape J → Type w
| id : Π X, hom X X
| init : Π (j : J), hom none (some j)

attribute [nolint unused_arguments] hom.decidable_eq

instance struct : category_struct (wide_pushout_shape J) :=
{ hom := hom,
  id := λ j, hom.id j,
  comp := λ j₁ j₂ j₃ f g,
  begin
    cases f,
      exact g,
    cases g,
    apply hom.init _
  end }

instance hom.inhabited : inhabited (hom none none) := ⟨hom.id (none : wide_pushout_shape J)⟩

local attribute [tidy] tactic.case_bash

instance subsingleton_hom (j j' : wide_pushout_shape J) : subsingleton (j ⟶ j') :=
⟨by tidy⟩

instance category : small_category (wide_pushout_shape J) := thin_category

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

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

/--
Construct a functor out of the wide pushout shape given a J-indexed collection of arrows from a
fixed object.
-/
@[simps]
def wide_span (B : C) (objs : J → C) (arrows : Π (j : J), B ⟶ objs j) : wide_pushout_shape J ⥤ C :=
{ obj := λ j, option.cases_on j B objs,
  map := λ X Y f,
  begin
    cases f with _ j,
    { apply (𝟙 _) },
    { exact arrows j }
  end,
  map_comp' := by { rintros (_|_) (_|_) (_|_) (_|_) (_|_); simpa <|> simp } }

/-- Every diagram is naturally isomorphic (actually, equal) to a `wide_span` -/
def diagram_iso_wide_span (F : wide_pushout_shape J ⥤ C) :
  F ≅ wide_span (F.obj none) (λ j, F.obj (some j)) (λ j, F.map (hom.init j)) :=
nat_iso.of_components (λ j, eq_to_iso $ by tidy) $ by tidy

/-- Construct a cocone over a wide span. -/
@[simps]
def mk_cocone {F : wide_pushout_shape J ⥤ C} {X : C}
  (f : F.obj none ⟶ X) (ι : Π j, F.obj (some j) ⟶ X)
  (w : ∀ j, F.map (hom.init j) ≫ ι j = f) : cocone F :=
{ X := X,
  ι :=
  { app := λ j, match j with
    | none := f
    | (some j) := ι j
    end,
    naturality' := λ j j' f, by { cases j; cases j'; cases f; unfold_aux; dsimp; simp [w], }, } }

end wide_pushout_shape

variables (C : Type u) [category.{v} C]

/-- `has_wide_pullbacks` represents a choice of wide pullback for every collection of morphisms -/
abbreviation has_wide_pullbacks : Prop :=
Π (J : Type w), has_limits_of_shape (wide_pullback_shape J) C

/-- `has_wide_pushouts` represents a choice of wide pushout for every collection of morphisms -/
abbreviation has_wide_pushouts : Prop :=
Π (J : Type w), has_colimits_of_shape (wide_pushout_shape J) C

variables {C J}

/-- `has_wide_pullback B objs arrows` means that `wide_cospan B objs arrows` has a limit. -/
abbreviation has_wide_pullback (B : C) (objs : J → C)
  (arrows : Π (j : J), objs j ⟶ B) : Prop :=
has_limit (wide_pullback_shape.wide_cospan B objs arrows)

/-- `has_wide_pushout B objs arrows` means that `wide_span B objs arrows` has a colimit. -/
abbreviation has_wide_pushout (B : C) (objs : J → C)
  (arrows : Π (j : J), B ⟶ objs j) : Prop :=
has_colimit (wide_pushout_shape.wide_span B objs arrows)

/-- A choice of wide pullback. -/
noncomputable
abbreviation wide_pullback (B : C) (objs : J → C) (arrows : Π (j : J), objs j ⟶ B)
  [has_wide_pullback B objs arrows] : C :=
limit (wide_pullback_shape.wide_cospan B objs arrows)

/-- A choice of wide pushout. -/
noncomputable
abbreviation wide_pushout (B : C) (objs : J → C) (arrows : Π (j : J), B ⟶ objs j)
  [has_wide_pushout B objs arrows] : C :=
colimit (wide_pushout_shape.wide_span B objs arrows)

variable (C)

namespace wide_pullback

variables {C} {B : C} {objs : J → C} (arrows : Π (j : J), objs j ⟶ B)
variables [has_wide_pullback B objs arrows]

/-- The `j`-th projection from the pullback. -/
noncomputable
abbreviation π (j : J) : wide_pullback _ _ arrows ⟶ objs j :=
limit.π (wide_pullback_shape.wide_cospan _ _ _) (option.some j)

/-- The unique map to the base from the pullback. -/
noncomputable
abbreviation base : wide_pullback _ _ arrows ⟶ B :=
limit.π (wide_pullback_shape.wide_cospan _ _ _) option.none

@[simp, reassoc]
lemma π_arrow (j : J) : π arrows j ≫ arrows _ = base arrows :=
by apply limit.w (wide_pullback_shape.wide_cospan _ _ _) (wide_pullback_shape.hom.term j)

variables {arrows}

/-- Lift a collection of morphisms to a morphism to the pullback. -/
noncomputable
abbreviation lift {X : C} (f : X ⟶ B) (fs : Π (j : J), X ⟶ objs j)
  (w : ∀ j, fs j ≫ arrows j = f) : X ⟶ wide_pullback _ _ arrows :=
limit.lift (wide_pullback_shape.wide_cospan _ _ _)
  (wide_pullback_shape.mk_cone f fs $ by exact w)

variables (arrows)

variables {X : C} (f : X ⟶ B) (fs : Π (j : J), X ⟶ objs j)
  (w : ∀ j, fs j ≫ arrows j = f)

@[simp, reassoc]
lemma lift_π (j : J) : lift f fs w ≫ π arrows j = fs _ :=
by { simp, refl }

@[simp, reassoc]
lemma lift_base : lift f fs w ≫ base arrows = f :=
by { simp, refl }

lemma eq_lift_of_comp_eq (g : X ⟶ wide_pullback _ _ arrows) :
  (∀ j : J, g ≫ π arrows j = fs j) → g ≫ base arrows = f → g = lift f fs w :=
begin
  intros h1 h2,
  apply (limit.is_limit (wide_pullback_shape.wide_cospan B objs arrows)).uniq
    (wide_pullback_shape.mk_cone f fs $ by exact w),
  rintro (_|_),
  { apply h2 },
  { apply h1 }
end

lemma hom_eq_lift (g : X ⟶ wide_pullback _ _ arrows) :
  g = lift (g ≫ base arrows) (λ j, g ≫ π arrows j) (by tidy) :=
begin
  apply eq_lift_of_comp_eq,
  tidy,
end

@[ext]
lemma hom_ext (g1 g2 : X ⟶ wide_pullback _ _ arrows) :
  (∀ j : J, g1 ≫ π arrows j = g2 ≫ π arrows j) →
  g1 ≫ base arrows = g2 ≫ base arrows → g1 = g2 :=
begin
  intros h1 h2,
  apply limit.hom_ext,
  rintros (_|_),
  { apply h2 },
  { apply h1 },
end

end wide_pullback

namespace wide_pushout

variables {C} {B : C} {objs : J → C} (arrows : Π (j : J), B ⟶ objs j)
variables [has_wide_pushout B objs arrows]

/-- The `j`-th inclusion to the pushout. -/
noncomputable
abbreviation ι (j : J) : objs j ⟶ wide_pushout _ _ arrows :=
colimit.ι (wide_pushout_shape.wide_span _ _ _) (option.some j)

/-- The unique map from the head to the pushout. -/
noncomputable
abbreviation head : B ⟶ wide_pushout B objs arrows :=
colimit.ι (wide_pushout_shape.wide_span _ _ _) option.none

@[simp, reassoc]
lemma arrow_ι (j : J) : arrows j ≫ ι arrows j = head arrows :=
by apply colimit.w (wide_pushout_shape.wide_span _ _ _) (wide_pushout_shape.hom.init j)

variables {arrows}

/-- Descend a collection of morphisms to a morphism from the pushout. -/
noncomputable
abbreviation desc {X : C} (f : B ⟶ X) (fs : Π (j : J), objs j ⟶ X)
  (w : ∀ j, arrows j ≫ fs j = f) : wide_pushout _ _ arrows ⟶ X :=
colimit.desc (wide_pushout_shape.wide_span B objs arrows)
  (wide_pushout_shape.mk_cocone f fs $ by exact w)

variables (arrows)

variables {X : C} (f : B ⟶ X) (fs : Π (j : J), objs j ⟶ X)
  (w : ∀ j, arrows j ≫ fs j = f)

@[simp, reassoc]
lemma ι_desc (j : J) : ι arrows j ≫ desc f fs w = fs _ :=
by { simp, refl }

@[simp, reassoc]
lemma head_desc : head arrows ≫ desc f fs w = f :=
by { simp, refl }

lemma eq_desc_of_comp_eq (g : wide_pushout _ _ arrows ⟶ X) :
  (∀ j : J, ι arrows j ≫ g = fs j) → head arrows ≫ g = f → g = desc f fs w :=
begin
  intros h1 h2,
  apply (colimit.is_colimit (wide_pushout_shape.wide_span B objs arrows)).uniq
    (wide_pushout_shape.mk_cocone f fs $ by exact w),
  rintro (_|_),
  { apply h2 },
  { apply h1 }
end

lemma hom_eq_desc (g : wide_pushout _ _ arrows ⟶ X) :
  g = desc (head arrows ≫ g) (λ j, ι arrows j ≫ g) (λ j, by { rw ← category.assoc, simp }) :=
begin
  apply eq_desc_of_comp_eq,
  tidy,
end

@[ext]
lemma hom_ext (g1 g2 : wide_pushout _ _ arrows ⟶ X) :
  (∀ j : J, ι arrows j ≫ g1 = ι arrows j ≫ g2) →
  head arrows ≫ g1 = head arrows ≫ g2 → g1 = g2 :=
begin
  intros h1 h2,
  apply colimit.hom_ext,
  rintros (_|_),
  { apply h2 },
  { apply h1 },
end

end wide_pushout

variable (J)

/-- The action on morphisms of the obvious functor
  `wide_pullback_shape_op : wide_pullback_shape J ⥤ (wide_pushout_shape J)ᵒᵖ`-/
def wide_pullback_shape_op_map : Π (X Y : wide_pullback_shape J),
  (X ⟶ Y) → ((op X : (wide_pushout_shape J)ᵒᵖ) ⟶ (op Y : (wide_pushout_shape J)ᵒᵖ))
| _ _ (wide_pullback_shape.hom.id X) := quiver.hom.op (wide_pushout_shape.hom.id _)
| _ _ (wide_pullback_shape.hom.term j) := quiver.hom.op (wide_pushout_shape.hom.init _)

/-- The obvious functor `wide_pullback_shape J ⥤ (wide_pushout_shape J)ᵒᵖ` -/
@[simps]
def wide_pullback_shape_op : wide_pullback_shape J ⥤ (wide_pushout_shape J)ᵒᵖ :=
{ obj := λ X, op X,
  map := wide_pullback_shape_op_map J, }

/-- The action on morphisms of the obvious functor
`wide_pushout_shape_op : `wide_pushout_shape J ⥤ (wide_pullback_shape J)ᵒᵖ` -/
def wide_pushout_shape_op_map : Π (X Y : wide_pushout_shape J),
  (X ⟶ Y) → ((op X : (wide_pullback_shape J)ᵒᵖ) ⟶ (op Y : (wide_pullback_shape J)ᵒᵖ))
| _ _ (wide_pushout_shape.hom.id X) := quiver.hom.op (wide_pullback_shape.hom.id _)
| _ _ (wide_pushout_shape.hom.init j) := quiver.hom.op (wide_pullback_shape.hom.term _)

/-- The obvious functor `wide_pushout_shape J ⥤ (wide_pullback_shape J)ᵒᵖ` -/
@[simps]
def wide_pushout_shape_op : wide_pushout_shape J ⥤ (wide_pullback_shape J)ᵒᵖ :=
{ obj := λ X, op X,
  map := wide_pushout_shape_op_map J, }

/-- The obvious functor `(wide_pullback_shape J)ᵒᵖ ⥤ wide_pushout_shape J`-/
@[simps]
def wide_pullback_shape_unop : (wide_pullback_shape J)ᵒᵖ ⥤ wide_pushout_shape J :=
(wide_pullback_shape_op J).left_op

/-- The obvious functor `(wide_pushout_shape J)ᵒᵖ ⥤ wide_pullback_shape J` -/
@[simps]
def wide_pushout_shape_unop : (wide_pushout_shape J)ᵒᵖ ⥤ wide_pullback_shape J :=
(wide_pushout_shape_op J).left_op

/-- The inverse of the unit isomorphism of the equivalence
`wide_pushout_shape_op_equiv : (wide_pushout_shape J)ᵒᵖ ≌ wide_pullback_shape J` -/
def wide_pushout_shape_op_unop : wide_pushout_shape_unop J ⋙ wide_pullback_shape_op J ≅ 𝟭 _ :=
nat_iso.of_components (λ X, iso.refl _) (λ X Y f, dec_trivial)

/-- The counit isomorphism of the equivalence
`wide_pullback_shape_op_equiv : (wide_pullback_shape J)ᵒᵖ ≌ wide_pushout_shape J` -/
def wide_pushout_shape_unop_op : wide_pushout_shape_op J ⋙ wide_pullback_shape_unop J ≅ 𝟭 _ :=
nat_iso.of_components (λ X, iso.refl _) (λ X Y f, dec_trivial)

/-- The inverse of the unit isomorphism of the equivalence
`wide_pullback_shape_op_equiv : (wide_pullback_shape J)ᵒᵖ ≌ wide_pushout_shape J` -/
def wide_pullback_shape_op_unop : wide_pullback_shape_unop J ⋙ wide_pushout_shape_op J ≅ 𝟭 _ :=
nat_iso.of_components (λ X, iso.refl _) (λ X Y f, dec_trivial)

/-- The counit isomorphism of the equivalence
`wide_pushout_shape_op_equiv : (wide_pushout_shape J)ᵒᵖ ≌ wide_pullback_shape J` -/
def wide_pullback_shape_unop_op : wide_pullback_shape_op J ⋙ wide_pushout_shape_unop J ≅ 𝟭 _ :=
nat_iso.of_components (λ X, iso.refl _) (λ X Y f, dec_trivial)

/-- The duality equivalence `(wide_pushout_shape J)ᵒᵖ ≌ wide_pullback_shape J` -/
@[simps]
def wide_pushout_shape_op_equiv : (wide_pushout_shape J)ᵒᵖ ≌ wide_pullback_shape J :=
{ functor := wide_pushout_shape_unop J,
  inverse := wide_pullback_shape_op J,
  unit_iso := (wide_pushout_shape_op_unop J).symm,
  counit_iso := wide_pullback_shape_unop_op J, }

/-- The duality equivalence `(wide_pullback_shape J)ᵒᵖ ≌ wide_pushout_shape J` -/
@[simps]
def wide_pullback_shape_op_equiv : (wide_pullback_shape J)ᵒᵖ ≌ wide_pushout_shape J :=
{ functor := wide_pullback_shape_unop J,
  inverse := wide_pushout_shape_op J,
  unit_iso := (wide_pullback_shape_op_unop J).symm,
  counit_iso := wide_pushout_shape_unop_op J, }

/-- If a category has wide pullbacks on a higher universe level it also has wide pullbacks
on a lower universe level. -/
lemma has_wide_pullbacks_shrink [has_wide_pullbacks.{max w w'} C] : has_wide_pullbacks.{w} C :=
λ J, has_limits_of_shape_of_equivalence
  (wide_pullback_shape.equivalence_of_equiv _ equiv.ulift.{w'})

end category_theory.limits


import data.list.chain
import data.sigma.basic

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

open list function

namespace coprod.pre

def reduced (l : list (Σ i, M i)) : Prop :=
l.chain' (λ a b, a.1 ≠ b.1) ∧ ∀ a : Σ i, M i, a ∈ l → a.2 ≠ 1

@[simp] lemma reduced_nil : reduced ([] : list (Σ i, M i)) :=
⟨list.chain'_nil, λ _, false.elim⟩

lemma reduced_singleton {i : Σ i, M i} (hi : i.2 ≠ 1) : reduced [i] :=
⟨by simp, begin
  cases i with i a,
  rintros ⟨j, b⟩,
  simp only [and_imp, ne.def, mem_singleton],
  rintro rfl h₂,
  simp * at *
end⟩

lemma reduced_of_reduced_cons {i : Σ i, M i} {l : list (Σ i, M i)}
  (h : reduced (i :: l)) : reduced l :=
⟨(list.chain'_cons'.1 h.1).2, λ b hb, h.2 _ (mem_cons_of_mem _ hb)⟩

lemma reduced_cons_of_reduced_cons {i : ι} {a b : M i} {l : list (Σ i, M i)}
  (h : reduced (⟨i, a⟩ :: l)) (hb : b ≠ 1) : reduced (⟨i, b⟩ :: l) :=
⟨chain'_cons'.2 (chain'_cons'.1 h.1),
  begin
    rintros ⟨k, c⟩ hk,
    cases (mem_cons_iff _ _ _).1 hk with hk hk,
    { simp only at hk,
      rcases hk with ⟨rfl, h⟩,
      simp * at * },
    { exact h.2 _ (mem_cons_of_mem _ hk) }
  end⟩

lemma reduced_cons_cons {i j : ι} {a : M i} {b : M j}
  {l : list (Σ i, M i)} (hij : i ≠ j) (ha : a ≠ 1)
  (hbl : reduced (⟨j, b⟩ :: l)) : reduced (⟨i, a⟩ :: ⟨j, b⟩ :: l) :=
⟨chain'_cons.2 ⟨hij, hbl.1⟩,
  begin
    rintros ⟨k, c⟩ hk,
    cases (mem_cons_iff _ _ _).1 hk with hk hk,
    { simp only at hk,
      rcases hk with ⟨rfl, h⟩,
      simp * at * },
    { exact hbl.2 _ hk }
  end⟩

lemma reduced_reverse {l : list (Σ i, M i)} (h : reduced l) : reduced l.reverse :=
⟨chain'_reverse.2 $ by {convert h.1, simp [function.funext_iff, eq_comm] },
  by simpa using h.2⟩

@[simp] lemma reduced_reverse_iff {l : list (Σ i, M i)} : reduced l.reverse ↔ reduced l :=
⟨λ h, by convert reduced_reverse h; simp, reduced_reverse⟩

lemma reduced_of_reduced_append_right : ∀ {l₁ l₂ : list (Σ i, M i)} (h : reduced (l₁ ++ l₂)),
  reduced l₂
| []      l₂ h := h
| (i::l₁) l₂ h := begin
  rw cons_append at h,
  exact reduced_of_reduced_append_right (reduced_of_reduced_cons h)
end

lemma reduced_of_reduced_append_left {l₁ l₂ : list (Σ i, M i)} (h : reduced (l₁ ++ l₂)) :
  reduced l₁ :=
begin
  rw [← reduced_reverse_iff],
  rw [← reduced_reverse_iff, reverse_append] at h,
  exact reduced_of_reduced_append_right h
end

variables {ι} [decidable_eq ι] {M} [Π i, decidable_eq (M i)]

def rcons : (Σ i, M i) → list (Σ i, M i) → list (Σ i, M i)
| i []     := [i]
| i (j::l) :=
  if hij : i.1 = j.1
    then let c := i.2 * cast (congr_arg M hij).symm j.2 in
      if c = 1
        then l
        else ⟨i.1, c⟩ :: l
    else i::j::l

def reduce : list (Σ i, M i) → list (Σ i, M i)
| []       := []
| (i :: l) := if i.2 = 1 then reduce l else rcons i (reduce l)

@[simp] lemma reduce_nil : reduce ([] : list (Σ i, M i)) = [] := rfl

lemma reduce_cons (i : Σ i, M i) (l : list (Σ i, M i)) :
  reduce (i::l) = if i.2 = 1 then reduce l else rcons i (reduce l) := rfl

lemma reduced_rcons : ∀ {i : Σ i, M i} {l : list (Σ i, M i)},
  i.2 ≠ 1 → reduced l → reduced (rcons i l)
| ⟨i, a⟩ []            hi h := ⟨list.chain'_singleton _,
  begin
    rintros ⟨j, b⟩ hj,
    simp only [rcons, list.mem_singleton] at hj,
    rcases hj with ⟨rfl, h⟩,
    simp * at *
  end⟩
| ⟨i, a⟩ (⟨j, b⟩ :: l) hi h := begin
  simp [rcons],
  split_ifs,
  { exact reduced_of_reduced_cons h },
  { dsimp only at h_1,
    subst h_1,
    exact reduced_cons_of_reduced_cons h h_2 },
  { exact reduced_cons_cons h_1 hi h }
end

lemma reduced_reduce : ∀ l : list (Σ i, M i), reduced (reduce l)
| []     := reduced_nil
| (a::l) := begin
  rw reduce,
  split_ifs,
  { exact reduced_reduce l },
  { exact reduced_rcons h (reduced_reduce l) }
end

lemma rcons_eq_cons : ∀ {i : Σ i, M i} {l : list (Σ i, M i)},
  reduced (i :: l) → rcons i l = i :: l
| i []     h := rfl
| i (j::l) h := dif_neg (chain'_cons.1 h.1).1

lemma rcons_reduce_eq_reduce_cons : ∀ {i : Σ i, M i} {l : list (Σ i, M i)},
  i.2 ≠ 1 → rcons i (reduce l) = reduce (i :: l)
| a []     ha := by simp [rcons, reduce, ha]
| a (b::l) ha := begin
  rw [reduce],
  split_ifs,
  { rw [reduce, if_neg ha, reduce, if_pos h] },
  { rw [reduce, if_neg ha, reduce, if_neg h] }
end

lemma reduce_eq_self_of_reduced : ∀ {l : list (Σ i, M i)}, reduced l → reduce l = l
| []     h := rfl
| (a::l) h := by rw [← rcons_reduce_eq_reduce_cons (h.2 a (mem_cons_self _ _)),
    reduce_eq_self_of_reduced (reduced_of_reduced_cons h), rcons_eq_cons h]

lemma rcons_eq_reduce_cons {i : Σ i, M i} {l : list (Σ i, M i)}
  (ha : i.2 ≠ 1) (hl : reduced l) : rcons i l = reduce (i :: l) :=
by rw [← rcons_reduce_eq_reduce_cons ha, reduce_eq_self_of_reduced hl]

@[simp] lemma reduce_reduce (l : list (Σ i, M i)) : reduce (reduce l) = reduce l :=
reduce_eq_self_of_reduced (reduced_reduce l)

@[simp] lemma reduce_cons_reduce_eq_reduce_cons (i : Σ i, M i) (l : list (Σ i, M i)) :
  reduce (i :: reduce l) = reduce (i :: l)  :=
if ha : i.2 = 1 then by rw [reduce, if_pos ha, reduce, if_pos ha, reduce_reduce]
else by rw [← rcons_reduce_eq_reduce_cons ha, ← rcons_reduce_eq_reduce_cons ha,
    reduce_reduce]

lemma length_rcons_le : ∀ (i : Σ i, M i) (l : list (Σ i, M i)),
  (rcons i l).length ≤ (i::l : list _).length
| i      []          := le_refl _
| ⟨i, a⟩ (⟨j, b⟩::l) := begin
  simp [rcons],
  split_ifs,
  { repeat { constructor } },
  { simp },
  { simp }
end

lemma length_reduce_le : ∀ (l : list (Σ i, M i)),
  (reduce l).length ≤ l.length
| []        := le_refl _
| [a]       := by { simp [reduce], split_ifs; simp [rcons] }
| (a::b::l) := begin
  simp only [reduce, rcons],
  split_ifs,
  { exact le_trans (length_reduce_le _)
      (le_trans (nat.le_succ _) (nat.le_succ _)) },
  { exact le_trans (length_rcons_le _ _) (nat.succ_le_succ
      (le_trans (length_reduce_le _) (nat.le_succ _))) },
  { exact le_trans (length_rcons_le _ _) (nat.succ_le_succ
      (le_trans (length_reduce_le _) (nat.le_succ _))) },
  { exact le_trans (length_rcons_le _ _) (nat.succ_le_succ
         (le_trans (length_rcons_le _ _) (nat.succ_le_succ
           (length_reduce_le _)))) }
end

lemma length_rcons_lt_or_eq_rcons : ∀ (i : Σ i, M i) (l : list (Σ i, M i)),
  (rcons i l).length < (i :: l : list _).length ∨ rcons i l = (i::l)
| i [] := or.inr rfl
| i (j::l) := begin
  simp only [rcons],
  split_ifs,
  { exact or.inl (nat.lt_succ_of_le (nat.le_succ _)) },
  { exact or.inl (nat.lt_succ_self _) },
  { simp }
end

lemma length_reduce_lt_or_eq_reduce : ∀ (l : list (Σ i, M i)),
  (reduce l).length < l.length ∨ reduce l = l
| []        := or.inr rfl
| (i::l)    := begin
  simp only [reduce],
  split_ifs,
  { exact or.inl (nat.lt_succ_of_le (length_reduce_le _)) },
  { cases length_rcons_lt_or_eq_rcons i (reduce l) with h h,
    { exact or.inl (lt_of_lt_of_le h (nat.succ_le_succ (length_reduce_le _))) },
    { rw h,
      cases length_reduce_lt_or_eq_reduce l with h h,
      { exact or.inl (nat.succ_lt_succ h) },
      { rw h, right, refl } } }
end

lemma rcons_append : ∀ {i j : Σ i, M i} {l₁ l₂ : list (Σ i, M i)},
  rcons i ((j::l₁) ++ l₂) = rcons i (j::l₁) ++ l₂
| i j [] l₂ := begin
  simp [rcons], split_ifs; simp
end
| a b (c::l₁) l₂ := begin
  rw [cons_append, rcons],
  dsimp,
  split_ifs,
  { simp [rcons, *] },
  { simp [rcons, *] },
  { simp [rcons, *] }
end

lemma rcons_rcons_of_mul_eq_one {i : ι} {a b : M i} : ∀ {l : list (Σ i, M i)},
  a * b = 1 → reduced l → rcons ⟨i, a⟩ (rcons ⟨i, b⟩ l) = l
| []          hab hl := by simp [rcons, cast, hab]
| (⟨j, c⟩::l) hab hl := begin
  simp only [rcons],
  split_ifs,
  { dsimp only at h,
    subst h,
    rw [← rcons_eq_cons hl, left_inv_eq_right_inv hab h_1, cast_eq] },
  { dsimp only at h,
    subst h,
    simp only [rcons, dif_pos rfl],
    rw [cast_eq, cast_eq, if_neg, ← mul_assoc, hab, one_mul],
    { rw [← mul_assoc, hab, one_mul],
      exact hl.2 ⟨i, c⟩ (mem_cons_self _ _) } },
  { rw [rcons, dif_pos rfl, cast_eq], dsimp, rw [if_pos hab] }
end

lemma rcons_rcons_of_mul_ne_one {i : ι} {a b : M i} : ∀ {l : list (Σ i, M i)},
  a * b ≠ 1 → a ≠ 1 → reduced l → rcons ⟨i, a⟩ (rcons ⟨i, b⟩ l) = rcons ⟨i, a * b⟩ l
| []          hab ha hl := by simp [rcons, hab]
| [⟨j, c⟩]    hab ha hl := begin
  simp only [rcons],
  split_ifs,
  { rw [mul_assoc, h_1, mul_one] at h_2,
    exact (ha h_2).elim },
  { simp [rcons, mul_assoc, h_1] },
  { simp only [rcons, ← mul_assoc, *, dif_pos rfl, if_pos rfl, cast_eq] },
  { dsimp only at h,
    subst h,
    simp only [rcons, dif_pos rfl, ← mul_assoc, cast_eq, *] at *,
    simp, },
  { simp [rcons, if_neg hab, if_pos rfl] }
end
| (⟨j, c⟩::⟨k, d⟩::l) hab ha hl := begin
  have hjk : j ≠ k, from (chain'_cons.1 hl.1).1,
  dsimp only [rcons],
  split_ifs,
  { rw [mul_assoc, h_1, mul_one] at h_2,
    exact (ha h_2).elim },
  { dsimp [rcons],
    subst h,
    simp [*, rcons, mul_assoc] at * },
  { simp [*, rcons, ← mul_assoc] at * },
  { simp [*, rcons, ← mul_assoc] },
  { simp [*, rcons] }
end

lemma reduce_rcons : ∀ {i : Σ i, M i} (l : list (Σ i, M i)), i.2 ≠ 1 →
  reduce (rcons i l) = rcons i (reduce l)
| i []               hi := by simp [rcons, reduce, hi]
| ⟨i, a⟩ [⟨j, b⟩]    ha := begin
    replace ha : a ≠ 1 := ha,
    dsimp only [reduce, rcons],
    by_cases hij : i = j,
    { subst hij,
      split_ifs;
      simp [*, reduce, rcons] at * },
    { simp [hij, reduce, rcons, ha] }
  end
| ⟨i, a⟩ (⟨j, b⟩::l) ha := begin
  dsimp only [rcons],
  split_ifs,
  { subst h,
    rw [cast_eq] at h_1,
    rw [reduce, if_neg, rcons_rcons_of_mul_eq_one h_1 (reduced_reduce _)],
    { refine λ hb : b = 1, _,
      rw [hb, mul_one] at h_1,
      exact ha h_1 } },
  { subst h,
    rw [reduce, if_neg h_1, reduce],
    split_ifs,
    { erw [cast_eq, show b = 1, from h, mul_one] },
    { rw cast_eq at h_1,
      rw [rcons_rcons_of_mul_ne_one h_1 ha (reduced_reduce l), cast_eq], } },
  { rw [rcons_eq_reduce_cons ha (reduced_reduce _), reduce_cons_reduce_eq_reduce_cons] }
end

lemma reduce_cons_cons_of_mul_eq_one {l : list (Σ i, M i)} {i : ι} {a b : M i}
  (ha : a ≠ 1) (hb : b ≠ 1) (hab : a * b = 1) : reduce (⟨i, a⟩ :: ⟨i, b⟩ :: l) = reduce l :=
by rw [reduce, if_neg ha, reduce, if_neg hb, rcons_rcons_of_mul_eq_one hab (reduced_reduce _)]

lemma reduce_cons_cons_of_mul_ne_one {l : list (Σ i, M i)} {i : ι} {a b : M i}
  (ha : a ≠ 1) (hab : a * b ≠ 1) : reduce (⟨i, a⟩ :: ⟨i, b⟩ :: l) = reduce (⟨i, a * b⟩ :: l) :=
begin
  rw [reduce, if_neg ha, reduce],
  split_ifs,
  { rw [rcons_eq_reduce_cons (show (⟨i, a⟩ : Σ i, M i).snd ≠ 1, from ha) (reduced_reduce _),
      show b = 1, from h, mul_one, reduce_cons_reduce_eq_reduce_cons] },
  { rw [rcons_rcons_of_mul_ne_one hab ha (reduced_reduce _),
      rcons_eq_reduce_cons (show (⟨i, a * b⟩ : Σ i, M i).snd ≠ 1, from hab : _) (reduced_reduce _),
      reduce_cons_reduce_eq_reduce_cons] }
end

@[simp] lemma reduce_reduce_append_eq_reduce_append : ∀ (l₁ l₂ : list (Σ i, M i)),
  reduce (reduce l₁ ++ l₂) = reduce (l₁ ++ l₂)
| []         l₂ := rfl
| (a::l₁) l₂ := begin
  simp only [reduce, cons_append],
  split_ifs with ha ha,
  { exact reduce_reduce_append_eq_reduce_append _ _ },
  { rw [← reduce_reduce_append_eq_reduce_append l₁ l₂],
    induction h : reduce l₁,
    { simp [rcons, rcons_eq_reduce_cons ha (reduced_reduce _)] },
    { rw [← rcons_append, reduce_rcons _ ha] } }
end

@[simp] lemma reduce_append_reduce_eq_reduce_append : ∀ (l₁ l₂ : list (Σ i, M i)),
  reduce (l₁ ++ reduce l₂) = reduce (l₁ ++ l₂)
| []      l₂ := by simp
| (a::l₁) l₂ := by rw [cons_append, ← reduce_cons_reduce_eq_reduce_cons,
    reduce_append_reduce_eq_reduce_append,
    reduce_cons_reduce_eq_reduce_cons, cons_append]

lemma reduced_iff_reduce_eq_self {l : list (Σ i, M i)} :
  reduced l ↔ reduce l = l :=
⟨reduce_eq_self_of_reduced, λ h, h ▸ reduced_reduce l⟩

lemma reduced_append_overlap {l₁ l₂ l₃ : list (Σ i, M i)}
  (h₁ : reduced (l₁ ++ l₂)) (h₂ : reduced (l₂ ++ l₃)) (hn : l₂ ≠ []):
  reduced (l₁ ++ l₂ ++ l₃) :=
⟨chain'.append_overlap h₁.1 h₂.1 hn,
  λ i hi, (mem_append.1 hi).elim (h₁.2 _) (λ hi, h₂.2 _ (mem_append_right _ hi))⟩

/-- `mul_aux` returns `reduce (l₁.reverse ++ l₂)` -/
@[simp] def mul_aux : Π (l₁ l₂ : list (Σ i, M i)), list (Σ i, M i)
| []      l₂      := l₂
| (i::l₁) []      := reverse (i :: l₁)
| (i::l₁) (j::l₂) :=
  if hij : i.1 = j.1
    then let c := i.2 * cast (congr_arg M hij).symm j.2 in
      if c = 1
        then mul_aux l₁ l₂
        else l₁.reverse_core (⟨i.1, c⟩::l₂)
    else l₁.reverse_core (i::j::l₂)

local attribute [simp] reverse_core_eq

@[simp] def mul_aux' : Π (l₁ l₂ : list (Σ i, M i)), list (Σ i, M i)
| []      l₂      := l₂
| (i::l₁) []      := reverse (i :: l₁)
| (i::l₁) (j::l₂) :=
  if hij : i.1 = j.1
    then let c := i.2 * cast (congr_arg M hij).symm j.2 in
      if c = 1
        then mul_aux' l₁ l₂
        else mul_aux' l₁ (⟨i.1, c⟩::l₂)
    else mul_aux' l₁ (i::j::l₂)

lemma mul_aux'_eq_append : Π {l₁ l₂ : list (Σ i, M i)},
  reduced (l₁.reverse ++ l₂) → mul_aux' l₁ l₂ = l₁.reverse ++ l₂
| []      l₂      h := rfl
| (i::l₁) []      h := by simp
| (i::l₁) (j::l₂) h := begin
  rw [mul_aux'],
  have hij : i.fst ≠ j.fst,
  { rw [reduced, chain'_split, ← reverse_cons, chain'_reverse, chain'_cons] at h,
    simp [flip] at h,
    tauto },
  rw [dif_neg hij, mul_aux'_eq_append];
  simp * at *
end

lemma mul_aux_eq_mul_aux' : Π {l₁ l₂ : list (Σ i, M i)}
  (h₁ : reduced l₁) (h₂ : reduced l₂),
  mul_aux l₁ l₂ = mul_aux' l₁ l₂
| []      l₂      _ _ := rfl
| (i::l₁) []      _ _ := rfl
| [i]     (j::l₂) _ _ :=
  begin
    unfold mul_aux mul_aux',
    split_ifs; simp
  end
| (i::j::l₁) (k::l₂) h₁ h₂:=
  begin
    unfold mul_aux mul_aux',
    have hij : j.fst ≠ i.fst,
      by simp [reduced] at h₁; tauto,
    simp only [dif_neg hij],
    split_ifs,
    { rw mul_aux_eq_mul_aux' (reduced_of_reduced_cons h₁)
        (reduced_of_reduced_cons h₂) },
    { cases i with i a, cases k with k b,
      dsimp only at h, subst h,
      rw [reverse_core_eq, ← mul_aux_eq_mul_aux' (reduced_of_reduced_cons h₁)
        (reduced_cons_of_reduced_cons h₂ h_1), mul_aux, dif_neg hij],
      simp },
    { have : reduced (l₁.reverse ++ j :: i :: k :: l₂),
      { suffices : reduced ((j :: l₁).reverse ++ [i, k] ++ l₂),
        { simpa },
        cases i with i a, cases j with j b, cases k with k c,
        have hc1 : c ≠ 1, from h₂.2 ⟨k, c⟩ (mem_cons_self _ _),
        have ha1 : a ≠ 1, from h₁.2 ⟨i, a⟩ (mem_cons_self _ _),
        refine reduced_append_overlap _ _ (cons_ne_nil _ _),
        { suffices : reduced (⟨k, c⟩ :: ⟨i, a⟩ :: ⟨j, b⟩ :: l₁),
          { rw [← reduced_reverse_iff],
            simpa },
          exact reduced_cons_cons (ne.symm h) hc1 h₁ },
        { suffices : reduced (⟨i, a⟩ :: ⟨k, c⟩ :: l₂),
          { simpa },
          exact reduced_cons_cons h ha1 h₂ } },
      rw [mul_aux'_eq_append this],
      simp }
  end

@[simp] lemma mul_aux'_nil (l : list (Σ i, M i)) : mul_aux' l [] = l.reverse :=
by cases l; simp

lemma mul_aux'_single : Π (l₁ l₂ : list (Σ i, M i)) (i : Σ i, M i),
  mul_aux' l₁ (mul_aux' l₂.reverse [i]) = mul_aux' (mul_aux' l₁ l₂).reverse [i]
| [] l₂      i := by simp
| (j::l₁) [] i := by simp
| (⟨j, b⟩::l₁) (⟨k, c⟩::l₂) ⟨i, a⟩ :=
  list.reverse_rec_on l₂
    begin

    end
    (begin
      rintros l₂ ⟨m, d⟩ ih,
      simp at *, dsimp at *,
      split_ifs at *,

    end)

lemma mul_aux'_cons : ∀ (l₁ l₂ : list (Σ i, M i)) (i : Σ i, M i),
  mul_aux' (rcons i l₁) l₂ = mul_aux' l₁ (rcons i l₂)
| [] l₂      i := by simp [rcons]; admit
| (j::l₁) [] i := begin
  simp [rcons, eq_comm],
  split_ifs,
  { refl },

end

lemma mul_aux'_single : Π (l₁ l₂ : list (Σ i, M i)) (i : Σ i, M i),
  mul_aux' l₁ (mul_aux' [i] l₂) = mul_aux' (mul_aux' l₁ [i]).reverse l₂
| [] l₂      i := by simp
| (j::l₁) [] i := by simp
| (⟨j, b⟩::l₁) (⟨k, c⟩::l₂) ⟨i, a⟩ := begin
  rw [mul_aux', mul_aux'],
  dsimp,
  split_ifs,
  { simp, }

end

lemma mul_aux'_single : Π (l₁ l₂ : list (Σ i, M i)) (i : Σ i, M i),
  mul_aux' l₁ (mul_aux' l₂ [i]) = mul_aux' (mul_aux' l₁ l₂.reverse).reverse [i]
| [] l₂      i := by simp
| (j::l₁) [] i := by simp
| (⟨j, b⟩::l₁) (⟨k, c⟩::l₂) ⟨i, a⟩ :=
  list.reverse_rec_on l₂

@[simp] lemma mul_aux_nil (l : list (Σ i, M i)) : mul_aux l [] = l.reverse :=
by cases l; refl

@[simp] lemma nil_mul_aux (l : list (Σ i, M i)) : mul_aux [] l = l := rfl

lemma mul_aux_single_reverse : ∀ (l : list (Σ i, M i)) (i : Σ i, M i),
  mul_aux l [i] = mul_aux [i] l
| [] i := by simp
| (i::l) j := list.reverse_rec_on l
  (by simp [mul_aux, reverse_core_eq]; split_ifs; simp)
  _

lemma mul_aux_single : Π (l₁ l₂ : list (Σ i, M i)) (i : Σ i, M i),
  mul_aux l₁ (mul_aux l₂.reverse [i]) = mul_aux (mul_aux l₁ l₂).reverse [i]
| [] l₂      i := by simp [mul_aux]
| (j::l₁) [] i := by simp [mul_aux]
| (j::l₁) (k::l₂) i := begin
  simp only [mul_aux],
  split_ifs,
  { rw ← mul_aux_single, sorry },
  { simp [reverse_core_eq], }

end

lemma mul_aux_eq_reduce_append : ∀ {l₁ l₂: list (Σ i, M i)},
  reduced l₁ → reduced l₂ → mul_aux l₁ l₂ = reduce (l₁.reverse ++ l₂)
| []          l₂          := λ h₁ h₂,
  by clear_aux_decl; simp [mul_aux, reduce_eq_self_of_reduced, *]
| (i::hd)     []          := λ h₁ h₂,
  by rw [mul_aux, append_nil, reduce_eq_self_of_reduced (reduced_reverse h₁)]
| (⟨i,a⟩::l₁) (⟨j,b⟩::l₂) := λ h₁ h₂,
  begin
    simp only [mul_aux],
    dsimp only,
    have ha : a ≠ 1, from h₁.2 ⟨i, a⟩ (by simp),
    have hb : b ≠ 1, from h₂.2 ⟨j, b⟩ (list.mem_cons_self _ _),
    rcases decidable.em (i = j) with ⟨rfl, hij⟩,
    { rw [dif_pos rfl, cast_eq],
      split_ifs,
      { have hrl₁ : reduced l₁,
        { exact reduced_of_reduced_cons h₁ },
        have hrl₂ : reduced l₂, from reduced_of_reduced_cons h₂,
        rw [mul_aux_eq_reduce_append hrl₁ hrl₂, reverse_cons, append_assoc,
          cons_append, nil_append, ← reduce_append_reduce_eq_reduce_append _ (_ :: _),
          reduce_cons_cons_of_mul_eq_one ha hb h_1,
          reduce_append_reduce_eq_reduce_append] },
      { have hrl₁ :reduced (l₁.reverse ++ [⟨i, a * b⟩]),
        { rw [← reduced_reverse_iff, reverse_append, reverse_reverse,
            reverse_singleton, singleton_append],
          exact reduced_cons_of_reduced_cons h₁ h_1 },
        have hrl₂ :reduced ([⟨i, a * b⟩] ++ l₂),
        { rw [singleton_append],
          exact reduced_cons_of_reduced_cons h₂ h_1 },
        simp only [reverse_cons, singleton_append, append_assoc, reverse_core_eq],
        rw [← reduce_append_reduce_eq_reduce_append,
          reduce_cons_cons_of_mul_ne_one ha h_1,
          reduce_append_reduce_eq_reduce_append, ← singleton_append, ← append_assoc],
        exact (reduce_eq_self_of_reduced
          (reduced_append_overlap hrl₁ hrl₂ (by simp))).symm } },
    { suffices : reduce (l₁.reverse ++ [⟨i, a⟩, ⟨j, b⟩] ++ l₂) =
        l₁.reverse ++ [⟨i, a⟩, ⟨j, b⟩] ++ l₂,
      { simpa [eq_comm, dif_neg h, reverse_core_eq] },
      have hrl₁ : reduced (l₁.reverse ++ [⟨i, a⟩, ⟨j, b⟩]),
      { rw [← reduced_reverse_iff],
        simp only [reverse_append, reverse_cons, cons_append, reverse_nil, nil_append,
          reverse_reverse],
        refine reduced_cons_cons (ne.symm h) hb h₁ },
      have hrl₂ : reduced ([⟨i, a⟩, ⟨j, b⟩] ++ l₂),
      { simp only [cons_append, nil_append],
        refine reduced_cons_cons h ha h₂ },
      exact reduce_eq_self_of_reduced (reduced_append_overlap hrl₁ hrl₂ (by simp)) }
  end

protected def mul (l₁ l₂ : list (Σ i, M i)) : list (Σ i, M i) :=
mul_aux l₁.reverse l₂

lemma mul_eq_reduce_append {l₁ l₂ : list (Σ i, M i)} (h₁ : reduced l₁) (h₂ : reduced l₂) :
  coprod.pre.mul l₁ l₂ = reduce (l₁ ++ l₂) :=
by rw [coprod.pre.mul, mul_aux_eq_reduce_append (reduced_reverse h₁) h₂, reverse_reverse]

lemma reduced_mul {l₁ l₂ : list (Σ i, M i)} (h₁ : reduced l₁) (h₂ : reduced l₂) :
  reduced (coprod.pre.mul l₁ l₂) :=
(mul_eq_reduce_append h₁ h₂).symm ▸ reduced_reduce _

protected lemma mul_assoc {l₁ l₂ l₃ : list (Σ i, M i)} (h₁ : reduced l₁) (h₂ : reduced l₂)
  (h₃ : reduced l₃) : pre.mul (pre.mul l₁ l₂) l₃ = pre.mul l₁ (pre.mul l₂ l₃) :=
begin
  rw [mul_eq_reduce_append (reduced_mul h₁ h₂) h₃, mul_eq_reduce_append h₁ h₂,
    mul_eq_reduce_append h₂ h₃, mul_eq_reduce_append h₁ (reduced_reduce _)],
  simp [append_assoc]
end

protected lemma one_mul (l : list (Σ i, M i)) : pre.mul [] l = l := rfl

protected lemma mul_one {l : list (Σ i, M i)} (h : reduced l) : pre.mul l [] = l :=
by rw [mul_eq_reduce_append h reduced_nil, append_nil, reduce_eq_self_of_reduced h]

section lift

variable (f : Π i, M i →* N)

def lift (l : list (Σ i, M i)) : N :=
l.foldl (λ n i, n * f i.1 i.2) 1

lemma lift_eq_map_prod (l : list (Σ i, M i)) :
  lift f l = (l.map (λ i : Σ i, M i, f i.1 i.2)).prod :=
begin
  rw [lift, ← one_mul (l.map _).prod],
  generalize h : (1 : N) = n, clear h,
  induction l with i l ih generalizing n,
  { simp },
  { rw [foldl_cons, ih, map_cons, prod_cons, mul_assoc] }
end

lemma map_prod_mul_aux : ∀ (l₁ l₂ : list (Σ i, M i)),
  ((mul_aux l₁ l₂).map (λ i : Σ i, M i, f i.1 i.2)).prod =
  (l₁.reverse.map (λ i : Σ i, M i, f i.1 i.2)).prod *
  (l₂.map (λ i : Σ i, M i, f i.1 i.2)).prod
| []      l₂      := by simp [mul_aux]
| (i::l₁) []      := by simp [mul_aux]
| (⟨i,a⟩::l₁) (⟨j,b⟩::l₂) := begin
  rw [mul_aux],
  split_ifs,
  { dsimp only at h,
    subst h,
    rw [cast_eq] at h_1,
    simp only [prod_nil, mul_one, reverse_cons, map, prod_cons, prod_append,
        map_append, map_reverse, mul_assoc],
    rw [← mul_assoc (f _ _), ← monoid_hom.map_mul, h_1],
    simp [map_prod_mul_aux] },
  { dsimp only at h,
    subst h,
    simp [reverse_core_eq, mul_assoc] },
  { simp [reverse_core_eq, mul_assoc] }
end

lemma lift_mul (l₁ l₂ : list (Σ i, M i)) : lift f (pre.mul l₁ l₂) = lift f l₁ * lift f l₂ :=
by simp [pre.mul, lift_eq_map_prod, map_prod_mul_aux]

end lift

section of
variables (i : ι) (a b : M i)

def of (i : ι) (a : M i) : list (Σ i, M i) :=
if a = 1 then [] else [⟨i, a⟩]

lemma reduced_of (i : ι) (a : M i) : reduced (of i a) :=
begin
  rw of,
  split_ifs,
  { simp },
  { exact reduced_singleton h }
end

lemma of_one : of i (1 : M i) = [] := if_pos rfl

lemma of_mul : of i (a * b) = pre.mul (of i a) (of i b) :=
begin
  simp only [of, pre.mul, mul_aux],
  split_ifs; simp [mul_aux, *, reverse_core_eq] at *
end

lemma lift_of (f : Π i, M i →* N) : lift f (of i a) = f i a :=
begin
  simp [lift, of],
  split_ifs;
  simp *
end

end of

section embedding
variables {κ : Type*} {O : κ → Type*} [Π i, monoid (O i)]
variables (f : ι → κ) (hf : injective f)
  (g : Π i, M i →* O (f i)) (hg : ∀ i a, g i a = 1 → a = 1)

protected def embedding (l : list (Σ i, M i)) : list Σ i, O i :=
l.map (λ i, ⟨f i.1, g i.1 i.2⟩)

include hf hg

variables [decidable_eq κ] [Π i, decidable_eq (O i)]

lemma embedding_mul_aux : ∀ (l₁ l₂ : list (Σ i, M i)),
  pre.embedding f g (mul_aux l₁ l₂) = mul_aux (pre.embedding f g l₁) (pre.embedding f g l₂)
| []      l₂      := rfl
| (i::l₁) []      := by simp [pre.embedding, mul_aux]
| (⟨i,a⟩::l₁) (⟨j, b⟩::l₂) :=
  begin
    rw [mul_aux],
    split_ifs,
    { dsimp only at h,
      subst h,
      have : g i a * g i b = 1,
      { erw [← monoid_hom.map_mul, h_1, monoid_hom.map_one] },
      rw [embedding_mul_aux],
      simp [pre.embedding, mul_aux, this] },
    { dsimp only at h,
      subst h,
      have : g i a * g i b ≠ 1,
      { rw [← monoid_hom.map_mul],
        exact mt (hg i (a * b)) h_1 },
      simp [pre.embedding, mul_aux, this, reverse_core_eq] },
    { dsimp only at h,
      simp [pre.embedding, mul_aux, reverse_core_eq, hf.eq_iff, h] }
  end

lemma embedding_mul {l₁ l₂ : list (Σ i, M i)} :
  pre.embedding f g (pre.mul l₁ l₂) = pre.mul (pre.embedding f g l₁) (pre.embedding f g l₂) :=
begin
  simp [pre.mul, embedding_mul_aux _ hf _ hg],
  simp [pre.embedding]
end

lemma reduced_embedding {l : list (Σ i, M i)} (hl : reduced l) :
  reduced (pre.embedding f g l) :=
⟨by simp [pre.embedding, list.chain'_map, hf.eq_iff, hl.1],
  begin
    simp only [pre.embedding, mem_map, and_imp, sigma.forall],
    rintros i a ⟨⟨j, b⟩, hjb, rfl, h⟩,
    rw [heq_iff_eq] at h,
    subst a,
    exact mt (hg j b) (hl.2 _ hjb)
  end⟩

end embedding

section inv

variable [Π i, decidable_eq (G i)]

protected def inv (l : list (Σ i, G i)) : list (Σ i, G i) :=
list.reverse (l.map (λ i : Σ i, G i, ⟨i.1, i.2⁻¹⟩))

lemma reduced_inv (l : list (Σ i, G i)) (hl : reduced l) :
  reduced (pre.inv l) :=
⟨list.chain'_reverse.2 ((list.chain'_map _).2 $
  by { convert hl.1, simp [function.funext_iff, eq_comm, flip] }),
begin
  rintros ⟨i, a⟩ hi,
  rw [pre.inv, mem_reverse, mem_map] at hi,
  rcases hi with ⟨⟨j, b⟩, hjl, h⟩,
  simp only at h,
  cases h with hij hba,
  subst hij,
  convert inv_ne_one.2 (hl.2 ⟨j, b⟩ hjl),
  simp * at *
end⟩

protected lemma mul_left_inv_aux : ∀ l : list (Σ i, G i),
  mul_aux (l.map (λ i : Σ i, G i, ⟨i.1, i.2⁻¹⟩)) l = []
| []     := rfl
| (i::l) := by simp [mul_aux, mul_left_inv_aux l]

protected lemma mul_left_inv (l : list (Σ i, G i)) :
  pre.mul (pre.inv l) l = [] :=
by rw [pre.mul, pre.inv, reverse_reverse, pre.mul_left_inv_aux]

end inv

end coprod.pre


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Tim Baumann, Stephen Morgan, Scott Morrison, Floris van Doorn
-/
import category_theory.functor.basic

/-!
# Isomorphisms

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

This file defines isomorphisms between objects of a category.

## Main definitions

- `structure iso` : a bundled isomorphism between two objects of a category;
- `class is_iso` : an unbundled version of `iso`;
  note that `is_iso f` is a `Prop`, and only asserts the existence of an inverse.
  Of course, this inverse is unique, so it doesn't cost us much to use choice to retrieve it.
- `inv f`, for the inverse of a morphism with `[is_iso f]`
- `as_iso` : convert from `is_iso` to `iso` (noncomputable);
- `of_iso` : convert from `iso` to `is_iso`;
- standard operations on isomorphisms (composition, inverse etc)

## Notations

- `X ≅ Y` : same as `iso X Y`;
- `α ≪≫ β` : composition of two isomorphisms; it is called `iso.trans`

## Tags

category, category theory, isomorphism
-/

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

namespace category_theory
open category

/--
An isomorphism (a.k.a. an invertible morphism) between two objects of a category.
The inverse morphism is bundled.

See also `category_theory.core` for the category with the same objects and isomorphisms playing
the role of morphisms.

See <https://stacks.math.columbia.edu/tag/0017>.
-/
structure iso {C : Type u} [category.{v} C] (X Y : C) :=
(hom : X ⟶ Y)
(inv : Y ⟶ X)
(hom_inv_id' : hom ≫ inv = 𝟙 X . obviously)
(inv_hom_id' : inv ≫ hom = 𝟙 Y . obviously)

restate_axiom iso.hom_inv_id'
restate_axiom iso.inv_hom_id'
attribute [simp, reassoc] iso.hom_inv_id iso.inv_hom_id

infixr ` ≅ `:10  := iso             -- type as \cong or \iso

variables {C : Type u} [category.{v} C]
variables {X Y Z : C}

namespace iso

@[ext] lemma ext ⦃α β : X ≅ Y⦄ (w : α.hom = β.hom) : α = β :=
suffices α.inv = β.inv, by cases α; cases β; cc,
calc α.inv
    = α.inv ≫ (β.hom ≫ β.inv) : by rw [iso.hom_inv_id, category.comp_id]
... = (α.inv ≫ α.hom) ≫ β.inv : by rw [category.assoc, ←w]
... = β.inv                   : by rw [iso.inv_hom_id, category.id_comp]

/-- Inverse isomorphism. -/
@[symm] def symm (I : X ≅ Y) : Y ≅ X :=
{ hom := I.inv,
  inv := I.hom,
  hom_inv_id' := I.inv_hom_id',
  inv_hom_id' := I.hom_inv_id' }

@[simp] lemma symm_hom (α : X ≅ Y) : α.symm.hom = α.inv := rfl
@[simp] lemma symm_inv (α : X ≅ Y) : α.symm.inv = α.hom := rfl

@[simp] lemma symm_mk {X Y : C} (hom : X ⟶ Y) (inv : Y ⟶ X) (hom_inv_id) (inv_hom_id) :
  iso.symm {hom := hom, inv := inv, hom_inv_id' := hom_inv_id, inv_hom_id' := inv_hom_id} =
    {hom := inv, inv := hom, hom_inv_id' := inv_hom_id, inv_hom_id' := hom_inv_id} := rfl

@[simp] lemma symm_symm_eq {X Y : C} (α : X ≅ Y) : α.symm.symm = α :=
by cases α; refl

@[simp] lemma symm_eq_iff {X Y : C} {α β : X ≅ Y} : α.symm = β.symm ↔ α = β :=
⟨λ h, symm_symm_eq α ▸ symm_symm_eq β ▸ congr_arg symm h, congr_arg symm⟩

lemma nonempty_iso_symm (X Y : C) : nonempty (X ≅ Y) ↔ nonempty (Y ≅ X) :=
⟨λ h, ⟨h.some.symm⟩, λ h, ⟨h.some.symm⟩⟩

/-- Identity isomorphism. -/
@[refl, simps] def refl (X : C) : X ≅ X :=
{ hom := 𝟙 X,
  inv := 𝟙 X }

instance : inhabited (X ≅ X) := ⟨iso.refl X⟩

@[simp] lemma refl_symm (X : C) : (iso.refl X).symm = iso.refl X := rfl

/-- Composition of two isomorphisms -/
@[trans, simps] def trans (α : X ≅ Y) (β : Y ≅ Z) : X ≅ Z :=
{ hom := α.hom ≫ β.hom,
  inv := β.inv ≫ α.inv }

infixr ` ≪≫ `:80 := iso.trans -- type as `\ll \gg`.

@[simp] lemma trans_mk {X Y Z : C}
  (hom : X ⟶ Y) (inv : Y ⟶ X) (hom_inv_id) (inv_hom_id)
  (hom' : Y ⟶ Z) (inv' : Z ⟶ Y) (hom_inv_id') (inv_hom_id') (hom_inv_id'') (inv_hom_id'') :
  iso.trans
    {hom := hom, inv := inv, hom_inv_id' := hom_inv_id, inv_hom_id' := inv_hom_id}
    {hom := hom', inv := inv', hom_inv_id' := hom_inv_id', inv_hom_id' := inv_hom_id'} =
  { hom := hom ≫ hom', inv := inv' ≫ inv, hom_inv_id' := hom_inv_id'',
    inv_hom_id' := inv_hom_id''} :=
rfl

@[simp] lemma trans_symm (α : X ≅ Y) (β : Y ≅ Z) : (α ≪≫ β).symm = β.symm ≪≫ α.symm := rfl
@[simp] lemma trans_assoc {Z' : C} (α : X ≅ Y) (β : Y ≅ Z) (γ : Z ≅ Z') :
  (α ≪≫ β) ≪≫ γ = α ≪≫ β ≪≫ γ :=
by ext; simp only [trans_hom, category.assoc]

@[simp] lemma refl_trans (α : X ≅ Y) : (iso.refl X) ≪≫ α = α := by ext; apply category.id_comp
@[simp] lemma trans_refl (α : X ≅ Y) : α ≪≫ (iso.refl Y) = α := by ext; apply category.comp_id

@[simp] lemma symm_self_id (α : X ≅ Y) : α.symm ≪≫ α = iso.refl Y := ext α.inv_hom_id
@[simp] lemma self_symm_id (α : X ≅ Y) : α ≪≫ α.symm = iso.refl X := ext α.hom_inv_id

@[simp] lemma symm_self_id_assoc (α : X ≅ Y) (β : Y ≅ Z) : α.symm ≪≫ α ≪≫ β = β :=
by rw [← trans_assoc, symm_self_id, refl_trans]

@[simp] lemma self_symm_id_assoc (α : X ≅ Y) (β : X ≅ Z) : α ≪≫ α.symm ≪≫ β = β :=
by rw [← trans_assoc, self_symm_id, refl_trans]

lemma inv_comp_eq (α : X ≅ Y) {f : X ⟶ Z} {g : Y ⟶ Z} : α.inv ≫ f = g ↔ f = α.hom ≫ g :=
⟨λ H, by simp [H.symm], λ H, by simp [H]⟩

lemma eq_inv_comp (α : X ≅ Y) {f : X ⟶ Z} {g : Y ⟶ Z} : g = α.inv ≫ f ↔ α.hom ≫ g = f :=
(inv_comp_eq α.symm).symm

lemma comp_inv_eq (α : X ≅ Y) {f : Z ⟶ Y} {g : Z ⟶ X} : f ≫ α.inv = g ↔ f = g ≫ α.hom :=
⟨λ H, by simp [H.symm], λ H, by simp [H]⟩

lemma eq_comp_inv (α : X ≅ Y) {f : Z ⟶ Y} {g : Z ⟶ X} : g = f ≫ α.inv ↔ g ≫ α.hom = f :=
(comp_inv_eq α.symm).symm

lemma inv_eq_inv (f g : X ≅ Y) : f.inv = g.inv ↔ f.hom = g.hom :=
have ∀{X Y : C} (f g : X ≅ Y), f.hom = g.hom → f.inv = g.inv, from λ X Y f g h, by rw [ext h],
⟨this f.symm g.symm, this f g⟩

lemma hom_comp_eq_id (α : X ≅ Y) {f : Y ⟶ X} : α.hom ≫ f = 𝟙 X ↔ f = α.inv :=
by rw [←eq_inv_comp, comp_id]

lemma comp_hom_eq_id (α : X ≅ Y) {f : Y ⟶ X} : f ≫ α.hom = 𝟙 Y ↔ f = α.inv :=
by rw [←eq_comp_inv, id_comp]

lemma inv_comp_eq_id (α : X ≅ Y) {f : X ⟶ Y} : α.inv ≫ f = 𝟙 Y ↔ f = α.hom :=
hom_comp_eq_id α.symm

lemma comp_inv_eq_id (α : X ≅ Y) {f : X ⟶ Y} : f ≫ α.inv = 𝟙 X ↔ f = α.hom :=
comp_hom_eq_id α.symm

lemma hom_eq_inv (α : X ≅ Y) (β : Y ≅ X) : α.hom = β.inv ↔ β.hom = α.inv :=
by { erw [inv_eq_inv α.symm β, eq_comm], refl }

end iso

/-- `is_iso` typeclass expressing that a morphism is invertible. -/
class is_iso (f : X ⟶ Y) : Prop :=
(out : ∃ inv : Y ⟶ X, f ≫ inv = 𝟙 X ∧ inv ≫ f = 𝟙 Y)

/--
The inverse of a morphism `f` when we have `[is_iso f]`.
-/
noncomputable def inv (f : X ⟶ Y) [I : is_iso f] := classical.some I.1

namespace is_iso

@[simp, reassoc] lemma hom_inv_id (f : X ⟶ Y) [I : is_iso f] : f ≫ inv f = 𝟙 X :=
(classical.some_spec I.1).left
@[simp, reassoc] lemma inv_hom_id (f : X ⟶ Y) [I : is_iso f] : inv f ≫ f = 𝟙 Y :=
(classical.some_spec I.1).right

end is_iso

open is_iso

/-- Reinterpret a morphism `f` with an `is_iso f` instance as an `iso`. -/
noncomputable
def as_iso (f : X ⟶ Y) [h : is_iso f] : X ≅ Y := ⟨f, inv f, hom_inv_id f, inv_hom_id f⟩

@[simp] lemma as_iso_hom (f : X ⟶ Y) [is_iso f] : (as_iso f).hom = f := rfl
@[simp] lemma as_iso_inv (f : X ⟶ Y) [is_iso f] : (as_iso f).inv = inv f := rfl

namespace is_iso

@[priority 100] -- see Note [lower instance priority]
instance epi_of_iso (f : X ⟶ Y) [is_iso f] : epi f  :=
{ left_cancellation := λ Z g h w,
  -- This is an interesting test case for better rewrite automation.
  by rw [← is_iso.inv_hom_id_assoc f g, w, is_iso.inv_hom_id_assoc f h] }
@[priority 100] -- see Note [lower instance priority]
instance mono_of_iso (f : X ⟶ Y) [is_iso f] : mono f :=
{ right_cancellation := λ Z g h w,
  by rw [← category.comp_id g, ← category.comp_id h, ← is_iso.hom_inv_id f, ← category.assoc, w,
    ← category.assoc] }

@[ext] lemma inv_eq_of_hom_inv_id {f : X ⟶ Y} [is_iso f] {g : Y ⟶ X}
  (hom_inv_id : f ≫ g = 𝟙 X) : inv f = g :=
begin
  apply (cancel_epi f).mp,
  simp [hom_inv_id],
end

lemma inv_eq_of_inv_hom_id {f : X ⟶ Y} [is_iso f] {g : Y ⟶ X}
  (inv_hom_id : g ≫ f = 𝟙 Y) : inv f = g :=
begin
  apply (cancel_mono f).mp,
  simp [inv_hom_id],
end

@[ext] lemma eq_inv_of_hom_inv_id {f : X ⟶ Y} [is_iso f] {g : Y ⟶ X}
  (hom_inv_id : f ≫ g = 𝟙 X) : g = inv f :=
(inv_eq_of_hom_inv_id hom_inv_id).symm

lemma eq_inv_of_inv_hom_id {f : X ⟶ Y} [is_iso f] {g : Y ⟶ X}
  (inv_hom_id : g ≫ f = 𝟙 Y) : g = inv f :=
(inv_eq_of_inv_hom_id inv_hom_id).symm

instance id (X : C) : is_iso (𝟙 X) :=
⟨⟨𝟙 X, by simp⟩⟩

instance of_iso (f : X ≅ Y) : is_iso f.hom :=
⟨⟨f.inv, by simp⟩⟩

instance of_iso_inv (f : X ≅ Y) : is_iso f.inv :=
is_iso.of_iso f.symm

variables {f g : X ⟶ Y} {h : Y ⟶ Z}

instance inv_is_iso [is_iso f] : is_iso (inv f) :=
is_iso.of_iso_inv (as_iso f)

/- The following instance has lower priority for the following reason:
Suppose we are given `f : X ≅ Y` with `X Y : Type u`.
Without the lower priority, typeclass inference cannot deduce `is_iso f.hom`
because `f.hom` is defeq to `(λ x, x) ≫ f.hom`, triggering a loop. -/
@[priority 900]
instance comp_is_iso [is_iso f] [is_iso h] : is_iso (f ≫ h) :=
is_iso.of_iso $ (as_iso f) ≪≫ (as_iso h)

@[simp] lemma inv_id : inv (𝟙 X) = 𝟙 X := by { ext, simp, }
@[simp] lemma inv_comp [is_iso f] [is_iso h] : inv (f ≫ h) = inv h ≫ inv f := by { ext, simp, }
@[simp] lemma inv_inv [is_iso f] : inv (inv f) = f := by { ext, simp, }
@[simp] lemma iso.inv_inv (f : X ≅ Y) : inv (f.inv) = f.hom := by { ext, simp, }
@[simp] lemma iso.inv_hom (f : X ≅ Y) : inv (f.hom) = f.inv := by { ext, simp, }

@[simp]
lemma inv_comp_eq (α : X ⟶ Y) [is_iso α] {f : X ⟶ Z} {g : Y ⟶ Z} : inv α ≫ f = g ↔ f = α ≫ g :=
(as_iso α).inv_comp_eq

@[simp]
lemma eq_inv_comp (α : X ⟶ Y) [is_iso α] {f : X ⟶ Z} {g : Y ⟶ Z} : g = inv α ≫ f ↔ α ≫ g = f :=
(as_iso α).eq_inv_comp

@[simp]
lemma comp_inv_eq (α : X ⟶ Y) [is_iso α] {f : Z ⟶ Y} {g : Z ⟶ X} : f ≫ inv α = g ↔ f = g ≫ α :=
(as_iso α).comp_inv_eq

@[simp]
lemma eq_comp_inv (α : X ⟶ Y) [is_iso α] {f : Z ⟶ Y} {g : Z ⟶ X} : g = f ≫ inv α ↔ g ≫ α = f :=
(as_iso α).eq_comp_inv

lemma of_is_iso_comp_left {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z)
  [is_iso f] [is_iso (f ≫ g)] : is_iso g :=
by { rw [← id_comp g, ← inv_hom_id f, assoc], apply_instance, }

lemma of_is_iso_comp_right {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z)
  [is_iso g] [is_iso (f ≫ g)] : is_iso f :=
by { rw [← comp_id f, ← hom_inv_id g, ← assoc], apply_instance, }

lemma of_is_iso_fac_left {X Y Z : C} {f : X ⟶ Y} {g : Y ⟶ Z} {h : X ⟶ Z}
  [is_iso f] [hh : is_iso h] (w : f ≫ g = h) : is_iso g :=
by { rw ← w at hh, haveI := hh, exact of_is_iso_comp_left f g, }

lemma of_is_iso_fac_right {X Y Z : C} {f : X ⟶ Y} {g : Y ⟶ Z} {h : X ⟶ Z}
  [is_iso g] [hh : is_iso h] (w : f ≫ g = h) : is_iso f :=
by { rw ← w at hh, haveI := hh, exact of_is_iso_comp_right f g, }

end is_iso

open is_iso

lemma eq_of_inv_eq_inv {f g : X ⟶ Y} [is_iso f] [is_iso g] (p : inv f = inv g) : f = g :=
begin
  apply (cancel_epi (inv f)).1,
  erw [inv_hom_id, p, inv_hom_id],
end

lemma is_iso.inv_eq_inv {f g : X ⟶ Y} [is_iso f] [is_iso g] : inv f = inv g ↔ f = g :=
iso.inv_eq_inv (as_iso f) (as_iso g)

lemma hom_comp_eq_id (g : X ⟶ Y) [is_iso g] {f : Y ⟶ X} : g ≫ f = 𝟙 X ↔ f = inv g :=
(as_iso g).hom_comp_eq_id

lemma comp_hom_eq_id (g : X ⟶ Y) [is_iso g] {f : Y ⟶ X} : f ≫ g = 𝟙 Y ↔ f = inv g :=
(as_iso g).comp_hom_eq_id

lemma inv_comp_eq_id (g : X ⟶ Y) [is_iso g] {f : X ⟶ Y} : inv g ≫ f = 𝟙 Y ↔ f = g :=
(as_iso g).inv_comp_eq_id

lemma comp_inv_eq_id (g : X ⟶ Y) [is_iso g] {f : X ⟶ Y} : f ≫ inv g = 𝟙 X ↔ f = g :=
(as_iso g).comp_inv_eq_id

lemma is_iso_of_hom_comp_eq_id (g : X ⟶ Y) [is_iso g] {f : Y ⟶ X} (h : g ≫ f = 𝟙 X) : is_iso f :=
by { rw [(hom_comp_eq_id _).mp h], apply_instance }

lemma is_iso_of_comp_hom_eq_id (g : X ⟶ Y) [is_iso g] {f : Y ⟶ X} (h : f ≫ g = 𝟙 Y) : is_iso f :=
by { rw [(comp_hom_eq_id _).mp h], apply_instance }

namespace iso

@[ext] lemma inv_ext {f : X ≅ Y} {g : Y ⟶ X}
  (hom_inv_id : f.hom ≫ g = 𝟙 X) : f.inv = g :=
((hom_comp_eq_id f).1 hom_inv_id).symm

@[ext] lemma inv_ext' {f : X ≅ Y} {g : Y ⟶ X}
  (hom_inv_id : f.hom ≫ g = 𝟙 X) : g = f.inv :=
(hom_comp_eq_id f).1 hom_inv_id

/-!
All these cancellation lemmas can be solved by `simp [cancel_mono]` (or `simp [cancel_epi]`),
but with the current design `cancel_mono` is not a good `simp` lemma,
because it generates a typeclass search.

When we can see syntactically that a morphism is a `mono` or an `epi`
because it came from an isomorphism, it's fine to do the cancellation via `simp`.

In the longer term, it might be worth exploring making `mono` and `epi` structures,
rather than typeclasses, with coercions back to `X ⟶ Y`.
Presumably we could write `X ↪ Y` and `X ↠ Y`.
-/

@[simp] lemma cancel_iso_hom_left {X Y Z : C} (f : X ≅ Y) (g g' : Y ⟶ Z) :
  f.hom ≫ g = f.hom ≫ g' ↔ g = g' :=
by simp only [cancel_epi]

@[simp] lemma cancel_iso_inv_left {X Y Z : C} (f : Y ≅ X) (g g' : Y ⟶ Z) :
  f.inv ≫ g = f.inv ≫ g' ↔ g = g' :=
by simp only [cancel_epi]

@[simp] lemma cancel_iso_hom_right {X Y Z : C} (f f' : X ⟶ Y) (g : Y ≅ Z) :
  f ≫ g.hom = f' ≫ g.hom ↔ f = f' :=
by simp only [cancel_mono]

@[simp] lemma cancel_iso_inv_right {X Y Z : C} (f f' : X ⟶ Y) (g : Z ≅ Y) :
  f ≫ g.inv = f' ≫ g.inv ↔ f = f' :=
by simp only [cancel_mono]

/-
Unfortunately cancelling an isomorphism from the right of a chain of compositions is awkward.
We would need separate lemmas for each chain length (worse: for each pair of chain lengths).

We provide two more lemmas, for case of three morphisms, because this actually comes up in practice,
but then stop.
-/

@[simp] lemma cancel_iso_hom_right_assoc {W X X' Y Z : C}
  (f : W ⟶ X) (g : X ⟶ Y) (f' : W ⟶ X') (g' : X' ⟶ Y)
  (h : Y ≅ Z) :
  f ≫ g ≫ h.hom = f' ≫ g' ≫ h.hom ↔ f ≫ g = f' ≫ g' :=
by simp only [←category.assoc, cancel_mono]

@[simp] lemma cancel_iso_inv_right_assoc {W X X' Y Z : C}
  (f : W ⟶ X) (g : X ⟶ Y) (f' : W ⟶ X') (g' : X' ⟶ Y)
  (h : Z ≅ Y) :
  f ≫ g ≫ h.inv = f' ≫ g' ≫ h.inv ↔ f ≫ g = f' ≫ g' :=
by simp only [←category.assoc, cancel_mono]

end iso

namespace functor

universes u₁ v₁ u₂ v₂
variables {D : Type u₂}

variables [category.{v₂} D]

/-- A functor `F : C ⥤ D` sends isomorphisms `i : X ≅ Y` to isomorphisms `F.obj X ≅ F.obj Y` -/
@[simps]
def map_iso (F : C ⥤ D) {X Y : C} (i : X ≅ Y) : F.obj X ≅ F.obj Y :=
{ hom := F.map i.hom,
  inv := F.map i.inv,
  hom_inv_id' := by rw [←map_comp, iso.hom_inv_id, ←map_id],
  inv_hom_id' := by rw [←map_comp, iso.inv_hom_id, ←map_id] }

@[simp] lemma map_iso_symm (F : C ⥤ D) {X Y : C} (i : X ≅ Y) :
  F.map_iso i.symm = (F.map_iso i).symm :=
rfl

@[simp] lemma map_iso_trans (F : C ⥤ D) {X Y Z : C} (i : X ≅ Y) (j : Y ≅ Z) :
  F.map_iso (i ≪≫ j) = (F.map_iso i) ≪≫ (F.map_iso j) :=
by ext; apply functor.map_comp

@[simp] lemma map_iso_refl (F : C ⥤ D) (X : C) : F.map_iso (iso.refl X) = iso.refl (F.obj X) :=
iso.ext $ F.map_id X

instance map_is_iso (F : C ⥤ D) (f : X ⟶ Y) [is_iso f] : is_iso (F.map f) :=
is_iso.of_iso $ F.map_iso (as_iso f)

@[simp]

lemma map_hom_inv (F : C ⥤ D) {X Y : C} (f : X ⟶ Y) [is_iso f] :
  F.map f ≫ F.map (inv f) = 𝟙 (F.obj X) :=
by simp

lemma map_inv_hom (F : C ⥤ D) {X Y : C} (f : X ⟶ Y) [is_iso f] :
  F.map (inv f) ≫ F.map f = 𝟙 (F.obj Y) :=
by simp

end functor

end category_theory