/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import morphisms.ring_hom_properties
import morphisms.preimmersion
import morphisms.monomorphism
import topology.sheaves.locally_surjective
import topology.local_at_target
import ring_theory.ring_hom.surjective
import algebraic_geometry.stalk_inducing
import for_mathlib.module_local_property
import algebraic_geometry.pushforward_stalk

/-!

# Closed immersions

A morphism of schemes is a closed immersion if the underlying map is a closed embedding, and
the sheaf map is locally surjective.

-/

noncomputable theory

open category_theory category_theory.limits opposite topological_space

universe u

namespace algebraic_geometry

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

/-- A morphism is a `is_closed_immersion` if the preimages of affine open sets are affine. -/
class is_closed_immersion (f : X ⟶ Y) extends is_preimmersion f : Prop :=
(range_is_closed [] : is_closed (set.range f.1.base))

lemma _root_.Top.presheaf.stalk_pushforward_subsingleton
  {X Y : Top} (F : X.presheaf CommRing) (hF : F.is_sheaf) (f : X ⟶ Y) (x : Y)
    (hx : x ∉ closure (set.range f)) :
  subsingleton ((f _* F).stalk x) :=
begin
  apply subsingleton_of_forall_eq (0 : (f _* F).stalk x),
  intro s,
  obtain ⟨U, hxU, s', e⟩ := (f _* F).germ_exist _ s,
  let V : opens Y := U ⊓ ⟨(closure (set.range f))ᶜ, is_closed_closure.is_open_compl⟩,
  let t : (f _* F).obj (op V) := (f _* F).map (hom_of_le inf_le_left).op s',
  have hxV : x ∈ V := ⟨hxU, hx⟩,
  obtain rfl : (f _* F).germ ⟨x, hxV⟩ t = s,
  { rw [Top.presheaf.germ_res_apply, ← e], refl },
  haveI : subsingleton ((f _* F).obj (op V)),
  { change subsingleton (F.obj $ op $ (opens.map f).obj V),
    refine CommRing.subsingleton_of_is_terminal
      (Top.sheaf.is_terminal_of_eq_empty ⟨F, hF⟩ $ eq_bot_iff.mpr _),
    exact λ x hx, hx.2 (subset_closure ⟨x, rfl⟩) },
  rw [subsingleton.elim t 0, map_zero]
end

lemma is_closed_immersion_iff_is_preimmersion {f : X ⟶ Y} :
  is_closed_immersion f ↔ is_preimmersion f ∧ is_closed (set.range f.1.base) :=
⟨λ H, ⟨H.1, H.2⟩, λ H, @@is_closed_immersion.mk H.1 H.2⟩

lemma is_closed_immersion_iff {f : X ⟶ Y} :
  is_closed_immersion f ↔
    closed_embedding f.1.base ∧ ∀ x, function.surjective (PresheafedSpace.stalk_map f.1 x) :=
⟨λ H, ⟨⟨H.1.1, H.2⟩, H.1.2⟩, λ H, @@is_closed_immersion.mk ⟨H.1.1, H.2⟩ H.1.2⟩

lemma is_closed_immersion_iff_closed_embedding_and_locally_surjective {f : X ⟶ Y} :
  is_closed_immersion f ↔
    closed_embedding f.1.base ∧ Top.presheaf.is_locally_surjective f.1.c :=
begin
  symmetry,
  rw [is_closed_immersion_iff, Top.presheaf.locally_surjective_iff_surjective_on_stalks],
  delta PresheafedSpace.stalk_map,
  split,
  { rintro ⟨h₁, h₂⟩, refine ⟨h₁, λ x, function.surjective.comp _ (h₂ $ f.1.base x)⟩,
    haveI := X.presheaf.stalk_pushforward_iso_of_inducing h₁.to_inducing x,
    exact (as_iso $ X.presheaf.stalk_pushforward CommRing f.1.base x)
      .CommRing_iso_to_ring_equiv.surjective },
  { rintro ⟨h₁, h₂⟩, refine ⟨h₁, λ y, _⟩,
    by_cases y ∈ set.range f.1.base,
    { obtain ⟨x, rfl⟩ := h,
      haveI := X.presheaf.stalk_pushforward_iso_of_inducing h₁.to_inducing x,
      have := (as_iso $ X.presheaf.stalk_pushforward CommRing f.1.base x).symm
        .CommRing_iso_to_ring_equiv.surjective.comp (h₂ x),
      erw ← coe_comp at this,
      simpa using this },
    { intro s,
      rw ← closure_eq_iff_is_closed.mpr h₁.closed_range at h,
      have := X.presheaf.stalk_pushforward_subsingleton X.sheaf.2 f.1.base y h,
      rw @@subsingleton.elim this s 0,
      exact ⟨0, map_zero _⟩ } }
end

lemma is_closed_immersion.stalk_map_surjective [is_closed_immersion f] (x : X.carrier) :
  function.surjective (PresheafedSpace.stalk_map f.1 x) :=
is_preimmersion.stalk_map_surjective f x

lemma is_closed_immersion.base_closed [is_closed_immersion f] :
  closed_embedding f.1.base :=
(is_closed_immersion_iff.mp infer_instance).1

lemma is_closed_immersion.c_locally_surjective [is_closed_immersion f] :
  Top.presheaf.is_locally_surjective f.1.c :=
(is_closed_immersion_iff_closed_embedding_and_locally_surjective.mp infer_instance).2

instance is_closed_immersion_of_is_iso (f : X ⟶ Y) [is_iso f] : is_closed_immersion f :=
begin
  refine is_closed_immersion_iff.mpr ⟨(Top.homeo_of_iso $ as_iso f.1.base).closed_embedding, _⟩,
  intro x,
  exact ((forget _).map_iso (as_iso $ PresheafedSpace.stalk_map f.val x)).to_equiv.surjective,
end

lemma is_closed_immersion_stable_under_composition :
  morphism_property.stable_under_composition @is_closed_immersion :=
begin
  introsI X Y Z f g h₁ h₂,
  rw is_closed_immersion_iff at h₁ h₂ ⊢,
  refine ⟨h₂.1.comp h₁.1, λ x, _⟩,
  erw PresheafedSpace.stalk_map.comp,
  exact (h₁.2 x).comp (h₂.2 $ f.1 x)
end

lemma is_closed_immersion_respects_iso :
  morphism_property.respects_iso @is_closed_immersion :=
begin
  apply is_closed_immersion_stable_under_composition.respects_iso,
  intros _ _ _, apply_instance
end

lemma is_closed_immersion_is_local_at_target : property_is_local_at_target @is_closed_immersion :=
begin
  constructor,
  { exact is_closed_immersion_respects_iso },
  { intros X Y f U hU,
    haveI := is_preimmersion_is_local_at_target.2 f U hU.1,
    constructor,
    rw morphism_restrict_val_base,
    exact ((is_closed_immersion.base_closed f).restrict_preimage U.1).2 },
  { introsI X Y f 𝒰 H,
    haveI := is_preimmersion_is_local_at_target.3 f 𝒰 infer_instance,
    constructor,
    apply (is_closed_iff_coe_preimage_of_supr_eq_top 𝒰.supr_opens_range _).mpr,
    intro i,
    convert ((is_closed_immersion_respects_iso.arrow_mk_iso_iff
      (morphism_restrict_opens_range f (𝒰.map i))).mpr (H i)).2 using 1,
    rw [morphism_restrict_val_base, set.range_restrict_preimage] },
end

lemma is_affine_of_closed_embedding {X Y : Scheme} (f : X ⟶ Y) [is_affine Y]
  (hf : closed_embedding f.1.base) : is_affine X :=
begin
  have : ∀ x, ∃ (s : Y.presheaf.obj (op ⊤)) (U : X.affine_opens),
    f.1.base x ∈ Y.basic_open s ∧ @Scheme.basic_open X ⊤ (f.1.c.app (op ⊤) s) ≤ U.1,
  { intro x,
    obtain ⟨_, ⟨U, hU : is_affine_open U, rfl⟩, hxU, -⟩ :=
      (is_basis_affine_open X).exists_subset_of_mem_open
      (show x ∈ (set.univ : set X.carrier), from trivial) is_open_univ,
    obtain ⟨V, hV, hV'⟩ := hf.to_inducing.is_open_iff.mp U.prop,
    rw ← hV' at hxU,
    obtain ⟨_, ⟨_, ⟨r, rfl⟩, rfl⟩, hxr, hr⟩ :=
      (is_basis_basic_open Y).exists_subset_of_mem_open (show f.1.base x ∈ _, from hxU) hV,
    refine ⟨r, ⟨U, hU⟩, hxr, _⟩,
    rw ← Scheme.preimage_basic_open,
    have := set.preimage_mono hr, rw hV' at this, exact this },
  choose s U hs hU using this,
  have := hf.closed_range,
  obtain ⟨ι, t, ht, ht'⟩ := (is_basis_basic_open Y).open_eq_Union hf.closed_range.1,
  have : ∀ i : ι, ∃ r : Y.presheaf.obj (op ⊤), (Y.basic_open r).1 = t i,
  { intro i, rcases ht' i with ⟨_, ⟨r, rfl⟩, e⟩, exact ⟨r, e⟩ },
  choose t' ht' using this,
  let r : X.carrier ⊕ ι → Y.presheaf.obj (op ⊤) := sum.elim s t',
  apply is_affine_of_span_top_of_is_affine_open X (f.1.c.app (op ⊤) '' set.range r),
  { rw [← ideal.map_span, ← ideal.map_top (f.1.c.app (op ⊤))],
    congr' 1,
    rw [← (top_is_affine_open Y).basic_open_union_eq_self_iff, eq_top_iff],
    rintro x -,
    erw opens.mem_supr,
    by_cases x ∈ set.range f.1.base,
    { obtain ⟨x, rfl⟩ := h, exact ⟨⟨_, sum.inl _, rfl⟩, hs _⟩ },
    { rw [← set.mem_compl_iff, ht, set.mem_Union] at h,
      obtain ⟨i, hi⟩ := h, rw ← ht' at hi, exact ⟨⟨_, sum.inr _, rfl⟩, hi⟩ } },
  { rintro ⟨_, _, ⟨i|i, rfl⟩, rfl⟩; dsimp only [r, sum.elim],
      have := inf_eq_right.mpr (hU i),
      { convert (U i).2.basic_open_is_affine
          (X.presheaf.map (hom_of_le le_top).op $ (f.val.c.app (op ⊤)) (s i)) using 1,
        rw Scheme.basic_open_res,
        exact (inf_eq_right.mpr (hU i)).symm },
      { convert bot_is_affine_open X,
        rw ← Scheme.preimage_basic_open,
        ext1,
        refine @set.preimage_eq_empty _ _ f.1.base _ _,
        apply set.subset_compl_iff_disjoint_right.mp,
        rw [ht', ht],
        exact set.subset_Union _ _ } }
end

lemma is_closed_immersion_le_affine :
  @is_closed_immersion ≤ @affine :=
begin
  rw [← is_closed_immersion_is_local_at_target.target_affine_locally_eq, affine_eq_affine_property],
  refine target_affine_locally_mono _,
  introsI X Y f H hf,
  exact is_affine_of_closed_embedding f (is_closed_immersion.base_closed f),
end

instance is_closed_immersion.to_affine [H : is_closed_immersion f] : affine f :=
is_closed_immersion_le_affine X Y f H

lemma surjective_of_is_closed_immersion {R S : CommRing} (f : R ⟶ S)
  [is_closed_immersion (Scheme.Spec.map f.op)] : function.surjective f :=
begin
  letI := f.to_algebra,
  change function.surjective (algebra.of_id R S).to_linear_map,
  apply linear_map.surjective_of_localization_maximal,
  introsI m hm,
  convert_to function.surjective ((localized_module.map m.prime_compl
      (algebra.of_id R S).to_linear_map).restrict_scalars R),
  rw Spec.localized_module_map_iso_stalk_map' R S ⟨m, _⟩,
  apply function.surjective.comp,
  { exact (linear_equiv.to_equiv _).surjective },
  dsimp only,
  apply function.surjective.comp,
  { exact (Top.presheaf.locally_surjective_iff_surjective_on_stalks _).mp
      (is_closed_immersion.c_locally_surjective (Scheme.Spec.map f.op) : _) ⟨m, _⟩ },
  { exact (linear_equiv.to_equiv _).surjective },
end

lemma property_le_of_le_affine {P₁ P₂ : morphism_property Scheme}
  (h₁ : P₁ ≤ @affine)
  (h₁' : property_is_local_at_target P₁) (h₂' : property_is_local_at_target P₂)
  (h : ∀ {R S : CommRing} (f : R ⟶ S), P₁ (Scheme.Spec.map f.op) → P₂ (Scheme.Spec.map f.op)) :
  P₁ ≤ P₂ :=
begin
  rw [← h₁'.target_affine_locally_eq, ← h₂'.target_affine_locally_eq],
  apply target_affine_locally_mono,
  intros X Y f hX hf,
  haveI := h₁ _ _ _ hf,
  haveI := is_affine_of_affine f,
  have := Γ_Spec.adjunction.unit_naturality f,
  rw [← h₂'.respects_iso.cancel_right_is_iso f (Γ_Spec.adjunction.unit.app Y),
    ← Γ_Spec.adjunction.unit_naturality f, h₂'.respects_iso.cancel_left_is_iso],
  rw [← h₁'.respects_iso.cancel_right_is_iso f (Γ_Spec.adjunction.unit.app Y),
    ← Γ_Spec.adjunction.unit_naturality f, h₁'.respects_iso.cancel_left_is_iso] at hf,
  exact h (Scheme.Γ.map f.op) hf
end

lemma property_ext_of_le_affine {P₁ P₂ : morphism_property Scheme}
  (h₁ : P₁ ≤ @affine) (h₂ : P₂ ≤ @affine)
  (h₁' : property_is_local_at_target P₁) (h₂' : property_is_local_at_target P₂)
  (h : ∀ {R S : CommRing} (f : R ⟶ S), P₁ (Scheme.Spec.map f.op) ↔ P₂ (Scheme.Spec.map f.op)) :
  P₁ = P₂ :=
begin
  refine (property_le_of_le_affine h₁ h₁' h₂' _).antisymm (property_le_of_le_affine h₂ h₂' h₁' _);
    simp only [h, forall_3_true_iff, imp_self]
end

def is_closed_immersion.affine_property : affine_target_morphism_property :=
affine_and $ λ R S _ _ f, function.surjective f

-- move me
lemma _root_.ring_hom.localization_surjective :
  ring_hom.localization_preserves (λ R S _ _ f, function.surjective ⇑f) :=
begin
  introsI R S _ _ f M R' S' _ _ _ _ _ _ H x,
  obtain ⟨x, ⟨_, ⟨s, hs, rfl⟩⟩, rfl⟩ := is_localization.mk'_surjective (M.map f) x,
  obtain ⟨x, rfl⟩ := H x,
  exact ⟨is_localization.mk' R' x ⟨s, hs⟩, is_localization.map_mk' _ _ _⟩
end

lemma is_closed_immersion.affine_property_is_local :
  (is_closed_immersion.affine_property : _).is_local :=
is_local_affine_and _
  ring_hom.surjective_respects_iso
  ring_hom.localization_surjective
  ring_hom.surjective_of_localization_span

lemma is_closed_immersion_eq_affine_property :
  @is_closed_immersion = target_affine_locally is_closed_immersion.affine_property :=
begin
  apply property_ext_of_le_affine is_closed_immersion_le_affine
    (by exact (target_affine_locally_affine_and_le_affine _)) is_closed_immersion_is_local_at_target
    is_closed_immersion.affine_property_is_local.target_affine_locally_is_local,
  simp_rw [is_closed_immersion.affine_property_is_local.affine_target_iff,
    is_closed_immersion.affine_property, affine_and_Spec_iff ring_hom.surjective_respects_iso],
  intros R S ϕ,
  refine ⟨λ h, by exactI surjective_of_is_closed_immersion ϕ, _⟩,
  { introI h,
    rw is_closed_immersion_iff_closed_embedding_and_locally_surjective,
    refine ⟨prime_spectrum.closed_embedding_comap_of_surjective _ _ h,
      (Top.presheaf.locally_surjective_iff_surjective_on_stalks _).mpr _⟩,
    rintro (x : prime_spectrum R),
    letI := ϕ.to_algebra,
    convert_to function.surjective (is_scalar_tower.to_alg_hom R
      ((Spec.structure_sheaf R).presheaf.stalk x)
      ((Spec.Top_map (algebra_map R S) _* (Spec.structure_sheaf S).1).stalk x)).to_linear_map,
    have := Spec.localized_module_map_iso_stalk_map R S x,
    refine @function.surjective.of_comp _ _ _ _ ((is_localized_module.iso x.as_ideal.prime_compl
      (algebra.of_id R ((Spec.structure_sheaf R).presheaf.stalk x)).to_linear_map).to_linear_map) _,
    rw [← linear_map.coe_comp, ← this],
    apply function.surjective.comp,
    { exact (linear_equiv.to_equiv _).surjective },
    { exact linear_map.surjective_localized_module_map _ (algebra.of_id R S).to_linear_map h } }
end

lemma is_closed_immersion.affine_open_cover_tfae {X Y : Scheme.{u}} (f : X ⟶ Y) :
  tfae [is_closed_immersion f,
    ∃ (𝒰 : Scheme.open_cover.{u} Y) [∀ i, is_affine (𝒰.obj i)],
      ∀ (i : 𝒰.J), is_affine (pullback f (𝒰.map i)) ∧
        function.surjective (Scheme.Γ.map (pullback.snd : pullback f (𝒰.map i) ⟶ _).op),
    ∀ (𝒰 : Scheme.open_cover.{u} Y) [∀ i, is_affine (𝒰.obj i)] (i : 𝒰.J),
      is_affine (pullback f (𝒰.map i)) ∧
        function.surjective (Scheme.Γ.map (pullback.snd : pullback f (𝒰.map i) ⟶ _).op),
    ∀ {U : Scheme} (g : U ⟶ Y) [is_affine U] [is_open_immersion g],
      is_affine (pullback f g) ∧
        function.surjective (Scheme.Γ.map (pullback.snd : pullback f g ⟶ _).op),
    ∃ {ι : Type u} (U : ι → opens Y.carrier) (hU : supr U = ⊤) (hU' : ∀ i, is_affine_open (U i)),
      ∀ i, is_affine_open ((opens.map f.1.base).obj $ U i) ∧
        function.surjective (f.1.c.app (op $ U i))] :=
begin
  rw is_closed_immersion_eq_affine_property,
  convert is_closed_immersion.affine_property_is_local.affine_open_cover_tfae f,
  delta is_closed_immersion.affine_property,
  ext ι,
  refine exists₃_congr (λ U hU hU', forall_congr $ λ i, and_congr iff.rfl _),
  dsimp only,
  rw [algebraic_geometry.Scheme.Γ_map, quiver.hom.unop_op, morphism_restrict_c_app, coe_comp],
  refine iff.trans _ (function.surjective.of_comp_iff' _ _).symm,
  { let V := (U i).open_embedding.is_open_map.functor.obj ⊤,
    show _ ↔ function.surjective (f.1.c.app (op V)),
    have e : V = _ := (U i).open_embedding_obj_top, clear_value V, subst e },
  { exact (as_iso $ X.presheaf.map (eq_to_hom _).op).CommRing_iso_to_ring_equiv.bijective }
end

lemma is_closed_immersion.is_local_at_target :
  property_is_local_at_target @is_closed_immersion :=
is_closed_immersion_eq_affine_property.symm ▸
  is_closed_immersion.affine_property_is_local.target_affine_locally_is_local

lemma is_closed_immersion.open_cover_tfae {X Y : Scheme.{u}} (f : X ⟶ Y) :
  tfae [is_closed_immersion f,
    ∃ (𝒰 : Scheme.open_cover.{u} Y), ∀ (i : 𝒰.J),
      is_closed_immersion (pullback.snd : (𝒰.pullback_cover f).obj i ⟶ 𝒰.obj i),
    ∀ (𝒰 : Scheme.open_cover.{u} Y) (i : 𝒰.J),
      is_closed_immersion (pullback.snd : (𝒰.pullback_cover f).obj i ⟶ 𝒰.obj i),
    ∀ (U : opens Y.carrier), is_closed_immersion (f ∣_ U),
    ∀ {U : Scheme} (g : U ⟶ Y) [is_open_immersion g],
      is_closed_immersion (pullback.snd : pullback f g ⟶ _),
    ∃ {ι : Type u} (U : ι → opens Y.carrier) (hU : supr U = ⊤), ∀ i, is_closed_immersion (f ∣_ (U i))] :=
is_closed_immersion_eq_affine_property.symm ▸
  is_closed_immersion.affine_property_is_local.target_affine_locally_is_local.open_cover_tfae f

lemma is_closed_immersion_over_affine_iff {X Y : Scheme} (f : X ⟶ Y) [is_affine Y] :
  is_closed_immersion f ↔ is_affine X ∧ function.surjective (Scheme.Γ.map f.op) :=
is_closed_immersion_eq_affine_property.symm ▸
  is_closed_immersion.affine_property_is_local.affine_target_iff f

lemma is_closed_immersion_Spec_iff {R S : CommRing} (f : R ⟶ S) :
  is_closed_immersion (Scheme.Spec.map f.op) ↔ function.surjective f :=
begin
  rw [is_closed_immersion_eq_affine_property,
    is_closed_immersion.affine_property_is_local.affine_target_iff,
    is_closed_immersion.affine_property, affine_and_Spec_iff ring_hom.surjective_respects_iso]
end

local attribute [instance] mono_comp

lemma is_closed_immersion_le_mono : @is_closed_immersion ≤ @mono Scheme _ :=
begin
  rw [← is_closed_immersion_is_local_at_target.target_affine_locally_eq,
    ← mono_is_local_at_target.target_affine_locally_eq],
  apply target_affine_locally_mono,
  introsI X Y f _ H,
  haveI := is_affine_of_affine f,
  rw is_closed_immersion_over_affine_iff at H,
  haveI := (forget CommRing).epi_of_epi_map ((epi_iff_surjective _).mpr H.2),
  have := Γ_Spec.adjunction.unit_naturality f,
  rw [functor.right_op_map, ← is_iso.comp_inv_eq] at this,
  rw ← this,
  apply_instance
end

@[priority 100]
instance is_closed_immersion.to_mono [is_closed_immersion f] : mono f :=
is_closed_immersion_le_mono _ _ f infer_instance

lemma is_closed_immersion.affine_open_cover_iff {X Y : Scheme.{u}} (𝒰 : Scheme.open_cover.{u} Y)
  [∀ i, is_affine (𝒰.obj i)] (f : X ⟶ Y) :
  is_closed_immersion f ↔ ∀ i, is_affine (pullback f (𝒰.map i)) ∧
        function.surjective (Scheme.Γ.map (pullback.snd : pullback f (𝒰.map i) ⟶ _).op) :=
is_closed_immersion_eq_affine_property.symm ▸
  is_closed_immersion.affine_property_is_local.affine_open_cover_iff f 𝒰

lemma is_closed_immersion.open_cover_iff {X Y : Scheme.{u}} (𝒰 : Scheme.open_cover.{u} Y) (f : X ⟶ Y) :
  is_closed_immersion f ↔ ∀ i, is_closed_immersion (pullback.snd : pullback f (𝒰.map i) ⟶ _) :=
is_closed_immersion_eq_affine_property.symm ▸
  is_closed_immersion.affine_property_is_local.target_affine_locally_is_local.open_cover_iff f 𝒰

instance [is_closed_immersion f] [is_closed_immersion g] : is_closed_immersion (f ≫ g) :=
is_closed_immersion_stable_under_composition _ _ infer_instance infer_instance

lemma is_closed_immersion_stable_under_base_change :
  morphism_property.stable_under_base_change @is_closed_immersion :=
begin
  rw is_closed_immersion_eq_affine_property,
  exact affine_and_stable_under_base_change _ ring_hom.surjective_respects_iso
    ring_hom.localization_surjective ring_hom.surjective_of_localization_span
    ring_hom.surjective_stable_under_base_change,
end

instance (f : X ⟶ Z) (g : Y ⟶ Z) [is_closed_immersion g] :
  is_closed_immersion (pullback.fst : pullback f g ⟶ X) :=
is_closed_immersion_stable_under_base_change.fst f g infer_instance

instance (f : X ⟶ Z) (g : Y ⟶ Z) [is_closed_immersion f] :
  is_closed_immersion (pullback.snd : pullback f g ⟶ Y) :=
is_closed_immersion_stable_under_base_change.snd f g infer_instance

instance (x) : is_closed_immersion
  (Scheme.Spec.map (CommRing.of_hom (local_ring.residue $ X.presheaf.stalk x)).op) :=
begin
  rw is_closed_immersion_Spec_iff,
  exact ideal.quotient.mk_surjective
end

instance (x) : is_preimmersion (X.from_Spec_residue_field x) :=
begin
  delta Scheme.from_Spec_residue_field,
  apply_instance
end

end algebraic_geometry


import category_theory.abelian.exact
import for_mathlib.split_exact

universes v u u'

namespace category_theory

namespace functor

open category_theory.limits

variables {A : Type u} {B : Type u'} [category.{v} A] [category.{v} B]
  [abelian A] [abelian B] (F : A ⥤ B) [functor.additive F]
  [preserves_finite_limits F] [preserves_finite_colimits F]

variables {X Y Z : A} (f : X ⟶ Y) (g : Y ⟶ Z)

lemma map_exact (h : exact f g) : exact (F.map f) (F.map g) :=
begin
  rw abelian.exact_iff,
  split,
  { rw [← F.map_comp, h.w, F.map_zero] },
  { let eK : F.obj (kernel g) ≅ kernel (F.map g) :=
      limits.preserves_kernel.iso _ _,
    let eQ : F.obj (cokernel f) ≅ cokernel (F.map f) :=
      limits.preserves_cokernel.iso _ _,
    have : kernel.ι (F.map g) = eK.inv ≫ F.map (kernel.ι _),
    { rw iso.eq_inv_comp, simp, },
    rw this, clear this,
    have : cokernel.π (F.map f) = F.map (cokernel.π _) ≫ eQ.hom,
    { rw ← iso.comp_inv_eq, simp },
    rw this, clear this,
    simp only [category.assoc, ← F.map_comp_assoc],
    rw abelian.exact_iff at h,
    rw h.2,
    simp }
end

lemma map_short_exact (h : short_exact f g) : short_exact (F.map f) (F.map g) :=
begin
  rcases h with ⟨hf, hg, hfg⟩,
  haveI : mono (F.map f),
  { rw (abelian.tfae_mono X f).out 0 2 at hf,
    rw (abelian.tfae_mono (F.obj X) (F.map f)).out 0 2,
    have := F.map_exact _ _ hf, rwa F.map_zero at this, },
  haveI : epi (F.map g),
  { rw (abelian.tfae_epi Z g).out 0 2 at hg,
    rw (abelian.tfae_epi (F.obj Z) (F.map g)).out 0 2,
    have := F.map_exact _ _ hg, rwa F.map_zero at this, },
  refine ⟨F.map_exact f g hfg⟩,
end

end functor

end category_theory


import topology.category.Profinite.as_limit
import for_mathlib.Fintype

import hacks_and_tricks.asyncI

noncomputable theory

namespace Profinite

open category_theory
open category_theory.limits

universes v u u'

variables {C : Type u} [category.{v} C] (F : Fintype.{v} ⥤ C)
variables {D : Type u'} [category.{v} D]

/-- Change a cone with respect to a morphism from `Profinite`. -/
@[simps]
def change_cone {X Y : Profinite} (f : X ⟶ Y) (D : cone (X.fintype_diagram ⋙ F)) :
  cone (Y.fintype_diagram ⋙ F) :=
{ X := D.X,
  π :=
  { app := λ S, D.π.app (S.comap f.continuous) ≫ F.map (discrete_quotient.map $ le_refl _),
    naturality' := by asyncI {
      rintros I J h,
      dsimp,
      simp only [category.id_comp, category.assoc],
      rw ← D.w (hom_of_le $ discrete_quotient.comap_mono _ $ le_of_hom h),
      simp only [category.assoc, ← F.map_comp, functor.comp_map],
      congr' 2,
      ext ⟨t⟩, refl, } } }
.

-- Assume that C has enough limits.
variable [∀ X : Profinite, has_limit (X.fintype_diagram ⋙ F)]

-- PROJECT: Prove that this is isomorphic to the right Kan extension along `Fintype.to_Profinite`.
/-- Extend a functor `Fintype ⥤ C` to `Profinite`. -/
@[simps]
def extend : Profinite ⥤ C :=
{ obj := λ X, limit (X.fintype_diagram ⋙ F),
  map := λ X Y f, limit.lift _ (change_cone _ f _),
  map_id' := by asyncI {
    intros X,
    ext S,
    dsimp,
    simp only [limit.lift_π, coe_id, change_cone_π_app, limit.cone_π, category.id_comp],
    erw discrete_quotient.map_id,
    change _ ≫ F.map (𝟙 _) = _,
    rw [F.map_id, category.comp_id],
    congr,
    exact S.comap_id, },
  map_comp' := by asyncI {
    intros X Y Z f g,
    ext S,
    dsimp,
    simp only [limit.lift_π, change_cone_π_app,
      limit.cone_π, limit.lift_π_assoc, coe_comp, category.assoc, ← F.map_comp],
    congr,
    exact discrete_quotient.map_comp _ _, } }
.

/-- discrete quotients of a finite type has an initial object given by `⊥`. -/
@[simps]
def bot_initial (X : Fintype) :
  is_initial (⊥ : discrete_quotient (Fintype.to_Profinite.obj X)) :=
{ desc := λ S, hom_of_le bot_le }

/-- The extension of `F : Fintype ⥤ C` extends `F`. -/
@[simps]
def extend_extends : Fintype.to_Profinite ⋙ extend F ≅ F :=
nat_iso.of_components (λ X, begin
  dsimp only [extend, functor.comp_obj],
  let Y := Fintype.to_Profinite.obj X,
  let D := limit.is_limit (Y.fintype_diagram ⋙ F),
  let E := limit_of_diagram_initial (bot_initial X) (Y.fintype_diagram ⋙ F),
  letI : topological_space X := ⊥,
  let e : Fintype.of (⊥ : discrete_quotient X) ≅ X :=
    Fintype.iso_of_equiv (equiv.of_bijective _ (discrete_quotient.proj_bot_bijective)).symm,
  let g := D.cone_point_unique_up_to_iso E,
  exact g ≪≫ F.map_iso e,
end) $
by asyncI {
  intros X Y f,
  letI : topological_space X := ⊥,
  letI : topological_space Y := ⊥,
  have hf : continuous f := continuous_bot,
  let A := Fintype.to_Profinite.obj X,
  let B := Fintype.to_Profinite.obj Y,
  dsimp [is_limit.cone_point_unique_up_to_iso, limit_of_diagram_initial],
  simp only [change_cone_π_app, limit.cone_π, limit.lift_π_assoc, category.assoc],
  let e : (⊥ : discrete_quotient X) ⟶ (⊥ : discrete_quotient Y).comap hf :=
    hom_of_le bot_le,
  erw ← limit.w (A.fintype_diagram ⋙ F) e,
  simp only [category.assoc, ← F.map_comp, functor.comp_map],
  congr' 2,
  simp_rw [← iso.inv_comp_eq, ← category.assoc],
  symmetry,
  rw ← iso.comp_inv_eq,
  refl, }
.

/-
instance extend_preserves_limit (X : Profinite) : preserves_limit X.diagram (extend F) :=
{ preserves := λ D hD,
    let e : X.diagram ⋙ extend F ≅ X.fintype_diagram ⋙ F :=
          iso_whisker_left _ (extend_extends F),
        D' : cone (X.fintype_diagram ⋙ F) :=
          (cones.postcompose e.hom).obj ((extend F).map_cone D) in
  { lift := λ E, begin
      dsimp,
      let D'' : cone X.diagram := X.as_limit_cone,
      let f' : X ⟶ D.X := hD.lift D'',
      admit
    end,
    fac' := _,
    uniq' := _ } }
-/

/-- `extend` is characterized by the fact that it preserves the correct limits and
  that its composition with `Profinite.to_Fintype` is the original functor. -/
def extend_unique (G : Profinite ⥤ C)
  [∀ X : Profinite, preserves_limit X.diagram G]
  (w : Fintype.to_Profinite ⋙ G ≅ F) : G ≅ extend F :=
nat_iso.of_components (λ X,
  let D := (X.as_limit_cone),
      hD := (X.as_limit),
      E := G.map_cone D,
      hE : is_limit E := preserves_limit.preserves hD,
      f : X.diagram ⋙ G ≅ X.fintype_diagram ⋙ F := iso_whisker_left _ w,
      E' : cone (X.fintype_diagram ⋙ F) := (cones.postcompose f.hom).obj E,
      hE' : is_limit E' := (is_limit.postcompose_hom_equiv f _).symm hE in
      hE'.cone_point_unique_up_to_iso (limit.is_limit _) ) $
by asyncI {
  intros A B f,
  dsimp [is_limit.postcompose_hom_equiv, is_limit.of_cone_equiv,
    is_limit.cone_point_unique_up_to_iso],
  ext S,
  simp only [←nat_trans.naturality w.hom, limit.lift_π, cones.postcompose_obj_π,
    functor.comp_map, functor.map_cone_π_app, change_cone_π_app, limit.cone_π,
    limit.lift_π_assoc, whisker_left_app, nat_trans.comp_app, category.assoc],
  simp only [← category.assoc, ← G.map_comp],
  refl, }
.

@[simps]
def extend_commutes (G : C ⥤ D)
  [∀ X : Profinite.{v}, preserves_limits_of_shape (discrete_quotient X) G]
  [∀ X : Profinite.{v}, has_limit (X.fintype_diagram ⋙ F ⋙ G)] :
  extend F ⋙ G ≅ extend (F ⋙ G) :=
nat_iso.of_components
(λ X, (is_limit_of_preserves G (limit.is_limit _)).cone_point_unique_up_to_iso (limit.is_limit _)) $
by asyncI {
  intros X Y f,
  ext,
  dsimp,
  simp only [category.assoc, limit.lift_π, change_cone_π_app, limit.cone_π, functor.comp_map],
  erw [limit.lift_π, limit.lift_π_assoc],
  dsimp,
  rw [← G.map_comp, limit.lift_π, ← G.map_comp],
  refl, }

@[reassoc]
lemma extend_commutes_comp_extend_extends (G : C ⥤ D)
  [∀ X : Profinite.{v}, preserves_limits_of_shape (discrete_quotient X) G]
  [∀ X : Profinite.{v}, has_limit (X.fintype_diagram ⋙ F ⋙ G)] :
  whisker_left Fintype.to_Profinite (extend_commutes F G).hom ≫ (extend_extends _).hom =
  (functor.associator _ _ _).inv ≫ (whisker_right (extend_extends _).hom G) :=
begin
  ext,
  simp only [nat_trans.comp_app, whisker_left_app, extend_extends_hom_app, functor.comp_map,
    functor.associator_inv_app, whisker_right_app, functor.map_comp, category.id_comp,
    extend_commutes_hom_app],
  rw [← category.assoc], congr' 1,
  rw [← iso.eq_comp_inv],
  ext,
  simp only [is_limit.cone_point_unique_up_to_iso, category.assoc,
    functor.map_iso_hom, is_limit.unique_up_to_iso_hom, cones.forget_map,
    is_limit.lift_cone_morphism_hom, limit.is_limit_lift],
  erw [limit.lift_π, limit.lift_π],
  simp only [functor.map_cone_π_app, limit.cone_π, functor.map_iso_inv, cones.forget_map,
    is_limit.unique_up_to_iso_inv, is_limit.lift_cone_morphism_hom, limit.is_limit_lift,
    cone_of_diagram_initial_π_app, functor.comp_map, limit_of_diagram_initial],
  rw [← functor.map_comp], congr' 1, symmetry,
  exact limit.w _ ((bot_initial x).to j),
end

/-- A natural transformation induces a natural transformation on extensions. -/
@[simps]
def extend_nat_trans {F G : Fintype ⥤ C}
  [∀ X : Profinite, has_limit (X.fintype_diagram ⋙ F)]
  [∀ X : Profinite, has_limit (X.fintype_diagram ⋙ G)]
  (η : F ⟶ G) : extend F ⟶ extend G :=
{ app := λ X, category_theory.limits.lim_map $ whisker_left _ η } .

@[simp]
lemma extend_nat_trans_id (F : Fintype ⥤ C)
  [∀ X : Profinite, has_limit (X.fintype_diagram ⋙ F)] :
  extend_nat_trans (𝟙 F) = 𝟙 _ :=
begin
  ext S,
  dsimp,
  simp,
end

@[simp]
lemma extend_nat_trans_comp {F G H : Fintype ⥤ C}
  [∀ X : Profinite, has_limit (X.fintype_diagram ⋙ F)]
  [∀ X : Profinite, has_limit (X.fintype_diagram ⋙ G)]
  [∀ X : Profinite, has_limit (X.fintype_diagram ⋙ H)]
  (α : F ⟶ G) (β : G ⟶ H) :
  extend_nat_trans (α ≫ β) = extend_nat_trans α ≫ extend_nat_trans β :=
begin
  ext S,
  dsimp,
  simp,
end

lemma extend_π (F G : Fintype ⥤ C)
  [∀ X : Profinite, has_limit (X.fintype_diagram ⋙ F)]
  [∀ X : Profinite, has_limit (X.fintype_diagram ⋙ G)]
  (α : extend F ⟶ extend G) (X : Profinite) (T : discrete_quotient X) :
  α.app X ≫ limit.π _ T =
  (extend F).map (X.as_limit_cone.π.app T) ≫
  α.app (Profinite.of T) ≫ (extend_extends G).hom.app _ :=
begin
  have : (extend_extends G).hom.app (X.fintype_diagram.obj T) =
    limit.π _ ⊥ ≫ _ := rfl,
  erw [this, α.naturality_assoc], congr' 1,
  dsimp [extend],
  simp only [limit.lift_π_assoc, change_cone_π_app, limit.cone_π, category.assoc,
    ← G.map_comp],
  convert (limit.w _ _).symm,
  swap,
  { apply hom_of_le, intros x y h, dsimp [discrete_quotient.comap] at h,
    change _ = _ at h, dsimp [Profinite.as_limit_cone] at h,
    exact quotient.exact' h },
  ext t, rcases t with ⟨t⟩,
  dsimp,
  let E : ↥(X.fintype_diagram.obj T) ≃ (⊥ : discrete_quotient T) :=
    equiv.of_bijective _ discrete_quotient.proj_bot_bijective,
  change E.symm _ = _,
  apply_fun E,
  rw equiv.apply_symm_apply, refl,
end

lemma extend_nat_trans_ext {F G : Fintype ⥤ C}
  [∀ X : Profinite, has_limit (X.fintype_diagram ⋙ F)]
  [∀ X : Profinite, has_limit (X.fintype_diagram ⋙ G)]
  (α β : extend F ⟶ extend G)
  (h : whisker_left Fintype.to_Profinite α = whisker_left Fintype.to_Profinite β) :
  α = β :=
begin
  ext S T,
  dsimp,
  let p : S ⟶ of T := S.as_limit_cone.π.app T,
  let E : Fintype.to_Profinite ⋙ extend G ≅ G := extend_extends G,
  apply_fun (λ e, (extend F).map p ≫ e.app ⟨T⟩ ≫ E.hom.app _) at h,
  simpa only [extend_π] using h,
end

lemma extend_nat_trans_whisker_left {F G : Fintype ⥤ C}
  [∀ X : Profinite, has_limit (X.fintype_diagram ⋙ F)]
  [∀ X : Profinite, has_limit (X.fintype_diagram ⋙ G)]
  (α : F ⟶ G) :
  whisker_left Fintype.to_Profinite (extend_nat_trans α) =
  (extend_extends F).hom ≫ α ≫ (extend_extends G).inv :=
begin
  ext S,
  simp only [lim_map, is_limit.map, whisker_left_app, extend_nat_trans_app, limit.is_limit_lift,
    limit.lift_π, cones.postcompose_obj_π, nat_trans.comp_app, limit.cone_π, extend_extends_hom_app,
    extend_extends_inv_app, category.assoc, nat_trans.naturality_assoc,
    ← G.map_iso_hom, ← G.map_iso_inv, iso.hom_inv_id_assoc],
  rw [← iso.inv_comp_eq],
  erw [limit.cone_point_unique_up_to_iso_inv_comp,
    limit.cone_point_unique_up_to_iso_inv_comp_assoc],
  simp only [cone_of_diagram_initial_π_app, functor.comp_map],
  erw [nat_trans.naturality],
end

lemma extend_nat_trans_whisker_right {F G : Fintype ⥤ C}
  [∀ X : Profinite, has_limit (X.fintype_diagram ⋙ F)]
  [∀ X : Profinite, has_limit (X.fintype_diagram ⋙ G)]
  (α : F ⟶ G) (E : C ⥤ D)
  [∀ X : Profinite.{v}, preserves_limits_of_shape (discrete_quotient X) E]
  [∀ X : Profinite.{v}, has_limit (X.fintype_diagram ⋙ F ⋙ E)]
  [∀ X : Profinite.{v}, has_limit (X.fintype_diagram ⋙ G ⋙ E)] :
  extend_nat_trans (whisker_right α E) =
  (extend_commutes _ _).inv ≫ whisker_right (extend_nat_trans α) E ≫ (extend_commutes _ _).hom :=
begin
  apply extend_nat_trans_ext,
  simp only [extend_nat_trans_whisker_left, ← whisker_right_left, category.assoc,
    whisker_left_comp, whisker_right_comp],
  rw [← iso_whisker_left_inv, iso.eq_inv_comp, iso_whisker_left_hom,
    extend_commutes_comp_extend_extends_assoc],
  simp only [← category.assoc, iso.comp_inv_eq],
  simp only [category.assoc, extend_commutes_comp_extend_extends],
  ext,
  simp only [nat_trans.comp_app, functor.associator_hom_app, functor.associator_inv_app],
  erw [category.id_comp, category.id_comp],
  simp only [← nat_trans.comp_app, ← iso_whisker_right_hom, ← iso_whisker_right_inv,
    iso.inv_hom_id],
  erw [category.comp_id],
end

end Profinite


import for_mathlib.category_theory.triangulated.pretriangulated_misc
import for_mathlib.category_theory.finite_products
import category_theory.limits.preserves.limits
import for_mathlib.category_theory.triangulated.yoneda

noncomputable theory

namespace category_theory

open limits preadditive category

namespace pretriangulated

variables {C : Type*} [category C] [has_zero_object C] [has_shift C ℤ] [preadditive C]
  [∀ (n : ℤ), functor.additive (shift_functor C n)] [pretriangulated C]

lemma kernel_cone_of_dist_triang₁ (T : triangle C) (hT : T ∈ dist_triang C) (zero : T.mor₃ = 0) :
  is_limit (kernel_fork.of_ι T.mor₁ (T.comp_zero₁₂ hT)) :=
is_limit_aux _ (λ s, (covariant_yoneda_exact₂ T hT s.ι s.condition).some)
    (λ s, (covariant_yoneda_exact₂ T hT s.ι s.condition).some_spec.symm)
(λ s m hm, begin
  dsimp at hm,
  rw ← sub_eq_zero,
  let f := m - (covariant_yoneda_exact₂ T hT s.ι s.condition).some,
  change f = 0,
  have hf₀ : f ≫ T.mor₁ = 0,
  { dsimp [f],
    rw [sub_comp, hm, (covariant_yoneda_exact₂ T hT s.ι s.condition).some_spec.symm, sub_self], },
  obtain ⟨g, hg⟩ := covariant_yoneda_exact₂ _ (inv_rot_of_dist_triangle _ _ hT) f hf₀,
  rw hg,
  simp only [zero, triangle.inv_rotate_mor₁, functor.map_zero, zero_comp, neg_zero, comp_zero],
end)

lemma mono_of_dist_triang₁ (T : triangle C) (hT : T ∈ dist_triang C) (zero : T.mor₃ = 0) :
  mono T.mor₁ :=
⟨λ Z f₁ f₂ hf, (kernel_cone_of_dist_triang₁ T hT zero).hom_ext begin
  rintro (_|_),
  { exact hf, },
  { dsimp,
    simp only [T.comp_zero₁₂ hT, comp_zero], },
end⟩

lemma mono_of_dist_triang₂ (T : triangle C) (hT : T ∈ dist_triang C) (zero : T.mor₁ = 0) :
  mono T.mor₂ :=
mono_of_dist_triang₁ _ (rot_of_dist_triangle _ _ hT)
  (by simp only [zero, triangle.rotate_mor₃, functor.map_zero, neg_zero])

lemma mono_of_dist_triang₃ (T : triangle C) (hT : T ∈ dist_triang C) (zero : T.mor₂ = 0) :
  mono T.mor₃ :=
mono_of_dist_triang₁ _ (rot_of_dist_triangle _ _ (rot_of_dist_triangle _ _ hT))
    (by { dsimp, rw [zero, functor.map_zero, neg_zero], })

lemma has_binary_biproduct_of_dist_triang (T : triangle C) (hT : T ∈ dist_triang C)
  (zero : T.mor₃ = 0) : has_binary_biproduct T.obj₁ T.obj₃ :=
begin
  haveI : mono T.mor₁ := mono_of_dist_triang₁ T hT zero,
  obtain ⟨i₂, hi₂⟩ := covariant_yoneda_exact₃ T hT (𝟙 T.obj₃) (by rw [zero, comp_zero]),
  obtain ⟨p₁, hp₁⟩ := covariant_yoneda_exact₂ T hT (𝟙 T.obj₂ - T.mor₂ ≫ i₂)
    (by rw [sub_comp, id_comp, assoc, ← hi₂, comp_id, sub_self]),
  let B : binary_bicone T.obj₁ T.obj₃ :=
  { X := T.obj₂,
    fst := p₁,
    snd := T.mor₂,
    inl := T.mor₁,
    inr := i₂,
    inl_fst' := by rw [← cancel_mono T.mor₁, assoc, ← hp₁, comp_sub, id_comp,
      comp_id, T.comp_zero₁₂_assoc hT, zero_comp, sub_zero],
    inl_snd' := T.comp_zero₁₂ hT,
    inr_fst' := by rw [← cancel_mono T.mor₁, assoc, zero_comp, ← hp₁, comp_sub,
      ← reassoc_of hi₂, comp_id, sub_self],
    inr_snd' := hi₂.symm, },
  exact has_binary_biproduct_of_total B (by rw [← hp₁, sub_add_cancel]),
end

instance : has_binary_biproducts C :=
⟨λ X₁ X₂, begin
  obtain ⟨Y, i₁, p₂, mem⟩ := pretriangulated.distinguished_cocone_triangle₂ (0 : X₂ ⟶ X₁⟦1⟧),
  exact has_binary_biproduct_of_dist_triang _ mem rfl,
end⟩

instance : has_finite_products C := by apply has_finite_products_of_has_binary_products

instance : has_finite_coproducts C := by apply has_finite_coproducts_of_has_binary_coproducts

lemma exists_iso_binary_product_of_dist_triang (T : triangle C) (hT : T ∈ dist_triang C)
  (zero : T.mor₃ = 0) :
  ∃ (e : T.obj₂ ≅ T.obj₁ ⨯ T.obj₃), T.mor₁ ≫ e.hom = prod.lift (𝟙 _) 0 ∧
    T.mor₂ = e.hom ≫ limits.prod.snd :=
begin
  haveI : mono T.mor₁ := mono_of_dist_triang₁ T hT zero,
  obtain ⟨i₂, hi₂⟩ := covariant_yoneda_exact₃ T hT (𝟙 T.obj₃) (by rw [zero, comp_zero]),
  obtain ⟨p₁, hp₁⟩ := covariant_yoneda_exact₂ T hT (𝟙 T.obj₂ - T.mor₂ ≫ i₂)
    (by rw [sub_comp, id_comp, assoc, ← hi₂, comp_id, sub_self]),
  let e : T.obj₂ ≅ T.obj₁ ⨯ T.obj₃ :=
  { hom := prod.lift p₁ T.mor₂,
    inv := limits.prod.fst ≫ T.mor₁ + limits.prod.snd ≫ i₂,
    hom_inv_id' :=  by simp only [comp_add, prod.lift_fst_assoc, prod.lift_snd_assoc,
      ← hp₁, ← hi₂, sub_add_cancel],
    inv_hom_id' := begin
      ext,
      { simp only [← cancel_mono T.mor₁, add_comp, assoc, prod.lift_fst, id_comp, ← hp₁,
          comp_sub, comp_id, T.comp_zero₁₂_assoc hT, zero_comp, comp_zero, sub_zero],
        rw [← reassoc_of hi₂, sub_self, add_zero], },
      { simp only [add_comp, assoc, prod.lift_snd, id_comp, T.comp_zero₁₂ hT, comp_zero,
          zero_add, ← hi₂, comp_id], },
    end, },
  refine ⟨e, _, by simp only [prod.lift_snd]⟩,
  { rw [← cancel_mono e.inv, assoc, e.hom_inv_id, comp_id],
    simp only [comp_add, prod.lift_fst_assoc, id_comp, prod.lift_snd_assoc, zero_comp, add_zero], },
end

instance : split_mono_category C :=
⟨λ X Y i, begin
  introI,
  constructor,
  obtain ⟨Z, z, p, mem⟩ := pretriangulated.distinguished_cocone_triangle₁ i,
  have zero : z ≫ i = 0 := triangle.comp_zero₁₂ _ mem,
  have hz : z = 0 := by rw [← cancel_mono i, zero, zero_comp],
  obtain ⟨r, hr⟩ := contravariant_yoneda_exact₂ _ mem (𝟙 X) (by { dsimp, rw [hz, zero_comp], }),
  exact nonempty.intro ⟨r, hr.symm⟩,
end⟩

lemma binary_product_triangle_distinguished (X₁ X₂ : C) :
  triangle.mk (prod.lift (𝟙 X₁) (0 : X₁ ⟶ X₂)) limits.prod.snd 0 ∈ dist_triang C :=
begin
  obtain ⟨Y, g, h, mem⟩ := pretriangulated.distinguished_cocone_triangle₂ (0 : X₂ ⟶ X₁⟦(1 : ℤ)⟧),
  obtain ⟨e, ⟨he₁, he₂⟩⟩ := exists_iso_binary_product_of_dist_triang _ mem rfl,
  refine pretriangulated.isomorphic_distinguished _ mem _ _,
  symmetry,
  dsimp at he₁ he₂,
  refine triangle.mk_iso _ _ (iso.refl _) e (iso.refl _) _ _ _,
  { dsimp,
    simp only [prod.comp_lift, comp_id, comp_zero, id_comp, he₁], },
  { dsimp,
    rw [comp_id, he₂], },
  { simp only [triangle.mk_mor₃, zero_comp, comp_zero], },
end

lemma binary_biproduct_triangle_distinguished (X₁ X₂ : C) :
  triangle.mk (limits.biprod.inl : X₁ ⟶ _) (limits.biprod.snd : _ ⟶ X₂) 0 ∈ dist_triang C :=
isomorphic_distinguished _ (binary_product_triangle_distinguished X₁ X₂) _ begin
  let e : X₁ ⊞ X₂ ≅ prod X₁ X₂ :=
  { hom := prod.lift biprod.fst biprod.snd,
    inv := biprod.lift limits.prod.fst limits.prod.snd, },
  exact triangle.mk_iso _ _ (iso.refl _) e (iso.refl _) (by tidy) (by tidy) (by tidy),
end

@[simps]
def triangle.coproduct {I : Type*} (T : I → triangle C) [has_coproduct (λ i, (T i).obj₁)]
  [has_coproduct (λ i, (T i).obj₂)] [has_coproduct (λ i, (T i).obj₃)]
  [has_coproduct (λ i, (shift_functor C (1 : ℤ)).obj (T i).obj₁)] : triangle C :=
{ obj₁ := ∐ (λ i, (T i).obj₁),
  obj₂ := ∐ (λ i, (T i).obj₂),
  obj₃ := ∐ (λ i, (T i).obj₃),
  mor₁ := limits.sigma.map (λ i, (T i).mor₁),
  mor₂ := limits.sigma.map (λ i, (T i).mor₂),
  mor₃ := limits.sigma.map (λ i, (T i).mor₃) ≫ sigma_comparison _ _, }

/-lemma triangle.coproduct_distinghished {I : Type*} (T : I → triangle C)
  [has_coproduct (λ i, (T i).obj₁)]
  [has_coproduct (λ i, (T i).obj₂)] [has_coproduct (λ i, (T i).obj₃)]
  [has_coproduct (λ i, (shift_functor C (1 : ℤ)).obj (T i).obj₁)]
  (hT : ∀ i, (T i) ∈ dist_triang C) : triangle.coproduct T ∈ dist_triang C := sorry-/

open algebra.homology

lemma triangle.product_distinghished {I : Type} (T : I → triangle C)
  [has_product (λ i, (T i).obj₁)]
  [has_product (λ i, (T i).obj₂)] [has_product (λ i, (T i).obj₃)]
  [has_product (λ i, (shift_functor C (1 : ℤ)).obj (T i).obj₁)]
  [has_product (λ i, (shift_functor C (1 : ℤ)).obj (T i).obj₂)]
  (hT : ∀ i, (T i) ∈ dist_triang C) : triangle.product T ∈ dist_triang C :=
begin
  let f₁ := pi.map (λ i, (T i).mor₁),
  obtain ⟨Z, f₂, f₃, hT'⟩ := distinguished_cocone_triangle _ _ f₁,
  let T' := triangle.mk f₁ f₂ f₃,
  change T' ∈ dist_triang C at hT',
  have h : ∀ (i : I), ∃ (φ₃ : T'.obj₃ ⟶ (T i).obj₃),
    T'.mor₂ ≫ φ₃ = pi.π _ i ≫ (T i).mor₂ ∧ T'.mor₃ ≫ (pi.π _ i)⟦1⟧' = φ₃ ≫ (T i).mor₃ :=
      λ i, pretriangulated.complete_distinguished_triangle_morphism _ _ hT' (hT i)
      (pi.π _ i) (pi.π _ i) (by simp only [triangle.mk_mor₁, lim_map_π, discrete.nat_trans_app]),
  let φ : Π i, T' ⟶ T i := λ i,
  { hom₁ := pi.π _ i,
    hom₂ := pi.π _ i,
    hom₃ := (h i).some,
    comm₁' := by simp only [triangle.mk_mor₁, lim_map_π, discrete.nat_trans_app],
    comm₂' := (h i).some_spec.1,
    comm₃' := (h i).some_spec.2, },
  let φ' : T' ⟶ triangle.product T := triangle.product.lift φ,
  suffices : is_iso φ'.hom₃,
  { haveI : is_iso φ'.hom₁,
    { have eq₁ : φ'.hom₁ = 𝟙 _,
      { ext i,
        discrete_cases,
        simp only [triangle.product.lift_hom₁, limit.lift_π, fan.mk_π_app, id_comp], },
      rw eq₁,
      apply_instance, },
    haveI : is_iso φ'.hom₂,
    { have eq₂ : φ'.hom₂ = 𝟙 _,
      { ext i,
        discrete_cases,
        simp only [triangle.product.lift_hom₂, limit.lift_π, fan.mk_π_app, id_comp], },
      rw eq₂,
      apply_instance, },
    haveI : is_iso φ',
    { exact triangle.is_iso_of_is_iso_homs _ infer_instance infer_instance infer_instance, },
    exact pretriangulated.isomorphic_distinguished _ hT' _ (as_iso φ').symm, },
  refine is_iso_of_yoneda_bijective _ (λ A, _),
  let T'' := λ i, candidate_triangle.of_distinguished _ (hT i),
  haveI : has_product (λ i, (T'' i).1.obj₁),
  { dsimp, apply_instance, },
  haveI : has_product (λ i, (T'' i).1.obj₂),
  { dsimp, apply_instance, },
  haveI : has_product (λ i, (T'' i).1.obj₃),
  { dsimp, apply_instance, },
  haveI : has_product (λ i, (shift_functor C (1 : ℤ)).obj (T'' i).1.obj₁),
  { dsimp, apply_instance, },
  haveI : has_product (λ i, (shift_functor C (1 : ℤ)).obj (T'' i).1.obj₂),
  { dsimp, apply_instance, },
  let ψ : candidate_triangle.of_distinguished T' hT' ⟶ candidate_triangle.pi T'' := φ',
  have hψ₁ : ((candidate_triangle.to_five_complex C).map ψ).τ₁ = 𝟙 _,
  { ext i, discrete_cases, dsimp, simp only [limit.lift_π, fan.mk_π_app, id_comp], },
  have hψ₂ : ((candidate_triangle.to_five_complex C).map ψ).τ₂ = 𝟙 _,
  { ext i, discrete_cases, dsimp, simp only [limit.lift_π, fan.mk_π_app, id_comp], },
  have hψ₄ : ((candidate_triangle.to_five_complex C).map ψ).τ₄ = 𝟙 _,
  { dsimp, convert functor.map_id _ _, },
  have hψ₅ : ((candidate_triangle.to_five_complex C).map ψ).τ₅ = 𝟙 _,
  { dsimp, convert functor.map_id _ _, },
  refine five_complex.five_lemma_bijective ((preadditive_coyoneda.obj
    (opposite.op A)).map_five_complex.map ((candidate_triangle.to_five_complex C).map ψ))
    (candidate_triangle.coyoneda_exact_of_distinguished _ _ _) _
    (yoneda_bijective_of_is_iso _ (by { rw hψ₁, apply_instance, }) _)
    (yoneda_bijective_of_is_iso _ (by { rw hψ₂, apply_instance, }) _)
    (yoneda_bijective_of_is_iso _ (by { rw hψ₄, apply_instance, }) _)
    (yoneda_bijective_of_is_iso _ (by { rw hψ₅, apply_instance, }) _),
  exact candidate_triangle.pi_coyoneda_exact _ _
    (λ i, candidate_triangle.coyoneda_exact_of_distinguished _ _ _),
end

@[simps]
def triangle.coprod (T₁ T₂ : triangle C) [has_binary_product T₁.obj₁ T₂.obj₁]
  [has_binary_product T₁.obj₂ T₂.obj₂] [has_binary_product T₁.obj₃ T₂.obj₃]
  [has_binary_product ((shift_functor C (1 : ℤ)).obj T₁.obj₃)
    ((shift_functor C (1 : ℤ)).obj T₁.obj₃)] : triangle C :=
{ obj₁ := T₁.obj₁ ⨿ T₂.obj₁,
  obj₂ := T₁.obj₂ ⨿ T₂.obj₂,
  obj₃ := T₁.obj₃ ⨿ T₂.obj₃,
  mor₁ := coprod.map T₁.mor₁ T₂.mor₁,
  mor₂ := coprod.map T₁.mor₂ T₂.mor₂,
  mor₃ := coprod.map T₁.mor₃ T₂.mor₃ ≫ coprod_comparison _ _ _, }

@[simps]
def coprod_iso_coproduct {D : Type*} [category D] (X : walking_pair → D)
  [has_coproduct (λ i, X i)] [has_binary_coproduct (X walking_pair.left) (X walking_pair.right)] :
  X walking_pair.left ⨿ X walking_pair.right ≅ ∐ X :=
{ hom := coprod.desc (sigma.ι _ _) (sigma.ι _ _),
  inv := sigma.desc (by { rintro (_|_), exacts [coprod.inl, coprod.inr], }),
  hom_inv_id' := by tidy,
  inv_hom_id' := by { ext j, discrete_cases, cases j, tidy, }, }

/-
lemma triangle.coprod_distinguished {I : Type*} (T₁ T₂ : triangle C)
  (hT₁ : T₁ ∈ dist_triang C) (hT₂ : T₂ ∈ dist_triang C) :
  triangle.coprod T₁ T₂ ∈ dist_triang C :=
begin
  let T' : walking_pair → triangle C := by { rintro (_|_), exacts [T₁, T₂], },
  have hT' := triangle.coproduct_distinghished T' (by { rintro (_|_), exacts [hT₁, hT₂], }),
  refine isomorphic_distinguished _ hT' _ _,
  refine triangle.mk_iso _ _ (coprod_iso_coproduct (λ i, (T' i).obj₁))
    (coprod_iso_coproduct (λ i, (T' i).obj₂)) (coprod_iso_coproduct (λ i, (T' i).obj₃))
    (by tidy) (by tidy) _,
  ext,
  { dsimp [T'],
    simp only [assoc, coprod.inl_map_assoc, coprod_comparison_inl_assoc, coprod.desc_comp_assoc,
      ι_colim_map, discrete.nat_trans_app, coprod.desc_comp, ι_comp_sigma_comparison,
      coprod.inl_desc, ι_colim_map_assoc, ← functor.map_comp], },
  { dsimp [T'],
    simp only [assoc, coprod.inr_map_assoc, coprod_comparison_inr_assoc, coprod.desc_comp_assoc,
      ι_colim_map, discrete.nat_trans_app, coprod.desc_comp, ι_comp_sigma_comparison,
      coprod.inr_desc, ι_colim_map_assoc, ← functor.map_comp], },
end-/

end pretriangulated

end category_theory


import condensed.proetale_site
import for_mathlib.presieve
import topology.category.Profinite.projective
import for_mathlib.Profinite.disjoint_union
import for_mathlib.fintype_induction
import tactic.derive_fintype -- for pbool

universes w v u

namespace category_theory.functor

open category_theory opposite

variables {C : Type u} [category.{v} C] (Q : Profinite.{w}ᵒᵖ ⥤ C)
variables (P : Profinite.{w}ᵒᵖ ⥤ Type u)

/-- A presheaf of types `P` on `Profinite` satisfies the finite product
condition if given any finite collection of topological spaces `X i`
indexed by `i` in `(α : Fintype)`, the map from `P (∑ i, X i)`
to `Π (a : α), P (X a)` sending `x` to the dependent function sending
`a : α` to  `P (the inclusion X a → Σ i, X i), evaluated at x`,
is a bijection. -/
def finite_product_condition : Prop := ∀
(α : Fintype.{w}) (X : α → Profinite.{w}),
function.bijective (λ (x : P.obj (op (Profinite.sigma X))) (a : α),
  P.map (Profinite.sigma.ι X a).op x)

def finite_product_condition_of (α : Fintype.{w}) : Prop :=
  ∀ (X : α → Profinite.{w}),
  function.bijective (λ (x : P.obj (op (Profinite.sigma X))) (a : α),
    P.map (Profinite.sigma.ι X a).op x)

def finite_product_condition' : Prop := ∀
(n : ℕ) (X : ulift.{w} (fin n) → Profinite.{w}),
function.bijective (λ (x : P.obj (op (Profinite.sigma X))) (a : ulift (fin n)),
  P.map (Profinite.sigma.ι X a).op x)

namespace finite_product_aux
def obj_equiv {α β : Type*} (e : α ≃ β) (X : β → Profinite.{w}) (b : β) :
  X b ≅ X (e (e.symm b)) := eq_to_iso (congr_arg X (e.apply_symm_apply _).symm)

def product_equiv {α β : Type*} (e : α ≃ β) (X : β → Profinite.{w}) :
  (Π (a : α), P.obj (opposite.op (X (e a)))) ≃ (Π b, P.obj (opposite.op (X b))) :=
e.Pi_congr (λ b, equiv.refl _)

def sigma_equiv {α β : Type w} [fintype α] [fintype β] (e : α ≃ β) (X : β → Profinite.{w}) :
  P.obj (opposite.op (Profinite.sigma (X ∘ e))) ≃
  P.obj (opposite.op (Profinite.sigma X)) :=
(P.map_iso (Profinite.sigma_iso_of_equiv _ _).op).symm.to_equiv

lemma product_equiv_compatible {α β : Type w} [fintype α] [fintype β]
  (e : α ≃ β) (X : β → Profinite.{w}) (a) (b) :
    P.map (Profinite.sigma.ι _ b).op ((sigma_equiv P e X).symm a) =
    (product_equiv P e X).symm (λ b, P.map (Profinite.sigma.ι _ _).op a) b :=
begin
  dsimp [product_equiv, sigma_equiv],
  simp only [← functor_to_types.map_comp_apply],
  refl,
end

end finite_product_aux

open finite_product_aux

lemma finite_product_condition_of_equiv (α β : Fintype.{w}) (e : α ≃ β)
  (h : P.finite_product_condition_of α) : P.finite_product_condition_of β :=
begin
  intros X,
  specialize h (X ∘ e),
  let f := _, show function.bijective f,
  let g := _, change function.bijective g at h,
  have : f = (product_equiv _ _ _) ∘ g ∘ (sigma_equiv P e X).symm,
  { suffices : (product_equiv _ _ _).symm ∘ f = g ∘ (sigma_equiv P e X).symm,
    by { rw ← this, ext, simp },
    symmetry,
    ext a,
    apply product_equiv_compatible },
  rw this,
  apply function.bijective.comp (equiv.bijective _) (h.comp (equiv.bijective _))
end

lemma finite_product_condition_iff_finite_product_condition' :
  P.finite_product_condition ↔ P.finite_product_condition' :=
begin
  split,
  { intros h n X,
    apply h ⟨ulift (fin n)⟩ X },
  { intros h α X,
    let n := fintype.card α,
    let e : ulift.{w} (fin n) ≃ α := equiv.ulift.trans (fintype.equiv_fin _).symm,
    let f := _, show function.bijective f,
    specialize h n (X ∘ e),
    let g := _, change function.bijective g at h,
    have : f = (product_equiv _ _ _) ∘ g ∘ (sigma_equiv P e X).symm,
    { suffices : (product_equiv _ _ _).symm ∘ f = g ∘ (sigma_equiv P e X).symm,
        by { rw ← this, ext, simp },
      symmetry,
      ext a,
      apply product_equiv_compatible },
    rw this,
    apply function.bijective.comp (equiv.bijective _) (h.comp (equiv.bijective _)) }
end

def empty_condition : Prop :=
  function.bijective (λ t : P.obj (op Profinite.empty), punit.star.{u})

def product_condition : Prop := ∀ (X Y : Profinite.{w}),
  function.bijective (λ (t : P.obj (op $ Profinite.sum X Y)),
    ((P.map (Profinite.sum.inl X Y).op t, P.map (Profinite.sum.inr X Y).op t) :
      P.obj (op X) × P.obj (op Y)))

open opposite

lemma finite_product_condition_of_empty_iff_empty_condition :
  P.finite_product_condition_of ⟨pempty⟩ ↔ P.empty_condition :=
begin
  split,
  { intros h,
    let f := _, show function.bijective f,
    let X : (pempty : Type w) → Profinite.{w} := pempty.elim,
    specialize h X,
    let g := _, change function.bijective g at h,
    let e : P.obj (opposite.op Profinite.empty) ≃ P.obj (op (Profinite.sigma X)) :=
      (P.map_iso (Profinite.sigma_iso_empty' X).op).to_equiv,
    let q : (Π (a : pempty), P.obj (op (X a))) ≃ punit :=
      ⟨λ a, punit.star, λ _ a, a.elim, by { intros i, ext ⟨⟩ }, by { rintros ⟨⟩, refl }⟩,
    have : f = q ∘ g ∘ e, { ext },
    rw this,
    exact q.bijective.comp (h.comp e.bijective) },
  { intros h X,
    let f := _, show function.bijective f,
    let g := _, change function.bijective g at h,
    let e : P.obj (op (Profinite.sigma X)) ≃ P.obj (op (Profinite.empty)) :=
      (P.map_iso (Profinite.sigma_iso_empty' X).op).symm.to_equiv,
    let q : punit ≃ (Π (a : pempty), P.obj (op (X a))) :=
      ⟨λ _ a, a.elim, λ _, punit.star,  by { rintros ⟨⟩, refl }, by { intros i, ext ⟨⟩ }⟩,
    have : f = q ∘ g ∘ e, { ext _ ⟨⟩ },
    rw this,
    exact q.bijective.comp (h.comp e.bijective) }
end

lemma finite_product_condition_of_pair_iff_product_condition :
  P.finite_product_condition_of ⟨ulift limits.walking_pair⟩ ↔ P.product_condition :=
begin
  split,
  { intros h A B,
    let f := _, show function.bijective f,
    let X : limits.walking_pair → Profinite.{w} :=
      λ i, limits.walking_pair.rec_on i A B,
    specialize h (X ∘ ulift.down),
    let g := _, change function.bijective g at h,
    let e : P.obj (op (A.sum B)) ≃ P.obj (op (Profinite.sigma (X ∘ ulift.down))) :=
      (P.map_iso (Profinite.sigma_walking_pair_iso (X ∘ ulift.down)).op).to_equiv,
    let q : (Π (a : limits.walking_pair), P.obj (op (X a))) ≃
      P.obj (op A) × P.obj (op B) :=
      ⟨λ f, ⟨f limits.walking_pair.left, f limits.walking_pair.right⟩,
        λ x a, limits.walking_pair.rec_on a x.1 x.2, _, _⟩,
    rotate, { intros a, ext ⟨x|x⟩, refl, refl }, { rintros ⟨a,b⟩, ext ⟨x|x⟩, refl, refl },
    let g' :
      (Π (a : Fintype.of (ulift.{w} limits.walking_pair)), P.obj (opposite.op (X a.down))) ≃
      (Π (a : limits.walking_pair), P.obj (opposite.op (X a))) :=
      ⟨λ f a, f ⟨a⟩, λ f a, f a.down,  _, _⟩,
    rotate,
    { intros f, ext ⟨a⟩, refl },
    { intros f, ext a, refl },
    have : f = q ∘ g' ∘ g ∘ e,
    { ext a,
      all_goals
      { dsimp [f,q,g,e],
        simp_rw [← functor_to_types.map_comp_apply, ← op_comp],
        refl } },
    rw this,
    refine q.bijective.comp _,
    refine g'.bijective.comp (h.comp e.bijective) },
  { intros h X,
    let f := _, show function.bijective f,
    specialize h (X ⟨limits.walking_pair.left⟩) (X ⟨limits.walking_pair.right⟩),
    let g := _, change function.bijective g at h,
    let e : P.obj (op (Profinite.sigma X)) ≃ P.obj (op (Profinite.sum _ _)) :=
      (P.map_iso (Profinite.sigma_walking_pair_iso X).op).symm.to_equiv,
    let q : P.obj (op (X ⟨limits.walking_pair.left⟩)) × P.obj (op (X ⟨limits.walking_pair.right⟩)) ≃
      (Π a : ulift.{w} limits.walking_pair, P.obj (op (X a))) :=
      ⟨λ x ⟨a⟩, limits.walking_pair.rec_on a x.1 x.2,
        λ f, (f ⟨limits.walking_pair.left⟩, f ⟨limits.walking_pair.right⟩), _, _⟩,
    rotate,
    { rintros ⟨a,b⟩, ext ⟨x|x⟩, refl, refl },
    { intros a, ext ⟨x|x⟩, refl, refl },
    have : f = q ∘ g ∘ e,
    { ext a ⟨x|x⟩,
      all_goals
      { dsimp [f,q,g,e],
        simp_rw [← functor_to_types.map_comp_apply, ← op_comp],
        refl } },
    rw this,
    exact q.bijective.comp (h.comp e.bijective) },
end

lemma finite_product_condition_of_sum (α β : Fintype.{w})
  (h1 : P.product_condition)
  (h2 : P.finite_product_condition_of α) :
  P.finite_product_condition_of (Fintype.of $ α ⊕ (punit : Type w)) :=
begin
  intros X,
  let f := _, show function.bijective f,
  let I : Profinite.sigma X ≅ _ := Profinite.sigma_sum_iso' _,
  let t : P.obj (opposite.op (Profinite.sigma X)) ≃ _ :=
    (P.map_iso I.symm.op).to_equiv,
  specialize h1 (Profinite.sigma (X ∘ sum.inl)) (Profinite.sigma (X ∘ sum.inr)),
  let g := _, change function.bijective g at h1,
  let e : (Π (a : ↥(Fintype.of (↥α ⊕ punit))), P.obj (opposite.op (X a))) ≃
    (Π (a : α), P.obj (op (X (sum.inl a)))) × P.obj (op (X (sum.inr punit.star))) :=
    ⟨ λ f, ⟨λ a, f (sum.inl a), f (sum.inr _)⟩,
      λ f x, sum.rec_on x (λ a, f.1 a) (λ ⟨⟩, f.2), _, _⟩,
  rotate, { rintros x, ext (a|⟨⟨⟩⟩), refl, refl }, { rintros ⟨a,b⟩, ext ⟨a|⟨⟨⟩⟩⟩, refl, refl },
  let l : P.obj (op (X (sum.inr punit.star))) ≃ P.obj (op (Profinite.sigma (X ∘ sum.inr))) :=
    (P.map_iso (Profinite.sigma_punit_iso (X ∘ sum.inr)).op).symm.to_equiv,
  specialize h2 (X ∘ sum.inl),
  let p := _, change function.bijective p at h2,
  let q :
    P.obj (op (Profinite.sigma (X ∘ sum.inl))) × P.obj (op (Profinite.sigma (X ∘ sum.inr)))
      ≃ (Π (a : α), P.obj (op (X (sum.inl a)))) × P.obj (op (Profinite.sigma (X ∘ sum.inr))) :=
    (equiv.of_bijective p h2).prod_congr (equiv.refl _),
  let r : (Π (a : α), P.obj (op (X (sum.inl a)))) × _ ≃ _ × _ :=
    (equiv.refl _).prod_congr l.symm,
  have : f = e.symm ∘ prod.map id l.symm ∘ q ∘ g ∘ t,
  { ext x ⟨a|⟨⟨⟩⟩⟩,
    ext i,
    cases i,
    { dsimp [f, e, q, g, t, p, I, Profinite.sigma_sum_iso'],
      simp_rw [← functor_to_types.map_comp_apply, ← op_comp],
      refl },
    { cases i,
      dsimp [f, e, q, g, t, p, I, Profinite.sigma_sum_iso'],
      simp_rw [← functor_to_types.map_comp_apply, ← op_comp],
      refl } },
  rw this,
  exact e.symm.bijective.comp (r.bijective.comp (q.bijective.comp (h1.comp t.bijective))),
end

theorem finite_product_condition_iff_empty_product :
  P.finite_product_condition ↔ P.empty_condition ∧ P.product_condition :=
begin
  split,
  { intros h,
    split,
    rw ← finite_product_condition_of_empty_iff_empty_condition,
    apply h,
    rw ← finite_product_condition_of_pair_iff_product_condition,
    apply h },
  { rintros ⟨h1,h2⟩,
    have := @Fintype.induction_empty_sum (λ (α : Fintype.{w}), P.finite_product_condition_of α),
    apply this,
    { intros α β e h,
      apply finite_product_condition_of_equiv _ _ _ e h },
    { erw finite_product_condition_of_empty_iff_empty_condition,
      assumption },
    { intros α h,
      apply finite_product_condition_of_sum P α (Fintype.of punit),
      assumption,
      assumption } }
end

-- should this be in mathlib in some form?
section is_singleton

-- is_singleton X is [nonempty X] [subsingleton X]

theorem is_singleton_iff_forall_bijective_to_punit (X : Sort*) :
  nonempty X ∧ subsingleton X ↔ ∀ f : X → punit, function.bijective f :=
begin
  split,
  { rintro ⟨h1, h2⟩ f,
    haveI := h2,
    exact ⟨λ a b h, subsingleton.elim _ _, λ s, ⟨h1.some, subsingleton.elim _ _⟩⟩ },
  { intro h,
    cases h (λ x, punit.star) with finj fsurj,
    choose g hg using fsurj,
    refine ⟨⟨g punit.star⟩, subsingleton.intro $ λ a b, finj rfl⟩, }
end

theorem is_singleton_iff_forall_bijective_to_is_singleton (X : Sort*) :
  nonempty X ∧ subsingleton X ↔ ∀ (Y : Sort*) [nonempty Y] [subsingleton Y]
  (f : X → Y), function.bijective f :=
begin
  split,
  { rintro ⟨⟨x⟩, hx⟩ Y hY1 hY2 f,
    haveI := hY2,
    haveI := hx,
    refine ⟨λ a b h, subsingleton.elim a b, λ s, ⟨x, subsingleton.elim _ _⟩⟩ },
  { intro h,
    cases h punit (λ x, punit.star) with finj fsurj,
    choose g hg using fsurj,
    refine ⟨⟨g punit.star⟩, subsingleton.intro $ λ a b, finj rfl⟩, }
end

theorem is_singleton_iff_exists_bijective_to_punit (X : Sort*) :
  nonempty X ∧ subsingleton X ↔ ∃ f : X → punit, function.bijective f :=
begin
  split,
  { rintro ⟨⟨x⟩, hx⟩,
    haveI := hx,
    use (λ x, punit.star),
    refine ⟨λ a b _, subsingleton.elim a b,
      λ a, ⟨x, subsingleton.elim _ _⟩⟩ },
  { rintro ⟨f, finj, fsurj⟩,
    choose g hg using fsurj,
    refine ⟨⟨g punit.star⟩, subsingleton.intro $ λ a b, finj $ subsingleton.elim _ _⟩, }
end

theorem is_singleton_iff_exists_bijective_to_is_singleton (X : Sort*) :
  nonempty X ∧ subsingleton X ↔ ∃ (Y : Sort*) [nonempty Y] [subsingleton Y] (f : X → Y), function.bijective f :=
begin
  split,
  { rintro ⟨⟨x⟩, hx⟩,
    haveI := hx,
    use [punit, infer_instance, infer_instance, (λ x, punit.star)],
    refine ⟨λ a b _, subsingleton.elim a b,
      λ a, ⟨x, subsingleton.elim _ _⟩⟩ },
  { rintro ⟨Y, hY1, hY2, f, finj, fsurj⟩,
    choose g hg using fsurj,
    haveI := hY2,
    refine ⟨⟨g hY1.some⟩, ⟨λ a b, finj $ subsingleton.elim _ _⟩⟩, },
end

lemma subsingleton.map_equiv {X Y : Type*} (e : X ≃ Y) : subsingleton X → subsingleton Y :=
λ h, ⟨λ a b, e.symm.injective $ @subsingleton.elim _ h _ _⟩

end is_singleton

section pbool

-- The category theory library has a type called `walking_pair` which accomplishes the same thing.
-- It's used in the API for binary (co)products.

@[derive fintype]
inductive pbool : Type u
| ff : pbool
| tt : pbool

end pbool

/-
-- Kevin is working on this
--lemma finite_product_condition_iff_empty_condition_product_condition :
--  P.finite_product_condition ↔ P.empty_condition ∧ P.product_condition :=
--begin
  /-
  split,
  { intro h_prod,
    split,
    { specialize h_prod (Fintype.of pempty) (λ x, Profinite.empty),
      suffices hs : nonempty (P.obj (op Profinite.empty)) ∧ subsingleton (P.obj (op Profinite.empty)),
      { rw is_singleton_iff_forall_bijective_to_punit at hs,
        apply hs },
      let e : Profinite.sigma.{w} (λ (x : ↥(Fintype.of.{w} pempty)), Profinite.empty) ≅ Profinite.empty :=
      { hom := Profinite.sigma.desc _ (λ i, by cases i),
        inv := Profinite.empty.elim _,
        hom_inv_id' := by {ext1 x, rcases x with ⟨⟨⟩⟩ },
        inv_hom_id' := by {ext1 x, cases x } },
      let e2 := category_theory.iso.op e,
      let e3 := category_theory.functor.map_iso P e2,
      let e4 := category_theory.iso.to_equiv e3,
      have := (is_singleton_iff_exists_bijective_to_is_singleton _).2 ⟨_, _, _, _, h_prod⟩,
      { exact ⟨nonempty.map e4.symm this.1, subsingleton.map_equiv e4.symm this.2⟩ },
      { exact ⟨λ x, by rcases x with ⟨⟨⟩⟩⟩ },
      { exact ⟨λ f g, by {ext x, rcases x with ⟨⟨⟩⟩ }⟩ } },
    { specialize h_prod (Fintype.of pbool),
      /-
      ∀ (X : ↥(Fintype.of pbool)) → Profinite), function.bijective
       (λ (x : P.obj (opposite.op (Profinite.sigma X))) (a : ↥(Fintype.of pbool)), P.map (Profinite.sigma.ι X a).op x)

      For all X : pbool -> Profinite, the obvious map from
      P(Σ X) to Π (a : pbool), P (X a) is bijective
      -/
      intros S T,
      let X : ↥(Fintype.of pbool) → Profinite :=
        λ a, pbool.rec S T a,
      specialize h_prod X,
      /-
      hypothesis : if X : pbool -> Profinite sends ff to S
      and tt to T, then the obvious map from
      P(Σ X) to Π (a : pbool), P (X a) is bijective.

      Goal: the obvious map from P (S ⊕ T) to P S × P T is bijective

      plan : triangle S → Σ X ≃ S ⊕ T commutes;
      triangle T → Σ X ≃ S ⊕ T commutes;

      Claim: the obvious map from P (S ⊕ T) to P S × P T
      is the obvious map from P (S ⊕ T) to Π (a : pbool), P (X a)
      composed with the obvious bijection
        from Π a, P (X a) to P S × P T.

      Reid says work with the commutative square, i.e. the two maps
      P (Σ a, X a) ⟶ P S × P T

      -/
      admit
    } },
  { admit }
  -/
--end
-/

def map_to_equalizer {W X B : Profinite.{w}} (f : X ⟶ B) (g₁ g₂ : W ⟶ X)
  (w : g₁ ≫ f = g₂ ≫ f) :
  P.obj (op B) → { x : P.obj (op X) | P.map g₁.op x = P.map g₂.op x } :=
λ t, ⟨P.map f.op t, by { change (P.map _ ≫ P.map _) _ = (P.map _ ≫ P.map _) _,
  simp_rw [← P.map_comp, ← op_comp, w] }⟩

def equalizer_condition : Prop := ∀
(X B : Profinite.{w}) (π : X ⟶ B) (surj : function.surjective π),
function.bijective (map_to_equalizer P π (Profinite.pullback.fst π π) (Profinite.pullback.snd π π)
    (Profinite.pullback.condition _ _))

-- Should we make this `unique` instead of `subsingleton`?
def subsingleton_empty : Prop := ∀
(Z : Profinite.{w}) [is_empty Z], subsingleton (P.obj (op Z))

def is_proetale_sheaf_of_types : Prop := ∀
-- a finite family of morphisms with base B
(α : Type w) [fintype α] (B : Profinite.{w}) (X : α → Profinite.{w}) (f : Π a, X a ⟶ B)
-- jointly surjective
(surj : ∀ b : B, ∃ a (x : X a), f a x = b)
-- family of terms
(x : Π a, P.obj (op (X a)))
-- which is compatible
(compat : ∀ (a b : α) (Z : Profinite.{w}) (g₁ : Z ⟶ X a) (g₂ : Z ⟶ X b),
  (g₁ ≫ f a = g₂ ≫ f b) → P.map g₁.op (x a) = P.map g₂.op (x b)),
-- the actual condition
∃! t : P.obj (op B), ∀ a : α, P.map (f a).op t = x a

def is_proetale_sheaf_of_types_pullback : Prop := ∀
-- a finite family of morphisms with base B
(α : Type w) [fintype α] (B : Profinite.{w}) (X : α → Profinite.{w}) (f : Π a, X a ⟶ B)
-- jointly surjective
(surj : ∀ b : B, ∃ a (x : X a), f a x = b)
-- family of terms
(x : Π a, P.obj (op (X a)))
-- which is compatible
(compat : ∀ (a b : α),
  P.map (limits.pullback.fst : limits.pullback (f a) (f b) ⟶ _).op (x a) =
  P.map limits.pullback.snd.op (x b)),
-- the actual condition
∃! t : P.obj (op B), ∀ a : α, P.map (f a).op t = x a

def is_proetale_sheaf_of_types_explicit_pullback : Prop := ∀
-- a finite family of morphisms with base B
(α : Type w) [fintype α] (B : Profinite.{w}) (X : α → Profinite.{w}) (f : Π a, X a ⟶ B)
-- jointly surjective
(surj : ∀ b : B, ∃ a (x : X a), f a x = b)
-- family of terms
(x : Π a, P.obj (op (X a)))
-- which is compatible
(compat : ∀ (a b : α),
  P.map (Profinite.pullback.fst (f a) (f b)).op (x a) =
  P.map (Profinite.pullback.snd _ _).op (x b)),
-- the actual condition
∃! t : P.obj (op B), ∀ a : α, P.map (f a).op t = x a

def is_proetale_sheaf_of_types_projective : Prop := ∀
-- a finite family of projective objects
(α : Fintype.{w}) (X : α → Profinite.{w}) [∀ a, projective (X a)],
function.bijective (λ (x : P.obj (op $ Profinite.sigma X)) (a : α),
  P.map (Profinite.sigma.ι _ a).op x)

theorem subsingleton_empty_of_is_proetale_sheaf_of_types
  (h : P.is_proetale_sheaf_of_types) : P.subsingleton_empty :=
begin
  intros Z hZ,
  specialize h pempty Z pempty.elim (λ a, a.elim) hZ.elim (λ a, a.elim) (λ a, a.elim),
  obtain ⟨t,ht1,ht2⟩ := h,
  constructor,
  intros x y,
  have : x = t, { apply ht2, exact λ a, a.elim },
  have : y = t, { apply ht2, exact λ a, a.elim },
  cc,
end

theorem finite_product_condition_of_is_proetale_sheaf_of_types
  (h : P.is_proetale_sheaf_of_types) : P.finite_product_condition :=
begin
  intros α X,
  split,
  { intros x y hh,
    dsimp at hh,
    specialize h α (Profinite.sigma X) X (Profinite.sigma.ι X)
      (Profinite.sigma.ι_jointly_surjective X)
      (λ a, P.map (Profinite.sigma.ι X a).op x) _,
    { intros a b Z g₁ g₂ hhh,
      dsimp,
      change (P.map _ ≫ P.map _) _ = (P.map _ ≫ P.map _) _,
      simp_rw [← P.map_comp, ← op_comp, hhh] },
    obtain ⟨t,ht1,ht2⟩ := h,
    have hx : x = t,
    { apply ht2,
      intros a,
      refl },
    have hy : y = t,
    { apply ht2,
      intros a,
      apply_fun (λ e, e a) at hh,
      exact hh.symm },
    rw [hx, ← hy] },
  { intros bb,
    dsimp,
    specialize h α (Profinite.sigma X) X (Profinite.sigma.ι X)
      (Profinite.sigma.ι_jointly_surjective X) bb _,
    { intros a b Z g₁ g₂ hhh,
      by_cases hZ : is_empty Z,
      { haveI := hZ,
        haveI := subsingleton_empty_of_is_proetale_sheaf_of_types P h Z,
        apply subsingleton.elim },
      simp at hZ,
      obtain ⟨z⟩ := hZ,
      have : a = b,
      { apply_fun (λ e, (e z).1) at hhh,
        exact hhh },
      subst this,
      have : g₁ = g₂,
      { ext1 t,
        apply_fun (Profinite.sigma.ι X a),
        swap, { exact Profinite.sigma.ι_injective X a },
        apply_fun (λ e, e t) at hhh,
        exact hhh },
      rw this },
    obtain ⟨t,ht1,ht2⟩ := h,
    use t,
    ext,
    apply ht1 }
end

theorem is_proetale_sheaf_of_types_iff :
  P.is_proetale_sheaf_of_types ↔ presieve.is_sheaf proetale_topology P :=
begin
  erw presieve.is_sheaf_pretopology,
  split,
  { intros h B S hS,
    obtain ⟨α, _, X, f, surj, rfl⟩ := hS,
    resetI,
    intros x hx,
    dsimp [presieve.family_of_elements] at x,
    let y : Π (a : α), P.obj (op (X a)) := λ a, x (f a) _,
    swap,
    { rw presieve.mem_of_arrows_iff, use [a, rfl], simp },
    specialize h α B X f surj y _,
    { intros a b Z g₁ g₂ hh,
      dsimp [presieve.family_of_elements.compatible] at hx,
      apply hx,
      assumption },
    convert h,
    ext t,
    split,
    { intro hh,
      intros a,
      apply hh },
    { intros hh Y g hg,
      rw presieve.mem_of_arrows_iff at hg,
      obtain ⟨u,rfl,rfl⟩ := hg,
      simp [hh] } },
  { introsI h α _ B X f surj x compat,
    let R : presieve B := presieve.of_arrows X f,
    have hR : R ∈ proetale_pretopology B := ⟨α, infer_instance, X, f, surj, rfl⟩,
    have hhh : ∀ ⦃Y⦄ (g : Y ⟶ B) (hg : R g), ∃ (a : α) (ha : Y = X a), g = eq_to_hom ha ≫ f a,
    { intros Y g hg,
      rcases hg with ⟨a⟩,
      use [a, rfl],
      simp },
    let aa : Π ⦃Y⦄ (g : Y ⟶ B) (hg : R g), α := λ Y g hg, (hhh g hg).some,
    have haa : ∀ ⦃Y⦄ (g : Y ⟶ B) (hg : R g), Y = X (aa g hg) :=
      λ Y g hg, (hhh g hg).some_spec.some,
    have haa' : ∀ ⦃Y⦄ (g : Y ⟶ B) (hg : R g), g = eq_to_hom (haa g hg) ≫ f (aa g hg) :=
      λ Y g hg, (hhh g hg).some_spec.some_spec,
    let y : R.family_of_elements P := λ Y g hg, P.map (eq_to_hom (haa g hg)).op (x (aa g hg)),
    specialize h R hR y _,
    { rintros Y₁ Y₂ Z g₁ g₂ f₁ f₂ ⟨a⟩ ⟨b⟩ hh,
      change (P.map _ ≫ P.map _) _ = (P.map _ ≫ P.map _) _,
      simp_rw [← P.map_comp, ← op_comp],
      apply compat,
      simp_rw category.assoc,
      convert hh,
      all_goals {
        symmetry,
        apply haa' } },
    convert h,
    ext t,
    split,
    { intros hh Y g hg,
      conv_lhs { rw haa' g hg },
      dsimp [y],
      simp [hh] },
    { intros hh a,
      have : R (f a),
      { dsimp [R],
        rw presieve.mem_of_arrows_iff,
        use [a, rfl],
        simp },
      rw hh (f a) this,
      dsimp [y],
      specialize compat (aa (f a) this) a (X a) (eq_to_hom _) (𝟙 _) _,
      { apply haa },
      rw category.id_comp,
      apply (haa' _ _).symm,
      simpa using compat } }
end

theorem is_proetale_sheaf_of_types_pullback_iff :
  P.is_proetale_sheaf_of_types ↔ P.is_proetale_sheaf_of_types_pullback :=
begin
  split,
  { introsI h α _ B X f surj x compat,
    apply h α B X f surj x,
    intros a b Z g₁ g₂ h,
    let g : Z ⟶ limits.pullback (f a) (f b) := limits.pullback.lift _ _ h,
    rw (show g₁ = g ≫ limits.pullback.fst, by simp [g]),
    rw (show g₂ = g ≫ limits.pullback.snd, by simp [g]),
    simp only [op_comp, P.map_comp],
    dsimp,
    rw compat },
  { introsI h α _ B X f surj x compat,
    apply h α B X f surj x,
    intros a b,
    apply compat,
    exact limits.pullback.condition }
end

theorem is_proetale_sheaf_of_types_explicit_pullback_iff :
  P.is_proetale_sheaf_of_types ↔ P.is_proetale_sheaf_of_types_explicit_pullback :=
begin
  split,
  { introsI h α _ B X f surj x compat,
    apply h α B X f surj x,
    intros a b Z g₁ g₂ h,
    let g : Z ⟶ Profinite.pullback (f a) (f b) := Profinite.pullback.lift (f a) (f b) g₁ g₂ h,
    rw (show g₁ = g ≫ Profinite.pullback.fst (f a) (f b), by simp [g]),
    rw (show g₂ = g ≫ Profinite.pullback.snd (f a) (f b), by simp [g]),
    simp only [op_comp, P.map_comp],
    dsimp,
    rw compat },
  { introsI h α _ B X f surj x compat,
    apply h α B X f surj x,
    intros a b,
    apply compat,
    exact Profinite.pullback.condition _ _ }
end

theorem equalizer_condition_of_is_proetale_sheaf_of_types
  (h : P.is_proetale_sheaf_of_types) : P.equalizer_condition :=
begin
  intros X B π surj,
  rw is_proetale_sheaf_of_types_explicit_pullback_iff at h,
  specialize h punit B (λ _, X) (λ _, π) _,
  { intros b,
    use punit.star,
    apply surj },
  dsimp at h,
  split,
  { intros x y hh,
    dsimp [map_to_equalizer] at hh,
    apply_fun (λ e, e.val) at hh,
    specialize h (λ _, P.map π.op x) _,
    { intros,
      dsimp,
      change (P.map _ ≫ P.map _) _ = (P.map _ ≫ P.map _) _,
      simp_rw [← P.map_comp, ← op_comp, Profinite.pullback.condition] },
    obtain ⟨t,ht1,ht2⟩ := h,
    have hx : x = t,
    { apply ht2,
      intros,
      refl },
    have hy : y = t,
    { apply ht2,
      intros a,
      exact hh.symm },
    rw [hx, ← hy] },
  { rintros ⟨x,hx⟩,
    specialize h (λ _, x) _,
    { intros,
      exact hx },
    obtain ⟨t,ht1,ht2⟩ := h,
    use [t],
    ext1,
    exact ht1 punit.star }
end

noncomputable theory

def sigma_pi_equiv {α : Fintype.{w}} (X : α → Profinite.{w}) (h : P.finite_product_condition) :
  P.obj (op $ Profinite.sigma X) ≃ Π a, P.obj (op $ X a) :=
equiv.of_bijective _ (h α X)

def equalizer_equiv {S₁ S₂ : Profinite}
  (h : P.equalizer_condition) (f : S₁ ⟶ S₂) (surj : function.surjective f) :
  P.obj (op S₂) ≃ { x : P.obj (op S₁) |
    P.map (Profinite.pullback.fst f f).op x = P.map (Profinite.pullback.snd f f).op x } :=
equiv.of_bijective _ (h _ _ _ surj)

lemma equalizes_of_compat {α : Fintype.{w}} {B} {X : α → Profinite.{w}}
  (h : P.finite_product_condition) (f : Π a, X a ⟶ B) (x : Π a, P.obj (op $ X a))
  (compat : ∀ a b, P.map (Profinite.pullback.fst (f a) (f b)).op (x a) =
    P.map (Profinite.pullback.snd (f a) (f b)).op (x b)) :
  P.map (Profinite.pullback.fst (Profinite.sigma.desc X f) (Profinite.sigma.desc X f)).op
    ((sigma_pi_equiv P X h).symm x) =
  P.map (Profinite.pullback.snd (Profinite.sigma.desc X f) (Profinite.sigma.desc X f)).op
    ((sigma_pi_equiv P X h).symm x) :=
begin
  let I := Profinite.sigma_pullback_to_pullback_sigma X f,
  apply_fun P.map I.op,
  swap, {
    intros i j hh,
    apply_fun P.map (category_theory.inv I).op at hh,
    change (P.map _ ≫ P.map _) _ = (P.map _ ≫ P.map _) _ at hh,
    simp_rw [← P.map_comp, ← op_comp] at hh,
    simpa using hh },
  change (P.map _ ≫ P.map _) _ = (P.map _ ≫ P.map _) _,
  simp_rw [← P.map_comp, ← op_comp],
  erw Profinite.sigma_pullback_to_pullback_sigma_fst,
  erw Profinite.sigma_pullback_to_pullback_sigma_snd,
  let E := sigma_pi_equiv P X h,
  specialize h ⟨α × α⟩ (λ a, Profinite.pullback (f a.1) (f a.2)),
  let E' := equiv.of_bijective _ h,
  apply_fun E',
  ext1 ⟨a,b⟩,
  dsimp [E'],
  change (P.map _ ≫ P.map _) _ = (P.map _ ≫ P.map _) _,
  simp_rw [← P.map_comp, ← op_comp, Profinite.sigma.ι_desc],
  dsimp,
  simp_rw [P.map_comp],
  convert compat a b,
  all_goals { dsimp [coe_comp],
    congr' 1,
    change ((E ∘ E.symm) x) _ = _,
    simp },
end

theorem is_proetale_sheaf_of_finite_product_condition_of_equalizer_condition
  (h1 : P.finite_product_condition) (h2 : P.equalizer_condition) :
  P.is_proetale_sheaf_of_types :=
begin
  rw is_proetale_sheaf_of_types_explicit_pullback_iff,
  introsI α _ B X f surj x compat,
  let A : Fintype := Fintype.of α,
  change Π (x : A), _ at x,
  change Π (x : A), _ at f,
  change ∀ (a b : A), _ at compat,
  change A → _ at X,
  let E := sigma_pi_equiv P X h1,
  let F := equalizer_equiv P h2 (Profinite.sigma.desc X f)
    (Profinite.sigma.desc_surjective _ _ surj),
  let π1 := Profinite.pullback.fst (Profinite.sigma.desc X f) (Profinite.sigma.desc X f),
  let π2 := Profinite.pullback.snd (Profinite.sigma.desc X f) (Profinite.sigma.desc X f),
  let S := P.obj (op $ Profinite.sigma X),
  let x' : { t : S | P.map π1.op t = P.map π2.op t } := ⟨E.symm x, _⟩,
  swap, { exact equalizes_of_compat P h1 f x compat },
  use F.symm x',
  split,
  { dsimp,
    intros a,
    have : P.map (f a).op = ((λ u : Π a, P.obj (op $ X a), u a) ∘
      (λ u : { t : S | P.map π1.op t = P.map π2.op t }, E u.val) ∘ F),
    { ext t, dsimp [E, F, sigma_pi_equiv, equalizer_equiv, map_to_equalizer],
      change _ = (P.map _ ≫ P.map _) _,
      simp_rw [← P.map_comp, ← op_comp, Profinite.sigma.ι_desc] },
    rw this,
    change ((λ u : Π a, P.obj (op $ X a), u a) ∘
      (λ u : { t : S | P.map π1.op t = P.map π2.op t }, E u.val) ∘ F ∘ F.symm) x' = _,
    simp },
  { intros y hy,
    apply_fun F,
    change _ = (F ∘ F.symm) x',
    simp only [equiv.self_comp_symm, id.def],
    ext1,
    apply_fun E,
    change _ = (E ∘ E.symm) _,
    simp only [equiv.self_comp_symm, id.def],
    dsimp [E,F, sigma_pi_equiv, equalizer_equiv, map_to_equalizer],
    ext a,
    change (P.map _ ≫ P.map _) _ = _,
    simp_rw [← P.map_comp, ← op_comp, Profinite.sigma.ι_desc, hy a] }
end

theorem is_proetale_sheaf_of_types_tfae :
  [ presieve.is_sheaf proetale_topology P
  , P.is_proetale_sheaf_of_types
  , P.is_proetale_sheaf_of_types_pullback
  , P.is_proetale_sheaf_of_types_explicit_pullback
  , P.finite_product_condition ∧ P.equalizer_condition
  , P.empty_condition ∧ P.product_condition ∧ P.equalizer_condition
  ].tfae :=
begin
  tfae_have : 1 ↔ 2, { exact P.is_proetale_sheaf_of_types_iff.symm },
  tfae_have : 2 ↔ 3, { exact P.is_proetale_sheaf_of_types_pullback_iff },
  tfae_have : 2 ↔ 4, { exact P.is_proetale_sheaf_of_types_explicit_pullback_iff },
  tfae_have : 2 → 5, {
    intros h,
    split,
    { exact finite_product_condition_of_is_proetale_sheaf_of_types _ h },
    { exact equalizer_condition_of_is_proetale_sheaf_of_types _ h } },
  tfae_have : 5 → 2, {
    rintros ⟨h1,h2⟩,
    apply is_proetale_sheaf_of_finite_product_condition_of_equalizer_condition,
    assumption' },
  tfae_have : 5 ↔ 6, {
    rw finite_product_condition_iff_empty_product,
    rw and_assoc },
  tfae_finish
end

def is_proetale_sheaf : Prop := ∀
-- a finite family of morphisms with base B
(α : Type w) [fintype α] (B : Profinite.{w}) (X : α → Profinite.{w}) (f : Π a, X a ⟶ B)
-- jointly surjective
(surj : ∀ b : B, ∃ a (x : X a), f a x = b)
-- test object
(T : C)
-- family of moprhisms
(x : Π a, T ⟶ Q.obj (op (X a)))
-- which is compatible
(compat : ∀ (a b : α) (Z : Profinite.{w}) (g₁ : Z ⟶ X a) (g₂ : Z ⟶ X b),
  (g₁ ≫ f a = g₂ ≫ f b) → x a ≫ Q.map g₁.op = x b ≫ Q.map g₂.op),
-- the actual condition
∃! t : T ⟶ Q.obj (op B), ∀ a : α, t ≫ Q.map (f a).op = x a

def is_proetale_sheaf_pullback : Prop := ∀
-- a finite family of morphisms with base B
(α : Type w) [fintype α] (B : Profinite.{w}) (X : α → Profinite.{w}) (f : Π a, X a ⟶ B)
-- jointly surjective
(surj : ∀ b : B, ∃ a (x : X a), f a x = b)
-- test object
(T : C)
-- family of moprhisms
(x : Π a, T ⟶ Q.obj (op (X a)))
-- which is compatible
(compat : ∀ (a b : α), x a ≫ Q.map (limits.pullback.fst : limits.pullback (f a) (f b) ⟶ _).op =
  x b ≫ Q.map limits.pullback.snd.op),
-- the actual condition
∃! t : T ⟶ Q.obj (op B), ∀ a : α, t ≫ Q.map (f a).op = x a

theorem is_proetale_sheaf_pullback_iff : Q.is_proetale_sheaf ↔ Q.is_proetale_sheaf_pullback :=
begin
  split,
  { introsI h α _ B X f surj T x compat,
    apply h α B X f surj T x,
    intros a b Z g₁ g₂ h,
    specialize compat a b,
    let g : Z ⟶ limits.pullback (f a) (f b) := limits.pullback.lift g₁ g₂ h,
    rw (show g₁ = g ≫ limits.pullback.fst, by simp [g]),
    rw (show g₂ = g ≫ limits.pullback.snd, by simp [g]),
    simp only [op_comp, Q.map_comp, reassoc_of compat] },
  { introsI h α _ B X f surj T x compat,
    apply h α B X f surj T x,
    intros a b,
    apply compat,
    exact limits.pullback.condition }
end

theorem is_proetale_sheaf_iff : Q.is_proetale_sheaf ↔ presheaf.is_sheaf proetale_topology Q :=
begin
  split,
  { intros h T,
    rw ← (Q ⋙ coyoneda.obj (op T)).is_proetale_sheaf_of_types_iff,
    introsI α _ B X f surj x compat,
    exact h α B X f surj T x compat },
  { introsI h α _ B X f surj T x compat,
    specialize h T,
    rw ← (Q ⋙ coyoneda.obj (op T)).is_proetale_sheaf_of_types_iff at h,
    exact h α B X f surj x compat }
end

def empty_condition' [limits.has_terminal C] : Prop :=
  is_iso (limits.terminal.from (Q.obj (op Profinite.empty)))

def product_condition' [limits.has_binary_products C] : Prop := ∀ (X Y : Profinite.{w}),
  is_iso (limits.prod.lift (Q.map (Profinite.sum.inl X Y).op) (Q.map (Profinite.sum.inr X Y).op))

def map_to_equalizer' [limits.has_equalizers C] {X Y Z : Profinite.{w}} (f : Y ⟶ X)
  (g₁ g₂ : Z ⟶ Y) (w : g₁ ≫ f = g₂ ≫ f) : Q.obj (op X) ⟶
  limits.equalizer (Q.map g₁.op) (Q.map g₂.op) :=
limits.equalizer.lift (Q.map f.op) begin
  simp only [← Q.map_comp, ← op_comp, w]
end

def equalizer_condition' [limits.has_equalizers C] : Prop := ∀ (X Y : Profinite.{w})
  (f : X ⟶ Y) (hf : function.surjective f),
  is_iso (Q.map_to_equalizer' f (Profinite.pullback.fst f f) (Profinite.pullback.snd f f)
    (Profinite.pullback.condition _ _))

lemma empty_of_empty_coyoneda [limits.has_terminal C] :
  (∀ X : C, (Q ⋙ coyoneda.obj (op X)).empty_condition) → Q.empty_condition' :=
begin
  intro h,
  have hh := h (⊤_ C),
  have hh' := h (Q.obj (op $ Profinite.empty)),
  let P := Q ⋙ coyoneda.obj (op $ Q.obj (op $ Profinite.empty)),
  rcases hh with ⟨h1,h2⟩,
  rcases hh' with ⟨h1',h2'⟩,
  dsimp [empty_condition'],
  obtain ⟨f,-⟩ := h2 punit.star,
  use f,
  simp only [and_true, eq_iff_true_of_subsingleton],
  apply h1',
  simp
end

lemma empty_coyoneda_of_empty [limits.has_terminal C] :
  Q.empty_condition' → (∀ X : C, (Q ⋙ coyoneda.obj (op X)).empty_condition) :=
begin
  intros h X,
  let e := limits.terminal.from (Q.obj (op $ Profinite.empty)),
  change is_iso e at h,
  resetI,
  split,
  { rintros f g -,
    dsimp [coyoneda, empty_condition'] at f g,
    suffices : f ≫ e = g ≫ e, {
      apply_fun (λ t, t ≫ category_theory.inv e) at this,
      simp_rw [category.assoc] at this,
      simpa only [category.comp_id, is_iso.hom_inv_id] using this },
    simp only [eq_iff_true_of_subsingleton] },
  { rintros a,
    dsimp [coyoneda],
    use limits.terminal.from X ≫ category_theory.inv e,
    simp }
end

lemma product_of_product_coyoneda [limits.has_binary_products C] :
  (∀ X : C, (Q ⋙ coyoneda.obj (op X)).product_condition) → Q.product_condition' :=
begin
  intro h,
  intros X Y,
  have hh := h (Q.obj (op X) ⨯ Q.obj (op Y)),
  have hh' := h (Q.obj (op $ Profinite.sum X Y)),
  let P1 := Q ⋙ coyoneda.obj (op $ Q.obj (op X) ⨯ Q.obj (op Y)),
  let P2 := Q ⋙ coyoneda.obj (op $ Q.obj (op $ Profinite.sum X Y)),
  specialize hh X Y,
  specialize hh' X Y,
  dsimp [P1,P2, coyoneda] at hh hh',
  rcases hh with ⟨-,hh⟩,
  rcases hh' with ⟨hh',-⟩,
  obtain ⟨f,hf⟩ := hh ⟨limits.prod.fst, limits.prod.snd⟩,
  use f,
  dsimp at *,
  simp only [prod.mk.inj_iff] at hf,
  cases hf with hf1 hf2,
  simp only [hf1, hf2, and_true, limits.prod.comp_lift,
    limits.prod.lift_fst_snd, eq_self_iff_true],
  apply hh',
  simp [hf1,hf2]
end

lemma product_coyoneda_of_product [limits.has_binary_products C] :
  Q.product_condition' → (∀ X : C, (Q ⋙ coyoneda.obj (op X)).product_condition) :=
begin
  intros h X A B,
  specialize h A B,
  let e := limits.prod.lift (Q.map (Profinite.sum.inl A B).op) (Q.map (Profinite.sum.inr A B).op),
  change is_iso e at h,
  resetI,
  split,
  { intros f g hh,
    dsimp at f g hh,
    simp only [prod.mk.inj_iff] at hh,
    rcases hh with ⟨hl,hr⟩,
    suffices : f ≫ e = g ≫ e,
    { apply_fun (λ t, t ≫ category_theory.inv e) at this,
      simp_rw category.assoc at this,
      simpa using this },
    apply limits.prod.hom_ext,
    { simp [hl] },
    { simp [hr] } },
  { rintros ⟨a,b⟩,
    dsimp at a b ⊢,
    use limits.prod.lift a b ≫ category_theory.inv e,
    have ha : category_theory.inv e ≫ Q.map (Profinite.sum.inl A B).op = limits.prod.fst,
    { simp [is_iso.inv_comp_eq,e] },
    have hb : category_theory.inv e ≫ Q.map (Profinite.sum.inr A B).op = limits.prod.snd,
    { simp [is_iso.inv_comp_eq,e] },
    simp [ha,hb] }
end

lemma equalizer_of_equalizer_coyoneda [limits.has_equalizers C] :
  (∀ X : C, (Q ⋙ coyoneda.obj (op X)).equalizer_condition) → Q.equalizer_condition' :=
begin
  intros h X B f hf,
  let h1 := h (Q.obj (opposite.op B)) X B f hf,
  let π1 := Profinite.pullback.fst f f,
  let π2 := Profinite.pullback.snd f f,
  let h2 := h (limits.equalizer (Q.map π1.op) (Q.map π2.op)) X B f hf,
  dsimp [map_to_equalizer] at h1 h2,
  obtain ⟨e,he⟩ := h2.2 ⟨limits.equalizer.ι _ _, _⟩,
  swap, { dsimp [π1,π2], simp [limits.equalizer.condition] },
  use e,
  dsimp [map_to_equalizer'] at *,
  simp at he,
  split,
  { apply h1.1,
    simp [he] },
  { apply limits.equalizer.hom_ext, simp [he], }
end

lemma equalizer_coyoneda_of_equalizer [limits.has_equalizers C] :
  Q.equalizer_condition' → (∀ X : C, (Q ⋙ coyoneda.obj (op X)).equalizer_condition) :=
begin
  intros h X A B f hf,
  specialize h A B f hf,
  let e := Q.map_to_equalizer' f (Profinite.pullback.fst f f) (Profinite.pullback.snd f f)
    (Profinite.pullback.condition _ _),
  change is_iso e at h,
  resetI,
  split,
  { intros a b hh,
    dsimp [map_to_equalizer] at a b hh,
    simp at hh,
    suffices : a ≫ e = b ≫ e, {
      apply_fun (λ t, t ≫ category_theory.inv e) at this,
      simp_rw [category.assoc] at this,
      simpa using this },
    apply limits.equalizer.hom_ext,
    simpa [e, map_to_equalizer'] },
  { rintros ⟨a,ha⟩,
    dsimp at a ha,
    use limits.equalizer.lift a ha ≫ category_theory.inv e,
    have : category_theory.inv e ≫ Q.map f.op = limits.equalizer.ι _ _,
    { simp [e,is_iso.comp_inv_eq, map_to_equalizer'] },
    simp [map_to_equalizer, this] }
end

theorem is_proetale_sheaf_of_empty_of_product_of_equalizer
  [limits.has_terminal C] [limits.has_binary_products C] [limits.has_equalizers C] :
  Q.empty_condition' ∧ Q.product_condition' ∧ Q.equalizer_condition' → Q.is_proetale_sheaf :=
begin
  rintro ⟨h1,h2,h3⟩,
  rw is_proetale_sheaf_iff,
  intros X,
  rw (Q ⋙ coyoneda.obj (op X)).is_proetale_sheaf_of_types_tfae.out 0 5,
  refine ⟨_,_,_⟩,
  { apply empty_coyoneda_of_empty, exact h1 },
  { apply product_coyoneda_of_product, exact h2 },
  { apply equalizer_coyoneda_of_equalizer, exact h3 }
end

theorem is_proetale_sheaf_tfae [limits.has_terminal C] [limits.has_binary_products C]
  [limits.has_equalizers C] :
  [ presheaf.is_sheaf proetale_topology Q,
    Q.is_proetale_sheaf,
    Q.is_proetale_sheaf_pullback,
    Q.empty_condition' ∧ Q.product_condition' ∧ Q.equalizer_condition'
  ].tfae :=
begin
  tfae_have : 1 ↔ 2, { exact Q.is_proetale_sheaf_iff.symm },
  tfae_have : 2 ↔ 3, { exact Q.is_proetale_sheaf_pullback_iff },
  tfae_have : 1 → 4,
  { intros h,
    refine ⟨_,_,_⟩,
    { apply empty_of_empty_coyoneda,
      intros X,
      specialize h X,
      rw (Q ⋙ coyoneda.obj (op X)).is_proetale_sheaf_of_types_tfae.out 0 5 at h,
      exact h.1 },
    { apply product_of_product_coyoneda,
      intros X,
      specialize h X,
      rw (Q ⋙ coyoneda.obj (op X)).is_proetale_sheaf_of_types_tfae.out 0 5 at h,
      exact h.2.1 },
    { apply equalizer_of_equalizer_coyoneda,
      intros X,
      specialize h X,
      rw (Q ⋙ coyoneda.obj (op X)).is_proetale_sheaf_of_types_tfae.out 0 5 at h,
      exact h.2.2 } },
  tfae_have : 4 → 1,
  { intros h X,
    rw (Q ⋙ coyoneda.obj (op X)).is_proetale_sheaf_of_types_tfae.out 0 5,
    refine ⟨_,_,_⟩,
    { apply empty_coyoneda_of_empty, exact h.1 },
    { apply product_coyoneda_of_product, exact h.2.1 },
    { apply equalizer_coyoneda_of_equalizer, exact h.2.2 } },
  tfae_finish
end

end category_theory.functor


/-
Copyright (c) 2021 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Meta.Transform
import Lean.Meta.Tactic.Injection
import Lean.Meta.Tactic.Apply
import Lean.Meta.Tactic.Cases
import Lean.Meta.Tactic.Subst
import Lean.Meta.Tactic.Simp.Types
import Lean.Meta.Tactic.Assumption

namespace Lean.Meta

private def mkAnd? (args : Array Expr) : Option Expr := do
  if args.isEmpty then
    return none
  else
    let mut result := args.back
    for arg in args.reverse[1:] do
      result := mkApp2 (mkConst ``And) arg result
    return result

def elimOptParam (type : Expr) : CoreM Expr := do
  Core.transform type fun e =>
    if e.isAppOfArity  ``optParam 2 then
      return TransformStep.visit (e.getArg! 0)
    else
      return TransformStep.visit e

private partial def mkInjectiveTheoremTypeCore? (ctorVal : ConstructorVal) (useEq : Bool) : MetaM (Option Expr) := do
  let us := ctorVal.levelParams.map mkLevelParam
  let type ← elimOptParam ctorVal.type
  forallBoundedTelescope type ctorVal.numParams fun params type =>
  forallTelescope type fun args1 resultType => do
    let jp (args2 args2New : Array Expr) : MetaM (Option Expr) := do
      let lhs := mkAppN (mkAppN (mkConst ctorVal.name us) params) args1
      let rhs := mkAppN (mkAppN (mkConst ctorVal.name us) params) args2
      let eq ← mkEq lhs rhs
      let mut eqs := #[]
      for arg1 in args1, arg2 in args2 do
        let arg1Type ← inferType arg1
        if !(← isProp arg1Type) && arg1 != arg2 then
          if (← isDefEq arg1Type (← inferType arg2)) then
            eqs := eqs.push (← mkEq arg1 arg2)
          else
            eqs := eqs.push (← mkHEq arg1 arg2)
      if let some andEqs ← mkAnd? eqs then
        let result ←
          if useEq then
            mkEq eq andEqs
          else
            mkArrow eq andEqs
        mkForallFVars params (← mkForallFVars args1 (← mkForallFVars args2New result))
      else
        return none
    let rec mkArgs2 (i : Nat) (type : Expr) (args2 args2New : Array Expr) : MetaM (Option Expr) := do
      if h : i < args1.size then
        match (← whnf type) with
        | Expr.forallE n d b _ =>
          let arg1 := args1.get ⟨i, h⟩
          if arg1.occurs resultType then
            mkArgs2 (i + 1) (b.instantiate1 arg1) (args2.push arg1) args2New
          else
            withLocalDecl n (if useEq then BinderInfo.default else BinderInfo.implicit) d fun arg2 =>
              mkArgs2 (i + 1) (b.instantiate1 arg2) (args2.push arg2) (args2New.push arg2)
        | _ => throwError "unexpected constructor type for '{ctorVal.name}'"
      else
        jp args2 args2New
    if useEq then
      mkArgs2 0 type #[] #[]
    else
      withNewBinderInfos (params.map fun param => (param.fvarId!, BinderInfo.implicit)) <|
      withNewBinderInfos (args1.map fun arg1 => (arg1.fvarId!, BinderInfo.implicit)) <|
        mkArgs2 0 type #[] #[]

private def mkInjectiveTheoremType? (ctorVal : ConstructorVal) : MetaM (Option Expr) :=
  mkInjectiveTheoremTypeCore? ctorVal false

private def injTheoremFailureHeader (ctorName : Name) : MessageData :=
  m!"failed to prove injectivity theorem for constructor '{ctorName}', use 'set_option genInjectivity false' to disable the generation"

private def throwInjectiveTheoremFailure {α} (ctorName : Name) (mvarId : MVarId) : MetaM α :=
  throwError "{injTheoremFailureHeader ctorName}{indentD <| MessageData.ofGoal mvarId}"

private def solveEqOfCtorEq (ctorName : Name) (mvarId : MVarId) (h : FVarId) : MetaM Unit := do
  match (← injection mvarId h) with
  | InjectionResult.solved => unreachable!
  | InjectionResult.subgoal mvarId .. =>
    (← splitAnd mvarId).forM fun mvarId =>
      unless (← assumptionCore mvarId) do
        throwInjectiveTheoremFailure ctorName mvarId

private def mkInjectiveTheoremValue (ctorName : Name) (targetType : Expr) : MetaM Expr :=
  forallTelescopeReducing targetType fun xs type => do
    let mvar ← mkFreshExprSyntheticOpaqueMVar type
    solveEqOfCtorEq ctorName mvar.mvarId! xs.back.fvarId!
    mkLambdaFVars xs mvar

def mkInjectiveTheoremNameFor (ctorName : Name) : Name :=
  ctorName ++ `inj

private def mkInjectiveTheorem (ctorVal : ConstructorVal) : MetaM Unit := do
  let some type ← mkInjectiveTheoremType? ctorVal
    | return ()
  let value ← mkInjectiveTheoremValue ctorVal.name type
  addDecl <| Declaration.thmDecl {
    name        := mkInjectiveTheoremNameFor ctorVal.name
    levelParams := ctorVal.levelParams
    type        := (← instantiateMVars type)
    value       := (← instantiateMVars value)
  }

def mkInjectiveEqTheoremNameFor (ctorName : Name) : Name :=
  ctorName ++ `injEq

private def mkInjectiveEqTheoremType? (ctorVal : ConstructorVal) : MetaM (Option Expr) :=
  mkInjectiveTheoremTypeCore? ctorVal true

private def mkInjectiveEqTheoremValue (ctorName : Name) (targetType : Expr) : MetaM Expr := do
  forallTelescopeReducing targetType fun xs type => do
    let mvar ← mkFreshExprSyntheticOpaqueMVar type
    let [mvarId₁, mvarId₂] ← apply mvar.mvarId! (mkConst ``Eq.propIntro)
      | throwError "unexpected number of subgoals when proving injective theorem for constructor '{ctorName}'"
    let (h, mvarId₁) ← intro1 mvarId₁
    let (_, mvarId₂) ← intro1 mvarId₂
    solveEqOfCtorEq ctorName mvarId₁ h
    let mvarId₂ ← casesAnd mvarId₂
    let mvarId₂ ← substEqs mvarId₂
    applyRefl mvarId₂ (injTheoremFailureHeader ctorName)
    mkLambdaFVars xs mvar

private def mkInjectiveEqTheorem (ctorVal : ConstructorVal) : MetaM Unit := do
  let some type ← mkInjectiveEqTheoremType? ctorVal
    | return ()
  let value ← mkInjectiveEqTheoremValue ctorVal.name type
  let name := mkInjectiveEqTheoremNameFor ctorVal.name
  addDecl <| Declaration.thmDecl {
    name
    levelParams := ctorVal.levelParams
    type        := (← instantiateMVars type)
    value       := (← instantiateMVars value)
  }
  addSimpLemma name (post := true) AttributeKind.global (prio := eval_prio default)

register_builtin_option genInjectivity : Bool := {
  defValue := true
  descr    := "generate injectivity theorems for inductive datatype constructors"
}

def mkInjectiveTheorems (declName : Name) : MetaM Unit := do
  if (← getEnv).contains ``Eq.propIntro && genInjectivity.get (← getOptions) &&  !(← isInductivePredicate declName) then
    let info ← getConstInfoInduct declName
    unless info.isUnsafe do
      for ctor in info.ctors do
        let ctorVal ← getConstInfoCtor ctor
        if ctorVal.numFields > 0 then
          mkInjectiveTheorem ctorVal
          mkInjectiveEqTheorem ctorVal

end Lean.Meta


-- import LACU ArchitectureDecomp

-- variables IMPLEMENTATIONS : Π (U : Component PORTS),  Impl U

-- variable CURRENT_ENVIRONMENT : EnvC LACU_with_Contract

-- def isCorrectImplementation {C : Component PORTS} (I : Impl C) (Ctr : Contract lt_eq_assertions PORTS) : Claim (Trace PORTS) :=
-- {
--   X := I,
--   P := λ σ, σ ∈ (lt_eq_assertions.sem Ctr.A) → σ ∈ (lt_eq_assertions.sem Ctr.G)
-- }

-- def isGoodEnv (E : EnvC LACU_with_Contract) : Claim (Trace PORTS) :=
-- {
--   X := E,
--   P := λ s, s ∈ (lt_eq_assertions.sem LACU_with_Contract.C.A)
-- }

-- namespace Contract

-- def strategy : Strategy (Trace PORTS) :=
-- { parent := Claim.correctDecomposition LACU_With_Subcontracts IMPLEMENTATIONS CURRENT_ENVIRONMENT,
--   decomp := λ C,
--   LACU_ARCH_MODEL.subs.map (λ C, isCorrectImplementation (IMPLEMENTATIONS C) (LACU_With_Subcontracts.contracts.find_val C).iget) ++ [isGoodEnv CURRENT_ENVIRONMENT]
--    }

-- end Contract

-- lemma subclaims_meaning_env :
--   (∀ clm ∈ (Contract.strategy IMPLEMENTATIONS CURRENT_ENVIRONMENT).subclaims, ⟦clm⟧) →
--  ⟦isGoodEnv CURRENT_ENVIRONMENT⟧ :=
-- begin
--  intros H₁,
--  replace H₁ := H₁ (isGoodEnv CURRENT_ENVIRONMENT),
--  rw Contract.strategy at H₁, rw Strategy.subclaims at H₁,
--   simp at H₁,
--   exact H₁,
-- end

-- lemma subclaims_meaning_impl :
--   (∀ clm ∈ (Contract.strategy IMPLEMENTATIONS CURRENT_ENVIRONMENT).subclaims, ⟦clm⟧) →
--  ∀ C ∈ LACU_ARCH_MODEL.subs, ⟦isCorrectImplementation (IMPLEMENTATIONS C) (LACU_With_Subcontracts.contracts.find_val C).iget⟧ :=
-- begin
--  intros H₁,
--  rw Contract.strategy at H₁, rw Strategy.subclaims at H₁,
--  simp at H₁,
--  intros C mem,
--  replace H₁ := H₁ (isCorrectImplementation (IMPLEMENTATIONS C) (Map.find_val C LACU_With_Subcontracts.contracts).iget),
--  apply H₁,
--  clear H₁,
--  left, use C,
--  split,assumption,refl,
-- end

-- lemma subclaims_meaning:
--   (∀ clm ∈ (Contract.strategy IMPLEMENTATIONS CURRENT_ENVIRONMENT).subclaims, ⟦clm⟧) →
--   ⟦isGoodEnv CURRENT_ENVIRONMENT⟧ ∧
--  ∀ C ∈ LACU_ARCH_MODEL.subs, ⟦isCorrectImplementation (IMPLEMENTATIONS C) (LACU_With_Subcontracts.contracts.find_val C).iget⟧ :=
-- begin
--   intros H₁,
--   split, apply subclaims_meaning_env, assumption,
--   apply subclaims_meaning_impl, assumption,
-- end

-- theorem validity : deductive (Trace PORTS) (Contract.strategy IMPLEMENTATIONS CURRENT_ENVIRONMENT) :=
-- begin
--   intro H,
--   replace H := subclaims_meaning _ _ H,
--   cases H with Henv Himpl,
--   rw Contract.strategy,
--   simp,
--   rw Claim.correctDecomposition,
--   rw meaning,
--   simp,
--   intros σ,
--   split, {
--     rw Claim.correctDecompositionImpl,
--     intros H₁ H₂,
--     rw CI at H₂,
--     simp at H₂,
--     sorry
--   }
-- end

-- -- theorem LACU_Decomp_Correct :
-- -- isCorrectDecomposition LACU_ARCH_MODEL IMPLEMENTATIONS CURRENT_ENVIRONMENT :=
-- -- begin
-- --   intro E,
-- --   rw isCorrectArchitecture,
-- --   split,
-- --   rw CompositeImplementation,
-- --   rw Impl.satisfiesContract,
-- --   simp,
-- --   rw set.subset_def,
-- --   simp,
-- --   intros σ σ' h₁ h₂ h₃,
-- --   rw Impl.toSet at h₁, simp at h₁,
-- -- end


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.Lean3Lib.data.dlist
import Mathlib.tactic.core
import Mathlib.PostPort

namespace Mathlib

namespace tactic

-- TODO(Simon): visit expressions built of `fn` nested inside other such expressions:

-- e.g.: x + f (a + b + c) + y should generate two rewrite candidates

namespace interactive

/--
`assoc_rewrite [h₀,← h₁] at ⊢ h₂` behaves like `rewrite [h₀,← h₁] at ⊢ h₂`
with the exception that associativity is used implicitly to make rewriting
possible.

It works for any function `f` for which an `is_associative f` instance can be found.

```
example {α : Type*} (f : α → α → α) [is_associative α f] (a b c d x : α) :
  let infix `~` := f in
  b ~ c = x → (a ~ b ~ c ~ d) = (a ~ x ~ d) :=
begin
  intro h,
  assoc_rw h,
end
```
-/
/-- synonym for `assoc_rewrite` -/
end Mathlib