import linear_algebra.dimension
import ring_theory.principal_ideal_domain
import set_theory.ordinal.arithmetic
import linear_algebra.free_module.basic

open_locale big_operators

section finset

universes u v w
variables {β : Type u} {α : Type v} {α' : Type w}  [comm_monoid β]

@[simp, to_additive]
lemma finset.prod_comap (s : finset α') (e : α → α') (f : α' → β)
  (he : set.inj_on e (e ⁻¹' ↑s))
  (hs : (s : set α') ⊆ set.range e):
  (∏ x in (s.preimage e he), f (e x)) = ∏ x in s, f x :=
begin
  haveI : Π (x : α'), decidable (x ∈ set.range e) := λ x, classical.prop_decidable _,
  haveI := classical.type_decidable_eq α',
  have hs : s = finset.image e (s.preimage e he),
  { rw finset.image_preimage,
    ext,
    split,
    { intro ha,
      simp only [finset.mem_filter, set.mem_range],
      refine ⟨ha, _⟩,
      exact_mod_cast set.mem_of_subset_of_mem hs ha
    },
    { simp only [finset.mem_filter, set.mem_range, and_imp, forall_exists_index],
      exact (λ H _ _, H)
    }
  },
  have hpre : e ⁻¹' ↑s = s.preimage e he := by rw finset.coe_preimage,
  have : ∏ x in (finset.image e (s.preimage e he)), f x = ∏ x in (s.preimage e he), f (e x),
  apply finset.prod_image,
  intros x hx y hy h,
  have hx : x ∈ e ⁻¹' ↑s := by rw hpre; exact hx,
  have hy : y ∈ e ⁻¹' ↑s := by rw hpre; exact hy,
  exact he hx hy h,
  rw ←this,
  rw ←hs
end

end finset

section finsupp

variables {α : Type*} {M : Type*} {R : Type*}
variables [semiring R] [add_comm_monoid M] [module R M]

variables {α' : Type*}

lemma finsupp.total_comap_domain'
  (v : α' → M) (f : α → α') (l : α' →₀ R) (hf : set.inj_on f (f ⁻¹' ↑l.support))
  (hsupp : (l.support : set α') ⊆ set.range f) :
(finsupp.total α M R (v ∘ f)) (finsupp.comap_domain f l hf) = ∑ (i : α') in l.support, l i • v i :=
begin
  haveI := classical.type_decidable_eq α',
  rw finsupp.total_apply,
  simp [finsupp.sum, finsupp.comap_domain],
  exact finset.sum_comap l.support f (λ x, l x • v x) hf hsupp
end

end finsupp

open submodule.is_principal set submodule

universe u

-- Equivalent of lt_of_lt_of_le for unbundled orders. (??)
lemma lt_of_lt_of_le_unbundled {α : Type u} {r : α → α → Prop} [is_strict_total_order' α r] {a b c : α}
  (hab : r a b) (hbc : ¬r c b) :
r a c :=
begin
  have t : r b c ∨ b = c ∨ r c b := trichotomous b c,
  cases t,
  exact is_trans.trans a b c hab t,
  cases t,
  rw ←t,
  exact hab,
  exact false.elim (hbc t)
end

-- Characterization of le for unbundled orders. (??)
lemma le_unbundled {α : Type u} {r : α → α → Prop} [is_strict_total_order' α r] {a b : α} :
  r a b ∨ a = b ↔  ¬r b a :=
begin
  split,
  intro h,
  cases h,
  by_contradiction h',
  exact irrefl a (is_trans.trans _ _ _ h h'),
  rw h,
  exact irrefl b,
  intro h,
  have t : r a b ∨ a = b ∨ r b a := trichotomous a b,
  cases t,
  exact or.intro_left _ t,
  cases t,
  exact or.intro_right _ t,
  exact false.elim (h t)
end

variables {R : Type*} [comm_ring R]
variables {M : Type*} [add_comm_group M] [module R M]

section aux_lemmas

variables {o : ordinal} {a : {i // i < o} → R}

lemma support_remove
  {i : ordinal}
  {j_good : { i // a i ≠ 0}}
  (hj: j_good.1.1.succ = i)
  {l l': {i // a i ≠ 0} →₀ R}
  (hsupp: ((l.support) : set { i // a i ≠ 0}) ⊆ λ (x : {i // a i ≠ 0}), x.1.1 < i)
  (hl' : l' = l + finsupp.single j_good (-(l j_good))) :
(l'.support : set { i // a i ≠ 0}) ⊆ (λ x : { i // a i ≠ 0}, x.1.1 < j_good.1.1) :=
begin
  let good := { i  // a i ≠ 0},
  have hl'j : l' j_good = 0,
  { simp only [hl', finsupp.coe_add, pi.add_apply, finsupp.single_eq_same, add_right_neg] },
  intros x hx,
  have hx₁ : x ∈ l'.support := hx,
  have hl' : ∀ x : good, x ≠ j_good → l' x = l x,
  intros x hx,
  simp only [hl', finsupp.single_eq_of_ne hx.symm, finsupp.coe_add, pi.add_apply, add_zero],
  by_contradiction,
  have h : ¬ x.1.1 < j_good.1.1 := h,
  have h := eq_or_lt_of_le (not_lt.1 h),
  cases h,
  { have h_1 : j_good = x := by simp at h_1; ext; exact h_1,
    rw ←h_1 at hx₁,
    rw l'.3 j_good at hx₁,
    contradiction
  },
  { have h_1' : j_good.1.1 ≠ x.1.1 := ne_of_lt h_1,
    have h_1' : j_good ≠ x,  -- todo: can't ext do this?
    simp at h_1',
    rw ne.def,
    apply mt subtype.ext_iff.1,
    apply mt subtype.ext_iff.1,
    exact h_1',
    have : l'.to_fun x = l x := hl' x h_1'.symm,
    have hx' := hx₁,
    rw l'.3 x at hx',
    rw this at hx',
    have hxi : j_good.1.1.succ ≤ x.1.1 := succ_order.succ_le_of_lt h_1,
    rw hj at hxi,
    have := not_mem_subset hsupp (not_lt_of_ge hxi),
    have := mt (l.3 x).2 this,
    contradiction
  }
end

-- Auxiliary lemma for proving linear independence at limit ordinals.
lemma lin_ind_limit
  {BB : { i // a i ≠ 0} → M}
  {i : ordinal}
  (hio : i ≤ o)
  (hlim : ordinal.is_limit i)
  (H : ∀ (k : ordinal), k < i → k ≤ o → ∀ (l : { i // a i ≠ 0} →₀ R),
      ((l.support : set { i // a i ≠ 0}) ⊆ λ (x : { i // a i ≠ 0}), x.1.1 < k) →
      finsupp.total { i // a i ≠ 0} M R BB l = 0 → l = 0)
  {l : { i // a i ≠ 0} →₀ R}
  (hsupp : (l.support : set {i // a i ≠ 0}) ⊆ (λ x : { i // a i ≠ 0}, x.1.1 < i))
  (hl : finsupp.total { i // a i ≠ 0} M R BB l = 0) :
l = 0 :=
begin
  let good := {i  // a i ≠ 0},
  by_cases hemp : l.support.nonempty,
  { let m := l.support.max' hemp,
    dsimp at hsupp,
    have hm₀ : ↑↑m < i := by exact_mod_cast mem_of_subset_of_mem hsupp (finset.max'_mem l.support hemp),
    have hm : m.1.1.succ < i := (ordinal.succ_lt_of_is_limit hlim).2 hm₀,
    have hmo : m.1.1.succ ≤ o := le_of_lt (lt_of_lt_of_le hm hio),
    have hsub : (l.support : set good) ⊆ (λ x : good, x.1.1 < m.1.1.succ),
    intros x hx,
    have hx : x ∈ l.support := hx,
    have : x.1.1 ≤ m.1.1 := finset.le_max' l.support x hx,
    exact order.lt_succ_iff.2 this,
    exact H m.1.1.succ hm hmo l hsub hl
  },
  { rw finset.not_nonempty_iff_eq_empty at hemp,
    exact finsupp.support_eq_empty.1 hemp
  }
end

-- Auxiliary lemma for proving the span property at limit ordinals.
lemma span_limit
  {N : submodule R M}
  {BB : { i // a i ≠ 0} → M}
  {i : ordinal}
  (hio : i ≤ o)
  (hlim : ordinal.is_limit i)
  {B : basis {i // i < o} R M}
  (H : ∀ (k : ordinal), k < i → k ≤ o → ∀ (l : {i // i < o} →₀ R),
      (l.support : set {i // i < o}) ⊆ (λ x, x.1 < k) →
      finsupp.total { i // i < o} M R B l ∈ N →
      finsupp.total { i // i < o} M R B l ∈ submodule.span R (range BB))
  {l : { i // i < o} →₀ R}
  (hsupp : (l.support : set {i // i < o}) ⊆ (λ x, x.1 < i))
  (hl : finsupp.total { i // i < o} M R B l ∈ N) :
finsupp.total { i // i < o} M R B l ∈ submodule.span R (range BB) :=
begin
  let ords := {i  // i < o},
  by_cases hemp : l.support.nonempty,
  { let m := l.support.max' hemp,
    dsimp at hsupp,
    have hm₀ : ↑m < i := by exact_mod_cast mem_of_subset_of_mem hsupp (finset.max'_mem l.support hemp),
    have hm : m.1.succ < i := (ordinal.succ_lt_of_is_limit hlim).2 hm₀,
    have hmo : m.1.succ ≤ o := le_of_lt (lt_of_lt_of_le hm hio),
    have hsub : (l.support : set ords) ⊆ (λ x : ords, x.1 < m.1.succ),
    intros x hx,
    have hx : x ∈ l.support := hx,
    have : x.1 ≤ m.1 := finset.le_max' l.support x hx,
    exact order.lt_succ_iff.2 this,
    exact H m.1.succ hm hmo l hsub hl
  },
  { rw finset.not_nonempty_iff_eq_empty at hemp,
    simp only [finsupp.support_eq_empty.1 hemp, _root_.map_zero, zero_mem]
  }
end

-- Auxiliary lemma for proving linear independence at successor ordinals.
lemma lin_ind_succ
  [is_domain R]
  {N : submodule R M}
  {B : basis {i // i < o} R M}
  {BB : { i  // a i ≠ 0} → N}
  (hB_BB : ∀ i : ordinal, ∀ l : {i // a i ≠ 0} →₀ R,
      ((l.support : set {i // a i ≠ 0}) ⊆ λ x, x.1.1 < i) →
      ∃ lB : {i // i < o} →₀ R, ((lB.support : set {i // i < o}) ⊆ λ x, x.1 < i) ∧
        finsupp.total {i // i < o} M R B lB = finsupp.total {i // a i ≠ 0} N R BB l)
  (hcoordB : ∀ i : { i // a i ≠ 0}, (B.coord i) (BB i) ≠ 0)
  {i : ordinal}
  (hio : i ≤ o)
  (hlim : ¬ordinal.is_limit i)
  (H : ∀ (k : ordinal), k < i → k ≤ o → ∀ (l : { i // a i ≠ 0} →₀ R),
      ((l.support : set { i // a i ≠ 0}) ⊆ λ (x : { i  // a i ≠ 0}), x.1.1 < k) →
      finsupp.total { i  // a i ≠ 0} N R BB l = 0 → l = 0)
  {l : { i // a i ≠ 0} →₀ R}
  (hsupp : (l.support : set {i  // a i ≠ 0}) ⊆ (λ x : { i // a i ≠ 0}, x.1.1 < i))
  (hl : finsupp.total { i  // a i ≠ 0} N R BB l = 0) :
l = 0 :=
begin
  let ords := { i // i < o},
  let good := { i  // a i ≠ 0},
  dsimp at hsupp,
  dsimp only [ordinal.is_limit] at hlim,
  repeat {push_neg at hlim},
  by_cases hi : i ≠ 0,
  rcases (hlim hi) with ⟨j, hj⟩,
  have hji : j < i := hj.1,
  have hjo : j < o := lt_of_lt_of_le hji hio,
  have hj : j.succ = i := le_antisymm (ordinal.succ_le.2 hj.1) hj.2,

  have not_j_lt_x : ∀ (x : good), ∀ (j : ordinal), x ∈ l.support → j < x.1.1 → j.succ = i → false,
  { intros x j hx h_1 hj,
    have hi : j.succ ≤ x := succ_order.succ_le_of_lt h_1,
    rw hj at hi,
    have hi' := mem_of_subset_of_mem hsupp hx,
    have hi' : ↑↑x < i := hi',
    have hi'' := not_le_of_lt hi',
    contradiction
  },

  by_cases hgood : a ⟨j, hjo⟩ ≠ 0,
  { -- Case: j is good
    let j_good : good := ⟨⟨j, hjo⟩, hgood⟩,
    by_cases hjsupp : j_good ∈ l.support,
    { let l' := l + finsupp.single j_good (-(l j_good)),
      have hsupp' : (l'.support : set good) ⊆ (λ x : good, x.1.1 < j),
      { have : j_good.1.1.succ = i := hj,
        exact support_remove this hsupp rfl
      },
      let lB := Exists.some (hB_BB j l' hsupp'),
      have hlBsupp : (lB.support : set {i // i < o}) ⊆ λ (x : {i // i < o}), x.1 < j :=
        (Exists.some_spec (hB_BB j l' hsupp')).1,
      have hlBtot : finsupp.total {i // i < o} M R B lB = finsupp.total good N R BB l' :=
       (Exists.some_spec (hB_BB j l' hsupp')).2,
      have h₁ : (B.coord ⟨j, hjo⟩) (finsupp.total good N R BB l) = 0 :=
        by simp only [hl, linear_map.map_zero, coe_zero],
      have h₂ : (B.coord ⟨j, hjo⟩) (finsupp.total good N R BB l') = 0,
      { rw ←hlBtot,
        simp only [basis.repr_total, basis.coord_apply],
        rw ←finsupp.not_mem_support_iff,
        apply not_mem_subset hlBsupp,
        have : ¬ (⟨j, hjo⟩ : ords).val < j := by simp; exact irrefl j,
        exact this
      },
      have h₃ : (B.coord ⟨j, hjo⟩) (finsupp.total good N R BB (finsupp.single j_good (-(l j_good)))) ≠ 0,
      have hlj : l j_good ≠ 0 := (l.3 j_good).1 hjsupp,
      { simp only [hlj, finsupp.total_single, coe_smul_of_tower, basis.coord_apply, linear_equiv.map_smulₛₗ, ring_hom.id_apply,
                   finsupp.coe_smul, pi.smul_apply, algebra.id.smul_eq_mul, ne.def, neg_eq_zero, mul_eq_zero, false_or],
        have := hcoordB j_good,
        rw basis.coord_apply at this,
        exact this
      },
      have hsum : (B.coord ⟨j, hjo⟩) (finsupp.total good N R BB l')
                  =   (B.coord ⟨j, hjo⟩) (finsupp.total good N R BB l)
                    + (B.coord ⟨j, hjo⟩) (finsupp.total good N R BB (finsupp.single j_good (-(l j_good)))) :=
        by simp [l', finsupp.single_neg, map_add_neg, map_neg],
      simp only [h₁, h₂, zero_add] at hsum,
      have hsum := eq.symm hsum,
      contradiction
    },
    { have hsub : (l.support : set good) ⊆ (λ x : good, x.1.1 < j),
      intros x hx,
      have hx : x ∈ l.support := hx,
      by_contradiction,
      have h : ¬ x.1.1 < j := h,
      have h := eq_or_lt_of_le (not_lt.1 h),
      cases h,
      { have : j_good = x := by simp [j_good, h_1],
        rw this at hjsupp,
        contradiction
      },
      { exact not_j_lt_x x j hx h_1 hj },
      exact H j hji (le_of_lt hjo) l hsub hl
    },
  },
  { -- Case: j is not good
    have hsub : (l.support : set good) ⊆ (λ x : good, x.1.1 < j),
    intros x hx,
    have hx : x ∈ l.support := hx,
    by_contradiction,
    have h : ¬ x.1.1 < j := h,
    have h := eq_or_lt_of_le (not_lt.1 h),
    cases h,
    { have hx' := x.2,
      have : x.1 = ⟨j, hjo⟩ := by simp [h_1],
      rw this at hx',
      contradiction
    },
    { exact not_j_lt_x x j hx h_1 hj },
    exact H j hji (le_of_lt hjo) l hsub hl
  },
  { -- induction base: i = 0
    have hi : i = 0 := not_not.1 hi,
    rw hi at hsupp,
    simp only [ordinal.not_lt_zero] at hsupp,
    have hsupp : (l.support : set good) ⊆ ∅ := hsupp,
    rw [subset_empty_iff, finset.coe_eq_empty] at hsupp,
    simp only [finsupp.support_eq_empty.1 hsupp, _root_.map_zero, zero_mem]
  }
end

-- Auxiliary lemma for proving the span property at successor ordinals.
lemma span_succ
  {N : submodule R M}
  {BB : { i // a i ≠ 0} → M}
  {i : ordinal}
  (hio : i ≤ o)
  (hlim : ¬ordinal.is_limit i)
  {B : basis {i // i < o} R M}
  (H : ∀ (k : ordinal), k < i → k ≤ o → ∀ (l : {i // i < o} →₀ R),
      (l.support : set {i // i < o}) ⊆ (λ x, x.1 < k) →
      finsupp.total { i // i < o} M R B l ∈ N →
      finsupp.total { i // i < o} M R B l ∈ submodule.span R (range BB))
  {l : { i // i < o} →₀ R}
  (hsupp : (l.support : set {i // i < o}) ⊆ (λ x, x.1 < i))
  (hl : finsupp.total { i // i < o} M R B l ∈ N)
  (hBB : ∀ i, ((B.repr (BB i)).support : set {i // i < o}) ⊆ (λ x, x.1 ≤ i))
  (hc : ∀ j : {i // i < o}, (i = j.1.succ) →
    ∃ r : R, (B.coord j) (finsupp.total {i // i < o} M R B l) = r •  a j)
   (hBBN : ∀ i, BB i ∈ N)
  (hBBa : ∀ j : { i // a i ≠ 0}, (B.coord j) (BB j) = a j) :
finsupp.total { i // i < o} M R B l ∈ submodule.span R (range BB) :=
begin
  let ords := { i  // i < o},
  let good := {i // a i ≠ 0},
  dsimp at hsupp,
  dsimp only [ordinal.is_limit] at hlim,
  repeat {push_neg at hlim},
  by_cases hi : i ≠ 0,
  rcases (hlim hi) with ⟨j, hj⟩,
  have hji : j < i := hj.1,
  have hjo : j < o := lt_of_lt_of_le hji hio,
  have hj : j.succ = i := le_antisymm (ordinal.succ_le.2 hj.1) hj.2,

  have not_j_lt_x : ∀ (x : ords), ∀ (j : ordinal), x ∈ l.support → j < x.1 → j.succ = i → false,
  { intros x j hx h_1 hj,
    have hi : j.succ ≤ x := succ_order.succ_le_of_lt h_1,
    rw hj at hi,
    have hi' := mem_of_subset_of_mem hsupp hx,
    have hi' : ↑x < i := hi',
    have hi'' := not_le_of_lt hi',
    contradiction
  },
  have hc := (hc ⟨j, hjo⟩ hj.symm),

  by_cases hgood : a ⟨j, hjo⟩ ≠ 0,
  { -- Case: j is good
    let j_good : good := ⟨⟨j, hjo⟩, hgood⟩,
    by_cases hjsupp : (⟨j, hjo⟩ : {i // i < o}) ∈ l.support,
    { let r := Exists.some hc,
      have hr : (B.coord ⟨j, hjo⟩) (finsupp.total {i // i < o} M R B l) = r • a ⟨j, hjo⟩ := Exists.some_spec hc,
      let l' := l - B.repr (r • (BB j_good)),
      have hsum : finsupp.total {i // i < o} M R B l' = finsupp.total {i // i < o} M R B l - r • (BB j_good) := by simp [l'],
      have hsum' : finsupp.total {i // i < o} M R B l = finsupp.total {i // i < o} M R B l' + r • (BB j_good) := by simp only [hsum, sub_add_cancel],
      rw hsum',
      have hsupp₀ : (l'.support : set {i // i < o}) ⊆ (λ x, x.1 < i),
      { have hBBj := hBB j_good,
        have hBBj' : (B.repr) (BB j_good) ∈ finsupp.supported R R (λ (x : ords), x.val < i),
        have hx : ∀ x : ords, x.1 ≤ j → x.1 < j.succ := λ x p, lt_of_le_of_lt p (ordinal.lt_succ_self j),
        rw hj at hx,
        intros y hy,
        have := mem_of_subset_of_mem hBBj hy,
        exact hx y (this : y.val ≤ j_good),
        intros x hx,
        let l₀ : finsupp.supported R R (λ x : ords, x.1 < i) := ⟨l, hsupp⟩,
        let BBj₀ : finsupp.supported R R (λ x : ords, x.1 < i) := ⟨B.repr (BB j_good), hBBj'⟩,
        let l'₀ : finsupp.supported R R (λ x : ords, x.1 < i) := l₀ - r • BBj₀,
        have hl' : l' = l'₀ :=
          by { simp only [l', linear_equiv.map_smulₛₗ, ring_hom.id_apply, subtype.coe_mk, coe_smul_of_tower,
            add_subgroup_class.coe_sub, submodule.coe_mk, sub_left_inj], },
        have hl'' := (finsupp.mem_supported R l'₀.1).1 l'₀.2,
        simp only [subtype.val_eq_coe, ←hl'] at hl'',
        exact mem_of_subset_of_mem hl'' hx
        },
      have hsupp' : (l'.support : set {i // i < o}) ⊆ (λ x, x.1 < j),
      { intros x hx,
        by_contradiction,
        have h : ¬ x.1 < j := h,
        have h := eq_or_lt_of_le (not_lt.1 h),
        cases h,
        have hjx : x = ⟨j, hjo⟩ := by simp [h_1],
        have hx : x ∈ l'.support := hx,
        rw l'.mem_support_to_fun at hx,
        have hl' : l' x = 0,
        dsimp [l'],
        have hu := hBBa j_good,
        simp at hu,
        simp only [hu, hjx, linear_equiv.map_smulₛₗ, ring_hom.id_apply, finsupp.coe_smul, pi.smul_apply],
        rw ←hr,
        simp,
        contradiction,
        have hx := mem_of_subset_of_mem hsupp₀ hx,
        have hx : x.1 < i := hx,
        rw ←hj at hx,
        have := mt (not_covby_iff (ordinal.lt_succ_self j)).2 (not_not.2 (order.succ_eq_iff_covby.mp rfl)),
        push_neg at this,
        have := not_lt_of_ge (this x h_1),
        contradiction
      },
      have hl' : finsupp.total {i // i < o} M R B l' ∈ N,
      { dsimp [l'],
        simp,
        rw sub_eq_add_neg,
        apply N.add_mem' hl,
        simp,
        apply N.smul_mem' r,
        exact hBBN j_good
      },
      have h : finsupp.total {i // i < o} M R B l' ∈ submodule.span R (range BB) := H j hji (le_of_lt hjo) l' hsupp' hl',
      have hBBj : r • (BB j_good) ∈ submodule.span R (range BB) := submodule.smul_mem' (submodule.span R (range BB)) r (mem_of_subset_of_mem subset_span (⟨j_good, rfl⟩ : BB j_good ∈ range BB)),
      exact submodule.add_mem' (submodule.span R (range BB)) h hBBj
    },
    { have hsub : (l.support : set {i // i < o}) ⊆ (λ x, x.1 < j),
      intros x hx,
      have hx : x ∈ l.support := hx,
      by_contradiction,
      have h : ¬ x.1 < j := h,
      have h := eq_or_lt_of_le (not_lt.1 h),
      cases h,
      { have : (⟨j, hjo⟩ : {i // i < o}) = x := by simp only [h_1, subtype.val_eq_coe, subtype.coe_eta],
        rw this at hjsupp,
        contradiction
      },
      { exact not_j_lt_x x j hx h_1 hj },
      exact H j hji (le_of_lt hjo) l hsub hl
    },
  },
  { -- Case: j is not good
    have hgood := not_not.1 hgood,
    simp only [hgood, ideal.submodule_span_eq, singleton_zero, ideal.span_zero, ideal.mem_bot] at hc,
    have hsub : (l.support : set {i // i < o}) ⊆ (λ x, x.1 < j),
    intros x hx,
    have hx : x ∈ l.support := hx,
    by_contradiction,
    have h : ¬ x.1 < j := h,
    have h := eq_or_lt_of_le (not_lt.1 h),
    cases h,
    { have : (⟨j, hjo⟩ : {i // i < o}) = x := by simp only [h_1, subtype.val_eq_coe, subtype.coe_eta],
      simp only [basis.coord_apply, basis.repr_total] at hc,
      rw this at hc,
      cases hc,
      simp only [algebra.id.smul_eq_mul, mul_zero] at hc_h,
      have hx := (finsupp.mem_support_to_fun l x).1 hx,
      contradiction
    },
    { exact not_j_lt_x x j hx h_1 hj },
    exact H j hji (le_of_lt hjo) l hsub hl
  },
  { -- induction base: i = 0
    have hi : i = 0 := not_not.1 hi,
    rw hi at hsupp,
    simp only [ordinal.not_lt_zero] at hsupp,
    have hsupp : (l.support : set {i // i < o}) ⊆ ∅ := hsupp,
    rw [subset_empty_iff, finset.coe_eq_empty] at hsupp,
    rw finsupp.support_eq_empty.1 hsupp,
    simp only [finsupp.support_eq_empty.1 hsupp, _root_.map_zero, zero_mem]
  }
end

end aux_lemmas

-- Auxiliary lemma for comparing a span in a submodule with the span considered in the larger module.
lemma span_restrict
  (N : submodule R M) (s : set M) (hs : s ⊆ N.carrier) :
  ∀ x : N, x ∈ @submodule.span R N _ _ _ (N.carrier.restrict s) ↔
  (x : M) ∈ submodule.span R s :=
begin
  intro x,
  split,
  { simp only [submodule.mem_span],
    intros hx p hp,
    let s' : set N := N.carrier.restrict s,
    have hp' : s' ⊆ comap N.subtype p,
    intros y hy,
    exact_mod_cast mem_of_subset_of_mem hp (hy : s y),
    have := hx (submodule.comap N.subtype p) hp',
    simp only [mem_comap, submodule.coe_subtype] at this,
    exact this,
  },
  { simp only [submodule.mem_span],
    intros hx p hp,
    have hp' : s ⊆ ↑(map N.subtype p),
    intros y hy,
    simp only [map_coe, submodule.coe_subtype, mem_image, set_like.mem_coe],
    have hy' := mem_of_subset_of_mem hs hy,
    refine ⟨⟨y, hy'⟩, ⟨_, rfl⟩⟩,
    have hy'' : N.carrier.restrict s ⟨y, hy'⟩,
    simp only [restrict_apply, coe_mk],
    exact hy,
    exact_mod_cast mem_of_subset_of_mem hp hy'',
    have hx' := hx (submodule.map N.subtype p) hp',
    simp at hx',
    exact hx'
  }
end

-- Auxiliary lemma for comparing a span in a submodule with the span considered in the larger module,
-- in the special case where the spanning set is the range of a map.
lemma span_range_cod_restrict
  (N : submodule R M) {α : Type*} (f : α → M) (h : ∀ (x : α), f x ∈ N) :
∀ x : N, x ∈ @submodule.span R N _ _ _ (range (cod_restrict f N h)) ↔ (x : M) ∈ submodule.span R (range f) :=
begin
  have hr : range (cod_restrict f N _) = N.carrier.restrict (range f),
  ext x,
  simp,
  split,
  { rintro ⟨y, hy⟩,
    use y,
    have hy := congr_arg coe hy,
    rw [coe_cod_restrict_apply] at hy,
    exact hy,
    exact h
  },
  { rintro ⟨y, hy⟩,
    use y,
    ext,
    rw coe_cod_restrict_apply,
    exact hy
  },
  rw hr,
  apply span_restrict,
  rintro x ⟨a, rfl⟩,
  exact h a
end

-- Equivalent of basis.reindex_apply for sets of indices.
theorem basis.reindex_apply_image {ι ι' : Type*}
  (b : basis ι R M) (e : ι ≃ ι') (s : set ι') :
(b.reindex e) '' s = (b ∘ (e.symm)) '' s :=
begin
  ext x,
  split,
  all_goals {
    rintro ⟨y, ⟨hy, rfl⟩⟩,
    simp only [basis.reindex_apply, function.comp_app, mem_image],
    refine ⟨y, ⟨hy, rfl⟩⟩
  }
end

-- Lemma on supports of finsupps, useful for finsupp.induction.
lemma finsupp.support_single_add {α : Type*}
  {l : α →₀ M}
  {b : M} (hb : b ≠ 0)
  {i : α} (hi : i ∉ l.support)
  {s : set α}
  (h : (finsupp.support (finsupp.single i b + l) : set α) ⊆ s) :
(finsupp.support l : set α) ⊆ s :=
begin
  haveI := classical.type_decidable_eq α,
  intros x hx,
  by_cases hx' : x = i,
  { have H : (finsupp.single i b + l) i ≠ 0 :=
      by simpa only [finsupp.not_mem_support_iff.1 hi, finsupp.coe_add, pi.add_apply, finsupp.single_eq_same, add_zero, ne.def],
    -- note: squeeze_simp does not work with field notations
    rw hx',
    exact mem_of_subset_of_mem h ((finsupp.mem_support_to_fun _ i).2 H)
  },
  { have H : (finsupp.single i b + l) x ≠ 0,
    simp only [finsupp.single_eq_of_ne (ne.symm hx'), finsupp.coe_add, pi.add_apply, zero_add, ne.def],
    exact (finsupp.mem_support_to_fun _ x).1 hx,
    exact mem_of_subset_of_mem h (finsupp.mem_support_iff.2 H)
  }
end

-- Lemma on supports of finsupps, useful for finsupp.induction.
lemma finsupp.mem_support_of_support_single_add {α : Type*}
  {l : α →₀ M}
  {b : M} (hb : b ≠ 0)
  {i : α} (hi : i ∉ l.support)
  {s : set α}
  (h : (finsupp.support (finsupp.single i b + l) : set α) ⊆ s) :
i ∈ s :=
begin
  haveI := classical.type_decidable_eq α,
  have H : (finsupp.single i b + l) i ≠ 0 := by simpa only [finsupp.not_mem_support_iff.1 hi, finsupp.coe_add, pi.add_apply, finsupp.single_eq_same, add_zero,
  ne.def],
  exact mem_of_subset_of_mem h (finsupp.mem_support_iff.2 H)
end

-- Has better def-eqs than `ordinal.enum_iso`. The mathlib fix is at #15454.
@[simps] noncomputable def _root_.ordinal.enum_iso' {α} (r : α → α → Prop) [is_well_order α r] :
  subrel (<) (< ordinal.type r) ≃r r :=
{ to_fun := λ x, ordinal.enum r x.1 x.2,
  inv_fun := λ x, ⟨ordinal.typein r x, ordinal.typein_lt_type r x⟩,
  left_inv := λ ⟨o, h⟩, subtype.ext_val (ordinal.typein_enum _ _),
  right_inv := λ h, ordinal.enum_typein _ _,
  map_rel_iff' := by { rintros ⟨a, _⟩ ⟨b, _⟩, apply ordinal.enum_lt_enum } }

/-- A submodule of a free module over a principal ideal domain is free. -/
theorem submodule.nonempty_basis_of_pid' [is_domain R] [is_principal_ideal_ring R]
  {ι : Type u}
  (b : basis ι R M) (N : submodule R M) :
  ∃ (B : Type (u+1)), nonempty (basis B R N) :=
begin
  haveI : decidable_eq M := classical.type_decidable_eq M,
  -- Set up the data.
  let r := classical.some (cardinal.ord_eq ι),
  haveI := classical.some (classical.some_spec (cardinal.ord_eq ι)),
  let o := ordinal.type r,
  let ords := {j : ordinal // j < o},
  let enum : ords → ι := λ i, ordinal.enum r i.1 i.2,

  let seg : ords → set ι :=  λ i, λ x, ¬r (enum i) x,  -- i.e. x ≤ i
  let F := λ i : ords, span R (image (coe_fn b) (seg i)),
  let U := λ i, (F i) ⊓ N,
  let V : ords → submodule R N := λ i, (F i).comap N.subtype,
  let V₁ : ordinal → submodule R N := λ i, dite (i < o) (λ p, V ⟨i, p⟩) (λ p, 0),
  have hU : ∀ i, U i ≤ N := λ i, inf_le_right,
  let ideal := λ i : ords, submodule.map (b.coord (enum i)) (U i),
  let a := λ i, generator (ideal i),
  let P := λ x, a x ≠ 0,
  have a_mem : Π i : ords, a i ∈ ideal i := λ i, generator_mem _,
  let u := λ i, Exists.some (a_mem i),
  have hu := λ i, Exists.some_spec (a_mem i),

  let B : basis ords R M := basis.reindex b (ordinal.enum_iso' r).to_equiv.symm,

  let good := {j : ords // a j ≠ 0},
  let BB : good → N := cod_restrict (λ i, u i.1) N (λ i, by {apply hU i.1, exact (hu i.1).1}),

  have hu' : ∀ j : good, (B.coord j) (BB j) = a j.1 := λ j, by simpa using (hu j).2,

  -- Prove lemmas about the data which are useful as hypotheses to the auxiliary lemmas above.
  have hc : ∀ i : ordinal, ∀ l : ords →₀ R, finsupp.total ords M R B l ∈ N →
    ((l.support : set ords) ⊆ (λ x, x.1 < i)) →
    ∀ j : ords, (i = j.1.succ) →
    ∃ r : R, (B.coord j) (finsupp.total ords M R B l) = r •  a j,
  { intros i l hl hsupp j hij,
    have hI : (B.coord j) (⇑(finsupp.total ords M R ⇑B) l) ∈ ideal j,
    refine ⟨finsupp.total ords M R B l, ⟨_, _⟩⟩,
    dsimp [U],
    refine ⟨_, hl⟩,
    simp only [mem_span_set, basis.coe_reindex, set_like.mem_coe],
    use finsupp.map_domain B l,
    split,
    rw finsupp.map_domain_support_of_inj_on l (inj_on_of_injective (basis.injective B) _),
    simp only [B, finset.coe_image, basis.reindex_apply_image],
    have h : ((ordinal.enum_iso' r).symm.to_equiv.symm) '' (l.support : set ords) ⊆ seg j,
    simp only [equiv.subset_image, rel_iso.coe_fn_to_equiv],
    intros x hx,
    use enum x,
    have hxi := mem_of_subset_of_mem hsupp hx,
    have hxi : x.1 < i := hxi,
    rw hij at hxi,
    have hxj : x.1 ≤ j.1 := succ_order.le_of_lt_succ hxi,
    split,
    have goal : ¬r (enum j) (enum x),
    rwa ordinal.enum_le_enum,
    exact goal,
    simp only [ordinal.enum_iso', ordinal.typein_enum, subtype.val_eq_coe, subtype.coe_eta,
      rel_iso.coe_fn_symm_mk, equiv.coe_fn_symm_mk],
    rw image_comp,
    exact image_subset b h,
    simp only [ordinal.enum_iso', subtype.val_eq_coe, basis.coe_reindex, equiv.coe_fn_symm_mk],
    rw ←@finsupp.total_apply M M R _ _ _ (λ x, x) _,
    rw finsupp.total_map_domain,
    rw function.injective.of_comp_iff (basis.injective b),
    exact equiv.injective (ordinal.enum_iso' r).to_equiv,
    simpa [B, ordinal.enum_iso'],
    rw ←submodule.is_principal.span_singleton_generator (ideal j) at hI,
    rw submodule.is_principal.mem_iff_eq_smul_generator  at hI,
    rw submodule.is_principal.span_singleton_generator at hI,
    exact hI
  },

  have hBBN : ∀ i, (BB i : M) ∈ N := λ i, by {apply hU i.1, exact (hu i.1).1},

  have hBB : ∀ i, (BB i : M) ∈ F i,
  { intro i,
    simp [BB],
    have : U i ≤ F i := inf_le_left,
    rw ←set_like.coe_subset_coe at this,
    have hi : u i ∈ U i := (hu i).1,
    exact_mod_cast mem_of_subset_of_mem this hi
  },

  have hcoordB : ∀ i : good, (B.coord i) (BB i) ≠ 0 := λ i, by rw hu'; exact i.2,

  have hBB' : ∀ i, (finsupp.support ((B.repr) (BB i)) : set ords) ⊆ (λ x, x.1 ≤ i),
  { intros i x hx,
    have h := hBB i,
    rw mem_span_set at h,
    rcases h with ⟨l, ⟨hsupp, hl⟩⟩,
    simp [B] at hx,
    simp [BB] at hl,
    let l' := finsupp.comap_domain b l (inj_on_of_injective (basis.injective b) _),
    have hsupp' : (l.support : set M) ⊆ range ⇑b := subset.trans hsupp (set.image_subset_range b (seg i)),
    have hrepr := finsupp.total_comap_domain' (λ i, i) b l (inj_on_of_injective (basis.injective b) _) hsupp',
    have hrepr : (finsupp.total ι M R ((λ i, i) ∘ b)) l' = ∑ (i : M) in l.support, l i • i := hrepr,
    dsimp [finsupp.sum] at hl,
    rw ←hrepr at hl,
    rw ←hl at hx,
    simp [ordinal.enum_iso] at hx,
    rw [←ne.def, ←finsupp.mem_support_iff] at hx,
    have hx := mem_of_subset_of_mem hsupp hx,
    rw function.injective.mem_set_image (basis.injective b) at hx,
    have henum := ordinal.enum_le_enum r x.2 i.1.2,
    simp at henum,
    apply henum.1,
    assumption
  },

  have hB_BB : ∀ i : ordinal, ∀ l : good →₀ R, ((l.support : set good) ⊆ λ x, x.1.1 < i) →
    ∃ lB : ords →₀ R, ((lB.support : set ords) ⊆ λ x, x.1 < i) ∧ finsupp.total ords M R B lB = finsupp.total good N R BB l,
  { intros i l,
    apply @finsupp.induction good R _ _ l,
    { intro _,
      use 0,
      simp only [finsupp.support_zero, finset.coe_empty, empty_subset, _root_.map_zero, coe_zero, eq_self_iff_true, and_self]
    },
    { intros j r l hj hr hl hl',
      have hlsupp := finsupp.support_single_add hr hj hl',
      have hl := hl hlsupp,
      rcases hl with ⟨lB, ⟨hlBsupp, hlBtot⟩⟩,
      use lB + r • B.repr (BB j),
      split,
      have hj' := finsupp.mem_support_of_support_single_add hr hj hl',
      have hj' : j.1.1 < i := hj',
      have hBBjsupp : (finsupp.support ((B.repr) (BB j)) : set ords) ⊆ (λ x, x.1 < i),
      { intros x hx,
        have := mem_of_subset_of_mem (hBB' j) hx,
        have : x.1 ≤ j := this,
        exact lt_of_le_of_lt this hj'
      },
      let lB₀ : finsupp.supported R R (λ x, x.1 < i : set ords) := ⟨lB, hlBsupp⟩,
      let BBj₀ : finsupp.supported R R (λ x, x.1 < i : set ords) := ⟨(B.repr) (BB j), hBBjsupp⟩,
      let l'₀ := lB₀ + r • BBj₀,
      exact l'₀.2,
      simp only [map_add, linear_map.map_smulₛₗ, ring_hom.id_apply,
                 finsupp.total_single, coe_add, coe_smul_of_tower, basis.total_repr, hlBtot],
      rw add_comm
    }
  },

  -- Prove linear independence.
  have HH₁ : ∀ j : ordinal, j ≤ o → ∀ (l : good →₀ R),
    (l.support : set good) ⊆ (λ x : good, x.1.1 < j) → (finsupp.total good N R BB) l = 0 → l = 0,
  { intros j hj,
    apply @ordinal.induction (λ j, j ≤ o → ∀ (l : good →₀ R),
      (l.support : set good) ⊆ (λ x : good, x.1.1 < j) → (finsupp.total good N R BB) l = 0 → l = 0),
    dsimp,
    intros i H hio l hsupp hl,
    by_cases hlim : ordinal.is_limit i,
    { exact lin_ind_limit hio hlim H hsupp hl },
    { exact lin_ind_succ hB_BB hcoordB hio hlim H hsupp hl },
    exact hj
  },

  have H₁ : linear_independent R BB,
  { rw linear_independent_iff,
    intros l hl,
    have hsupp : (l.support : set good) ⊆ (λ x : good, x.1.1 < o) := λ x _, x.1.2,
    exact HH₁ o (le_refl o) l hsupp hl
  },

  -- Prove the span property.
  have HH₂ : ∀ j : ordinal, j ≤ o → ∀ (l : ords →₀ R),
    (l.support : set ords) ⊆ (λ x, x.1 < j) → finsupp.total ords M R B l ∈ N → finsupp.total ords M R B l ∈ submodule.span R (range (λ i : good, u i.1)),
  { intros j hj,
    apply @ordinal.induction (λ k, k ≤ o → ∀ (l : {i // i < o} →₀ R),
      (l.support : set {i // i < o}) ⊆ (λ x, x.1 < k) → finsupp.total { i // i < o} M R B l ∈ N →
      finsupp.total { i // i < o} M R B l ∈ submodule.span R (range (λ i : good, u i.1))),
    dsimp,
    intros i H hio l hsupp hl,
    by_cases hlim : ordinal.is_limit i,
    { exact span_limit hio hlim H hsupp hl },
    { exact span_succ hio hlim H hsupp hl hBB' (hc i l hl hsupp) hBBN hu' },
    exact hj
  },

  have H₂ : submodule.span R (range BB) = ⊤,
  { rw submodule.eq_top_iff',
    intro x,
    let l := B.repr (x : M),
    have hl : finsupp.total ords M R B l ∈ N := by simp only [l, basis.total_repr]; exact x.2,
    have hx := HH₂ o (le_refl o) l _ hl,
    simp only [l, basis.total_repr] at hx,
    rw (span_range_cod_restrict N (λ i : good, u i.1) _ x),
    exact hx,
    intros y _,
    exact y.2
  },

  exact ⟨good, ⟨basis.mk H₁ H₂⟩⟩
end

@[instance]
theorem submodule.free_of_pid_of_free [is_domain R] [is_principal_ideal_ring R]
  {N : submodule R M}
  [module.free R M] :
module.free R N :=
begin
  have h := (submodule.nonempty_basis_of_pid' (module.free.choose_basis R M) N).some_spec,
  cases h,
  exact module.free.of_basis h
end


import for_mathlib.pid
import for_mathlib.projectives
import algebra.category.Module.projective
import for_mathlib.AddCommGroup.exact

noncomputable theory

open Module category_theory category_theory.limits

open_locale zero_object

lemma nat.eq_zero_or_exists_eq_add_of_ne_one {i : ℕ} (h : i ≠ 1) :
i = 0 ∨ ∃ k : ℕ, i = k + 2 :=
begin
  by_cases hi : i = 0,
  exact or.intro_left _ hi,
  simp at h,
  have : 2 ≤ i := nat.one_lt_iff_ne_zero_and_ne_one.2 ⟨hi, h⟩,
  have := or.intro_right _ (nat.exists_eq_add_of_le this),
  simpa [add_comm]
end

universes u v

variables (R : Type u) [comm_ring R] (M : Type (max u v)) [add_comm_group M] [module R M]

@[instance]
lemma Module.projective_of_of_projective [h : module.projective.{u v} R M] : category_theory.projective (of R M) :=
is_projective.iff_projective.1 h

/-- The objects of the two step ""resolution" of a module over a commutative ring. -/
def two_step_resolution_X : ℕ → Module.{max v u} R
| 0 := Module.of R (M →₀ R)
| 1 := Module.of R ((finsupp.total M M R id).ker)
| (n+2) := 0

/--  The objects of the two step projective resolution of an Abelian group .-/
def two_step_resolution_ab_X (M : Type v) [add_comm_group M] : ℕ → AddCommGroup.{v}
| 0 := AddCommGroup.of (M →₀ ℤ)
| 1 := AddCommGroup.of ((finsupp.total M M ℤ id).ker)
| (n+2) := 0

/--  The boundary maps of the two step "resolution" of a module over a commutative ring. -/
def two_step_resolution_d (i j : ℕ) : two_step_resolution_X R M i ⟶ two_step_resolution_X R M j :=
match i, j with
| 1, 0 := Module.as_hom (submodule.subtype ((finsupp.total M M R id).ker))
| _, _ := 0
end

/-- The boundary maps of the two step projective resolution of an Abelian group. -/
def two_step_resolution_ab_d (M : Type v) [add_comm_group M] (i j : ℕ) :
two_step_resolution_ab_X M i ⟶ two_step_resolution_ab_X M j :=
match i, j with
| 1, 0 := AddCommGroup.of_hom (add_subgroup.subtype (finsupp.total M M ℤ id).to_add_monoid_hom.ker)
| _, _ := 0
end

/-- The two step "resolution" of a module over a commutative ring. It is a projective resolution
    if the ring is a principal ideal domain. -/
def two_step_resolution : chain_complex (Module.{max v u} R) ℕ :=
{ X := two_step_resolution_X R M,
  d := two_step_resolution_d R M,
  shape' := by {
    simp,
    rintros i j hij,
    by_cases h : i = 1 ∧ j = 0,
    { rw [h.1, h.2] at hij,
      simp only [eq_self_iff_true, not_true] at hij,
      contradiction
    },
    { push_neg at h,
      by_cases hi : i = 1,
      { have hj := h hi,
        have hj : ∃ k : ℕ, j = k + 1,
        { have h : 1 ≤ j := nat.one_le_iff_ne_zero.mpr hj,
          have h := nat.exists_eq_add_of_le h,
          simp only [add_comm] at h,
          exact h
        },
        rcases hj with ⟨k, rfl⟩,
        rw hi,
        refl
      },
      { have hi : i = 0 ∨ ∃ k : ℕ, i = k + 2 := nat.eq_zero_or_exists_eq_add_of_ne_one hi,
        cases hi with hi hi,
        { rw hi, refl },
        { rcases hi with ⟨k, rfl⟩, refl }
  }}},
  d_comp_d' := by {
    intros i j k hij hjk,
    by_cases hi : i = 1,
    { simp only [hi, complex_shape.down_rel, add_left_eq_self] at hij,
      simp only [hij, complex_shape.down_rel, nat.succ_ne_zero] at hjk,
      contradiction
    },
    { have hi : i = 0 ∨ ∃ k : ℕ, i = k + 2 := nat.eq_zero_or_exists_eq_add_of_ne_one hi,
      cases hi with hi hi,
      { rw hi, simp only [two_step_resolution_d, zero_comp]},
      { rcases hi with ⟨k, rfl⟩, simp only [two_step_resolution_d, zero_comp]}
  }}
}

/-- The two step projective resolution of an abelian group M by the free abelian group M →₀ ℤ over M
    and the kernel of the natural map (M →₀ ℤ) → M. -/
def two_step_resolution_ab  (M : Type v) [add_comm_group M] : chain_complex AddCommGroup.{v} ℕ :=
{ X := two_step_resolution_ab_X M,
  d := two_step_resolution_ab_d M,
  shape' := by {
    simp,
    rintros i j hij,
    by_cases h : i = 1 ∧ j = 0,
    { rw [h.1, h.2] at hij,
      simp only [eq_self_iff_true, not_true] at hij,
      contradiction
    },
    { push_neg at h,
      by_cases hi : i = 1,
      { have hj := h hi,
        have hj : ∃ k : ℕ, j = k + 1,
        { have h : 1 ≤ j := nat.one_le_iff_ne_zero.mpr hj,
          have h := nat.exists_eq_add_of_le h,
          simp only [add_comm] at h,
          exact h
        },
        rcases hj with ⟨k, rfl⟩,
        rw hi,
        refl
      },
      { have hi : i = 0 ∨ ∃ k : ℕ, i = k + 2 := nat.eq_zero_or_exists_eq_add_of_ne_one hi,
        cases hi with hi hi,
        { rw hi, refl },
        { rcases hi with ⟨k, rfl⟩, refl }
  }}},
  d_comp_d' := by {
    intros i j k hij hjk,
    by_cases hi : i = 1,
    { simp only [hi, complex_shape.down_rel, add_left_eq_self] at hij,
      simp only [hij, complex_shape.down_rel, nat.succ_ne_zero] at hjk,
      contradiction
    },
    { have hi : i = 0 ∨ ∃ k : ℕ, i = k + 2 := nat.eq_zero_or_exists_eq_add_of_ne_one hi,
      cases hi with hi hi,
      { rw hi, simp only [two_step_resolution_ab_d, zero_comp]},
      { rcases hi with ⟨k, rfl⟩, simp only [two_step_resolution_ab_d, zero_comp]}
  }}
}

/-- The surjective homomorphism from the two step "resolution" of a module over a commutative ring
    to the module. -/
def two_step_resolution_hom :
(two_step_resolution R M) ⟶ ((chain_complex.single₀ (Module.{max u v} R)).obj (of R M)) :=
begin
  apply (chain_complex.to_single₀_equiv (two_step_resolution R M) (of R M)).inv_fun,
  refine ⟨finsupp.total M M R id, _⟩,
  ext,
  rw category_theory.comp_apply,
  dunfold two_step_resolution,
  simp [two_step_resolution_d, Module.as_hom]
end

/-- The surjective homomorphism from the two step projective resolution of an Abelian group to the
    group. -/
def two_step_resolution_hom_ab (M : Type v) [add_comm_group M] :
(two_step_resolution_ab M) ⟶ ((chain_complex.single₀ AddCommGroup.{v}).obj (AddCommGroup.of M)) :=
begin
  apply (chain_complex.to_single₀_equiv (two_step_resolution_ab M) (AddCommGroup.of M)).inv_fun,
  refine ⟨(finsupp.total M M ℤ id).to_add_monoid_hom, _⟩,
  ext,
  rw category_theory.comp_apply,
  dunfold two_step_resolution_ab,
  simp [two_step_resolution_ab_d, AddCommGroup.of_hom]
end

/-- The two step resolution of a module over a principal ideal domain is a projective resolution. -/
theorem two_step_resolution_projective_pid [is_domain R] [is_principal_ideal_ring R] :
  (two_step_resolution R M).is_projective_resolution (of R M) (two_step_resolution_hom R M) :=
begin
  refine ⟨_, _, _, _⟩,
  { -- Projectivity.
    intro n,
    by_cases hn : n = 0,
    simp only [hn, two_step_resolution, two_step_resolution_X],
    apply_instance,

    by_cases hn' : n = 1,
    simp only [hn'],
    dsimp only [two_step_resolution, two_step_resolution_X],
    -- apply_instance,  -- fails because of universe unification issues
    apply Module.projective_of_of_projective.{u v},

    have hn : ∃ m : ℕ, n = m + 2,
    { have := nat.eq_zero_or_exists_eq_add_of_ne_one hn',
      simp only [hn, false_or] at this,
      exact this
    },
    rcases hn with ⟨m, rfl⟩,
    dsimp only [two_step_resolution, two_step_resolution_X],
    apply_instance
  },

  { -- Exactness at degree zero.
    dsimp [two_step_resolution, two_step_resolution_hom, Module.as_hom, chain_complex.to_single₀_equiv, two_step_resolution_d],
    rw Module.exact_iff,
    simp only [submodule.range_subtype]
  },

  { -- Exactness at positive degrees.
    dsimp only [two_step_resolution, Module.as_hom, auto_param_eq],
    intro n,
    by_cases hn : n = 0,
    { -- Exactness at degree one.
      rw [hn, zero_add 2, zero_add 1],
      dsimp only [two_step_resolution_d, Module.as_hom],
      haveI : mono (Module.as_hom ((finsupp.total M M R id).ker.subtype)),
      { rw Module.mono_iff_injective,
        dsimp only [Module.as_hom],
        exact submodule.injective_subtype (finsupp.total M M R id).ker
      },
      exact_mod_cast category_theory.exact_zero_mono (Module.as_hom ((finsupp.total M M R id).ker.subtype))
    },
    { -- Exactness at degrees greater than one.
      have hn : ∃ k : ℕ, n = k + 1,
      { have := nat.exists_eq_add_of_le (nat.one_le_iff_ne_zero.2 hn),
        simpa only [add_comm]
      },
      rcases hn with ⟨k, rfl⟩,
      dsimp only [two_step_resolution_d],
      apply category_theory.exact_of_zero
    }
  },
  { -- Surjectivity.
    dsimp only [two_step_resolution_hom, chain_complex.to_single₀_equiv, auto_param_eq],
    have : epi (Module.as_hom ((finsupp.total M M R id))),
    rw Module.epi_iff_surjective,
    dsimp only [Module.as_hom],
    exact finsupp.total_surjective R (function.surjective_id),
    exact this
  }
end

-- lemma coe_of' : (of R M : Type (max u v)) = M := rfl

lemma Module.coe_of'' (M : Module.{v} R) : (of R M) = M :=
begin
  cases M,
  dsimp [of, coe_sort, has_coe_to_sort.coe],
  refl
end

lemma AddCommGroup.coe_of' (M : AddCommGroup.{v}) : (AddCommGroup.of M) = M := by cases M; refl

lemma add_submonoid.injective_subtype {M : Type v} [add_comm_monoid M] (p : add_submonoid M) : function.injective p.subtype :=
subtype.coe_injective

/-- An ℤ-module considered as an Abelian group  is projective if it is projective as a ℤ-module. -/
@[instance]
lemma AddCommGroup.projective_of_Z_Module_projective (M : Module.{v} ℤ) [projective M] :
projective (AddCommGroup.of M) :=
begin
  refine ⟨_⟩,
  intros,
  let e' : (forget₂ (Module.{v} ℤ) AddCommGroup).obj (Module.of ℤ E) ⟶ (forget₂ (Module.{v} ℤ) AddCommGroup).obj (Module.of ℤ X) := e,
  let eM := full.preimage e',
  let f' : (forget₂ (Module.{v} ℤ) AddCommGroup).obj (Module.of ℤ M) ⟶ (forget₂ (Module.{v} ℤ) AddCommGroup).obj (Module.of ℤ X) := f,
  let fM := full.preimage f',
  haveI : epi eM,
  { apply functor.epi_of_epi_map (forget₂ (Module.{v} ℤ) AddCommGroup.{v}) _,
    rw full.witness,
    apply epi.mk,
    intros Z g h H,
    let g' : X ⟶ Z := g,
    let h' : X ⟶ Z := h,
    have H : e ≫ g' = e ≫ h' := H,
    --rw cancel_epi at H,    -- "failed to synthesize type class instance for epi e"
    rw @cancel_epi _ _ _ _ _ _ _inst_2 _ _ at H,
    exact H },
  haveI : projective (of ℤ M) := by rw [Module.coe_of'' ℤ M]; apply_instance,
  let pM := projective.factor_thru fM eM,
  use (forget₂ (Module.{v} ℤ) AddCommGroup).map pM,
  have hpM := projective.factor_thru_comp fM eM,
  have h : (forget₂ (Module.{v} ℤ) AddCommGroup).map (projective.factor_thru fM eM ≫ eM) = (forget₂ (Module.{v} ℤ) AddCommGroup).map fM := by simp only [hpM],
  rw functor.map_comp at h,
  simp only [full.witness] at h,
  exact h
end

/-- The two step resolution of an Abelian group is a projective resolution. -/
lemma two_step_resolution_ab_projective (M : Type v) [add_comm_group M] :
  (two_step_resolution_ab M).is_projective_resolution (AddCommGroup.of M) (two_step_resolution_hom_ab M) :=
begin
  refine ⟨_, _, _, _⟩,
  { -- Projectivity.
    intro n,
    by_cases hn : n = 0,
    simp only [hn, two_step_resolution_ab, two_step_resolution_ab_X],
    exact AddCommGroup.projective_of_Z_Module_projective (Module.of.{v} ℤ (M →₀ ℤ)),
    -- apply_instance,  -- fails

    by_cases hn' : n = 1,
    simp only [hn'],
    dsimp only [two_step_resolution_ab, two_step_resolution_ab_X],
    exact AddCommGroup.projective_of_Z_Module_projective (Module.of.{v} ℤ(finsupp.total M M ℤ id).ker),
    -- apply_instance,  -- fails

    have hn : ∃ m : ℕ, n = m + 2,
    { have := nat.eq_zero_or_exists_eq_add_of_ne_one hn',
      simp only [hn, false_or] at this,
      exact this
    },
    rcases hn with ⟨m, rfl⟩,
    dsimp only [two_step_resolution_ab, two_step_resolution_ab_X],
    apply_instance
  },

  { -- Exactness at degree zero.
    dsimp [two_step_resolution_ab, two_step_resolution_hom_ab, AddCommGroup.of_hom, chain_complex.to_single₀_equiv, two_step_resolution_ab_d],
    rw AddCommGroup.exact_iff,
    simp only [add_subgroup.subtype_range]
  },

  { -- Exactness at positive degrees.
    dsimp only [two_step_resolution, Module.as_hom, auto_param_eq],
    intro n,
    by_cases hn : n = 0,
    { -- Exactness at degree one.
      rw [hn, zero_add 2, zero_add 1],
      dsimp only [two_step_resolution_ab, two_step_resolution_ab_d, AddCommGroup.of_hom],
      haveI : mono (AddCommGroup.of_hom (add_subgroup.subtype (finsupp.total M M ℤ id).to_add_monoid_hom.ker)),
      { rw AddCommGroup.mono_iff_injective,
        dsimp only [AddCommGroup.of_hom],
        exact add_submonoid.injective_subtype _
      },
      exact_mod_cast category_theory.exact_zero_mono (AddCommGroup.of_hom (add_subgroup.subtype (finsupp.total M M ℤ id).to_add_monoid_hom.ker))
    },
    { -- Exactness at degrees greater than one.
      have hn : ∃ k : ℕ, n = k + 1,
      { have := nat.exists_eq_add_of_le (nat.one_le_iff_ne_zero.2 hn),
        simpa only [add_comm]
      },
      rcases hn with ⟨k, rfl⟩,
      dsimp only [two_step_resolution_ab, two_step_resolution_ab_d],
      apply category_theory.exact_of_zero
    }
  },
  { -- Surjectivity.
    dsimp only [two_step_resolution_hom, chain_complex.to_single₀_equiv, auto_param_eq],
    have : epi (AddCommGroup.of_hom (finsupp.total M M ℤ id).to_add_monoid_hom),
    rw AddCommGroup.epi_iff_surjective,
    dsimp only [AddCommGroup.of_hom],
    exact finsupp.total_surjective ℤ (function.surjective_id),
    exact this
  }
end


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.category.Ring.basic
import category_theory.limits.has_limits
import category_theory.limits.concrete_category

/-!
# The category of commutative rings has all colimits.

This file uses a "pre-automated" approach, just as for `Mon/colimits.lean`.
It is a very uniform approach, that conceivably could be synthesised directly
by a tactic that analyses the shape of `comm_ring` and `ring_hom`.
-/

universes u v

open category_theory
open category_theory.limits

-- [ROBOT VOICE]:
-- You should pretend for now that this file was automatically generated.
-- It follows the same template as colimits in Mon.
/-
`#print comm_ring` says:

structure comm_ring : Type u → Type u
fields:
comm_ring.zero : Π (α : Type u) [c : comm_ring α], α
comm_ring.one : Π (α : Type u) [c : comm_ring α], α
comm_ring.neg : Π {α : Type u} [c : comm_ring α], α → α
comm_ring.add : Π {α : Type u} [c : comm_ring α], α → α → α
comm_ring.mul : Π {α : Type u} [c : comm_ring α], α → α → α

comm_ring.zero_add : ∀ {α : Type u} [c : comm_ring α] (a : α), 0 + a = a
comm_ring.add_zero : ∀ {α : Type u} [c : comm_ring α] (a : α), a + 0 = a
comm_ring.one_mul : ∀ {α : Type u} [c : comm_ring α] (a : α), 1 * a = a
comm_ring.mul_one : ∀ {α : Type u} [c : comm_ring α] (a : α), a * 1 = a
comm_ring.add_left_neg : ∀ {α : Type u} [c : comm_ring α] (a : α), -a + a = 0
comm_ring.add_comm : ∀ {α : Type u} [c : comm_ring α] (a b : α), a + b = b + a
comm_ring.mul_comm : ∀ {α : Type u} [c : comm_ring α] (a b : α), a * b = b * a
comm_ring.add_assoc : ∀ {α : Type u} [c : comm_ring α] (a b c_1 : α), a + b + c_1 = a + (b + c_1)
comm_ring.mul_assoc : ∀ {α : Type u} [c : comm_ring α] (a b c_1 : α), a * b * c_1 = a * (b * c_1)
comm_ring.left_distrib : ∀ {α : Type u} [c : comm_ring α] (a b c_1 : α),
                                                            a * (b + c_1) = a * b + a * c_1
comm_ring.right_distrib : ∀ {α : Type u} [c : comm_ring α] (a b c_1 : α),
                                                            (a + b) * c_1 = a * c_1 + b * c_1
-/

namespace CommRing.colimits
/-!
We build the colimit of a diagram in `CommRing` by constructing the
free commutative ring on the disjoint union of all the commutative rings in the diagram,
then taking the quotient by the commutative ring laws within each commutative ring,
and the identifications given by the morphisms in the diagram.
-/

variables {J : Type v} [small_category J] (F : J ⥤ CommRing.{v})

/--
An inductive type representing all commutative ring expressions (without relations)
on a collection of types indexed by the objects of `J`.
-/
inductive prequotient
-- There's always `of`
| of : Π (j : J) (x : F.obj j), prequotient
-- Then one generator for each operation
| zero : prequotient
| one : prequotient
| neg : prequotient → prequotient
| add : prequotient → prequotient → prequotient
| mul : prequotient → prequotient → prequotient

instance : inhabited (prequotient F) := ⟨prequotient.zero⟩

open prequotient

/--
The relation on `prequotient` saying when two expressions are equal
because of the commutative ring laws, or
because one element is mapped to another by a morphism in the diagram.
-/
inductive relation : prequotient F → prequotient F → Prop
-- Make it an equivalence relation:
| refl : Π (x), relation x x
| symm : Π (x y) (h : relation x y), relation y x
| trans : Π (x y z) (h : relation x y) (k : relation y z), relation x z
-- There's always a `map` relation
| map : Π (j j' : J) (f : j ⟶ j') (x : F.obj j), relation (of j' (F.map f x)) (of j x)
-- Then one relation per operation, describing the interaction with `of`
| zero : Π (j), relation (of j 0) zero
| one : Π (j), relation (of j 1) one
| neg : Π (j) (x : F.obj j), relation (of j (-x)) (neg (of j x))
| add : Π (j) (x y : F.obj j), relation (of j (x + y)) (add (of j x) (of j y))
| mul : Π (j) (x y : F.obj j), relation (of j (x * y)) (mul (of j x) (of j y))
-- Then one relation per argument of each operation
| neg_1 : Π (x x') (r : relation x x'), relation (neg x) (neg x')
| add_1 : Π (x x' y) (r : relation x x'), relation (add x y) (add x' y)
| add_2 : Π (x y y') (r : relation y y'), relation (add x y) (add x y')
| mul_1 : Π (x x' y) (r : relation x x'), relation (mul x y) (mul x' y)
| mul_2 : Π (x y y') (r : relation y y'), relation (mul x y) (mul x y')
-- And one relation per axiom
| zero_add      : Π (x), relation (add zero x) x
| add_zero      : Π (x), relation (add x zero) x
| one_mul       : Π (x), relation (mul one x) x
| mul_one       : Π (x), relation (mul x one) x
| add_left_neg  : Π (x), relation (add (neg x) x) zero
| add_comm      : Π (x y), relation (add x y) (add y x)
| mul_comm      : Π (x y), relation (mul x y) (mul y x)
| add_assoc     : Π (x y z), relation (add (add x y) z) (add x (add y z))
| mul_assoc     : Π (x y z), relation (mul (mul x y) z) (mul x (mul y z))
| left_distrib  : Π (x y z), relation (mul x (add y z)) (add (mul x y) (mul x z))
| right_distrib : Π (x y z), relation (mul (add x y) z) (add (mul x z) (mul y z))

/--
The setoid corresponding to commutative expressions modulo monoid relations and identifications.
-/
def colimit_setoid : setoid (prequotient F) :=
{ r := relation F, iseqv := ⟨relation.refl, relation.symm, relation.trans⟩ }
attribute [instance] colimit_setoid

/--
The underlying type of the colimit of a diagram in `CommRing`.
-/
@[derive inhabited]
def colimit_type : Type v := quotient (colimit_setoid F)

instance : add_group (colimit_type F) :=
{ zero :=
  begin
    exact quot.mk _ zero
  end,
  neg :=
  begin
    fapply @quot.lift,
    { intro x,
      exact quot.mk _ (neg x) },
    { intros x x' r,
      apply quot.sound,
      exact relation.neg_1 _ _ r },
  end,
  add :=
  begin
    fapply @quot.lift _ _ ((colimit_type F) → (colimit_type F)),
    { intro x,
      fapply @quot.lift,
      { intro y,
        exact quot.mk _ (add x y) },
      { intros y y' r,
        apply quot.sound,
        exact relation.add_2 _ _ _ r } },
    { intros x x' r,
      funext y,
      induction y,
      dsimp,
      apply quot.sound,
      { exact relation.add_1 _ _ _ r },
      { refl } },
  end,
  zero_add := λ x,
  begin
    induction x,
    dsimp,
    apply quot.sound,
    apply relation.zero_add,
    refl,
  end,
  add_zero := λ x,
  begin
    induction x,
    dsimp,
    apply quot.sound,
    apply relation.add_zero,
    refl,
  end,
  add_left_neg := λ x,
  begin
    induction x,
    dsimp,
    apply quot.sound,
    apply relation.add_left_neg,
    refl,
  end,
  add_assoc := λ x y z,
  begin
    induction x,
    induction y,
    induction z,
    dsimp,
    apply quot.sound,
    apply relation.add_assoc,
    refl,
    refl,
    refl,
  end }

instance : add_group_with_one (colimit_type F) :=
{ one :=
  begin
    exact quot.mk _ one
  end,
  .. colimit_type.add_group F }

instance : comm_ring (colimit_type F) :=
{ one :=
  begin
    exact quot.mk _ one
  end,
  mul :=
  begin
    fapply @quot.lift _ _ ((colimit_type F) → (colimit_type F)),
    { intro x,
      fapply @quot.lift,
      { intro y,
        exact quot.mk _ (mul x y) },
      { intros y y' r,
        apply quot.sound,
        exact relation.mul_2 _ _ _ r } },
    { intros x x' r,
      funext y,
      induction y,
      dsimp,
      apply quot.sound,
      { exact relation.mul_1 _ _ _ r },
      { refl } },
  end,
  one_mul := λ x,
  begin
    induction x,
    dsimp,
    apply quot.sound,
    apply relation.one_mul,
    refl,
  end,
  mul_one := λ x,
  begin
    induction x,
    dsimp,
    apply quot.sound,
    apply relation.mul_one,
    refl,
  end,
  add_comm := λ x y,
  begin
    induction x,
    induction y,
    dsimp,
    apply quot.sound,
    apply relation.add_comm,
    refl,
    refl,
  end,
  mul_comm := λ x y,
  begin
    induction x,
    induction y,
    dsimp,
    apply quot.sound,
    apply relation.mul_comm,
    refl,
    refl,
  end,
  add_assoc := λ x y z,
  begin
    induction x,
    induction y,
    induction z,
    dsimp,
    apply quot.sound,
    apply relation.add_assoc,
    refl,
    refl,
    refl,
  end,
  mul_assoc := λ x y z,
  begin
    induction x,
    induction y,
    induction z,
    dsimp,
    apply quot.sound,
    apply relation.mul_assoc,
    refl,
    refl,
    refl,
  end,
  left_distrib := λ x y z,
  begin
    induction x,
    induction y,
    induction z,
    dsimp,
    apply quot.sound,
    apply relation.left_distrib,
    refl,
    refl,
    refl,
  end,
  right_distrib := λ x y z,
  begin
    induction x,
    induction y,
    induction z,
    dsimp,
    apply quot.sound,
    apply relation.right_distrib,
    refl,
    refl,
    refl,
  end,
  .. colimit_type.add_group_with_one F }

@[simp] lemma quot_zero : quot.mk setoid.r zero = (0 : colimit_type F) := rfl
@[simp] lemma quot_one : quot.mk setoid.r one = (1 : colimit_type F) := rfl
@[simp] lemma quot_neg (x) :
  quot.mk setoid.r (neg x) = (-(quot.mk setoid.r x) : colimit_type F) := rfl
@[simp] lemma quot_add (x y) :
  quot.mk setoid.r (add x y) = ((quot.mk setoid.r x) + (quot.mk setoid.r y) : colimit_type F) := rfl
@[simp] lemma quot_mul (x y) :
  quot.mk setoid.r (mul x y) = ((quot.mk setoid.r x) * (quot.mk setoid.r y) : colimit_type F) := rfl

/-- The bundled commutative ring giving the colimit of a diagram. -/
def colimit : CommRing := CommRing.of (colimit_type F)

/-- The function from a given commutative ring in the diagram to the colimit commutative ring. -/
def cocone_fun (j : J) (x : F.obj j) : colimit_type F :=
quot.mk _ (of j x)

/-- The ring homomorphism from a given commutative ring in the diagram to the colimit commutative
ring. -/
def cocone_morphism (j : J) : F.obj j ⟶ colimit F :=
{ to_fun := cocone_fun F j,
  map_one' := by apply quot.sound; apply relation.one,
  map_mul' := by intros; apply quot.sound; apply relation.mul,
  map_zero' := by apply quot.sound; apply relation.zero,
  map_add' := by intros; apply quot.sound; apply relation.add }

@[simp] lemma cocone_naturality {j j' : J} (f : j ⟶ j') :
  F.map f ≫ (cocone_morphism F j') = cocone_morphism F j :=
begin
  ext,
  apply quot.sound,
  apply relation.map,
end

@[simp] lemma cocone_naturality_components (j j' : J) (f : j ⟶ j') (x : F.obj j):
  (cocone_morphism F j') (F.map f x) = (cocone_morphism F j) x :=
by { rw ←cocone_naturality F f, refl }

/-- The cocone over the proposed colimit commutative ring. -/
def colimit_cocone : cocone F :=
{ X := colimit F,
  ι :=
  { app := cocone_morphism F } }.

/-- The function from the free commutative ring on the diagram to the cone point of any other
cocone. -/
@[simp] def desc_fun_lift (s : cocone F) : prequotient F → s.X
| (of j x)  := (s.ι.app j) x
| zero      := 0
| one       := 1
| (neg x)   := -(desc_fun_lift x)
| (add x y) := desc_fun_lift x + desc_fun_lift y
| (mul x y) := desc_fun_lift x * desc_fun_lift y

/-- The function from the colimit commutative ring to the cone point of any other cocone. -/
def desc_fun (s : cocone F) : colimit_type F → s.X :=
begin
  fapply quot.lift,
  { exact desc_fun_lift F s },
  { intros x y r,
    induction r; try { dsimp },
    -- refl
    { refl },
    -- symm
    { exact r_ih.symm },
    -- trans
    { exact eq.trans r_ih_h r_ih_k },
    -- map
    { simp, },
    -- zero
    { simp, },
    -- one
    { simp, },
    -- neg
    { simp, },
    -- add
    { simp, },
    -- mul
    { simp, },
    -- neg_1
    { rw r_ih, },
    -- add_1
    { rw r_ih, },
    -- add_2
    { rw r_ih, },
    -- mul_1
    { rw r_ih, },
    -- mul_2
    { rw r_ih, },
    -- zero_add
    { rw zero_add, },
    -- add_zero
    { rw add_zero, },
    -- one_mul
    { rw one_mul, },
    -- mul_one
    { rw mul_one, },
    -- add_left_neg
    { rw add_left_neg, },
    -- add_comm
    { rw add_comm, },
    -- mul_comm
    { rw mul_comm, },
    -- add_assoc
    { rw add_assoc, },
    -- mul_assoc
    { rw mul_assoc, },
    -- left_distrib
    { rw left_distrib, },
    -- right_distrib
    { rw right_distrib, } }
end

/-- The ring homomorphism from the colimit commutative ring to the cone point of any other
cocone. -/
def desc_morphism (s : cocone F) : colimit F ⟶ s.X :=
{ to_fun := desc_fun F s,
  map_one' := rfl,
  map_zero' := rfl,
  map_add' := λ x y, by { induction x; induction y; refl },
  map_mul' := λ x y, by { induction x; induction y; refl }, }

/-- Evidence that the proposed colimit is the colimit. -/
def colimit_is_colimit : is_colimit (colimit_cocone F) :=
{ desc := λ s, desc_morphism F s,
  uniq' := λ s m w,
  begin
    ext,
    induction x,
    induction x,
    { have w' := congr_fun (congr_arg (λ f : F.obj x_j ⟶ s.X, (f : F.obj x_j → s.X)) (w x_j)) x_x,
      erw w',
      refl, },
    { simp, },
    { simp, },
    { simp *, },
    { simp *, },
    { simp *, },
    refl
  end }.

instance has_colimits_CommRing : has_colimits CommRing :=
{ has_colimits_of_shape := λ J 𝒥, by exactI
  { has_colimit := λ F, has_colimit.mk
    { cocone := colimit_cocone F,
      is_colimit := colimit_is_colimit F } } }

end CommRing.colimits


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.sheaves.sheaf
import Mathlib.category_theory.limits.preserves.basic
import Mathlib.category_theory.category.pairwise
import Mathlib.PostPort

universes v u

namespace Mathlib

/-!
# Equivalent formulations of the sheaf condition

We give an equivalent formulation of the sheaf condition.

Given any indexed type `ι`, we define `overlap ι`,
a category with objects corresponding to
* individual open sets, `single i`, and
* intersections of pairs of open sets, `pair i j`,
with morphisms from `pair i j` to both `single i` and `single j`.

Any open cover `U : ι → opens X` provides a functor `diagram U : overlap ι ⥤ (opens X)ᵒᵖ`.

There is a canonical cone over this functor, `cone U`, whose cone point is `supr U`,
and in fact this is a limit cone.

A presheaf `F : presheaf C X` is a sheaf precisely if it preserves this limit.
We express this in two equivalent ways, as
* `is_limit (F.map_cone (cone U))`, or
* `preserves_limit (diagram U) F`
-/

namespace Top.presheaf

/--
An alternative formulation of the sheaf condition
(which we prove equivalent to the usual one below as
`sheaf_condition_equiv_sheaf_condition_pairwise_intersections`).

A presheaf is a sheaf if `F` sends the cone `(pairwise.cocone U).op` to a limit cone.
(Recall `pairwise.cocone U`, has cone point `supr U`, mapping down to the `U i` and the `U i ⊓ U j`.)
-/
def sheaf_condition_pairwise_intersections {X : Top} {C : Type u} [category_theory.category C] (F : presheaf C X) :=
  {ι : Type v} →
    (U : ι → topological_space.opens ↥X) →
      category_theory.limits.is_limit
        (category_theory.functor.map_cone F (category_theory.limits.cocone.op (category_theory.pairwise.cocone U)))

/--
An alternative formulation of the sheaf condition
(which we prove equivalent to the usual one below as
`sheaf_condition_equiv_sheaf_condition_preserves_limit_pairwise_intersections`).

A presheaf is a sheaf if `F` preserves the limit of `pairwise.diagram U`.
(Recall `pairwise.diagram U` is the diagram consisting of the pairwise intersections
`U i ⊓ U j` mapping into the open sets `U i`. This diagram has limit `supr U`.)
-/
def sheaf_condition_preserves_limit_pairwise_intersections {X : Top} {C : Type u} [category_theory.category C] (F : presheaf C X) :=
  {ι : Type v} →
    (U : ι → topological_space.opens ↥X) →
      category_theory.limits.preserves_limit (category_theory.functor.op (category_theory.pairwise.diagram U)) F

/-!
The remainder of this file shows that these conditions are equivalent
to the usual sheaf condition.
-/

namespace sheaf_condition_pairwise_intersections

/-- Implementation of `sheaf_condition_pairwise_intersections.cone_equiv`. -/
def cone_equiv_functor_obj {X : Top} {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] (F : presheaf C X) {ι : Type v} (U : ι → topological_space.opens ↥X) (c : category_theory.limits.cone (category_theory.functor.op (category_theory.pairwise.diagram U) ⋙ F)) : category_theory.limits.cone (sheaf_condition_equalizer_products.diagram F U) :=
  category_theory.limits.cone.mk (category_theory.limits.cone.X c)
    (category_theory.nat_trans.mk
      fun (Z : category_theory.limits.walking_parallel_pair) =>
        category_theory.limits.walking_parallel_pair.cases_on Z
          (category_theory.limits.pi.lift
            fun (i : ι) =>
              category_theory.nat_trans.app (category_theory.limits.cone.π c)
                (opposite.op (category_theory.pairwise.single i)))
          (category_theory.limits.pi.lift
            fun (b : ι × ι) =>
              category_theory.nat_trans.app (category_theory.limits.cone.π c)
                (opposite.op (category_theory.pairwise.pair (prod.fst b) (prod.snd b)))))

/-- Implementation of `sheaf_condition_pairwise_intersections.cone_equiv`. -/
def cone_equiv_functor {X : Top} {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] (F : presheaf C X) {ι : Type v} (U : ι → topological_space.opens ↥X) : category_theory.limits.cone (category_theory.functor.op (category_theory.pairwise.diagram U) ⋙ F) ⥤
  category_theory.limits.cone (sheaf_condition_equalizer_products.diagram F U) :=
  category_theory.functor.mk
    (fun (c : category_theory.limits.cone (category_theory.functor.op (category_theory.pairwise.diagram U) ⋙ F)) =>
      cone_equiv_functor_obj F U c)
    fun (c c' : category_theory.limits.cone (category_theory.functor.op (category_theory.pairwise.diagram U) ⋙ F))
      (f : c ⟶ c') => category_theory.limits.cone_morphism.mk (category_theory.limits.cone_morphism.hom f)

/-- Implementation of `sheaf_condition_pairwise_intersections.cone_equiv`. -/
@[simp] theorem cone_equiv_inverse_obj_π_app {X : Top} {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] (F : presheaf C X) {ι : Type v} (U : ι → topological_space.opens ↥X) (c : category_theory.limits.cone (sheaf_condition_equalizer_products.diagram F U)) (x : category_theory.pairwise ιᵒᵖ) : category_theory.nat_trans.app (category_theory.limits.cone.π (cone_equiv_inverse_obj F U c)) x =
  opposite.op_induction
    (fun (x : category_theory.pairwise ι) =>
      category_theory.pairwise.cases_on x
        (fun (i : ι) =>
          category_theory.nat_trans.app (category_theory.limits.cone.π c)
              category_theory.limits.walking_parallel_pair.zero ≫
            category_theory.limits.pi.π (fun (i : ι) => category_theory.functor.obj F (opposite.op (U i))) i)
        fun (i j : ι) =>
          category_theory.nat_trans.app (category_theory.limits.cone.π c)
              category_theory.limits.walking_parallel_pair.one ≫
            category_theory.limits.pi.π
              (fun (p : ι × ι) => category_theory.functor.obj F (opposite.op (U (prod.fst p) ⊓ U (prod.snd p)))) (i, j))
    x :=
  Eq.refl (category_theory.nat_trans.app (category_theory.limits.cone.π (cone_equiv_inverse_obj F U c)) x)

/-- Implementation of `sheaf_condition_pairwise_intersections.cone_equiv`. -/
@[simp] theorem cone_equiv_inverse_map_hom {X : Top} {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] (F : presheaf C X) {ι : Type v} (U : ι → topological_space.opens ↥X) (c : category_theory.limits.cone (sheaf_condition_equalizer_products.diagram F U)) (c' : category_theory.limits.cone (sheaf_condition_equalizer_products.diagram F U)) (f : c ⟶ c') : category_theory.limits.cone_morphism.hom (category_theory.functor.map (cone_equiv_inverse F U) f) =
  category_theory.limits.cone_morphism.hom f :=
  Eq.refl (category_theory.limits.cone_morphism.hom (category_theory.functor.map (cone_equiv_inverse F U) f))

/-- Implementation of `sheaf_condition_pairwise_intersections.cone_equiv`. -/
def cone_equiv_unit_iso_app {X : Top} {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] (F : presheaf C X) {ι : Type v} (U : ι → topological_space.opens ↥X) (c : category_theory.limits.cone (category_theory.functor.op (category_theory.pairwise.diagram U) ⋙ F)) : category_theory.functor.obj 𝟭 c ≅ category_theory.functor.obj (cone_equiv_functor F U ⋙ cone_equiv_inverse F U) c :=
  category_theory.iso.mk (category_theory.limits.cone_morphism.mk 𝟙) (category_theory.limits.cone_morphism.mk 𝟙)

/-- Implementation of `sheaf_condition_pairwise_intersections.cone_equiv`. -/
@[simp] theorem cone_equiv_unit_iso_hom_app_hom {X : Top} {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] (F : presheaf C X) {ι : Type v} (U : ι → topological_space.opens ↥X) : ∀ (X_1 : category_theory.limits.cone (category_theory.functor.op (category_theory.pairwise.diagram U) ⋙ F)),
  category_theory.limits.cone_morphism.hom
      (category_theory.nat_trans.app (category_theory.iso.hom (cone_equiv_unit_iso F U)) X_1) =
    𝟙 :=
  fun (X_1 : category_theory.limits.cone (category_theory.functor.op (category_theory.pairwise.diagram U) ⋙ F)) =>
    Eq.refl 𝟙

/-- Implementation of `sheaf_condition_pairwise_intersections.cone_equiv`. -/
@[simp] theorem cone_equiv_counit_iso_hom_app_hom {X : Top} {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] (F : presheaf C X) {ι : Type v} (U : ι → topological_space.opens ↥X) : ∀ (X_1 : category_theory.limits.cone (sheaf_condition_equalizer_products.diagram F U)),
  category_theory.limits.cone_morphism.hom
      (category_theory.nat_trans.app (category_theory.iso.hom (cone_equiv_counit_iso F U)) X_1) =
    𝟙 :=
  fun (X_1 : category_theory.limits.cone (sheaf_condition_equalizer_products.diagram F U)) => Eq.refl 𝟙

/--
Cones over `diagram U ⋙ F` are the same as a cones over the usual sheaf condition equalizer diagram.
-/
@[simp] theorem cone_equiv_functor_2 {X : Top} {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] (F : presheaf C X) {ι : Type v} (U : ι → topological_space.opens ↥X) : category_theory.equivalence.functor (cone_equiv F U) = cone_equiv_functor F U :=
  Eq.refl (category_theory.equivalence.functor (cone_equiv F U))

/--
If `sheaf_condition_equalizer_products.fork` is an equalizer,
then `F.map_cone (cone U)` is a limit cone.
-/
def is_limit_map_cone_of_is_limit_sheaf_condition_fork {X : Top} {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] (F : presheaf C X) {ι : Type v} (U : ι → topological_space.opens ↥X) (P : category_theory.limits.is_limit (sheaf_condition_equalizer_products.fork F U)) : category_theory.limits.is_limit
  (category_theory.functor.map_cone F (category_theory.limits.cocone.op (category_theory.pairwise.cocone U))) :=
  category_theory.limits.is_limit.of_iso_limit
    (coe_fn
      (equiv.symm (category_theory.limits.is_limit.of_cone_equiv (category_theory.equivalence.symm (cone_equiv F U)))) P)
    (category_theory.iso.mk (category_theory.limits.cone_morphism.mk 𝟙) (category_theory.limits.cone_morphism.mk 𝟙))

/--
If `F.map_cone (cone U)` is a limit cone,
then `sheaf_condition_equalizer_products.fork` is an equalizer.
-/
def is_limit_sheaf_condition_fork_of_is_limit_map_cone {X : Top} {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] (F : presheaf C X) {ι : Type v} (U : ι → topological_space.opens ↥X) (Q : category_theory.limits.is_limit
  (category_theory.functor.map_cone F (category_theory.limits.cocone.op (category_theory.pairwise.cocone U)))) : category_theory.limits.is_limit (sheaf_condition_equalizer_products.fork F U) :=
  category_theory.limits.is_limit.of_iso_limit
    (coe_fn (equiv.symm (category_theory.limits.is_limit.of_cone_equiv (cone_equiv F U))) Q)
    (category_theory.iso.mk (category_theory.limits.cone_morphism.mk 𝟙) (category_theory.limits.cone_morphism.mk 𝟙))

end sheaf_condition_pairwise_intersections

/--
The sheaf condition in terms of an equalizer diagram is equivalent
to the reformulation in terms of a limit diagram over `U i` and `U i ⊓ U j`.
-/
def sheaf_condition_equiv_sheaf_condition_pairwise_intersections {X : Top} {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] (F : presheaf C X) : sheaf_condition F ≃ sheaf_condition_pairwise_intersections F :=
  equiv.Pi_congr_right
    fun (i : Type v) =>
      equiv.Pi_congr_right
        fun (U : i → topological_space.opens ↥X) =>
          equiv_of_subsingleton_of_subsingleton
            (sheaf_condition_pairwise_intersections.is_limit_map_cone_of_is_limit_sheaf_condition_fork F U)
            (sheaf_condition_pairwise_intersections.is_limit_sheaf_condition_fork_of_is_limit_map_cone F U)

/--
The sheaf condition in terms of an equalizer diagram is equivalent
to the reformulation in terms of the presheaf preserving the limit of the diagram
consisting of the `U i` and `U i ⊓ U j`.
-/
def sheaf_condition_equiv_sheaf_condition_preserves_limit_pairwise_intersections {X : Top} {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] (F : presheaf C X) : sheaf_condition F ≃ sheaf_condition_preserves_limit_pairwise_intersections F := sorry


/-
Copyright © 2020 Nicolò Cavalleri. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Nicolò Cavalleri
-/

import geometry.manifold.algebra.smooth_functions
import ring_theory.derivation

/-!

# Derivation bundle

In this file we define the derivations at a point of a manifold on the algebra of smooth fuctions.
Moreover, we define the differential of a function in terms of derivations.

The content of this file is not meant to be regarded as an alternative definition to the current
tangent bundle but rather as a purely algebraic theory that provides a purely algebraic definition
of the Lie algebra for a Lie group.

-/

variables (𝕜 : Type*) [nontrivially_normed_field 𝕜]
{E : Type*} [normed_add_comm_group E] [normed_space 𝕜 E]
{H : Type*} [topological_space H] (I : model_with_corners 𝕜 E H)
(M : Type*) [topological_space M] [charted_space H M] (n : ℕ∞)

open_locale manifold

-- the following two instances prevent poorly understood type class inference timeout problems
instance smooth_functions_algebra : algebra 𝕜 C^∞⟮I, M; 𝕜⟯ := by apply_instance
instance smooth_functions_tower : is_scalar_tower 𝕜 C^∞⟮I, M; 𝕜⟯ C^∞⟮I, M; 𝕜⟯ := by apply_instance

/-- Type synonym, introduced to put a different `has_smul` action on `C^n⟮I, M; 𝕜⟯`
which is defined as `f • r = f(x) * r`. -/
@[nolint unused_arguments] def pointed_smooth_map (x : M) := C^n⟮I, M; 𝕜⟯

localized "notation (name := pointed_smooth_map) `C^` n `⟮` I `, ` M `; ` 𝕜 `⟯⟨` x `⟩` :=
  pointed_smooth_map 𝕜 I M n x" in derivation

variables {𝕜 M}

namespace pointed_smooth_map

instance {x : M} : has_coe_to_fun C^∞⟮I, M; 𝕜⟯⟨x⟩ (λ _, M → 𝕜) :=
cont_mdiff_map.has_coe_to_fun
instance {x : M} : comm_ring C^∞⟮I, M; 𝕜⟯⟨x⟩ := smooth_map.comm_ring
instance {x : M} : algebra 𝕜 C^∞⟮I, M; 𝕜⟯⟨x⟩ := smooth_map.algebra
instance {x : M} : inhabited C^∞⟮I, M; 𝕜⟯⟨x⟩ := ⟨0⟩
instance {x : M} : algebra C^∞⟮I, M; 𝕜⟯⟨x⟩ C^∞⟮I, M; 𝕜⟯ := algebra.id C^∞⟮I, M; 𝕜⟯
instance {x : M} : is_scalar_tower 𝕜 C^∞⟮I, M; 𝕜⟯⟨x⟩ C^∞⟮I, M; 𝕜⟯ := is_scalar_tower.right

variable {I}

/-- `smooth_map.eval_ring_hom` gives rise to an algebra structure of `C^∞⟮I, M; 𝕜⟯` on `𝕜`. -/
instance eval_algebra {x : M} : algebra C^∞⟮I, M; 𝕜⟯⟨x⟩ 𝕜 :=
(smooth_map.eval_ring_hom x : C^∞⟮I, M; 𝕜⟯⟨x⟩ →+* 𝕜).to_algebra

/-- With the `eval_algebra` algebra structure evaluation is actually an algebra morphism. -/
def eval (x : M) : C^∞⟮I, M; 𝕜⟯ →ₐ[C^∞⟮I, M; 𝕜⟯⟨x⟩] 𝕜 :=
algebra.of_id C^∞⟮I, M; 𝕜⟯⟨x⟩ 𝕜

lemma smul_def (x : M) (f : C^∞⟮I, M; 𝕜⟯⟨x⟩) (k : 𝕜) : f • k = f x * k := rfl

instance (x : M) : is_scalar_tower 𝕜 C^∞⟮I, M; 𝕜⟯⟨x⟩ 𝕜 :=
{ smul_assoc := λ k f h, by { simp only [smul_def, algebra.id.smul_eq_mul, smooth_map.coe_smul,
  pi.smul_apply, mul_assoc]} }

end pointed_smooth_map

open_locale derivation

/-- The derivations at a point of a manifold. Some regard this as a possible definition of the
tangent space -/
@[reducible] def point_derivation (x : M) := derivation 𝕜 (C^∞⟮I, M; 𝕜⟯⟨x⟩) 𝕜

section

variables (I) {M} (X Y : derivation 𝕜 C^∞⟮I, M; 𝕜⟯ C^∞⟮I, M; 𝕜⟯) (f g : C^∞⟮I, M; 𝕜⟯) (r : 𝕜)

/-- Evaluation at a point gives rise to a `C^∞⟮I, M; 𝕜⟯`-linear map between `C^∞⟮I, M; 𝕜⟯` and `𝕜`.
 -/
def smooth_function.eval_at (x : M) : C^∞⟮I, M; 𝕜⟯ →ₗ[C^∞⟮I, M; 𝕜⟯⟨x⟩] 𝕜 :=
(pointed_smooth_map.eval x).to_linear_map

namespace derivation

variable {I}

/-- The evaluation at a point as a linear map. -/
def eval_at (x : M) : (derivation 𝕜 C^∞⟮I, M; 𝕜⟯ C^∞⟮I, M; 𝕜⟯) →ₗ[𝕜] point_derivation I x :=
(smooth_function.eval_at I x).comp_der

lemma eval_at_apply (x : M) : eval_at x X f = (X f) x := rfl

end derivation

variables {I} {E' : Type*} [normed_add_comm_group E'] [normed_space 𝕜 E']
{H' : Type*} [topological_space H'] {I' : model_with_corners 𝕜 E' H'}
{M' : Type*} [topological_space M'] [charted_space H' M']

/-- The heterogeneous differential as a linear map. Instead of taking a function as an argument this
differential takes `h : f x = y`. It is particularly handy to deal with situations where the points
on where it has to be evaluated are equal but not definitionally equal. -/
def hfdifferential {f : C^∞⟮I, M; I', M'⟯} {x : M} {y : M'} (h : f x = y) :
  point_derivation I x →ₗ[𝕜] point_derivation I' y :=
{ to_fun := λ v, derivation.mk'
    { to_fun := λ g, v (g.comp f),
      map_add' := λ g g', by rw [smooth_map.add_comp, derivation.map_add],
      map_smul' := λ k g,
        by simp only [smooth_map.smul_comp, derivation.map_smul, ring_hom.id_apply], }
    (λ g g', by simp only [derivation.leibniz, smooth_map.mul_comp, linear_map.coe_mk,
      pointed_smooth_map.smul_def, cont_mdiff_map.comp_apply, h]),
  map_smul' := λ k v, rfl,
  map_add' := λ v w, rfl }

/-- The homogeneous differential as a linear map. -/
def fdifferential (f : C^∞⟮I, M; I', M'⟯) (x : M) :
  point_derivation I x →ₗ[𝕜] point_derivation I' (f x) :=
hfdifferential (rfl : f x = f x)

/- Standard notation for the differential. The abbreviation is `MId`. -/
localized "notation (name := fdifferential) `𝒅` := fdifferential" in manifold

/- Standard notation for the differential. The abbreviation is `MId`. -/
localized "notation (name := hfdifferential) `𝒅ₕ` := hfdifferential" in manifold

@[simp] lemma apply_fdifferential (f : C^∞⟮I, M; I', M'⟯) {x : M} (v : point_derivation I x)
  (g : C^∞⟮I', M'; 𝕜⟯) : 𝒅f x v g = v (g.comp f) := rfl

@[simp] lemma apply_hfdifferential {f : C^∞⟮I, M; I', M'⟯} {x : M} {y : M'} (h : f x = y)
  (v : point_derivation I x) (g : C^∞⟮I', M'; 𝕜⟯) : 𝒅ₕh v g = 𝒅f x v g := rfl

variables {E'' : Type*} [normed_add_comm_group E''] [normed_space 𝕜 E'']
{H'' : Type*} [topological_space H''] {I'' : model_with_corners 𝕜 E'' H''}
{M'' : Type*} [topological_space M''] [charted_space H'' M'']

@[simp] lemma fdifferential_comp (g : C^∞⟮I', M'; I'', M''⟯) (f : C^∞⟮I, M; I', M'⟯) (x : M) :
  𝒅(g.comp f) x = (𝒅g (f x)).comp (𝒅f x) := rfl

end


import algebra.ofe.basic

universe u

/-!
# Next
The type-level "later" construction.
-/

/-- The type-level "later". -/
@[ext] structure next (α : Type u) : Type u :=
(val : α)

instance (α : Type u) [ofe α] : ofe (next α) := {
  eq_at := λ n x y, @nat.rec (λ _, Prop) true (λ n _, x.val =[n] y.val) n,
  eq_at_reflexive := begin
    intros n x,
    cases n,
    trivial,
    simp only,
  end,
  eq_at_symmetric := begin
    intros n x y h,
    cases n,
    trivial,
    simp only at h ⊢,
    rw eq_at_symm_iff,
    exact h,
  end,
  eq_at_transitive := begin
    intros n x y z hxy hyz,
    cases n,
    trivial,
    simp only at hxy hyz ⊢,
    transitivity y.val,
    exact hxy,
    exact hyz,
  end,
  eq_at_mono' := begin
    intros m n hmn x y h,
    cases m,
    { trivial, },
    cases n,
    { simpa only [le_zero_iff, nat.succ_ne_zero] using hmn, },
    simp only at h ⊢,
    exact eq_at_mono (nat.succ_le_succ_iff.mp hmn) h,
  end,
  eq_at_limit' := begin
    intros x y h,
    ext,
    rw eq_at_limit,
    intro n,
    exact h (n + 1),
  end,
}

lemma next.eq_at_def {α : Type u} [ofe α] (x y : next α) (n : ℕ) :
  x =[n] y ↔ @nat.rec (λ _, Prop) true (λ n _, x.val =[n] y.val) n := iff.rfl

@[simp] lemma next.eq_at_iff {α : Type u} [ofe α] {x y : next α} {n : ℕ} :
  x =[n + 1] y ↔ x.val =[n] y.val := ⟨id, id⟩

def next.map {α β : Type u} [ofe α] [ofe β] : (α →ₙₑ β) →ₖ (next α →ₙₑ next β) :=
⟨λ f, ⟨λ a, next.mk (f a.val), begin
  intros n x y h,
  cases n,
  { trivial, },
  refine nonexpansive f _,
  rw ← next.eq_at_iff,
  exact h,
end⟩, begin
  intros n f g h a,
  cases n,
  { trivial, },
  { exact h n (nat.lt_succ_self n) a.val, },
end⟩

@[simp] lemma next.map_id {α : Type u} [ofe α] :
  next.map (nonexpansive_fun.id α) = nonexpansive_fun.id (next α) :=
by ext; refl

@[simp] lemma next.map_comp {α β γ : Type u} [ofe α] [ofe β] [ofe γ]
  (f : β →ₙₑ γ) (g : α →ₙₑ β) : next.map (f.comp g) = (next.map f).comp (next.map g) :=
by ext; refl

def next_functor : ofe_functor := {
  obj := next,
  ofe_obj := λ α [ofe α], by exactI next.ofe α,
  map := λ α β [ofe α] [ofe β], by exactI next.map,
  map_id := λ α [ofe α], by exactI next.map_id,
  map_comp := λ α β γ [ofe α] [ofe β] [ofe γ], by exactI next.map_comp,
}

lemma next_locally_contractive : locally_contractive_functor next_functor :=
begin
  introsI α β _ _ _ _,
  exact next.map.is_contractive',
end


import data.real.basic -- Lean has a good API for reals so I'm happy to use them.
import algebra.pointwise -- for addition on set ℝ
import for_mathlib.add_comm_monoid
local attribute [instance] set.add_comm_monoid

/-
Goal : prove the following theorem.

Sup(X+Y)=Sup(X)+Sup(Y).
Goal after that: state and prove Richard Thomas' problem sheet question.
-/

/-- This should be part of a controlled natural language, not a Lean definition -/
class bounded_above (X : set ℝ) : Prop :=
(is_bounded_above : bounded (≤) X)

local attribute [instance] set.add_comm_monoid

instance (X Y : Type*) : nonempty X → nonempty Y → nonempty (X × Y)
| ⟨x⟩ ⟨y⟩ := ⟨(x, y)⟩

--set_option pp.notation false
#check ∀ (X : Type) (P : X → Prop), {x : X | P x}
/-- version of set_of without universes and {}s -/
def set_of' (X : Type) (P : X → Prop) := {x : X | P x}
#check set_of'
#print set_of'
/-- version of subtype without universes and {} -/
def subtype' (X : Type) (P : X → Prop) := {x : X // P x}
#check subtype'
#check set_of'
#check @set_of
example : set_of' = @set_of := rfl
#check subtype'
-- question: relationship between subtype' and set_of'
--set_option pp.notation false
#check set_of'
#print set_of
#check subtype'
#print subtype
/-
/- Remark: subtype must take a Sort instead of Type because of the axiom strong_indefinite_description. -/
structure subtype {α : Sort u} (p : α → Prop) :=
(val : α) (property : p val)
-/
#print set_of
variables (R : Type) (P : R → Prop)
#check (@subtype.val R P : subtype P → R)
#check (@subtype.property R P : ∀ (c : subtype P), P (c.val))
#check set_of' R P
-- set_of must be notation.
example : set_of' R P = P := rfl
#check subtype' R P
#print prefix subtype

def subtype'.val : subtype P → R := subtype.val
def subtype'.property : ∀ (c : subtype P), P (c.val) := subtype.property

#check @coe_sort
#check has_coe_to_sort

example : @id _ = @set_of R := rfl -- set_of is the identity function
example : set_of' R = id := rfl
example : set R ≃ (R → Prop) := {
  to_fun := id,
  inv_fun := set_of, -- id also works
  left_inv := λ _, rfl,
  right_inv := λ _, rfl }

#check subtype' R
theorem real.add_nonempty (X Y : set ℝ) :
  nonempty X → nonempty Y → nonempty (subtype' ℝ ((X + Y) : set ℝ))
| ⟨x⟩ ⟨y⟩ := ⟨⟨x.val + y.val, ⟨x.val, x.property, y.val, y.2, rfl⟩⟩⟩

--set_option pp.notation false
-- coe_sort is ↥
#check real.add_nonempty
#print has_coe_to_sort
/-
class has_coe_to_sort (a : Sort u) : Type (max u (v+1)) :=
(S : Sort v) (coe : a → S)
-/
example : has_coe_to_sort (set ℝ) := by apply_instance -- set.has_coe_to_sort
#print set.has_coe_to_sort
#check set.has_coe_to_sort.coe -- : set X → has_coe_to_sort.S (set X)
#check set.has_coe_to_sort.S --: set ℝ → Type
#check (subtype' ℝ : (ℝ → Prop) → Type)
example : subtype' R P = set.has_coe_to_sort.S := sorry
--#check @coe_sort :
#exit

theorem real.Sup_add -- or is it real.Sup.add?
  (X : set ℝ) (h1X : nonempty X) (h2X : bounded_above X)
  (Y : set ℝ) (h1Y : nonempty Y) (h2Y : bounded_above Y) :
  real.Sup {z : ℝ | ∃ (x ∈ X) (y ∈ Y), z = x + y} = real.Sup X + real.Sup Y  :=
begin

  apply le_antisymm,
  { rw real.Sup_le,
    sorry
  },
  {
    sorry
  }
end

/-
Question: should there be an "add top and bottom" type?
Question: should instance : has_add (set ℝ) exist?

-/

/-
/-- It's zero if the sup doesn't exist -/
def Sup (S : set ℝ) : ℝ

theorem Sup_le (S : set ℝ) (h₁ : ∃ x, x ∈ S) (h₂ : ∃ x, ∀ y ∈ S, y ≤ x)
  {y} : Sup S ≤ y ↔ ∀ z ∈ S, z ≤ y

theorem lt_Sup (S : set ℝ) (h₁ : ∃ x, x ∈ S) (h₂ : ∃ x, ∀ y ∈ S, y ≤ x)
  {y} : y < Sup S ↔ ∃ z ∈ S, y < z

theorem le_Sup (S : set ℝ) (h₂ : ∃ x, ∀ y ∈ S, y ≤ x) {x} (xS : x ∈ S) : x ≤ Sup S

theorem Sup_le_ub (S : set ℝ) (h₁ : ∃ x, x ∈ S) {ub} (h₂ : ∀ y ∈ S, y ≤ ub) : Sup S ≤ ub

lemma is_lub_Sup {s : set ℝ} {a b : ℝ} (ha : a ∈ s) (hb : b ∈ upper_bounds s) :
  is_lub s (Sup s) :=
-/

/-- The type $$[-∞,+∞]$$ -/
def ereal : Type := with_bot (with_top ℝ)

--def is_ub (X : set ℝ) (b : ℝ) := ∀ x ∈ X, x ≤ b
--def is_lub (X : set ℝ) (l : ℝ) := is_ub X l ∧

/-
theorem exists_sup (S : set ℝ) : (∃ x, x ∈ S) → (∃ x, ∀ y ∈ S, y ≤ x) →
  ∃ x, ∀ y, x ≤ y ↔ ∀ z ∈ S, z ≤ y
-/


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.list.basic
import Mathlib.PostPort

universes u

namespace Mathlib

namespace list

/- bag_inter -/

@[simp] theorem nil_bag_inter {α : Type u} [DecidableEq α] (l : List α) :
    list.bag_inter [] l = [] :=
  list.cases_on l (Eq.refl (list.bag_inter [] []))
    fun (l_hd : α) (l_tl : List α) => Eq.refl (list.bag_inter [] (l_hd :: l_tl))

@[simp] theorem bag_inter_nil {α : Type u} [DecidableEq α] (l : List α) :
    list.bag_inter l [] = [] :=
  list.cases_on l (Eq.refl (list.bag_inter [] []))
    fun (l_hd : α) (l_tl : List α) => Eq.refl (list.bag_inter (l_hd :: l_tl) [])

@[simp] theorem cons_bag_inter_of_pos {α : Type u} [DecidableEq α] {a : α} (l₁ : List α)
    {l₂ : List α} (h : a ∈ l₂) :
    list.bag_inter (a :: l₁) l₂ = a :: list.bag_inter l₁ (list.erase l₂ a) :=
  list.cases_on l₂ (fun (h : a ∈ []) => if_pos h)
    (fun (l₂_hd : α) (l₂_tl : List α) (h : a ∈ l₂_hd :: l₂_tl) => if_pos h) h

@[simp] theorem cons_bag_inter_of_neg {α : Type u} [DecidableEq α] {a : α} (l₁ : List α)
    {l₂ : List α} (h : ¬a ∈ l₂) : list.bag_inter (a :: l₁) l₂ = list.bag_inter l₁ l₂ :=
  sorry

@[simp] theorem mem_bag_inter {α : Type u} [DecidableEq α] {a : α} {l₁ : List α} {l₂ : List α} :
    a ∈ list.bag_inter l₁ l₂ ↔ a ∈ l₁ ∧ a ∈ l₂ :=
  sorry

@[simp] theorem count_bag_inter {α : Type u} [DecidableEq α] {a : α} {l₁ : List α} {l₂ : List α} :
    count a (list.bag_inter l₁ l₂) = min (count a l₁) (count a l₂) :=
  sorry

theorem bag_inter_sublist_left {α : Type u} [DecidableEq α] (l₁ : List α) (l₂ : List α) :
    list.bag_inter l₁ l₂ <+ l₁ :=
  sorry

theorem bag_inter_nil_iff_inter_nil {α : Type u} [DecidableEq α] (l₁ : List α) (l₂ : List α) :
    list.bag_inter l₁ l₂ = [] ↔ l₁ ∩ l₂ = [] :=
  sorry

end Mathlib


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import data.set.lattice
import data.set.pairwise.basic

/-!
# Relations holding pairwise

In this file we prove many facts about `pairwise` and the set lattice.
-/

open set function

variables {α β γ ι ι' : Type*} {r p q : α → α → Prop}

section pairwise
variables {f g : ι → α} {s t u : set α} {a b : α}

namespace set

lemma pairwise_Union {f : ι → set α} (h : directed (⊆) f) :
  (⋃ n, f n).pairwise r ↔ ∀ n, (f n).pairwise r :=
begin
  split,
  { assume H n,
    exact pairwise.mono (subset_Union _ _) H },
  { assume H i hi j hj hij,
    rcases mem_Union.1 hi with ⟨m, hm⟩,
    rcases mem_Union.1 hj with ⟨n, hn⟩,
    rcases h m n with ⟨p, mp, np⟩,
    exact H p (mp hm) (np hn) hij }
end

lemma pairwise_sUnion {r : α → α → Prop} {s : set (set α)} (h : directed_on (⊆) s) :
  (⋃₀ s).pairwise r ↔ (∀ a ∈ s, set.pairwise a r) :=
by { rw [sUnion_eq_Union, pairwise_Union (h.directed_coe), set_coe.forall], refl }

end set

end pairwise

namespace set
section partial_order_bot
variables [partial_order α] [order_bot α] {s t : set ι} {f g : ι → α}

lemma pairwise_disjoint_Union {g : ι' → set ι} (h : directed (⊆) g) :
  (⋃ n, g n).pairwise_disjoint f ↔ ∀ ⦃n⦄, (g n).pairwise_disjoint f :=
pairwise_Union h

lemma pairwise_disjoint_sUnion {s : set (set ι)} (h : directed_on (⊆) s) :
  (⋃₀ s).pairwise_disjoint f ↔ ∀ ⦃a⦄, a ∈ s → set.pairwise_disjoint a f :=
pairwise_sUnion h

end partial_order_bot

section complete_lattice
variables [complete_lattice α]

/-- Bind operation for `set.pairwise_disjoint`. If you want to only consider finsets of indices, you
can use `set.pairwise_disjoint.bUnion_finset`. -/
lemma pairwise_disjoint.bUnion {s : set ι'} {g : ι' → set ι} {f : ι → α}
  (hs : s.pairwise_disjoint (λ i' : ι', ⨆ i ∈ g i', f i))
  (hg : ∀ i ∈ s, (g i).pairwise_disjoint f) :
  (⋃ i ∈ s, g i).pairwise_disjoint f :=
begin
  rintro a ha b hb hab,
  simp_rw set.mem_Union at ha hb,
  obtain ⟨c, hc, ha⟩ := ha,
  obtain ⟨d, hd, hb⟩ := hb,
  obtain hcd | hcd := eq_or_ne (g c) (g d),
  { exact hg d hd (hcd.subst ha) hb hab },
  { exact (hs hc hd $ ne_of_apply_ne _ hcd).mono (le_supr₂ a ha) (le_supr₂ b hb) }
end

end complete_lattice

lemma bUnion_diff_bUnion_eq {s t : set ι} {f : ι → set α} (h : (s ∪ t).pairwise_disjoint f) :
  (⋃ i ∈ s, f i) \ (⋃ i ∈ t, f i) = (⋃ i ∈ s \ t, f i) :=
begin
  refine (bUnion_diff_bUnion_subset f s t).antisymm
    (Union₂_subset $ λ i hi a ha, (mem_diff _).2 ⟨mem_bUnion hi.1 ha, _⟩),
  rw mem_Union₂, rintro ⟨j, hj, haj⟩,
  exact (h (or.inl hi.1) (or.inr hj) (ne_of_mem_of_not_mem hj hi.2).symm).le_bot ⟨ha, haj⟩,
end

/-- Equivalence between a disjoint bounded union and a dependent sum. -/
noncomputable def bUnion_eq_sigma_of_disjoint {s : set ι} {f : ι → set α}
  (h : s.pairwise_disjoint f) :
  (⋃ i ∈ s, f i) ≃ (Σ i : s, f i) :=
(equiv.set_congr (bUnion_eq_Union _ _)).trans $ Union_eq_sigma_of_disjoint $
  λ ⟨i, hi⟩ ⟨j, hj⟩ ne, h hi hj $ λ eq, ne $ subtype.eq eq

end set

section
variables {f : ι → set α} {s t : set ι}

lemma set.pairwise_disjoint.subset_of_bUnion_subset_bUnion (h₀ : (s ∪ t).pairwise_disjoint f)
  (h₁ : ∀ i ∈ s, (f i).nonempty) (h : (⋃ i ∈ s, f i) ⊆ ⋃ i ∈ t, f i) :
  s ⊆ t :=
begin
  rintro i hi,
  obtain ⟨a, hai⟩ := h₁ i hi,
  obtain ⟨j, hj, haj⟩ := mem_Union₂.1 (h $ mem_Union₂_of_mem hi hai),
  rwa h₀.eq (subset_union_left _ _ hi) (subset_union_right _ _ hj)
    (not_disjoint_iff.2 ⟨a, hai, haj⟩),
end

lemma pairwise.subset_of_bUnion_subset_bUnion (h₀ : pairwise (disjoint on f))
  (h₁ : ∀ i ∈ s, (f i).nonempty) (h : (⋃ i ∈ s, f i) ⊆ ⋃ i ∈ t, f i) :
  s ⊆ t :=
set.pairwise_disjoint.subset_of_bUnion_subset_bUnion (h₀.set_pairwise _) h₁ h

lemma pairwise.bUnion_injective (h₀ : pairwise (disjoint on f)) (h₁ : ∀ i, (f i).nonempty) :
  injective (λ s : set ι, ⋃ i ∈ s, f i) :=
λ s t h, (h₀.subset_of_bUnion_subset_bUnion (λ _ _, h₁ _) $ h.subset).antisymm $
  h₀.subset_of_bUnion_subset_bUnion (λ _ _, h₁ _) $ h.superset

end


import Mathlib.Tactic.SplitIfs

example (x : Nat) (p : Prop) [Decidable p] : x = if p then x else x := by
  split_ifs with h1
  · rfl
  · rfl

example (x y : Nat) (p : Prop) [Decidable p] (h : if p then x = y else y = x) : x = y := by
  split_ifs at h
  · exact h
  · exact h.symm

example (x : Nat) (p q : Prop) [Decidable p] [Decidable q] :
    x = if p then (if q then x else x) else x := by
  split_ifs
  · rfl
  · rfl
  · rfl

example (x : Nat) (p : Prop) [Decidable p] :
    x = if (if p then False else True) then x else x := by
  split_ifs
  · rfl
  · rfl
  · rfl

example (p : Prop) [Decidable p] : if if ¬p then p else True then p else ¬p := by
  split_ifs with h
  · exact h
  · exact h

example (p q : Prop) [Decidable p] [Decidable q] :
    if if if p then ¬p else q then p else q then q else ¬p ∨ ¬q := by
  split_ifs with h1 h2 h3
  · exact h2
  · exact Or.inr h2
  · exact Or.inl h1
  · exact Or.inr h3

example (p : Prop) [Decidable p] (h : (if p then 1 else 2) > 3) : False := by
  split_ifs at h
  cases h
  · case inl.step h => cases h
  · case inr h =>
    cases h
    case step h =>
      cases h
      case step h => cases h

example (p : Prop) [Decidable p] (x : Nat) (h : (if p then 1 else 2) > x) :
     x < (if ¬p then 1 else 0) + 1 := by
   split_ifs at * <;> assumption

example (p : Prop) [Decidable p] : if if ¬p then p else True then p else ¬p := by
  split_ifs <;>
  assumption

example (p q : Prop) [Decidable p] [Decidable q] :
     if if if p then ¬p else q then p else q then q else ¬p ∨ ¬q := by
  split_ifs <;>
  simp [*]

example : True := by
  fail_if_success { split_ifs }
  trivial

open Classical in
example (P Q : Prop) (w : if P then (if Q then true else true) else true = true) : true := by
  split_ifs at w
  -- check that we've fully split w into three subgoals
  · trivial
  · trivial
  · trivial