import category_theory.preadditive.basic
import category_theory.abelian.exact
import algebra.homology.exact
import category_theory.limits.preserves.shapes.terminal
import category_theory.limits.shapes.zero_morphisms

namespace category_theory
namespace limits

open category_theory.limits

variables {C : Type*} [category C] [has_zero_morphisms C]

open_locale zero_object

lemma is_zero_iff_id_eq_zero {X : C} : is_zero X ↔ 𝟙 X = 0 :=
begin
  split,
  { exact λ h, h.eq_of_src _ _, },
  { intro e, split; intro Y; use 0; intro f,
    { rw [← cancel_epi (𝟙 _), e, comp_zero, zero_comp], apply_instance },
    { rw [← cancel_mono (𝟙 _), e, comp_zero, zero_comp], apply_instance }, }
end

lemma is_zero_of_mono {X Y : C} (f : X ⟶ Y) [mono f] (h : is_zero Y) : is_zero X :=
by rw [is_zero_iff_id_eq_zero, ← cancel_mono f, zero_comp, h.eq_of_tgt (𝟙 _ ≫ f)]

lemma is_zero_of_epi {X Y : C} (f : X ⟶ Y) [epi f] (h : is_zero X) : is_zero Y :=
by rw [is_zero_iff_id_eq_zero, ← cancel_epi f, comp_zero, h.eq_of_src (f ≫ 𝟙 Y)]

lemma is_zero_of_top_le_bot [has_zero_object C] (X : C)
  (h : (⊤ : subobject X) ≤ ⊥) : is_zero X :=
{ unique_to := λ Y,
  begin
    use 0, intro f,
    rw [← cancel_epi ((⊤ : subobject X).arrow), ← subobject.of_le_arrow h],
    simp only [subobject.bot_arrow, comp_zero, zero_comp],
  end,
  unique_from := λ Y,
  begin
    use 0, intro f,
    rw ← subobject.bot_factors_iff_zero,
    exact subobject.factors_of_le f h (subobject.top_factors f),
  end }

-- inline this
lemma is_zero_of_iso_of_zero {C : Type*} [category C] [has_zero_morphisms C]
  {X : C} (hX : is_zero X) {Y : C} (h : X ≅ Y) : is_zero Y :=
hX.of_iso h.symm

lemma is_zero_of_exact_zero_zero {C : Type*} [category C] [abelian C]
  {X Y Z : C} (h : exact (0 : X ⟶ Y) (0 : Y ⟶ Z)) : is_zero Y :=
is_zero_of_top_le_bot _
begin
  rw abelian.exact_iff_image_eq_kernel at h,
  rw [← @kernel_subobject_zero _ _ _ Y Z, ← @image_subobject_zero _ _ _ _ X Y, h],
end

lemma exact_of_is_zero {C : Type*} [category C] [abelian C]
  {X Y Z : C} (hY : is_zero Y) (f : X ⟶ Y) (g : Y ⟶ Z) : exact f g :=
by simp only [abelian.exact_iff, is_zero.eq_zero_of_tgt hY f,
  is_zero.eq_zero_of_tgt hY (kernel.ι g), zero_comp, eq_self_iff_true, and_self]

lemma is_zero_iff_exact_zero_zero {C : Type*} [category C] [abelian C]
  {X Y Z : C} : is_zero Y ↔ exact (0 : X ⟶ Y) (0 : Y ⟶ Z) :=
⟨λ h, exact_of_is_zero h 0 0, is_zero_of_exact_zero_zero⟩

lemma is_zero_of_exact_zero_zero' {C : Type*} [category C] [abelian C]
  {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) (h : exact f g) (hf : f = 0) (hg : g = 0) : is_zero Y :=
by { rw [hf, hg] at h, exact is_zero_of_exact_zero_zero h }

lemma is_zero_of_exact_is_zero_is_zero {C : Type*} [category C] [abelian C] {X Y Z : C}
  (f : X ⟶ Y) (g : Y ⟶ Z) (h : exact f g) (hX : is_zero X) (hZ : is_zero Z) : is_zero Y :=
is_zero_of_exact_zero_zero' f g h (hX.eq_of_src f _) (hZ.eq_of_tgt g _)

lemma is_zero_cokernel_of_epi {C : Type*} [category C] [abelian C] {X Y : C}
  (f : X ⟶ Y) [epi f] : is_zero (cokernel f) :=
begin
  have h1 : cokernel.π f = 0, by rwa ← abelian.epi_iff_cokernel_π_eq_zero,
  have h2 : exact (cokernel.π f) 0 := category_theory.exact_epi_zero (cokernel.π f),
  exact is_zero_of_exact_zero_zero' (cokernel.π f) 0 h2 h1 rfl,
end

lemma epi_iff_is_zero_cokernel {C : Type*} [category C] [abelian C] {X Y : C}
  (f : X ⟶ Y) : epi f ↔ is_zero (cokernel f) :=
begin
  split,
  { introsI, apply is_zero_cokernel_of_epi },
  { intros h,
    rw abelian.epi_iff_cokernel_π_eq_zero,
    apply h.eq_of_tgt }
end

lemma is_zero_kernel_of_mono {C : Type*} [category C] [abelian C] {X Y : C}
  (f : X ⟶ Y) [mono f] : is_zero (kernel f) :=
begin
  have h1 : kernel.ι f = 0, by rwa ← abelian.mono_iff_kernel_ι_eq_zero,
  have h2 : exact 0 (kernel.ι f) := category_theory.exact_zero_mono (kernel.ι f),
  exact is_zero_of_exact_zero_zero' 0 (kernel.ι f) h2 rfl h1
end

lemma mono_iff_is_zero_kernel {C : Type*} [category C] [abelian C] {X Y : C}
  (f : X ⟶ Y) : mono f ↔ is_zero (kernel f) :=
begin
  split,
  { introsI, apply is_zero_kernel_of_mono },
  { intros h,
    rw abelian.mono_iff_kernel_ι_eq_zero,
    apply h.eq_of_src }
end

noncomputable def image_iso_of_eq [category C] [abelian C] {A B : C} {f f' : A ⟶ B} (h : f = f') : image f ≅ image f' :=
eq_to_iso (by rw h)

noncomputable def image.is_iso_comp {𝓐 : Type*} [category 𝓐] [abelian 𝓐] {A B C : 𝓐} {f : A ⟶ B} [is_iso f] (g : B ⟶ C) : image (f ≫ g) ≅ image g :=
{ hom := image.lift (({ I := _,
  m := image.ι _,
  m_mono := infer_instance,
  e := f ≫ factor_thru_image g,
  fac' := by simp only [category.assoc, image.fac]} : mono_factorisation _)),
  inv := image.lift (({ I := _,
  m := image.ι _,
  m_mono := infer_instance,
  e := (inv f) ≫ factor_thru_image (f ≫ g),
  fac' := by simp only [category.assoc, image.fac, is_iso.inv_hom_id_assoc]} : mono_factorisation _)) }

lemma is_iso_of_is_zero_of_is_zero {𝓐 : Type*} [category 𝓐] [abelian 𝓐] {a b : 𝓐} (ha : is_zero a) (hb : is_zero b)
  (f : a ⟶ b) : is_iso f :=
begin
  rw is_zero.eq_zero_of_src ha f,
  apply (is_iso_zero_equiv a b).symm.to_fun,
  exact ⟨is_zero.eq_of_src ha (𝟙 a) 0, is_zero.eq_of_src hb (𝟙 b) 0⟩,
end

lemma obj_is_zero_of_iso {𝓐 : Type*} [category 𝓐] [abelian 𝓐] {𝓑 : Type*} [category 𝓑] [abelian 𝓑] {F G : 𝓐 ⥤ 𝓑}
  (h : F ≅ G) {a : 𝓐} (ha : is_zero (F.obj a)) : is_zero (G.obj a) :=
is_zero_of_iso_of_zero ha (h.app a)

lemma map_is_iso_of_iso_of_map_is_iso {𝓐 : Type*} [category 𝓐] [abelian 𝓐] {𝓑 : Type*} [category 𝓑] [abelian 𝓑] {F G : 𝓐 ⥤ 𝓑}
  (h : F ≅ G) {a₁ a₂ : 𝓐} (f : a₁ ⟶ a₂) (ha : is_iso (F.map f)) : is_iso (G.map f) :=
begin
  rw ← nat_iso.naturality_1 h,
  exact is_iso.comp_is_iso,
end

@[simp] lemma epi_comp_iso_iff_epi {V : Type*} [category V] {A B C : V} (e : A ≅ B) (f : B ⟶ C) :
  epi (e.hom ≫ f) ↔ epi f :=
begin
  split,
  { rintro ⟨h⟩,
    constructor,
    intros Z s t h2,
    apply h,
    simp [h2], },
  { rintro ⟨h⟩,
    constructor,
    intros Z s t h2,
    apply h,
    simpa using h2,
  },
end

@[simp] lemma epi_iso_comp_iff_epi {V : Type*} [category V] {A B C : V} (f : A ⟶ B) (e : B ≅ C) :
  epi (f ≫ e.hom) ↔ epi f :=
begin
  split,
  { introI h,
    constructor,
    intros Z s t h2,
    suffices : e.inv ≫ s = e.inv ≫ t,
      simpa,
    rw ← cancel_epi (f ≫ e.hom),
    simpa using h2, },
  { introI h,
    constructor,
    intros Z s t h2,
    simp only [category.assoc] at h2,
    rw cancel_epi at h2,
    rwa cancel_epi at h2, },
end

lemma is_iso_iff_is_iso_comp_left {V : Type*} [category V] {A B C : V} (f : A ⟶ B) {e : B ⟶ C}
  [is_iso f] : is_iso (f ≫ e) ↔ is_iso e :=
begin
  split,
  { introI h, exact is_iso.of_is_iso_comp_left f e },
  { introI h, exact is_iso.comp_is_iso },
end

lemma is_iso_iff_is_iso_comp_right {V : Type*} [category V] {A B C : V} {f : A ⟶ B} (g : B ⟶ C)
  [is_iso g] : is_iso (f ≫ g) ↔ is_iso f :=
begin
  split,
  { introI, exact is_iso.of_is_iso_comp_right f g},
  { introI h, exact is_iso_of_op (f ≫ g), },
end

@[simp] lemma epi_comp_is_iso_iff_epi {V : Type*} [category V] {A B C : V} (e : A ⟶ B) (f : B ⟶ C)
  [is_iso e] : epi (e ≫ f) ↔ epi f :=
epi_comp_iso_iff_epi (as_iso e) f

@[simp] lemma epi_is_iso_comp_iff_epi {V : Type*} [category V] {A B C : V} (f : A ⟶ B) (e : B ⟶ C)
  [is_iso e] : epi (f ≫ e) ↔ epi f :=
epi_iso_comp_iff_epi f (as_iso e)

lemma zero_of_epi_comp_zero {V : Type*} [category V] [abelian V]
  {A B C : V} {f : A ⟶ B} {g : B ⟶ C} (w : f ≫ g = 0) [epi f] : g = 0 :=
(preadditive.epi_iff_cancel_zero f).mp infer_instance C g w

@[simp] lemma comp_mono_zero_iff {V : Type*} [category V] [abelian V]
  {A B C : V} {f : A ⟶ B} {g : B ⟶ C} [mono g] : f ≫ g = 0 ↔ f = 0 :=
⟨(preadditive.mono_iff_cancel_zero g).1 infer_instance A f, λ f, f.symm ▸ zero_comp⟩

lemma epi_of_epi_of_comp_epi_of_mono {V : Type*} [category V] [abelian V]
  {A B C : V} (f : A ⟶ B) (g : B ⟶ C) [epi (f ≫ g)] [mono g] : epi f :=
begin
  haveI foo : is_iso g,
  { rw is_iso_iff_mono_and_epi,
    refine ⟨infer_instance, _⟩,
    apply epi_of_epi f,
  },
  simp * at *,
end

lemma is_zero_initial {C : Type*} [category C] [abelian C] : is_zero (⊥_ C) :=
is_zero_of_iso_of_zero (is_zero_zero _) $
{ hom := 0,
  inv := 0 }

lemma is_zero_terminal {C : Type*} [category C] [abelian C] : is_zero (⊤_ C) :=
is_zero_of_iso_of_zero (is_zero_zero _) $
{ hom := 0,
  inv := 0 }

universes v u₁ u₂

class preserves_zero_objects {C D : Type*} [category C] [has_zero_morphisms C]
  [category D] [has_zero_morphisms D] (F : C ⥤ D) : Prop :=
(preserves : ∀ (X : C), is_zero X → is_zero (F.obj X))

instance preserves_zero_of_preserves_initial {C : Type u₁} {D : Type u₂}
  [category.{v} C] [abelian C] [category.{v} D] [abelian D] (F : C ⥤ D)
  [preserves_colimit (functor.empty C) F] :
  preserves_zero_objects F := preserves_zero_objects.mk $ λ X hX,
begin
  have e : X ≅ ⊥_ _ := hX.iso is_zero_initial,
  replace e : F.obj X ≅ F.obj ⊥_ _ := F.map_iso e,
  apply is_zero_of_iso_of_zero _ e.symm,
  have : F.obj ⊥_ _ ≅ ⊥_ _,
  { apply_with limits.preserves_initial.iso { instances := ff }, assumption },
  apply is_zero_of_iso_of_zero _ this.symm,
  exact is_zero_initial,
end

-- sanity check
example {C : Type u₁} {D : Type u₂}
  [category.{v} C] [abelian C] [category.{v} D] [abelian D] (F : C ⥤ D)
  [preserves_colimits F] : preserves_zero_objects F := infer_instance

instance preserves_zero_of_preserves_terminal {C : Type u₁} {D : Type u₂}
  [category.{v} C] [abelian C] [category.{v} D] [abelian D] (F : C ⥤ D)
  [preserves_limit (functor.empty C) F] :
  preserves_zero_objects F := preserves_zero_objects.mk $ λ X hX,
begin
  have e : X ≅ ⊤_ _ := hX.iso is_zero_terminal,
  replace e : F.obj X ≅ F.obj ⊤_ _ := F.map_iso e,
  apply is_zero_of_iso_of_zero _ e.symm,
  have : F.obj ⊤_ _ ≅ ⊤_ _,
  { apply_with limits.preserves_terminal.iso { instances := ff }, assumption },
  apply is_zero_of_iso_of_zero _ this.symm,
  exact is_zero_terminal,
end

-- sanity check
example {C : Type u₁} {D : Type u₂}
  [category.{v} C] [abelian C] [category.{v} D] [abelian D] (F : C ⥤ D)
  [preserves_limits F] : preserves_zero_objects F := infer_instance

lemma is_zero_of_preserves {C D : Type*} [category C] [has_zero_morphisms C]
  [category D] [has_zero_morphisms D] {X : C} (F : C ⥤ D)
  [preserves_zero_objects F] (e : is_zero X) : is_zero (F.obj X) :=
preserves_zero_objects.preserves _ e

lemma is_zero_biprod {C : Type u₁} [category.{v} C] [abelian C] (X Y : C)
  (hX : is_zero X) (hY : is_zero Y) : is_zero (biprod X Y) :=
begin
  constructor,
  { intro W, use 0, intro f, ext, simp, apply hX.eq_of_src, simp, apply hY.eq_of_src },
  { intro W, use 0, intro f, ext, simp, apply hX.eq_of_tgt, simp, apply hY.eq_of_tgt }
end

end limits

end category_theory


/-
Copyright (c) 2016 Marcos Mazari. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Ideals and quotient rings.

Authors: Marcos Mazari, Jeremy Avigad
-/
import data.set algebra.ring theories.move
open function eq.ops algebra set classical

/- TODO: move -/

abbreviation contrapos := @not_imp_not_of_imp

lemma ne_of_not_mem_of_mem {A : Type} {I J : set A} {y : A} (H1 :  y ∉ I) (H2 : y ∈ J) : I ≠ J :=
by intro H; rewrite H at H1; exact H1 H2

lemma exists_mem_and_not_mem_of_not_subset {A : Type} {I J : set A} (H : ¬ J ⊆ I) :
  ∃ y, y ∈ J ∧ y ∉ I :=
obtain x (Hx : ¬ (x ∈ J → x ∈ I)), from exists_not_of_not_forall H,
exists.intro x (and_not_of_not_implies Hx)

lemma exists_mem_and_not_mem_of_ne_of_subset {A : Type} {I J : set A} (H1 : I ≠ J) (H2 : I ⊆ J) :
  ∃ y, y ∈ J ∧ y ∉ I :=
exists_mem_and_not_mem_of_not_subset (assume H, H1 (eq_of_subset_of_subset H2 H))

/- TODO: move to file for additive subgroups -/

section

variable {A : Type}

structure is_zero_closed [class] [has_zero A] (S : set A) : Prop :=
(zero_mem : zero ∈ S)

proposition zero_mem [has_zero A] {S : set A} [is_zero_closed S] : 0 ∈ S :=
is_zero_closed.zero_mem _ S

structure is_add_closed [class] [has_add A] (S : set A) : Prop :=
(add_mem : ∀₀ a ∈ S, ∀₀ b ∈ S, a + b ∈ S)

proposition add_mem [has_add A] {S : set A} [is_add_closed S] {a : A} (aS : a ∈ S) {b : A}
    (bS : b ∈ S) :
  a + b ∈ S :=
is_add_closed.add_mem _ S aS bS

structure is_neg_closed [class] [has_neg A] (S : set A) : Prop :=
(neg_mem : ∀₀ a ∈ S, -a ∈ S)

proposition neg_mem [has_neg A] {S : set A} [is_neg_closed S] {a : A} (aS : a ∈ S) : -a ∈ S :=
is_neg_closed.neg_mem _ S aS

proposition mem_of_neg_mem [add_group A] {S : set A} [is_neg_closed S] {a : A} (naS : -a ∈ S) :
  a ∈ S :=
by rewrite -neg_neg; exact neg_mem naS

proposition neg_mem_iff [add_group A] {S : set A} [is_neg_closed S] (a : A) : -a ∈ S ↔ a ∈ S :=
iff.intro mem_of_neg_mem neg_mem

proposition sub_mem_swap [add_group A] {S : set A} [is_neg_closed S] {a b : A} (H : b - a ∈ S) :
  a - b ∈ S :=
mem_of_neg_mem (by rewrite neg_sub; assumption)

proposition sub_mem_iff [add_group A] {S : set A} [is_neg_closed S] (a b : A) :
  a - b ∈ S ↔ b - a ∈ S :=
iff.intro sub_mem_swap sub_mem_swap

structure is_add_subgroup [class] [add_group A] (S : set A)
  extends is_zero_closed S, is_add_closed S, is_neg_closed S : Prop

definition set_add [has_add A] (S T : set A) : set A := {x | ∃₀ y ∈ S, ∃₀ z ∈ T, x = y + z}

end

namespace set_add
  infix + := set_add
end set_add
open set_add

section

variables {A : Type}

proposition mem_set_add [has_add A] {S T : set A} {a b c : A}
    (aS : a ∈ S) (bT : b ∈ T) (ceq : c = a + b) :
  c ∈ S + T :=
exists.intro a (and.intro aS (exists.intro b (and.intro bT ceq)))

proposition subset_set_add_right [add_monoid A] (S T : set A) [is_zero_closed T] : S ⊆ S + T :=
take a, assume aS, mem_set_add aS zero_mem (by simp)

proposition subset_set_add_left [add_monoid A] (S T : set A) [is_zero_closed S] : T ⊆ S + T :=
take a, assume aT, mem_set_add zero_mem aT (by simp)

end

section
variable {A : Type}
variable [comm_ring A]

structure is_ideal [class] (I : set A) extends is_zero_closed I, is_add_closed I : Prop :=
(mul_arb_mem : ∀ x, ∀₀ y ∈ I, x * y ∈ I)

proposition mul_arb_mem {I : set A} [is_ideal I] (x : A) {y : A} (yI : y ∈ I) : x * y ∈ I :=
is_ideal.mul_arb_mem _ I x yI

proposition is_add_subgroup_of_is_ideal [instance] (I : set A) [is_ideal I] : is_add_subgroup I :=
is_add_subgroup.mk zero_mem (@add_mem _ _ _ _)
  (λ a aI, by rewrite [neg_eq_neg_one_mul]; apply mul_arb_mem _ aI)

proposition mul_arb_mem' {I : set A} [H : is_ideal I] {x : A} (xI : x ∈ I) (y : A) : x * y ∈ I :=
by rewrite mul.comm; apply mul_arb_mem y xI

lemma eq_univ_of_one_mem_of_is_ideal {I : set A} (H : 1 ∈ I) [is_ideal I] : I = univ :=
eq_univ_of_forall (take x, have x * 1 ∈ I, from mul_arb_mem x H, by simp)

theorem is_ideal_inter ( I J : set A) (HI : is_ideal I)
  (HJ : is_ideal J) :  is_ideal (I ∩ J) :=
have H1 : 0 ∈ I ∩ J, from and.intro zero_mem zero_mem,
have H2 : ∀₀ x ∈ I ∩ J, ∀₀ y ∈ I ∩ J, x + y ∈ I ∩ J, from
  take x, assume xIJ, take y, assume yIJ,
  obtain xI xJ, from xIJ,
  obtain yI yJ, from yIJ,
  show x + y ∈ I ∩ J, from and.intro (add_mem xI yI) (add_mem xJ yJ),
have H3 : ∀ x, ∀₀ y ∈ I ∩ J, x * y ∈ I ∩ J, from
  take x y, assume yIJ,
  obtain yI yJ, from yIJ,
  show x * y ∈ I ∩ J, from and.intro (mul_arb_mem x yI)(mul_arb_mem x yJ),
show is_ideal (I ∩ J), from is_ideal.mk H1 H2 H3

theorem is_ideal_singleton_zero : is_ideal '{(0 : A)} :=
have H1 : 0 ∈ '{0}, from mem_singleton 0,
have H2 : ∀₀ x ∈ '{0}, ∀₀ y ∈ '{0}, x + y ∈ '{0}, from
  take x, assume xmem, take y, assume ymem,
  by rewrite [eq_of_mem_singleton xmem, eq_of_mem_singleton ymem, zero_add]; apply mem_singleton,
have H3 : ∀x, ∀₀ y ∈ '{0}, x * y ∈ '{0}, from
  take x y, assume ymem,
  by rewrite [eq_of_mem_singleton ymem, mul_zero]; apply mem_singleton,
is_ideal.mk H1 H2 H3

lemma is_ideal_univ : is_ideal (@univ A) :=
have H1 : 0 ∈ @univ A, from trivial,
have H2:  ∀₀ x ∈ univ, ∀₀ y ∈ univ, x + y ∈ (@univ A), from λ x xmem y ymem, trivial,
have H3 : ∀ x, ∀₀ y ∈ univ, x * y ∈ (@univ A), from λ x y ymem, trivial,
is_ideal.mk H1 H2 H3

lemma is_ideal_set_add [instance] (I J : set A) [is_ideal I] [is_ideal J] : is_ideal (I + J) :=
have H1 : 0 ∈ I + J, from
  mem_set_add zero_mem zero_mem (by simp),
have H2 : ∀₀ x ∈ I + J, ∀₀ y ∈ I + J, x + y ∈ I + J, from
  λ x xmem y ymem,
    obtain ix [ixI [jx [jxJ xeq]]], from xmem,
    obtain iy [iyI [jy [jyJ yeq]]], from ymem,
    show x + y ∈ I + J, from
      mem_set_add (add_mem ixI iyI) (add_mem jxJ jyJ)
        (by rewrite [xeq, yeq, *add.assoc, add.left_comm jx]),
have H3 : ∀ x, ∀₀ y ∈ I + J, x * y ∈ I + J, from
  λ x y ymem,
    obtain iy [iyI [jy [jyJ yeq]]], from ymem,
    show x * y ∈ I + J, from
      mem_set_add (mul_arb_mem x iyI) (mul_arb_mem x jyJ)
        (by rewrite [yeq, left_distrib]),
is_ideal.mk H1 H2 H3

lemma set_add_subset_of_is_ideal {S T I : set A} [is_ideal I] (SsubI : S ⊆ I) (TsubI : T ⊆ I) :
  S + T ⊆ I :=
take x, suppose x ∈ S + T,
obtain s [sS [t [tT xeq]]], from this,
have s + t ∈ I, from add_mem (SsubI sS) (TsubI tT),
show x ∈ I, by rewrite xeq; apply this

/- ideal generated by a set -/

inductive ideal_generated_by (S : set A) : A → Prop :=
| generators_mem : ∀ {x}, x ∈ S → ideal_generated_by S x
| zero_closed    : ideal_generated_by S 0
| add_closed     : ∀ {x y}, ideal_generated_by S x → ideal_generated_by S y →
                     ideal_generated_by S (x + y)
| mul_arb_closed : ∀ r {x}, ideal_generated_by S x → ideal_generated_by S (r * x)

theorem subset_ideal_generated_by (S : set A) : S ⊆ ideal_generated_by S :=
λ x xS, ideal_generated_by.generators_mem xS

theorem is_ideal_ideal_generated_by [instance] (S : set A) : is_ideal (ideal_generated_by S) :=
is_ideal.mk
  (ideal_generated_by.zero_closed S)
  (λ x xmem y ymem, ideal_generated_by.add_closed xmem ymem)
  (λ r x xmem, ideal_generated_by.mul_arb_closed r xmem)

theorem ideal_generated_by_subset {S : set A} {I : set A} [is_ideal I] (H : S ⊆ I) :
  ideal_generated_by S ⊆ I :=
begin
  intro x xiS,
  induction xiS with a ains a b aiS biS aI bI r a aiS aI,
    {exact H ains},
    {exact zero_mem},
    {exact add_mem aI bI},
  exact mul_arb_mem r aI
end

theorem ideal_generated_by_eq {S : set A} {I : set A} [is_ideal I] (SsubI : S ⊆ I)
    (H : ∀ J, is_ideal J → S ⊆ J → I ⊆ J) :
  ideal_generated_by S = I :=
eq_of_subset_of_subset
  (ideal_generated_by_subset SsubI)
  (H _ _ (subset_ideal_generated_by S))

theorem ideal_generated_by_eq_of_is_ideal {S : set A} [is_ideal S] : ideal_generated_by S = S :=
ideal_generated_by_eq (subset.refl _) (λ J iJ sJ, sJ)

definition principal_ideal (a : A) : set A := ideal_generated_by '{a}

theorem mem_principal_ideal (a : A) : a ∈ principal_ideal a :=
subset_ideal_generated_by _ (mem_singleton a)

theorem is_ideal_principal_ideal [instance] (a : A) : is_ideal (principal_ideal a) :=
is_ideal_ideal_generated_by _

theorem principal_ideal_eq (a : A) : principal_ideal a = {b | ∃ r, b = r * a} :=
have is_ideal {b | ∃ r, b = r * a}, from
  is_ideal.mk
    (exists.intro 0 (by simp))
    (λ x xmem y ymem,
      obtain r xeq, from xmem, obtain s yeq, from ymem,
      exists.intro (r + s) (by rewrite [xeq, yeq, right_distrib]))
    (λ x y ymem,
      obtain r yeq, from ymem,
      exists.intro (x * r) (by rewrite [yeq, mul.assoc])),
ideal_generated_by_eq
  (singleton_subset_of_mem (exists.intro 1 (by simp)))
  (take J, suppose is_ideal J, suppose '{a} ⊆ J,
    have a ∈ J, from mem_of_singleton_subset this,
    show {b | ∃ r, b = r * a} ⊆ J, from
      take b, suppose ∃ r, b = r * a,
      obtain r beq, from this,
      show b ∈ J, by rewrite beq; exact mul_arb_mem r `a ∈ J`)

theorem ideal_generated_by_union_eq (S T: set A) :
  ideal_generated_by (S ∪ T) = ideal_generated_by S + ideal_generated_by T :=
-- TODO: why are these needed?
have is_ideal (ideal_generated_by S + ideal_generated_by T), from is_ideal_set_add _ _,
have is_add_subgroup (ideal_generated_by T), from is_add_subgroup_of_is_ideal _,
have is_zero_closed (ideal_generated_by T), from is_add_subgroup.to_is_zero_closed _,
have is_add_subgroup (ideal_generated_by S), from is_add_subgroup_of_is_ideal _,
have is_zero_closed (ideal_generated_by S), from is_add_subgroup.to_is_zero_closed _,
ideal_generated_by_eq
  (union_subset
    (subset.trans (subset_ideal_generated_by S) (subset_set_add_right _ _))
    (subset.trans (subset_ideal_generated_by T) (subset_set_add_left _ _)))
  (take J, assume idealJ, assume JsubST,
    set_add_subset_of_is_ideal
      (ideal_generated_by_subset (subset.trans (subset_union_left _ _) JsubST))
      (ideal_generated_by_subset (subset.trans (subset_union_right _ _) JsubST)))

lemma ideal_generated_by_union_singleton (I : set A) [is_ideal I] (a : A) :
  ideal_generated_by (I ∪ '{a}) = {b | ∃₀ y ∈ I, ∃ z, b = y + z * a} :=
begin
  rewrite [ideal_generated_by_union_eq, ideal_generated_by_eq_of_is_ideal],
  xrewrite [principal_ideal_eq],
  show I + {b | ∃ r, b = r * a} = {b | ∃ x, x ∈ I ∧ ∃ z, b = x + z * a},
    from set.ext (take y, iff.intro
      (assume ymem,
        obtain x [xI [b [[r beq] xeq]]], from ymem,
        exists.intro x (and.intro xI (exists.intro r (by rewrite [xeq, beq]))))
      (assume ymem,
        obtain x [xI [z beq]], from ymem,
        mem_set_add xI (exists.intro z rfl) beq))
end

theorem exists_mul_eq_one_of_two_ideals (H : ∀ I : set A, is_ideal I → I = univ ∨ I = '{0})
    {x : A} (H1 : x ≠ 0) :
  ∃ y, x * y = 1 :=
or.elim (H (principal_ideal x) _)
  (suppose principal_ideal x = univ,
    have 1 ∈ principal_ideal x, by rewrite this; apply mem_univ,
    have ∃r, 1 = r*x, by rewrite [principal_ideal_eq x at this]; apply this,
    obtain r oneeq, from this,
     exists.intro r (by rewrite [oneeq, mul.comm]))
  (suppose principal_ideal x = '{0},
    have x ∈ '{0}, by rewrite -this; apply mem_principal_ideal x,
    have x = 0, from eq_of_mem_singleton this,
    absurd this H1)

theorem principal_ideal_subset {I : set A} [is_ideal I] {a : A} (aI : a ∈ I) :
  principal_ideal a ⊆ I :=
take x,
suppose x ∈ principal_ideal a,
have ∃ r, x = r * a, by rewrite [principal_ideal_eq at this]; apply this,
obtain r xeq, from this,
show x ∈ I, by rewrite xeq; apply mul_arb_mem r aI

theorem exists_mem_and_ne_zero_of_is_ideal {I : set A} [is_ideal I] (H : I ≠ '{0}) :
  ∃ y, y ∈ I ∧ y ≠ 0 :=
have '{0} ⊆ I, from singleton_subset zero_mem,
have ∃y , (y ∈ I ∧  y ∉ '{0}),
  from exists_mem_and_not_mem_of_ne_of_subset (ne.symm H) this,
obtain y [yI ynmem], from this,
exists.intro y (and.intro yI (assume yeq, ynmem (mem_singleton_of_eq yeq)))

theorem eq_univ_of_is_ideal_of_one_mem {I : set A} [is_ideal I] (H : 1 ∈ I) : I = univ :=
eq_univ_of_forall (take x, by rewrite -mul_one; apply mul_arb_mem _ H)

theorem eq_univ_or_eq_singleton_zero_of_is_ideal (H : ∀ x : A , x ≠ 0 → ∃ y, x * y = 1)
  {I : set A} [is_ideal I] : I = univ ∨ I = '{0} :=
by_cases
  (suppose I = '{0}, or.inr this)
  (suppose I ≠ '{0},
    obtain x [xI xne0], from exists_mem_and_ne_zero_of_is_ideal this,
    obtain y (xyeq : x * y = 1), from H x xne0,
    have 1 ∈ I, by rewrite -xyeq; exact mul_arb_mem' xI _,
    have I = univ, from eq_univ_of_is_ideal_of_one_mem this,
    or.inl this)

-- TODO: move
private definition inhabited_of_has_zero [instance] : inhabited A :=
inhabited.mk 0

noncomputable private definition classical_inv (x : A) : A :=
if H : x = 0 then 0 else epsilon (λ y, x * y = 1)

private theorem mul_classical_inv (H : ∀ x : A , x ≠ 0 → ∃ y, x * y = 1) (x : A) (H' : x ≠ 0) :
  x * (classical_inv x) = 1 :=
by rewrite [↑classical_inv, dif_neg H']; apply epsilon_spec (H x H')

private theorem classical_inv_mul (H : ∀ x : A , x ≠ 0 → ∃ y, x * y = 1) (x : A) (H' : x ≠ 0) :
  (classical_inv x) * x = 1 :=
by rewrite [mul.comm, mul_classical_inv H x H']

private theorem classical_inv_zero : classical_inv (0 : A) = 0 :=
by rewrite [↑classical_inv, dif_pos rfl]

noncomputable definition discrete_field_of_comm_ring (H : ∀ x : A , x ≠ 0 → ∃ y, x * y = 1)
    (H' : 0 ≠ 1) :
  discrete_field A :=
⦃ discrete_field, (_ : comm_ring A),
  inv              := classical_inv,
  zero_ne_one      := H',
  inv_mul_cancel   := classical_inv_mul H,
  mul_inv_cancel   := mul_classical_inv H,
  has_decidable_eq := _,
  inv_zero         := classical_inv_zero
⦄

end

/- quotient ring -/

namespace quotient_ring
variables {A : Type} [comm_ring A] (K : set A) [is_ideal K]

local notation  a `~` b :=  b - a ∈ K

private lemma rel_rfl (a : A) : a ~ a := by rewrite sub_self; apply zero_mem

private lemma rel_symm (a b : A) (H : a ~ b) : b ~ a :=
mem_of_neg_mem (by rewrite neg_sub; apply H)

private lemma rel_trans (a b c : A) (H₁ : a ~ b) (H₂ : b ~ c) : a ~ c :=
have c - a = (c - b) + (b - a), by simp,
show c - a ∈ K, by rewrite this; exact add_mem H₂ H₁

private lemma add_well_defined {a1 a2 b1 b2 : A} (H1 : a1 ~ b1) (H2 : a2 ~ b2) :
  a1 + a2 ~ b1 + b2 :=
have (b1 + b2) - (a1 + a2) = (b1 - a1) + (b2 - a2), by simp,
by rewrite this; apply add_mem H1 H2

private lemma neg_well_defined {a  b : A} (H : a ~ b) : (-a ~ -b) :=
mem_of_neg_mem (by rewrite [neg_neg_sub_neg]; apply H)

private lemma mul_well_defined {a1 a2 b1 b2 : A} (H1 : a1 ~  b1) (H2 : a2 ~  b2) :
  a1 * a2 ~ b1 * b2 :=
have b1 * b2 - a1 * a2 = (b1 - a1) * b2 + a1 * (b2 - a2),
  by rewrite [mul_sub_right_distrib, mul_sub_left_distrib, *sub_eq_add_neg, add.assoc,
              neg_add_cancel_left],
begin
  rewrite this, apply add_mem,
    {exact mul_arb_mem' H1 _},
  exact mul_arb_mem _ H2
end

definition quotient_ring_setoid : setoid A :=
setoid.mk (λ a b, b - a ∈ K) (mk_equivalence _ (rel_rfl K) (rel_symm K) (rel_trans K))

local attribute quotient_ring_setoid [instance]

definition quotient [reducible] : Type := quot (quotient_ring_setoid K)

definition qproj (a : A) : quotient K := @quot.mk A (quotient_ring_setoid K) a

infix ` / `      := λ (A' : Type) [comm_ring A'] K' [is_ideal K'], quotient K'
infix ` '+ `:65  := λ {A' : Type} [comm_ring A'] a K' [is_ideal K'], qproj K' a

variable {K}

theorem qproj_eq_qproj {a b : A} (H : b - a ∈ K) : a '+ K = b '+ K :=
quot.sound H

theorem sub_mem_of_qproj_eq_qproj {a b : A} (H : a '+ K = b '+ K) : b - a ∈ K :=
quot.exact H

theorem qproj_eq_qproj_iff (a b : A) : a '+ K = b '+ K ↔ b - a ∈ K :=
iff.intro sub_mem_of_qproj_eq_qproj qproj_eq_qproj

-- TODO: replace in group.quotient as well
proposition quotient_induction {P : A / K → Prop} (h : ∀ a, P (a '+ K)) : ∀ a, P a :=
take a, quot.induction_on a h

proposition quotient_induction_on {P : A / K → Prop} (a : A / K) (h : ∀ a, P (a '+ K)) : P a :=
quot.induction_on a h

proposition quotient_induction₂ {P : A / K → A / K → Prop}
    (h : ∀ a₁ a₂, P (a₁ '+ K) (a₂ '+ K)) :
  ∀ a₁ a₂, P a₁ a₂ :=
take a₁ a₂, quot.induction_on₂ a₁ a₂ h

proposition quotient_induction_on₂ {P : A / K → A / K → Prop}
    (a₁ a₂ : A / K) (h : ∀ a₁ a₂, P (a₁ '+ K) (a₂ '+ K)) :
  P a₁ a₂ :=
quot.induction_on₂ a₁ a₂ h

proposition exists_eq_qproj : ∀ a : A / K, ∃ a', a = a' '+ K :=
quotient_induction (λ a, exists.intro _ rfl)

private definition qadd : A / K → A / K → A / K :=
quot.lift₂
  (λ a b, (a + b) '+ K)
  (take a₁ a₂ b₁ b₂, assume Ha : a₁ ~ b₁, assume Hb : a₂ ~ b₂,
    quot.sound (add_well_defined K Ha Hb))

private definition qmul : A / K → A / K → A / K :=
quot.lift₂
  (λ a b, (a * b) '+ K)
  (take a₁ a₂ b₁ b₂, assume Ha : a₁ ~ b₁, assume Hb : a₂ ~ b₂,
    quot.sound (mul_well_defined K Ha Hb))

private definition qzero : A / K := 0 '+ K

private definition qone : A / K := 1 '+ K

private lemma qproj_eq_qproj_of_eq {a b : A} (H : a = b) : (a '+ K) = (b '+ K) := by rewrite H

private theorem qadd_comm (a b : A / K) : qadd a b = qadd b a :=
quot.induction_on₂ a b
  (take a b, qproj_eq_qproj_of_eq (add.comm a b))

private theorem qadd_assoc (a b c : A / K) : qadd (qadd a b) c = qadd a (qadd b c) :=
quot.induction_on₃ a b c
  (take a b c, qproj_eq_qproj_of_eq (add.assoc a b c))

private definition qneg : A / K → A / K :=
quot.lift
  (λ a , (-a) '+ K)
  (take a1 a2, assume Ha : a1 ~ a2, quot.sound (neg_well_defined K Ha))

private theorem qadd_left_inverse (a : A/ K) : qadd (qneg a) a = qzero :=
quot.induction_on a
  (take a, qproj_eq_qproj_of_eq (add.left_inv a))

private theorem zero_qadd (a : A / K) : qadd qzero a = a :=
quot.induction_on a
  (take a, qproj_eq_qproj_of_eq (zero_add a))

private theorem qadd_zero (a  : A / K) : qadd a qzero = a  :=
quot.induction_on a
  (take a, qproj_eq_qproj_of_eq (add_zero a))

private theorem qmul_comm (a b : A / K) : qmul a b = qmul b a :=
quot.induction_on₂ a b
  (take a b, qproj_eq_qproj_of_eq (mul.comm a b))

private theorem  qmul_assoc (a b c : A / K) : qmul (qmul a b) c = qmul a (qmul b c) :=
quot.induction_on₃ a b c
  (take a b c, qproj_eq_qproj_of_eq (mul.assoc a b c))

private theorem one_qmul (a  : A / K) : qmul qone a = a  :=
quot.induction_on a
  (take a, qproj_eq_qproj_of_eq (one_mul a))

private theorem qmul_one (a  : A / K) : qmul  a qone = a  :=
quot.induction_on a
  (take a, qproj_eq_qproj_of_eq (mul_one a))

private theorem left_distrib (a b c : A/K) : qmul a (qadd b c)= qadd (qmul a b) (qmul a c) :=
quot.induction_on₃ a b c
  (take a b c, qproj_eq_qproj_of_eq (left_distrib a b c))

private theorem right_distrib (a b c : A/K) : qmul (qadd a b) c = qadd (qmul a c) (qmul b c) :=
quot.induction_on₃ a b c
  (take a b c, qproj_eq_qproj_of_eq (right_distrib a b c))

private theorem qadd_comm (a b : A / K) : qadd a b = qadd b a :=
quot.induction_on b
  (quot.induction_on a
    (take a b,
      have (b + a) - (a + b) = 0, by simp,
      have (b + a) - (a + b) ∈ K, by rewrite this; exact zero_mem,
      quot.sound this))

protected definition to_ring [instance] : comm_ring (quotient K) :=
⦃ comm_ring,
  add           := qadd,
  add_assoc     := qadd_assoc,
  zero          := qzero,
  zero_add      := zero_qadd,
  add_zero      := qadd_zero,
  neg           := qneg,
  add_left_inv  := qadd_left_inverse,
  add_comm      := qadd_comm,
  mul           := qmul,
  mul_assoc     := qmul_assoc,
  one           := qone,
  one_mul       := one_qmul,
  mul_one       := qmul_one,
  left_distrib  := left_distrib,
  right_distrib := right_distrib,
  mul_comm      := qmul_comm
⦄

variable (K)
theorem qproj_zero : 0 '+ K = 0 := rfl
theorem qproj_one : 1 '+ K = 1 := rfl
variable {K}

theorem qproj_eq_zero_iff (a : A) : a '+ K = 0 ↔ a ∈ K :=
by krewrite [qproj_eq_qproj_iff, sub_mem_iff, sub_zero]

theorem mem_of_qproj_eq_zero {a : A} (H : a '+ K = 0 '+ K) : a ∈ K :=
iff.mp (qproj_eq_zero_iff a) H

theorem qproj_eq_zero {a : A} (H : a ∈ K) : a '+ K = 0 :=
iff.mpr (qproj_eq_zero_iff a) H

end quotient_ring

/- prime and maximal ideals -/

section
variables {A : Type} [comm_ring A]
open quotient_ring

structure is_prime_ideal [class] (I : set A) extends is_ideal I : Prop :=
(is_prime : ∀ ⦃a b⦄, a * b ∈ I → a ∈ I ∨ b ∈ I)
(nontrivial : I ≠ univ)

structure is_maximal_ideal [class] (I : set A) extends is_ideal I : Prop :=
(is_maximal : ∀ ⦃J : set A⦄, is_ideal J → J ⊇ I → J = I ∨ J = univ)
(nontrivial : I ≠ univ)

theorem mem_or_mem_of_is_prime {I : set A} [is_prime_ideal I] {a b : A} (H : a * b ∈ I) :
  a ∈ I ∨ b ∈ I :=
is_prime_ideal.is_prime H

theorem ne_univ_of_is_prime (I : set A) [is_prime_ideal I] : I ≠ univ :=
@is_prime_ideal.nontrivial _ _ I _

theorem is_maximal {I : set A} [is_maximal_ideal I] {J : set A} [idealJ : is_ideal J] (H : J ⊇ I) :
  J = I ∨ J = univ :=
is_maximal_ideal.is_maximal idealJ H

theorem qproj_eq_zero_or_qproj_eq_zero_of_is_prime_ideal {I : set A} [is_prime_ideal I] (a b : A)
    (H : (a '+ I) * (b '+ I) = 0) :
  a '+ I = 0 ∨ b '+ I = 0 :=
begin
  rewrite [+qproj_eq_zero_iff],
  apply mem_or_mem_of_is_prime,
  apply mem_of_qproj_eq_zero,
  exact H
end

theorem is_prime_ideal_of_forall {I : set A} [is_ideal I]
    (H : ∀ a b, (a '+ I) * (b '+ I) = 0 → a '+ I = 0 ∨ b '+ I = 0) (H' : I ≠ univ) :
  is_prime_ideal I :=
⦃ is_prime_ideal, (_ : is_ideal I),
  is_prime   := begin
                  intro a b abI,
                  rewrite [-+qproj_eq_zero_iff],
                  apply H,
                  exact qproj_eq_zero abI
                end,
  nontrivial := H'
⦄

theorem exists_qproj_mul_qproj_eq_one_of_is_maximal {I : set A} [is_maximal_ideal I] {a : A}
    (H : a '+ I ≠ 0) :
  ∃ y, (a '+ I) * (y '+ I) = 1 :=
have ideal_generated_by (I ∪ '{a}) ≠ I, from
  assume otherwise,
  have a ∈ ideal_generated_by (I ∪ '{a}),
    from subset_ideal_generated_by _ (mem_unionr (mem_singleton _)),
  have a ∉ I, from λ H', H (qproj_eq_zero H'),
  show false, begin apply this, rewrite -otherwise, assumption end,
have ideal_generated_by (I ∪ '{a}) = univ, from
  or.resolve_left
    (is_maximal (subset.trans (subset_union_left _ _) (subset_ideal_generated_by _))) this,
have 1 ∈ {b | ∃₀ y ∈ I, ∃ z, b = y + z * a},
  by rewrite [-ideal_generated_by_union_singleton, this]; apply mem_univ,
obtain y [yI [z (oneeq : 1 = y + z * a)]], from this,
exists.intro z (qproj_eq_qproj
    (show 1 - a * z ∈ I, by rewrite [oneeq, mul.comm, add_sub_cancel]; exact yI))

theorem is_maximal_ideal_of_forall {I : set A} [is_ideal I]
    (H : ∀ a, a '+ I ≠ 0 → ∃ y, (a '+ I)  * (y '+ I) = 1) (H' : I ≠ univ) :
  is_maximal_ideal I :=
⦃ is_maximal_ideal, (_ : is_ideal I),
  is_maximal := take J, suppose is_ideal J, suppose J ⊇ I,
                by_cases
                  (suppose J = I, or.inl this)
                  (suppose J ≠ I,
                    obtain a [aJ anI],
                      from exists_mem_and_not_mem_of_ne_of_subset (ne.symm this) `J ⊇ I`,
                    have a '+ I ≠ 0, from λ H', anI (mem_of_qproj_eq_zero H'),
                    obtain y (Hy : (a '+ I)  * (y '+ I) = 1), from H _ this,
                    have 1 - a * y ∈ I, from sub_mem_of_qproj_eq_qproj Hy,
                    have 1 - a * y + a * y ∈ J, from add_mem (`J ⊇ I` this) (mul_arb_mem' aJ _),
                    have 1 ∈ J, by rewrite [sub_add_cancel at this]; exact this,
                    show J = I ∨ J = univ, from or.inr (eq_univ_of_is_ideal_of_one_mem this)),
  nontrivial := H'
⦄

definition integral_domain_quotient_of_is_prime_ideal [instance] (I : set A) [is_prime_ideal I] :
  integral_domain (A / I) :=
have H : ∀ a b : A / I, a * b = 0 → a = 0 ∨ b = 0, from
  quotient_induction₂ qproj_eq_zero_or_qproj_eq_zero_of_is_prime_ideal,
have H' : (0 : A / I) ≠ 1, from
  assume otherwise,
  have 1 - 0 ∈ I, from sub_mem_of_qproj_eq_qproj otherwise,
  have I = univ, from eq_univ_of_is_ideal_of_one_mem (by rewrite [sub_zero at this]; exact this),
  show false, from is_prime_ideal.nontrivial _ I this,
⦃ integral_domain, (_ : comm_ring (A / I)),
  eq_zero_or_eq_zero_of_mul_eq_zero := H,
  zero_ne_one                       := H'
⦄

theorem is_prime_ideal_of_forall_quotient {I : set A} [is_ideal I]
    (H : ∀ a b : A / I, a * b = 0 → a = 0 ∨ b = 0) (H' : I ≠ univ) :
  is_prime_ideal I :=
is_prime_ideal_of_forall (λ a b, H _ _) H'

noncomputable definition discrete_field_quotient_of_is_maximal_ideal [instance]
    (I : set A) [is_maximal_ideal I] :
  discrete_field (A / I) :=
have H : ∀ x : A / I, x ≠ 0 → ∃ y, x * y = 1, from
  quotient_induction
    (take a, assume anz,
      obtain y Hy, from exists_qproj_mul_qproj_eq_one_of_is_maximal anz,
      exists.intro (y '+ I) Hy),
have H' : (0 : A / I) ≠ 1, from
  assume otherwise,
  have 1 - 0 ∈ I, from sub_mem_of_qproj_eq_qproj otherwise,
  have I = univ, from eq_univ_of_is_ideal_of_one_mem (by rewrite [sub_zero at this]; exact this),
  show false, from is_maximal_ideal.nontrivial _ I this,
discrete_field_of_comm_ring H H'

theorem is_maximal_ideal_of_forall_quotient {I : set A} [is_ideal I]
    (H : ∀ a : A / I, a ≠ 0 → ∃ b, a * b = 1) (H' : I ≠ univ) :
  is_maximal_ideal I :=
is_maximal_ideal_of_forall
  (λ a aIne0,
    obtain b Hb, from H _ aIne0,
    obtain b' (beq : b = b' '+ I), from exists_eq_qproj b,
    exists.intro b' (by rewrite -beq; exact Hb))
  H'

theorem is_prime_ideal_of_is_maximal_ideal [instance] {I : set A} [is_maximal_ideal I] :
  is_prime_ideal I :=
is_prime_ideal_of_forall_quotient
  (@eq_zero_or_eq_zero_of_mul_eq_zero _ _)
  (is_maximal_ideal.nontrivial _ I)

end


import polyhedral_lattice.cosimplicial
import polyhedral_lattice.Hom

open_locale nnreal

namespace PolyhedralLattice

open pseudo_normed_group polyhedral_lattice.conerve (L obj lift' lift'_w)

variables (r' : ℝ≥0) (Λ : PolyhedralLattice)
variables (M : ProFiltPseuNormGrpWithTinv r') (N : ℕ) [fact (0 < N)]
variables (m : ℕ) (g₀ : Λ →+ M)
variables (g : fin (m + 1) → (Λ.rescaled_power N →+ M))
variables (hg : ∀ i l, (g i) (Λ.diagonal_embedding N l) = g₀ l)

lemma cosimplicial_lift_mk (l) :
  Λ.cosimplicial_lift N m g₀ g hg (quotient_add_group.mk l) = finsupp.lift_add_hom g l :=
begin
  dsimp only [cosimplicial_lift, lift'],
  have := quotient_add_group.lift_mk'
    (L (Λ.diagonal_embedding N) (m + 1))
    (lift'_w (Λ.diagonal_embedding N) m g₀ g hg _) l,
  exact this,
end

lemma cosimplicial_lift_mem_filtration (c : ℝ≥0)
  (H : ∀ i, g i ∈ filtration ((Λ.rescaled_power N) →+ M) c) :
  cosimplicial_lift Λ N m g₀ g hg ∈ filtration (obj (Λ.diagonal_embedding N) (m + 1) →+ M) c :=
begin
  intros c' l' hl',
  rw [seminormed_add_comm_group.mem_filtration_iff] at hl',
  obtain ⟨l, rfl, hl⟩ := polyhedral_lattice.norm_lift _ l',
  erw cosimplicial_lift_mk,
  rw [finsupp.lift_add_hom_apply, finsupp.sum_fintype],
  swap, { intro, rw add_monoid_hom.map_zero },
  simp only [← coe_nnnorm, nnreal.eq_iff] at hl,
  erw [finsupp.nnnorm_def, finsupp.sum_fintype] at hl,
  swap, { intro, rw nnnorm_zero },
  rw ← hl at hl',
  replace hl' := mul_le_mul' (le_refl c) hl',
  rw [finset.mul_sum] at hl',
  apply filtration_mono hl',
  apply sum_mem_filtration,
  rintro i -,
  apply H,
  exact seminormed_add_comm_group.mem_filtration_nnnorm (l i),
end

end PolyhedralLattice


import category_theory.full_subcategory
import category_theory.limits.preserves.basic
import category_theory.reflects_isomorphisms
import category_theory.punit

open category_theory category_theory.category category_theory.limits

universes v u u₂

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

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

variables (F : C ⥤ D)

instance fully_faithful_reflects_limits [full F] [faithful F] : reflects_limits F :=
{ reflects_limits_of_shape := λ J 𝒥₁, by exactI
  { reflects_limit := λ K,
    { reflects := λ c t,
      is_limit.mk_cone_morphism (λ s, (cones.functoriality K F).preimage (t.lift_cone_morphism _)) $
      begin
        apply (λ s m, (cones.functoriality K F).map_injective _),
        rw [functor.image_preimage],
        apply t.uniq_cone_morphism,
      end } } }

instance fully_faithful_reflects_colimits [full F] [faithful F] : reflects_colimits F :=
{ reflects_colimits_of_shape := λ J 𝒥₁, by exactI
  { reflects_colimit := λ K,
    { reflects := λ c t,
      is_colimit.mk_cocone_morphism (λ s, (cocones.functoriality K F).preimage (t.desc_cocone_morphism _)) $
      begin
        apply (λ s m, (cocones.functoriality K F).map_injective _),
        rw [functor.image_preimage],
        apply t.uniq_cocone_morphism,
      end } } }

@[simps]
def punit_cone_of_morphism {A B : C} (f : A ⟶ B) : cone (functor.from_punit B) :=
{ X := A,
  π := { app := λ _, f } }

@[simps]
def punit_cocone_of_morphism {A B : C} (f : A ⟶ B) : cocone (functor.from_punit A) :=
{ X := B,
  ι := { app := λ _, f } }

def is_iso_of_is_limit {A B : C} (f : A ⟶ B) (t : is_limit (punit_cone_of_morphism f)) : is_iso f :=
{ inv := t.lift (punit_cone_of_morphism (𝟙 _)),
  inv_hom_id' := t.fac _ punit.star,
  hom_inv_id' := t.hom_ext $ λ j, by { rw [assoc, t.fac _ j], simp } }

def is_iso_of_is_colimit {A B : C} (f : A ⟶ B) (t : is_colimit (punit_cocone_of_morphism f)) : is_iso f :=
{ inv := t.desc (punit_cocone_of_morphism (𝟙 _)),
  hom_inv_id' := t.fac _ punit.star,
  inv_hom_id' := t.hom_ext $ λ j, by { rw t.fac_assoc, dsimp, simp } }

def is_limit_of_is_iso {A B : C} (f : A ⟶ B) [is_iso f] : is_limit (punit_cone_of_morphism f) :=
{ lift := λ s, s.π.app punit.star ≫ inv f,
  uniq' := λ s m w, (as_iso f).eq_comp_inv.2 (w punit.star) }

def is_colimit_of_is_iso {A B : C} (f : A ⟶ B) [is_iso f] : is_colimit (punit_cocone_of_morphism f) :=
{ desc := λ s, inv f ≫ s.ι.app punit.star,
  uniq' := λ s m w, (as_iso f).eq_inv_comp.2 (w punit.star) }

def map_cone_point (B : C) : functor.from_punit B ⋙ F ≅ functor.from_punit (F.obj B) :=
nat_iso.of_components
(λ X, iso.refl _)
(λ X Y f, by { erw F.map_id, refl })

/--
If `F` reflects limits of shape `1`, then `F` reflects isomorphisms.
This is actually an iff.
-/
instance reflects_iso_of_reflects_limits_of_shape_punit [reflects_limits_of_shape (discrete punit) F] :
  reflects_isomorphisms F :=
{ reflects := λ A B f,
  begin
    introsI i,
    apply is_iso_of_is_limit,
    suffices : is_limit (F.map_cone (punit_cone_of_morphism f)),
      apply reflects_limit.reflects this,
    have l := is_limit_of_is_iso (F.map f),
    let t : cone (functor.from_punit B ⋙ F) ≌ cone _ := cones.postcompose_equivalence (map_cone_point F B),
    apply is_limit.of_iso_limit (is_limit.of_right_adjoint t.inverse l),
    refine cones.ext (iso.refl _) _,
    intro j,
    dsimp [map_cone_point],
    simp
  end }

/--
If `F` reflects colimits of shape `1`, then `F` reflects isomorphisms.
This is actually an iff.
-/
instance reflects_iso_of_reflects_colimits_of_shape_punit [reflects_colimits_of_shape (discrete punit) F] :
  reflects_isomorphisms F :=
{ reflects := λ A B f,
  begin
    introsI i,
    apply is_iso_of_is_colimit,
    suffices : is_colimit (F.map_cocone (punit_cocone_of_morphism f)),
      apply reflects_colimit.reflects this,
    have l := is_colimit_of_is_iso (F.map f),
    let t : cocone (functor.from_punit A ⋙ F) ≌ cocone _ := cocones.precompose_equivalence (map_cone_point F A).symm,
    apply is_colimit.of_iso_colimit (is_colimit.of_left_adjoint t.inverse l),
    refine cocones.ext (iso.refl _) _,
    intro j,
    dsimp [map_cone_point],
    simp
  end }

example [reflects_limits F] : reflects_isomorphisms F :=
infer_instance

example [reflects_colimits F] : reflects_isomorphisms F :=
infer_instance


universe variables u v

variables {α : Type u}
variables {β : Type u}

@[simp]
lemma none_or_else (x : option α)
: (none <|> x) = x :=
by { cases x ; refl }

@[simp]
lemma or_else_none (x : option α)
: (x <|> none) = x :=
by { cases x ; refl }

@[simp]
lemma some_or_else (x : α) (y : option α)
: (some x <|> y) = some x :=
by { refl }

@[simp]
lemma or_else_assoc (x y z : option α)
: ((x <|> y) <|> z) = (x <|> (y <|> z)) :=
by { cases x ; simp }

@[simp]
lemma or_else_eq_none_iff (x y : option α)
: (x <|> y) = none ↔ x = none ∧ y = none :=
begin
  split ; intros h,
  cases x with x,
  { simp at h, simp [h] },
  { simp at h, contradiction },
  { simp [h.left,h.right] }
end

@[simp]
lemma fmap_none (f : α → β)
: f <$> none = none := rfl

@[simp]
lemma fmap_some (f : α → β) (x : α)
: f <$> some x = some (f x) := rfl

@[simp]
lemma fmap_eq_none_iff (f : α → β) (x : option α)
: f <$> x = none ↔ x = none :=
by cases x ; simp

@[simp]
lemma coe_eq_some (x : α)
: ↑x = some x :=
rfl

lemma is_some_of_eq_some {α : Type u}
  (x : α) {y : option α}
  (h : some x = y)
: y.is_some :=
begin
  rw [← h,option.is_some],
  exact rfl
end

namespace option

def to_suml {α β} (x : β) : option α → α ⊕ β
  | none := sum.inr x
  | (some y) := sum.inl y

def to_sumr {α β} (x : α) : option β → α ⊕ β
  | none := sum.inl x
  | (some y) := sum.inr y

end option


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Jeremy Avigad, Mario Carneiro, Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.fin2
import Mathlib.data.typevec
import Mathlib.logic.function.basic
import Mathlib.tactic.basic
import Mathlib.PostPort

universes u_1 u_2 l u v

namespace Mathlib

/-!

Functors between the category of tuples of types, and the category Type

Features:

`mvfunctor n` : the type class of multivariate functors
`f <$$> x`    : notation for map

-/

/-- multivariate functors, i.e. functor between the category of type vectors
and the category of Type -/
class mvfunctor {n : ℕ} (F : typevec n → Type u_2) where
  map : {α β : typevec n} → typevec.arrow α β → F α → F β

namespace mvfunctor

/-- predicate lifting over multivariate functors -/
def liftp {n : ℕ} {F : typevec n → Type v} [mvfunctor F] {α : typevec n}
    (p : (i : fin2 n) → α i → Prop) (x : F α) :=
  ∃ (u : F fun (i : fin2 n) => Subtype (p i)), map (fun (i : fin2 n) => subtype.val) u = x

/-- relational lifting over multivariate functors -/
def liftr {n : ℕ} {F : typevec n → Type v} [mvfunctor F] {α : typevec n}
    (r : {i : fin2 n} → α i → α i → Prop) (x : F α) (y : F α) :=
  ∃ (u : F fun (i : fin2 n) => Subtype fun (p : α i × α i) => r (prod.fst p) (prod.snd p)),
    map
          (fun (i : fin2 n) (t : Subtype fun (p : α i × α i) => r (prod.fst p) (prod.snd p)) =>
            prod.fst (subtype.val t))
          u =
        x ∧
      map
          (fun (i : fin2 n) (t : Subtype fun (p : α i × α i) => r (prod.fst p) (prod.snd p)) =>
            prod.snd (subtype.val t))
          u =
        y

/-- given `x : F α` and a projection `i` of type vector `α`, `supp x i` is the set
of `α.i` contained in `x` -/
def supp {n : ℕ} {F : typevec n → Type v} [mvfunctor F] {α : typevec n} (x : F α) (i : fin2 n) :
    set (α i) :=
  set_of fun (y : α i) => ∀ {p : (i : fin2 n) → α i → Prop}, liftp p x → p i y

theorem of_mem_supp {n : ℕ} {F : typevec n → Type v} [mvfunctor F] {α : typevec n} {x : F α}
    {p : {i : fin2 n} → α i → Prop} (h : liftp p x) (i : fin2 n) (y : α i) (H : y ∈ supp x i) :
    p y :=
  hy h

end mvfunctor

/-- laws for `mvfunctor` -/
class is_lawful_mvfunctor {n : ℕ} (F : typevec n → Type u_2) [mvfunctor F] where
  id_map : ∀ {α : typevec n} (x : F α), mvfunctor.map typevec.id x = x
  comp_map :
    ∀ {α β γ : typevec n} (g : typevec.arrow α β) (h : typevec.arrow β γ) (x : F α),
      mvfunctor.map (typevec.comp h g) x = mvfunctor.map h (mvfunctor.map g x)

namespace mvfunctor

/-- adapt `mvfunctor.liftp` to accept predicates as arrows -/
def liftp' {n : ℕ} {α : typevec n} {F : typevec n → Type v} [mvfunctor F]
    (p : typevec.arrow α (typevec.repeat n Prop)) : F α → Prop :=
  liftp fun (i : fin2 n) (x : α i) => typevec.of_repeat (p i x)

/-- adapt `mvfunctor.liftp` to accept relations as arrows -/
def liftr' {n : ℕ} {α : typevec n} {F : typevec n → Type v} [mvfunctor F]
    (r : typevec.arrow (typevec.prod α α) (typevec.repeat n Prop)) : F α → F α → Prop :=
  liftr fun (i : fin2 n) (x y : α i) => typevec.of_repeat (r i (typevec.prod.mk i x y))

@[simp] theorem id_map {n : ℕ} {α : typevec n} {F : typevec n → Type v} [mvfunctor F]
    [is_lawful_mvfunctor F] (x : F α) : map typevec.id x = x :=
  is_lawful_mvfunctor.id_map x

@[simp] theorem id_map' {n : ℕ} {α : typevec n} {F : typevec n → Type v} [mvfunctor F]
    [is_lawful_mvfunctor F] (x : F α) : map (fun (i : fin2 n) (a : α i) => a) x = x :=
  id_map x

theorem map_map {n : ℕ} {α : typevec n} {β : typevec n} {γ : typevec n} {F : typevec n → Type v}
    [mvfunctor F] [is_lawful_mvfunctor F] (g : typevec.arrow α β) (h : typevec.arrow β γ)
    (x : F α) : map h (map g x) = map (typevec.comp h g) x :=
  Eq.symm (comp_map g h x)

theorem exists_iff_exists_of_mono {n : ℕ} {α : typevec n} {β : typevec n} (F : typevec n → Type v)
    [mvfunctor F] [is_lawful_mvfunctor F] {p : F α → Prop} {q : F β → Prop} (f : typevec.arrow α β)
    (g : typevec.arrow β α) (h₀ : typevec.comp f g = typevec.id)
    (h₁ : ∀ (u : F α), p u ↔ q (map f u)) : (∃ (u : F α), p u) ↔ ∃ (u : F β), q u :=
  sorry

theorem liftp_def {n : ℕ} {α : typevec n} {F : typevec n → Type v} [mvfunctor F]
    (p : typevec.arrow α (typevec.repeat n Prop)) [is_lawful_mvfunctor F] (x : F α) :
    liftp' p x ↔ ∃ (u : F (typevec.subtype_ p)), map (typevec.subtype_val p) u = x :=
  sorry

theorem liftr_def {n : ℕ} {α : typevec n} {F : typevec n → Type v} [mvfunctor F]
    (r : typevec.arrow (typevec.prod α α) (typevec.repeat n Prop)) [is_lawful_mvfunctor F] (x : F α)
    (y : F α) :
    liftr' r x y ↔
        ∃ (u : F (typevec.subtype_ r)),
          map (typevec.comp typevec.prod.fst (typevec.subtype_val r)) u = x ∧
            map (typevec.comp typevec.prod.snd (typevec.subtype_val r)) u = y :=
  sorry

end mvfunctor

namespace mvfunctor

theorem liftp_last_pred_iff {n : ℕ} {F : typevec (n + 1) → Type u_1} [mvfunctor F]
    [is_lawful_mvfunctor F] {α : typevec n} {β : Type u} (p : β → Prop) (x : F (α ::: β)) :
    liftp' (typevec.pred_last' α p) x ↔ liftp (typevec.pred_last α p) x :=
  sorry

theorem liftr_last_rel_iff {n : ℕ} {F : typevec (n + 1) → Type u_1} [mvfunctor F]
    [is_lawful_mvfunctor F] {α : typevec n} {β : Type u} (rr : β → β → Prop) (x : F (α ::: β))
    (y : F (α ::: β)) : liftr' (typevec.rel_last' α rr) x y ↔ liftr (typevec.rel_last α rr) x y :=
  sorry

end Mathlib


/-
Copyright (c) 2017 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import tactic.lint
import control.basic

/-!
# Functors

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

This module provides additional lemmas, definitions, and instances for `functor`s.

## Main definitions

* `const α` is the functor that sends all types to `α`.
* `add_const α` is `const α` but for when `α` has an additive structure.
* `comp F G` for functors `F` and `G` is the functor composition of `F` and `G`.
* `liftp` and `liftr` respectively lift predicates and relations on a type `α`
  to `F α`.  Terms of `F α` are considered to, in some sense, contain values of type `α`.

## Tags

functor, applicative
-/

attribute [functor_norm] seq_assoc pure_seq_eq_map map_pure seq_map_assoc map_seq

universes u v w

section functor

variables {F : Type u → Type v}
variables {α β γ : Type u}
variables [functor F] [is_lawful_functor F]

lemma functor.map_id : (<$>) id = (id : F α → F α) :=
by apply funext; apply id_map

lemma functor.map_comp_map (f : α → β) (g : β → γ) :
  ((<$>) g ∘ (<$>) f : F α → F γ) = (<$>) (g ∘ f) :=
by apply funext; intro; rw comp_map

theorem functor.ext {F} : ∀ {F1 : functor F} {F2 : functor F}
  [@is_lawful_functor F F1] [@is_lawful_functor F F2]
  (H : ∀ α β (f : α → β) (x : F α),
    @functor.map _ F1 _ _ f x = @functor.map _ F2 _ _ f x),
  F1 = F2
| ⟨m, mc⟩ ⟨m', mc'⟩ H1 H2 H :=
begin
  cases show @m = @m', by funext α β f x; apply H,
  congr, funext α β,
  have E1 := @map_const_eq _ ⟨@m, @mc⟩ H1,
  have E2 := @map_const_eq _ ⟨@m, @mc'⟩ H2,
  exact E1.trans E2.symm
end

end functor

/-- Introduce the `id` functor. Incidentally, this is `pure` for
`id` as a `monad` and as an `applicative` functor. -/
def id.mk {α : Sort u} : α → id α := id

namespace functor

/-- `const α` is the constant functor, mapping every type to `α`. When
`α` has a monoid structure, `const α` has an `applicative` instance.
(If `α` has an additive monoid structure, see `functor.add_const`.) -/
@[nolint unused_arguments]
def const (α : Type*) (β : Type*) := α

/-- `const.mk` is the canonical map `α → const α β` (the identity), and
it can be used as a pattern to extract this value. -/
@[pattern] def const.mk {α β} (x : α) : const α β := x

/-- `const.mk'` is `const.mk` but specialized to map `α` to
`const α punit`, where `punit` is the terminal object in `Type*`. -/
def const.mk' {α} (x : α) : const α punit := x

/-- Extract the element of `α` from the `const` functor. -/
def const.run {α β} (x : const α β) : α := x

namespace const

protected lemma ext {α β} {x y : const α β} (h : x.run = y.run) : x = y := h

/-- The map operation of the `const γ` functor. -/
@[nolint unused_arguments]
protected def map {γ α β} (f : α → β) (x : const γ β) : const γ α := x

instance {γ} : functor (const γ) :=
{ map := @const.map γ }

instance {γ} : is_lawful_functor (const γ) :=
by constructor; intros; refl

instance {α β} [inhabited α] : inhabited (const α β) :=
⟨(default : α)⟩

end const

/-- `add_const α` is a synonym for constant functor `const α`, mapping
every type to `α`. When `α` has a additive monoid structure,
`add_const α` has an `applicative` instance. (If `α` has a
multiplicative monoid structure, see `functor.const`.) -/
def add_const (α : Type*) := const α

/-- `add_const.mk` is the canonical map `α → add_const α β`, which is the identity,
where `add_const α β = const α β`. It can be used as a pattern to extract this value. -/
@[pattern]
def add_const.mk {α β} (x : α) : add_const α β := x

/-- Extract the element of `α` from the constant functor. -/
def add_const.run {α β} : add_const α β → α := id

instance add_const.functor {γ} : functor (add_const γ) :=
@const.functor γ

instance add_const.is_lawful_functor {γ} : is_lawful_functor (add_const γ) :=
@const.is_lawful_functor γ

instance {α β} [inhabited α] : inhabited (add_const α β) :=
⟨(default : α)⟩

/-- `functor.comp` is a wrapper around `function.comp` for types.
    It prevents Lean's type class resolution mechanism from trying
    a `functor (comp F id)` when `functor F` would do. -/
def comp (F : Type u → Type w) (G : Type v → Type u) (α : Type v) : Type w :=
F $ G α

/-- Construct a term of `comp F G α` from a term of `F (G α)`, which is the same type.
Can be used as a pattern to extract a term of `F (G α)`. -/
@[pattern] def comp.mk {F : Type u → Type w} {G : Type v → Type u} {α : Type v}
  (x : F (G α)) : comp F G α := x

/-- Extract a term of `F (G α)` from a term of `comp F G α`, which is the same type. -/
def comp.run {F : Type u → Type w} {G : Type v → Type u} {α : Type v}
  (x : comp F G α) : F (G α) := x

namespace comp

variables {F : Type u → Type w} {G : Type v → Type u}

protected lemma ext
  {α} {x y : comp F G α} : x.run = y.run → x = y := id

instance {α} [inhabited (F (G α))] : inhabited (comp F G α) :=
⟨(default : F (G α))⟩

variables [functor F] [functor G]

/-- The map operation for the composition `comp F G` of functors `F` and `G`. -/
protected def map {α β : Type v} (h : α → β) : comp F G α → comp F G β
| (comp.mk x) := comp.mk ((<$>) h <$> x)

instance : functor (comp F G) := { map := @comp.map F G _ _ }

@[functor_norm] lemma map_mk {α β} (h : α → β) (x : F (G α)) :
  h <$> comp.mk x = comp.mk ((<$>) h <$> x) := rfl

@[simp] protected lemma run_map {α β} (h : α → β) (x : comp F G α) :
  (h <$> x).run = (<$>) h <$> x.run := rfl

variables [is_lawful_functor F] [is_lawful_functor G]
variables {α β γ : Type v}

protected lemma id_map : ∀ (x : comp F G α), comp.map id x = x
| (comp.mk x) := by simp [comp.map, functor.map_id]

protected lemma comp_map (g' : α → β) (h : β → γ) : ∀ (x : comp F G α),
           comp.map (h ∘ g') x = comp.map h (comp.map g' x)
| (comp.mk x) := by simp [comp.map, functor.map_comp_map g' h] with functor_norm

instance : is_lawful_functor (comp F G) :=
{ id_map := @comp.id_map F G _ _ _ _,
  comp_map := @comp.comp_map F G _ _ _ _ }

theorem functor_comp_id {F} [AF : functor F] [is_lawful_functor F] :
  @comp.functor F id _ _ = AF :=
@functor.ext F _ AF (@comp.is_lawful_functor F id _ _ _ _) _ (λ α β f x, rfl)

theorem functor_id_comp {F} [AF : functor F] [is_lawful_functor F] :
  @comp.functor id F _ _ = AF :=
@functor.ext F _ AF (@comp.is_lawful_functor id F _ _ _ _) _ (λ α β f x, rfl)

end comp

namespace comp

open function (hiding comp)
open functor

variables {F : Type u → Type w} {G : Type v → Type u}

variables [applicative F] [applicative G]

/-- The `<*>` operation for the composition of applicative functors. -/
protected def seq {α β : Type v} : comp F G (α → β) → comp F G α → comp F G β
| (comp.mk f) (comp.mk x) := comp.mk $ (<*>) <$> f <*> x

instance : has_pure (comp F G) :=
⟨λ _ x, comp.mk $ pure $ pure x⟩

instance : has_seq (comp F G) :=
⟨λ _ _ f x, comp.seq f x⟩

@[simp] protected lemma run_pure {α : Type v} :
  ∀ x : α, (pure x : comp F G α).run = pure (pure x)
| _ := rfl

@[simp] protected lemma run_seq {α β : Type v} (f : comp F G (α → β)) (x : comp F G α) :
  (f <*> x).run = (<*>) <$> f.run <*> x.run := rfl

instance : applicative (comp F G) :=
{ map := @comp.map F G _ _,
  seq := @comp.seq F G _ _,
  ..comp.has_pure }

end comp

variables {F : Type u → Type u} [functor F]

/-- If we consider `x : F α` to, in some sense, contain values of type `α`,
predicate `liftp p x` holds iff every value contained by `x` satisfies `p`. -/
def liftp {α : Type u} (p : α → Prop) (x : F α) : Prop :=
∃ u : F (subtype p), subtype.val <$> u = x

/-- If we consider `x : F α` to, in some sense, contain values of type `α`, then
`liftr r x y` relates `x` and `y` iff (1) `x` and `y` have the same shape and
(2) we can pair values `a` from `x` and `b` from `y` so that `r a b` holds. -/
def liftr {α : Type u} (r : α → α → Prop) (x y : F α) : Prop :=
∃ u : F {p : α × α // r p.fst p.snd},
  (λ t : {p : α × α // r p.fst p.snd}, t.val.fst) <$> u = x ∧
  (λ t : {p : α × α // r p.fst p.snd}, t.val.snd) <$> u = y

/-- If we consider `x : F α` to, in some sense, contain values of type `α`, then
`supp x` is the set of values of type `α` that `x` contains. -/
def supp {α : Type u} (x : F α) : set α := { y : α | ∀ ⦃p⦄, liftp p x → p y }

theorem of_mem_supp {α : Type u} {x : F α} {p : α → Prop} (h : liftp p x) :
  ∀ y ∈ supp x, p y :=
λ y hy, hy h

end functor


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.limits.shapes.equalizers
import category_theory.limits.shapes.binary_products
import category_theory.limits.shapes.pullbacks

/-!
# Constructing equalizers from pullbacks and binary products.

If a category has pullbacks and binary products, then it has equalizers.

TODO: provide the dual result.
-/

noncomputable theory

universes v u

open category_theory category_theory.category

namespace category_theory.limits

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

-- We hide the "implementation details" inside a namespace
namespace has_equalizers_of_pullbacks_and_binary_products

/-- Define the equalizing object -/
@[reducible]
def construct_equalizer (F : walking_parallel_pair ⥤ C) : C :=
pullback (prod.lift (𝟙 _) (F.map walking_parallel_pair_hom.left))
         (prod.lift (𝟙 _) (F.map walking_parallel_pair_hom.right))

/-- Define the equalizing morphism -/
abbreviation pullback_fst (F : walking_parallel_pair ⥤ C) :
  construct_equalizer F ⟶ F.obj walking_parallel_pair.zero :=
pullback.fst

lemma pullback_fst_eq_pullback_snd (F : walking_parallel_pair ⥤ C) :
  pullback_fst F = pullback.snd :=
by convert pullback.condition =≫ limits.prod.fst; simp

/-- Define the equalizing cone -/
@[reducible]
def equalizer_cone (F : walking_parallel_pair ⥤ C) : cone F :=
cone.of_fork
  (fork.of_ι (pullback_fst F)
    (begin
      conv_rhs { rw pullback_fst_eq_pullback_snd, },
      convert pullback.condition =≫ limits.prod.snd using 1; simp
     end))

/-- Show the equalizing cone is a limit -/
def equalizer_cone_is_limit (F : walking_parallel_pair ⥤ C) : is_limit (equalizer_cone F) :=
{ lift :=
  begin
    intro c, apply pullback.lift (c.π.app _) (c.π.app _),
    apply limit.hom_ext,
    rintro (_ | _); simp
  end,
  fac' := by rintros c (_ | _); simp,
  uniq' :=
  begin
    intros c _ J,
    have J0 := J walking_parallel_pair.zero, simp at J0,
    apply pullback.hom_ext,
    { rwa limit.lift_π },
    { erw [limit.lift_π, ← J0, pullback_fst_eq_pullback_snd] }
  end }

end has_equalizers_of_pullbacks_and_binary_products

open has_equalizers_of_pullbacks_and_binary_products
/-- Any category with pullbacks and binary products, has equalizers. -/
-- This is not an instance, as it is not always how one wants to construct equalizers!
lemma has_equalizers_of_pullbacks_and_binary_products :
  has_equalizers C :=
{ has_limit := λ F, has_limit.mk
  { cone := equalizer_cone F,
    is_limit := equalizer_cone_is_limit F } }

end category_theory.limits