/-
The main point of this file is to prove that
`μ.with_density f = μ.with_density g → f =ᵐ[μ] g`.

We have this already with `with_densityᵥ` due to lemmas for `integral`.
We should use these existing API to transport the lemmas to `lintegral`.
However, that might be difficult since it would require
`∀ᵐ x ∂μ, f x < ∞` which is unnecessary mathematically.

Okay, actually the condition is necessary. Indeed, consider the
`⊤` measure on `ℝ` which maps `∅` to `0` and `∞` otherwise. Then
`∫ₛ 1 ∂⊤ = ∫ₛ 2 ∂⊤ = ∞` for all `s` while ¬ `1 = 2` a.e.
-/

import measure_theory.measure.with_density_vector_measure

noncomputable theory
open_locale classical measure_theory nnreal ennreal

namespace measure_theory

open topological_space

variables {α : Type*} [measurable_space α] {μ : measure α}

lemma lintegral_sub_le (f g : α → ℝ≥0∞)
  (hf : measurable f) (hg : measurable g) (h : f ≤ᵐ[μ] g) :
  ∫⁻ x, g x ∂μ - ∫⁻ x, f x ∂μ ≤ ∫⁻ x, g x - f x ∂μ :=
begin
  by_cases hfi : ∫⁻ x, f x ∂μ = ∞,
  { rw [hfi, ennreal.sub_top],
    exact bot_le },
  { rw lintegral_sub hg hf hfi h,
    refl' }
end

lemma ae_le_of_ae_lt {f g : α → ℝ≥0∞} (h : ∀ᵐ x ∂μ, f x < g x) : f ≤ᵐ[μ] g :=
begin
  rw [filter.eventually_le, ae_iff],
  rw ae_iff at h,
  refine measure_mono_null (λ x hx, _) h,
  exact not_lt.2 (le_of_lt (not_le.1 hx)),
end

lemma lintegral_strict_mono {f g : α → ℝ≥0∞} (huniv : 0 < μ set.univ)
  (hf : measurable f) (hg : measurable g) (hfi : ∫⁻ x, f x ∂μ ≠ ∞) (h : ∀ᵐ x ∂μ, f x < g x) :
  ∫⁻ x, f x ∂μ < ∫⁻ x, g x ∂μ :=
begin
  rw [← ennreal.sub_pos, ← lintegral_sub hg hf hfi (ae_le_of_ae_lt h)],
  by_contra hnlt,
  rw [not_lt, nonpos_iff_eq_zero, lintegral_eq_zero_iff (hg.sub hf), filter.eventually_eq] at hnlt,
  simp only [ae_iff, ennreal.sub_eq_zero_iff_le, pi.zero_apply, not_lt, not_le] at hnlt h,
  refine huniv.ne _,
  rw [← h, ← add_zero (μ {a : α | g a ≤ f a}), ← hnlt, ← measure_union],
  { congr, ext x,
    simp only [set.mem_univ, iff_true, set.mem_union_eq, set.mem_set_of_eq, le_or_lt] },
  { rintro x ⟨hxlt, hxgt⟩,
    exact not_lt.2 hxlt hxgt },
  { exact measurable_set_le hg hf },
  { exact measurable_set_lt hf hg }
end

lemma set_lintegral_strict_mono {f g : α → ℝ≥0∞} {s : set α}
  (hsm : measurable_set s) (hs : 0 < μ s) (hf : measurable f) (hg : measurable g)
  (hfi : ∫⁻ x in s, f x ∂μ ≠ ∞) (h : ∀ᵐ x ∂μ, x ∈ s → f x < g x) :
  ∫⁻ x in s, f x ∂μ < ∫⁻ x in s, g x ∂μ :=
begin
  refine lintegral_strict_mono _ hf hg hfi _,
  { rwa [measure.restrict_apply measurable_set.univ, set.univ_inter] },
  { rwa ae_restrict_iff' hsm }
end

lemma lt_or_gt_pos_of_ne_pos {f : α → ℝ≥0∞} (hf : measurable f)
  {c : ℝ≥0∞} (h : 0 < μ {x | f x ≠ c}) :
  0 < μ {x | f x < c} ∨ 0 < μ {x | f x > c} :=
begin
  by_contra hn, push_neg at hn,
  rw [nonpos_iff_eq_zero, nonpos_iff_eq_zero] at hn,
  refine h.ne _,
  rw [← hn.2, ← zero_add (μ {x : α | f x > c}), ← hn.1, ← measure_union],
  { congr, ext x, split,
    { rintro (hlt | hgt), exacts [ne_of_lt hlt, ne_of_gt hgt] },
    { intro hn, exact ne_iff_lt_or_gt.1 hn } },
  { rintro x ⟨hxlt, hxgt⟩,
    exact not_lt.2 (le_of_lt hxlt) hxgt },
  { exact measurable_set_lt hf measurable_const },
  { exact measurable_set_lt measurable_const hf }
end

-- lemma eq_const_of_lintegral {f : α → ℝ≥0∞} (hf : measurable f) (c : ℝ≥0∞)
--   (hfi : ∀ s : set α, ∫⁻ x in s, f x ∂μ = c * μ s) : f =ᵐ[μ] (λ _, c) :=
-- begin
--   by_cases huniv : 0 < μ set.univ,
--   { rw [filter.eventually_eq, ae_iff],
--     by_contra hμ, rw [← ne.def, ← pos_iff_ne_zero] at hμ,
--     obtain (hlt | hgt) := lt_or_gt_pos_of_ne_pos hf hμ,
--     { have := set_lintegral_strict_mono _ hlt hf measurable_const,

--     },
--     { sorry } },
--   { rw [filter.eventually_eq, ae_iff, ← nonpos_iff_eq_zero],
--     refine le_trans (measure_mono (set.subset_univ _)) (not_lt.1 huniv) }
-- end

lemma ennreal.of_real_to_real_ae_eq (f : α → ℝ≥0∞) (hf : ∀ᵐ x ∂μ, f x < ∞) :
  (λ x, ennreal.of_real (f x).to_real) =ᵐ[μ] f :=
begin
  rw ae_iff at hf,
  rw [filter.eventually_eq, ae_iff],
  have : {x | ¬ ennreal.of_real (f x).to_real = f x} = {x | f x = ∞},
  { ext x, simp only [ne.def, set.mem_set_of_eq], split; intro hx,
    { by_contra hntop,
      exact hx (ennreal.of_real_to_real hntop) },
    { rw hx, simp } },
  rw this,
  simpa using hf,
end

lemma ae_eq_of_to_real_ae_eq {f g : α → ℝ≥0∞}
  (hf : ae_measurable f μ) (hg : ae_measurable g μ)
  (hfi : ∀ᵐ x ∂μ, f x < ∞) (hgi : ∀ᵐ x ∂μ, g x < ∞)
  (hfg : (λ x, (f x).to_real) =ᵐ[μ] (λ x, (g x).to_real)) :
  f =ᵐ[μ] g :=
begin
  rw [filter.eventually_eq, ae_iff] at hfg ⊢,
  simp_rw [ae_iff, not_lt, top_le_iff] at hfi hgi,
  have : {x | f x ≠ g x} ⊆ {x | (f x).to_real ≠ (g x).to_real} ∪ ({x | f x = ∞} ∪ {x | g x = ∞}),
  { intros x hx,
    simp only [set.mem_union_eq, or_iff_not_imp_left],
    intro hx', by_contra h, push_neg at h,
    refine hx _,
    rw ← ennreal.to_real_eq_to_real h.1 h.2,
    exact not_not.1 hx' },
  refine measure_mono_null this (nonpos_iff_eq_zero.1 (le_trans (measure_union_le _ _) _)),
  rw [hfg, zero_add],
  exact le_trans (measure_union_le _ _)
    (hfi.symm ▸ hgi.symm ▸ (zero_add (0 : ℝ≥0∞)).symm ▸ le_refl _),
end

lemma ae_eq_of_forall_set_lintegral_eq {f g : α → ℝ≥0∞}
  (hf : ae_measurable f μ) (hg : ae_measurable g μ)
  (hfi : ∫⁻ x, f x ∂μ ≠ ∞) (hgi : ∫⁻ x, g x ∂μ ≠ ∞)
  (hfg : ∀ ⦃s⦄, measurable_set s → μ s < ∞ → ∫⁻ x in s, f x ∂μ = ∫⁻ x in s, g x ∂μ) :
  f =ᵐ[μ] g :=
begin
  refine ae_eq_of_to_real_ae_eq hf hg (ae_lt_top' hf hfi) (ae_lt_top' hg hgi)
    (integrable.ae_eq_of_forall_set_integral_eq _ _
      (integrable_to_real_of_lintegral_ne_top hf hfi)
      (integrable_to_real_of_lintegral_ne_top hg hgi) (λ s hs hs', _)),
  rw [integral_eq_lintegral_of_nonneg_ae, integral_eq_lintegral_of_nonneg_ae],
  { congr' 1,
    rw lintegral_congr_ae (ennreal.of_real_to_real_ae_eq f _),
    rw lintegral_congr_ae (ennreal.of_real_to_real_ae_eq g _),
    { exact hfg hs hs' },
    { refine (ae_lt_top' hg.restrict (ne_of_lt (lt_of_le_of_lt _ hgi.lt_top))),
      exact @set_lintegral_univ α _ μ g ▸ lintegral_mono_set (set.subset_univ _) },
    { refine (ae_lt_top' hf.restrict (ne_of_lt (lt_of_le_of_lt _ hfi.lt_top))),
      exact @set_lintegral_univ α _ μ f ▸ lintegral_mono_set (set.subset_univ _) } },
  { exact ae_of_all _ (λ x, ennreal.to_real_nonneg) },
  { exact ae_measurable.restrict hg.ennreal_to_real },
  { exact ae_of_all _ (λ x, ennreal.to_real_nonneg) },
  { exact ae_measurable.restrict hf.ennreal_to_real }
end

end measure_theory


/-
Copyright (c) 2022 Yaël Dillies, Kexing Ying. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Kexing Ying
-/
import mathlib.combinatorics.simple_graph.subgraph
import weighted_cube

/-!
# The Erdős–Rényi model

In this file, we define the Erdős–Rényi model through its marginals.
-/

open measure_theory probability_theory
open_locale measure_theory probability_theory ennreal nnreal

variables {α Ω : Type*} [measurable_space Ω]

/-- A sequence iid. real valued Bernoulli random variables with parameter `p ≤ 1`. -/
abbreviation erdos_renyi (G : Ω → simple_graph α) [Π ω, decidable_rel (G ω).adj] (p : ℝ≥0)
  (μ : measure Ω . volume_tac) : Prop :=
bernoulli_seq (λ ω, (G ω).edge_set) p μ

variables (G : Ω → simple_graph α) (H : simple_graph α) [Π ω, decidable_rel (G ω).adj] {p : ℝ≥0}
  (μ : measure Ω) [is_probability_measure μ] [erdos_renyi G p μ]
include G p

namespace erdos_renyi

protected lemma le_one : p ≤ 1 := bernoulli_seq.le_one (λ ω, (G ω).edge_set) μ

protected lemma Indep_fun : Indep_fun infer_instance (λ e ω, e ∈ (G ω).edge_set) μ :=
bernoulli_seq.Indep_fun _ _

protected lemma map (e : sym2 α) :
  measure.map (λ ω, e ∈ (G ω).edge_set) μ =
    (pmf.bernoulli' p $ erdos_renyi.le_one G μ).to_measure :=
bernoulli_seq.map _ _ e

protected lemma ae_measurable (e : sym2 α) : ae_measurable (λ ω, e ∈ (G ω).edge_set) μ :=
bernoulli_seq.ae_measurable _ _ e

protected lemma null_measurable_set (e : sym2 α) : null_measurable_set {ω | e ∈ (G ω).edge_set} μ :=
bernoulli_seq.null_measurable_set _ _ e

protected lemma ident_distrib (d e : sym2 α) :
  ident_distrib (λ ω, d ∈ (G ω).edge_set) (λ ω, e ∈ (G ω).edge_set) μ μ :=
bernoulli_seq.ident_distrib _ _ d e

lemma meas_edge (e : sym2 α) : μ {ω | e ∈ (G ω).edge_set} = p :=
bernoulli_seq.meas_apply _ _ e

protected lemma meas [fintype α] [decidable_eq α] [decidable_rel H.adj] :
  μ {ω | G ω = H}
    = p ^ H.edge_finset.card * (1 - p) ^ (fintype.card (sym2 α) - H.edge_finset.card) :=
by { convert bernoulli_seq.meas (λ ω, (G ω).edge_set) μ H.edge_finset, ext, simp }

end erdos_renyi


/-
Copyright (c) 2019 Abhimanyu Pallavi Sudhir. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Abhimanyu Pallavi Sudhir
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.order.filter.filter_product
import Mathlib.analysis.specific_limits
import Mathlib.PostPort

namespace Mathlib

/-!
# Construction of the hyperreal numbers as an ultraproduct of real sequences.
-/

/-- Hyperreal numbers on the ultrafilter extending the cofinite filter -/
def hyperreal :=
  filter.germ ↑(filter.hyperfilter ℕ) ℝ

notation:1024 "ℝ*" => Mathlib.hyperreal

namespace hyperreal

protected instance has_coe_t : has_coe_t ℝ ℝ* :=
  has_coe_t.mk fun (x : ℝ) => ↑x

@[simp] theorem coe_eq_coe {x : ℝ} {y : ℝ} : ↑x = ↑y ↔ x = y :=
  filter.germ.const_inj

@[simp] theorem coe_eq_zero {x : ℝ} : ↑x = 0 ↔ x = 0 :=
  coe_eq_coe

@[simp] theorem coe_eq_one {x : ℝ} : ↑x = 1 ↔ x = 1 :=
  coe_eq_coe

@[simp] theorem coe_one : ↑1 = 1 :=
  rfl

@[simp] theorem coe_zero : ↑0 = 0 :=
  rfl

@[simp] theorem coe_inv (x : ℝ) : ↑(x⁻¹) = (↑x⁻¹) :=
  rfl

@[simp] theorem coe_neg (x : ℝ) : ↑(-x) = -↑x :=
  rfl

@[simp] theorem coe_add (x : ℝ) (y : ℝ) : ↑(x + y) = ↑x + ↑y :=
  rfl

@[simp] theorem coe_bit0 (x : ℝ) : ↑(bit0 x) = bit0 ↑x :=
  rfl

@[simp] theorem coe_bit1 (x : ℝ) : ↑(bit1 x) = bit1 ↑x :=
  rfl

@[simp] theorem coe_mul (x : ℝ) (y : ℝ) : ↑(x * y) = ↑x * ↑y :=
  rfl

@[simp] theorem coe_div (x : ℝ) (y : ℝ) : ↑(x / y) = ↑x / ↑y :=
  rfl

@[simp] theorem coe_sub (x : ℝ) (y : ℝ) : ↑(x - y) = ↑x - ↑y :=
  rfl

@[simp] theorem coe_lt_coe {x : ℝ} {y : ℝ} : ↑x < ↑y ↔ x < y :=
  filter.germ.const_lt

@[simp] theorem coe_pos {x : ℝ} : 0 < ↑x ↔ 0 < x :=
  coe_lt_coe

@[simp] theorem coe_le_coe {x : ℝ} {y : ℝ} : ↑x ≤ ↑y ↔ x ≤ y :=
  filter.germ.const_le_iff

@[simp] theorem coe_abs (x : ℝ) : ↑(abs x) = abs ↑x :=
  filter.germ.const_abs x

@[simp] theorem coe_max (x : ℝ) (y : ℝ) : ↑(max x y) = max ↑x ↑y :=
  filter.germ.const_max x y

@[simp] theorem coe_min (x : ℝ) (y : ℝ) : ↑(min x y) = min ↑x ↑y :=
  filter.germ.const_min x y

/-- Construct a hyperreal number from a sequence of real numbers. -/
def of_seq (f : ℕ → ℝ) : ℝ* :=
  ↑f

/-- A sample infinitesimal hyperreal-/
def epsilon : ℝ* :=
  of_seq fun (n : ℕ) => ↑n⁻¹

/-- A sample infinite hyperreal-/
def omega : ℝ* :=
  of_seq coe

theorem epsilon_eq_inv_omega : epsilon = (omega⁻¹) :=
  rfl

theorem inv_epsilon_eq_omega : epsilon⁻¹ = omega :=
  inv_inv' omega

theorem epsilon_pos : 0 < epsilon := sorry

theorem epsilon_ne_zero : epsilon ≠ 0 :=
  ne_of_gt epsilon_pos

theorem omega_pos : 0 < omega :=
  eq.mpr (id (Eq._oldrec (Eq.refl (0 < omega)) (Eq.symm inv_epsilon_eq_omega))) (iff.mpr inv_pos epsilon_pos)

theorem omega_ne_zero : omega ≠ 0 :=
  ne_of_gt omega_pos

theorem epsilon_mul_omega : epsilon * omega = 1 :=
  inv_mul_cancel omega_ne_zero

theorem lt_of_tendsto_zero_of_pos {f : ℕ → ℝ} (hf : filter.tendsto f filter.at_top (nhds 0)) {r : ℝ} : 0 < r → of_seq f < ↑r := sorry

theorem neg_lt_of_tendsto_zero_of_pos {f : ℕ → ℝ} (hf : filter.tendsto f filter.at_top (nhds 0)) {r : ℝ} : 0 < r → -↑r < of_seq f := sorry

theorem gt_of_tendsto_zero_of_neg {f : ℕ → ℝ} (hf : filter.tendsto f filter.at_top (nhds 0)) {r : ℝ} : r < 0 → ↑r < of_seq f := sorry

theorem epsilon_lt_pos (x : ℝ) : 0 < x → epsilon < ↑x :=
  lt_of_tendsto_zero_of_pos tendsto_inverse_at_top_nhds_0_nat

/-- Standard part predicate -/
def is_st (x : ℝ*) (r : ℝ) :=
  ∀ (δ : ℝ), 0 < δ → ↑r - ↑δ < x ∧ x < ↑r + ↑δ

/-- Standard part function: like a "round" to ℝ instead of ℤ -/
def st : ℝ* → ℝ :=
  fun (x : ℝ*) =>
    dite (∃ (r : ℝ), is_st x r) (fun (h : ∃ (r : ℝ), is_st x r) => classical.some h) fun (h : ¬∃ (r : ℝ), is_st x r) => 0

/-- A hyperreal number is infinitesimal if its standard part is 0 -/
def infinitesimal (x : ℝ*) :=
  is_st x 0

/-- A hyperreal number is positive infinite if it is larger than all real numbers -/
def infinite_pos (x : ℝ*) :=
  ∀ (r : ℝ), ↑r < x

/-- A hyperreal number is negative infinite if it is smaller than all real numbers -/
def infinite_neg (x : ℝ*) :=
  ∀ (r : ℝ), x < ↑r

/-- A hyperreal number is infinite if it is infinite positive or infinite negative -/
def infinite (x : ℝ*) :=
  infinite_pos x ∨ infinite_neg x

/-!
### Some facts about `st`
-/

theorem is_st_unique {x : ℝ*} {r : ℝ} {s : ℝ} (hr : is_st x r) (hs : is_st x s) : r = s :=
  or.dcases_on (lt_trichotomy r s) (fun (h : r < s) => false.elim (is_st_unique' x r s hr hs h))
    fun (h : r = s ∨ s < r) =>
      or.dcases_on h (fun (h : r = s) => h) fun (h : s < r) => false.elim (is_st_unique' x s r hs hr h)

theorem not_infinite_of_exists_st {x : ℝ*} : (∃ (r : ℝ), is_st x r) → ¬infinite x := sorry

theorem is_st_Sup {x : ℝ*} (hni : ¬infinite x) : is_st x (Sup (set_of fun (y : ℝ) => ↑y < x)) := sorry

theorem exists_st_of_not_infinite {x : ℝ*} (hni : ¬infinite x) : ∃ (r : ℝ), is_st x r :=
  Exists.intro (Sup (set_of fun (y : ℝ) => ↑y < x)) (is_st_Sup hni)

theorem st_eq_Sup {x : ℝ*} : st x = Sup (set_of fun (y : ℝ) => ↑y < x) := sorry

theorem exists_st_iff_not_infinite {x : ℝ*} : (∃ (r : ℝ), is_st x r) ↔ ¬infinite x :=
  { mp := not_infinite_of_exists_st, mpr := exists_st_of_not_infinite }

theorem infinite_iff_not_exists_st {x : ℝ*} : infinite x ↔ ¬∃ (r : ℝ), is_st x r :=
  iff.mp iff_not_comm exists_st_iff_not_infinite

theorem st_infinite {x : ℝ*} (hi : infinite x) : st x = 0 := sorry

theorem st_of_is_st {x : ℝ*} {r : ℝ} (hxr : is_st x r) : st x = r := sorry

theorem is_st_st_of_is_st {x : ℝ*} {r : ℝ} (hxr : is_st x r) : is_st x (st x) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (is_st x (st x))) (st_of_is_st hxr))) hxr

theorem is_st_st_of_exists_st {x : ℝ*} (hx : ∃ (r : ℝ), is_st x r) : is_st x (st x) :=
  Exists.dcases_on hx fun (r : ℝ) => is_st_st_of_is_st

theorem is_st_st {x : ℝ*} (hx : st x ≠ 0) : is_st x (st x) := sorry

theorem is_st_st' {x : ℝ*} (hx : ¬infinite x) : is_st x (st x) :=
  is_st_st_of_exists_st (exists_st_of_not_infinite hx)

theorem is_st_refl_real (r : ℝ) : is_st (↑r) r :=
  fun (δ : ℝ) (hδ : 0 < δ) =>
    { left := sub_lt_self (↑r) (iff.mpr coe_lt_coe hδ), right := lt_add_of_pos_right (↑r) (iff.mpr coe_lt_coe hδ) }

theorem st_id_real (r : ℝ) : st ↑r = r :=
  st_of_is_st (is_st_refl_real r)

theorem eq_of_is_st_real {r : ℝ} {s : ℝ} : is_st (↑r) s → r = s :=
  is_st_unique (is_st_refl_real r)

theorem is_st_real_iff_eq {r : ℝ} {s : ℝ} : is_st (↑r) s ↔ r = s :=
  { mp := eq_of_is_st_real,
    mpr := fun (hrs : r = s) => eq.mpr (id (Eq._oldrec (Eq.refl (is_st (↑r) s)) hrs)) (is_st_refl_real s) }

theorem is_st_symm_real {r : ℝ} {s : ℝ} : is_st (↑r) s ↔ is_st (↑s) r :=
  eq.mpr (id (Eq._oldrec (Eq.refl (is_st (↑r) s ↔ is_st (↑s) r)) (propext is_st_real_iff_eq)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (r = s ↔ is_st (↑s) r)) (propext is_st_real_iff_eq)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (r = s ↔ s = r)) (propext eq_comm))) (iff.refl (s = r))))

theorem is_st_trans_real {r : ℝ} {s : ℝ} {t : ℝ} : is_st (↑r) s → is_st (↑s) t → is_st (↑r) t :=
  eq.mpr (id (Eq._oldrec (Eq.refl (is_st (↑r) s → is_st (↑s) t → is_st (↑r) t)) (propext is_st_real_iff_eq)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (r = s → is_st (↑s) t → is_st (↑r) t)) (propext is_st_real_iff_eq)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (r = s → s = t → is_st (↑r) t)) (propext is_st_real_iff_eq))) Eq.trans))

theorem is_st_inj_real {r₁ : ℝ} {r₂ : ℝ} {s : ℝ} (h1 : is_st (↑r₁) s) (h2 : is_st (↑r₂) s) : r₁ = r₂ :=
  Eq.trans (eq_of_is_st_real h1) (Eq.symm (eq_of_is_st_real h2))

theorem is_st_iff_abs_sub_lt_delta {x : ℝ*} {r : ℝ} : is_st x r ↔ ∀ (δ : ℝ), 0 < δ → abs (x - ↑r) < ↑δ := sorry

theorem is_st_add {x : ℝ*} {y : ℝ*} {r : ℝ} {s : ℝ} : is_st x r → is_st y s → is_st (x + y) (r + s) := sorry

theorem is_st_neg {x : ℝ*} {r : ℝ} (hxr : is_st x r) : is_st (-x) (-r) := sorry

theorem is_st_sub {x : ℝ*} {y : ℝ*} {r : ℝ} {s : ℝ} : is_st x r → is_st y s → is_st (x - y) (r - s) :=
  fun (hxr : is_st x r) (hys : is_st y s) =>
    eq.mpr (id (Eq._oldrec (Eq.refl (is_st (x - y) (r - s))) (sub_eq_add_neg x y)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (is_st (x + -y) (r - s))) (sub_eq_add_neg r s))) (is_st_add hxr (is_st_neg hys)))

/- (st x < st y) → (x < y) → (x ≤ y) → (st x ≤ st y) -/

theorem lt_of_is_st_lt {x : ℝ*} {y : ℝ*} {r : ℝ} {s : ℝ} (hxr : is_st x r) (hys : is_st y s) : r < s → x < y := sorry

theorem is_st_le_of_le {x : ℝ*} {y : ℝ*} {r : ℝ} {s : ℝ} (hrx : is_st x r) (hsy : is_st y s) : x ≤ y → r ≤ s :=
  eq.mpr (id (Eq._oldrec (Eq.refl (x ≤ y → r ≤ s)) (Eq.symm (propext not_lt))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (¬y < x → r ≤ s)) (Eq.symm (propext not_lt))))
      (eq.mpr (id (Eq._oldrec (Eq.refl (¬y < x → ¬s < r)) (propext not_imp_not))) (lt_of_is_st_lt hsy hrx)))

theorem st_le_of_le {x : ℝ*} {y : ℝ*} (hix : ¬infinite x) (hiy : ¬infinite y) : x ≤ y → st x ≤ st y :=
  (fun (hx' : is_st x (st x)) => (fun (hy' : is_st y (st y)) => is_st_le_of_le hx' hy') (is_st_st' hiy)) (is_st_st' hix)

theorem lt_of_st_lt {x : ℝ*} {y : ℝ*} (hix : ¬infinite x) (hiy : ¬infinite y) : st x < st y → x < y :=
  (fun (hx' : is_st x (st x)) => (fun (hy' : is_st y (st y)) => lt_of_is_st_lt hx' hy') (is_st_st' hiy)) (is_st_st' hix)

/-!
### Basic lemmas about infinite
-/

theorem infinite_pos_def {x : ℝ*} : infinite_pos x ↔ ∀ (r : ℝ), ↑r < x :=
  eq.mpr (id (Eq._oldrec (Eq.refl (infinite_pos x ↔ ∀ (r : ℝ), ↑r < x)) iff_eq_eq)) (Eq.refl (infinite_pos x))

theorem infinite_neg_def {x : ℝ*} : infinite_neg x ↔ ∀ (r : ℝ), x < ↑r :=
  eq.mpr (id (Eq._oldrec (Eq.refl (infinite_neg x ↔ ∀ (r : ℝ), x < ↑r)) iff_eq_eq)) (Eq.refl (infinite_neg x))

theorem ne_zero_of_infinite {x : ℝ*} : infinite x → x ≠ 0 := sorry

theorem not_infinite_zero : ¬infinite 0 :=
  fun (hI : infinite 0) => ne_zero_of_infinite hI rfl

theorem pos_of_infinite_pos {x : ℝ*} : infinite_pos x → 0 < x :=
  fun (hip : infinite_pos x) => hip 0

theorem neg_of_infinite_neg {x : ℝ*} : infinite_neg x → x < 0 :=
  fun (hin : infinite_neg x) => hin 0

theorem not_infinite_pos_of_infinite_neg {x : ℝ*} : infinite_neg x → ¬infinite_pos x :=
  fun (hn : infinite_neg x) (hp : infinite_pos x) => not_lt_of_lt (hn 1) (hp 1)

theorem not_infinite_neg_of_infinite_pos {x : ℝ*} : infinite_pos x → ¬infinite_neg x :=
  iff.mp imp_not_comm not_infinite_pos_of_infinite_neg

theorem infinite_neg_neg_of_infinite_pos {x : ℝ*} : infinite_pos x → infinite_neg (-x) :=
  fun (hp : infinite_pos x) (r : ℝ) => iff.mp neg_lt (hp (-r))

theorem infinite_pos_neg_of_infinite_neg {x : ℝ*} : infinite_neg x → infinite_pos (-x) :=
  fun (hp : infinite_neg x) (r : ℝ) => iff.mp lt_neg (hp (-r))

theorem infinite_pos_iff_infinite_neg_neg {x : ℝ*} : infinite_pos x ↔ infinite_neg (-x) :=
  { mp := infinite_neg_neg_of_infinite_pos,
    mpr := fun (hin : infinite_neg (-x)) => neg_neg x ▸ infinite_pos_neg_of_infinite_neg hin }

theorem infinite_neg_iff_infinite_pos_neg {x : ℝ*} : infinite_neg x ↔ infinite_pos (-x) :=
  { mp := infinite_pos_neg_of_infinite_neg,
    mpr := fun (hin : infinite_pos (-x)) => neg_neg x ▸ infinite_neg_neg_of_infinite_pos hin }

theorem infinite_iff_infinite_neg {x : ℝ*} : infinite x ↔ infinite (-x) := sorry

theorem not_infinite_of_infinitesimal {x : ℝ*} : infinitesimal x → ¬infinite x := sorry

theorem not_infinitesimal_of_infinite {x : ℝ*} : infinite x → ¬infinitesimal x :=
  iff.mp imp_not_comm not_infinite_of_infinitesimal

theorem not_infinitesimal_of_infinite_pos {x : ℝ*} : infinite_pos x → ¬infinitesimal x :=
  fun (hp : infinite_pos x) => not_infinitesimal_of_infinite (Or.inl hp)

theorem not_infinitesimal_of_infinite_neg {x : ℝ*} : infinite_neg x → ¬infinitesimal x :=
  fun (hn : infinite_neg x) => not_infinitesimal_of_infinite (Or.inr hn)

theorem infinite_pos_iff_infinite_and_pos {x : ℝ*} : infinite_pos x ↔ infinite x ∧ 0 < x := sorry

theorem infinite_neg_iff_infinite_and_neg {x : ℝ*} : infinite_neg x ↔ infinite x ∧ x < 0 := sorry

theorem infinite_pos_iff_infinite_of_pos {x : ℝ*} (hp : 0 < x) : infinite_pos x ↔ infinite x :=
  eq.mpr (id (Eq._oldrec (Eq.refl (infinite_pos x ↔ infinite x)) (propext infinite_pos_iff_infinite_and_pos)))
    { mp := fun (hI : infinite x ∧ 0 < x) => and.left hI, mpr := fun (hI : infinite x) => { left := hI, right := hp } }

theorem infinite_pos_iff_infinite_of_nonneg {x : ℝ*} (hp : 0 ≤ x) : infinite_pos x ↔ infinite x := sorry

theorem infinite_neg_iff_infinite_of_neg {x : ℝ*} (hn : x < 0) : infinite_neg x ↔ infinite x :=
  eq.mpr (id (Eq._oldrec (Eq.refl (infinite_neg x ↔ infinite x)) (propext infinite_neg_iff_infinite_and_neg)))
    { mp := fun (hI : infinite x ∧ x < 0) => and.left hI, mpr := fun (hI : infinite x) => { left := hI, right := hn } }

theorem infinite_pos_abs_iff_infinite_abs {x : ℝ*} : infinite_pos (abs x) ↔ infinite (abs x) :=
  infinite_pos_iff_infinite_of_nonneg (abs_nonneg x)

theorem infinite_iff_infinite_pos_abs {x : ℝ*} : infinite x ↔ infinite_pos (abs x) := sorry

theorem infinite_iff_infinite_abs {x : ℝ*} : infinite x ↔ infinite (abs x) := sorry

theorem infinite_iff_abs_lt_abs {x : ℝ*} : infinite x ↔ ∀ (r : ℝ), abs ↑r < abs x := sorry

theorem infinite_pos_add_not_infinite_neg {x : ℝ*} {y : ℝ*} : infinite_pos x → ¬infinite_neg y → infinite_pos (x + y) := sorry

theorem not_infinite_neg_add_infinite_pos {x : ℝ*} {y : ℝ*} : ¬infinite_neg x → infinite_pos y → infinite_pos (x + y) :=
  fun (hx : ¬infinite_neg x) (hy : infinite_pos y) =>
    eq.mpr (id (Eq._oldrec (Eq.refl (infinite_pos (x + y))) (add_comm x y))) (infinite_pos_add_not_infinite_neg hy hx)

theorem infinite_neg_add_not_infinite_pos {x : ℝ*} {y : ℝ*} : infinite_neg x → ¬infinite_pos y → infinite_neg (x + y) := sorry

theorem not_infinite_pos_add_infinite_neg {x : ℝ*} {y : ℝ*} : ¬infinite_pos x → infinite_neg y → infinite_neg (x + y) :=
  fun (hx : ¬infinite_pos x) (hy : infinite_neg y) =>
    eq.mpr (id (Eq._oldrec (Eq.refl (infinite_neg (x + y))) (add_comm x y))) (infinite_neg_add_not_infinite_pos hy hx)

theorem infinite_pos_add_infinite_pos {x : ℝ*} {y : ℝ*} : infinite_pos x → infinite_pos y → infinite_pos (x + y) :=
  fun (hx : infinite_pos x) (hy : infinite_pos y) =>
    infinite_pos_add_not_infinite_neg hx (not_infinite_neg_of_infinite_pos hy)

theorem infinite_neg_add_infinite_neg {x : ℝ*} {y : ℝ*} : infinite_neg x → infinite_neg y → infinite_neg (x + y) :=
  fun (hx : infinite_neg x) (hy : infinite_neg y) =>
    infinite_neg_add_not_infinite_pos hx (not_infinite_pos_of_infinite_neg hy)

theorem infinite_pos_add_not_infinite {x : ℝ*} {y : ℝ*} : infinite_pos x → ¬infinite y → infinite_pos (x + y) :=
  fun (hx : infinite_pos x) (hy : ¬infinite y) =>
    infinite_pos_add_not_infinite_neg hx (and.right (iff.mp not_or_distrib hy))

theorem infinite_neg_add_not_infinite {x : ℝ*} {y : ℝ*} : infinite_neg x → ¬infinite y → infinite_neg (x + y) :=
  fun (hx : infinite_neg x) (hy : ¬infinite y) =>
    infinite_neg_add_not_infinite_pos hx (and.left (iff.mp not_or_distrib hy))

theorem infinite_pos_of_tendsto_top {f : ℕ → ℝ} (hf : filter.tendsto f filter.at_top filter.at_top) : infinite_pos (of_seq f) := sorry

theorem infinite_neg_of_tendsto_bot {f : ℕ → ℝ} (hf : filter.tendsto f filter.at_top filter.at_bot) : infinite_neg (of_seq f) := sorry

theorem not_infinite_neg {x : ℝ*} : ¬infinite x → ¬infinite (-x) :=
  iff.mpr not_imp_not (iff.mpr infinite_iff_infinite_neg)

theorem not_infinite_add {x : ℝ*} {y : ℝ*} (hx : ¬infinite x) (hy : ¬infinite y) : ¬infinite (x + y) := sorry

theorem not_infinite_iff_exist_lt_gt {x : ℝ*} : ¬infinite x ↔ ∃ (r : ℝ), ∃ (s : ℝ), ↑r < x ∧ x < ↑s := sorry

theorem not_infinite_real (r : ℝ) : ¬infinite ↑r :=
  eq.mpr (id (Eq._oldrec (Eq.refl (¬infinite ↑r)) (propext not_infinite_iff_exist_lt_gt)))
    (Exists.intro (r - 1)
      (Exists.intro (r + 1) { left := iff.mpr coe_lt_coe (sub_one_lt r), right := iff.mpr coe_lt_coe (lt_add_one r) }))

theorem not_real_of_infinite {x : ℝ*} : infinite x → ∀ (r : ℝ), x ≠ ↑r :=
  fun (hi : infinite x) (r : ℝ) (hr : x = ↑r) => not_infinite_real r (hr ▸ hi)

/-!
### Facts about `st` that require some infinite machinery
-/

theorem is_st_mul {x : ℝ*} {y : ℝ*} {r : ℝ} {s : ℝ} (hxr : is_st x r) (hys : is_st y s) : is_st (x * y) (r * s) := sorry

--AN INFINITE LEMMA THAT REQUIRES SOME MORE ST MACHINERY

theorem not_infinite_mul {x : ℝ*} {y : ℝ*} (hx : ¬infinite x) (hy : ¬infinite y) : ¬infinite (x * y) := sorry

---

theorem st_add {x : ℝ*} {y : ℝ*} (hx : ¬infinite x) (hy : ¬infinite y) : st (x + y) = st x + st y := sorry

theorem st_neg (x : ℝ*) : st (-x) = -st x := sorry

theorem st_mul {x : ℝ*} {y : ℝ*} (hx : ¬infinite x) (hy : ¬infinite y) : st (x * y) = st x * st y := sorry

/-!
### Basic lemmas about infinitesimal
-/

theorem infinitesimal_def {x : ℝ*} : infinitesimal x ↔ ∀ (r : ℝ), 0 < r → -↑r < x ∧ x < ↑r := sorry

theorem lt_of_pos_of_infinitesimal {x : ℝ*} : infinitesimal x → ∀ (r : ℝ), 0 < r → x < ↑r :=
  fun (hi : infinitesimal x) (r : ℝ) (hr : 0 < r) => and.right (iff.mp infinitesimal_def hi r hr)

theorem lt_neg_of_pos_of_infinitesimal {x : ℝ*} : infinitesimal x → ∀ (r : ℝ), 0 < r → -↑r < x :=
  fun (hi : infinitesimal x) (r : ℝ) (hr : 0 < r) => and.left (iff.mp infinitesimal_def hi r hr)

theorem gt_of_neg_of_infinitesimal {x : ℝ*} : infinitesimal x → ∀ (r : ℝ), r < 0 → ↑r < x := sorry

theorem abs_lt_real_iff_infinitesimal {x : ℝ*} : infinitesimal x ↔ ∀ (r : ℝ), r ≠ 0 → abs x < abs ↑r := sorry

theorem infinitesimal_zero : infinitesimal 0 :=
  is_st_refl_real 0

theorem zero_of_infinitesimal_real {r : ℝ} : infinitesimal ↑r → r = 0 :=
  eq_of_is_st_real

theorem zero_iff_infinitesimal_real {r : ℝ} : infinitesimal ↑r ↔ r = 0 :=
  { mp := zero_of_infinitesimal_real,
    mpr := fun (hr : r = 0) => eq.mpr (id (Eq._oldrec (Eq.refl (infinitesimal ↑r)) hr)) infinitesimal_zero }

theorem infinitesimal_add {x : ℝ*} {y : ℝ*} (hx : infinitesimal x) (hy : infinitesimal y) : infinitesimal (x + y) := sorry

theorem infinitesimal_neg {x : ℝ*} (hx : infinitesimal x) : infinitesimal (-x) := sorry

theorem infinitesimal_neg_iff {x : ℝ*} : infinitesimal x ↔ infinitesimal (-x) :=
  { mp := infinitesimal_neg, mpr := fun (h : infinitesimal (-x)) => neg_neg x ▸ infinitesimal_neg h }

theorem infinitesimal_mul {x : ℝ*} {y : ℝ*} (hx : infinitesimal x) (hy : infinitesimal y) : infinitesimal (x * y) := sorry

theorem infinitesimal_of_tendsto_zero {f : ℕ → ℝ} : filter.tendsto f filter.at_top (nhds 0) → infinitesimal (of_seq f) := sorry

theorem infinitesimal_epsilon : infinitesimal epsilon :=
  infinitesimal_of_tendsto_zero tendsto_inverse_at_top_nhds_0_nat

theorem not_real_of_infinitesimal_ne_zero (x : ℝ*) : infinitesimal x → x ≠ 0 → ∀ (r : ℝ), x ≠ ↑r :=
  fun (hi : infinitesimal x) (hx : x ≠ 0) (r : ℝ) (hr : x = ↑r) =>
    hx (Eq.trans hr (iff.mpr coe_eq_zero (is_st_unique (Eq.symm hr ▸ is_st_refl_real r) hi)))

theorem infinitesimal_sub_is_st {x : ℝ*} {r : ℝ} (hxr : is_st x r) : infinitesimal (x - ↑r) := sorry

theorem infinitesimal_sub_st {x : ℝ*} (hx : ¬infinite x) : infinitesimal (x - ↑(st x)) :=
  infinitesimal_sub_is_st (is_st_st' hx)

theorem infinite_pos_iff_infinitesimal_inv_pos {x : ℝ*} : infinite_pos x ↔ infinitesimal (x⁻¹) ∧ 0 < (x⁻¹) := sorry

theorem infinite_neg_iff_infinitesimal_inv_neg {x : ℝ*} : infinite_neg x ↔ infinitesimal (x⁻¹) ∧ x⁻¹ < 0 := sorry

theorem infinitesimal_inv_of_infinite {x : ℝ*} : infinite x → infinitesimal (x⁻¹) :=
  fun (hi : infinite x) =>
    or.cases_on hi (fun (hip : infinite_pos x) => and.left (iff.mp infinite_pos_iff_infinitesimal_inv_pos hip))
      fun (hin : infinite_neg x) => and.left (iff.mp infinite_neg_iff_infinitesimal_inv_neg hin)

theorem infinite_of_infinitesimal_inv {x : ℝ*} (h0 : x ≠ 0) (hi : infinitesimal (x⁻¹)) : infinite x := sorry

theorem infinite_iff_infinitesimal_inv {x : ℝ*} (h0 : x ≠ 0) : infinite x ↔ infinitesimal (x⁻¹) :=
  { mp := infinitesimal_inv_of_infinite, mpr := infinite_of_infinitesimal_inv h0 }

theorem infinitesimal_pos_iff_infinite_pos_inv {x : ℝ*} : infinite_pos (x⁻¹) ↔ infinitesimal x ∧ 0 < x := sorry

theorem infinitesimal_neg_iff_infinite_neg_inv {x : ℝ*} : infinite_neg (x⁻¹) ↔ infinitesimal x ∧ x < 0 := sorry

theorem infinitesimal_iff_infinite_inv {x : ℝ*} (h : x ≠ 0) : infinitesimal x ↔ infinite (x⁻¹) := sorry

/-!
### `st` stuff that requires infinitesimal machinery
-/

theorem is_st_of_tendsto {f : ℕ → ℝ} {r : ℝ} (hf : filter.tendsto f filter.at_top (nhds r)) : is_st (of_seq f) r := sorry

theorem is_st_inv {x : ℝ*} {r : ℝ} (hi : ¬infinitesimal x) : is_st x r → is_st (x⁻¹) (r⁻¹) := sorry

theorem st_inv (x : ℝ*) : st (x⁻¹) = (st x⁻¹) := sorry

/-!
### Infinite stuff that requires infinitesimal machinery
-/

theorem infinite_pos_omega : infinite_pos omega :=
  iff.mpr infinite_pos_iff_infinitesimal_inv_pos { left := infinitesimal_epsilon, right := epsilon_pos }

theorem infinite_omega : infinite omega :=
  iff.mpr (infinite_iff_infinitesimal_inv omega_ne_zero) infinitesimal_epsilon

theorem infinite_pos_mul_of_infinite_pos_not_infinitesimal_pos {x : ℝ*} {y : ℝ*} : infinite_pos x → ¬infinitesimal y → 0 < y → infinite_pos (x * y) := sorry

theorem infinite_pos_mul_of_not_infinitesimal_pos_infinite_pos {x : ℝ*} {y : ℝ*} : ¬infinitesimal x → 0 < x → infinite_pos y → infinite_pos (x * y) :=
  fun (hx : ¬infinitesimal x) (hp : 0 < x) (hy : infinite_pos y) =>
    eq.mpr (id (Eq._oldrec (Eq.refl (infinite_pos (x * y))) (mul_comm x y)))
      (infinite_pos_mul_of_infinite_pos_not_infinitesimal_pos hy hx hp)

theorem infinite_pos_mul_of_infinite_neg_not_infinitesimal_neg {x : ℝ*} {y : ℝ*} : infinite_neg x → ¬infinitesimal y → y < 0 → infinite_pos (x * y) := sorry

theorem infinite_pos_mul_of_not_infinitesimal_neg_infinite_neg {x : ℝ*} {y : ℝ*} : ¬infinitesimal x → x < 0 → infinite_neg y → infinite_pos (x * y) :=
  fun (hx : ¬infinitesimal x) (hp : x < 0) (hy : infinite_neg y) =>
    eq.mpr (id (Eq._oldrec (Eq.refl (infinite_pos (x * y))) (mul_comm x y)))
      (infinite_pos_mul_of_infinite_neg_not_infinitesimal_neg hy hx hp)

theorem infinite_neg_mul_of_infinite_pos_not_infinitesimal_neg {x : ℝ*} {y : ℝ*} : infinite_pos x → ¬infinitesimal y → y < 0 → infinite_neg (x * y) := sorry

theorem infinite_neg_mul_of_not_infinitesimal_neg_infinite_pos {x : ℝ*} {y : ℝ*} : ¬infinitesimal x → x < 0 → infinite_pos y → infinite_neg (x * y) :=
  fun (hx : ¬infinitesimal x) (hp : x < 0) (hy : infinite_pos y) =>
    eq.mpr (id (Eq._oldrec (Eq.refl (infinite_neg (x * y))) (mul_comm x y)))
      (infinite_neg_mul_of_infinite_pos_not_infinitesimal_neg hy hx hp)

theorem infinite_neg_mul_of_infinite_neg_not_infinitesimal_pos {x : ℝ*} {y : ℝ*} : infinite_neg x → ¬infinitesimal y → 0 < y → infinite_neg (x * y) := sorry

theorem infinite_neg_mul_of_not_infinitesimal_pos_infinite_neg {x : ℝ*} {y : ℝ*} : ¬infinitesimal x → 0 < x → infinite_neg y → infinite_neg (x * y) :=
  fun (hx : ¬infinitesimal x) (hp : 0 < x) (hy : infinite_neg y) =>
    eq.mpr (id (Eq._oldrec (Eq.refl (infinite_neg (x * y))) (mul_comm x y)))
      (infinite_neg_mul_of_infinite_neg_not_infinitesimal_pos hy hx hp)

theorem infinite_pos_mul_infinite_pos {x : ℝ*} {y : ℝ*} : infinite_pos x → infinite_pos y → infinite_pos (x * y) :=
  fun (hx : infinite_pos x) (hy : infinite_pos y) =>
    infinite_pos_mul_of_infinite_pos_not_infinitesimal_pos hx (not_infinitesimal_of_infinite_pos hy) (hy 0)

theorem infinite_neg_mul_infinite_neg {x : ℝ*} {y : ℝ*} : infinite_neg x → infinite_neg y → infinite_pos (x * y) :=
  fun (hx : infinite_neg x) (hy : infinite_neg y) =>
    infinite_pos_mul_of_infinite_neg_not_infinitesimal_neg hx (not_infinitesimal_of_infinite_neg hy) (hy 0)

theorem infinite_pos_mul_infinite_neg {x : ℝ*} {y : ℝ*} : infinite_pos x → infinite_neg y → infinite_neg (x * y) :=
  fun (hx : infinite_pos x) (hy : infinite_neg y) =>
    infinite_neg_mul_of_infinite_pos_not_infinitesimal_neg hx (not_infinitesimal_of_infinite_neg hy) (hy 0)

theorem infinite_neg_mul_infinite_pos {x : ℝ*} {y : ℝ*} : infinite_neg x → infinite_pos y → infinite_neg (x * y) :=
  fun (hx : infinite_neg x) (hy : infinite_pos y) =>
    infinite_neg_mul_of_infinite_neg_not_infinitesimal_pos hx (not_infinitesimal_of_infinite_pos hy) (hy 0)

theorem infinite_mul_of_infinite_not_infinitesimal {x : ℝ*} {y : ℝ*} : infinite x → ¬infinitesimal y → infinite (x * y) := sorry

theorem infinite_mul_of_not_infinitesimal_infinite {x : ℝ*} {y : ℝ*} : ¬infinitesimal x → infinite y → infinite (x * y) :=
  fun (hx : ¬infinitesimal x) (hy : infinite y) =>
    eq.mpr (id (Eq._oldrec (Eq.refl (infinite (x * y))) (mul_comm x y)))
      (infinite_mul_of_infinite_not_infinitesimal hy hx)

theorem infinite_mul_infinite {x : ℝ*} {y : ℝ*} : infinite x → infinite y → infinite (x * y) :=
  fun (hx : infinite x) (hy : infinite y) =>
    infinite_mul_of_infinite_not_infinitesimal hx (not_infinitesimal_of_infinite hy)


import topology.category.Top

namespace Top

open category_theory
open topological_space

universes u
variables (X : Top.{u})

structure oc : Type (u+1) :=
(ι : Type.{u})
[lo : linear_order ι . tactic.apply_instance]
[wo : is_well_order ι ((<) : ι → ι → Prop) . tactic.apply_instance]
(cover : ι → opens X)
(is_cover : supr cover = ⊤)

attribute [instance] oc.lo oc.wo
attribute [simp] oc.is_cover

instance (A : X.oc) [nonempty X] : nonempty A.ι :=
⟨nonempty.some $ classical.by_contradiction $ λ r, @@is_empty.false (not_nonempty_iff.mp r) $
  (opens.mem_supr.mp (by rw A.is_cover; trivial : nonempty.some infer_instance ∈ supr A.cover)).some⟩

noncomputable instance (A : X.oc) [inhabited X] : inhabited A.ι :=
⟨nonempty.some infer_instance⟩

variables {X}
/--
A cover `𝔄` refines a cover `𝔅` if there is a function `f` between their indexing sets such that
for all `i` in indexing set of `𝔄`, `𝔄ᵢ ⊆ 𝔅_{f i}`
-/
@[ext] structure refines (𝔄 𝔅 : X.oc) : Type (u+1) :=
(func : 𝔄.ι → 𝔅.ι)
-- (strict_mono : strict_mono func)
(is_refinement : ∀ i : 𝔄.ι, 𝔄.cover i ≤ 𝔅.cover (func i))

def refines.refl (𝔄 : X.oc) : refines 𝔄 𝔄 :=
{ func := id,
  -- strict_mono := strict_mono_id,
  -- is_inj := function.injective_id,
  is_refinement := λ i, le_refl _ }

def refines.trans {𝔄 𝔅 ℭ : X.oc} (r1 : refines 𝔄 𝔅) (r2 : refines 𝔅 ℭ) : refines 𝔄 ℭ :=
{ func := r2.func ∘ r1.func,
  -- is_inj := function.injective.comp (r2.is_inj) (r1.is_inj),
  -- strict_mono := strict_mono.comp (r2.strict_mono) (r1.strict_mono),
  is_refinement := λ i, le_trans (r1.is_refinement i) (r2.is_refinement $ r1.func i) }

-- instance : has_le X.oc :=
-- { le := λ 𝔄 𝔅, nonempty (refines 𝔄 𝔅) }

-- instance : has_lt X.oc :=
-- { lt := λ 𝔄 𝔅, 𝔄 ≤ 𝔅 ∧ ¬ 𝔅 ≤ 𝔄 }

instance : inhabited X.oc :=
{ default :=
  { ι := punit,
    wo := ⟨{ apply := λ x, by { cases x, fconstructor, rintros ⟨-⟩ r, exfalso, simpa using r } }⟩,
    cover := λ _, ⊤,
    is_cover := by simp } }

-- this is probably wrong
-- example (A : X.oc) (f : refines A A) (i) : f.func i = i :=
-- begin
--   have := @trichotomous _ ((<) : A.ι → A.ι → Prop) _ (f.func i) i,
--   rcases this,
--   { -- this is contradiction
--     -- suppose `a` is the least function such that `f a < a` then `f f a < f a < a` contradiction
--     sorry },
--   { rcases this,
--     { exact this },
--     { --
--       sorry } },
-- end

-- instance : preorder X.oc :=
-- { le := (≤),
--   lt := (<),
--   le_refl := λ x, nonempty.intro $ refines.refl _,
--   le_trans := λ _ _ _ ⟨r1⟩ ⟨r2⟩, ⟨r1.trans r2⟩,
--   lt_iff_le_not_le := λ _ _, ⟨id, id⟩ }

-- def common_refinement (A B : X.oc) : X.oc :=
-- { ι := A.ι ⊗ B.ι,
--   lo :=
--   { le := sum.lex ((≤) : A.ι → A.ι → Prop) ((≤) : B.ι → B.ι → Prop),
--     lt := _,
--     le_refl := _,
--     le_trans := _,
--     lt_iff_le_not_le := _,
--     le_antisymm := _,
--     le_total := _,
--     decidable_le := _,
--     decidable_eq := _,
--     decidable_lt := _,
--     max := _,
--     max_def := _,
--     min := _,
--     min_def := _ },
--   wo := _,
--   cover := λ i, sum.rec_on i A.cover B.cover,
--   is_cover := sorry }

instance : category_theory.small_category X.oc :=
{ hom := λ A B, refines A B,
  id := λ A, refines.refl A,
  comp := λ A B C f g, refines.trans f g,
  id_comp' := λ A B f, by ext; refl,
  comp_id' := λ A B f, by ext; refl,
  assoc' := λ A B C D f g h, by ext; refl }

-- instance : category_theory.is_cofiltered X.oc :=
-- { cocone_objs := λ A B, sorry, -- common refinement
--   cocone_maps := λ A B, sorry,
--   /-
--   A indexed by a
--   B indexed by b
--                   f
--   W -------> A ========> B
--                   g

--   such that f ≫ h = g ≫ h

--   -/
--   nonempty := ⟨default⟩ }

end Top


/-
Copyright (c) 2021 Justus Springer. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Justus Springer, Andrew Yang
-/
import algebra.category.Ring.filtered_colimits
import algebraic_geometry.sheafed_space
import topology.sheaves.stalks
import algebra.category.Ring.colimits
import algebra.category.Ring.limits

/-!
# Ringed spaces

We introduce the category of ringed spaces, as an alias for `SheafedSpace CommRing`.

The facts collected in this file are typically stated for locally ringed spaces, but never actually
make use of the locality of stalks. See for instance <https://stacks.math.columbia.edu/tag/01HZ>.

-/

universe v

open category_theory
open topological_space
open opposite
open Top
open Top.presheaf

namespace algebraic_geometry

/-- The type of Ringed spaces, as an abbreviation for `SheafedSpace CommRing`. -/
abbreviation RingedSpace : Type* := SheafedSpace CommRing

namespace RingedSpace

open SheafedSpace

variables (X : RingedSpace.{v})

/--
If the germ of a section `f` is a unit in the stalk at `x`, then `f` must be a unit on some small
neighborhood around `x`.
-/
lemma is_unit_res_of_is_unit_germ (U : opens X) (f : X.presheaf.obj (op U)) (x : U)
  (h : is_unit (X.presheaf.germ x f)) :
  ∃ (V : opens X) (i : V ⟶ U) (hxV : x.1 ∈ V), is_unit (X.presheaf.map i.op f) :=
begin
  obtain ⟨g', heq⟩ := h.exists_right_inv,
  obtain ⟨V, hxV, g, rfl⟩ := X.presheaf.germ_exist x.1 g',
  let W := U ⊓ V,
  have hxW : x.1 ∈ W := ⟨x.2, hxV⟩,
  erw [← X.presheaf.germ_res_apply (opens.inf_le_left U V) ⟨x.1, hxW⟩ f,
    ← X.presheaf.germ_res_apply (opens.inf_le_right U V) ⟨x.1, hxW⟩ g,
    ← ring_hom.map_mul, ← ring_hom.map_one (X.presheaf.germ (⟨x.1, hxW⟩ : W))] at heq,
  obtain ⟨W', hxW', i₁, i₂, heq'⟩ := X.presheaf.germ_eq x.1 hxW hxW _ _ heq,
  use [W', i₁ ≫ opens.inf_le_left U V, hxW'],
  rw [ring_hom.map_one, ring_hom.map_mul, ← comp_apply, ← X.presheaf.map_comp, ← op_comp] at heq',
  exact is_unit_of_mul_eq_one _ _ heq',
end

/-- If a section `f` is a unit in each stalk, `f` must be a unit. -/
lemma is_unit_of_is_unit_germ (U : opens X) (f : X.presheaf.obj (op U))
  (h : ∀ x : U, is_unit (X.presheaf.germ x f)) :
  is_unit f :=
begin
  -- We pick a cover of `U` by open sets `V x`, such that `f` is a unit on each `V x`.
  choose V iVU m h_unit using λ x : U, X.is_unit_res_of_is_unit_germ U f x (h x),
  have hcover : U ≤ supr V,
  { intros x hxU,
    rw [opens.mem_supr],
    exact ⟨⟨x, hxU⟩, m ⟨x, hxU⟩⟩ },
  -- Let `g x` denote the inverse of `f` in `U x`.
  choose g hg using λ x : U, is_unit.exists_right_inv (h_unit x),
  -- We claim that these local inverses glue together to a global inverse of `f`.
  obtain ⟨gl, gl_spec, -⟩ := X.sheaf.exists_unique_gluing' V U iVU hcover g _,
  swap,
  { intros x y,
    apply section_ext X.sheaf (V x ⊓ V y),
    rintro ⟨z, hzVx, hzVy⟩,
    rw [germ_res_apply, germ_res_apply],
    apply (is_unit.mul_right_inj (h ⟨z, (iVU x).le hzVx⟩)).mp,
    erw [← X.presheaf.germ_res_apply (iVU x) ⟨z, hzVx⟩ f, ← ring_hom.map_mul,
      congr_arg (X.presheaf.germ (⟨z, hzVx⟩ : V x)) (hg x), germ_res_apply,
      ← X.presheaf.germ_res_apply (iVU y) ⟨z, hzVy⟩ f, ← ring_hom.map_mul,
      congr_arg (X.presheaf.germ (⟨z, hzVy⟩ : V y)) (hg y),
      ring_hom.map_one, ring_hom.map_one] },
  apply is_unit_of_mul_eq_one f gl,
  apply X.sheaf.eq_of_locally_eq' V U iVU hcover,
  intro i,
  rw [ring_hom.map_one, ring_hom.map_mul, gl_spec],
  exact hg i,
end

/--
The basic open of a section `f` is the set of all points `x`, such that the germ of `f` at
`x` is a unit.
-/
def basic_open {U : opens X} (f : X.presheaf.obj (op U)) : opens X :=
{ carrier := coe '' { x : U | is_unit (X.presheaf.germ x f) },
  is_open' := begin
    rw is_open_iff_forall_mem_open,
    rintros _ ⟨x, hx, rfl⟩,
    obtain ⟨V, i, hxV, hf⟩ := X.is_unit_res_of_is_unit_germ U f x hx,
    use V.1,
    refine ⟨_, V.2, hxV⟩,
    intros y hy,
    use (⟨y, i.le hy⟩ : U),
    rw set.mem_set_of_eq,
    split,
    { convert ring_hom.is_unit_map (X.presheaf.germ ⟨y, hy⟩) hf,
      exact (X.presheaf.germ_res_apply i ⟨y, hy⟩ f).symm },
    { refl }
  end }

@[simp]
lemma mem_basic_open {U : opens X} (f : X.presheaf.obj (op U)) (x : U) :
  ↑x ∈ X.basic_open f ↔ is_unit (X.presheaf.germ x f) :=
begin
  split,
  { rintro ⟨x, hx, a⟩, cases subtype.eq a, exact hx },
  { intro h, exact ⟨x, h, rfl⟩ },
end

@[simp]
lemma mem_top_basic_open (f : X.presheaf.obj (op ⊤)) (x : X) :
  x ∈ X.basic_open f ↔ is_unit (X.presheaf.germ ⟨x, show x ∈ (⊤ : opens X), by trivial⟩ f) :=
mem_basic_open X f ⟨x, _⟩

lemma basic_open_le {U : opens X} (f : X.presheaf.obj (op U)) : X.basic_open f ≤ U :=
by { rintros _ ⟨x, hx, rfl⟩, exact x.2 }

/-- The restriction of a section `f` to the basic open of `f` is a unit. -/

@[simp] lemma basic_open_res {U V : (opens X)ᵒᵖ} (i : U ⟶ V) (f : X.presheaf.obj U) :
  @basic_open X (unop V) (X.presheaf.map i f) = (unop V) ⊓ @basic_open X (unop U) f :=
begin
  induction U using opposite.rec,
  induction V using opposite.rec,
  let g := i.unop, have : i = g.op := rfl, clear_value g, subst this,
  ext, split,
  { rintro ⟨x, (hx : is_unit _), rfl⟩,
    rw germ_res_apply at hx,
    exact ⟨x.2, g x, hx, rfl⟩ },
  { rintros ⟨hxV, x, hx, rfl⟩,
    refine ⟨⟨x, hxV⟩, (_ : is_unit _), rfl⟩,
    rwa germ_res_apply }
end

-- This should fire before `basic_open_res`.
@[simp, priority 1100] lemma basic_open_res_eq {U V : (opens X)ᵒᵖ} (i : U ⟶ V) [is_iso i]
  (f : X.presheaf.obj U) :
  @basic_open X (unop V) (X.presheaf.map i f) = @RingedSpace.basic_open X (unop U) f :=
begin
  apply le_antisymm,
  { rw X.basic_open_res i f, exact inf_le_right },
  { have := X.basic_open_res (inv i) (X.presheaf.map i f),
    rw [← comp_apply, ← X.presheaf.map_comp, is_iso.hom_inv_id, X.presheaf.map_id] at this,
    erw this,
    exact inf_le_right }
end

@[simp] lemma basic_open_mul {U : opens X} (f g : X.presheaf.obj (op U)) :
  X.basic_open (f * g) = X.basic_open f ⊓ X.basic_open g :=
begin
  ext1,
  dsimp [RingedSpace.basic_open],
  rw ←set.image_inter subtype.coe_injective,
  congr,
  ext,
  simp_rw map_mul,
  exact is_unit.mul_iff,
end

lemma basic_open_of_is_unit {U : opens X} {f : X.presheaf.obj (op U)} (hf : is_unit f) :
  X.basic_open f = U :=
begin
  apply le_antisymm,
  { exact X.basic_open_le f },
  intros x hx,
  erw X.mem_basic_open f (⟨x, hx⟩ : U),
  exact ring_hom.is_unit_map _ hf
end

end RingedSpace

end algebraic_geometry


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

open order

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: succ j_good.1.1 = 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 : succ j_good.1.1 ≤ 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 : succ m.1.1 < i := (ordinal.succ_lt_of_is_limit hlim).2 hm₀,
    have hmo : succ m.1.1 ≤ o := le_of_lt (lt_of_lt_of_le hm hio),
    have hsub : (l.support : set good) ⊆ (λ x : good, x.1.1 < succ m.1.1),
    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 (succ m.1.1) 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 : succ m.1 < i := (ordinal.succ_lt_of_is_limit hlim).2 hm₀,
    have hmo : succ m.1 ≤ o := le_of_lt (lt_of_lt_of_le hm hio),
    have hsub : (l.support : set ords) ⊆ (λ x : ords, x.1 < succ m.1),
    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 (succ m.1) 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 : succ j = i := le_antisymm (succ_le_iff.2 hj.1) hj.2,

  have not_j_lt_x : ∀ (x : good), ∀ (j : ordinal), x ∈ l.support → j < x.1.1 → succ j = i → false,
  { intros x j hx h_1 hj,
    have hi : succ j ≤ 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 : succ j_good.1.1 = 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 = succ j.1) →
    ∃ 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 : succ j = i := le_antisymm (succ_le_iff.2 hj.1) hj.2,

  have not_j_lt_x : ∀ (x : ords), ∀ (j : ordinal), x ∈ l.support → j < x.1 → succ j = i → false,
  { intros x j hx h_1 hj,
    have hi : succ j ≤ 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 < succ j := λ x p, lt_of_le_of_lt p (lt_succ 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 (lt_succ 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 = succ j.1) →
    ∃ 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,
    apply (ordinal.enum_le_enum r x.2 i.1.2).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),
  { rintro 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