/-
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
import category_theory.adjunction

/-!

# Multi-(co)equalizers

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 v u

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

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

namespace walking_multicospan

variables {L R : Type v} {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 v
| 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_inhabited_instance]
structure multicospan_index (C : Type u) [category.{v} C] :=
(L R : Type v)
(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_inhabited_instance]
structure multispan_index (C : Type u) [category.{v} C] :=
(L R : Type v)
(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_inhabited_instance]
abbreviation multifork (I : multicospan_index C) := cone I.multicospan

/-- A multicofork is a cocone over a multispan. -/
@[nolint has_inhabited_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 ι_eq_app_left (a) : K.ι a = K.π.app (walking_multicospan.left _) := rfl

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

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

/-- 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 } }

@[reassoc]
lemma condition (b) :
  K.ι (I.fst_to b) ≫ I.fst b = K.ι (I.snd_to b) ≫ I.snd b := by simp

/-- 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, 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.π.app walking_parallel_pair.zero = 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).π.app (walking_multicospan.left 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 } }

/-- `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))
    (λ K₁ K₂ f, by { ext, simp }),
  counit_iso := nat_iso.of_components (λ K, fork.ext (iso.refl _) (by { ext, 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.π b = K.ι.app (walking_multispan.right _) := rfl

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

@[simp] lemma snd_app_right (a) :
  I.snd a ≫ K.ι.app (walking_multispan.right (I.snd_from a)) =
    K.ι.app (walking_multispan.left a) :=
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 } }

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

/-- 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, 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_ι_app_zero :
  K.to_sigma_cofork.ι.app walking_parallel_pair.zero = I.fst_sigma_map ≫ sigma.desc K.π := rfl

@[simp] lemma to_sigma_cofork_ι_app_one :
  K.to_sigma_cofork.ι.app walking_parallel_pair.one = 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 [←cofork.left_app_one, -cofork.left_app_one] },
      { change _ ≫ _ ≫ _ = (_ ≫ _) ≫ 𝟙 _,
        rw c.condition,
        dsimp, simp [←cofork.right_app_one, -cofork.right_app_one] }
    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, dsimp, simp }))
    (λ 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] [has_equalizer I.fst_pi_map I.snd_pi_map]

/-- 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]
variables [has_coequalizer I.fst_sigma_map I.snd_sigma_map]

/-- 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) 2019 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon

The writer monad transformer for passing immutable state.

! This file was ported from Lean 3 source module control.monad.writer
! leanprover-community/mathlib commit 9407b03373c8cd201df99d6bc5514fc2db44054f
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Group.Defs
import Mathbin.Logic.Equiv.Defs

universe u v w u₀ u₁ v₀ v₁

structure WriterT (ω : Type u) (m : Type u → Type v) (α : Type u) : Type max u v where
  run : m (α × ω)
#align writer_t WriterTₓ

#print Writer /-
@[reducible]
def Writer (ω : Type u) :=
  WriterT ω id
#align writer Writer
-/

attribute [pp_using_anonymous_constructor] WriterT

namespace WriterT

section

variable {ω : Type u}

variable {m : Type u → Type v}

variable [Monad m]

variable {α β : Type u}

open Function

@[ext]
protected theorem ext (x x' : WriterT ω m α) (h : x.run = x'.run) : x = x' := by
  cases x <;> cases x' <;> congr <;> apply h
#align writer_t.ext WriterTₓ.ext

@[inline]
protected def tell (w : ω) : WriterT ω m PUnit :=
  ⟨pure (PUnit.unit, w)⟩
#align writer_t.tell WriterTₓ.tell

@[inline]
protected def listen : WriterT ω m α → WriterT ω m (α × ω)
  | ⟨cmd⟩ => ⟨(fun x : α × ω => ((x.1, x.2), x.2)) <$> cmd⟩
#align writer_t.listen WriterTₓ.listen

@[inline]
protected def pass : WriterT ω m (α × (ω → ω)) → WriterT ω m α
  | ⟨cmd⟩ => ⟨uncurry (uncurry fun x (f : ω → ω) w => (x, f w)) <$> cmd⟩
#align writer_t.pass WriterTₓ.pass

@[inline]
protected def pure [One ω] (a : α) : WriterT ω m α :=
  ⟨pure (a, 1)⟩
#align writer_t.pure WriterTₓ.pure

@[inline]
protected def bind [Mul ω] (x : WriterT ω m α) (f : α → WriterT ω m β) : WriterT ω m β :=
  ⟨do
    let x ← x.run
    let x' ← (f x.1).run
    pure (x'.1, x.2 * x'.2)⟩
#align writer_t.bind WriterTₓ.bind

instance [One ω] [Mul ω] : Monad (WriterT ω m)
    where
  pure α := WriterT.pure
  bind α β := WriterT.bind

instance [Monoid ω] [LawfulMonad m] : LawfulMonad (WriterT ω m)
    where
  id_map := by
    intros
    cases x
    simp [(· <$> ·), WriterT.bind, WriterT.pure]
  pure_bind := by
    intros
    simp [Pure.pure, WriterT.pure, (· >>= ·), WriterT.bind]
    ext <;> rfl
  bind_assoc := by
    intros
    simp [(· >>= ·), WriterT.bind, mul_assoc, functor_norm]

@[inline]
protected def lift [One ω] (a : m α) : WriterT ω m α :=
  ⟨flip Prod.mk 1 <$> a⟩
#align writer_t.lift WriterTₓ.lift

instance (m) [Monad m] [One ω] : HasMonadLift m (WriterT ω m) :=
  ⟨fun α => WriterT.lift⟩

@[inline]
protected def monadMap {m m'} [Monad m] [Monad m'] {α} (f : ∀ {α}, m α → m' α) :
    WriterT ω m α → WriterT ω m' α := fun x => ⟨f x.run⟩
#align writer_t.monad_map WriterTₓ.monadMap

instance (m m') [Monad m] [Monad m'] : MonadFunctor m m' (WriterT ω m) (WriterT ω m') :=
  ⟨@WriterT.monadMap ω m m' _ _⟩

@[inline]
protected def adapt {ω' : Type u} {α : Type u} (f : ω → ω') : WriterT ω m α → WriterT ω' m α :=
  fun x => ⟨Prod.map id f <$> x.run⟩
#align writer_t.adapt WriterTₓ.adapt

instance (ε) [One ω] [Monad m] [MonadExcept ε m] : MonadExcept ε (WriterT ω m)
    where
  throw α := WriterT.lift ∘ throw
  catch α x c := ⟨catch x.run fun e => (c e).run⟩

end

end WriterT

#print MonadWriter /-
/-- An implementation of [MonadReader](
https://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-Reader-Class.html#t:MonadReader).
It does not contain `local` because this function cannot be lifted using `monad_lift`.
Instead, the `monad_reader_adapter` class provides the more general `adapt_reader` function.

Note: This class can be seen as a simplification of the more "principled" definition
```
class monad_reader (ρ : out_param (Type u)) (n : Type u → Type u) :=
(lift {α : Type u} : (∀ {m : Type u → Type u} [monad m], reader_t ρ m α) → n α)
```
-/
class MonadWriter (ω : outParam (Type u)) (m : Type u → Type v) where
  tell (w : ω) : m PUnit
  listen {α} : m α → m (α × ω)
  pass {α : Type u} : m (α × (ω → ω)) → m α
#align monad_writer MonadWriter
-/

export MonadWriter ()

instance {ω : Type u} {m : Type u → Type v} [Monad m] : MonadWriter ω (WriterT ω m)
    where
  tell := WriterT.tell
  listen α := WriterT.listen
  pass α := WriterT.pass

instance {ω ρ : Type u} {m : Type u → Type v} [Monad m] [MonadWriter ω m] :
    MonadWriter ω (ReaderT ρ m)
    where
  tell x := monadLift (tell x : m PUnit)
  listen := fun α ⟨cmd⟩ => ⟨fun r => listen (cmd r)⟩
  pass := fun α ⟨cmd⟩ => ⟨fun r => pass (cmd r)⟩

def swapRight {α β γ} : (α × β) × γ → (α × γ) × β
  | ⟨⟨x, y⟩, z⟩ => ((x, z), y)
#align swap_right swapRight

instance {ω σ : Type u} {m : Type u → Type v} [Monad m] [MonadWriter ω m] :
    MonadWriter ω (StateT σ m)
    where
  tell x := monadLift (tell x : m PUnit)
  listen := fun α ⟨cmd⟩ => ⟨fun r => swapRight <$> listen (cmd r)⟩
  pass := fun α ⟨cmd⟩ => ⟨fun r => pass (swapRight <$> cmd r)⟩

open Function

def ExceptT.passAux {ε α ω} : Except ε (α × (ω → ω)) → Except ε α × (ω → ω)
  | Except.error a => (Except.error a, id)
  | Except.ok (x, y) => (Except.ok x, y)
#align except_t.pass_aux ExceptTₓ.passAux

instance {ω ε : Type u} {m : Type u → Type v} [Monad m] [MonadWriter ω m] :
    MonadWriter ω (ExceptT ε m)
    where
  tell x := monadLift (tell x : m PUnit)
  listen := fun α ⟨cmd⟩ => ⟨(uncurry fun x y => flip Prod.mk y <$> x) <$> listen cmd⟩
  pass := fun α ⟨cmd⟩ => ⟨pass (ExceptT.passAux <$> cmd)⟩

def OptionT.passAux {α ω} : Option (α × (ω → ω)) → Option α × (ω → ω)
  | none => (none, id)
  | some (x, y) => (some x, y)
#align option_t.pass_aux OptionTₓ.passAux

instance {ω : Type u} {m : Type u → Type v} [Monad m] [MonadWriter ω m] : MonadWriter ω (OptionT m)
    where
  tell x := monadLift (tell x : m PUnit)
  listen := fun α ⟨cmd⟩ => ⟨(uncurry fun x y => flip Prod.mk y <$> x) <$> listen cmd⟩
  pass := fun α ⟨cmd⟩ => ⟨pass (OptionT.passAux <$> cmd)⟩

/-- Adapt a monad stack, changing the type of its top-most environment.

This class is comparable to
[Control.Lens.Magnify](https://hackage.haskell.org/package/lens-4.15.4/docs/Control-Lens-Zoom.html#t:Magnify),
but does not use lenses (why would it), and is derived automatically for any transformer
implementing `monad_functor`.

Note: This class can be seen as a simplification of the more "principled" definition
```
class monad_reader_functor (ρ ρ' : out_param (Type u)) (n n' : Type u → Type u) :=
(map {α : Type u} :
  (∀ {m : Type u → Type u} [monad m], reader_t ρ m α → reader_t ρ' m α) → n α → n' α)
```
-/
class MonadWriterAdapter (ω ω' : outParam (Type u)) (m m' : Type u → Type v) where
  adaptWriter {α : Type u} : (ω → ω') → m α → m' α
#align monad_writer_adapter MonadWriterAdapter

export MonadWriterAdapter (adaptWriter)

section

variable {ω ω' : Type u} {m m' : Type u → Type v}

/-- Transitivity.

This instance generates the type-class problem with a metavariable argument (which is why this
is marked as `[nolint dangerous_instance]`).
Currently that is not a problem, as there are almost no instances of `monad_functor` or
`monad_writer_adapter`.

see Note [lower instance priority] -/
@[nolint dangerous_instance]
instance (priority := 100) monadWriterAdapterTrans {n n' : Type u → Type v}
    [MonadWriterAdapter ω ω' m m'] [MonadFunctor m m' n n'] : MonadWriterAdapter ω ω' n n' :=
  ⟨fun α f => monadMap fun α => (adaptWriter f : m α → m' α)⟩
#align monad_writer_adapter_trans monadWriterAdapterTrans

instance [Monad m] : MonadWriterAdapter ω ω' (WriterT ω m) (WriterT ω' m) :=
  ⟨fun α => WriterT.adapt⟩

end

instance (ω : Type u) (m out) [MonadRun out m] : MonadRun (fun α => out (α × ω)) (WriterT ω m) :=
  ⟨fun α x => run <| x.run⟩

/-- reduce the equivalence between two writer monads to the equivalence between
their underlying monad -/
def WriterT.equiv {m₁ : Type u₀ → Type v₀} {m₂ : Type u₁ → Type v₁} {α₁ ω₁ : Type u₀}
    {α₂ ω₂ : Type u₁} (F : m₁ (α₁ × ω₁) ≃ m₂ (α₂ × ω₂)) : WriterT ω₁ m₁ α₁ ≃ WriterT ω₂ m₂ α₂
    where
  toFun := fun ⟨f⟩ => ⟨F f⟩
  invFun := fun ⟨f⟩ => ⟨F.symm f⟩
  left_inv := fun ⟨f⟩ => congr_arg WriterT.mk <| F.left_inv _
  right_inv := fun ⟨f⟩ => congr_arg WriterT.mk <| F.right_inv _
#align writer_t.equiv WriterTₓ.equiv


import tactic.transport
import order.bounded_order
import algebra.lie.basic

-- We verify that `transport` can move a `semiring` across an equivalence.
-- Note that we've never even mentioned the idea of addition or multiplication to `transport`.
def semiring.map {α : Type} [semiring α] {β : Type} (e : α ≃ β) : semiring β :=
begin
  transport using e,
  -- TODO
  { simp *, refl }, -- nat_cast_zero
  { intros, simp *, show _ = e _, simp, refl, }, -- nat_cast_succ
end

-- Indeed, it can equally well move a `semilattice_sup`.
def sup.map {α : Type} [semilattice_sup α] {β : Type} (e : α ≃ β) : semilattice_sup β :=
by transport using e

-- Verify definitional equality of the new structure data.
example {α : Type} [semilattice_sup α] {β : Type} (e : α ≃ β) (x y : β) :
begin
  haveI := sup.map e,
  exact (x ≤ y) = (e.symm x ≤ e.symm y),
end :=
rfl

-- Below we verify in more detail that the transported structure for `semiring`
-- is definitionally what you would hope for.

inductive mynat : Type
| zero : mynat
| succ : mynat → mynat

def mynat_equiv : ℕ ≃ mynat :=
{ to_fun := λ n, nat.rec_on n mynat.zero (λ n, mynat.succ),
  inv_fun := λ n, mynat.rec_on n nat.zero (λ n, nat.succ),
  left_inv := λ n, begin induction n, refl, exact congr_arg nat.succ n_ih, end,
  right_inv := λ n, begin induction n, refl, exact congr_arg mynat.succ n_ih, end }

@[simp] lemma mynat_equiv_apply_zero : mynat_equiv 0 = mynat.zero := rfl
@[simp] lemma mynat_equiv_apply_succ (n : ℕ) :
  mynat_equiv (n + 1) = mynat.succ (mynat_equiv n) := rfl
@[simp] lemma mynat_equiv_symm_apply_zero : mynat_equiv.symm mynat.zero = 0:= rfl
@[simp] lemma mynat_equiv_symm_apply_succ (n : mynat) :
  mynat_equiv.symm (mynat.succ n) = (mynat_equiv.symm n) + 1 := rfl

instance semiring_mynat : semiring mynat :=
semiring.map mynat_equiv

lemma mynat_add_def (a b : mynat) : a + b = mynat_equiv (mynat_equiv.symm a + mynat_equiv.symm b) :=
rfl

-- Verify that we can do computations with the transported structure.
example :
  (mynat.succ (mynat.succ mynat.zero)) + (mynat.succ mynat.zero) =
    (mynat.succ (mynat.succ (mynat.succ mynat.zero))) :=
rfl

lemma mynat_zero_def : (0 : mynat) = mynat_equiv 0 :=
rfl

lemma mynat_one_def : (1 : mynat) = mynat_equiv 1 :=
rfl

lemma mynat_mul_def (a b : mynat) : a * b = mynat_equiv (mynat_equiv.symm a * mynat_equiv.symm b) :=
rfl

example : (3 : mynat) + (7 : mynat) = (10 : mynat) :=
rfl

example : (2 : mynat) * (2 : mynat) = (4 : mynat) :=
rfl

example : (3 : mynat) + (7 : mynat) * (2 : mynat) = (17 : mynat) :=
rfl

example : (2 : ℕ) • (3 : mynat) = (6 : mynat) :=
rfl

example : (3 : mynat) ^ 2 = (9 : mynat) :=
rfl


import category_theory.limits.concrete_category
import topology.category.Profinite.as_limit
import for_mathlib.Profinite.compat_discrete_quotient
import for_mathlib.Cech.split

noncomputable theory

open category_theory

universe u

namespace Profinite

variables (F : arrow Profinite.{u}) (surj : function.surjective F.hom)

open discrete_quotient

/-- A diagram of arrows construction from discrete quotients of F.left. -/
@[simps]
def fintype_arrow_diagram : discrete_quotient F.left ⥤ arrow Fintype.{u} :=
{ obj := λ S,
  { left := Fintype.of S,
    right := Fintype.of $ S.make F.hom surj,
    hom := discrete_quotient.map (S.make_le_comap _ _) },
  map := λ S T f,
  { left := of_le $ le_of_hom f,
    right := of_le $ make_right_mono F.hom surj S T $ le_of_hom f } }.

/-- A diagram of arrows construction from discrete quotients of F.left. -/
@[simps]
def arrow_diagram : discrete_quotient F.left ⥤ arrow Profinite.{u} :=
fintype_arrow_diagram F surj ⋙ Fintype.to_Profinite.map_arrow

/-- The left diagram associated to arrow_diagram. -/
abbreviation left_arrow_diagram : discrete_quotient F.left ⥤ Profinite.{u} :=
arrow_diagram F surj ⋙ arrow.left_func

/-- The right diagram associated to arrow_diagram. -/
abbreviation right_arrow_diagram : discrete_quotient F.left ⥤ Profinite.{u} :=
arrow_diagram F surj ⋙ arrow.right_func

lemma arrow_diagram_surjective (S : discrete_quotient F.left) :
  function.surjective ((arrow_diagram F surj).obj S).hom :=
begin
  rintro ⟨x⟩,
  obtain ⟨x,rfl⟩ := surj x,
  exact ⟨S.proj x,rfl⟩,
end

instance (S : discrete_quotient F.left) : arrow.split ((arrow_diagram F surj).obj S) :=
{ σ := ⟨λ x, classical.some (arrow_diagram_surjective F surj S x),
    continuous_of_discrete_topology⟩,
  is_splitting' := begin
    ext x,
    erw classical.some_spec (arrow_diagram_surjective F surj S x),
    refl,
  end }

/-- A cone which is a limit expressing an arrow as a limit. -/
@[simps]
def arrow_cone : limits.cone (arrow_diagram F surj) :=
{ X := F,
  π :=
  { app := λ S,
    { left := ⟨S.proj, S.proj_continuous⟩,
      right := ⟨(S.make _ surj).proj,
        (S.make _ surj).proj_continuous⟩ } } }

/-- A helper definition used for `arrow_limit_cone`. -/
def arrow_diagram_snd_preserves :
  limits.preserves_limit (arrow_diagram F surj ⋙ comma.snd _ _) (𝟭 _) :=
begin
  have h := limits.id_preserves_limits.preserves_limits_of_shape,
  have hh := h.preserves_limit,
  exact hh,
end

/-- the limit cone assocciated to arrow_diagram -/
@[simps]
def arrow_limit_cone : limits.limit_cone (arrow_diagram F surj) :=
{ cone := @comma.cone_of_preserves _ _ _ _ _ _ _ _ _ _ _
  (arrow_diagram_snd_preserves _ _) (limit_cone _) _ (limit_cone_is_limit _),
  is_limit := @comma.cone_of_preserves_is_limit _ _ _ _ _ _ _ _ _ _ _
    (arrow_diagram_snd_preserves _ _) _ (limit_cone_is_limit _) _ _ }

/-- lifing arrow_cone gives an isomorphism on the left -/
instance arrow_is_iso_lift_left : is_iso ((arrow_limit_cone F surj).is_limit.lift
  (arrow_cone F surj)).left := Profinite.is_iso_as_limit_cone_lift _

/-- lifing arrow_cone gives an isomorphism on the right -/
instance arrow_is_iso_lift_right : is_iso ((arrow_limit_cone F surj).is_limit.lift
  (arrow_cone F surj)).right := is_iso_of_bijective _
begin
  split,
  { intros x y h,
    apply discrete_quotient.eq_of_proj_eq,
    intros S,
    apply_fun subtype.val at h,
    let T : discrete_quotient F.left := S.comap F.hom.continuous,
    let R : discrete_quotient F.right := T.make F.hom surj,
    have hR : R ≤ S,
    { apply discrete_quotient.make_right_le,
      tauto },
    apply_fun (λ e, e T) at h,
    have := discrete_quotient.of_le_proj_apply hR,
    rw [← this, ← this],
    congr' 1 },
  { intros x,
    cases x with x hx,
    dsimp at x hx,
    let Us : Π (I : discrete_quotient F.right), I := λ I,
      of_le (make_right_le _ _ _ _ (by tauto)) (x $ I.comap F.hom.continuous),
    rcases discrete_quotient.exists_of_compat Us _ with ⟨y,hy⟩,
    { refine ⟨y,_⟩,
      ext I : 2,
      dsimp at *,
      let J : discrete_quotient F.right := (I.make F.hom surj),
      let II : discrete_quotient F.left := J.comap F.hom.continuous ⊓ I,
      have h1 : II ≤ I := inf_le_right,
      have h2 : II ≤ J.comap F.hom.continuous := inf_le_left,
      rw ← hx (hom_of_le h1),
      dsimp [comma.cone_of_preserves_is_limit,
        limit_cone_is_limit, CompHaus.limit_cone_is_limit,
        Top.limit_cone_is_limit],
      rw hy,
      dsimp [Us],
      rw ← hx (hom_of_le h2),
      rw ← of_le_comp_apply },
    { intros A B h,
      dsimp [Us],
      have := comap_mono F.hom.continuous h,
      rw ← hx (hom_of_le this),
      rw [← of_le_comp_apply, ← of_le_comp_apply] } },
end

@[simps]
def left_arrow_cone : limits.cone (left_arrow_diagram F surj) :=
functor.map_cone _ (arrow_cone F surj)

@[simps]
def right_arrow_cone : limits.cone (right_arrow_diagram F surj) :=
functor.map_cone _ (arrow_cone F surj)

instance left_arrow_cone_lift_is_iso : is_iso $
  (limit_cone_is_limit $ left_arrow_diagram F surj).lift (left_arrow_cone F surj) :=
Profinite.arrow_is_iso_lift_left _ _

instance right_arrow_cone_lift_is_iso : is_iso $
  (limit_cone_is_limit $ right_arrow_diagram F surj).lift (right_arrow_cone F surj) :=
Profinite.arrow_is_iso_lift_right _ _

@[simps]
def left_arrow_cone_iso : left_arrow_cone F surj ≅
  (limit_cone $ left_arrow_diagram F surj) :=
limits.cones.ext (as_iso $ (limit_cone_is_limit $ left_arrow_diagram F surj).lift _)
  (λ _ , rfl)

@[simps]
def right_arrow_cone_iso : right_arrow_cone F surj ≅
  (limit_cone $ right_arrow_diagram F surj) :=
limits.cones.ext (as_iso $ (limit_cone_is_limit $ right_arrow_diagram F surj).lift _)
  (λ _ , rfl)

/-- The isomorphism of cones showing that arrow_cone is a limit cone. -/
@[simps]
def arrow_cone_iso : arrow_cone F surj ≅ (arrow_limit_cone F surj).cone :=
begin
  haveI := arrow.is_iso_of_iso_left_of_is_iso_right
    ((arrow_limit_cone F surj).is_limit.lift (arrow_cone F surj)),
  exact limits.cones.ext
    (as_iso $ (arrow_limit_cone F surj).is_limit.lift (arrow_cone F surj))
    (λ _, rfl)
end

/-- arrow_cone is a limit cone. -/
@[simps]
def is_limit_arrow_cone : limits.is_limit (arrow_cone F surj) :=
limits.is_limit.of_iso_limit (arrow_limit_cone F surj).is_limit
  (arrow_cone_iso F surj).symm

@[simps]
def is_limit_left_arrow_cone : limits.is_limit (left_arrow_cone F surj) :=
limits.is_limit.of_iso_limit (limit_cone_is_limit $ left_arrow_diagram F surj)
  (left_arrow_cone_iso _ _).symm

@[simps]
def is_limit_right_arrow_cone : limits.is_limit (right_arrow_cone F surj) :=
limits.is_limit.of_iso_limit (limit_cone_is_limit $ right_arrow_diagram F surj)
  (right_arrow_cone_iso _ _).symm

open opposite

open_locale simplicial

@[simps]
def Cech_cone_diagram (n : ℕ) : discrete_quotient F.left ⥤ Profinite.{u} :=
arrow_diagram F surj ⋙ simplicial_object.cech_nerve ⋙
  (evaluation _ _).obj (op [n])

def Cech_cone_diagram_proj (n : ℕ) (S : discrete_quotient F.left) (i : fin (n+1)) :
  (Cech_cone_diagram F surj n).obj S ⟶ Profinite.of S :=
limits.wide_pullback.π _ i

def Cech_cone_diagram_inclusion (n : ℕ) (S : discrete_quotient F.left) :
  (Cech_cone_diagram F surj n).obj S → fin (n+1) → S :=
λ a i, Cech_cone_diagram_proj F surj n S i a

set_option pp.universes true
lemma Cech_cone_diagram_inclusion_injective (n : ℕ) (S : discrete_quotient F.left) :
  function.injective (Cech_cone_diagram_inclusion F surj n S) :=
begin
  intros a b h,
  dsimp [Cech_cone_diagram] at a b,
  haveI : limits.preserves_limits_of_size.{0 0} (forget Profinite.{u}) :=
    limits.preserves_limits_of_size_shrink.{0 u 0 u u u u+1 u+1} (forget.{u+1 u u} Profinite.{u}),
  apply category_theory.limits.concrete.wide_pullback_ext',
  rintros j,
  apply_fun (λ e, e j) at h,
  exact h,
end

instance Cech_cone_diagram_fintype (n : ℕ) (S : discrete_quotient F.left) :
  fintype ((Cech_cone_diagram F surj n).obj S) :=
fintype.of_injective (Cech_cone_diagram_inclusion F surj n S)
  (Cech_cone_diagram_inclusion_injective F surj n S)

@[simps]
def Cech_cone (n : ℕ) : limits.cone (Cech_cone_diagram F surj n) :=
functor.map_cone _ (arrow_cone F surj)

@[simps]
def swap_cone_right (n : ℕ) (S : limits.cone (Cech_cone_diagram F surj n)) :
  limits.cone (right_arrow_diagram F surj) :=
{ X := S.X,
  π := { app := λ T, S.π.app T ≫ limits.wide_pullback.base _,
  naturality' := begin
    intros X Y f,
    dsimp,
    simp [← S.w f],
  end } }

@[simps]
def swap_cone_left (n : ℕ) (i : (fin (n+1)))
  (S : limits.cone (Cech_cone_diagram F surj n)) :
  limits.cone (left_arrow_diagram F surj) :=
{ X := S.X,
  π :=
  { app := λ T, S.π.app T ≫ limits.wide_pullback.π _ i,
    naturality' := begin
      intros X Y f,
      dsimp,
      simp [← S.w f],
    end } }

@[simps]
def Cech_cone_is_limit (n : ℕ) : limits.is_limit (Cech_cone F surj n) :=
{ lift := λ S, limits.wide_pullback.lift
    ((is_limit_right_arrow_cone F surj).lift $ swap_cone_right _ _ _ _)
    (λ i, (is_limit_left_arrow_cone F surj).lift $ swap_cone_left _ _ _ i _)
    begin
      intros i,
      apply (is_limit_right_arrow_cone F surj).hom_ext,
      intros T,
      simp,
      have : (arrow_cone F surj).X.hom ≫ (right_arrow_cone F surj).π.app T =
        (left_arrow_cone F surj).π.app T ≫
        (whisker_left (arrow_diagram F surj) arrow.left_to_right).app T, by refl,
      erw [this, ← category.assoc,
        (is_limit_left_arrow_cone F surj).fac (swap_cone_left F surj n i S) T],
      simp,
    end,
  fac' := begin
    intros S T,
    apply limits.wide_pullback.hom_ext,
    { intro i,
      dsimp,
      simp,
      have := (is_limit_left_arrow_cone F surj).fac,
      erw this,
      refl },
    { dsimp,
      simp,
      erw (is_limit_right_arrow_cone F surj).fac,
      refl }
  end,
  uniq' := begin
    intros S f h,
    apply limits.wide_pullback.hom_ext,
    { dsimp, simp,
      intros i,
      apply (is_limit_left_arrow_cone F surj).hom_ext,
      intros T,
      simp,
      erw [← h T, category.assoc, limits.wide_pullback.lift_π],
      refl },
    { dsimp, simp,
      apply (is_limit_right_arrow_cone F surj).hom_ext,
      intros T,
      simp,
      erw [← h T, category.assoc, limits.wide_pullback.lift_base],
      refl }
  end }.

end Profinite


import morphisms.surjective

/-!
# Radicial morphisms

A morphism of schemes `f : X ⟶ Y` is radicial if the underlying map is injective,
and it induces radicial (purely inseparable) extensions on residue fields.

-/

noncomputable theory

open category_theory category_theory.limits opposite topological_space

universe u

open_locale algebraic_geometry

namespace algebraic_geometry

variables {X Y Z : Scheme.{u}} (f : X ⟶ Y) (g : Y ⟶ Z)

/--
A field extension is radicial if it is an epi in the category of fields.

TODO: Replace this with purely inseparable extensions once we have those.
-/
def _root_.ring_hom.is_radicial {K L : Type u} [field K] [field L] (f : K →+* L) : Prop :=
∀ (L' : Type u) [field L'],
  by exactI function.injective (flip ring_hom.comp f : (L →+* L') → (K →+* L'))

/--
A morphism of schemes `f : X ⟶ Y` is radicial if the underlying map is injective,
and it induces radicial (purely inseparable) extensions on residue fields.

We show that this is equivalent to universally injective and equivalent to the diagonal map being
surjective below.
-/
@[mk_iff]
class radicial (f : X ⟶ Y) : Prop :=
(base_injective [] : function.injective f.1.base)
(residue_radicial [] : ∀ x, ring_hom.is_radicial (f.map_residue_field x))

section tfae

lemma radicial.epi_of_field [radicial f] {K : Type*} [field K] :
  function.injective (λ g : Scheme.Spec.obj (op $ CommRing.of K) ⟶ X, g ≫ f) :=
begin
  intros g₁ g₂ e,
  dsimp only at e,
  apply (Spec_to_equiv_of_field K _).injective,
  refine Spec_to_equiv_of_field_eq_iff.mpr ⟨_, _⟩,
  { apply radicial.base_injective f,
    simp only [Spec_to_equiv_of_field_apply_fst, ← Scheme.comp_val_base_apply, e] },
  { simp only [Spec_to_equiv_of_field_apply_snd],
    apply radicial.residue_radicial f,
    convert_to f.map_residue_field _ ≫ _ = f.map_residue_field _ ≫ _,
    rw [← cancel_epi (Y.to_residue_field _)], swap, { apply_instance },
    simp only [Top.presheaf.stalk_congr_hom, stalk_closed_point_to,
      Scheme.to_residue_field_of_eq_assoc, Scheme.to_residue_field_map_residue_field_assoc,
      Scheme.to_desc_residue_field,
      ← PresheafedSpace.stalk_map.stalk_specializes_stalk_map_assoc],
    slice_lhs 1 2 { rw [← PresheafedSpace.stalk_map.comp] },
    erw PresheafedSpace.stalk_map.congr_hom' _ _
      (show g₁.1 ≫ f.1 = g₂.1 ≫ f.1, by injection e),
    slice_rhs 2 3 { erw ← PresheafedSpace.stalk_map.comp },
    simp_rw category.assoc, refl }
end

lemma _root_.field.exists_common_extension {K L M : Type u} [field K] [field L] [field M]
  (f : K →+* L) (g : K →+* M) :
  ∃ (N : Type u) [field N], by exactI ∃ (h : L →+* N) (k : M →+* N), h.comp f = k.comp g :=
begin
  letI := f.to_algebra,
  letI := g.to_algebra,
  obtain ⟨m, hm⟩ := ideal.exists_maximal (tensor_product K L M),
  rw ideal.quotient.maximal_ideal_iff_is_field_quotient at hm,
  refine ⟨tensor_product K L M ⧸ m, hm.to_field,
    m^.quotient.mk^.comp algebra.tensor_product.include_left.to_ring_hom,
    m^.quotient.mk^.comp algebra.tensor_product.include_right.to_ring_hom, _⟩,
  rw [ring_hom.comp_assoc, ring_hom.comp_assoc],
  congr' 1,
  exact algebra.tensor_product.include_right.comp_algebra_map.symm,
end

lemma universally_injective_of_epi_of_field
  (H : ∀ {K : Type u} [field K],
    by exactI function.injective (λ (g : Scheme.Spec.obj (op (CommRing.of K)) ⟶ X), g ≫ f)) :
  morphism_property.universally (λ X Y (f : Scheme.hom X Y), function.injective f.1.base) f :=
begin
  intros X' Y' i₁ i₂ f' h x₁ x₂ e,
  obtain ⟨K, hK, g₁, g₂, e'⟩ := field.exists_common_extension
    (Y'.residue_field_of_eq e ≫ f'.map_residue_field x₁ : _) (f'.map_residue_field x₂),
  resetI,
  change X'.residue_field x₁ ⟶ CommRing.of K at g₁,
  change X'.residue_field x₂ ⟶ CommRing.of K at g₂,
  replace e' : (Y'.residue_field_of_eq e ≫ f'.map_residue_field x₁) ≫ g₁ =
    f'.map_residue_field x₂ ≫ g₂ := by convert e',
  suffices : (Spec_to_equiv_of_field K X').symm ⟨x₁, g₁⟩ =
    (Spec_to_equiv_of_field K X').symm ⟨x₂, g₂⟩,
  { injection (Spec_to_equiv_of_field K X').symm.injective this },
  have : (Spec_to_equiv_of_field K X').symm ⟨x₁, g₁⟩ ≫ f' =
    (Spec_to_equiv_of_field K X').symm ⟨x₂, g₂⟩ ≫ f',
  { dsimp only [Spec_to_equiv_of_field_symm_apply, is_pullback.cone_fst],
    simp_rw [category.assoc, ← Scheme.hom.map_residue_field_from_Spec_residue_field f',
      ← functor.map_comp_assoc, ← op_comp, ← e', op_comp, functor.map_comp_assoc,
      Scheme.residue_field_of_eq_from_Spec] },
  apply pullback_cone.is_limit.hom_ext h.is_limit,
  { exact this },
  { apply H, simp only [category.assoc, is_pullback.cone_snd, ← h.w, reassoc_of this], }
end

lemma _root_.category_theory.is_iso_of_comp_mono {C} [category C] {X Y Z : C}
  (f : X ⟶ Y) (g : Y ⟶ Z) [is_iso (f ≫ g)] [mono g] : is_iso f :=
begin
  haveI : is_split_epi g := ⟨⟨⟨inv (f ≫ g) ≫ f, by simp⟩⟩⟩,
  haveI : is_iso g := is_iso_of_mono_of_is_split_epi g,
  rw (show f = (f ≫ g) ≫ inv g, by simp),
  apply_instance
end

lemma Spec_to_eq_of_injective {K : Type*} [field K] {X : Scheme}
  {f₁ f₂ : Scheme.Spec.obj (op $ CommRing.of K) ⟶ X}
  {g} (hf₁ : f₁ ≫ g = 𝟙 _) (hf₂ : f₂ ≫ g = 𝟙 _) (hg : function.injective g.1.base) : f₁ = f₂ :=
begin
  haveI : subsingleton X.carrier := @@function.injective.subsingleton _ hg
    (show subsingleton (prime_spectrum K), by apply_instance),
  apply (Spec_to_equiv_of_field _ _).injective,
  refine Spec_to_equiv_of_field_eq_iff.mpr ⟨subsingleton.elim _ _, _⟩,
  simp only [Spec_to_equiv_of_field_apply_snd],
  haveI : is_iso (g.map_residue_field (f₁.1.base (local_ring.closed_point K))),
  { refine category_theory.is_iso_of_comp_mono _ _,
    swap, { exact f₁.map_residue_field (local_ring.closed_point K) },
    { rw [← Scheme.hom.map_residue_field_comp],
      let f := f₁ ≫ g, change is_iso (f.map_residue_field _), rw (show f = 𝟙 _, from hf₁),
      apply_instance },
    { rw concrete_category.mono_iff_injective_of_preserves_pullback,
      exact ring_hom.injective _ } },
  rw ← cancel_epi (g.map_residue_field (f₁.1.base (local_ring.closed_point K))),
  rw ← cancel_epi (Scheme.to_residue_field _ _), swap, { apply_instance },
  simp only [Top.presheaf.stalk_congr_hom, stalk_closed_point_to,
    Scheme.to_residue_field_of_eq_assoc, Scheme.to_residue_field_map_residue_field_assoc,
    Scheme.to_desc_residue_field, ← PresheafedSpace.stalk_map.stalk_specializes_stalk_map_assoc],
  slice_lhs 1 2 { erw [← PresheafedSpace.stalk_map.comp] },
  slice_rhs 2 3 { erw [← PresheafedSpace.stalk_map.comp] },
  erw PresheafedSpace.stalk_map.congr_hom' _ _
    (show f₁.1 ≫ g.1 = f₂.1 ≫ g.1, by injection hf₁.trans hf₂.symm),
  simp only [category.assoc],
  refl,
end

def morphism_property.injective : morphism_property Scheme :=
λ X Y f, function.injective f.1.base

lemma radicial_tfae :
  tfae [radicial f,
    ∀ {K : Type*} [field K], by exactI function.injective
      (λ g : Scheme.Spec.obj (op $ CommRing.of K) ⟶ X, g ≫ f),
    morphism_property.universally morphism_property.injective f,
    surjective (pullback.diagonal f)] :=
begin
  tfae_have : 1 → 2,
  { introsI _ K _, exact radicial.epi_of_field f },
  tfae_have : 2 → 3,
  { exact universally_injective_of_epi_of_field f },
  tfae_have : 3 → 2,
  { introsI H K hK g₁ g₂ e,
    let f' := g₁ ≫ f,
    rw [← pullback.lift_snd (𝟙 _) g₁ (category.id_comp f'),
      ← pullback.lift_snd (𝟙 _) g₂ ((category.id_comp f').trans e)],
    congr' 1,
    apply Spec_to_eq_of_injective (pullback.lift_fst _ _ _) (pullback.lift_fst _ _ _)
      (H _ _ _ (is_pullback.of_has_pullback f' f)) },
  tfae_have : 3 → 1,
  { intro H,
    refine ⟨(morphism_property.universally_le _ _ _ f H : _), _⟩,
    introsI x K _ f₁ f₂ e,
    change X.residue_field x ⟶ CommRing.of K at f₁,
    change X.residue_field x ⟶ CommRing.of K at f₂,
    replace e : f.map_residue_field x ≫ f₁ = f.map_residue_field x ≫ f₂ := by convert e,
    suffices : (Spec_to_equiv_of_field K X).symm ⟨x, f₁⟩ =
      (Spec_to_equiv_of_field K X).symm ⟨x, f₂⟩,
    { injection (Spec_to_equiv_of_field K X).symm.injective this, exact eq_of_heq ‹_› },
    apply tfae_3_to_2 H,
    dsimp only [Spec_to_equiv_of_field_symm_apply],
    simp only [category.assoc, ← Scheme.hom.map_residue_field_from_Spec_residue_field,
      ← functor.map_comp_assoc, ← op_comp, e] },
  tfae_have : 3 → 4,
  { rw surjective_iff,
    intros H x,
    refine ⟨(pullback.fst : pullback f f ⟶ _).1.base x,
      H _ _ _ (is_pullback.of_has_pullback f f) _⟩,
    simp only [← Scheme.comp_val_base_apply, category.assoc,
      pullback.diagonal_fst, category.comp_id] },
  tfae_have : 4 → 3,
  { suffices : morphism_property.diagonal @surjective ≤ morphism_property.injective.universally,
    { apply this },
    rw ← (surjective_stable_under_base_change.diagonal surjective_respects_iso).universally_eq,
    refine morphism_property.universally_mono _,
    intros X Y f h x y e,
    let T : pullback.triplet f f := ⟨x, y, _, e, rfl⟩,
    obtain ⟨z, hz, hz'⟩ := T.exists_preimage,
    obtain ⟨z', rfl⟩ := h.1 z,
    simp only [← Scheme.comp_val_base_apply,
      pullback.diagonal_fst, pullback.diagonal_snd] at hz hz',
    exact hz.symm.trans hz' },
  tfae_finish
end

lemma radicial_eq_univerally_injective :
  @radicial = morphism_property.universally morphism_property.injective :=
by { ext X Y f, exact (radicial_tfae f).out 0 2 }

lemma radicial_eq_diagonal_surjective :
  @radicial = morphism_property.diagonal @surjective :=
by { ext X Y f, exact (radicial_tfae f).out 0 3 }

end tfae

lemma radicial_respects_iso :
  morphism_property.respects_iso @radicial :=
radicial_eq_univerally_injective.symm ▸
  morphism_property.injective.universally_respects_iso

lemma radicial_stable_under_composition :
  morphism_property.stable_under_composition @radicial :=
radicial_eq_diagonal_surjective.symm ▸
  surjective_stable_under_composition.diagonal
    surjective_respects_iso
    surjective_stable_under_base_change

lemma radicial_stable_under_base_change :
  morphism_property.stable_under_base_change @radicial :=
radicial_eq_univerally_injective.symm ▸
  morphism_property.universally_stable_under_base_change _

lemma radicial_is_local_at_target :
  property_is_local_at_target @radicial :=
radicial_eq_diagonal_surjective.symm ▸
  surjective_is_local_at_target.diagonal

instance radicial_of_mono [mono f] : radicial f :=
by { rw radicial_eq_diagonal_surjective, show surjective _, apply_instance }

end algebraic_geometry


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/

import category_theory.category
import category_theory.abelian.basic
import abelian_SEMF

open category_theory
open category_theory.limits

universes v u

namespace category_theory.abelian

section
variables {C : Type u} [𝒞 : category.{v} C] [abelian.{v} C]
include 𝒞

def exact {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) : Prop :=
f ≫ g = 0 ∧ kernel.ι g ≫ cokernel.π f = 0

def exact_fork {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) (e : exact f g) : kernel_fork g :=
kernel_fork.of_ι (kernel.ι (cokernel.π f)) $
  zero_of_epi_comp (abelian.factor_thru_image f) $ by rw [←category.assoc, image.fac f, e.1]

def exact_ker {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) (e : exact f g) : is_limit $ exact_fork f g e :=
fork.is_limit.mk _
  (λ s, kernel.lift _ (fork.ι s)
  begin
    let t : s.X ⟶ kernel g := kernel.lift g (fork.ι s) (kernel_fork.condition _),
    have : t ≫ kernel.ι g = fork.ι s := by erw limit.lift_π; refl,
    rw [←this, category.assoc, e.2, has_zero_morphisms.comp_zero]
  end)
  (λ s, by erw limit.lift_π; refl)
  (λ s m h, by ext; erw [h walking_parallel_pair.zero, limit.lift_π]; refl)

def exact_cofork {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) (e : exact f g) : cokernel_cofork f :=
cokernel_cofork.of_π (cokernel.π (kernel.ι g)) $
  zero_of_comp_mono (abelian.factor_thru_coimage g) $ by rw [category.assoc, coimage.fac g, e.1]

def exact_coker {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) (e : exact f g) :
  is_colimit $ exact_cofork f g e :=
cofork.is_colimit.mk _
  (λ s, cokernel.desc _ (cofork.π s)
  begin
    let t : cokernel f ⟶ s.X := cokernel.desc f (cofork.π s) (cokernel_cofork.condition _),
    have : cokernel.π f ≫ t = cofork.π s := by erw colimit.ι_desc; refl,
    rw [←this, ←category.assoc, e.2, has_zero_morphisms.zero_comp]
  end)
  (λ s, by erw colimit.ι_desc; refl)
  (λ s m h, by ext; erw [h walking_parallel_pair.one, colimit.ι_desc]; refl)

lemma exact_zero_of_mono (P : C) {Q R : C} (f : Q ⟶ R) [mono f] : exact (0 : P ⟶ Q) f :=
⟨has_zero_morphisms.zero_comp _ _,
begin
  rw (preadditive.cancel_zero_iff_mono f).1 (by apply_instance) _ (kernel.ι f) (kernel.condition _),
  exact has_zero_morphisms.zero_comp _ _
end⟩

lemma mono_of_exact_zero (P : C) {Q R : C} (f : Q ⟶ R) (h : exact (0 : P ⟶ Q) f) : mono f :=
(preadditive.cancel_zero_iff_mono f).2 $ λ Z g h₀,
begin
  obtain ⟨k, hk⟩ := kernel_fork.is_limit.lift' (exact_ker _ _ h) g h₀,
  have := (preadditive.cancel_zero_iff_epi (factor_thru_image (0 : P ⟶ Q))).1
    (by apply_instance) _ _ (image.fac (0 : P ⟶ Q)),
  change k ≫ kernel.ι (cokernel.π (0 : P ⟶ Q)) = g at hk,
  rw ←hk,
  conv_lhs { congr, skip, rw this },
  exact has_zero_morphisms.comp_zero _ _
end

lemma exact_zero_of_epi {P Q : C} (f : P ⟶ Q) (R : C) [epi f] : exact f (0 : Q ⟶ R) :=
⟨has_zero_morphisms.comp_zero _ _,
begin
  rw (preadditive.cancel_zero_iff_epi f).1 (by apply_instance) _ (cokernel.π f) (cokernel.condition _),
  exact has_zero_morphisms.comp_zero _ _
end⟩

lemma exact_zero_of_epi' {P Q : C} (f : P ⟶ Q) [epi f] : exact f (0 : Q ⟶ Q) :=
exact_zero_of_epi _ _

lemma epi_of_exact_zero {P Q : C} (f : P ⟶ Q) (R : C) (h : exact f (0 : Q ⟶ R)) : epi f :=
(preadditive.cancel_zero_iff_epi f).2 $ λ Z g h₀,
begin
  obtain ⟨k, hk⟩ := cokernel.desc' f g h₀,
  haveI : is_iso (kernel.ι (0 : Q ⟶ R)) := kernel.ι_of_zero _ _,
  apply (preadditive.cancel_zero_iff_epi (kernel.ι (0 : Q ⟶ R))).1 (by apply_instance) _ _,
  rw [←hk, ←category.assoc, h.2],
  exact has_zero_morphisms.zero_comp _ _
end

lemma kernel_exact {P Q : C} (f : P ⟶ Q) : exact (kernel.ι f) f :=
⟨kernel.condition _, cokernel.condition _⟩

lemma cokernel_exact {P Q : C} (f : P ⟶ Q) : exact f (cokernel.π f) :=
⟨cokernel.condition _, kernel.condition _⟩

def kernel_of_mono_exact {P Q R : C} (f : P ⟶ Q) [mono f] (g : Q ⟶ R) (h : exact f g) :
  is_limit $ kernel_fork.of_ι f h.1 :=
begin
  let I := kernel (cokernel.π f),
  let i : kernel g ≅ I := functor.map_iso (cones.forget _)
    (is_limit.unique_up_to_iso (limit.is_limit _) (exact_ker f g h)),
  have h₀ : i.hom ≫ kernel.ι (cokernel.π f) = kernel.ι g :=
    cone_morphism.w (is_limit.unique_up_to_iso (limit.is_limit _) (exact_ker f g h)).hom
      walking_parallel_pair.zero,
  haveI : mono (factor_thru_image f) := mono_of_mono_fac (image.fac f),
  haveI : is_iso (factor_thru_image f) := mono_epi_iso _,
  let j : P ≅ I := as_iso (factor_thru_image f),
  apply kernel.transport _ _ (j ≪≫ i.symm),
  erw [category.assoc, ←(iso.eq_inv_comp i).2 h₀, image.fac],
end

def cokernel_of_epi_exact {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) [epi g] (h : exact f g) :
  is_colimit $ cokernel_cofork.of_π g h.1 :=
begin
  let I := cokernel (kernel.ι g),
  let i : cokernel f ≅ I := functor.map_iso (cocones.forget _)
    (is_colimit.unique_up_to_iso (colimit.is_colimit _) (exact_coker f g h)),
  have h₀ : cokernel.π f ≫ i.hom = cokernel.π (kernel.ι g) :=
    cocone_morphism.w (is_colimit.unique_up_to_iso (colimit.is_colimit _) (exact_coker f g h)).hom
      walking_parallel_pair.one,
  haveI : epi (factor_thru_coimage g) := epi_of_epi_fac (coimage.fac g),
  haveI : is_iso (factor_thru_coimage g) := mono_epi_iso _,
  let j : I ≅ R := as_iso (factor_thru_coimage g),
  apply cokernel.transport _ _ (i ≪≫ j),
  erw [←category.assoc, h₀, coimage.fac],
end

lemma image_exact {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) (h : exact f g) :
  exact (kernel.ι (cokernel.π f)) g :=
⟨begin
  apply (preadditive.cancel_zero_iff_epi (factor_thru_image f)).1 (by apply_instance),
  rw ←category.assoc,
  rw image.fac f,
  exact h.1,
end,
begin
  obtain ⟨l, hl⟩ := cokernel.desc' f (cokernel.π (kernel.ι (cokernel.π f)))
    begin conv_lhs { congr, rw ←image.fac f, }, rw category.assoc, rw cokernel.condition,
      rw has_zero_morphisms.comp_zero, end,
  rw ←hl,
  rw ←category.assoc,
  rw h.2,
  rw has_zero_morphisms.zero_comp,
end⟩

lemma exact_image {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) (h : exact f g) :
  exact f (factor_thru_image g) :=
⟨begin
  apply (preadditive.cancel_zero_iff_mono (kernel.ι (cokernel.π g))).1 (by apply_instance),
  rw category.assoc,
  rw image.fac g,
  exact h.1,
end,
begin
  obtain ⟨l, hl⟩ := kernel.lift' g (kernel.ι (factor_thru_image g))
    begin conv_lhs { congr, skip, rw ←image.fac g, }, rw ←category.assoc, rw kernel.condition,
      rw has_zero_morphisms.zero_comp, end,
  rw ←hl,
  rw category.assoc,
  rw h.2,
  rw has_zero_morphisms.comp_zero,
end⟩

lemma exact_iso {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) {Q' : C} (i : Q ≅ Q') (h : exact f g) :
  exact (f ≫ i.hom) (i.inv ≫ g) :=
⟨by simpa using h.1,
begin
  obtain ⟨l, hl⟩ := kernel.lift' g (kernel.ι (i.inv ≫ g) ≫ i.inv)
    (by rw [category.assoc, kernel.condition]),
  obtain ⟨m, hm⟩ := cokernel.desc' f (i.hom ≫ cokernel.π (f ≫ i.hom))
    (by rw [←category.assoc, cokernel.condition]),
  calc kernel.ι (i.inv ≫ g) ≫ cokernel.π (f ≫ i.hom)
        = kernel.ι (i.inv ≫ g) ≫ (i.inv ≫ i.hom) ≫ cokernel.π (f ≫ i.hom) : by rw [iso.inv_hom_id, category.id_comp]
    ... = (kernel.ι (i.inv ≫ g) ≫ i.inv) ≫ i.hom ≫ cokernel.π (f ≫ i.hom) : by simp only [category.assoc]
    ... = (l ≫ kernel.ι g) ≫ cokernel.π f ≫ m : by rw [←hl, ←hm]
    ... = l ≫ (kernel.ι g ≫ cokernel.π f) ≫ m : by simp only [category.assoc]
    ... = l ≫ 0 ≫ m : by rw h.2
    ... = 0 : by rw [has_zero_morphisms.zero_comp, has_zero_morphisms.comp_zero]
end⟩

lemma exact_iso_right {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) {R' : C} (i : R ≅ R') (h : exact f g) :
  exact f (g ≫ i.hom) :=
⟨by rw [←category.assoc, h.1, has_zero_morphisms.zero_comp],
begin
  obtain ⟨l, hl⟩ := kernel.lift' g (kernel.ι (g ≫ i.hom))
    (calc kernel.ι (g ≫ i.hom) ≫ g
          = kernel.ι (g ≫ i.hom) ≫ g ≫ i.hom ≫ i.inv : by simp
      ... = (kernel.ι (g ≫ i.hom) ≫ g ≫ i.hom) ≫ i.inv : by simp only [category.assoc]
      ... = 0 ≫ i.inv : by rw kernel.condition
      ... = 0 : by rw has_zero_morphisms.zero_comp),

  rw [←hl, category.assoc, h.2, has_zero_morphisms.comp_zero],
end⟩

lemma exact_iso_left {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) {P' : C} (i : P' ≅ P) (h : exact f g) :
  exact (i.hom ≫ f) g :=
⟨by rw [category.assoc, h.1, has_zero_morphisms.comp_zero],
begin
  obtain ⟨l, hl⟩ := cokernel.desc' f (cokernel.π (i.hom ≫ f))
    (calc f ≫ cokernel.π (i.hom ≫ f)
          = (i.inv ≫ i.hom) ≫ f ≫ cokernel.π (i.hom ≫ f) : by simp
      ... = i.inv ≫ (i.hom ≫ f) ≫ cokernel.π (i.hom ≫ f) : by simp only [category.assoc]
      ... = i.inv ≫ 0 : by rw cokernel.condition
      ... = 0 : by rw has_zero_morphisms.comp_zero),

  rw [←hl, ←category.assoc, h.2, has_zero_morphisms.zero_comp],
end⟩

lemma epi_mono_exact_left {P Q R S : C} (f : P ⟶ Q) (g : Q ⟶ R) (h : R ⟶ S)
  (e : exact (f ≫ g) h) [epi f] [mono g] : exact g h :=
begin
  let upper : strong_epi_mono_factorisation (f ≫ g) :=
  { I := _, e := f, m := g, fac' := rfl,
    m_mono := by apply_instance, e_strong_epi := strong_epi_of_epi _ },
  let lower := image_SEMF (f ≫ g),
  let s : Q ≅ kernel (cokernel.π (f ≫ g)) := is_image.iso_ext upper.to_mono_is_image
    lower.to_mono_is_image,
  have : s.hom ≫ kernel.ι (cokernel.π (f ≫ g)) = g,
  { erw is_image.lift_fac },
  rw ←this,
  apply exact_iso_left _ _ s,
  exact image_exact _ _ e,
end

lemma epi_mono_exact_right {P Q R S : C} (f : P ⟶ Q) (g : Q ⟶ R) (h : R ⟶ S)
  (e : exact f (g ≫ h)) [epi g] [mono h] : exact f g :=
begin
  let upper : strong_epi_mono_factorisation (g ≫ h) :=
  { I := _, e := g, m := h, fac' := rfl,
  m_mono := by apply_instance, e_strong_epi := strong_epi_of_epi _ },
  let lower := image_SEMF (g ≫ h),
  let s : kernel (cokernel.π (g ≫ h)) ≅ R := is_image.iso_ext lower.to_mono_is_image
    upper.to_mono_is_image,
  have : factor_thru_image (g ≫ h) ≫ s.hom = g,
  { erw is_image.fac_lift lower.to_mono_is_image upper.to_mono_factorisation },
  rw ←this,
  apply exact_iso_right _ _ s,
  exact exact_image _ _ e,
end

lemma exact_left_epi {P Q R S : C} (f : P ⟶ Q) (g : Q ⟶ R) (h : R ⟶ S) (e : exact g h) [epi f] :
  exact (f ≫ g) h :=
⟨by rw [category.assoc, e.1, has_zero_morphisms.comp_zero],
begin
  obtain ⟨l, hl⟩ := cokernel.desc' g (cokernel.π (f ≫ g))
    begin
      apply (preadditive.cancel_zero_iff_epi f).1 (by apply_instance),
      rw [←category.assoc, cokernel.condition],
    end,
  rw [←hl, ←category.assoc, e.2, has_zero_morphisms.zero_comp],
end⟩

end

end category_theory.abelian


import QL.FOL.Tait.calculus logic

universes u v

namespace fol
open_locale logic_symbol aclogic
variables {L : language.{u}} {μ : Type v} {μ₁ : Type*} {μ₂ : Type*} {m n : ℕ} {S : Structure L}

namespace Tait
namespace subformula

variables (S) {n} {Φ : μ → S} {e : fin n → S}

@[simp] def subval' (Φ : μ → S) : ∀ {n} (e : fin n → S), subformula L μ n → Prop
| n _ verum              := true
| n _ falsum             := false
| n e (relation p v)     := S.pr p (λ i, subterm.val S Φ e (v i))
| n e (neg_relation p v) := ¬S.pr p (λ i, subterm.val S Φ e (v i))
| n e (and p q)          := p.subval' e ∧ q.subval' e
| n e (or p q)           := p.subval' e ∨ q.subval' e
| n e (fal p)            := ∀ x : S, (p.subval' (x *> e))
| n e (ex p)             := ∃ x : S, (p.subval' (x *> e))

@[simp] lemma subval'_neg (p : subformula L μ n) : subval' S Φ e (∼p) = ¬subval' S Φ e p :=
by induction p generalizing Φ e; simp[mlift, ←verum_eq, ←falsum_eq, ←and_eq, ←or_eq, ←not_eq, ←fal_eq, ←ex_eq, or_iff_not_imp_left, *] at*

@[irreducible] def subval (Φ : μ → S) (e : fin n → S) : subformula L μ n →ₗ Prop :=
{ to_fun := subval' S Φ e,
  map_neg' := λ _, by simp,
  map_imply' := λ _ _, by simp[has_arrow.arrow, imply, or_iff_not_imp_left, not_eq],
  map_and' := λ p q, by unfold has_inf.inf; simp; refl,
  map_or' := λ p q, by unfold has_sup.sup; simp; refl,
  map_top' := by refl,
  map_bot' := by refl }

@[reducible] def val (Φ : μ → S) : formula L μ →ₗ Prop := subformula.subval S Φ fin.nil

@[simp] lemma subval_relation {p} {r : L.pr p} {v} :
  subval S Φ e (relation r v) ↔ S.pr r (subterm.val S Φ e ∘ v) :=  by simp[subval]; refl

@[simp] lemma subval_neg_relation {p} {r : L.pr p} {v} :
  subval S Φ e (neg_relation r v) ↔ ¬S.pr r (subterm.val S Φ e ∘ v) := by simp[subval]; refl

@[simp] lemma subval_fal {p : subformula L μ (n + 1)} :
  subval S Φ e (∀'p) ↔ ∀ x : S, subval S Φ (x *> e) p := by simp[subval]; refl

@[simp] lemma subval_ex {p : subformula L μ (n + 1)} :
  subval S Φ e (∃'p) ↔ ∃ x : S, subval S Φ (x *> e) p := by simp[subval]; refl

variables {μ₁ μ₂}

lemma subval_map {f : μ₁ → μ₂} {Φ : μ₂ → S} {p : subformula L μ₁ n} :
  subval S Φ e (map f p) ↔ subval S (Φ ∘ f) e p :=
by induction p using fol.Tait.subformula.ind_on; simp[*, (∘), subterm.val_map]

lemma subval_subst {p : subformula L μ (n + 1)} : ∀ {e} {u : subterm L μ n},
  subval S Φ e (subst u p) ↔ subval S Φ (e <* subterm.val S Φ e u) p :=
by apply ind_succ_on p; intros; simp[*, (∘), subterm.val_subst, subterm.val_lift, fin.left_right_concat_assoc]

end subformula

namespace subformula
variables (S) {Φ : μ → S}

notation S` ⊧ᵀ[`:80 e`] `p :50 := val S e p

variables {S} {p q : formula L μ}

@[simp] lemma models_relation {k} {r : L.pr k} {v} :
  S ⊧ᵀ[Φ] relation r v ↔ S.pr r (λ i, subterm.val S Φ fin.nil (v i)) := by simp[val]

end subformula

def models (S : Structure L) (p : formula L μ) : Prop := ∀ e, S ⊧ᵀ[e] p

instance : logic.semantics (formula L μ) (Structure L) := ⟨models⟩

lemma models_def {S : Structure L} {p : formula L μ} : S ⊧ p ↔ (∀ e, S ⊧ᵀ[e] p) := by refl

lemma sentence_models_def {S : Structure L} {σ : sentence L} : S ⊧ σ ↔ S ⊧ᵀ[fin.nil] σ := by simp[models_def, fin.nil]

--@[simp] lemma models_neg {σ : sentence L} :
--  S ⊧ ∼σ ↔ ¬S ⊧ σ := by simp[sentence_models_def]

@[simp] lemma models_coe {S : Structure L} {σ : sentence L} {e : μ → S} : S ⊧ᵀ[e] ↑σ ↔ S ⊧ σ :=
by { rw [subformula.sentence_coe_def],
     simp[sentence_models_def, -subformula.map_sentence_coe, subformula.val, subformula.subval_map,
       show e ∘ fin.nil = fin.nil, by ext x; exact fin.nil x] }

instance : has_double_turnstile (Tait.preTheory L μ) (formula L μ) := ⟨logic.semantics.consequence (Structure L)⟩

lemma consequence_def {T : preTheory L μ} {p : formula L μ} :
  T ⊧ p ↔ (∀ S : Structure L, S ⊧ T → S ⊧ p) := by refl

namespace subformula
variables (S) {Φ : μ → S} {e : fin n → S}

@[simp] lemma subval_to_tait {p : fol.subformula L μ n} : subval S Φ e p.to_tait ↔ fol.subformula.subval S Φ e p :=
by induction p using fol.subformula.ind_on; simp*

@[simp] lemma subval_of_tait {p : Tait.subformula L μ n} : fol.subformula.subval S Φ e p.of_tait ↔ subval S Φ e p :=
by induction p using fol.Tait.subformula.ind_on; simp*

end subformula

@[simp] lemma models_to_tait {p : fol.formula L μ} : S ⊧ p.to_tait ↔ S ⊧ p :=
by simp[models_def, fol.Structure.models_def]

@[simp] lemma models_of_tait {p : Tait.formula L μ} : S ⊧ p.of_tait ↔ S ⊧ p :=
by simp[models_def, fol.Structure.models_def]

end Tait

end fol