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

/-!
# The category of small categories has all small limits.

An object in the limit consists of a family of objects,
which are carried to one another by the functors in the diagram.
A morphism between two such objects is a family of morphisms between the corresponding objects,
which are carried to one another by the action on morphisms of the functors in the diagram.

## Future work
Can the indexing category live in a lower universe?
-/

noncomputable theory

universes v u

open category_theory.limits

namespace category_theory

variables {J : Type v} [small_category J]

namespace Cat

namespace has_limits

instance category_objects {F : J ⥤ Cat.{u u}} {j} :
  small_category ((F ⋙ Cat.objects.{u u}).obj j) :=
(F.obj j).str

/-- Auxiliary definition:
the diagram whose limit gives the morphism space between two objects of the limit category. -/
@[simps]
def hom_diagram {F : J ⥤ Cat.{v v}} (X Y : limit (F ⋙ Cat.objects.{v v})) : J ⥤ Type v :=
{ obj := λ j, limit.π (F ⋙ Cat.objects) j X ⟶ limit.π (F ⋙ Cat.objects) j Y,
  map := λ j j' f g,
  begin
    refine eq_to_hom _ ≫ (F.map f).map g ≫ eq_to_hom _,
    exact (congr_fun (limit.w (F ⋙ Cat.objects) f) X).symm,
    exact (congr_fun (limit.w (F ⋙ Cat.objects) f) Y),
  end,
  map_id' := λ X, begin
    ext f, dsimp,
    simp [functor.congr_hom (F.map_id X) f],
  end,
  map_comp' := λ X Y Z f g, begin
    ext h, dsimp,
    simp [functor.congr_hom (F.map_comp f g) h, eq_to_hom_map],
    refl,
  end, }

@[simps]
instance (F : J ⥤ Cat.{v v}) : category (limit (F ⋙ Cat.objects)) :=
{ hom := λ X Y, limit (hom_diagram X Y),
  id := λ X, types.limit.mk.{v v} (hom_diagram X X) (λ j, 𝟙 _) (λ j j' f, by simp),
  comp := λ X Y Z f g, types.limit.mk.{v v} (hom_diagram X Z)
    (λ j, limit.π (hom_diagram X Y) j f ≫ limit.π (hom_diagram Y Z) j g)
    (λ j j' h, begin
      rw [←congr_fun (limit.w (hom_diagram X Y) h) f, ←congr_fun (limit.w (hom_diagram Y Z) h) g],
      dsimp,
      simp,
    end), }

/-- Auxiliary definition: the limit category. -/
@[simps]
def limit_cone_X (F : J ⥤ Cat.{v v}) : Cat.{v v} :=
{ α := limit (F ⋙ Cat.objects), }.

/-- Auxiliary definition: the cone over the limit category. -/
@[simps]
def limit_cone (F : J ⥤ Cat.{v v}) : cone F :=
{ X := limit_cone_X F,
  π :=
  { app := λ j,
    { obj := limit.π (F ⋙ Cat.objects) j,
      map := λ X Y, limit.π (hom_diagram X Y) j, },
    naturality' := λ j j' f, category_theory.functor.ext
      (λ X, (congr_fun (limit.w (F ⋙ Cat.objects) f) X).symm)
      (λ X Y h, (congr_fun (limit.w (hom_diagram X Y) f) h).symm), } }

/-- Auxiliary definition: the universal morphism to the proposed limit cone. -/
@[simps]
def limit_cone_lift (F : J ⥤ Cat.{v v}) (s : cone F) : s.X ⟶ limit_cone_X F :=
{ obj := limit.lift (F ⋙ Cat.objects)
  { X := s.X,
    π :=
    { app := λ j, (s.π.app j).obj,
      naturality' := λ j j' f, (congr_arg functor.obj (s.π.naturality f) : _), } },
  map := λ X Y f,
  begin
    fapply types.limit.mk.{v v},
    { intro j,
      refine eq_to_hom _ ≫ (s.π.app j).map f ≫ eq_to_hom _;
      simp, },
    { intros j j' h,
      dsimp,
      simp only [category.assoc, functor.map_comp,
        eq_to_hom_map, eq_to_hom_trans, eq_to_hom_trans_assoc],
      rw [←functor.comp_map],
      have := (s.π.naturality h).symm,
      conv at this { congr, skip, dsimp, simp, },
      erw [functor.congr_hom this f],
      dsimp, simp, },
  end, }

@[simp]
lemma limit_π_hom_diagram_eq_to_hom {F : J ⥤ Cat.{v v}}
  (X Y : limit (F ⋙ Cat.objects.{v v})) (j : J) (h : X = Y) :
  limit.π (hom_diagram X Y) j (eq_to_hom h) =
    eq_to_hom (congr_arg (limit.π (F ⋙ Cat.objects.{v v}) j) h) :=
by { subst h, simp, }

/-- Auxiliary definition: the proposed cone is a limit cone. -/
def limit_cone_is_limit (F : J ⥤ Cat.{v v}) : is_limit (limit_cone F) :=
{ lift := limit_cone_lift F,
  fac' := λ s j, category_theory.functor.ext (by tidy) (λ X Y f, types.limit.π_mk _ _ _ _),
  uniq' := λ s m w,
  begin
    symmetry,
    fapply category_theory.functor.ext,
    { intro X,
      ext,
      dsimp, simp only [types.limit.lift_π_apply', ←w j],
      refl, },
    { intros X Y f,
      dsimp, simp [(λ j, functor.congr_hom (w j).symm f)],
      congr, },
  end, }

end has_limits

/-- The category of small categories has all small limits. -/
instance : has_limits (Cat.{v v}) :=
{ has_limits_of_shape := λ J _, by exactI
  { has_limit := λ F, ⟨⟨⟨has_limits.limit_cone F, has_limits.limit_cone_is_limit F⟩⟩⟩, } }

instance : preserves_limits Cat.objects.{v v} :=
{ preserves_limits_of_shape := λ J _, by exactI
  { preserves_limit := λ F,
    preserves_limit_of_preserves_limit_cone (has_limits.limit_cone_is_limit F)
      (limits.is_limit.of_iso_limit (limit.is_limit (F ⋙ Cat.objects))
        (cones.ext (by refl) (by tidy))), }}

end Cat

end category_theory


import category_theory.abelian.homology
import for_mathlib.homotopy_category_pretriangulated
import category_theory.limits.constructions.epi_mono
import for_mathlib.homology_iso
import for_mathlib.homotopy_category_coproducts
import category_theory.abelian.homology

namespace category_theory

open category_theory.limits

universes v u

class AB4 (A : Type u) [category.{v} A] [has_coproducts.{v} A] : Prop :=
(cond : ∀ {α : Type v} (X Y : α → A) (f : Π a, X a ⟶ Y a)
  (hf : ∀ a, mono (f a)), mono (sigma.desc $ λ a, f a ≫ sigma.ι Y a))

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

instance AB4_mono
  [has_coproducts.{v} A] [AB4 A]
  {α : Type v} (X Y : α → A) (f : Π a, X a ⟶ Y a)
  [∀ a, mono (f a)] : mono (sigma.desc $ λ a, f a ≫ sigma.ι Y a) :=
begin
  apply AB4.cond, assumption,
end

variable (A)
noncomputable
def sigma_functor
  [has_coproducts.{v} A]
  (α : Type v) : (α → A) ⥤ A :=
{ obj := λ X, sigma_obj X,
  map := λ X Y f, sigma.desc $ λ a, f a ≫ sigma.ι _ a,
  map_id' := λ X, by { ext ⟨j⟩, simp },
  map_comp' := λ X Y Z f j, by { ext ⟨j⟩, simp } }.

variable {A}

instance sigma_functor_preserves_mono
  [has_coproducts.{v} A] [AB4 A]
  (α : Type v)
  {X Y : α → A} (f : X ⟶ Y) [∀ a, mono (f a)] :
  mono ((sigma_functor A α).map f) :=
category_theory.AB4_mono X Y f

instance sigma_functor_preserves_epi
  [has_coproducts.{v} A]
  (α : Type v)
  {X Y : α → A} (f : X ⟶ Y) [∀ a, epi (f a)] :
  epi ((sigma_functor A α).map f) :=
begin
  constructor, intros Z s t h,
  apply colimit.hom_ext,
  rintros ⟨a⟩,
  dsimp [sigma_functor] at h,
  apply_fun (λ e, colimit.ι _ (discrete.mk a) ≫ e) at h,
  simp at h,
  rwa cancel_epi at h,
end

set_option pp.universes true

lemma AB4_of_preserves_colimits_of_reflects_limits_of_AB4
  {A B : Type u} [category.{v} A] [category.{v} B]
  [has_coproducts.{v} A]
  [has_coproducts.{v} B]
  (F : A ⥤ B)
  [preserves_colimits F]
  [creates_limits F]
  [has_limits B]
  [AB4 B] : AB4 A :=
begin
  constructor, introsI a X Y f hf,
  let t := _, change mono t,
  suffices : mono (F.map t),
  { haveI := reflects_limits_of_size_shrink.{0 v 0 v} F,
    apply F.mono_of_mono_map this, },
  let eX : F.obj (∐ λ (a : a), X a) ≅ (∐ λ a, F.obj (X a)) :=
    (is_colimit_of_preserves F (colimit.is_colimit _)).cocone_point_unique_up_to_iso
      (colimit.is_colimit _) ≪≫ has_colimit.iso_of_nat_iso
      (nat_iso.of_components (λ _, iso.refl _) _),
  swap, { rintro ⟨⟩ ⟨⟩ ⟨⟨⟨⟩⟩⟩, dsimp, simp, dsimp, simp },
  let eY : F.obj (∐ λ (a : a), Y a) ≅ (∐ λ a, F.obj (Y a)) :=
    (is_colimit_of_preserves F (colimit.is_colimit _)).cocone_point_unique_up_to_iso
      (colimit.is_colimit _) ≪≫ has_colimit.iso_of_nat_iso
      (nat_iso.of_components (λ _, iso.refl _) _),
  swap, { rintro ⟨⟩ ⟨⟩ ⟨⟨⟨⟩⟩⟩, dsimp, simp, dsimp, simp },
  let tt : (∐ λ a, F.obj (X a)) ⟶ (∐ λ a, F.obj (Y a)) :=
    sigma.desc (λ a, F.map (f a) ≫ sigma.ι _ a),
  haveI : mono tt,
  { apply AB4.cond, intros a, apply_instance },
  suffices : F.map t = eX.hom ≫ tt ≫ eY.inv,
  { rw this, apply mono_comp },
  apply (is_colimit_of_preserves F (colimit.is_colimit _)).hom_ext,
  swap, apply_instance,
  rintros ⟨i⟩,
  erw [← F.map_comp, colimit.ι_desc, F.map_comp],
  dsimp [eX, tt, t, eY, limits.is_colimit.cocone_point_unique_up_to_iso, is_colimit_of_preserves,
    has_colimit.iso_of_nat_iso, is_colimit.map],
  slice_rhs 0 1
  { erw (is_colimit_of_preserves F (colimit.is_colimit _)).fac },
  slice_rhs 0 1
  { erw colimit.ι_desc },
  dsimp [iso.refl],
  simp only [category.id_comp, colimit.ι_desc, cofan.mk_ι_app, category.assoc,
    cocones.precompose_obj_ι, nat_trans.comp_app, nat_iso.of_components_inv_app,
    colimit.cocone_ι, functor.map_cocone_ι_app],
  dsimp,
  simp,
end

noncomputable
example {X Y Z : A} [abelian A]
  (f : X ⟶ Y) (g : Y ⟶ Z) (w : f ≫ g = 0): cokernel (image_to_kernel' f g w) ≅ homology f g w :=
  (homology_iso_cokernel_image_to_kernel' f g w).symm

noncomputable
def coproduct_kernel_comparison (M : Type*) (S : complex_shape M) (α : Type v)
  [abelian A] [has_coproducts.{v} A] (i : M) (X : α → homological_complex A S) :
  (∐ λ (a : α), kernel ((X a).d_from i)) ⟶ kernel ((∐ X).d_from i) :=
sigma.desc $ λ a, kernel.lift _ (kernel.ι _ ≫ (sigma.ι _ a : X a ⟶ ∐ X).f i)
begin
  rw [category.assoc, (sigma.ι X a : X a ⟶ _).comm_from, ← category.assoc, kernel.condition,
    zero_comp],
end

-- This should follow from the AB4 assumption
instance mono_coproduct_kernel_comparison (M : Type*) (S : complex_shape M) (α : Type v)
  [abelian A] [has_coproducts.{v} A] [AB4 A] (i : M) (X : α → homological_complex A S) :
mono (coproduct_kernel_comparison M S α i X) :=
begin
  let ι : kernel ((∐ X).d_from i) ⟶ _ := kernel.ι _,
  let t := _, change (mono t),
  suffices : mono (t ≫ ι),
  { resetI, apply mono_of_mono t ι },
  let F : homological_complex A S ⥤ A := homological_complex.eval _ _ i,
  let E : (∐ X).X i ≅ (∐ λ b, (X b).X i) :=
    (is_colimit_of_preserves F (colimit.is_colimit
      (discrete.functor X))).cocone_point_unique_up_to_iso
      (colimit.is_colimit _) ≪≫
      has_colimit.iso_of_nat_iso (discrete.nat_iso $ λ b, iso.refl _),
  suffices : t ≫ ι = sigma.desc (λ a, kernel.ι _ ≫ (sigma.ι (λ b, (X b).X i) a)) ≫ E.inv,
  { rw this, apply_instance },
  dsimp [t,ι, coproduct_kernel_comparison],
  apply colimit.hom_ext, intros a,
  simp only [colimit.ι_desc_assoc, cofan.mk_ι_app, kernel.lift_ι, category.assoc,
    has_colimit.iso_of_nat_iso_ι_inv_assoc, discrete.nat_iso_inv_app,
    colimit.comp_cocone_point_unique_up_to_iso_inv, functor.map_cocone_ι_app,
    colimit.cocone_ι, homological_complex.eval_map],
  dsimp, simp only [category.id_comp],
end

noncomputable
def eval_next (A : Type u) [category.{v} A] [abelian A] {M : Type*}
  (S : complex_shape M) (i : M) :
  homological_complex A S ⥤ A :=
{ obj := λ X, X.X_next i,
  map := λ X Y f, f.next i,
  map_id' := λ X, rfl,
  map_comp' := λ X Y Z f g, rfl, }

open_locale zero_object

noncomputable
def preserves_colimits_of_shape_const_zero_aux
  (α : Type v) (M : Type*) (S : complex_shape M)
  [abelian A] [has_coproducts.{v} A]
  (K : discrete α ⥤ homological_complex A S) :
  is_colimit (((functor.const _).obj (0 : A)).map_cocone (colimit.cocone K)) :=
{ desc := λ S, 0,
  fac' := λ S j, (is_zero_zero _).eq_of_src _ _,
  uniq' := λ S m hm, (is_zero_zero _).eq_of_src _ _ }

noncomputable
instance preserves_colimits_of_shape_const_zero
  (α : Type v) (M : Type*) (S : complex_shape M) [abelian A] [has_coproducts.{v} A] :
  preserves_colimits_of_shape (discrete α)
  ((functor.const _).obj 0 : homological_complex A S ⥤ A) :=
begin
  constructor, intros K,
  apply preserves_colimit_of_preserves_colimit_cocone
    (colimit.is_colimit K),
  apply preserves_colimits_of_shape_const_zero_aux,
end

noncomputable
def eval_next_iso
  (M : Type*) (S : complex_shape M) [abelian A] (i : M) :
  eval_next A S i ≅ homological_complex.eval _ _ (S.next i) :=
nat_iso.of_components (λ X, iso.refl _)
begin
  intros X Y f,
  simp only [iso.refl_hom, category.comp_id, homological_complex.eval_map, category.id_comp],
  refl
end

noncomputable
instance eval_next_preserves_coproducts (α : Type v)
  (M : Type*) (S : complex_shape M) [abelian A] [has_coproducts.{v} A] (i : M) :
  preserves_colimits_of_shape (discrete α) (eval_next A S i) :=
begin
  apply preserves_colimits_of_shape_of_nat_iso (eval_next_iso M S i).symm,
  apply_instance
end

noncomputable
def eval_prev (A : Type u) [category.{v} A] [abelian A] {M : Type*}
  (S : complex_shape M) (i : M) :
  homological_complex A S ⥤ A :=
{ obj := λ X, X.X_prev i,
  map := λ X Y f, f.prev i,
  map_id' := λ X, rfl,
  map_comp' := λ X Y Z f g, rfl, }

noncomputable
def eval_prev_iso
  (M : Type*) (S : complex_shape M) [abelian A] (i : M) :
  eval_prev A S i ≅ homological_complex.eval _ _ (S.prev i) :=
nat_iso.of_components (λ X, iso.refl _)
begin
  intros X Y f,
  simp only [iso.refl_hom, category.comp_id, homological_complex.eval_map, category.id_comp],
  refl,
end

noncomputable
instance eval_prev_preserves_coproducts (α : Type v)
  (M : Type*) (S : complex_shape M) [abelian A] [has_coproducts.{v} A] (i : M) :
  preserves_colimits_of_shape (discrete α) (eval_prev A S i) :=
begin
  apply preserves_colimits_of_shape_of_nat_iso (eval_prev_iso M S i).symm,
  apply_instance
end

lemma exact_iff_exact_cokernel_desc [abelian A] (X Y Z : A)
  (f : X ⟶ Y) (g : Y ⟶ Z) :
  exact f g ↔ ∃ w, mono (cokernel.desc f g w) :=
begin
  split,
  { intros h, refine ⟨h.w, _⟩,
    apply abelian.pseudoelement.mono_of_zero_of_map_zero,
    intros a ha,
    have h' : exact f (cokernel.π f) := abelian.exact_cokernel f,
    replace h' := abelian.pseudoelement.pseudo_exact_of_exact h',
    have hπ := abelian.pseudoelement.pseudo_surjective_of_epi (cokernel.π f),
    obtain ⟨b,rfl⟩ := hπ a,
    rw [← abelian.pseudoelement.comp_apply, cokernel.π_desc] at ha,
    replace h := abelian.pseudoelement.pseudo_exact_of_exact h,
    obtain ⟨b,rfl⟩ := h.2 _ ha,
    rw [← abelian.pseudoelement.comp_apply, cokernel.condition],
    simp only [abelian.pseudoelement.zero_apply] },
  { rintros ⟨w,h⟩, rw abelian.exact_iff, refine ⟨w, _⟩, resetI,
    rw ← cancel_mono (cokernel.desc f g w),
    simp only [category.assoc, cokernel.π_desc, kernel.condition, zero_comp] }
end

lemma exact_iff_exact_of_cofork [abelian A] (X Y Z : A)
  (f : X ⟶ Y) (g : Y ⟶ Z) (T : cokernel_cofork f) (hT : is_colimit T) :
  exact f g ↔ ∃ w : f ≫ g = 0,
  mono (hT.desc (cokernel_cofork.of_π g w)) :=
begin
  let e : T.X ≅ cokernel f :=
    hT.cocone_point_unique_up_to_iso (colimit.is_colimit _),
  rw exact_iff_exact_cokernel_desc,
  apply exists_congr (λ w, _),
  have : hT.desc (cokernel_cofork.of_π g w) =
    e.hom ≫ cokernel.desc f g w,
  { dsimp [e, limits.is_colimit.cocone_point_unique_up_to_iso],
    apply hT.hom_ext, intros i,
    simp only [is_colimit.fac, is_colimit.fac_assoc, colimit.cocone_ι,
      colimit.ι_desc] },
  rw this,
  split,
  { introI _, apply_instance },
  { introI, constructor,
    intros Z a b h,
    rw [← cancel_mono e.inv, ← cancel_mono (e.hom ≫ cokernel.desc f g w)],
    simpa }
end

noncomputable
def sigma_cokernel_cofork [abelian A] [has_coproducts.{v} A] [AB4 A]
  {α : Type v} (X Y : α → A) (f : X ⟶ Y) :
  cokernel_cofork ((sigma_functor A α).map f) :=
cokernel_cofork.of_π
(sigma.desc (λ a : α, cokernel.π (f a) ≫ sigma.ι (λ b, cokernel (f b)) a))
begin
  apply colimit.hom_ext,
  intros a,
  dsimp [sigma_functor],
  simp only [colimit.ι_desc_assoc, cofan.mk_ι_app, category.assoc,
    colimit.ι_desc, cokernel.condition_assoc, zero_comp,
    comp_zero],
end

noncomputable
def is_colimit_sigma_cokernel_cofork [abelian A] [has_coproducts.{v} A] [AB4 A]
  {α : Type v} (X Y : α → A) (f : X ⟶ Y) :
  is_colimit (sigma_cokernel_cofork X Y f) :=
is_colimit_aux _
(λ S, sigma.desc $ λ b, cokernel.desc _ (sigma.ι _ _ ≫ S.π)
  begin
    rw ← category.assoc,
    let t := _, change t ≫ _ = _,
    have ht : t = sigma.ι X b ≫ (sigma_functor A α).map f,
    { dsimp [sigma_functor], simp },
    rw ht, clear ht, clear t,
    rw [category.assoc, S.condition, comp_zero],
  end)
begin
  intros S,
  dsimp [sigma_cokernel_cofork],
  apply colimit.hom_ext,
  simp only [category.assoc, colimit.ι_desc, cofan.mk_ι_app, eq_self_iff_true,
    cokernel_cofork.condition, comp_zero,
    colimit.ι_desc_assoc, cokernel.π_desc, implies_true_iff],
  rintro ⟨j⟩,
  simp,
end
begin
  intros S m hm,
  apply colimit.hom_ext, rintros ⟨a⟩,
  simp only [colimit.ι_desc, cofan.mk_ι_app],
  apply coequalizer.hom_ext, simp only [coequalizer_as_cokernel, cokernel.π_desc],
  simp_rw [← hm, ← category.assoc], congr' 1,
  dsimp [sigma_cokernel_cofork],
  simp only [colimit.ι_desc, cofan.mk_ι_app],
end

lemma exact_coproduct [abelian A] [has_coproducts.{v} A] [AB4 A]
  {α : Type v} (X Y Z : α → A) (f : X ⟶ Y) (g : Y ⟶ Z)
  (w : ∀ i, exact (f i) (g i)) :
  exact ((sigma_functor A α).map f) ((sigma_functor A α).map g) :=
begin
  let ι : (λ a : α, cokernel (f a)) ⟶ Z :=
    λ a, (cokernel.desc _ (g a) (w a).w),
  let π : Y ⟶ (λ a : α, cokernel (f a)) :=
    λ a, (cokernel.π _),
  haveI : ∀ a, mono (ι a),
  { intros a,
    suffices : ∃ w, mono (cokernel.desc (f a) (g a) w),
    { obtain ⟨q,h⟩ := this, exact h },
    rw ← exact_iff_exact_cokernel_desc, apply w },
  have : mono ((sigma_functor A α).map ι),
  { apply AB4.cond, assumption },
  -- Now need to show that sigma functor commutes with cokernels
  -- Use the fact that this commutes with cokernels to identify the source
  -- with the cokernel of `f`.
  -- Then use exact_iff_exact_cokernel_desc
  rw exact_iff_exact_of_cofork
    ((sigma_functor A α).obj X)
    ((sigma_functor A α).obj Y)
    ((sigma_functor A α).obj Z)
    ((sigma_functor A α).map f)
    ((sigma_functor A α).map g)
    (sigma_cokernel_cofork _ _ f)
    (is_colimit_sigma_cokernel_cofork _ _ f),
  refine ⟨_,_⟩,
  { apply colimit.hom_ext, intros a,
    dsimp [sigma_functor],
    simp only [colimit.ι_desc_assoc, cofan.mk_ι_app, category.assoc, colimit.ι_desc, comp_zero],
    rw [← category.assoc, (w a.1).w, zero_comp] },
  simp only [exact_iff_exact_cokernel_desc] at w,
  choose w₁ w₂ using w,
  convert AB4.cond _ Z ι w₂ using 1,
  apply colimit.hom_ext, intros a,
  dsimp [is_colimit_sigma_cokernel_cofork, is_colimit_aux],
  simp only [colimit.ι_desc, cofan.mk_ι_app],
  apply coequalizer.hom_ext,
  simp only [cokernel.π_desc, cokernel.π_desc_assoc],
  dsimp [sigma_functor],
  simp only [colimit.ι_desc, cofan.mk_ι_app],
end

section
open_locale pseudoelement
instance epi_coproduct_kernel_comparison [has_coproducts.{v} A] [AB4 A]
  (M : Type*) (S : complex_shape M) (α : Type v)
  [abelian A] [has_coproducts.{v} A] (i : M) (X : α → homological_complex A S) :
  epi (coproduct_kernel_comparison M S α i X) :=
begin
  /-
     _ -ι₁-> _ -π₁-> _
     |       |       |
     t     E.inv   Q.inv
     |       |       |
     v       v       v
     _ -ι₂-> _ -π₂-> _

  -/
  let t := _, change epi t,
  let F : homological_complex A S ⥤ A := homological_complex.eval _ _ i,
  let N : homological_complex A S ⥤ A := eval_next _ _ i,
  let E : (∐ X).X i ≅ (∐ λ b, (X b).X i) :=
    (is_colimit_of_preserves F (colimit.is_colimit
      (discrete.functor X))).cocone_point_unique_up_to_iso
      (colimit.is_colimit _) ≪≫
      has_colimit.iso_of_nat_iso (discrete.nat_iso $ λ b, iso.refl _),
  let Q : (∐ X).X_next i ≅ (∐ λ b, (X b).X_next i) :=
    (is_colimit_of_preserves N (colimit.is_colimit
      (discrete.functor X))).cocone_point_unique_up_to_iso
      (colimit.is_colimit _) ≪≫
      has_colimit.iso_of_nat_iso (discrete.nat_iso $ λ b, iso.refl _),
  let ι₁ : (∐ λ (a : α), kernel ((X a).d_from i)) ⟶ (∐ λ b, (X b).X i) :=
    sigma.desc (λ a, kernel.ι _ ≫ sigma.ι _ a),
  let π₁ : (∐ λ b, (X b).X i) ⟶ (∐ λ b, (X b).X_next i) :=
    sigma.desc (λ a, (X a).d_from i ≫ sigma.ι _ a),
  let ι₂ : kernel ((∐ X).d_from i) ⟶ (∐ X).X i := kernel.ι _,
  let π₂ : (∐ X).X i ⟶ (∐ X).X_next i := (∐ X).d_from i,
  have sqι : ι₁ ≫ E.inv = t ≫ ι₂,
  { apply colimit.hom_ext, intros a, dsimp [ι₁, E, t, ι₂],
    simp only [colimit.ι_desc_assoc, cofan.mk_ι_app, category.assoc,
      has_colimit.iso_of_nat_iso_ι_inv_assoc, discrete.nat_iso_inv_app,
      colimit.comp_cocone_point_unique_up_to_iso_inv, functor.map_cocone_ι_app,
      colimit.cocone_ι, homological_complex.eval_map],
    dsimp [coproduct_kernel_comparison],
    simp only [category.id_comp, colimit.ι_desc_assoc, cofan.mk_ι_app, kernel.lift_ι] },
  have sqπ : π₁ ≫ Q.inv = E.inv ≫ π₂,
  { dsimp [π₁, Q, E, π₂, coproduct_kernel_comparison], apply colimit.hom_ext, rintros ⟨a⟩,
    simp only [colimit.ι_desc_assoc, cofan.mk_ι_app, category.assoc,
      has_colimit.iso_of_nat_iso_ι_inv_assoc, discrete.nat_iso_inv_app,
      colimit.comp_cocone_point_unique_up_to_iso_inv, functor.map_cocone_ι_app,
      colimit.cocone_ι, colimit.comp_cocone_point_unique_up_to_iso_inv_assoc,
      homological_complex.eval_map],
    dsimp,
    simp only [homological_complex.hom.comm_from, category.id_comp],
    erw category.id_comp,
    refl },
  have e1 : exact ι₁ π₁,
  { apply exact_coproduct, intros b, exact exact_kernel_ι },
  have e2 : exact ι₂ π₂ := exact_kernel_ι,
  have hι₂ := abelian.pseudoelement.pseudo_injective_of_mono ι₂,
  replace e1 := abelian.pseudoelement.pseudo_exact_of_exact e1,
  replace e2 := abelian.pseudoelement.pseudo_exact_of_exact e2,
  have hEinv := abelian.pseudoelement.pseudo_surjective_of_epi E.inv,
  have hQinv := abelian.pseudoelement.pseudo_injective_of_mono Q.inv,
  apply abelian.pseudoelement.epi_of_pseudo_surjective,
  -- Now we start the diagram chase.
  intros x,
  let x' := ι₂ x,
  obtain ⟨y,hy⟩ := hEinv x',
  have hy' : π₁ y = 0,
  { apply hQinv,
    simp only [abelian.pseudoelement.apply_zero, ← abelian.pseudoelement.comp_apply, sqπ],
    rw [abelian.pseudoelement.comp_apply, hy],
    dsimp only [x'], rw e2.1 },
  obtain ⟨z,hz⟩ := e1.2 _ hy',
  use z,
  apply hι₂,
  rw [← abelian.pseudoelement.comp_apply, ← sqι, abelian.pseudoelement.comp_apply, hz, hy],
end
end

instance is_iso_coproduct_kernel_comparison (M : Type*) (S : complex_shape M) (α : Type v)
  [abelian A] [has_coproducts.{v} A] [AB4 A] (i : M) (X : α → homological_complex A S) :
is_iso (coproduct_kernel_comparison M S α i X) :=
is_iso_of_mono_of_epi _

noncomputable
def coproduct_homology_comparison (M : Type*) (S : complex_shape M) (α : Type v)
  [abelian A] [has_coproducts.{v} A] (i : M) (X : α → homological_complex A S) :
  (∐ λ a : α, (X a).homology i) ⟶ (∐ X).homology i :=
sigma.desc $ λ b, (homology_functor _ _ _).map $ sigma.ι _ _

noncomputable
def coproduct_homology_comparison_inv (M : Type*) (S : complex_shape M) (α : Type v)
  [abelian A] [has_coproducts.{v} A] [AB4 A] (i : M) (X : α → homological_complex A S) :
  (∐ X).homology i ⟶ (∐ λ a : α, (X a).homology i) :=
homology.desc' _ _ _ (inv (coproduct_kernel_comparison M S α i X) ≫
  sigma.desc (λ b, homology.π' ((X b).d_to _) ((X b).d_from i)
    (homological_complex.d_to_comp_d_from _ _) ≫ sigma.ι _ b))
begin
  rw ← category.assoc, let t := _, change t ≫ _ = _,
  let e : (∐ X).X_prev i ≅ ∐ (λ a, (X a).X_prev i) :=
    (is_colimit_of_preserves (eval_prev A S i)
      (colimit.is_colimit _)).cocone_point_unique_up_to_iso
      (colimit.is_colimit _) ≪≫ has_colimit.iso_of_nat_iso (discrete.nat_iso $ λ b, iso.refl _),
  have ht : t = e.hom ≫ sigma.desc (λ b, _ ≫ sigma.ι _ b),
  rotate 2,
  { refine kernel.lift _ _ _, exact (X b).d_to i,
    exact (X b).d_to_comp_d_from i },
  { dsimp [t, e, limits.is_colimit.cocone_point_unique_up_to_iso,
      has_colimit.iso_of_nat_iso, is_colimit.map, coproduct_kernel_comparison],
    rw is_iso.comp_inv_eq,
    apply (is_colimit_of_preserves (eval_prev A S i)
      (colimit.is_colimit (discrete.functor X))).hom_ext,
    rintros ⟨j⟩,
    apply equalizer.hom_ext,
    simp only [functor.map_cocone_ι_app, colimit.cocone_ι,
      equalizer_as_kernel, category.assoc, kernel.lift_ι],
    slice_rhs 1 2
    { erw (is_colimit_of_preserves (eval_prev A S i) (colimit.is_colimit (discrete.functor X))).fac },
    dsimp [eval_prev],
    simp only [homological_complex.hom.comm_to, colimit.ι_desc, cocones.precompose_obj_ι,
      nat_trans.comp_app, discrete.nat_iso_hom_app, colimit.cocone_ι, category.assoc,
      cofan.mk_ι_app, kernel.lift_ι, kernel.lift_ι_assoc],
    dsimp, simp only [category.id_comp] },
  { rw ht,
    dsimp [e, limits.is_colimit.cocone_point_unique_up_to_iso],
    apply (is_colimit_of_preserves (eval_prev A S i) (colimit.is_colimit (discrete.functor X))).hom_ext,
    intros j,
    simp only [functor.map_cocone_ι_app, colimit.cocone_ι, category.assoc,
      has_colimit.iso_of_nat_iso_hom_desc, comp_zero],
    slice_lhs 1 2
    { erw (is_colimit_of_preserves (eval_prev A S i) (colimit.is_colimit (discrete.functor X))).fac },
    simp only [colimit.cocone_ι, colimit.ι_desc, cocones.precompose_obj_ι, nat_trans.comp_app,
      cofan.mk_ι_app, category.assoc, homology.condition_π'_assoc, zero_comp, comp_zero] }
end

noncomputable
def coproduct_homology_iso
  (M : Type*) (S : complex_shape M) (α : Type v)
  [abelian A] [has_coproducts.{v} A] [AB4 A] (i : M) (X : α → homological_complex A S) :
  (∐ λ a : α, (X a).homology i) ≅ (∐ X).homology i :=
{ hom := coproduct_homology_comparison _ _ _ _ _,
  inv := coproduct_homology_comparison_inv _ _ _ _ _,
  hom_inv_id' := begin
    dsimp [coproduct_homology_comparison, coproduct_homology_comparison_inv],
    apply colimit.hom_ext, rintros ⟨a⟩,
    dsimp,
    simp only [colimit.ι_desc_assoc, cofan.mk_ι_app, category.comp_id],
    apply homology.hom_from_ext,
    rw homology.map_eq_desc'_lift_left,
    simp only [homological_complex.hom.sq_from_left, homology.π'_desc'_assoc],
    let t := _, change t ≫ _ = _,
    have ht : t = kernel.lift _ (kernel.ι _ ≫ _) _ ≫ homology.π' _ _ _,
    rotate 2,
    { let e : X a ⟶ ∐ X := sigma.ι _ a, exact e.f i },
    { dsimp,
      rw [category.assoc, (sigma.ι X a : X a ⟶ ∐ X).comm_from, ← category.assoc,
        kernel.condition, zero_comp] },
    { dsimp [t], apply homology.hom_to_ext,
      simp only [category.assoc, homology.lift_ι, homological_complex.homology.π'_ι,
        kernel.lift_ι_assoc] },
    { rw ht, clear ht, clear t,
      rw [category.assoc, homology.π'_desc', ← category.assoc],
      let t := _, change t ≫ _ = _,
      have ht : t = sigma.ι _ a,
      { dsimp [t], rw is_iso.comp_inv_eq,
        apply equalizer.hom_ext,
        dsimp [coproduct_kernel_comparison],
        simp only [category.assoc, kernel.lift_ι],
        erw colimit.ι_desc_assoc,
        dsimp,
        simp only [kernel.lift_ι] },
      rw ht, clear ht, clear t,
      erw colimit.ι_desc,
      refl }
  end,
  inv_hom_id' := begin
    dsimp [coproduct_homology_comparison, coproduct_homology_comparison_inv],
    apply homology.hom_from_ext,
    simp only [homology.π'_desc'_assoc, category.assoc, category.comp_id,
      is_iso.inv_comp_eq],
    apply colimit.hom_ext, rintros ⟨a⟩,
    dsimp,
    simp only [homological_complex.hom.sq_from_right, homological_complex.hom.sq_to_right,
      colimit.ι_desc_assoc, cofan.mk_ι_app, category.assoc, colimit.ι_desc, homology.π'_map],
    erw colimit.ι_desc_assoc, refl,
  end }

noncomputable
def is_colimit_homology_map_cocone  (M : Type*) (S : complex_shape M) (α : Type v)
  [abelian A] [has_coproducts.{v} A] [AB4 A] (i : M) (X : α → homological_complex A S) :
  is_colimit ((homology_functor A S i).map_cocone (colimit.cocone (discrete.functor X))) :=
{ desc := λ E, (coproduct_homology_iso _ _ _ _ _).inv ≫ sigma.desc (λ a, E.ι.app ⟨_⟩),
  fac' := begin
    rintros E ⟨j⟩,
    dsimp [coproduct_homology_comparison_inv, coproduct_homology_iso],
    apply homology.hom_from_ext,
    rw homology.map_eq_desc'_lift_left,
    simp only [homological_complex.hom.sq_from_left, homology.π'_desc'_assoc],
    let t := _, change t ≫ _ = _,
    have ht : t = kernel.lift _ (kernel.ι _ ≫ _) _ ≫ homology.π' _ _ _,
    rotate 2,
    { let e := (sigma.ι X j), exact e.f i },
    { dsimp, rw [category.assoc],
      erw (sigma.ι X j : X j ⟶ ∐ X).comm_from,
      rw [← category.assoc, kernel.condition, zero_comp] },
    { dsimp [t],
      apply homology.hom_to_ext,
      simp only [category.assoc, homology.lift_ι, homological_complex.homology.π'_ι,
        kernel.lift_ι_assoc] },
    rw ht, clear ht, clear t,
    simp only [category.assoc, homology.π'_desc'_assoc],
    simp only [← category.assoc],
    let t := _, change (t ≫ _) ≫ _ = _,
    have ht : t = sigma.ι _ j,
    { dsimp [t], rw [is_iso.comp_inv_eq],
      dsimp [coproduct_kernel_comparison],
      erw colimit.ι_desc, refl },
    rw ht, clear ht, clear t,
    simp only [category.assoc], erw [colimit.ι_desc_assoc], dsimp,
    rw [category.assoc, colimit.ι_desc], refl,
  end,
  uniq' := begin
    intros E m hm,
    rw iso.eq_inv_comp, dsimp [coproduct_homology_comparison, coproduct_homology_iso],
    apply colimit.hom_ext, rintros ⟨j⟩, specialize hm ⟨j⟩,
    simpa only [←hm, colimit.ι_desc_assoc, cofan.mk_ι_app, colimit.ι_desc,
      functor.map_cocone_ι_app, colimit.cocone_ι,
      homology_functor_map],
  end }

noncomputable
instance homology_functor_preserves_coproducts
  (M : Type*) (S : complex_shape M) (α : Type v)
  [abelian A] [has_coproducts.{v} A] [AB4 A] (i) :
  preserves_colimits_of_shape (discrete α)
  (homology_functor A S i) :=
begin
  constructor, intros K,
  let E : K ≅ discrete.functor (λ n, K.obj ⟨n⟩) := discrete.nat_iso (λ ⟨i⟩, iso.refl _),
  suffices : preserves_colimit (discrete.functor (λ n, K.obj ⟨n⟩)) (homology_functor A _ i),
  { apply preserves_colimit_of_iso_diagram _ E.symm, assumption },
  apply preserves_colimit_of_preserves_colimit_cocone
    (colimit.is_colimit (discrete.functor (λ n, K.obj ⟨n⟩))),
  apply is_colimit_homology_map_cocone,
end

noncomputable
def is_colimit_homotopy_category_homology_functor_map_cocone
  {α : Type v} [abelian A] [has_coproducts.{v} A] [AB4 A] (i)
  (K : α → homotopy_category A (complex_shape.up ℤ)) :
  is_colimit
  ((homotopy_category.homology_functor A (complex_shape.up ℤ) i).map_cocone
    (homotopy_category.colimit_cofan K)) :=
{ desc := λ S,
    (is_colimit_of_preserves (homology_functor A (complex_shape.up ℤ) i)
    (colimit.is_colimit $ discrete.functor $ λ i, (K i).as)).desc ⟨S.X,
    discrete.nat_trans $ λ i, S.ι.app i⟩,
  fac' := begin
    rintros S ⟨j⟩, dsimp,
    erw (is_colimit_of_preserves (homology_functor A (complex_shape.up ℤ) i)
      (colimit.is_colimit (discrete.functor (λ (i : α), (K i).as)))).fac,
    refl,
  end,
  uniq' := begin
    intros S m hm,
    apply (is_colimit_of_preserves (homology_functor A (complex_shape.up ℤ) i)
      (colimit.is_colimit (discrete.functor (λ (i : α), (K i).as)))).hom_ext,
    rintros ⟨j⟩,
    erw (is_colimit_of_preserves (homology_functor A (complex_shape.up ℤ) i)
      (colimit.is_colimit (discrete.functor (λ (i : α), (K i).as)))).fac,
    dsimp, rw ← hm, refl,
  end }

noncomputable
instance homotopy_category_homology_functor_preserves_coproducts
  (α : Type v)
  [abelian A] [has_coproducts.{v} A] [AB4 A] (i) :
  preserves_colimits_of_shape (discrete α)
  (homotopy_category.homology_functor A (complex_shape.up ℤ) i) :=
begin
  constructor, intros K,
  let E : K ≅ discrete.functor (λ n, K.obj ⟨n⟩) := discrete.nat_iso (λ ⟨i⟩, iso.refl _),
  suffices : preserves_colimit (discrete.functor (λ n, K.obj ⟨n⟩))
    (homotopy_category.homology_functor A _ i),
  { apply preserves_colimit_of_iso_diagram _ E.symm, assumption },
  apply preserves_colimit_of_preserves_colimit_cocone
    (homotopy_category.is_colimit_cofan (λ n, K.obj ⟨n⟩)),
  apply is_colimit_homotopy_category_homology_functor_map_cocone,
end

end category_theory


import solve tactic.group

open expr tactic free_group

local notation `C∞` := multiplicative ℤ

meta structure cache :=
(G : expr)
(univ : level)
(red : transparency)
(ic : ref instance_cache) -- instance_cache for G
(atoms : ref (buffer expr))

@[derive [monad, alternative]]
meta def group1r_m (α : Type) : Type :=
reader_t cache tactic α

namespace group1r

meta def get_cache : group1r_m cache := reader_t.read

/-- Run a `group1r_m` tactic in the tactic monad. -/
meta def group1r_m.run (red : transparency) (G : expr)
  {α} (m : group1r_m α) : tactic α :=
do u ← mk_meta_univ,
   infer_type G >>= unify (expr.sort (level.succ u)),
   u ← get_univ_assignment u,
   ic ← mk_instance_cache G,
   zc ← mk_instance_cache `(ℤ),
   using_new_ref ic $ λ ric,
   using_new_ref mk_buffer $ λ atoms,
   reader_t.run m ⟨G, u, red, ric, atoms⟩

namespace group1r_m

meta def lift {α : Type} : tactic α → group1r_m α := reader_t.lift

/-- Lift an instance cache tactic (probably from `norm_num`) to the `ring_m` monad. This version
is abstract over the instance cache in question (either the ring `α`, or `ℕ` for exponents). -/
@[inline] meta def ic_lift' (icf : cache → ref instance_cache) {α}
  (f : instance_cache → tactic (instance_cache × α)) : group1r_m α :=
⟨λ c, do
  let r := icf c,
  ic ← read_ref r,
  (ic', a) ← f ic,
  a <$ write_ref r ic'⟩

/-- Lift an instance cache tactic (probably from `norm_num`) to the `group1r_m` monad. This uses
the instance cache corresponding to the ring `α`. -/
@[inline] meta def ic_lift {α} : (instance_cache → tactic (instance_cache × α)) → group1r_m α :=
ic_lift' cache.ic

meta def add_atom (e : expr) : group1r_m ℕ :=
⟨λ l, do es ← read_ref l.atoms,
  es.iterate failed (λ n e' t, t <|> (is_def_eq e e' l.red $> n.1)) <|>
    (es.size <$ write_ref l.atoms (es.push_back e))⟩

/-- Get an already encountered atom by its index. -/
meta def get_atom (n : ℕ) : group1r_m expr :=
⟨λ c, do es ← read_ref c.atoms, pure (es.read' n)⟩

meta def to_free_group : expr → group1r_m (free_group ℕ)
| `(%%a * %%b) :=
  do a' ← to_free_group a,
     b' ← to_free_group b,
     return (a' * b')
| `((%%a)⁻¹) :=
  do a' ← to_free_group a, return (a'⁻¹)
| `(@has_one.one _ _) := return 1
| e@`((%%a) ^ (-%%n)) :=
  cond (is_numeral n)
    (do ne ← lift (eval_expr' ℤ n),
      a' ← to_free_group a,
      return (a' ^ -ne))
    (do i ← add_atom e, return (of i))
| e@`((%%a) ^ (%%n)) :=
  cond (is_numeral n)
    ((do ne ← lift (eval_expr' ℕ n),
      a' ← to_free_group a,
      return (a' ^ ne)) <|>
      (do ne ← lift (eval_expr' ℤ n),
        a' ← to_free_group a,
        return (a' ^ ne)))
    (do i ← add_atom e, return (of i))
| e := do i ← add_atom e, return (of i)

-- meta def to_group_equality : expr → group1r_m (expr × free_group ℕ × free_group ℕ)
-- | `(@eq %%G %%a %%b) :=
--   do a' ← to_free_group a,
--      b' ← to_free_group b,
--      return (G, a', b')
-- | _ := failure

-- meta def X : has_reflect int := reflect n
-- #print int.has_reflect
-- set_option pp.numerals false

-- run_cmd tactic.trace (X (-12))

protected meta def expr.of_nat (n : ℕ) : expr :=
if n = 0 then `(0 : ℤ) else
  let one := `(1 : ℤ) in
  n.binary_rec one $ λ b n e,
    if n = 0 then one else
    cond b
      `((bit1 %%e : ℤ))
      `((bit0 %%e : ℤ))

protected meta def expr.of_int : ℤ → expr
| (n : ℕ) := expr.of_nat n
| -[1+ n] := `(has_neg.neg %%(expr.of_nat (n + 1)) : ℤ)

meta def free_group_to_expr_aux : list (Σ i : ℕ, C∞) → group1r_m expr
| []            := ic_lift $ λ ic, ic.mk_app ``has_one.one []
| (⟨a, n⟩ :: l) :=
  do w ← free_group_to_expr_aux l,
  ae ← get_atom a,
  lift $
  do p ← tactic.mk_app `has_pow.pow [ae, expr.of_int n.to_add],
    tactic.mk_app `has_mul.mul [p, w]

meta def free_group_to_expr : free_group ℕ → group1r_m expr :=
free_group_to_expr_aux ∘ subtype.val

meta def free_group_free_group_to_expr_aux : list (Σ i : free_group ℕ, C∞) → group1r_m expr
| [] := do c ← get_cache,
  return (app (const `list.nil [level.max c.univ level.zero])
    (app (app (const `prod [c.univ, level.zero]) c.G) `(ℤ)))
| (⟨w, n⟩ :: l) :=
  do w' ← free_group_to_expr w,
  l' ← free_group_free_group_to_expr_aux l,
  c ← get_cache, lift $
  do w'n ← tactic.mk_app `prod.mk [w', expr.of_int n.to_add],
  tactic.mk_app `list.cons [w'n, l']

def eval_conj {G : Type*} [group G] (r : G) : list (G × ℤ) → G
| []          := 1
| (a::l) := a.1 * (r ^ a.2 * (a.1⁻¹ * eval_conj l))

lemma eval_conj_eq_one {G : Type*} [group G] (r : G) (hr : r = 1) : ∀ (l : list (G × ℤ)),
  eval_conj r l = 1
| []          := rfl
| (⟨g, n⟩::l) := by rw [eval_conj, eval_conj_eq_one, hr]; simp [*, eval_conj]

lemma mul_inv_eq_one_of_eq {G : Type*} [group G] (a b : G) (h : a = b) : a * b⁻¹ = 1 :=
by simp [h]

meta def free_group_free_group_to_expr (p : free_group (free_group ℕ))
  (r : expr) (r_eq_one : expr) : group1r_m expr :=
free_group_free_group_to_expr_aux p.to_list

/- What do I have left?

-/

end group1r_m

open group1r.group1r_m group1r

meta def mk_list
  (hyp : expr)
  (hyp_type : expr)
  (tgt : expr)
  (red : transparency) :
  -- first expr is an expr of type `list (G × ℤ)`
  -- second expr is a proof of r = 1
  tactic (expr × expr) :=
do (hyp_left, hyp_right) ← is_eq hyp_type,
  (tgt_left, tgt_right) ← is_eq tgt,
  G ← infer_type hyp_left,
  group1r_m.run red G $
  do hyp_lhs ← to_free_group hyp_left,
  hyp_rhs ← to_free_group hyp_right,
  tgt_lhs ← to_free_group tgt_left,
  tgt_rhs ← to_free_group tgt_right,
  r ← ic_lift (λ ic,
    do (ic, right_inv) ← ic.mk_app `has_inv.inv [hyp_right],
    ic.mk_app `has_mul.mul [hyp_left, right_inv]),
  r_eq_one ← ic_lift
    (λ ic, ic.mk_app `group1r.group1r_m.mul_inv_eq_one_of_eq [hyp_left, hyp_right, hyp]),
  p ← group1r_m.lift (_root_.golf_solve (hyp_lhs * hyp_rhs⁻¹) ∅ (tgt_lhs * tgt_rhs⁻¹)),
  group1r_m.lift $ tactic.trace (repr (list.map (λ x : Σ i : free_group ℕ, C∞, x.snd.nat_abs) p.left.1).sum),
  l ← free_group_free_group_to_expr p.left r r_eq_one,
  return (l, r_eq_one)

lemma helper {G : Type*} [group G] {r : G} (hr : r = 1) {a b : G} (l : list (G × ℤ)) :
  a = eval_conj r l * b → a = b :=
by { rw [eval_conj_eq_one r hr, one_mul], exact id }

end group1r

namespace tactic.interactive

open lean.parser lean interactive.types interactive group1r tactic.simp_arg_type

local postfix `?`:9001 := optional

meta def group1r (red : parse (lean.parser.tk "!")?) (hyp : parse (tk "using" *> texpr)) :
  tactic unit :=
do hyp ← (hyp : option pexpr) >>= i_to_expr,
   let transp := if red.is_some then semireducible else reducible,
   hyp_type ← infer_type hyp,
   tgt ← target,
   (l, r_eq_one) ← mk_list hyp hyp_type tgt transp,
   `[refine group1r.helper %%r_eq_one %%l _,
     simp only [group1r.group1r_m.eval_conj, gpow_bit0,
      gpow_bit1, one_mul, mul_one, mul_inv_rev, mul_assoc,
      gpow_neg, mul_inv_self, inv_mul_self,
      one_inv, mul_inv_cancel_left, inv_mul_cancel_left,
      gpow_one, gpow_zero, pow_bit0, pow_bit1, pow_one, inv_inv]]

end tactic.interactive

set_option pp.implicit true
set_option profiler true

-- example {G : Type*} [group G] {a b c : G}
--   (h : (a * b) * (b^2 * a * c) * (a * b)⁻¹ = (b^2 * a * c)^2) :
--   (a * b)^5 * (b^2 * a * c) * (a * b)^(-5 : int) * (b^2 * a * c) =
--   (b^2 * a * c) * (a * b)^5 * (b^2 * a * c) * (a * b)^(-5 : int) :=
-- begin
--   group1r using h,
-- end
set_option profiler true
-- example {G : Type*} [group G] (a b : G)
--   (h : a * b * a^(-11 : int) * b^ 4 = 1) :
--   a^10 * b^(-4 : int) * a^11 * b⁻¹ * a * b * a^(-11 : int) * b^5 * a^(-11 : int)
--   * b * a^(11 : int) * b⁻¹ * a⁻¹ * b⁻¹ * a^(-10 : int) = 1 :=
-- begin
--   group1r using h,

-- end

example {G : Type} [group G] (a b c d : G) (h : a * b * c * a * b^2 = 1)
  (h2 : a * b * d * a * b * c^(-2 : int) = 1) :
  a * b * d * a * b = (b⁻¹ * a⁻¹ * b^(-2 : int) * a⁻¹)^(2 : int) :=
have d = b⁻¹ * a⁻¹ * (a * b * c^(-2 : int))⁻¹, by group1r using h2,
begin
  subst this,
  group1r using h,

end

example {G : Type*} [group G] {a b c : G} (m : nat)
  (h : a * b * a⁻¹ = b^2) (n : nat) : a ^ n * b = b ^ (2^n) * a^n :=
begin
  induction n with n ih,
  { norm_num },
  { simp only [pow_succ, mul_comm 2],
    simp only [pow_mul], }

end

def W {G : Type*} [group G] (a b : G): ℕ → G
| 0 := a
| (n+1) := (b⁻¹ * W n * b)⁻¹ * a * (b⁻¹ * W n * b)

example {G : Type*} [group G] (a b : G)
  (h : (b⁻¹ * a * b)⁻¹ * a * (b⁻¹ * a * b) = a ^ 2) :
  W a b 2 = a ^ 4 :=
begin
  dunfold W,
  simp [mul_assoc, gpow_bit0, gpow_bit1],
  group1r using h,

end


import global.localisation
import local.h_principle

noncomputable theory

open set filter model_with_corners metric
open_locale topology manifold

set_option trace.filter_inst_type true

variables
{EM : Type*} [normed_add_comm_group EM] [normed_space ℝ EM] [finite_dimensional ℝ EM]
{HM : Type*} [topological_space HM] {IM : model_with_corners ℝ EM HM} [boundaryless IM]
{M : Type*} [topological_space M] [charted_space HM M] [smooth_manifold_with_corners IM M]
[t2_space M] [locally_compact_space M] [nonempty M] [sigma_compact_space M]

{EX : Type*} [normed_add_comm_group EX] [normed_space ℝ EX] [finite_dimensional ℝ EX]
  [measurable_space EX] [borel_space EX]
{HX : Type*} [topological_space HX] {IX : model_with_corners ℝ EX HX} [model_with_corners.boundaryless IX]
-- note: X is a metric space
{X : Type*} [metric_space X] [charted_space HX X] [smooth_manifold_with_corners IX X]
[locally_compact_space X]
[sigma_compact_space X]
[nonempty X]

lemma open_smooth_embedding.improve_formal_sol
  (φ : open_smooth_embedding 𝓘(ℝ, EM) EM IM M)
  (ψ : open_smooth_embedding 𝓘(ℝ, EX) EX IX X)
  {R : rel_mfld IM M IX X}
  (hRample : R.ample)
  (hRopen : is_open R)
  {C : set M}
  (hC : is_closed C)
  {δ : M → ℝ}
  (hδ_pos : ∀ x, 0 < δ x)
  (hδ_cont : continuous δ)
  {F : formal_sol R}
  (hFφψ : F.bs '' (range φ) ⊆ range ψ)
  (hFC : ∀ᶠ x near C, F.is_holonomic_at x)
  {K₀ K₁ : set EM}
  (hK₀ : is_compact K₀)
  (hK₁ : is_compact K₁)
  (hK₀K₁ : K₀ ⊆ interior K₁) :
  ∃ F' : htpy_formal_sol R,
    (∀ᶠ t near Iic (0 : ℝ), F' t = F) ∧
    (∀ᶠ t near Ici (1 : ℝ), F' t = F' 1) ∧
    (∀ᶠ x near C, ∀ t, F' t x = F x) ∧
    (∀ t, ∀ x ∉ φ '' K₁, F' t x = F x) ∧
    (∀ t x, dist ((F' t).bs x) (F.bs x) < δ x) ∧
    ∀ᶠ x near C ∪ φ '' K₀, (F' 1).is_holonomic_at x :=
begin
  let Rloc : rel_loc EM EX := (R.localize φ ψ).rel_loc,
  have hRloc_op : is_open Rloc,
  { exact  is_open_of_is_open _ (hRopen.preimage $ one_jet_bundle.continuous_transfer _ _) },
  have hRloc_ample : Rloc.is_ample,
  { exact ample_of_ample _ (hRample.localize _ _) },
  -- TODO: try to be consistent about how to state the hFφψ condition
  replace hFφψ : range (F.bs ∘ φ) ⊆ range ψ,
  { rw range_comp,
    exact hFφψ },
  let p : chart_pair IM M IX X :=
  { φ := φ,
    ψ := ψ,
    K₁ := K₁,
    hK₁ := hK₁ },
  rcases p.dist_update' hδ_pos hδ_cont hFφψ with ⟨τ, τ_pos, hτ⟩,
  let 𝓕 := F.localize p hFφψ,
  let L : landscape EM :=
  { C := φ ⁻¹' C,
    K₀ := K₀,
    K₁ := K₁,
    hC := hC.preimage φ.continuous,
    hK₀ := hK₀,
    hK₁ := hK₁,
    h₀₁ := hK₀K₁ },
  have h𝓕C : ∀ᶠ (x : EM) near L.C, 𝓕.is_holonomic_at x,
  { rw eventually_nhds_set_iff at hFC ⊢,
    intros e he,
    rw [φ.inducing.nhds_eq_comap, eventually_comap],
    apply (hFC _ he).mono,
    rintros x hx e rfl,
    exact F.is_holonomic_localize p hFφψ e hx },
  rcases 𝓕.improve_htpy' hRloc_op hRloc_ample L τ_pos h𝓕C
    with ⟨𝓕', h𝓕't0, h𝓕't1, h𝓕'relC, h𝓕'relK₁, h𝓕'dist, h𝓕'hol⟩,
  have hcompat : p.compat' F 𝓕', from ⟨hFφψ, h𝓕'relK₁⟩,
  let F' : htpy_formal_sol R := p.mk_htpy F 𝓕',
  have hF'relK₁ : ∀ t, ∀ x ∉ φ '' K₁, F' t x = F x,
  { apply p.mk_htpy_eq_of_not_mem },
  have hF't0 : ∀ᶠ (t : ℝ) near Iic 0, F' t = F,
  { apply h𝓕't0.mono,
    rintros t ht,
    exact p.mk_htpy_eq_of_forall hcompat ht },
  have hF't1 : ∀ᶠ (t : ℝ) near Ici 1, F' t = F' 1,
  { exact h𝓕't1.mono (λ t, p.mk_htpy_congr _) },
  refine ⟨F', hF't0, hF't1, _, _, _, _⟩,
  { apply φ.forall_near hK₁ h𝓕'relC (eventually_of_forall $ λ x hx t, hF'relK₁ t x hx),
    { intros e he t,
      rw p.mk_htpy_eq_of_eq _ _ hcompat,
      exact he t } },
  { exact hF'relK₁ },
  { intros t x,
    rcases classical.em (x ∈ φ '' K₁) with ⟨e, he, rfl⟩|hx,
    { by_cases ht : t ∈ (Icc 0 1 : set ℝ),
      { exact hτ hcompat e he t ht (h𝓕'dist e t) },
      { rw [mem_Icc, not_and_distrib, not_le, not_le] at ht,
        cases ht with ht ht,
        { erw [hF't0.on_set t ht.le, dist_self],
          apply hδ_pos },
        { rw [hF't1.on_set t ht.le],
          exact hτ hcompat e he 1 (right_mem_Icc.mpr zero_le_one) (h𝓕'dist e 1) } } },
    { change dist ((F' t x).1.2) (F.bs x) < δ x,
      erw [p.mk_htpy_eq_of_not_mem _ _ hx, dist_self],
      apply hδ_pos } },
  { have h𝓕'holC : ∀ᶠ (x : EM) near L.C, (𝓕' 1).is_holonomic_at x,
    { apply (h𝓕'relC.eventually_nhds_set.and h𝓕C).mono,
      rintros x ⟨hx, hx'⟩,
      exact jet_sec.is_holonomic_at.congr hx' (hx.mono $ λ x' hx', (hx' 1).symm) },
    have : ∀ᶠ x near φ ⁻¹' C  ∪ K₀, (𝓕' 1).is_holonomic_at x := h𝓕'holC.union h𝓕'hol,
    rw [← preimage_image_eq K₀ φ.injective, ← preimage_union] at this,
    apply φ.forall_near hK₁ this,
    { apply filter.eventually.union,
      { apply hFC.mono,
        intros x hx hx',
        apply hx.congr,
        symmetry,
        have : ∀ᶠ y in 𝓝 x, y ∈ (φ '' K₁)ᶜ,
        { exact is_open_iff_mem_nhds.mp (hK₁.image φ.continuous).is_closed.is_open_compl x hx' },
        apply this.mono,
        exact hF'relK₁ _ },
      { have : ∀ᶠ x near φ '' K₀, x ∈ p.φ '' K₁,
      { suffices : ∀ᶠ x near φ '' K₀, x ∈ interior (p.φ '' K₁), from this.mono interior_subset,
        apply is_open_interior.forall_near_mem_of_subset,
        exact (image_subset φ hK₀K₁).trans (φ.open_map.image_interior_subset K₁) },
        apply this.mono,
        exact λ a hx hx', (hx' hx).elim } },
    { exact λ _, (p.mk_htpy_is_holonomic_at_iff hcompat).mpr } },
end


import logic.equiv.local_equiv

open set

lemma local_equiv.range_eq_target_of_source_eq_univ {α β : Type*}
  (e : local_equiv α β) (h : e.source = univ) :
  range e = e.target :=
by { rw [← image_univ, ← h], exact e.image_source_eq_target, }


/-
Copyright (c) 2020 Gabriel Ebner. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Gabriel Ebner
-/
import tactic.lint.basic

/-!
# Linter for simplification lemmas

This files defines several linters that prevent common mistakes when declaring simp lemmas:

 * `simp_nf` checks that the left-hand side of a simp lemma is not simplified by a different lemma.
 * `simp_var_head` checks that the head symbol of the left-hand side is not a variable.
 * `simp_comm` checks that commutativity lemmas are not marked as simplification lemmas.
-/

open tactic expr

/-- `simp_lhs_rhs ty` returns the left-hand and right-hand side of a simp lemma with type `ty`. -/
private meta def simp_lhs_rhs : expr → tactic (expr × expr) | ty := do
ty ← head_beta ty,
-- We only detect a fixed set of simp relations here.
-- This is somewhat justified since for a custom simp relation R,
-- the simp lemma `R a b` is implicitly converted to `R a b ↔ true` as well.
match ty with
| `(¬ %%lhs) := pure (lhs, `(false))
| `(%%lhs = %%rhs) := pure (lhs, rhs)
| `(%%lhs ↔ %%rhs) := pure (lhs, rhs)
| (expr.pi n bi a b) := do
  l ← mk_local' n bi a,
  simp_lhs_rhs (b.instantiate_var l)
| ty := pure (ty, `(true))
end

/-- `simp_lhs ty` returns the left-hand side of a simp lemma with type `ty`. -/
private meta def simp_lhs (ty : expr): tactic expr :=
prod.fst <$> simp_lhs_rhs ty

/--
`simp_is_conditional_core ty` returns `none` if `ty` is a conditional simp
lemma, and `some lhs` otherwise.
-/
private meta def simp_is_conditional_core : expr → tactic (option expr) | ty := do
ty ← head_beta ty,
match ty with
| `(¬ %%lhs) := pure lhs
| `(%%lhs = _) := pure lhs
| `(%%lhs ↔ _) := pure lhs
| (expr.pi n bi a b) := do
  l ← mk_local' n bi a,
  some lhs ← simp_is_conditional_core (b.instantiate_var l) | pure none,
  if bi ≠ binder_info.inst_implicit ∧
      ¬ (lhs.abstract_local l.local_uniq_name).has_var then
    pure none
  else
    pure lhs
| ty := pure ty
end

/--
`simp_is_conditional ty` returns true iff the simp lemma with type `ty` is conditional.
-/
private meta def simp_is_conditional (ty : expr) : tactic bool :=
option.is_none <$> simp_is_conditional_core ty

private meta def heuristic_simp_lemma_extraction (prf : expr) : tactic (list name) :=
prf.list_constant.to_list.mfilter is_simp_lemma

/-- Checks whether two expressions are equal for the simplifier. That is,
they are reducibly-definitional equal, and they have the same head symbol. -/
meta def is_simp_eq (a b : expr) : tactic bool :=
if a.get_app_fn.const_name ≠ b.get_app_fn.const_name then pure ff else
succeeds $ is_def_eq a b transparency.reducible

/-- Reports declarations that are simp lemmas whose left-hand side is not in simp-normal form. -/
meta def simp_nf_linter (timeout := 200000) (d : declaration) : tactic (option string) := do
tt ← is_simp_lemma d.to_name | pure none,
-- Sometimes, a definition is tagged @[simp] to add the equational lemmas to the simp set.
-- In this case, ignore the declaration if it is not a valid simp lemma by itself.
tt ← is_valid_simp_lemma_cnst d.to_name | pure none,
[] ← get_eqn_lemmas_for ff d.to_name | pure none,
try_for timeout $
retrieve $ do
g ← mk_meta_var d.type,
set_goals [g],
unfreezing intros,
(lhs, rhs) ← target >>= simp_lhs_rhs,
sls ← simp_lemmas.mk_default,
let sls' := sls.erase [d.to_name],
(lhs', prf1, ns1) ← decorate_error "simplify fails on left-hand side:" $
  simplify sls [] lhs {fail_if_unchanged := ff},
prf1_lems ← heuristic_simp_lemma_extraction prf1,
if d.to_name ∈ prf1_lems then pure none else do
is_cond ← simp_is_conditional d.type,
(rhs', prf2, ns2) ← decorate_error "simplify fails on right-hand side:" $
  simplify sls [] rhs {fail_if_unchanged := ff},
lhs'_eq_rhs' ← is_simp_eq lhs' rhs',
lhs_in_nf ← is_simp_eq lhs' lhs,
if lhs'_eq_rhs' then do
  used_lemmas ← heuristic_simp_lemma_extraction (prf1 prf2),
  pure $ pure $ "simp can prove this:\n"
    ++ "  by simp only " ++ to_string used_lemmas ++ "\n"
    ++ "One of the lemmas above could be a duplicate.\n"
    ++ "If that's not the case try reordering lemmas or adding @[priority].\n"
else if ¬ lhs_in_nf then do
  lhs ← pp lhs,
  lhs' ← pp lhs',
  pure $ format.to_string $
    to_fmt "Left-hand side simplifies from"
      ++ lhs.group.indent 2 ++ format.line
      ++ "to" ++ lhs'.group.indent 2 ++ format.line
      ++ "using " ++ (to_fmt prf1_lems).group.indent 2 ++ format.line
      ++ "Try to change the left-hand side to the simplified term!\n"
else if ¬ is_cond ∧ lhs = lhs' then
  pure $ some $ "Left-hand side does not simplify.\nYou need to debug this yourself using " ++
"`set_option trace.simplify.rewrite true`"
else
  pure none

/--
This note gives you some tips to debug any errors that the simp-normal form linter raises.

The reason that a lemma was considered faulty is because its left-hand side is not in simp-normal
form.
These lemmas are hence never used by the simplifier.

This linter gives you a list of other simp lemmas: look at them!

Here are some tips depending on the error raised by the linter:

  1. 'the left-hand side reduces to XYZ':
     you should probably use XYZ as the left-hand side.

  2. 'simp can prove this':
     This typically means that lemma is a duplicate, or is shadowed by another lemma:

     2a. Always put more general lemmas after specific ones:
      ```
      @[simp] lemma zero_add_zero : 0 + 0 = 0 := rfl
      @[simp] lemma add_zero : x + 0 = x := rfl
      ```

      And not the other way around!  The simplifier always picks the last matching lemma.

     2b. You can also use `@[priority]` instead of moving simp-lemmas around in the file.

      Tip: the default priority is 1000.
      Use `@[priority 1100]` instead of moving a lemma down,
      and `@[priority 900]` instead of moving a lemma up.

     2c. Conditional simp lemmas are tried last. If they are shadowed
         just remove the `simp` attribute.

     2d. If two lemmas are duplicates, the linter will complain about the first one.
         Try to fix the second one instead!
         (You can find it among the other simp lemmas the linter prints out!)

  3. 'try_for tactic failed, timeout':
     This typically means that there is a loop of simp lemmas.
     Try to apply squeeze_simp to the right-hand side (removing this lemma from the simp set) to see
     what lemmas might be causing the loop.

     Another trick is to `set_option trace.simplify.rewrite true` and
     then apply `try_for 10000 { simp }` to the right-hand side.  You will
     see a periodic sequence of lemma applications in the trace message.
-/
library_note "simp-normal form"

/-- A linter for simp lemmas whose lhs is not in simp-normal form, and which hence never fire. -/
@[linter] meta def linter.simp_nf : linter :=
{ test := simp_nf_linter,
  auto_decls := tt,
  no_errors_found := "All left-hand sides of simp lemmas are in simp-normal form.",
  errors_found := "SOME SIMP LEMMAS ARE NOT IN SIMP-NORMAL FORM.
see note [simp-normal form] for tips how to debug this.
https://leanprover-community.github.io/mathlib_docs/notes.html#simp-normal%20form" }

private meta def simp_var_head (d : declaration) : tactic (option string) := do
tt ← is_simp_lemma d.to_name | pure none,
-- Sometimes, a definition is tagged @[simp] to add the equational lemmas to the simp set.
-- In this case, ignore the declaration if it is not a valid simp lemma by itself.
tt ← is_valid_simp_lemma_cnst d.to_name | pure none,
lhs ← simp_lhs d.type,
head_sym@(expr.local_const _ _ _ _) ← pure lhs.get_app_fn | pure none,
head_sym ← pp head_sym,
pure $ format.to_string $ "Left-hand side has variable as head symbol: " ++ head_sym

/--
A linter for simp lemmas whose lhs has a variable as head symbol,
and which hence never fire.
-/
@[linter] meta def linter.simp_var_head : linter :=
{ test := simp_var_head,
  auto_decls := tt,
  no_errors_found :=
    "No left-hand sides of a simp lemma has a variable as head symbol.",
  errors_found := "LEFT-HAND SIDE HAS VARIABLE AS HEAD SYMBOL.\n" ++
    "Some simp lemmas have a variable as head symbol of the left-hand side:" }

private meta def simp_comm (d : declaration) : tactic (option string) := do
tt ← is_simp_lemma d.to_name | pure none,
-- Sometimes, a definition is tagged @[simp] to add the equational lemmas to the simp set.
-- In this case, ignore the declaration if it is not a valid simp lemma by itself.
tt ← is_valid_simp_lemma_cnst d.to_name | pure none,
(lhs, rhs) ← simp_lhs_rhs d.type,
if lhs.get_app_fn.const_name ≠ rhs.get_app_fn.const_name then pure none else do
(lhs', rhs') ← (prod.snd <$> open_pis_metas d.type) >>= simp_lhs_rhs,
tt ← succeeds $ unify rhs lhs' transparency.reducible | pure none,
tt ← succeeds $ is_def_eq rhs lhs' transparency.reducible | pure none,
-- ensure that the second application makes progress:
ff ← succeeds $ unify lhs' rhs' transparency.reducible | pure none,
pure $ "should not be marked simp"

/-- A linter for commutativity lemmas that are marked simp. -/
@[linter] meta def linter.simp_comm : linter :=
{ test := simp_comm,
  auto_decls := tt,
  no_errors_found := "No commutativity lemma is marked simp.",
  errors_found := "COMMUTATIVITY LEMMA IS SIMP.\n" ++
    "Some commutativity lemmas are simp lemmas:" }


import data.matrix.notation

/-!

Helpers that don't currently fit elsewhere...

-/

lemma split_eq {m n : Type*} (x : m × n) (p p' : m × n) :
  p = x ∨ p' = x ∨ (x ≠ p ∧ x ≠ p') := by tauto

-- For `playfield`s, the piece type and/or piece index type.
variables (X : Type*)
variables [has_repr X]

namespace chess.utils

section repr

/--
An auxiliary wrapper for `option X` that allows for overriding the `has_repr` instance
for `option`, and rather, output just the value in the `some` and a custom provided
`string` for `none`.
-/
structure option_wrapper :=
(val : option X)
(none_s : string)

instance wrapped_option_repr : has_repr (option_wrapper X) :=
⟨λ ⟨val, s⟩, (option.map has_repr.repr val).get_or_else s⟩

variables {X}
/--
Construct an `option_wrapper` term from a provided `option X` and the `string`
that will override the `has_repr.repr` for `none`.
-/
def option_wrap (val : option X) (none_s : string) : option_wrapper X := ⟨val, none_s⟩

-- The size of the "vectors" for a `fin n' → X`, for `has_repr` definitions
variables {m' n' : ℕ}

/--
For a "vector" `X^n'` represented by the type `Π n' : ℕ, fin n' → X`, where
the `X` has a `has_repr` instance itself, we can provide a `has_repr` for the "vector".
This definition is used for displaying rows of the playfield, when it is defined
via a `matrix`, likely through notation.
-/
def vec_repr : Π {n' : ℕ}, (fin n' → X) → string :=
λ _ v, string.intercalate ", " ((vector.of_fn v).to_list.map repr)

instance vec_repr_instance : has_repr (fin n' → X) := ⟨vec_repr⟩

/--
For a `matrix` `X^(m' × n')` where the `X` has a `has_repr` instance itself,
we can provide a `has_repr` for the matrix, using `vec_repr` for each of the rows of the matrix.
This definition is used for displaying the playfield, when it is defined
via a `matrix`, likely through notation.
-/
def matrix_repr : Π {m' n'}, matrix (fin m') (fin n') X → string :=
λ _ _ M, string.intercalate ";\n" ((vector.of_fn M).to_list.map repr)

instance matrix_repr_instance :
  has_repr (matrix (fin n') (fin m') X) := ⟨matrix_repr⟩

end repr

end chess.utils


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import order.category.Lat

/-!
# The category of distributive lattices

This file defines `DistLat`, the category of distributive lattices.

Note that [`DistLat`](https://ncatlab.org/nlab/show/DistLat) in the literature doesn't always
correspond to `DistLat` as we don't require bottom or top elements. Instead, this `DistLat`
corresponds to `BddDistLat`.
-/

universes u

open category_theory

/-- The category of distributive lattices. -/
def DistLat := bundled distrib_lattice

namespace DistLat

instance : has_coe_to_sort DistLat Type* := bundled.has_coe_to_sort
instance (X : DistLat) : distrib_lattice X := X.str

/-- Construct a bundled `DistLat` from a `distrib_lattice` underlying type and typeclass. -/
def of (α : Type*) [distrib_lattice α] : DistLat := bundled.of α

@[simp] lemma coe_of (α : Type*) [distrib_lattice α] : ↥(of α) = α := rfl

instance : inhabited DistLat := ⟨of punit⟩

instance : bundled_hom.parent_projection @distrib_lattice.to_lattice := ⟨⟩

attribute [derive [large_category, concrete_category]] DistLat

instance has_forget_to_Lat : has_forget₂ DistLat Lat := bundled_hom.forget₂ _ _

/-- Constructs an equivalence between distributive lattices from an order isomorphism between them.
-/
@[simps] def iso.mk {α β : DistLat.{u}} (e : α ≃o β) : α ≅ β :=
{ hom := e,
  inv := e.symm,
  hom_inv_id' := by { ext, exact e.symm_apply_apply _ },
  inv_hom_id' := by { ext, exact e.apply_symm_apply _ } }

/-- `order_dual` as a functor. -/
@[simps] def dual : DistLat ⥤ DistLat :=
{ obj := λ X, of Xᵒᵈ, map := λ X Y, lattice_hom.dual }

/-- The equivalence between `DistLat` and itself induced by `order_dual` both ways. -/
@[simps functor inverse] def dual_equiv : DistLat ≌ DistLat :=
equivalence.mk dual dual
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)

end DistLat

lemma DistLat_dual_comp_forget_to_Lat :
  DistLat.dual ⋙ forget₂ DistLat Lat =
    forget₂ DistLat Lat ⋙ Lat.dual := rfl


-- From AT: This approach could work, but seems too complicated for now.
-- I have opted to use the comparison lemma instead.
-- See the folder `condensed/extr/`.
/-
import topology.category.Profinite
import for_mathlib.Profinite.disjoint_union

open category_theory

namespace Profinite

universe u

/- The following three lemmas are used below to help speed up some proofs. -/

@[simp] lemma pullback.fst_apply {A B C : Profinite.{u}} (f : A ⟶ C) (g : B ⟶ C)
  (a : A) (b : B) (h : f a = g b) : Profinite.pullback.fst f g ⟨(a,b),h⟩ = a := rfl

@[simp] lemma pullback.snd_apply {A B C : Profinite.{u}} (f : A ⟶ C) (g : B ⟶ C)
  (a : A) (b : B) (h : f a = g b) : Profinite.pullback.snd f g ⟨(a,b),h⟩ = b := rfl

@[simp] lemma pullback.lift_apply {A B C D : Profinite.{u}} (f : A ⟶ C) (g : B ⟶ C)
  (a : D ⟶ A) (b : D ⟶ B) (w : a ≫ f = b ≫ g) (d : D) :
  Profinite.pullback.lift f g a b w d = ⟨(a d, b d), by { change (a ≫ f) d = _, rw w, refl }⟩ :=
rfl

structure prepresentation (B : Profinite.{u}) :=
(G : Profinite.{u})
(π : G ⟶ B)
(hπ : function.surjective π)
(R : Profinite.{u})
(r : R ⟶ Profinite.pullback π π)
(hr : function.surjective r)

def prepresentation.fst {B : Profinite.{u}} (P : B.prepresentation) :
  P.R ⟶ P.G :=
P.r ≫ Profinite.pullback.fst _ _

def prepresentation.snd {B : Profinite.{u}} (P : B.prepresentation) :
  P.R ⟶ P.G :=
P.r ≫ Profinite.pullback.snd _ _

lemma prepresentation.fst_surjective {B : Profinite.{u}} (P : B.prepresentation) :
  function.surjective P.fst :=
begin
  apply function.surjective.comp _ P.hr,
  intros x,
  exact ⟨⟨⟨x,x⟩,rfl⟩,rfl⟩,
end

lemma prepresentation.snd_surjective {B : Profinite.{u}} (P : B.prepresentation) :
  function.surjective P.snd :=
begin
  apply function.surjective.comp _ P.hr,
  intros x,
  exact ⟨⟨⟨x,x⟩,rfl⟩,rfl⟩,
end

def prepresentation.base {B : Profinite.{u}} (P : B.prepresentation) :
  P.R ⟶ B :=
P.snd ≫ P.π

@[simp, reassoc, elementwise]
lemma prepresentation.base_fst {B : Profinite.{u}} (P : B.prepresentation) :
  P.fst ≫ P.π = P.base :=
by { dsimp [prepresentation.fst, prepresentation.snd, prepresentation.base],
  simp [Profinite.pullback.condition] }

@[simp, reassoc, elementwise]
lemma prepresentation.base_snd {B : Profinite.{u}} (P : B.prepresentation) :
  P.snd ≫ P.π = P.base := rfl

lemma prepresentation.base_surjective {B : Profinite.{u}} (P : B.prepresentation) :
  function.surjective P.base := function.surjective.comp P.hπ P.snd_surjective

structure prepresentation.hom_over {B₁ B₂ : Profinite.{u}}
  (X₁ : B₁.prepresentation) (X₂ : B₂.prepresentation) (f : B₁ ⟶ B₂) :=
(g : X₁.G ⟶ X₂.G)
(hg : g ≫ X₂.π = X₁.π ≫ f)
(r : X₁.R ⟶ X₂.R)
(fst : r ≫ X₂.fst = X₁.fst ≫ g)
(snd : r ≫ X₂.snd = X₁.snd ≫ g)

attribute [simp, reassoc, elementwise]
  prepresentation.hom_over.hg
  prepresentation.hom_over.fst
  prepresentation.hom_over.snd

local attribute [simp, elementwise]
  Profinite.pullback.condition
  Profinite.pullback.condition_assoc

def prepresentation.hom_over.comp {B₁ B₂ B₃ : Profinite.{u}}
  {X₁ : B₁.prepresentation} {X₂ : B₂.prepresentation} {X₃ : B₃.prepresentation}
  {f₁ : B₁ ⟶ B₂} {f₂ : B₂ ⟶ B₃}
  (e₁ : X₁.hom_over X₂ f₁) (e₂ : X₂.hom_over X₃ f₂) :
  X₁.hom_over X₃ (f₁ ≫ f₂) :=
{ g := e₁.g ≫ e₂.g,
  hg := by simp,
  r := e₁.r ≫ e₂.r,
  fst := by simp,
  snd := by simp }

def prepresentation.pullback_G {X B : Profinite} (f : X ⟶ B) (hf : function.surjective f)
  (P : B.prepresentation) : X.prepresentation :=
{ G := Profinite.pullback f P.π,
  π := Profinite.pullback.fst _ _,
  hπ := begin
    intros x,
    obtain ⟨y,hy⟩ := P.hπ (f x),
    exact ⟨⟨⟨x,y⟩,hy.symm⟩,rfl⟩,
  end,
  R := Profinite.pullback f P.base,
  r := Profinite.pullback.lift _ _
    (Profinite.pullback.lift _ _
      (Profinite.pullback.fst _ _)
      (Profinite.pullback.snd _ _ ≫ P.fst) $ by simp)
    (Profinite.pullback.lift _ _
      (Profinite.pullback.fst _ _)
      (Profinite.pullback.snd _ _ ≫ P.snd) $ by simp) $ by simp,
  hr := begin
    rintros ⟨⟨⟨⟨a,b₁⟩,h₁⟩,⟨⟨a₂,b₂⟩,h₂⟩⟩,(rfl : a = a₂)⟩,
    dsimp at h₁ h₂,
    let c : Profinite.pullback P.π P.π := ⟨⟨b₁,b₂⟩,_⟩,
    swap, { dsimp, rw [← h₁, ← h₂] },
    obtain ⟨d,hd⟩ := P.hr c,
    refine ⟨⟨⟨a,d⟩,_⟩,_⟩,
    { dsimp only [prepresentation.base, prepresentation.snd],
      dsimp,
      rwa hd },
    { dsimp [prepresentation.fst, prepresentation.snd],
      congr,
      { simp [hd] },
      { simp [hd] } },
  end } .

def presentation.pullback_R {X B : Profinite} (f : X ⟶ B) (hf : function.surjective f)
  (P : B.prepresentation) : (Profinite.pullback f f).prepresentation :=
{ G := Profinite.pullback (Profinite.pullback.snd f f ≫ f) P.π,
  π := Profinite.pullback.lift _ _
    (Profinite.pullback.fst _ _ ≫ Profinite.pullback.fst _ _)
    (Profinite.pullback.fst _ _ ≫ Profinite.pullback.snd _ _) $ by simp,
  hπ := begin
    rintros ⟨⟨a,b⟩,h⟩,
    dsimp at h,
    obtain ⟨c,hc⟩ := P.hπ (f b),
    refine ⟨⟨⟨⟨⟨a,b⟩,h⟩,c⟩,hc.symm⟩,_⟩,
    refl,
  end,
  R := Profinite.pullback (Profinite.pullback.snd f f ≫ f) P.base,
  r := Profinite.pullback.lift _ _
    (Profinite.pullback.lift _ _
      (Profinite.pullback.fst _ _)
      (Profinite.pullback.snd _ _ ≫ P.fst) $ by simp)
    (Profinite.pullback.lift _ _
      (Profinite.pullback.fst _ _)
      (Profinite.pullback.snd _ _ ≫ P.snd) $ by simp) $
      by { apply Profinite.pullback.hom_ext; simp },
  hr := begin
    rintros ⟨⟨⟨⟨⟨⟨a₁,a₁'⟩,h₁'⟩,b₁⟩,h₁⟩,⟨⟨⟨⟨a₂,a₂'⟩,h₂'⟩,b₂⟩,h₂⟩⟩,h⟩,
    change f a₁' = (P.π) b₁ at h₁,
    change f a₂' = (P.π) b₂ at h₂,
    change f a₁ = f a₁' at h₁',
    change f a₂ = f a₂' at h₂',
    change _ = _ at h,
    have hfst := h,
    have hsnd := h,
    apply_fun (λ a, a.1.1) at hfst,
    apply_fun (λ a, a.1.2) at hsnd,
    change a₁ = a₂ at hfst,
    change a₁' = a₂' at hsnd,
    let e : Profinite.pullback f f := ⟨⟨a₁,a₁'⟩, h₁'⟩,
    let w₀ : Profinite.pullback P.π P.π := ⟨⟨b₁,b₂⟩,_⟩,
    swap, { change _ = _, rw [← h₁, ← h₂, hsnd] },
    obtain ⟨w₁,hw₁⟩ := P.hr w₀,
    let w : Profinite.pullback (pullback.snd f f ≫ f) P.base := ⟨⟨e,w₁⟩,_⟩,
    swap, { change _ = _, change f _ = P.π (pullback.snd _ _ _),
      erw hw₁,
      dsimp only [pullback.fst_apply, e, pullback.snd_apply], rw hsnd, exact h₂ },
    use w,
    dsimp only [w, e, pullback.fst_apply, pullback.snd_apply, pullback.lift_apply],
    congr,
    { dsimp [prepresentation.fst],
      rw hw₁, refl },
    { congr' 2 },
    { dsimp [prepresentation.snd],
      rw hw₁, refl },
  end } .

def prepresentation.pullback_π {X B : Profinite}
  (f : X ⟶ B) (hf : function.surjective f)
  (P : B.prepresentation) : (P.pullback_G f hf).hom_over P f :=
{ g := Profinite.pullback.snd _ _,
  hg := begin
    dsimp [prepresentation.pullback_G],
    simp,
  end,
  r := Profinite.pullback.snd _ _,
  fst := begin
    dsimp [prepresentation.pullback_G, prepresentation.fst],
    simp,
  end,
  snd := begin
    dsimp [prepresentation.pullback_G, prepresentation.snd],
    simp,
  end }

lemma prepresentation.pullback_π_g_surjective {X B : Profinite}
  (f : X ⟶ B) (hf : function.surjective f)
  (P : B.prepresentation) :
  function.surjective (P.pullback_π f hf).g :=
begin
  intros x,
  obtain ⟨y,hy⟩ := hf (P.π x),
  exact ⟨⟨⟨y,x⟩,hy⟩,rfl⟩,
end

lemma prepresentation.pullback_π_r_surjective {X B : Profinite}
  (f : X ⟶ B) (hf : function.surjective f)
  (P : B.prepresentation) :
  function.surjective (P.pullback_π f hf).r :=
begin
  intros x,
  obtain ⟨y,hy⟩ := hf (P.base x),
  exact ⟨⟨⟨y,x⟩,hy⟩,rfl⟩
end

end Profinite
-/


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

import category_theory.limits.shapes.binary_products
import category_theory.limits.preserves.shapes.binary_products
import category_theory.limits.shapes.pullbacks
import category_theory.comma
import category_theory.adjunction.limits
import category_theory.pempty
import category_theory.limits.preserves.basic
import category_theory.limits.preserves.shapes.products
import category.pullbacks

universes v u u' u₂

noncomputable theory
open category_theory category_theory.category category_theory.limits
namespace category_theory

section

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

instance mono_prod_map {X Y Z W : C} (f : X ⟶ Y) (g : W ⟶ Z) [has_binary_products.{v} C] [mono f] [mono g] : mono (limits.prod.map f g) :=
⟨λ A h k l, begin
  apply prod.hom_ext,
  { rw [← cancel_mono f, assoc, assoc, ← limits.prod.map_fst f g, reassoc_of l] },
  { rw [← cancel_mono g, assoc, assoc, ← limits.prod.map_snd f g, reassoc_of l] },
end⟩

variables {F : J ⥤ C}

open category_theory.equivalence

def cone_equivalence_comp (e : K ≌ J) (c : cone F) : cone (e.functor ⋙ F) := cone.whisker e.functor c
def is_limit_equivalence_comp (e : K ≌ J) {c : cone F} (t : is_limit c) : is_limit (cone.whisker e.functor c) :=
is_limit.whisker_equivalence t _

end

-- def discrete_equiv_of_iso {J : Type u} {K : Type u₂} (h : J ≃ K) : discrete J ≌ discrete K :=
-- { functor := discrete.functor h.to_fun,
--   inverse := functor.of_function h.inv_fun,
--   unit_iso := nat_iso.of_components (λ X, eq_to_iso (h.left_inv X).symm) (λ X Y f, dec_trivial),
--   counit_iso := nat_iso.of_components (λ X, eq_to_iso (h.right_inv X)) (λ X Y f, dec_trivial) }

-- def pempty_equiv_discrete0 : pempty ≌ discrete (ulift (fin 0)) :=
-- begin
--   apply (functor.empty (discrete pempty)).as_equivalence.trans (discrete.equivalence _),
--   refine ⟨λ x, x.elim, λ ⟨t⟩, t.elim0, λ t, t.elim, λ ⟨t⟩, t.elim0⟩,
-- end

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

section
variables {D : Type u₂} [category.{v} D]

section

variables [has_finite_products.{v} C] [has_finite_products.{v} D] (F : C ⥤ D)

@[reassoc]
lemma thingy (A B : C) [is_iso (prod_comparison F A B)] :
  inv (prod_comparison F A B) ≫ F.map limits.prod.fst = limits.prod.fst :=
begin
  erw (as_iso (prod_comparison F A B)).inv_comp_eq,
  dsimp [as_iso_hom, prod_comparison],
  rw prod.lift_fst,
end

@[reassoc]
lemma thingy2 (A B : C) [is_iso (prod_comparison F A B)] :
  inv (prod_comparison F A B) ≫ F.map limits.prod.snd = limits.prod.snd :=
begin
  erw (as_iso (prod_comparison F A B)).inv_comp_eq,
  dsimp [as_iso_hom, prod_comparison],
  rw prod.lift_snd,
end

@[reassoc] lemma prod_comparison_inv_natural {A A' B B' : C} (f : A ⟶ A') (g : B ⟶ B') [is_iso (prod_comparison F A B)] [is_iso (prod_comparison F A' B')] :
  inv (prod_comparison F A B) ≫ F.map (limits.prod.map f g) = limits.prod.map (F.map f) (F.map g) ≫ inv (prod_comparison F A' B') :=
begin
  erw [(as_iso (prod_comparison F A' B')).eq_comp_inv, assoc, (as_iso (prod_comparison F A B)).inv_comp_eq],
  apply prod_comparison_natural,
end

variables [preserves_limits_of_shape (discrete walking_pair) F]

end

/-- Transfer preservation of limits along a equivalence in the shape. -/
def preserves_limit_of_equiv {J₁ J₂ : Type v} [small_category J₁] [small_category J₂] (e : J₁ ≌ J₂)
  (F : C ⥤ D) [preserves_limits_of_shape J₁ F] :
  preserves_limits_of_shape J₂ F :=
{ preserves_limit := λ K,
  begin
    refine ⟨λ c t, _⟩,
    have : is_limit (F.map_cone (cone.whisker e.functor c)),
      apply is_limit_of_preserves F (is_limit.whisker_equivalence t e),
    have := is_limit.whisker_equivalence this e.symm,
    let equ := e.inv_fun_id_assoc (K ⋙ F),
    apply ((is_limit.postcompose_hom_equiv equ _).symm this).of_iso_limit,
    apply cones.ext _ _,
    { apply iso.refl _ },
    { intro j,
      dsimp,
      simp [←functor.map_comp] },
  end }

@[simps {rhs_md := semireducible}]
def build_prod {n : ℕ} {f : ulift (fin (n+1)) → C}
  (c₁ : fan (λ (i : ulift (fin n)), f ⟨i.down.succ⟩))
  (c₂ : binary_fan (f ⟨0⟩) c₁.X) :
fan f :=
fan.mk c₂.X
begin
  rintro ⟨i⟩,
  revert i,
  refine fin.cases _ _,
  { apply c₂.fst },
  { intro i,
    apply c₂.snd ≫ c₁.π.app (ulift.up i) },
end

def build_limit {n : ℕ} (f : ulift (fin (n+1)) → C)
  {c₁ : fan (λ (i : ulift (fin n)), f ⟨i.down.succ⟩)} {c₂ : binary_fan (f ⟨0⟩) c₁.X}
  (t₁ : is_limit c₁) (t₂ : is_limit c₂) :
  is_limit (build_prod c₁ c₂) :=
{ lift := λ s,
  begin
    apply (binary_fan.is_limit.lift' t₂ _ _).1,
    { apply s.π.app ⟨0⟩ },
    { apply t₁.lift ⟨_, discrete.nat_trans (λ i, s.π.app ⟨i.down.succ⟩)⟩ }
  end,
  fac' := λ s,
  begin
    rintro ⟨j⟩,
    revert j,
    rw fin.forall_fin_succ,
    split,
    { apply (binary_fan.is_limit.lift' t₂ _ _).2.1 },
    { intro i,
      dsimp only [build_prod_π_app],
      rw [fin.cases_succ, ← assoc, (binary_fan.is_limit.lift' t₂ _ _).2.2, t₁.fac],
      refl }
  end,
  uniq' := λ s m w,
  begin
    apply binary_fan.is_limit.hom_ext t₂,
    { rw (binary_fan.is_limit.lift' t₂ _ _).2.1,
      apply w ⟨0⟩ },
    { rw (binary_fan.is_limit.lift' t₂ _ _).2.2,
      apply t₁.uniq ⟨_, _⟩,
      rintro ⟨j⟩,
      rw assoc,
      dsimp only [discrete.nat_trans_app],
      rw ← w ⟨j.succ⟩,
      dsimp only [build_prod_π_app],
      rw fin.cases_succ }
  end }

variables (F : C ⥤ D) [preserves_limits_of_shape (discrete walking_pair) F] [preserves_limits_of_shape (discrete pempty) F]
variables [has_finite_products.{v} C] [has_finite_products.{v} D]

def fin0_equiv_pempty : fin 0 ≃ pempty :=
equiv.equiv_pempty (λ a, a.elim0)

lemma has_scalar.ext {R M : Type*} : ∀ (a b : has_scalar R M), a.smul = b.smul → a = b
| ⟨_⟩ ⟨_⟩ rfl := rfl

noncomputable def preserves_fin_of_preserves_binary_and_terminal  :
  Π (n : ℕ) (f : ulift (fin n) → C), preserves_limit (discrete.functor f) F
| 0 := λ f,
  begin
    letI : preserves_limits_of_shape (discrete (ulift (fin 0))) F :=
      preserves_limit_of_equiv (discrete.equivalence (equiv.ulift.trans fin0_equiv_pempty).symm) _,
    apply_instance,
  end
| (n+1) :=
  begin
    haveI := preserves_fin_of_preserves_binary_and_terminal n,
    intro f,
    refine preserves_limit_of_preserves_limit_cone
      (build_limit f (limit.is_limit _) (limit.is_limit _)) _,
    apply (is_limit_map_cone_fan_mk_equiv _ _ _).symm _,
    let := build_limit (λ i, F.obj (f i))
              (is_limit_of_has_product_of_preserves_limit F _)
              (is_limit_of_has_binary_product_of_preserves_limit F _ _),
    refine is_limit.of_iso_limit this _,
    apply cones.ext _ _,
    apply iso.refl _,
    rintro ⟨j⟩,
    revert j,
    refine fin.cases _ _,
    { symmetry,
      apply category.id_comp _ },
    { intro i,
      symmetry,
      dsimp,
      rw [fin.cases_succ, fin.cases_succ],
      change 𝟙 _ ≫ F.map _ = F.map _ ≫ F.map _,
      rw [id_comp, ← F.map_comp],
      refl }
  end

def preserves_ulift_fin_of_preserves_binary_and_terminal (n : ℕ) :
  preserves_limits_of_shape (discrete (ulift (fin n))) F :=
{ preserves_limit := λ K,
  begin
    let : discrete.functor K.obj ≅ K := discrete.nat_iso (λ i, iso.refl _),
    haveI := preserves_fin_of_preserves_binary_and_terminal F n K.obj,
    apply preserves_limit_of_iso_diagram F this,
  end }

def preserves_finite_products_of_preserves_binary_and_terminal (J : Type v) [fintype J] :
  preserves_limits_of_shape.{v} (discrete J) F :=
begin
  classical,
  refine trunc.rec_on_subsingleton (fintype.equiv_fin J) _,
  intro e,
  haveI := preserves_ulift_fin_of_preserves_binary_and_terminal F (fintype.card J),
  apply preserves_limit_of_equiv (discrete.equivalence (e.trans equiv.ulift.symm)).symm,
end

end

variables [has_binary_products.{v} C] {B : C} [has_binary_products.{v} (over B)]
variables (f g : over B)

@[reducible]
def magic_arrow (f g : over B) :
  (g ⨯ f).left ⟶ g.left ⨯ f.left :=
prod.lift ((limits.prod.fst : g ⨯ f ⟶ g).left) ((limits.prod.snd : g ⨯ f ⟶ f).left)

-- This is an equalizer but we don't really need that
instance magic_mono : mono (magic_arrow f g) :=
begin
  refine ⟨λ Z p q h, _⟩,
  have h₁ := h =≫ limits.prod.fst,
  rw [assoc, assoc, prod.lift_fst] at h₁,
  have h₂ := h =≫ limits.prod.snd,
  rw [assoc, assoc, prod.lift_snd] at h₂,
  have: p ≫ (g ⨯ f).hom = q ≫ (g ⨯ f).hom,
    have: (g ⨯ f).hom = (limits.prod.fst : g ⨯ f ⟶ g).left ≫ g.hom := (over.w (limits.prod.fst : g ⨯ f ⟶ g)).symm,
    rw this,
    apply reassoc_of h₁,
  let Z' : over B := over.mk (q ≫ (g ⨯ f).hom),
  let p' : Z' ⟶ g ⨯ f := over.hom_mk p,
  let q' : Z' ⟶ g ⨯ f := over.hom_mk q,
  suffices: p' = q',
    show p'.left = q'.left,
    rw this,
  apply prod.hom_ext,
  ext1,
  exact h₁,
  ext1,
  exact h₂,
end

def magic_comm (f g h : over B) (k : f ⟶ g) :
  (limits.prod.map k (𝟙 h)).left ≫ magic_arrow h g = magic_arrow h f ≫ limits.prod.map k.left (𝟙 h.left) :=
begin
  apply prod.hom_ext,
  { rw [assoc, prod.lift_fst, ← over.comp_left, limits.prod.map_fst, assoc, limits.prod.map_fst, prod.lift_fst_assoc], refl },
  { rw [assoc, assoc, limits.prod.map_snd, comp_id, prod.lift_snd, ← over.comp_left, limits.prod.map_snd, comp_id, prod.lift_snd] }
end
def magic_pb (f g h : over B) (k : f ⟶ g) :
  is_limit (pullback_cone.mk (limits.prod.map k (𝟙 h)).left (magic_arrow h f) (magic_comm f g h k)) :=
begin
  refine is_limit.mk' _ _,
  intro s,
  have s₁ := pullback_cone.condition s =≫ limits.prod.fst,
    rw [assoc, assoc, prod.lift_fst, limits.prod.map_fst] at s₁,
  have s₂ := pullback_cone.condition s =≫ limits.prod.snd,
    rw [assoc, assoc, prod.lift_snd, limits.prod.map_snd, comp_id] at s₂,
  let sX' : over B := over.mk (pullback_cone.fst s ≫ (g ⨯ h).hom),
  have z : (pullback_cone.snd s ≫ limits.prod.snd) ≫ h.hom = sX'.hom,
    rw ← s₂,
    change (pullback_cone.fst s ≫ _) ≫ h.hom = pullback_cone.fst s ≫ (g ⨯ h).hom,
    rw ← over.w (limits.prod.snd : g ⨯ h ⟶ _),
    rw assoc,
  have z₂ : (pullback_cone.snd s ≫ limits.prod.fst) ≫ f.hom = pullback_cone.fst s ≫ (g ⨯ h).hom,
    rw ← over.w k,
    slice_lhs 1 3 {rw ← s₁},
    rw assoc,
    rw over.w (limits.prod.fst : g ⨯ h ⟶ _),
  let l : sX' ⟶ f := over.hom_mk (pullback_cone.snd s ≫ limits.prod.fst) z₂,
  let t : sX' ⟶ f ⨯ h := prod.lift l (over.hom_mk (pullback_cone.snd s ≫ limits.prod.snd) z),
  have t₁: t.left ≫ (limits.prod.fst : f ⨯ h ⟶ f).left = l.left,
    rw [← over.comp_left, prod.lift_fst],
  have t₂: t.left ≫ (limits.prod.snd : f ⨯ h ⟶ h).left = pullback_cone.snd s ≫ limits.prod.snd,
    rw [← over.comp_left, prod.lift_snd], refl,
  have fac: t.left ≫ magic_arrow h f = pullback_cone.snd s,
    apply prod.hom_ext,
    rw [assoc],
    change t.left ≫ magic_arrow h f ≫ limits.prod.fst = pullback_cone.snd s ≫ limits.prod.fst,
    rw [prod.lift_fst], exact t₁,
    rw ← t₂,
    rw assoc,
    change t.left ≫ magic_arrow h f ≫ limits.prod.snd = _,
    rw prod.lift_snd,
  refine ⟨t.left, _, fac, _⟩,
  rw [← cancel_mono (magic_arrow h g), pullback_cone.condition s, assoc],
  change t.left ≫ (limits.prod.map k (𝟙 h)).left ≫ magic_arrow h g =
    pullback_cone.snd s ≫ limits.prod.map k.left (𝟙 h.left),
  rw [magic_comm, ← fac, assoc],
  intros m m₁ m₂,
  rw ← cancel_mono (magic_arrow h f),
  erw m₂,
  exact fac.symm,
end

end category_theory


import Kenny.sheaf_on_opens

universes v u

open topological_space

variables {X : Type u} [topological_space X]

structure subpresheaf (F : presheaf.{u v} X) : Type (max u v) :=
(to_set : Π U : opens X, set (F U))
(res_mem_to_set : ∀ {U V : opens X} (HVU : V ⊆ U) {x : F U}, x ∈ to_set U → F.res U V HVU x ∈ to_set V)

namespace subpresheaf

instance (F : presheaf.{u v} X) : has_coe_to_fun (subpresheaf F) :=
⟨_, to_set⟩

instance (F : presheaf.{u v} X) : partial_order (subpresheaf F) :=
partial_order.lift to_set (λ ⟨x, hx⟩ ⟨y, hy⟩, mk.inj_eq.mpr) infer_instance

def to_subsheaf {F : presheaf.{u v} X} (S : subpresheaf F) : subpresheaf F :=
{ to_set := λ U, { x | ∃ OC : covering.{u} U, ∀ i : OC.γ, F.res U (OC.Uis i) (subset_covering i) x ∈ S (OC.Uis i) },
  res_mem_to_set := λ U V HVU x ⟨OC, hx⟩, ⟨opens.covering_res U V HVU OC,
    λ i, have _ ∈ S ((opens.covering_res U V HVU OC).Uis i) := S.res_mem_to_set (set.inter_subset_right _ _) (hx i),
    by rwa ← presheaf.Hcomp' at this ⊢⟩ }

theorem le_to_subsheaf {F : presheaf.{u v} X} (S : subpresheaf F) : S ≤ S.to_subsheaf :=
λ U x hx, ⟨{ γ := punit, Uis := λ _, U, Hcov := le_antisymm (lattice.supr_le $ λ _, le_refl U) (lattice.le_supr (λ _, U) punit.star) },
λ i, by erw F.Hid'; exact hx⟩

def to_presheaf {F : presheaf.{u v} X} (S : subpresheaf F) : presheaf X :=
{ F := λ U, S U,
  res := λ U V HVU x, ⟨F.res U V HVU x.1, S.2 HVU x.2⟩,
  Hid := λ U, funext $ λ x, subtype.eq $ F.Hid' U x.1,
  Hcomp := λ U V W HWV HVU, funext $ λ x, subtype.eq $ F.Hcomp' U V W HWV HVU x.1 }

theorem locality {O : sheaf.{u v} X} (S : subpresheaf O.to_presheaf) : locality S.to_presheaf :=
λ U OC s t H, subtype.eq $ O.locality OC s.1 t.1 $ λ i, have _ := congr_arg subtype.val (H i), this

end subpresheaf

class is_subsheaf {F : presheaf.{u v} X} (S : subpresheaf F) : Prop :=
(mem_of_res_mem : ∀ {U : opens X}, ∀ {x : F U}, ∀ OC : covering.{u} U, (∀ i : OC.γ, F.res U (OC.Uis i) (subset_covering i) x ∈ S (OC.Uis i)) → x ∈ S U)

theorem covering.exists {U : opens X} (OC : covering U) {x : X} (hx : x ∈ U) : ∃ i : OC.γ, x ∈ OC.Uis i :=
let ⟨_, ⟨_, ⟨i, rfl⟩, rfl⟩, hi⟩ := set.mem_sUnion.1 (((set.ext_iff _ _).1 (congr_arg subtype.val OC.Hcov) x).2 hx) in ⟨i, hi⟩

def covering.glue {U : opens X} (OC : covering U) (F : Π i : OC.γ, covering (OC.Uis i)) : covering U :=
{ γ := Σ i : OC.γ, (F i).γ,
  Uis := λ P, (F P.1).Uis P.2,
  Hcov := opens.ext $ (set.sUnion_image _ _).trans $ set.subset.antisymm
    (set.bUnion_subset $ set.range_subset_iff.2 $ λ P, set.subset.trans (subset_covering P.2) (subset_covering P.1))
    (λ x hx, let ⟨i, hi⟩ := OC.exists hx, ⟨j, hj⟩ := (F i).exists hi in set.mem_bUnion ⟨⟨i, j⟩, rfl⟩ hj) }

theorem is_subsheaf_to_subsheaf {F : presheaf.{u v} X} (S : subpresheaf F) : is_subsheaf S.to_subsheaf :=
⟨λ U x OC H, ⟨OC.glue $ λ i, classical.some (H i),
λ P, have _ := classical.some_spec (H P.1) P.2, by rw ← F.Hcomp' at this; convert this⟩⟩

theorem is_subsheaf.is_sheaf_to_presheaf {O : sheaf.{u v} X} (S : subpresheaf O.to_presheaf) [is_subsheaf S] : is_sheaf S.to_presheaf :=
{ left := λ U, S.locality,
  right := λ U OC s H, let ⟨f, hf⟩ := O.gluing OC (λ i, (s i).1) (λ j k, congr_arg subtype.val (H j k)) in
    ⟨⟨f, is_subsheaf.mem_of_res_mem OC $ λ i, (hf i).symm ▸ (s i).2⟩, λ i, subtype.eq $ hf i⟩ }