/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot, Scott Morrison, Mario Carneiro, Andrew Yang
-/
import topology.category.Top.epi_mono
import category_theory.category.ulift
import category_theory.limits.concrete_category
import category_theory.concrete_category.elementwise

/-!
# The category of topological spaces has all limits and colimits

Further, these limits and colimits are preserved by the forgetful functor --- that is, the
underlying types are just the limits in the category of types.
-/

open topological_space
open category_theory
open category_theory.limits
open opposite

universes u v w

noncomputable theory

namespace Top

variables {J : Type v} [small_category J]

local notation `forget` := forget Top

/--
A choice of limit cone for a functor `F : J ⥤ Top`.
Generally you should just use `limit.cone F`, unless you need the actual definition
(which is in terms of `types.limit_cone`).
-/
def limit_cone (F : J ⥤ Top.{max v u}) : cone F :=
{ X := Top.of {u : Π j : J, F.obj j | ∀ {i j : J} (f : i ⟶ j), F.map f (u i) = u j},
  π :=
  { app := λ j,
    { to_fun := λ u, u.val j,
      continuous_to_fun := show continuous ((λ u : Π j : J, F.obj j, u j) ∘ subtype.val),
        by continuity } } }

/--
A choice of limit cone for a functor `F : J ⥤ Top` whose topology is defined as an
infimum of topologies infimum.
Generally you should just use `limit.cone F`, unless you need the actual definition
(which is in terms of `types.limit_cone`).
-/
def limit_cone_infi (F : J ⥤ Top.{max v u}) : cone F :=
{ X := ⟨(types.limit_cone (F ⋙ forget)).X, ⨅j,
        (F.obj j).str.induced ((types.limit_cone (F ⋙ forget)).π.app j)⟩,
  π :=
  { app := λ j, ⟨(types.limit_cone (F ⋙ forget)).π.app j,
                 continuous_iff_le_induced.mpr (infi_le _ _)⟩,
    naturality' := λ j j' f, continuous_map.coe_injective
      ((types.limit_cone (F ⋙ forget)).π.naturality f) } }

/--
The chosen cone `Top.limit_cone F` for a functor `F : J ⥤ Top` is a limit cone.
Generally you should just use `limit.is_limit F`, unless you need the actual definition
(which is in terms of `types.limit_cone_is_limit`).
-/
def limit_cone_is_limit (F : J ⥤ Top.{max v u}) : is_limit (limit_cone F) :=
{ lift := λ S, { to_fun := λ x, ⟨λ j, S.π.app _ x, λ i j f, by { dsimp, erw ← S.w f, refl }⟩ },
  uniq' := λ S m h, by { ext : 3, simpa [← h] } }

/--
The chosen cone `Top.limit_cone_infi F` for a functor `F : J ⥤ Top` is a limit cone.
Generally you should just use `limit.is_limit F`, unless you need the actual definition
(which is in terms of `types.limit_cone_is_limit`).
-/
def limit_cone_infi_is_limit (F : J ⥤ Top.{max v u}) : is_limit (limit_cone_infi F) :=
by { refine is_limit.of_faithful forget (types.limit_cone_is_limit _) (λ s, ⟨_, _⟩) (λ s, rfl),
     exact continuous_iff_coinduced_le.mpr (le_infi $ λ j,
       coinduced_le_iff_le_induced.mp $ (continuous_iff_coinduced_le.mp (s.π.app j).continuous :
         _) ) }

instance Top_has_limits_of_size : has_limits_of_size.{v} Top.{max v u} :=
{ has_limits_of_shape := λ J 𝒥, by exactI
  { has_limit := λ F, has_limit.mk { cone := limit_cone F, is_limit := limit_cone_is_limit F } } }

instance Top_has_limits : has_limits Top.{u} := Top.Top_has_limits_of_size.{u u}

instance forget_preserves_limits_of_size :
  preserves_limits_of_size.{v v} (forget : Top.{max v u} ⥤ Type (max v u)) :=
{ preserves_limits_of_shape := λ J 𝒥,
  { preserves_limit := λ F,
    by exactI preserves_limit_of_preserves_limit_cone
      (limit_cone_is_limit F) (types.limit_cone_is_limit (F ⋙ forget)) } }

instance forget_preserves_limits : preserves_limits (forget : Top.{u} ⥤ Type u) :=
Top.forget_preserves_limits_of_size.{u u}

/--
A choice of colimit cocone for a functor `F : J ⥤ Top`.
Generally you should just use `colimit.coone F`, unless you need the actual definition
(which is in terms of `types.colimit_cocone`).
-/
def colimit_cocone (F : J ⥤ Top.{max v u}) : cocone F :=
{ X := ⟨(types.colimit_cocone (F ⋙ forget)).X, ⨆ j,
        (F.obj j).str.coinduced ((types.colimit_cocone (F ⋙ forget)).ι.app j)⟩,
  ι :=
  { app := λ j, ⟨(types.colimit_cocone (F ⋙ forget)).ι.app j,
                 continuous_iff_coinduced_le.mpr (le_supr _ j)⟩,
    naturality' := λ j j' f, continuous_map.coe_injective
      ((types.colimit_cocone (F ⋙ forget)).ι.naturality f) } }

/--
The chosen cocone `Top.colimit_cocone F` for a functor `F : J ⥤ Top` is a colimit cocone.
Generally you should just use `colimit.is_colimit F`, unless you need the actual definition
(which is in terms of `types.colimit_cocone_is_colimit`).
-/
def colimit_cocone_is_colimit (F : J ⥤ Top.{max v u}) : is_colimit (colimit_cocone F) :=
by { refine is_colimit.of_faithful forget (types.colimit_cocone_is_colimit _) (λ s, ⟨_, _⟩)
       (λ s, rfl),
     exact continuous_iff_le_induced.mpr (supr_le $ λ j,
       coinduced_le_iff_le_induced.mp $ (continuous_iff_coinduced_le.mp (s.ι.app j).continuous :
         _) ) }

instance Top_has_colimits_of_size : has_colimits_of_size.{v} Top.{max v u} :=
{ has_colimits_of_shape := λ J 𝒥, by exactI
  { has_colimit := λ F, has_colimit.mk { cocone := colimit_cocone F, is_colimit :=
    colimit_cocone_is_colimit F } } }

instance Top_has_colimits : has_colimits Top.{u} := Top.Top_has_colimits_of_size.{u u}

instance forget_preserves_colimits_of_size :
  preserves_colimits_of_size.{v v} (forget : Top.{max v u} ⥤ Type (max v u)) :=
{ preserves_colimits_of_shape := λ J 𝒥,
  { preserves_colimit := λ F,
    by exactI preserves_colimit_of_preserves_colimit_cocone
      (colimit_cocone_is_colimit F) (types.colimit_cocone_is_colimit (F ⋙ forget)) } }

instance forget_preserves_colimits : preserves_colimits (forget : Top.{u} ⥤ Type u) :=
Top.forget_preserves_colimits_of_size.{u u}

/-- The projection from the product as a bundled continous map. -/
abbreviation pi_π {ι : Type v} (α : ι → Top.{max v u}) (i : ι) : Top.of (Π i, α i) ⟶ α i :=
⟨λ f, f i, continuous_apply i⟩

/-- The explicit fan of a family of topological spaces given by the pi type. -/
@[simps X π_app]
def pi_fan {ι : Type v} (α : ι → Top.{max v u}) : fan α :=
fan.mk (Top.of (Π i, α i)) (pi_π α)

/-- The constructed fan is indeed a limit -/
def pi_fan_is_limit {ι : Type v} (α : ι → Top.{max v u}) : is_limit (pi_fan α) :=
{ lift := λ S, { to_fun := λ s i, S.π.app ⟨i⟩ s },
  uniq' := by { intros S m h, ext x i, simp [← h ⟨i⟩] },
  fac' := λ s j, by { cases j, tidy, }, }

/--
The product is homeomorphic to the product of the underlying spaces,
equipped with the product topology.
-/
def pi_iso_pi {ι : Type v} (α : ι → Top.{max v u}) : ∏ α ≅ Top.of (Π i, α i) :=
(limit.is_limit _).cone_point_unique_up_to_iso (pi_fan_is_limit α)

@[simp, reassoc]
lemma pi_iso_pi_inv_π {ι : Type v} (α : ι → Top.{max v u}) (i : ι) :
  (pi_iso_pi α).inv ≫ pi.π α i = pi_π α i :=
by simp [pi_iso_pi]

@[simp]
lemma pi_iso_pi_inv_π_apply {ι : Type v} (α : ι → Top.{max v u}) (i : ι) (x : Π i, α i) :
  (pi.π α i : _) ((pi_iso_pi α).inv x) = x i :=
concrete_category.congr_hom (pi_iso_pi_inv_π α i) x

@[simp]
lemma pi_iso_pi_hom_apply {ι : Type v} (α : ι → Top.{max v u}) (i : ι) (x : ∏ α) :
  (pi_iso_pi α).hom x i = (pi.π α i : _) x :=
begin
  have := pi_iso_pi_inv_π α i,
  rw iso.inv_comp_eq at this,
  exact concrete_category.congr_hom this x
end

/-- The inclusion to the coproduct as a bundled continous map. -/
abbreviation sigma_ι {ι : Type v} (α : ι → Top.{max v u}) (i : ι) : α i ⟶ Top.of (Σ i, α i) :=
⟨sigma.mk i⟩

/-- The explicit cofan of a family of topological spaces given by the sigma type. -/
@[simps X ι_app]
def sigma_cofan {ι : Type v} (α : ι → Top.{max v u}) : cofan α :=
cofan.mk (Top.of (Σ i, α i)) (sigma_ι α)

/-- The constructed cofan is indeed a colimit -/
def sigma_cofan_is_colimit {ι : Type v} (α : ι → Top.{max v u}) : is_colimit (sigma_cofan α) :=
{ desc := λ S, { to_fun := λ s, S.ι.app ⟨s.1⟩ s.2,
    continuous_to_fun := continuous_sigma $ λ i, map_continuous (S.ι.app ⟨i⟩) },
  uniq' := by { intros S m h,  ext ⟨i, x⟩, simp [← h ⟨i⟩] },
  fac' := λ s j, by { cases j, tidy, }, }

/--
The coproduct is homeomorphic to the disjoint union of the topological spaces.
-/
def sigma_iso_sigma {ι : Type v} (α : ι → Top.{max v u}) : ∐ α ≅ Top.of (Σ i, α i) :=
(colimit.is_colimit _).cocone_point_unique_up_to_iso (sigma_cofan_is_colimit α)

@[simp, reassoc]
lemma sigma_iso_sigma_hom_ι {ι : Type v} (α : ι → Top.{max v u}) (i : ι) :
  sigma.ι α i ≫ (sigma_iso_sigma α).hom = sigma_ι α i :=
by simp [sigma_iso_sigma]

@[simp]
lemma sigma_iso_sigma_hom_ι_apply {ι : Type v} (α : ι → Top.{max v u}) (i : ι) (x : α i) :
  (sigma_iso_sigma α).hom ((sigma.ι α i : _) x) = sigma.mk i x :=
concrete_category.congr_hom (sigma_iso_sigma_hom_ι α i) x

@[simp]
lemma sigma_iso_sigma_inv_apply {ι : Type v} (α : ι → Top.{max v u}) (i : ι) (x : α i) :
  (sigma_iso_sigma α).inv ⟨i, x⟩ = (sigma.ι α i : _) x :=
by { rw [← sigma_iso_sigma_hom_ι_apply, ← comp_app], simp, }

lemma induced_of_is_limit {F : J ⥤ Top.{max v u}} (C : cone F) (hC : is_limit C) :
  C.X.topological_space = ⨅ j, (F.obj j).topological_space.induced (C.π.app j) :=
begin
  let homeo := homeo_of_iso (hC.cone_point_unique_up_to_iso (limit_cone_infi_is_limit F)),
  refine homeo.inducing.induced.trans _,
  change induced homeo (⨅ (j : J), _) = _,
  simpa [induced_infi, induced_compose],
end

lemma limit_topology (F : J ⥤ Top.{max v u}) :
  (limit F).topological_space = ⨅ j, (F.obj j).topological_space.induced (limit.π F j) :=
induced_of_is_limit _ (limit.is_limit F)

section prod

/-- The first projection from the product. -/
abbreviation prod_fst {X Y : Top.{u}} : Top.of (X × Y) ⟶ X := ⟨prod.fst⟩

/-- The second projection from the product. -/
abbreviation prod_snd {X Y : Top.{u}} : Top.of (X × Y) ⟶ Y := ⟨prod.snd⟩

/-- The explicit binary cofan of `X, Y` given by `X × Y`. -/
def prod_binary_fan (X Y : Top.{u}) : binary_fan X Y :=
binary_fan.mk prod_fst prod_snd

/-- The constructed binary fan is indeed a limit -/
def prod_binary_fan_is_limit (X Y : Top.{u}) : is_limit (prod_binary_fan X Y) :=
{ lift := λ (S : binary_fan X Y), { to_fun := λ s, (S.fst s, S.snd s) },
  fac' := begin
    rintros S (_|_),
    tidy
  end,
  uniq' := begin
    intros S m h,
    ext x,
    { specialize h ⟨walking_pair.left⟩,
      apply_fun (λ e, (e x)) at h,
      exact h },
     { specialize h ⟨walking_pair.right⟩,
      apply_fun (λ e, (e x)) at h,
      exact h },
  end }

/--
The homeomorphism between `X ⨯ Y` and the set-theoretic product of `X` and `Y`,
equipped with the product topology.
-/
def prod_iso_prod (X Y : Top.{u}) : X ⨯ Y ≅ Top.of (X × Y) :=
(limit.is_limit _).cone_point_unique_up_to_iso (prod_binary_fan_is_limit X Y)

@[simp, reassoc] lemma prod_iso_prod_hom_fst (X Y : Top.{u}) :
  (prod_iso_prod X Y).hom ≫ prod_fst = limits.prod.fst :=
by simpa [← iso.eq_inv_comp, prod_iso_prod]

@[simp, reassoc] lemma prod_iso_prod_hom_snd (X Y : Top.{u}) :
  (prod_iso_prod X Y).hom ≫ prod_snd = limits.prod.snd :=
by simpa [← iso.eq_inv_comp, prod_iso_prod]

@[simp] lemma prod_iso_prod_hom_apply {X Y : Top.{u}} (x : X ⨯ Y) :
  (prod_iso_prod X Y).hom x =
    ((limits.prod.fst : X ⨯ Y ⟶ _) x, (limits.prod.snd : X ⨯ Y ⟶ _) x) :=
begin
  ext,
  { exact concrete_category.congr_hom (prod_iso_prod_hom_fst X Y) x },
  { exact concrete_category.congr_hom (prod_iso_prod_hom_snd X Y) x }
end

@[simp, reassoc, elementwise] lemma prod_iso_prod_inv_fst (X Y : Top.{u}) :
  (prod_iso_prod X Y).inv ≫ limits.prod.fst = prod_fst :=
by simp [iso.inv_comp_eq]

@[simp, reassoc, elementwise] lemma prod_iso_prod_inv_snd (X Y : Top.{u}) :
  (prod_iso_prod X Y).inv ≫ limits.prod.snd = prod_snd :=
by simp [iso.inv_comp_eq]

lemma prod_topology {X Y : Top} :
  (X ⨯ Y).topological_space =
    induced (limits.prod.fst : X ⨯ Y ⟶ _) X.topological_space ⊓
      induced (limits.prod.snd : X ⨯ Y ⟶ _) Y.topological_space :=
begin
  let homeo := homeo_of_iso (prod_iso_prod X Y),
  refine homeo.inducing.induced.trans _,
  change induced homeo (_ ⊓ _) = _,
  simpa [induced_compose]
end

lemma range_prod_map {W X Y Z : Top.{u}} (f : W ⟶ Y) (g : X ⟶ Z) :
  set.range (limits.prod.map f g) =
    (limits.prod.fst : Y ⨯ Z ⟶ _) ⁻¹' (set.range f) ∩
      (limits.prod.snd : Y ⨯ Z ⟶ _) ⁻¹' (set.range g) :=
begin
  ext,
  split,
  { rintros ⟨y, rfl⟩,
    simp only [set.mem_preimage, set.mem_range, set.mem_inter_iff, ←comp_apply],
    simp only [limits.prod.map_fst, limits.prod.map_snd,
      exists_apply_eq_apply, comp_apply, and_self] },
  { rintros ⟨⟨x₁, hx₁⟩, ⟨x₂, hx₂⟩⟩,
    use (prod_iso_prod W X).inv (x₁, x₂),
    apply concrete.limit_ext,
    rintro ⟨⟨⟩⟩,
    { simp only [← comp_apply, category.assoc], erw limits.prod.map_fst, simp [hx₁] },
    { simp only [← comp_apply, category.assoc], erw limits.prod.map_snd, simp [hx₂] } }
end

lemma inducing_prod_map {W X Y Z : Top} {f : W ⟶ X} {g : Y ⟶ Z}
  (hf : inducing f) (hg : inducing g) : inducing (limits.prod.map f g) :=
begin
  constructor,
  simp only [prod_topology, induced_compose, ←coe_comp, limits.prod.map_fst, limits.prod.map_snd,
    induced_inf],
  simp only [coe_comp],
  rw [← @induced_compose _ _ _ _ _ f, ← @induced_compose _ _ _ _ _ g, ← hf.induced, ← hg.induced]
end

lemma embedding_prod_map {W X Y Z : Top} {f : W ⟶ X} {g : Y ⟶ Z}
  (hf : embedding f) (hg : embedding g) : embedding (limits.prod.map f g) :=
⟨inducing_prod_map hf.to_inducing hg.to_inducing,
begin
  haveI := (Top.mono_iff_injective _).mpr hf.inj,
  haveI := (Top.mono_iff_injective _).mpr hg.inj,
  exact (Top.mono_iff_injective _).mp infer_instance
end⟩

end prod

section pullback

variables {X Y Z : Top.{u}}

/-- The first projection from the pullback. -/
abbreviation pullback_fst (f : X ⟶ Z) (g : Y ⟶ Z) : Top.of { p : X × Y // f p.1 = g p.2 } ⟶ X :=
⟨prod.fst ∘ subtype.val⟩

/-- The second projection from the pullback. -/
abbreviation pullback_snd (f : X ⟶ Z) (g : Y ⟶ Z) : Top.of { p : X × Y // f p.1 = g p.2 } ⟶ Y :=
⟨prod.snd ∘ subtype.val⟩

/-- The explicit pullback cone of `X, Y` given by `{ p : X × Y // f p.1 = g p.2 }`. -/
def pullback_cone (f : X ⟶ Z) (g : Y ⟶ Z) : pullback_cone f g :=
pullback_cone.mk (pullback_fst f g) (pullback_snd f g) (by { ext ⟨x, h⟩, simp [h] })

/-- The constructed cone is a limit. -/
def pullback_cone_is_limit (f : X ⟶ Z) (g : Y ⟶ Z) :
  is_limit (pullback_cone f g) := pullback_cone.is_limit_aux' _
begin
  intro s,
  split, swap,
  exact { to_fun := λ x, ⟨⟨s.fst x, s.snd x⟩,
    by simpa using concrete_category.congr_hom s.condition x⟩ },
  refine ⟨_,_,_⟩,
  { ext, delta pullback_cone, simp },
  { ext, delta pullback_cone, simp },
  { intros m h₁ h₂,
    ext x,
    { simpa using concrete_category.congr_hom h₁ x },
    { simpa using concrete_category.congr_hom h₂ x } }
end

/-- The pullback of two maps can be identified as a subspace of `X × Y`. -/
def pullback_iso_prod_subtype (f : X ⟶ Z) (g : Y ⟶ Z) :
  pullback f g ≅ Top.of { p : X × Y // f p.1 = g p.2 } :=
(limit.is_limit _).cone_point_unique_up_to_iso (pullback_cone_is_limit f g)

@[simp, reassoc] lemma pullback_iso_prod_subtype_inv_fst (f : X ⟶ Z) (g : Y ⟶ Z) :
  (pullback_iso_prod_subtype f g).inv ≫ pullback.fst = pullback_fst f g :=
by simpa [pullback_iso_prod_subtype]

@[simp] lemma pullback_iso_prod_subtype_inv_fst_apply (f : X ⟶ Z) (g : Y ⟶ Z)
  (x : { p : X × Y // f p.1 = g p.2 }) :
  (pullback.fst : pullback f g ⟶ _) ((pullback_iso_prod_subtype f g).inv x) = (x : X × Y).fst :=
concrete_category.congr_hom (pullback_iso_prod_subtype_inv_fst f g) x

@[simp, reassoc] lemma pullback_iso_prod_subtype_inv_snd (f : X ⟶ Z) (g : Y ⟶ Z) :
  (pullback_iso_prod_subtype f g).inv ≫ pullback.snd = pullback_snd f g :=
by simpa [pullback_iso_prod_subtype]

@[simp] lemma pullback_iso_prod_subtype_inv_snd_apply (f : X ⟶ Z) (g : Y ⟶ Z)
  (x : { p : X × Y // f p.1 = g p.2 }) :
  (pullback.snd : pullback f g ⟶ _) ((pullback_iso_prod_subtype f g).inv x) = (x : X × Y).snd :=
concrete_category.congr_hom (pullback_iso_prod_subtype_inv_snd f g) x

lemma pullback_iso_prod_subtype_hom_fst (f : X ⟶ Z) (g : Y ⟶ Z) :
  (pullback_iso_prod_subtype f g).hom ≫ pullback_fst f g = pullback.fst :=
by rw [←iso.eq_inv_comp, pullback_iso_prod_subtype_inv_fst]

lemma pullback_iso_prod_subtype_hom_snd (f : X ⟶ Z) (g : Y ⟶ Z) :
  (pullback_iso_prod_subtype f g).hom ≫ pullback_snd f g = pullback.snd :=
by rw [←iso.eq_inv_comp, pullback_iso_prod_subtype_inv_snd]

@[simp] lemma pullback_iso_prod_subtype_hom_apply {f : X ⟶ Z} {g : Y ⟶ Z}
  (x : pullback f g) : (pullback_iso_prod_subtype f g).hom x =
    ⟨⟨(pullback.fst : pullback f g ⟶ _) x, (pullback.snd : pullback f g ⟶ _) x⟩,
      by simpa using concrete_category.congr_hom pullback.condition x⟩ :=
begin
  ext,
  exacts [concrete_category.congr_hom (pullback_iso_prod_subtype_hom_fst f g) x,
    concrete_category.congr_hom (pullback_iso_prod_subtype_hom_snd f g) x]
end

lemma pullback_topology {X Y Z : Top.{u}} (f : X ⟶ Z) (g : Y ⟶ Z) :
  (pullback f g).topological_space =
    induced (pullback.fst : pullback f g ⟶ _) X.topological_space ⊓
      induced (pullback.snd : pullback f g ⟶ _) Y.topological_space :=
begin
  let homeo := homeo_of_iso (pullback_iso_prod_subtype f g),
  refine homeo.inducing.induced.trans _,
  change induced homeo (induced _ (_ ⊓ _)) = _,
  simpa [induced_compose]
end

lemma range_pullback_to_prod {X Y Z : Top} (f : X ⟶ Z) (g : Y ⟶ Z) :
  set.range (prod.lift pullback.fst pullback.snd : pullback f g ⟶ X ⨯ Y) =
  { x | (limits.prod.fst ≫ f) x = (limits.prod.snd ≫ g) x } :=
begin
  ext x,
  split,
  { rintros ⟨y, rfl⟩,
    simp only [←comp_apply, set.mem_set_of_eq],
    congr' 1,
    simp [pullback.condition] },
  { intro h,
    use (pullback_iso_prod_subtype f g).inv ⟨⟨_, _⟩, h⟩,
    apply concrete.limit_ext,
    rintro ⟨⟨⟩⟩; simp, }
end

lemma inducing_pullback_to_prod {X Y Z : Top} (f : X ⟶ Z) (g : Y ⟶ Z) :
  inducing ⇑(prod.lift pullback.fst pullback.snd : pullback f g ⟶ X ⨯ Y) :=
⟨by simp [prod_topology, pullback_topology, induced_compose, ←coe_comp]⟩

lemma embedding_pullback_to_prod {X Y Z : Top} (f : X ⟶ Z) (g : Y ⟶ Z) :
  embedding ⇑(prod.lift pullback.fst pullback.snd : pullback f g ⟶ X ⨯ Y) :=
⟨inducing_pullback_to_prod f g, (Top.mono_iff_injective _).mp infer_instance⟩

/-- If the map `S ⟶ T` is mono, then there is a description of the image of `W ×ₛ X ⟶ Y ×ₜ Z`. -/
lemma range_pullback_map {W X Y Z S T : Top} (f₁ : W ⟶ S) (f₂ : X ⟶ S)
  (g₁ : Y ⟶ T) (g₂ : Z ⟶ T) (i₁ : W ⟶ Y) (i₂ : X ⟶ Z) (i₃ : S ⟶ T) [H₃ : mono i₃]
  (eq₁ : f₁ ≫ i₃ = i₁ ≫ g₁) (eq₂ : f₂ ≫ i₃ = i₂ ≫ g₂) :
  set.range (pullback.map f₁ f₂ g₁ g₂ i₁ i₂ i₃ eq₁ eq₂) =
    (pullback.fst : pullback g₁ g₂ ⟶ _) ⁻¹' (set.range i₁) ∩
      (pullback.snd : pullback g₁ g₂ ⟶ _) ⁻¹' (set.range i₂) :=
begin
  ext,
  split,
  { rintro ⟨y, rfl⟩, simp, },
  rintros ⟨⟨x₁, hx₁⟩, ⟨x₂, hx₂⟩⟩,
  have : f₁ x₁ = f₂ x₂,
  { apply (Top.mono_iff_injective _).mp H₃,
    simp only [←comp_apply, eq₁, eq₂],
    simp only [comp_apply, hx₁, hx₂],
    simp only [←comp_apply, pullback.condition] },
  use (pullback_iso_prod_subtype f₁ f₂).inv ⟨⟨x₁, x₂⟩, this⟩,
  apply concrete.limit_ext,
  rintros (_|_|_),
  { simp only [Top.comp_app, limit.lift_π_apply, category.assoc, pullback_cone.mk_π_app_one,
      hx₁, pullback_iso_prod_subtype_inv_fst_apply, subtype.coe_mk],
    simp only [← comp_apply],
    congr,
    apply limit.w _ walking_cospan.hom.inl },
  { simp [hx₁] },
  { simp [hx₂] },
end

lemma pullback_fst_range {X Y S : Top} (f : X ⟶ S) (g : Y ⟶ S) :
  set.range (pullback.fst : pullback f g ⟶ _) = { x : X | ∃ y : Y, f x = g y} :=
begin
  ext x,
  split,
  { rintro ⟨y, rfl⟩,
    use (pullback.snd : pullback f g ⟶ _) y,
    exact concrete_category.congr_hom pullback.condition y },
  { rintro ⟨y, eq⟩,
    use (Top.pullback_iso_prod_subtype f g).inv ⟨⟨x, y⟩, eq⟩,
    simp },
end

lemma pullback_snd_range {X Y S : Top} (f : X ⟶ S) (g : Y ⟶ S) :
  set.range (pullback.snd : pullback f g ⟶ _) = { y : Y | ∃ x : X, f x = g y} :=
begin
  ext y,
  split,
  { rintro ⟨x, rfl⟩,
    use (pullback.fst : pullback f g ⟶ _) x,
    exact concrete_category.congr_hom pullback.condition x },
  { rintro ⟨x, eq⟩,
    use (Top.pullback_iso_prod_subtype f g).inv ⟨⟨x, y⟩, eq⟩,
    simp },
end

/--
If there is a diagram where the morphisms `W ⟶ Y` and `X ⟶ Z` are embeddings,
then the induced morphism `W ×ₛ X ⟶ Y ×ₜ Z` is also an embedding.

  W  ⟶  Y
    ↘      ↘
      S  ⟶  T
    ↗      ↗
  X  ⟶  Z
-/
lemma pullback_map_embedding_of_embeddings {W X Y Z S T : Top}
  (f₁ : W ⟶ S) (f₂ : X ⟶ S) (g₁ : Y ⟶ T) (g₂ : Z ⟶ T) {i₁ : W ⟶ Y} {i₂ : X ⟶ Z}
  (H₁ : embedding i₁) (H₂ : embedding i₂) (i₃ : S ⟶ T)
  (eq₁ : f₁ ≫ i₃ = i₁ ≫ g₁) (eq₂ : f₂ ≫ i₃ = i₂ ≫ g₂) :
  embedding (pullback.map f₁ f₂ g₁ g₂ i₁ i₂ i₃ eq₁ eq₂) :=
begin
  refine embedding_of_embedding_compose (continuous_map.continuous_to_fun _)
    (show continuous (prod.lift pullback.fst pullback.snd : pullback g₁ g₂ ⟶ Y ⨯ Z), from
      continuous_map.continuous_to_fun _) _,
  suffices : embedding
    (prod.lift pullback.fst pullback.snd ≫ limits.prod.map i₁ i₂ : pullback f₁ f₂ ⟶ _),
  { simpa [←coe_comp] using this },
  rw coe_comp,
  refine embedding.comp (embedding_prod_map H₁ H₂)
    (embedding_pullback_to_prod _ _)
end

/--
If there is a diagram where the morphisms `W ⟶ Y` and `X ⟶ Z` are open embeddings, and `S ⟶ T`
is mono, then the induced morphism `W ×ₛ X ⟶ Y ×ₜ Z` is also an open embedding.
  W  ⟶  Y
    ↘      ↘
      S  ⟶  T
    ↗       ↗
  X  ⟶  Z
-/
lemma pullback_map_open_embedding_of_open_embeddings {W X Y Z S T : Top}
  (f₁ : W ⟶ S) (f₂ : X ⟶ S) (g₁ : Y ⟶ T) (g₂ : Z ⟶ T) {i₁ : W ⟶ Y} {i₂ : X ⟶ Z}
  (H₁ : open_embedding i₁) (H₂ : open_embedding i₂) (i₃ : S ⟶ T) [H₃ : mono i₃]
  (eq₁ : f₁ ≫ i₃ = i₁ ≫ g₁) (eq₂ : f₂ ≫ i₃ = i₂ ≫ g₂) :
  open_embedding (pullback.map f₁ f₂ g₁ g₂ i₁ i₂ i₃ eq₁ eq₂) :=
begin
  split,
  { apply pullback_map_embedding_of_embeddings
      f₁ f₂ g₁ g₂ H₁.to_embedding H₂.to_embedding i₃ eq₁ eq₂ },
  { rw range_pullback_map,
    apply is_open.inter; apply continuous.is_open_preimage,
    continuity,
    exacts [H₁.open_range, H₂.open_range] }
end

lemma snd_embedding_of_left_embedding {X Y S : Top}
  {f : X ⟶ S} (H : embedding f) (g : Y ⟶ S) :
  embedding ⇑(pullback.snd : pullback f g ⟶ Y) :=
begin
  convert (homeo_of_iso (as_iso (pullback.snd : pullback (𝟙 S) g ⟶ _))).embedding.comp
    (pullback_map_embedding_of_embeddings f g (𝟙 _) g H
      (homeo_of_iso (iso.refl _)).embedding (𝟙 _) rfl (by simp)),
  erw ←coe_comp,
  simp
end

lemma fst_embedding_of_right_embedding {X Y S : Top}
  (f : X ⟶ S) {g : Y ⟶ S} (H : embedding g) :
  embedding ⇑(pullback.fst : pullback f g ⟶ X) :=
begin
  convert (homeo_of_iso (as_iso (pullback.fst : pullback f (𝟙 S) ⟶ _))).embedding.comp
    (pullback_map_embedding_of_embeddings f g f (𝟙 _)
      (homeo_of_iso (iso.refl _)).embedding H (𝟙 _) rfl (by simp)),
  erw ←coe_comp,
  simp
end

lemma embedding_of_pullback_embeddings {X Y S : Top}
  {f : X ⟶ S} {g : Y ⟶ S} (H₁ : embedding f) (H₂ : embedding g) :
  embedding (limit.π (cospan f g) walking_cospan.one) :=
begin
  convert H₂.comp (snd_embedding_of_left_embedding H₁ g),
  erw ←coe_comp,
  congr,
  exact (limit.w _ walking_cospan.hom.inr).symm
end

lemma snd_open_embedding_of_left_open_embedding {X Y S : Top}
  {f : X ⟶ S} (H : open_embedding f) (g : Y ⟶ S) :
  open_embedding ⇑(pullback.snd : pullback f g ⟶ Y) :=
begin
  convert (homeo_of_iso (as_iso (pullback.snd : pullback (𝟙 S) g ⟶ _))).open_embedding.comp
    (pullback_map_open_embedding_of_open_embeddings f g (𝟙 _) g H
      (homeo_of_iso (iso.refl _)).open_embedding (𝟙 _) rfl (by simp)),
  erw ←coe_comp,
  simp
end

lemma fst_open_embedding_of_right_open_embedding {X Y S : Top}
  (f : X ⟶ S) {g : Y ⟶ S} (H : open_embedding g) :
  open_embedding ⇑(pullback.fst : pullback f g ⟶ X) :=
begin
  convert (homeo_of_iso (as_iso (pullback.fst : pullback f (𝟙 S) ⟶ _))).open_embedding.comp
    (pullback_map_open_embedding_of_open_embeddings f g f (𝟙 _)
      (homeo_of_iso (iso.refl _)).open_embedding H (𝟙 _) rfl (by simp)),
  erw ←coe_comp,
  simp
end

/-- If `X ⟶ S`, `Y ⟶ S` are open embeddings, then so is `X ×ₛ Y ⟶ S`. -/
lemma open_embedding_of_pullback_open_embeddings {X Y S : Top}
  {f : X ⟶ S} {g : Y ⟶ S} (H₁ : open_embedding f) (H₂ : open_embedding g) :
  open_embedding (limit.π (cospan f g) walking_cospan.one) :=
begin
  convert H₂.comp (snd_open_embedding_of_left_open_embedding H₁ g),
  erw ←coe_comp,
  congr,
  exact (limit.w _ walking_cospan.hom.inr).symm
end

lemma fst_iso_of_right_embedding_range_subset {X Y S : Top} (f : X ⟶ S) {g : Y ⟶ S}
  (hg : embedding g) (H : set.range f ⊆ set.range g) : is_iso (pullback.fst : pullback f g ⟶ X) :=
begin
  let : (pullback f g : Top) ≃ₜ X :=
    (homeomorph.of_embedding _ (fst_embedding_of_right_embedding f hg)).trans
    { to_fun := coe,
      inv_fun := (λ x, ⟨x,
        by { rw pullback_fst_range, exact ⟨_, (H (set.mem_range_self x)).some_spec.symm⟩ }⟩),
      left_inv := λ ⟨_,_⟩, rfl,
      right_inv := λ x, rfl },
  convert is_iso.of_iso (iso_of_homeo this),
  ext,
  refl
end

lemma snd_iso_of_left_embedding_range_subset {X Y S : Top} {f : X ⟶ S} (hf : embedding f)
  (g : Y ⟶ S) (H : set.range g ⊆ set.range f) : is_iso (pullback.snd : pullback f g ⟶ Y) :=
begin
  let : (pullback f g : Top) ≃ₜ Y :=
    (homeomorph.of_embedding _ (snd_embedding_of_left_embedding hf g)).trans
    { to_fun := coe,
      inv_fun := (λ x, ⟨x,
        by { rw pullback_snd_range, exact ⟨_, (H (set.mem_range_self x)).some_spec⟩ }⟩),
      left_inv := λ ⟨_,_⟩, rfl,
      right_inv := λ x, rfl },
  convert is_iso.of_iso (iso_of_homeo this),
  ext,
  refl
end

lemma pullback_snd_image_fst_preimage (f : X ⟶ Z) (g : Y ⟶ Z) (U : set X) :
  (pullback.snd : pullback f g ⟶ _) '' ((pullback.fst : pullback f g ⟶ _) ⁻¹' U) =
    g ⁻¹' (f '' U) :=
begin
  ext x,
  split,
  { rintros ⟨y, hy, rfl⟩,
    exact ⟨(pullback.fst : pullback f g ⟶ _) y, hy,
    concrete_category.congr_hom pullback.condition y⟩ },
  { rintros ⟨y, hy, eq⟩,
    exact ⟨(Top.pullback_iso_prod_subtype f g).inv ⟨⟨_,_⟩, eq⟩, by simpa, by simp⟩ },
end

lemma pullback_fst_image_snd_preimage (f : X ⟶ Z) (g : Y ⟶ Z) (U : set Y) :
  (pullback.fst : pullback f g ⟶ _) '' ((pullback.snd : pullback f g ⟶ _) ⁻¹' U) =
    f ⁻¹' (g '' U) :=
begin
  ext x,
  split,
  { rintros ⟨y, hy, rfl⟩,
    exact ⟨(pullback.snd : pullback f g ⟶ _) y, hy,
    (concrete_category.congr_hom pullback.condition y).symm⟩ },
  { rintros ⟨y, hy, eq⟩,
    exact ⟨(Top.pullback_iso_prod_subtype f g).inv ⟨⟨_,_⟩,eq.symm⟩, by simpa, by simp⟩ },
end

end pullback

/-- The terminal object of `Top` is `punit`. -/
def is_terminal_punit : is_terminal (Top.of punit.{u+1}) :=
begin
  haveI : ∀ X, unique (X ⟶ Top.of punit.{u+1}) :=
    λ X, ⟨⟨⟨λ x, punit.star, by continuity⟩⟩, λ f, by ext⟩,
  exact limits.is_terminal.of_unique _,
end

/-- The terminal object of `Top` is `punit`. -/
def terminal_iso_punit : ⊤_ Top.{u} ≅ Top.of punit :=
terminal_is_terminal.unique_up_to_iso is_terminal_punit

/-- The initial object of `Top` is `pempty`. -/
def is_initial_pempty : is_initial (Top.of pempty.{u+1}) :=
begin
  haveI : ∀ X, unique (Top.of pempty.{u+1} ⟶ X) :=
    λ X, ⟨⟨⟨λ x, x.elim, by continuity⟩⟩, λ f, by ext ⟨⟩⟩,
  exact limits.is_initial.of_unique _,
end

/-- The initial object of `Top` is `pempty`. -/
def initial_iso_pempty : ⊥_ Top.{u} ≅ Top.of pempty :=
initial_is_initial.unique_up_to_iso is_initial_pempty

/-- The binary coproduct cofan in `Top`. -/
protected
def binary_cofan (X Y : Top.{u}) : binary_cofan X Y :=
binary_cofan.mk (⟨sum.inl⟩ : X ⟶ Top.of (X ⊕ Y)) ⟨sum.inr⟩

/-- The constructed binary coproduct cofan in `Top` is the coproduct. -/
def binary_cofan_is_colimit (X Y : Top.{u}) : is_colimit (Top.binary_cofan X Y) :=
begin
  refine limits.binary_cofan.is_colimit_mk (λ s, ⟨sum.elim s.inl s.inr⟩) _ _ _,
  { intro s, ext, refl },
  { intro s, ext, refl },
  { intros s m h₁ h₂, ext (x|x),
    exacts [(concrete_category.congr_hom h₁ x : _), (concrete_category.congr_hom h₂ x : _)] },
end

lemma binary_cofan_is_colimit_iff {X Y : Top} (c : binary_cofan X Y) :
  nonempty (is_colimit c) ↔
    open_embedding c.inl ∧ open_embedding c.inr ∧ is_compl (set.range c.inl) (set.range c.inr) :=
begin
  classical,
  split,
  { rintro ⟨h⟩,
    rw [← show _ = c.inl, from h.comp_cocone_point_unique_up_to_iso_inv
      (binary_cofan_is_colimit X Y) ⟨walking_pair.left⟩,
      ← show _ = c.inr, from h.comp_cocone_point_unique_up_to_iso_inv
      (binary_cofan_is_colimit X Y) ⟨walking_pair.right⟩],
    dsimp,
    refine
    ⟨(homeo_of_iso $ h.cocone_point_unique_up_to_iso (binary_cofan_is_colimit X Y)).symm
      .open_embedding.comp open_embedding_inl, (homeo_of_iso $ h.cocone_point_unique_up_to_iso
        (binary_cofan_is_colimit X Y)).symm.open_embedding.comp open_embedding_inr, _⟩,
    erw [set.range_comp, ← eq_compl_iff_is_compl, set.range_comp _ sum.inr, ← set.image_compl_eq
      (homeo_of_iso $ h.cocone_point_unique_up_to_iso (binary_cofan_is_colimit X Y))
      .symm.bijective],
    congr' 1,
    exact set.compl_range_inr.symm },
  { rintros ⟨h₁, h₂, h₃⟩,
    have : ∀ x, x ∈ set.range c.inl ∨ x ∈ set.range c.inr,
    { rw [eq_compl_iff_is_compl.mpr h₃.symm], exact λ _, or_not },
    refine ⟨binary_cofan.is_colimit.mk _ _ _ _ _⟩,
    { intros T f g,
      refine continuous_map.mk _ _,
      { exact λ x, if h : x ∈ set.range c.inl
        then f ((equiv.of_injective _ h₁.inj).symm ⟨x, h⟩)
        else g ((equiv.of_injective _ h₂.inj).symm ⟨x, (this x).resolve_left h⟩) },
      rw continuous_iff_continuous_at,
      intro x,
      by_cases x ∈ set.range c.inl,
      { revert h x,
      apply (is_open.continuous_on_iff _).mp,
      { rw continuous_on_iff_continuous_restrict,
        convert_to continuous (f ∘ (homeomorph.of_embedding _ h₁.to_embedding).symm),
        { ext ⟨x, hx⟩, exact dif_pos hx },
        continuity },
      { exact h₁.open_range } },
    { revert h x,
      apply (is_open.continuous_on_iff _).mp,
      { rw continuous_on_iff_continuous_restrict,
        have : ∀ a, a ∉ set.range c.inl → a ∈ set.range c.inr,
        { rintros a (h : a ∈ (set.range c.inl)ᶜ), rwa eq_compl_iff_is_compl.mpr h₃.symm },
        convert_to continuous
          (g ∘ (homeomorph.of_embedding _ h₂.to_embedding).symm ∘ subtype.map _ this),
        { ext ⟨x, hx⟩, exact dif_neg hx },
        continuity,
        rw embedding_subtype_coe.to_inducing.continuous_iff,
        exact continuous_subtype_coe },
      { change is_open (set.range c.inl)ᶜ, rw ← eq_compl_iff_is_compl.mpr h₃.symm,
        exact h₂.open_range } } },
    { intros T f g, ext x, refine (dif_pos _).trans _, { exact ⟨x, rfl⟩ },
        { rw equiv.of_injective_symm_apply } },
    { intros T f g, ext x, refine (dif_neg _).trans _,
      { rintro ⟨y, e⟩, have : c.inr x ∈ set.range c.inl ⊓ set.range c.inr := ⟨⟨_, e⟩, ⟨_, rfl⟩⟩,
        rwa disjoint_iff.mp h₃.1 at this },
      { exact congr_arg g (equiv.of_injective_symm_apply _ _) } },
    { rintro T _ _ m rfl rfl, ext x, change m x = dite _ _ _,
      split_ifs; exact congr_arg _ (equiv.apply_of_injective_symm _ ⟨_, _⟩).symm } }
end

--TODO: Add analogous constructions for `pushout`.

lemma coinduced_of_is_colimit {F : J ⥤ Top.{max v u}} (c : cocone F) (hc : is_colimit c) :
  c.X.topological_space = ⨆ j, (F.obj j).topological_space.coinduced (c.ι.app j) :=
begin
  let homeo := homeo_of_iso (hc.cocone_point_unique_up_to_iso (colimit_cocone_is_colimit F)),
  ext,
  refine homeo.symm.is_open_preimage.symm.trans (iff.trans _ is_open_supr_iff.symm),
  exact is_open_supr_iff
end

lemma colimit_topology (F : J ⥤ Top.{max v u}) :
  (colimit F).topological_space = ⨆ j, (F.obj j).topological_space.coinduced (colimit.ι F j) :=
coinduced_of_is_colimit _ (colimit.is_colimit F)

lemma colimit_is_open_iff (F : J ⥤ Top.{max v u}) (U : set ((colimit F : _) : Type (max v u))) :
  is_open U ↔ ∀ j, is_open (colimit.ι F j ⁻¹' U) :=
begin
  conv_lhs { rw colimit_topology F },
  exact is_open_supr_iff
end

lemma coequalizer_is_open_iff (F : walking_parallel_pair ⥤ Top.{u})
  (U : set ((colimit F : _) : Type u)) :
  is_open U ↔ is_open (colimit.ι F walking_parallel_pair.one ⁻¹' U) :=
begin
  rw colimit_is_open_iff.{u},
  split,
  { intro H, exact H _ },
  { intros H j,
    cases j,
    { rw ←colimit.w F walking_parallel_pair_hom.left,
      exact (F.map walking_parallel_pair_hom.left).continuous_to_fun.is_open_preimage _ H },
    { exact H } }
end

end Top

namespace Top

section cofiltered_limit

variables {J : Type v} [small_category J] [is_cofiltered J] (F : J ⥤ Top.{max v u})
  (C : cone F) (hC : is_limit C)

include hC

/--
Given a *compatible* collection of topological bases for the factors in a cofiltered limit
which contain `set.univ` and are closed under intersections, the induced *naive* collection
of sets in the limit is, in fact, a topological basis.
-/
theorem is_topological_basis_cofiltered_limit
  (T : Π j, set (set (F.obj j))) (hT : ∀ j, is_topological_basis (T j))
  (univ : ∀ (i : J), set.univ ∈ T i)
  (inter : ∀ i (U1 U2 : set (F.obj i)), U1 ∈ T i → U2 ∈ T i → U1 ∩ U2 ∈ T i)
  (compat : ∀ (i j : J) (f : i ⟶ j) (V : set (F.obj j)) (hV : V ∈ T j), (F.map f) ⁻¹' V ∈ T i) :
  is_topological_basis { U : set C.X | ∃ j (V : set (F.obj j)), V ∈ T j ∧ U = C.π.app j ⁻¹' V } :=
begin
  classical,
  -- The limit cone for `F` whose topology is defined as an infimum.
  let D := limit_cone_infi F,
  -- The isomorphism between the cone point of `C` and the cone point of `D`.
  let E : C.X ≅ D.X := hC.cone_point_unique_up_to_iso (limit_cone_infi_is_limit _),
  have hE : inducing E.hom := (Top.homeo_of_iso E).inducing,
  -- Reduce to the assertion of the theorem with `D` instead of `C`.
  suffices : is_topological_basis
    { U : set D.X | ∃ j (V : set (F.obj j)), V ∈ T j ∧ U = D.π.app j ⁻¹' V },
  { convert this.inducing hE,
    ext U0,
    split,
    { rintro ⟨j, V, hV, rfl⟩,
      refine ⟨D.π.app j ⁻¹' V, ⟨j, V, hV, rfl⟩, rfl⟩ },
    { rintro ⟨W, ⟨j, V, hV, rfl⟩, rfl⟩,
      refine ⟨j, V, hV, rfl⟩ } },
  -- Using `D`, we can apply the characterization of the topological basis of a
  -- topology defined as an infimum...
  convert is_topological_basis_infi hT (λ j (x : D.X), D.π.app j x),
  ext U0,
  split,
  { rintros  ⟨j, V, hV, rfl⟩,
    let U : Π i, set (F.obj i) := λ i, if h : i = j then (by {rw h, exact V}) else set.univ,
    refine ⟨U,{j},_,_⟩,
    { rintro i h,
      rw finset.mem_singleton at h,
      dsimp [U],
      rw dif_pos h,
      subst h,
      exact hV },
    { dsimp [U],
      simp } },
  { rintros ⟨U, G, h1, h2⟩,
    obtain ⟨j, hj⟩ := is_cofiltered.inf_objs_exists G,
    let g : ∀ e (he : e ∈ G), j ⟶ e := λ _ he, (hj he).some,
    let Vs : J → set (F.obj j) := λ e, if h : e ∈ G then F.map (g e h) ⁻¹' (U e) else set.univ,
    let V : set (F.obj j) := ⋂ (e : J) (he : e ∈ G), Vs e,
    refine ⟨j, V, _, _⟩,
    { -- An intermediate claim used to apply induction along `G : finset J` later on.
      have : ∀ (S : set (set (F.obj j))) (E : finset J) (P : J → set (F.obj j))
        (univ : set.univ ∈ S)
        (inter : ∀ A B : set (F.obj j), A ∈ S → B ∈ S → A ∩ B ∈ S)
        (cond : ∀ (e : J) (he : e ∈ E), P e ∈ S), (⋂ e (he : e ∈ E), P e) ∈ S,
      { intros S E,
        apply E.induction_on,
        { intros P he hh,
          simpa },
        { intros a E ha hh1 hh2 hh3 hh4 hh5,
          rw finset.set_bInter_insert,
          refine hh4 _ _ (hh5 _ (finset.mem_insert_self _ _)) (hh1 _ hh3 hh4 _),
          intros e he,
          exact hh5 e (finset.mem_insert_of_mem he) } },
      -- use the intermediate claim to finish off the goal using `univ` and `inter`.
      refine this _ _ _ (univ _) (inter _) _,
      intros e he,
      dsimp [Vs],
      rw dif_pos he,
      exact compat j e (g e he) (U e) (h1 e he), },
    { -- conclude...
      rw h2,
      dsimp [V],
      rw set.preimage_Inter,
      congr' 1,
      ext1 e,
      rw set.preimage_Inter,
      congr' 1,
      ext1 he,
      dsimp [Vs],
      rw [dif_pos he, ← set.preimage_comp],
      congr' 1,
      change _ = ⇑(D.π.app j ≫ F.map (g e he)),
      rw D.w } }
end

end cofiltered_limit

section topological_konig

/-!
## Topological Kőnig's lemma

A topological version of Kőnig's lemma is that the inverse limit of nonempty compact Hausdorff
spaces is nonempty.  (Note: this can be generalized further to inverse limits of nonempty compact
T0 spaces, where all the maps are closed maps; see [Stone1979] --- however there is an erratum
for Theorem 4 that the element in the inverse limit can have cofinally many components that are
not closed points.)

We give this in a more general form, which is that cofiltered limits
of nonempty compact Hausdorff spaces are nonempty
(`nonempty_limit_cone_of_compact_t2_cofiltered_system`).

This also applies to inverse limits, where `{J : Type u} [preorder J] [is_directed J (≤)]` and
`F : Jᵒᵖ ⥤ Top`.

The theorem is specialized to nonempty finite types (which are compact Hausdorff with the
discrete topology) in lemmas `nonempty_sections_of_finite_cofiltered_system` and
`nonempty_sections_of_finite_inverse_system` in the file `category_theory.cofiltered_system`.

(See <https://stacks.math.columbia.edu/tag/086J> for the Set version.)
-/

variables {J : Type u} [small_category J]
variables (F : J ⥤ Top.{u})

private abbreviation finite_diagram_arrow {J : Type u} [small_category J] (G : finset J) :=
Σ' (X Y : J) (mX : X ∈ G) (mY : Y ∈ G), X ⟶ Y
private abbreviation finite_diagram (J : Type u) [small_category J] :=
Σ (G : finset J), finset (finite_diagram_arrow G)

/--
Partial sections of a cofiltered limit are sections when restricted to
a finite subset of objects and morphisms of `J`.
-/
def partial_sections {J : Type u} [small_category J] (F : J ⥤ Top.{u})
  {G : finset J} (H : finset (finite_diagram_arrow G)) : set (Π j, F.obj j) :=
{ u | ∀ {f : finite_diagram_arrow G} (hf : f ∈ H), F.map f.2.2.2.2 (u f.1) = u f.2.1 }

lemma partial_sections.nonempty [is_cofiltered_or_empty J] [h : Π (j : J), nonempty (F.obj j)]
  {G : finset J} (H : finset (finite_diagram_arrow G)) :
  (partial_sections F H).nonempty :=
begin
  classical,
  casesI is_empty_or_nonempty J,
  { exact ⟨is_empty_elim, λ j, is_empty.elim' infer_instance j.1⟩ },
  haveI : is_cofiltered J := ⟨⟩,
  use λ (j : J), if hj : j ∈ G
                 then F.map (is_cofiltered.inf_to G H hj) (h (is_cofiltered.inf G H)).some
                 else (h _).some,
  rintros ⟨X, Y, hX, hY, f⟩ hf,
  dsimp only,
  rwa [dif_pos hX, dif_pos hY, ←comp_app, ←F.map_comp,
       @is_cofiltered.inf_to_commutes _ _ _ G H],
end

lemma partial_sections.directed :
  directed superset (λ (G : finite_diagram J), partial_sections F G.2) :=
begin
  classical,
  intros A B,
  let ιA : finite_diagram_arrow A.1 → finite_diagram_arrow (A.1 ⊔ B.1) :=
    λ f, ⟨f.1, f.2.1, finset.mem_union_left _ f.2.2.1, finset.mem_union_left _ f.2.2.2.1,
          f.2.2.2.2⟩,
  let ιB : finite_diagram_arrow B.1 → finite_diagram_arrow (A.1 ⊔ B.1) :=
    λ f, ⟨f.1, f.2.1, finset.mem_union_right _ f.2.2.1, finset.mem_union_right _ f.2.2.2.1,
          f.2.2.2.2⟩,
  refine ⟨⟨A.1 ⊔ B.1, A.2.image ιA ⊔ B.2.image ιB⟩, _, _⟩,
  { rintro u hu f hf,
    have : ιA f ∈ A.2.image ιA ⊔ B.2.image ιB,
    { apply finset.mem_union_left,
      rw finset.mem_image,
      refine ⟨f, hf, rfl⟩ },
    exact hu this },
  { rintro u hu f hf,
    have : ιB f ∈ A.2.image ιA ⊔ B.2.image ιB,
    { apply finset.mem_union_right,
      rw finset.mem_image,
      refine ⟨f, hf, rfl⟩ },
    exact hu this }
end

lemma partial_sections.closed [Π (j : J), t2_space (F.obj j)]
  {G : finset J} (H : finset (finite_diagram_arrow G)) :
  is_closed (partial_sections F H) :=
begin
  have : partial_sections F H =
    ⋂ {f : finite_diagram_arrow G} (hf : f ∈ H), { u | F.map f.2.2.2.2 (u f.1) = u f.2.1 },
  { ext1,
    simp only [set.mem_Inter, set.mem_set_of_eq],
    refl, },
  rw this,
  apply is_closed_bInter,
  intros f hf,
  apply is_closed_eq,
  continuity,
end

/--
Cofiltered limits of nonempty compact Hausdorff spaces are nonempty topological spaces.
-/
lemma nonempty_limit_cone_of_compact_t2_cofiltered_system
  [is_cofiltered_or_empty J]
  [Π (j : J), nonempty (F.obj j)]
  [Π (j : J), compact_space (F.obj j)]
  [Π (j : J), t2_space (F.obj j)] :
  nonempty (Top.limit_cone.{u} F).X :=
begin
  classical,
  obtain ⟨u, hu⟩ := is_compact.nonempty_Inter_of_directed_nonempty_compact_closed
    (λ G, partial_sections F _)
    (partial_sections.directed F)
    (λ G, partial_sections.nonempty F _)
    (λ G, is_closed.is_compact (partial_sections.closed F _))
    (λ G, partial_sections.closed F _),
  use u,
  intros X Y f,
  let G : finite_diagram J :=
    ⟨{X, Y},
     {⟨X, Y,
      by simp only [true_or, eq_self_iff_true, finset.mem_insert],
      by simp only [eq_self_iff_true, or_true, finset.mem_insert, finset.mem_singleton],
      f⟩}⟩,
  exact hu _ ⟨G, rfl⟩ (finset.mem_singleton_self _),
end

end topological_konig

end Top


/-
Copyright (c) 2019 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Simon Hudon, Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.equiv.basic
import Mathlib.control.bifunctor
import Mathlib.PostPort

universes u v w

namespace Mathlib

/-!
# Functor and bifunctors can be applied to `equiv`s.

We define
```lean
def functor.map_equiv (f : Type u → Type v) [functor f] [is_lawful_functor f] :
  α ≃ β → f α ≃ f β
```
and
```lean
def bifunctor.map_equiv (F : Type u → Type v → Type w) [bifunctor F] [is_lawful_bifunctor F] :
  α ≃ β → α' ≃ β' → F α α' ≃ F β β'
```
-/

namespace functor

/-- Apply a functor to an `equiv`. -/
def map_equiv {α : Type u} {β : Type u} (f : Type u → Type v) [Functor f] [is_lawful_functor f]
    (h : α ≃ β) : f α ≃ f β :=
  equiv.mk (Functor.map ⇑h) (Functor.map ⇑(equiv.symm h)) sorry sorry

@[simp] theorem map_equiv_apply {α : Type u} {β : Type u} (f : Type u → Type v) [Functor f]
    [is_lawful_functor f] (h : α ≃ β) (x : f α) : coe_fn (map_equiv f h) x = ⇑h <$> x :=
  rfl

@[simp] theorem map_equiv_symm_apply {α : Type u} {β : Type u} (f : Type u → Type v) [Functor f]
    [is_lawful_functor f] (h : α ≃ β) (y : f β) :
    coe_fn (equiv.symm (map_equiv f h)) y = ⇑(equiv.symm h) <$> y :=
  rfl

@[simp] theorem map_equiv_refl {α : Type u} (f : Type u → Type v) [Functor f]
    [is_lawful_functor f] : map_equiv f (equiv.refl α) = equiv.refl (f α) :=
  sorry

end functor

namespace bifunctor

/-- Apply a bifunctor to a pair of `equiv`s. -/
def map_equiv {α : Type u} {β : Type u} {α' : Type v} {β' : Type v} (F : Type u → Type v → Type w)
    [bifunctor F] [is_lawful_bifunctor F] (h : α ≃ β) (h' : α' ≃ β') : F α α' ≃ F β β' :=
  equiv.mk (bimap ⇑h ⇑h') (bimap ⇑(equiv.symm h) ⇑(equiv.symm h')) sorry sorry

@[simp] theorem map_equiv_apply {α : Type u} {β : Type u} {α' : Type v} {β' : Type v}
    (F : Type u → Type v → Type w) [bifunctor F] [is_lawful_bifunctor F] (h : α ≃ β) (h' : α' ≃ β')
    (x : F α α') : coe_fn (map_equiv F h h') x = bimap (⇑h) (⇑h') x :=
  rfl

@[simp] theorem map_equiv_symm_apply {α : Type u} {β : Type u} {α' : Type v} {β' : Type v}
    (F : Type u → Type v → Type w) [bifunctor F] [is_lawful_bifunctor F] (h : α ≃ β) (h' : α' ≃ β')
    (y : F β β') :
    coe_fn (equiv.symm (map_equiv F h h')) y = bimap (⇑(equiv.symm h)) (⇑(equiv.symm h')) y :=
  rfl

@[simp] theorem map_equiv_refl_refl {α : Type u} {α' : Type v} (F : Type u → Type v → Type w)
    [bifunctor F] [is_lawful_bifunctor F] :
    map_equiv F (equiv.refl α) (equiv.refl α') = equiv.refl (F α α') :=
  sorry

end Mathlib


/-
Copyright (c) 2020 Kenji Nakagawa. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenji Nakagawa, Anne Baanen, Filippo A. E. Nuccio
-/
import ring_theory.ideal.over
import ring_theory.polynomial.rational_root

/-!
# Dedekind domains

This file defines the notion of a Dedekind domain (or Dedekind ring),
as a Noetherian integrally closed commutative ring of Krull dimension at most one.

## Main definitions

 - `is_dedekind_domain` defines a Dedekind domain as a commutative ring that is
   Noetherian, integrally closed in its field of fractions and has Krull dimension at most one.
   `is_dedekind_domain_iff` shows that this does not depend on the choice of field of fractions.

## Implementation notes

The definitions that involve a field of fractions choose a canonical field of fractions,
but are independent of that choice. The `..._iff` lemmas express this independence.

Often, definitions assume that Dedekind domains are not fields. We found it more practical
to add a `(h : ¬ is_field A)` assumption whenever this is explicitly needed.

## References

* [D. Marcus, *Number Fields*][marcus1977number]
* [J.W.S. Cassels, A. Frölich, *Algebraic Number Theory*][cassels1967algebraic]
* [J. Neukirch, *Algebraic Number Theory*][Neukirch1992]

## Tags

dedekind domain, dedekind ring
-/

variables (R A K : Type*) [comm_ring R] [comm_ring A] [field K]

open_locale non_zero_divisors polynomial

/-- A ring `R` has Krull dimension at most one if all nonzero prime ideals are maximal. -/
def ring.dimension_le_one : Prop :=
∀ p ≠ (⊥ : ideal R), p.is_prime → p.is_maximal

open ideal ring

namespace ring

lemma dimension_le_one.principal_ideal_ring
  [is_domain A] [is_principal_ideal_ring A] : dimension_le_one A :=
λ p nonzero prime, by { haveI := prime, exact is_prime.to_maximal_ideal nonzero }

lemma dimension_le_one.is_integral_closure (B : Type*) [comm_ring B] [is_domain B]
  [nontrivial R] [algebra R A] [algebra R B] [algebra B A] [is_scalar_tower R B A]
  [is_integral_closure B R A] (h : dimension_le_one R) :
  dimension_le_one B :=
λ p ne_bot prime, by exactI
  is_integral_closure.is_maximal_of_is_maximal_comap A p
    (h _ (is_integral_closure.comap_ne_bot A ne_bot) infer_instance)

lemma dimension_le_one.integral_closure [nontrivial R] [is_domain A] [algebra R A]
  (h : dimension_le_one R) : dimension_le_one (integral_closure R A) :=
h.is_integral_closure R A (integral_closure R A)

end ring

variables [is_domain A]

/--
A Dedekind domain is an integral domain that is Noetherian, integrally closed, and
has Krull dimension at most one.

This is definition 3.2 of [Neukirch1992].

The integral closure condition is independent of the choice of field of fractions:
use `is_dedekind_domain_iff` to prove `is_dedekind_domain` for a given `fraction_map`.

This is the default implementation, but there are equivalent definitions,
`is_dedekind_domain_dvr` and `is_dedekind_domain_inv`.
TODO: Prove that these are actually equivalent definitions.
-/
class is_dedekind_domain : Prop :=
(is_noetherian_ring : is_noetherian_ring A)
(dimension_le_one : dimension_le_one A)
(is_integrally_closed : is_integrally_closed A)

-- See library note [lower instance priority]
attribute [instance, priority 100]
  is_dedekind_domain.is_noetherian_ring is_dedekind_domain.is_integrally_closed

/-- An integral domain is a Dedekind domain iff and only if it is
Noetherian, has dimension ≤ 1, and is integrally closed in a given fraction field.
In particular, this definition does not depend on the choice of this fraction field. -/
lemma is_dedekind_domain_iff (K : Type*) [field K] [algebra A K] [is_fraction_ring A K] :
  is_dedekind_domain A ↔ is_noetherian_ring A ∧ dimension_le_one A ∧
    (∀ {x : K}, is_integral A x → ∃ y, algebra_map A K y = x) :=
⟨λ ⟨hr, hd, hi⟩, ⟨hr, hd, λ x, (is_integrally_closed_iff K).mp hi⟩,
 λ ⟨hr, hd, hi⟩, ⟨hr, hd, (is_integrally_closed_iff K).mpr @hi⟩⟩

@[priority 100] -- See library note [lower instance priority]
instance is_principal_ideal_ring.is_dedekind_domain [is_principal_ideal_ring A] :
  is_dedekind_domain A :=
⟨principal_ideal_ring.is_noetherian_ring,
 ring.dimension_le_one.principal_ideal_ring A,
 unique_factorization_monoid.is_integrally_closed⟩


/-
Copyright (c) 2019 Robert A. Spencer. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Robert A. Spencer, Markus Himmel
-/
import algebra.category.Group.basic
import category_theory.concrete_category
import category_theory.limits.shapes.kernels
import category_theory.linear
import linear_algebra.basic

/-!
# The category of `R`-modules

`Module.{v} R` is the category of bundled `R`-modules with carrier in the universe `v`. We show
that it is preadditive and show that being an isomorphism, monomorphism and epimorphism is
equivalent to being a linear equivalence, an injective linear map and a surjective linear map,
respectively.

## Implementation details

To construct an object in the category of `R`-modules from a type `M` with an instance of the
`module` typeclass, write `of R M`. There is a coercion in the other direction.

Similarly, there is a coercion from morphisms in `Module R` to linear maps.

Unfortunately, Lean is not smart enough to see that, given an object `M : Module R`, the expression
`of R M`, where we coerce `M` to the carrier type, is definitionally equal to `M` itself.
This means that to go the other direction, i.e., from linear maps/equivalences to (iso)morphisms
in the category of `R`-modules, we have to take care not to inadvertently end up with an
`of R M` where `M` is already an object. Hence, given `f : M →ₗ[R] N`,
* if `M N : Module R`, simply use `f`;
* if `M : Module R` and `N` is an unbundled `R`-module, use `↿f` or `as_hom_left f`;
* if `M` is an unbundled `R`-module and `N : Module R`, use `↾f` or `as_hom_right f`;
* if `M` and `N` are unbundled `R`-modules, use `↟f` or `as_hom f`.

Similarly, given `f : M ≃ₗ[R] N`, use `to_Module_iso`, `to_Module_iso'_left`, `to_Module_iso'_right`
or `to_Module_iso'`, respectively.

The arrow notations are localized, so you may have to `open_locale Module` to use them. Note that
the notation for `as_hom_left` clashes with the notation used to promote functions between types to
morphisms in the category `Type`, so to avoid confusion, it is probably a good idea to avoid having
the locales `Module` and `category_theory.Type` open at the same time.

If you get an error when trying to apply a theorem and the `convert` tactic produces goals of the
form `M = of R M`, then you probably used an incorrect variant of `as_hom` or `to_Module_iso`.

-/

open category_theory
open category_theory.limits
open category_theory.limits.walking_parallel_pair

universes v u

variables (R : Type u) [ring R]

/-- The category of R-modules and their morphisms.

 Note that in the case of `R = ℤ`, we can not
impose here that the `ℤ`-multiplication field from the module structure is defeq to the one coming
from the `is_add_comm_group` structure (contrary to what we do for all module structures in
mathlib), which creates some difficulties down the road. -/
structure Module :=
(carrier : Type v)
[is_add_comm_group : add_comm_group carrier]
[is_module : module R carrier]

attribute [instance] Module.is_add_comm_group Module.is_module

namespace Module

instance : has_coe_to_sort (Module.{v} R) :=
{ S := Type v, coe := Module.carrier }

instance Module_category : category (Module.{v} R) :=
{ hom   := λ M N, M →ₗ[R] N,
  id    := λ M, 1,
  comp  := λ A B C f g, g.comp f }

instance Module_concrete_category : concrete_category.{v} (Module.{v} R) :=
{ forget := { obj := λ R, R, map := λ R S f, (f : R → S) },
  forget_faithful := { } }

instance has_forget_to_AddCommGroup : has_forget₂ (Module R) AddCommGroup :=
{ forget₂ :=
  { obj := λ M, AddCommGroup.of M,
    map := λ M₁ M₂ f, linear_map.to_add_monoid_hom f } }

/-- The object in the category of R-modules associated to an R-module -/
def of (X : Type v) [add_comm_group X] [module R X] : Module R := ⟨X⟩

instance : has_zero (Module R) := ⟨of R punit⟩
instance : inhabited (Module R) := ⟨0⟩

@[simp]
lemma coe_of (X : Type u) [add_comm_group X] [module R X] : (of R X : Type u) = X := rfl

variables {R}

/-- Forgetting to the underlying type and then building the bundled object returns the original
module. -/
@[simps]
def of_self_iso (M : Module R) : Module.of R M ≅ M :=
{ hom := 𝟙 M, inv := 𝟙 M }

instance : subsingleton (of R punit) :=
by { rw coe_of R punit, apply_instance }

instance : has_zero_object (Module.{v} R) :=
{ zero := 0,
  unique_to := λ X,
  { default := (0 : punit →ₗ[R] X),
    uniq := λ _, linear_map.ext $ λ x,
      have h : x = 0, from dec_trivial,
      by simp only [h, linear_map.map_zero]},
  unique_from := λ X,
  { default := (0 : X →ₗ[R] punit),
    uniq := λ _, linear_map.ext $ λ x, dec_trivial } }

variables {R} {M N U : Module.{v} R}

@[simp] lemma id_apply (m : M) : (𝟙 M : M → M) m = m := rfl

@[simp] lemma coe_comp (f : M ⟶ N) (g : N ⟶ U) :
  ((f ≫ g) : M → U) = g ∘ f := rfl

lemma comp_def (f : M ⟶ N) (g : N ⟶ U) : f ≫ g = g.comp f := rfl

end Module

variables {R}
variables {X₁ X₂ : Type v}

/-- Reinterpreting a linear map in the category of `R`-modules. -/
def Module.as_hom [add_comm_group X₁] [module R X₁] [add_comm_group X₂] [module R X₂] :
  (X₁ →ₗ[R] X₂) → (Module.of R X₁ ⟶ Module.of R X₂) := id

localized "notation `↟` f : 1024 := Module.as_hom f" in Module

/-- Reinterpreting a linear map in the category of `R`-modules. -/
def Module.as_hom_right [add_comm_group X₁] [module R X₁] {X₂ : Module.{v} R} :
  (X₁ →ₗ[R] X₂) → (Module.of R X₁ ⟶ X₂) := id

localized "notation `↾` f : 1024 := Module.as_hom_right f" in Module

/-- Reinterpreting a linear map in the category of `R`-modules. -/
def Module.as_hom_left {X₁ : Module.{v} R} [add_comm_group X₂] [module R X₂] :
  (X₁ →ₗ[R] X₂) → (X₁ ⟶ Module.of R X₂) := id

localized "notation `↿` f : 1024 := Module.as_hom_left f" in Module

/-- Build an isomorphism in the category `Module R` from a `linear_equiv` between `module`s. -/
@[simps]
def linear_equiv.to_Module_iso
  {g₁ : add_comm_group X₁} {g₂ : add_comm_group X₂} {m₁ : module R X₁} {m₂ : module R X₂}
  (e : X₁ ≃ₗ[R] X₂) :
  Module.of R X₁ ≅ Module.of R X₂ :=
{ hom := (e : X₁ →ₗ[R] X₂),
  inv := (e.symm : X₂ →ₗ[R] X₁),
  hom_inv_id' := begin ext, exact e.left_inv x, end,
  inv_hom_id' := begin ext, exact e.right_inv x, end, }

/--
Build an isomorphism in the category `Module R` from a `linear_equiv` between `module`s.

This version is better than `linear_equiv_to_Module_iso` when applicable, because Lean can't see
`Module.of R M` is defeq to `M` when `M : Module R`. -/
@[simps]
def linear_equiv.to_Module_iso' {M N : Module.{v} R} (i : M ≃ₗ[R] N) : M ≅ N :=
{ hom := i,
  inv := i.symm,
  hom_inv_id' := linear_map.ext $ λ x, by simp,
  inv_hom_id' := linear_map.ext $ λ x, by simp }

/--
Build an isomorphism in the category `Module R` from a `linear_equiv` between `module`s.

This version is better than `linear_equiv_to_Module_iso` when applicable, because Lean can't see
`Module.of R M` is defeq to `M` when `M : Module R`. -/
@[simps]
def linear_equiv.to_Module_iso'_left {X₁ : Module.{v} R} {g₂ : add_comm_group X₂} {m₂ : module R X₂}
  (e : X₁ ≃ₗ[R] X₂) : X₁ ≅ Module.of R X₂ :=
{ hom := (e : X₁ →ₗ[R] X₂),
  inv := (e.symm : X₂ →ₗ[R] X₁),
  hom_inv_id' := linear_map.ext $ λ x, by simp,
  inv_hom_id' := linear_map.ext $ λ x, by simp }

/--
Build an isomorphism in the category `Module R` from a `linear_equiv` between `module`s.

This version is better than `linear_equiv_to_Module_iso` when applicable, because Lean can't see
`Module.of R M` is defeq to `M` when `M : Module R`. -/
@[simps]
def linear_equiv.to_Module_iso'_right {g₁ : add_comm_group X₁} {m₁ : module R X₁}
  {X₂ : Module.{v} R} (e : X₁ ≃ₗ[R] X₂) : Module.of R X₁ ≅ X₂ :=
{ hom := (e : X₁ →ₗ[R] X₂),
  inv := (e.symm : X₂ →ₗ[R] X₁),
  hom_inv_id' := linear_map.ext $ λ x, by simp,
  inv_hom_id' := linear_map.ext $ λ x, by simp }

namespace category_theory.iso

/-- Build a `linear_equiv` from an isomorphism in the category `Module R`. -/
@[simps]
def to_linear_equiv {X Y : Module R} (i : X ≅ Y) : X ≃ₗ[R] Y :=
{ to_fun    := i.hom,
  inv_fun   := i.inv,
  left_inv  := by tidy,
  right_inv := by tidy,
  map_add'  := by tidy,
  map_smul' := by tidy, }.

end category_theory.iso

/-- linear equivalences between `module`s are the same as (isomorphic to) isomorphisms
in `Module` -/
@[simps]
def linear_equiv_iso_Module_iso {X Y : Type u} [add_comm_group X] [add_comm_group Y] [module R X]
  [module R Y] :
  (X ≃ₗ[R] Y) ≅ (Module.of R X ≅ Module.of R Y) :=
{ hom := λ e, e.to_Module_iso,
  inv := λ i, i.to_linear_equiv, }

namespace Module

instance : preadditive (Module.{v} R) :=
{ add_comp' := λ P Q R f f' g,
    show (f + f') ≫ g = f ≫ g + f' ≫ g, by { ext, simp },
  comp_add' := λ P Q R f g g',
    show f ≫ (g + g') = f ≫ g + f ≫ g', by { ext, simp } }

section
variables {S : Type u} [comm_ring S]

instance : linear S (Module.{v} S) :=
{ hom_module := λ X Y, linear_map.module,
  smul_comp' := by { intros, ext, simp },
  comp_smul' := by { intros, ext, simp }, }

end

end Module

instance (M : Type u) [add_comm_group M] [module R M] : has_coe (submodule R M) (Module R) :=
⟨ λ N, Module.of R N ⟩


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

! This file was ported from Lean 3 source module algebra.module.ulift
! leanprover-community/mathlib commit 68d1483e8a718ec63219f0e227ca3f0140361086
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Ring.Ulift
import Mathbin.Algebra.Module.Equiv

/-!
# `ulift` instances for module and multiplicative actions

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

This file defines instances for module, mul_action and related structures on `ulift` types.

(Recall `ulift α` is just a "copy" of a type `α` in a higher universe.)

We also provide `ulift.module_equiv : ulift M ≃ₗ[R] M`.

-/

namespace ULift

universe u v w

variable {R : Type u}

variable {M : Type v}

variable {N : Type w}

#print ULift.smulLeft /-
@[to_additive]
instance smulLeft [SMul R M] : SMul (ULift R) M :=
  ⟨fun s x => s.down • x⟩
#align ulift.has_smul_left ULift.smulLeft
#align ulift.has_vadd_left ULift.vaddLeft
-/

/- warning: ulift.smul_def -> ULift.smul_def is a dubious translation:
lean 3 declaration is
  forall {R : Type.{u1}} {M : Type.{u2}} [_inst_1 : SMul.{u1, u2} R M] (s : ULift.{u3, u1} R) (x : M), Eq.{succ u2} M (SMul.smul.{max u1 u3, u2} (ULift.{u3, u1} R) M (ULift.smulLeft.{u1, u2, u3} R M _inst_1) s x) (SMul.smul.{u1, u2} R M _inst_1 (ULift.down.{u3, u1} R s) x)
but is expected to have type
  forall {R : Type.{u2}} {M : Type.{u3}} [_inst_1 : SMul.{u2, u3} R M] (s : ULift.{u1, u2} R) (x : M), Eq.{succ u3} M (HSMul.hSMul.{max u2 u1, u3, u3} (ULift.{u1, u2} R) M M (instHSMul.{max u2 u1, u3} (ULift.{u1, u2} R) M (ULift.smulLeft.{u2, u3, u1} R M _inst_1)) s x) (HSMul.hSMul.{u2, u3, u3} R M M (instHSMul.{u2, u3} R M _inst_1) (ULift.down.{u1, u2} R s) x)
Case conversion may be inaccurate. Consider using '#align ulift.smul_def ULift.smul_defₓ'. -/
@[simp, to_additive]
theorem smul_def [SMul R M] (s : ULift R) (x : M) : s • x = s.down • x :=
  rfl
#align ulift.smul_def ULift.smul_def
#align ulift.vadd_def ULift.vadd_def

#print ULift.isScalarTower /-
instance isScalarTower [SMul R M] [SMul M N] [SMul R N] [IsScalarTower R M N] :
    IsScalarTower (ULift R) M N :=
  ⟨fun x y z => show (x.down • y) • z = x.down • y • z from smul_assoc _ _ _⟩
#align ulift.is_scalar_tower ULift.isScalarTower
-/

#print ULift.isScalarTower' /-
instance isScalarTower' [SMul R M] [SMul M N] [SMul R N] [IsScalarTower R M N] :
    IsScalarTower R (ULift M) N :=
  ⟨fun x y z => show (x • y.down) • z = x • y.down • z from smul_assoc _ _ _⟩
#align ulift.is_scalar_tower' ULift.isScalarTower'
-/

#print ULift.isScalarTower'' /-
instance isScalarTower'' [SMul R M] [SMul M N] [SMul R N] [IsScalarTower R M N] :
    IsScalarTower R M (ULift N) :=
  ⟨fun x y z => show up ((x • y) • z.down) = ⟨x • y • z.down⟩ by rw [smul_assoc]⟩
#align ulift.is_scalar_tower'' ULift.isScalarTower''
-/

instance [SMul R M] [SMul Rᵐᵒᵖ M] [IsCentralScalar R M] : IsCentralScalar R (ULift M) :=
  ⟨fun r m => congr_arg up <| op_smul_eq_smul r m.down⟩

#print ULift.mulAction /-
@[to_additive]
instance mulAction [Monoid R] [MulAction R M] : MulAction (ULift R) M
    where
  smul := (· • ·)
  mul_smul _ _ := mul_smul _ _
  one_smul := one_smul _
#align ulift.mul_action ULift.mulAction
#align ulift.add_action ULift.addAction
-/

#print ULift.mulAction' /-
@[to_additive]
instance mulAction' [Monoid R] [MulAction R M] : MulAction R (ULift M)
    where
  smul := (· • ·)
  mul_smul := fun r s ⟨f⟩ => ext _ _ <| mul_smul _ _ _
  one_smul := fun ⟨f⟩ => ext _ _ <| one_smul _ _
#align ulift.mul_action' ULift.mulAction'
#align ulift.add_action' ULift.addAction'
-/

#print ULift.smulZeroClass /-
instance smulZeroClass [Zero M] [SMulZeroClass R M] : SMulZeroClass (ULift R) M :=
  { ULift.smulLeft with smul_zero := fun _ => smul_zero _ }
#align ulift.smul_zero_class ULift.smulZeroClass
-/

#print ULift.smulZeroClass' /-
instance smulZeroClass' [Zero M] [SMulZeroClass R M] : SMulZeroClass R (ULift M)
    where smul_zero c := by
    ext
    simp [smul_zero]
#align ulift.smul_zero_class' ULift.smulZeroClass'
-/

#print ULift.distribSmul /-
instance distribSmul [AddZeroClass M] [DistribSMul R M] : DistribSMul (ULift R) M
    where smul_add _ := smul_add _
#align ulift.distrib_smul ULift.distribSmul
-/

#print ULift.distribSmul' /-
instance distribSmul' [AddZeroClass M] [DistribSMul R M] : DistribSMul R (ULift M)
    where smul_add c f g := by
    ext
    simp [smul_add]
#align ulift.distrib_smul' ULift.distribSmul'
-/

#print ULift.distribMulAction /-
instance distribMulAction [Monoid R] [AddMonoid M] [DistribMulAction R M] :
    DistribMulAction (ULift R) M :=
  { ULift.mulAction, ULift.distribSmul with }
#align ulift.distrib_mul_action ULift.distribMulAction
-/

#print ULift.distribMulAction' /-
instance distribMulAction' [Monoid R] [AddMonoid M] [DistribMulAction R M] :
    DistribMulAction R (ULift M) :=
  { ULift.mulAction', ULift.distribSmul' with }
#align ulift.distrib_mul_action' ULift.distribMulAction'
-/

#print ULift.mulDistribMulAction /-
instance mulDistribMulAction [Monoid R] [Monoid M] [MulDistribMulAction R M] :
    MulDistribMulAction (ULift R) M
    where
  smul_one _ := smul_one _
  smul_mul _ := smul_mul' _
#align ulift.mul_distrib_mul_action ULift.mulDistribMulAction
-/

#print ULift.mulDistribMulAction' /-
instance mulDistribMulAction' [Monoid R] [Monoid M] [MulDistribMulAction R M] :
    MulDistribMulAction R (ULift M) :=
  {
    ULift.mulAction' with
    smul_one := fun _ => by
      ext
      simp [smul_one]
    smul_mul := fun c f g => by
      ext
      simp [smul_mul'] }
#align ulift.mul_distrib_mul_action' ULift.mulDistribMulAction'
-/

#print ULift.smulWithZero /-
instance smulWithZero [Zero R] [Zero M] [SMulWithZero R M] : SMulWithZero (ULift R) M :=
  { ULift.smulLeft with
    smul_zero := fun _ => smul_zero _
    zero_smul := zero_smul _ }
#align ulift.smul_with_zero ULift.smulWithZero
-/

#print ULift.smulWithZero' /-
instance smulWithZero' [Zero R] [Zero M] [SMulWithZero R M] : SMulWithZero R (ULift M)
    where
  smul_zero _ := ULift.ext _ _ <| smul_zero _
  zero_smul _ := ULift.ext _ _ <| zero_smul _ _
#align ulift.smul_with_zero' ULift.smulWithZero'
-/

#print ULift.mulActionWithZero /-
instance mulActionWithZero [MonoidWithZero R] [Zero M] [MulActionWithZero R M] :
    MulActionWithZero (ULift R) M :=
  { ULift.smulWithZero with }
#align ulift.mul_action_with_zero ULift.mulActionWithZero
-/

#print ULift.mulActionWithZero' /-
instance mulActionWithZero' [MonoidWithZero R] [Zero M] [MulActionWithZero R M] :
    MulActionWithZero R (ULift M) :=
  { ULift.smulWithZero' with }
#align ulift.mul_action_with_zero' ULift.mulActionWithZero'
-/

#print ULift.module /-
instance module [Semiring R] [AddCommMonoid M] [Module R M] : Module (ULift R) M :=
  { ULift.smulWithZero with add_smul := fun _ _ => add_smul _ _ }
#align ulift.module ULift.module
-/

#print ULift.module' /-
instance module' [Semiring R] [AddCommMonoid M] [Module R M] : Module R (ULift M) :=
  { ULift.smulWithZero' with add_smul := fun _ _ _ => ULift.ext _ _ <| add_smul _ _ _ }
#align ulift.module' ULift.module'
-/

#print ULift.moduleEquiv /-
/-- The `R`-linear equivalence between `ulift M` and `M`.
-/
@[simps apply symm_apply]
def moduleEquiv [Semiring R] [AddCommMonoid M] [Module R M] : ULift M ≃ₗ[R] M
    where
  toFun := ULift.down
  invFun := ULift.up
  map_smul' r x := rfl
  map_add' x y := rfl
  left_inv := by tidy
  right_inv := by tidy
#align ulift.module_equiv ULift.moduleEquiv
-/

end ULift


import algebraic_geometry.morphisms.universally_closed
import algebraic_geometry.morphisms.quasi_compact
import ring_theory.valuation.valuation_ring

noncomputable theory

open category_theory
open category_theory.morphism_property
open algebraic_geometry.morphism_property (topologically)
open algebraic_geometry.Scheme

universes u v

namespace category_theory

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

structure commutative_square :=
/-
tl ----> tr
|         |
|         |
bl ----> br
-/
{tl tr bl br : C} -- t for top; b for bottom; l for left; r for right
(v1 : tl ⟶ bl) (v2 : tr ⟶ br) (h1 : tl ⟶ tr) (h2 : bl ⟶ br)
(commutes : v1 ≫ h2 = h1 ≫ v2 . obviously)

variables {C}

def commutative_square.is_diagnol' (S : commutative_square C) (d : S.bl ⟶ S.tr) : Prop :=
  S.v1 ≫ d = S.h1 ∧ -- top triangle
  d ≫ S.v2 = S.h2

def commutative_square.exists_diagnol' (S : commutative_square C) : Prop :=
∃ (d : S.bl ⟶ S.tr), S.is_diagnol' d

def commutative_square.diagnol'_unique (S : commutative_square C) : Prop :=
∀ (d d' : S.bl ⟶ S.tr), S.is_diagnol' d → S.is_diagnol' d' → d = d'

end category_theory

structure valuative_pair :=
(ring_ : Type u) (fraction_field_ : Type u)
-- assumption on ring part
[is_comm_ring : comm_ring ring_]
[is_domain : is_domain ring_]
[is_valuation_ring : valuation_ring ring_]
-- assumption on fraction field part
[is_field : field fraction_field_]
[is_algebra : algebra ring_ fraction_field_]
[is_fractional : is_fraction_ring ring_ fraction_field_]

attribute [instance]
  valuative_pair.is_comm_ring
  valuative_pair.is_domain
  valuative_pair.is_valuation_ring
  valuative_pair.is_field
  valuative_pair.is_algebra
  valuative_pair.is_fractional

instance (P : valuative_pair) : algebra (CommRing.of P.ring_) (CommRing.of P.fraction_field_) := P.is_algebra
instance (P : valuative_pair) : is_domain (CommRing.of P.ring_) := P.is_domain
instance (P : valuative_pair) : valuation_ring (CommRing.of P.ring_) := P.is_valuation_ring
instance (P : valuative_pair) : local_ring (CommRing.of P.ring_) := valuation_ring.local_ring (CommRing.of P.ring_)

namespace Top

def specialization_lift_along : morphism_property Top.{u} :=
λ X Y g, ∀ ⦃y' y : Y⦄ (h : y' ⤳ y) (x' : X) (h' : g x' = y'), ∃ (x : X) (hx : x' ⤳ x), g x = y

-- **0064**
lemma specialization_lift_along.comp {X Y Z : Top.{u}} (f : X ⟶ Y) (g : Y ⟶ Z)
  (hf : specialization_lift_along f) (hg : specialization_lift_along g) :
  specialization_lift_along $ f ≫ g :=
λ y' y h x' h',
begin
  obtain ⟨a, ha1, ha2⟩ := hg h (f x') h',
  obtain ⟨x, hx1, hx2⟩ := hf ha1 x' rfl,
  refine ⟨x, hx1, _⟩,
  rw [comp_apply, hx2, ha2],
end

-- **0066 a)**
lemma specialization_lift_along_of_closed {X Y : Top.{u}} (g : X ⟶ Y) (hg : is_closed_map g) :
  specialization_lift_along g :=
λ y' y hy x' hx',
begin
  let T : set X := closure {x'},
  have hT : is_closed T := is_closed_closure,
  let S : set Y := g '' T,
  have hS : is_closed S := hg _ hT,
  have y'_mem : g x' ∈ S := ⟨x', subset_closure (set.mem_singleton _), rfl⟩,
  rw hx' at y'_mem,
  obtain ⟨x, hx1, hx2⟩ := hy.mem_closed hS y'_mem,
  exact ⟨x, specializes_iff_mem_closure.mpr hx1, hx2⟩,
end

end Top

namespace algebraic_geometry

variables {X S : Scheme.{u}} (f : X ⟶ S)

def specialization_lift_along : morphism_property Scheme.{u} :=
λ X Y g, Top.specialization_lift_along g.1.base

def universally_specialization_lift_along : morphism_property Scheme.{u} :=
universally specialization_lift_along

-- **01KC a)**
lemma universally_specialization_lift_along_of_universally_closed [universally_closed f] :
  universally_specialization_lift_along f :=
λ X' S' i₁ i₂ f' H, Top.specialization_lift_along_of_closed _ $ universally_closed.out _ _ _ H

-- **01K9**
-- Need reduced induced strucutre of scheme
-- but this is fundamentally a topological question, so perhaps we don't have to be so fancy
lemma closed_iff_specialization_lift_along_of_quasi_compact [quasi_compact f] :
  is_closed_map f.1.base ↔ specialization_lift_along f :=
{ mp := λ h, Top.specialization_lift_along_of_closed _ h,
  mpr := sorry }

-- **01KC b)**
lemma universally_closed_of_quasicompact_and_universally_specialization_lift_along
  [quasi_compact f] (h1 : universally_specialization_lift_along f) :
  universally_closed f :=
{ out := λ X' Y' i₁ i₂ f' H,
  begin
    haveI : quasi_compact f' := quasi_compact_stable_under_base_change H.flip infer_instance,
    refine (closed_iff_specialization_lift_along_of_quasi_compact _).mpr (h1 _ _ _ H),
  end }

lemma universally_closed_iff_universally_specialization_lift_along_of_quasi_compact [quasi_compact f] :
  universally_closed f ↔ universally_specialization_lift_along f :=
⟨λ i, by exactI universally_specialization_lift_along_of_universally_closed f,
λ i, by exactI universally_closed_of_quasicompact_and_universally_specialization_lift_along f i⟩

alias category_theory.commutative_square ← commutative_square

def valuative_pair.Scheme_square (P : valuative_pair) ⦃X S : Scheme.{u}⦄ (f : X ⟶ S) (h1 h2 commutes) : commutative_square Scheme.{u} :=
{ v1 := Spec_map (algebra_map (CommRing.of P.ring_) (CommRing.of P.fraction_field_)),
  v2 := f,
  h1 := h1,
  h2 := h2 }

def valuative_pair.closed_point (P : valuative_pair) : (Spec_obj (CommRing.of P.ring_)).carrier :=
⟨_, ideal.is_maximal.is_prime' (local_ring.maximal_ideal _)⟩

lemma valuative_pair.closed_point_is_maximal_ideal (P : valuative_pair) :
  ideal.is_maximal P.closed_point.as_ideal :=
local_ring.maximal_ideal.is_maximal _

lemma valuative_pair.closed_point_is_closed (P : valuative_pair) : is_closed ({P.closed_point} : set $ (Spec_obj (CommRing.of P.ring_)).carrier) :=
begin
  rw prime_spectrum.is_closed_iff_zero_locus,
  refine ⟨P.closed_point.as_ideal, _⟩,
  rw ←prime_spectrum.closure_singleton,
  ext, simp only [set.mem_singleton_iff], split,
  { rintros rfl, refine subset_closure (set.mem_singleton _), },
  { intros h, rw ←prime_spectrum.le_iff_mem_closure at h,
    ext1, symmetry,
    refine ideal.is_maximal.eq_of_le P.closed_point_is_maximal_ideal x.is_prime.ne_top h, },
end

lemma valuative_pair.closed_point_unique
  (P : valuative_pair) {x : (Spec_obj (CommRing.of P.ring_)).carrier}
  (hx : is_closed ({x} : set $ (Spec_obj (CommRing.of P.ring_)).carrier)) :
  x = P.closed_point :=
begin
  rw prime_spectrum.is_closed_singleton_iff_is_maximal x at hx,
  ext : 1,
  convert local_ring.eq_maximal_ideal hx,
end

def valuative_pair.generic_point (P : valuative_pair) : (Spec_obj (CommRing.of P.ring_)).carrier :=
⟨⊥ , ideal.bot_prime⟩

lemma valuative_pair.generic_point_is_generic (P : valuative_pair) : is_generic_point P.generic_point set.univ :=
begin
  rw [is_generic_point_def, set.eq_univ_iff_forall],
  intros x,
  rw ←prime_spectrum.le_iff_mem_closure,
  exact bot_le,
end

lemma valuative_pair.generic_point_unique
  (P : valuative_pair) {x : (Spec_obj (CommRing.of P.ring_)).carrier}
  (hx : is_generic_point x set.univ) : x = P.generic_point :=
begin
  have h := hx.trans P.generic_point_is_generic.symm,
  have h1 := (prime_spectrum.le_iff_mem_closure x P.generic_point).mpr (h.symm ▸ subset_closure (set.mem_singleton _)),
  have h2 := (prime_spectrum.le_iff_mem_closure P.generic_point x).mpr (h ▸ subset_closure (set.mem_singleton _)),
  ext1,
  refine le_antisymm h1 h2,
end

-- **01J8 1)** but stacks says more
lemma morphisms_from_specialization {S : Scheme.{u}} {s' s : S.carrier} (hs : s' ⤳ s) :
  ∃ (P : valuative_pair) (f : Spec_obj (CommRing.of P.ring_) ⟶ S),
    (f : Spec_obj (CommRing.of P.ring_) ⟶ S).1.base P.generic_point = s' ∧
    (f : Spec_obj (CommRing.of P.ring_) ⟶ S).1.base P.closed_point = s := sorry

-- **01KD**
def valuative_criterion_existence_part : morphism_property Scheme.{u} :=
λ X S f, ∀ (P : valuative_pair) (h1 h2) (commutes),
  (P.Scheme_square f h1 h2 commutes).exists_diagnol'

-- **01KD**
def valuative_criterion_uniqueness_part : morphism_property Scheme.{u} :=
λ X S f, ∀ (P : valuative_pair) (h1 h2) (commutes), (P.Scheme_square f h1 h2 commutes).diagnol'_unique

-- **00KE**
lemma universally_specialization_lift_along_iff_valuative_criterion_existence_part :
  universally_specialization_lift_along f ↔ valuative_criterion_existence_part f :=
sorry

-- **01KF**
lemma valuative_criterion_for_universally_closedness [quasi_compact f] :
  universally_closed f ↔ valuative_criterion_existence_part f :=
(universally_closed_iff_universally_specialization_lift_along_of_quasi_compact f).trans $
universally_specialization_lift_along_iff_valuative_criterion_existence_part f

end algebraic_geometry


import algebra.group data.equiv algebra.module

#check is_group_hom
#print equiv.Pi_congr_right

#print out_param

#print module

universe u
definition Pi_lift_map₁ {γ : Type u} {F : γ → Type u} {G : γ → Type u}
  (H : ∀ i : γ, F i → G i) : (Π i, F i) → Π i, G i := λ Fi i, H i (Fi i)

class foomap {α β : Type u} (f : α → β) :=
(preserves_structure : ∀ a : α, f a = f a)

instance Pi_foomap_is_foomap {γ : Type u} {F : γ → Type u} {G : γ → Type u}
(H : ∀ i : γ, F i → G i) [∀ i, foomap (H i)] : foomap (Pi_lift_map₁ H) := sorry

example {γ : Type u} {F : γ → Type u} {G : γ → Type u}
(H : ∀ i : γ, F i → G i) [∀ i, foomap (H i)] : foomap (Pi_lift_map₁ H) := by apply_instance

example {γ : Type u} {F : γ → Type u} {G : γ → Type u}
(H : ∀ i : γ, F i → G i) [∀ i, foomap (H i)] : (Pi_lift_map₁ H) = (λ Fi i, H i (Fi i) : (Π i, F i) → Π i, G i) := rfl

example {γ : Type u} {F : γ → Type u} {G : γ → Type u}
(H : ∀ i : γ, F i → G i) [∀ i, foomap (H i)] : foomap (λ Fi i, H i (Fi i) : (Π i, F i) → Π i, G i) := by apply_instance -- fails

#check module


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.natural_isomorphism
import Mathlib.category_theory.eq_to_hom
import Mathlib.data.sigma.basic
import Mathlib.category_theory.pi.basic
import Mathlib.PostPort

universes w₁ v₁ u₁ l u₂ v₂ w₂ w₃

namespace Mathlib

/-!
# Disjoint union of categories

We define the category structure on a sigma-type (disjoint union) of categories.
-/

namespace category_theory

namespace sigma

/--
The type of morphisms of a disjoint union of categories: for `X : C i` and `Y : C j`, a morphism
`(i, X) ⟶ (j, Y)` if `i = j` is just a morphism `X ⟶ Y`, and if `i ≠ j` there are no such morphisms.
-/
inductive sigma_hom {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)] :
    (sigma fun (i : I) => C i) → (sigma fun (i : I) => C i) → Type (max w₁ v₁ u₁)
    where
| mk : {i : I} → {X Y : C i} → (X ⟶ Y) → sigma_hom (sigma.mk i X) (sigma.mk i Y)

namespace sigma_hom

/-- The identity morphism on an object. -/
def id {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)] (X : sigma fun (i : I) => C i) :
    sigma_hom X X :=
  sorry

protected instance inhabited {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)]
    (X : sigma fun (i : I) => C i) : Inhabited (sigma_hom X X) :=
  { default := id X }

/-- Composition of sigma homomorphisms. -/
def comp {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)] {X : sigma fun (i : I) => C i}
    {Y : sigma fun (i : I) => C i} {Z : sigma fun (i : I) => C i} :
    sigma_hom X Y → sigma_hom Y Z → sigma_hom X Z :=
  sorry

protected instance sigma.category_theory.category_struct {I : Type w₁} {C : I → Type u₁}
    [(i : I) → category (C i)] : category_struct (sigma fun (i : I) => C i) :=
  category_struct.mk id fun (X Y Z : sigma fun (i : I) => C i) (f : X ⟶ Y) (g : Y ⟶ Z) => comp f g

@[simp] theorem comp_def {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)] (i : I)
    (X : C i) (Y : C i) (Z : C i) (f : X ⟶ Y) (g : Y ⟶ Z) : comp (mk f) (mk g) = mk (f ≫ g) :=
  rfl

theorem assoc {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)]
    (X : sigma fun (i : I) => C i) (Y : sigma fun (i : I) => C i) (Z : sigma fun (i : I) => C i)
    (W : sigma fun (i : I) => C i) (f : X ⟶ Y) (g : Y ⟶ Z) (h : Z ⟶ W) : (f ≫ g) ≫ h = f ≫ g ≫ h :=
  sorry

theorem id_comp {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)]
    (X : sigma fun (i : I) => C i) (Y : sigma fun (i : I) => C i) (f : X ⟶ Y) : 𝟙 ≫ f = f :=
  sorry

theorem comp_id {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)]
    (X : sigma fun (i : I) => C i) (Y : sigma fun (i : I) => C i) (f : X ⟶ Y) : f ≫ 𝟙 = f :=
  sorry

end sigma_hom

protected instance sigma {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)] :
    category (sigma fun (i : I) => C i) :=
  category.mk

/-- The inclusion functor into the disjoint union of categories. -/
@[simp] theorem incl_map {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)] (i : I)
    (X : C i) (Y : C i) : ∀ (ᾰ : X ⟶ Y), functor.map (incl i) ᾰ = sigma_hom.mk ᾰ :=
  fun (ᾰ : X ⟶ Y) => Eq.refl (functor.map (incl i) ᾰ)

@[simp] theorem incl_obj {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)] {i : I}
    (X : C i) : functor.obj (incl i) X = sigma.mk i X :=
  rfl

protected instance incl.category_theory.full {I : Type w₁} {C : I → Type u₁}
    [(i : I) → category (C i)] (i : I) : full (incl i) :=
  full.mk fun (X Y : C i) (_x : functor.obj (incl i) X ⟶ functor.obj (incl i) Y) => sorry

protected instance incl.category_theory.faithful {I : Type w₁} {C : I → Type u₁}
    [(i : I) → category (C i)] (i : I) : faithful (incl i) :=
  faithful.mk

/--
To build a natural transformation over the sigma category, it suffices to specify it restricted to
each subcategory.
-/
def nat_trans {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)] {D : Type u₂} [category D]
    {F : (sigma fun (i : I) => C i) ⥤ D} {G : (sigma fun (i : I) => C i) ⥤ D}
    (h : (i : I) → incl i ⋙ F ⟶ incl i ⋙ G) : F ⟶ G :=
  nat_trans.mk fun (_x : sigma fun (i : I) => C i) => sorry

@[simp] theorem nat_trans_app {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)]
    {D : Type u₂} [category D] {F : (sigma fun (i : I) => C i) ⥤ D}
    {G : (sigma fun (i : I) => C i) ⥤ D} (h : (i : I) → incl i ⋙ F ⟶ incl i ⋙ G) (i : I) (X : C i) :
    nat_trans.app (nat_trans h) (sigma.mk i X) = nat_trans.app (h i) X :=
  rfl

/-- (Implementation). An auxiliary definition to build the functor `desc`. -/
def desc_map {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)] {D : Type u₂} [category D]
    (F : (i : I) → C i ⥤ D) (X : sigma fun (i : I) => C i) (Y : sigma fun (i : I) => C i) :
    (X ⟶ Y) →
        (functor.obj (F (sigma.fst X)) (sigma.snd X) ⟶
          functor.obj (F (sigma.fst Y)) (sigma.snd Y)) :=
  sorry

/--
Given a collection of functors `F i : C i ⥤ D`, we can produce a functor `(Σ i, C i) ⥤ D`.

The produced functor `desc F` satisfies: `incl i ⋙ desc F ≅ F i`, i.e. restricted to just the
subcategory `C i`, `desc F` agrees with `F i`, and it is unique (up to natural isomorphism) with
this property.

This witnesses that the sigma-type is the coproduct in Cat.
-/
@[simp] theorem desc_obj {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)] {D : Type u₂}
    [category D] (F : (i : I) → C i ⥤ D) (X : sigma fun (i : I) => C i) :
    functor.obj (desc F) X = functor.obj (F (sigma.fst X)) (sigma.snd X) :=
  Eq.refl (functor.obj (desc F) X)

@[simp] theorem desc_map_mk {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)] {D : Type u₂}
    [category D] (F : (i : I) → C i ⥤ D) {i : I} (X : C i) (Y : C i) (f : X ⟶ Y) :
    functor.map (desc F) (sigma_hom.mk f) = functor.map (F i) f :=
  rfl

/--
This shows that when `desc F` is restricted to just the subcategory `C i`, `desc F` agrees with
`F i`.
-/
-- We hand-generate the simp lemmas about this since they come out cleaner.

def incl_desc {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)] {D : Type u₂} [category D]
    (F : (i : I) → C i ⥤ D) (i : I) : incl i ⋙ desc F ≅ F i :=
  nat_iso.of_components (fun (X : C i) => iso.refl (functor.obj (incl i ⋙ desc F) X)) sorry

@[simp] theorem incl_desc_hom_app {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)]
    {D : Type u₂} [category D] (F : (i : I) → C i ⥤ D) (i : I) (X : C i) :
    nat_trans.app (iso.hom (incl_desc F i)) X = 𝟙 :=
  rfl

@[simp] theorem incl_desc_inv_app {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)]
    {D : Type u₂} [category D] (F : (i : I) → C i ⥤ D) (i : I) (X : C i) :
    nat_trans.app (iso.inv (incl_desc F i)) X = 𝟙 :=
  rfl

/--
If `q` when restricted to each subcategory `C i` agrees with `F i`, then `q` is isomorphic to
`desc F`.
-/
def desc_uniq {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)] {D : Type u₂} [category D]
    (F : (i : I) → C i ⥤ D) (q : (sigma fun (i : I) => C i) ⥤ D) (h : (i : I) → incl i ⋙ q ≅ F i) :
    q ≅ desc F :=
  nat_iso.of_components (fun (_x : sigma fun (i : I) => C i) => sorry) sorry

@[simp] theorem desc_uniq_hom_app {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)]
    {D : Type u₂} [category D] (F : (i : I) → C i ⥤ D) (q : (sigma fun (i : I) => C i) ⥤ D)
    (h : (i : I) → incl i ⋙ q ≅ F i) (i : I) (X : C i) :
    nat_trans.app (iso.hom (desc_uniq F q h)) (sigma.mk i X) = nat_trans.app (iso.hom (h i)) X :=
  rfl

@[simp] theorem desc_uniq_inv_app {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)]
    {D : Type u₂} [category D] (F : (i : I) → C i ⥤ D) (q : (sigma fun (i : I) => C i) ⥤ D)
    (h : (i : I) → incl i ⋙ q ≅ F i) (i : I) (X : C i) :
    nat_trans.app (iso.inv (desc_uniq F q h)) (sigma.mk i X) = nat_trans.app (iso.inv (h i)) X :=
  rfl

/--
If `q₁` and `q₂` when restricted to each subcategory `C i` agree, then `q₁` and `q₂` are isomorphic.
-/
@[simp] theorem nat_iso_inv {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)] {D : Type u₂}
    [category D] {q₁ : (sigma fun (i : I) => C i) ⥤ D} {q₂ : (sigma fun (i : I) => C i) ⥤ D}
    (h : (i : I) → incl i ⋙ q₁ ≅ incl i ⋙ q₂) :
    iso.inv (nat_iso h) = nat_trans fun (i : I) => iso.inv (h i) :=
  Eq.refl (iso.inv (nat_iso h))

/-- A function `J → I` induces a functor `Σ j, C (g j) ⥤ Σ i, C i`. -/
def map {I : Type w₁} (C : I → Type u₁) [(i : I) → category (C i)] {J : Type w₂} (g : J → I) :
    (sigma fun (j : J) => C (g j)) ⥤ sigma fun (i : I) => C i :=
  desc fun (j : J) => incl (g j)

@[simp] theorem map_obj {I : Type w₁} (C : I → Type u₁) [(i : I) → category (C i)] {J : Type w₂}
    (g : J → I) (j : J) (X : C (g j)) : functor.obj (map C g) (sigma.mk j X) = sigma.mk (g j) X :=
  rfl

@[simp] theorem map_map {I : Type w₁} (C : I → Type u₁) [(i : I) → category (C i)] {J : Type w₂}
    (g : J → I) {j : J} {X : C (g j)} {Y : C (g j)} (f : X ⟶ Y) :
    functor.map (map C g) (sigma_hom.mk f) = sigma_hom.mk f :=
  rfl

/--
The functor `sigma.map C g` restricted to the subcategory `C j` acts as the inclusion of `g j`.
-/
@[simp] theorem incl_comp_map_hom_app {I : Type w₁} (C : I → Type u₁) [(i : I) → category (C i)]
    {J : Type w₂} (g : J → I) (j : J) (X : C (g j)) :
    nat_trans.app (iso.hom (incl_comp_map C g j)) X = 𝟙 :=
  Eq.refl 𝟙

/-- The functor `sigma.map` applied to the identity function is just the identity functor. -/
@[simp] theorem map_id_hom_app (I : Type w₁) (C : I → Type u₁) [(i : I) → category (C i)]
    (_x : sigma fun (i : I) => (fun (i : I) => (fun (i : I) => C (id i)) i) i) :
    nat_trans.app (iso.hom (map_id I C)) _x =
        nat_trans._match_1
          (fun (i : I) =>
            iso.hom
              (nat_iso.of_components (fun (X : C i) => iso.refl (sigma.mk i X))
                (map_id._proof_1 I C i)))
          _x :=
  sorry

/-- The functor `sigma.map` applied to a composition is a composition of functors. -/
@[simp] theorem map_comp_hom_app {I : Type w₁} (C : I → Type u₁) [(i : I) → category (C i)]
    {J : Type w₂} {K : Type w₃} (f : K → J) (g : J → I)
    (X : sigma fun (i : K) => (fun (j : K) => function.comp C g (f j)) i) :
    nat_trans.app (iso.hom (map_comp C f g)) X =
        iso.hom
          (desc_uniq._match_1 (fun (j : K) => incl (g (f j))) (map (C ∘ g) f ⋙ map C g)
            (fun (k : K) =>
              iso_whisker_right (incl_comp_map (C ∘ g) f k) (map C g) ≪≫ incl_comp_map C g (f k))
            X) :=
  sorry

namespace functor

/--
Assemble an `I`-indexed family of functors into a functor between the sigma types.
-/
def sigma {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)] {D : I → Type u₁}
    [(i : I) → category (D i)] (F : (i : I) → C i ⥤ D i) :
    (sigma fun (i : I) => C i) ⥤ sigma fun (i : I) => D i :=
  desc fun (i : I) => F i ⋙ incl i

end functor

namespace nat_trans

/--
Assemble an `I`-indexed family of natural transformations into a single natural transformation.
-/
def sigma {I : Type w₁} {C : I → Type u₁} [(i : I) → category (C i)] {D : I → Type u₁}
    [(i : I) → category (D i)] {F : (i : I) → C i ⥤ D i} {G : (i : I) → C i ⥤ D i}
    (α : (i : I) → F i ⟶ G i) : functor.sigma F ⟶ functor.sigma G :=
  nat_trans.mk
    fun (f : sigma fun (i : I) => C i) =>
      sigma_hom.mk (nat_trans.app (α (sigma.fst f)) (sigma.snd f))

end Mathlib


example (P : Prop) : ∀ {p : P}, P := by
  exact fun {p} => p

example (P : Prop) : ∀ {p : P}, P := by
  intro h; exact h

example (P : Prop) : ∀ {p : P}, P := by
  exact @id _

example (P : Prop) : ∀ {p : P}, P := by
  exact noImplicitLambda% id

macro "exact'" x:term : tactic => `(exact noImplicitLambda% $x)

example (P : Prop) : ∀ {p : P}, P := by
  exact' id

example (P : Prop) : ∀ {p : P}, P := by
  apply id

example (P : Prop) : ∀ p : P, P := by
  have : _ := 1
  apply id

example (P : Prop) : ∀ {p : P}, P := by
  refine noImplicitLambda% (have : _ := 1; ?_)
  apply id

example (P : Prop) : ∀ {p : P}, P := by
  have : _ := 1
  apply id