import analysis.convex.gauge analysis.normed_space.basic
import topology.category.CompHaus.default
import .general_topology
import analysis.inner_product_space.euclidean_dist
import data.set.function
import .linear_algebra
import analysis.normed_space.hahn_banach.extension
import analysis.normed_space.add_torsor_bases

lemma convex_with_zero_in_int_is_absorbing {E : Type*} [seminormed_add_comm_group E]
  [normed_space ℝ E] (s : set E) (hs₁ : convex ℝ s) (hs₂ : (0 : E) ∈ interior s)
  : absorbent ℝ s :=
begin
  obtain ⟨t, ⟨ht1, ht2⟩, ht3⟩ := hs₂,
  rw metric.is_open_iff at ht1,
  obtain ⟨r, hr1, hr2⟩ := ht1 0 ht3,
  rw absorbent_iff_nonneg_lt, intro x,
  have H : 0 ≤ r⁻¹ * ∥x∥ := mul_nonneg (inv_nonneg.mpr (le_of_lt hr1)) (norm_nonneg x),
  refine ⟨r⁻¹ * ∥x∥, H, _⟩,
  intros a ha,
  have H' : 0 < ∥a∥ := lt_of_le_of_lt H ha,
  refine ⟨a⁻¹ • x, ht2 (hr2 _), _⟩,
  { rw [mem_ball_zero_iff, norm_smul, mul_comm, norm_inv, mul_inv_lt_iff,
        mul_comm, ← mul_inv_lt_iff, mul_comm], exact ha,
    { exact hr1 },
    { exact H' } },
  { rw ← mul_smul, rw mul_inv_cancel, exact one_smul _ x,
    intro ha', rw [ha', norm_zero] at H', exact lt_irrefl 0 H' }
end

lemma gauge_cont {E : Type*} [seminormed_add_comm_group E] [normed_space ℝ E] (s : set E)
  (hs₁ : convex ℝ s) (hs₂ : (0 : E) ∈ interior s) : uniform_continuous (gauge s) :=
begin
  have absorbs := convex_with_zero_in_int_is_absorbing s hs₁ hs₂,
  obtain ⟨t, ⟨ht1, ht2⟩, ht3⟩ := hs₂,
  rw metric.is_open_iff at ht1,
  obtain ⟨r, hr1, hr2⟩ := ht1 0 ht3,
  have h1 : continuous_at (gauge s) 0,
  { rw metric.continuous_at_iff, simp,
    intros ε hε,
    refine ⟨ε * r, mul_pos hε hr1, _⟩,
    intros x hx,
    rw abs_of_nonneg (gauge_nonneg _),
    refine lt_of_le_of_lt (gauge_mono (absorbent_ball _) (subset_trans hr2 ht2) x) _,
    { rw norm_zero, exact hr1 },
    { refine gauge_lt_of_mem_smul x ε hε (metric.mem_ball_self hr1) (convex_ball 0 r)
                                  metric.is_open_ball _,
      refine ⟨ε⁻¹ • x, _, _⟩,
      { rw [mem_ball_zero_iff, norm_smul, mul_comm, norm_inv, real.norm_eq_abs,
            abs_eq_self.mpr (le_of_lt hε), mul_inv_lt_iff hε],
        exact hx },
      { rw ← mul_smul, rw mul_inv_cancel, exact one_smul _ x,
        intro h, rw h at hε, exact lt_irrefl 0 hε } } },
  rw metric.uniform_continuous_iff,
  intros ε hε, rw metric.continuous_at_iff at h1,
  obtain ⟨δ, hδ, H⟩ := h1 ε hε, simp [abs_of_nonneg, gauge_nonneg] at H,
  refine ⟨δ, hδ, _⟩,
  intros x y hxy,
  rw dist_eq_norm at hxy ⊢,
  apply @lt_of_le_of_lt _ _ _ (max (gauge s (x - y)) (gauge s (y - x))),
  { rw real.norm_eq_abs, rw abs_le, split,
    rw [neg_le, neg_sub], refine le_trans _ (le_max_right _ _),
    swap, refine le_trans _ (le_max_left _ _),
    all_goals
    { rw sub_le_iff_le_add,
      refine le_trans (le_of_eq _) (gauge_add_le hs₁ absorbs _ _), rw sub_add_cancel } },
  { apply max_lt; apply H, exact hxy, rw norm_sub_rev, exact hxy }
end.

noncomputable
def normalize_by (K E : Type*) [is_R_or_C K] [normed_add_comm_group E] [normed_space K E]
  (f : E → K) := λ x, (f x * (∥x∥⁻¹ : K)) • x

lemma normalize_by_continuous (K E : Type*) [is_R_or_C K] [normed_add_comm_group E]
  [normed_space K E] (f : E → K) (hf1 : continuous f) (hf2 : f 0 = 0)
  : continuous (normalize_by K E f) :=
begin
  suffices : continuous_on (normalize_by K E f) (set.univ \ {0})
           ∧ continuous_at (normalize_by K E f) 0,
  { obtain ⟨h1, h2⟩ := this,
    constructor,
    intros U hU,
    rw ← set.compl_eq_univ_diff at h1,
    rw continuous_on_open_iff at h1,
    { specialize h1 U hU,
      by_cases (0 : E) ∈ U,
      { rw continuous_at_def at h2,
        specialize h2 U,
        rw mem_nhds_iff at h2,
        specialize h2 ⟨U, subset_refl U, hU, _⟩,
        { simp [normalize_by], exact h },
        rw mem_nhds_iff at h2,
        obtain ⟨t, ht1, ht2, ht3⟩ := h2,
        convert is_open.union h1 ht2,
        rw [set.inter_union_distrib_right, set.union_eq_self_of_subset_right ht1],
        symmetry, convert set.univ_inter _,
        rw [← set.univ_subset_iff],
        refine subset_trans (subset_of_eq (set.compl_union_self {(0 : E)}).symm) _,
        apply set.union_subset_union_right, rw set.singleton_subset_iff, exact ht3 },
      { convert h1,
        ext, simp, intros h2 h3, rw h3 at h2,
        simp [normalize_by] at h2,
        exact h h2 } },
    { apply is_open_compl_singleton } },
  split,
  { refine continuous_on.smul _ continuous_on_id,
    refine continuous_on.mul hf1.continuous_on _,
    apply continuous_on.inv₀,
    { exact continuous.continuous_on (is_R_or_C.continuous_of_real.comp continuous_norm) },
    { simp } },
  { rw metric.continuous_at_iff,
    intros ε hε,
    rw metric.continuous_iff at hf1,
    obtain ⟨δ, hδ, H⟩ := hf1 0 ε hε,
    simp at H,
    refine ⟨δ, hδ, _⟩,
    simp [normalize_by],
    intros x hx,
    convert H x hx,
    rw hf2, simp,
    by_cases x = 0,
    { rw [h, hf2], simp, },
    { rw [mul_smul, norm_smul], simp [norm_smul_inv_norm h] } }
end

noncomputable
def normalize_by_gauge {E : Type*} [normed_add_comm_group E] [normed_space ℝ E] (s : set E)
  := normalize_by ℝ E (gauge s)

lemma norm_of_normalize_by_gauge {E : Type*} [normed_add_comm_group E] [normed_space ℝ E]
  (s : set E) (x : E) : ∥normalize_by_gauge s x∥ = gauge s x :=
begin
  dsimp [normalize_by_gauge, normalize_by],
  by_cases x = 0,
  { subst h, simp },
  { rw [norm_smul, norm_mul, mul_assoc, norm_inv, norm_norm, inv_mul_cancel],
    { rw [real.norm_eq_abs, abs_eq_self.mpr (gauge_nonneg _)], exact mul_one _ },
    { simp, exact h } }
end

lemma normalize_by_gauge_cont {E : Type*} [normed_add_comm_group E] [normed_space ℝ E]
  (s : set E) (hs₁ : convex ℝ s) (hs₂ : (0 : E) ∈ interior s)
  : continuous (normalize_by_gauge s) :=
begin
  apply normalize_by_continuous,
  { exact (gauge_cont s hs₁ hs₂).continuous },
  { exact gauge_zero }
end.

lemma interior_eq_gauge_lt_one {E : Type*} [normed_add_comm_group E] [normed_space ℝ E]
  (s : set E) (hs₁ : convex ℝ s) (hs₂ : (0 : E) ∈ interior s)
  : interior s = { p : E | gauge s p < 1 } :=
begin
  let U := { p : E | gauge s p < 1 },
  have : is_open U := is_open.preimage (gauge_cont s hs₁ hs₂).continuous is_open_Iio,
  refine subset_antisymm _ _,
  { rintros x hx,
    have h1 := convex.interior hs₁,
    refine lt_of_le_of_lt (gauge_mono _ interior_subset x) _,
    { apply convex_with_zero_in_int_is_absorbing,
      { assumption }, { rw interior_interior, assumption } },
    { apply gauge_lt_one_of_mem_of_open,
      { assumption },
      { assumption },
      { exact is_open_interior },
      { assumption } } },
  { apply interior_maximal,
    { refine gauge_lt_one_subset_self hs₁ (interior_subset hs₂)
                                      (convex_with_zero_in_int_is_absorbing s hs₁ hs₂) },
    { assumption } }
end

lemma frontier_eq_gauge_one {E : Type*} [normed_add_comm_group E] [normed_space ℝ E]
  (s : set E) (hs₁ : convex ℝ s) (hs₂ : (0 : E) ∈ interior s)
  : frontier s = { p : E | gauge s p = 1 } :=
begin
  unfold frontier,
  rw interior_eq_gauge_lt_one s hs₁ hs₂,
  ext, simp, split; intro h,
  { refine le_antisymm _ h.right,
    change x ∈ { p : E | gauge s p ≤ 1 },
    refine closure_minimal self_subset_gauge_le_one _ h.left,
    exact is_closed.preimage (gauge_cont s hs₁ hs₂).continuous is_closed_Iic },
  { rw h, simp,
    rw mem_closure_iff,
    intros U hU hxU,
    rw metric.is_open_iff at hU,
    obtain ⟨r, hr, H⟩ := hU x hxU,
    let r' := min r (∥x∥/2),
    have H1 : 0 < ∥x∥, { rw norm_pos_iff, intro hx, rw hx at h, simp at h, exact h },
    have H2 : 0 < 1 - ∥x∥⁻¹ * r',
    { rw [sub_pos, ← div_eq_inv_mul, div_lt_one_iff],
      left, exact ⟨H1, lt_of_le_of_lt (min_le_right _ _) (half_lt_self H1)⟩ },
    have : gauge s x < (1 - ∥x∥⁻¹ * r')⁻¹,
    { rw h, rw lt_inv, simp,
      { refine mul_pos (inv_pos.mpr H1) (lt_min hr (half_pos H1)) },
      { exact zero_lt_one },
      { exact H2 } },
    dsimp [gauge] at this,
    obtain ⟨r'', ⟨hr1'', hx⟩, hr2''⟩ := exists_lt_of_cInf_lt _ this,
    { refine ⟨r''⁻¹ • x, _, _⟩,
      { refine H _,
        simp, refine lt_of_lt_of_le _ (min_le_left r (∥x∥/2)), change dist (r''⁻¹ • x) x < r',
        rw [dist_eq_norm, norm_sub_rev],
        rw (_ : x - r''⁻¹ • x = (1 - r''⁻¹) • x), swap, rw [sub_smul, one_smul],
        rw [norm_smul, real.norm_eq_abs, abs_eq_self.mpr],
        swap,
        { rw [sub_nonneg], apply inv_le_one,
          rw ← h, apply cInf_le,
          { existsi (0 : ℝ), simp [lower_bounds], intros a ha _, exact le_of_lt ha },
          { exact ⟨hr1'', hx⟩ } },
        { rw [← inv_inv (∥x∥), mul_inv_lt_iff, sub_lt, lt_inv], exact hr2'',
          exact H2, exact hr1'', rw inv_pos, exact H1 } },
      { rw set.mem_smul_set_iff_inv_smul_mem₀ at hx, assumption,
        exact ne.symm (ne_of_lt hr1'') } },
    { apply absorbent.gauge_set_nonempty,
      apply convex_with_zero_in_int_is_absorbing; assumption } },
end.

lemma gauge_eq_zero_iff {E : Type*} [normed_add_comm_group E] [normed_space ℝ E]
  (s : set E) (hs₁ : absorbent ℝ s) (hs₂ : metric.bounded s) (x : E)
  : gauge s x = 0 ↔ x = 0 :=
begin
  split; intro h,
  { rw ← norm_eq_zero,
    refine le_antisymm (le_of_not_lt _) (norm_nonneg x),
    intro h', refine lt_irrefl (∥x∥) _,
    obtain ⟨B, hB⟩ := metric.bounded.subset_ball hs₂ 0,
    let B' := |B| + 1,
    have hB' : s ⊆ metric.closed_ball 0 B',
    { refine subset_trans hB (metric.closed_ball_subset_closed_ball _),
      refine le_trans (le_abs_self B) (le_add_of_nonneg_right zero_le_one) },
    have h'' : 0 < ∥x∥/B',
    { refine div_pos h' (add_pos_of_nonneg_of_pos (abs_nonneg B) zero_lt_one) },
    rw ← h at h'',
    obtain ⟨r, ⟨hr1, hr2⟩, hr3⟩ := exists_lt_of_cInf_lt (absorbent.gauge_set_nonempty _) h'',
    swap, { assumption },
    rw set.mem_smul_set_iff_inv_smul_mem₀ (ne.symm (ne_of_lt hr1)) at hr2,
    specialize hB' hr2, simp at hB',
    rw [norm_smul, mul_comm, norm_inv, real.norm_eq_abs,
        abs_eq_self.mpr (le_of_lt hr1), mul_inv_le_iff hr1] at hB',
    rw lt_div_iff (add_pos_of_nonneg_of_pos (abs_nonneg B) zero_lt_one) at hr3,
    exact lt_of_le_of_lt hB' hr3 },
  { rw h, simp }
end

noncomputable
def compact_convex_with_zero_in_interior_homeo_to_ball
  {E : Type*} [normed_add_comm_group E]
  [normed_space ℝ E] (s : set E) (hs₁ : convex ℝ s) (hs₂ : (0 : E) ∈ interior s)
  (hs₃ : is_compact s) : s ≃ₜ metric.closed_ball (0 : E) 1 :=
  have h1 : is_compact (metric.closed_ball (0 : E) 1),
  by { obtain ⟨t, ⟨ht1, ht2⟩, ht3⟩ := hs₂,
       rw metric.is_open_iff at ht1,
       obtain ⟨r, hr1, hr2⟩ := ht1 0 ht3,
       have H : is_compact (metric.closed_ball (0 : E) (r/2)),
       { apply compact_of_is_closed_subset hs₃ metric.is_closed_ball ,
         refine subset_trans (metric.closed_ball_subset_ball _) (subset_trans hr2 ht2),
         exact half_lt_self hr1 },
       convert is_compact.image H (continuous.const_smul continuous_id (2/r)),
       simp, have h : 0 < r / 2 := half_pos hr1,
       rw smul_closed_ball, simp, congr, rw [abs_eq_self.mpr, ← inv_div, inv_mul_cancel],
       exact ne.symm (ne_of_lt h), exact le_of_lt hr1, exact le_of_lt h },
  have h2 : absorbent ℝ s,
  { apply convex_with_zero_in_int_is_absorbing; assumption },
  have h3 : metric.bounded s, from hs₃.bounded,
  let X := @CompHaus.of s _ (is_compact_iff_compact_space.mp hs₃) _,
      Y := @CompHaus.of _ _ (is_compact_iff_compact_space.mp h1) _ in
begin
  refine Top.homeo_of_iso (CompHaus_to_Top.map_iso (@CompHaus.iso_of_bijective X Y ⟨_, _⟩ ⟨_, _⟩)),
  { refine set.cod_restrict (set.restrict s (normalize_by_gauge s)) _ _,
    intro, simp, rw norm_of_normalize_by_gauge, apply gauge_le_one_of_mem, exact x.property },
  { continuity, apply normalize_by_gauge_cont; assumption },
  { simp, rintros ⟨x, hx⟩ ⟨y, hy⟩ hxy, simp at hxy, simp,
    have h4 : gauge s x = gauge s y,
    { rw [← norm_of_normalize_by_gauge, ← norm_of_normalize_by_gauge, hxy] },
    by_cases x = 0,
    { rw h at ⊢ h4, simp at h4, symmetry' at ⊢ h4, rw ← gauge_eq_zero_iff s; assumption },
    { rw ← gauge_eq_zero_iff s h2 h3 at h,
      have h' : ¬ gauge s y = 0,
      { intro h', rw h' at h4, contradiction },
      have h'' : x ≠ 0, { intro h'', rw h'' at h, simp at h, exact h },
      have h''' : y ≠ 0, { intro h''', rw h''' at h', simp at h', exact h' },
      have H : ∥x∥⁻¹ • x = ∥y∥⁻¹ • y,
      { refine eq.trans (inv_smul_smul₀ h _).symm (eq.trans _ (inv_smul_smul₀ h' _)),
        refine congr_arg2 _ (congr_arg (λ t, t⁻¹) h4) _,
        rw [smul_smul, smul_smul], exact hxy },
      suffices : ∥x∥ = ∥y∥,
      { refine eq.trans (smul_inv_smul₀ _ _).symm
                        (eq.trans (congr_arg2 _ this H) (smul_inv_smul₀ _ _));
        rw [norm_ne_zero_iff]; assumption },
      have H' : x = (∥x∥ * ∥y∥⁻¹) • y,
      { rw ← smul_smul, rw inv_smul_eq_iff₀ at H, exact H, rw norm_ne_zero_iff, assumption },
      rw [H', gauge_smul_of_nonneg] at h4,
      rw ← mul_inv_eq_one₀, rw [smul_eq_mul, mul_left_eq_self₀] at h4, exact h4.resolve_right h',
      { rw norm_ne_zero_iff, assumption },
      { exact mul_nonneg (norm_nonneg _) (inv_nonneg.mpr (norm_nonneg _)) } } },
  { simp, rintros ⟨y, hy⟩,
    by_cases y = 0,
    { refine ⟨⟨0, interior_subset hs₂⟩, _⟩,
      simp [normalize_by, normalize_by_gauge, set.restrict, set.cod_restrict], exact h.symm },
    { have h' := h,
      rw ← gauge_eq_zero_iff s h2 h3 at h',
      refine ⟨⟨∥y∥ • (gauge s y)⁻¹ • y, _⟩, _⟩,
      { have := closure_eq_interior_union_frontier s,
        rw hs₃.is_closed.closure_eq at this,
        rw [interior_eq_gauge_lt_one s hs₁ hs₂, frontier_eq_gauge_one s hs₁ hs₂] at this,
        suffices H : gauge s (∥y∥ • (gauge s y)⁻¹ • y) ≤ 1,
        { exact eq.mpr (congr_arg2 _ (refl _) this) (lt_or_eq_of_le H) },
        rw smul_smul,
        rw gauge_smul_of_nonneg (mul_nonneg (norm_nonneg _) (inv_nonneg.mpr (gauge_nonneg _))),
        swap, apply_instance,
        rw [smul_eq_mul, mul_right_comm, mul_inv_cancel_right₀ h'],
        exact mem_closed_ball_zero_iff.mp hy },
      { simp [normalize_by, normalize_by_gauge, set.restrict, set.cod_restrict],
        rw gauge_smul_of_nonneg (norm_nonneg _); try { apply_instance },
        rw gauge_smul_of_nonneg (inv_nonneg.mpr (gauge_nonneg _)); try { apply_instance },
        rw [smul_smul, smul_smul],
        convert one_smul ℝ y,
        rw [norm_smul, norm_smul, norm_norm, real.norm_eq_abs,
            abs_eq_self.mpr (inv_nonneg.mpr (gauge_nonneg _)),
            mul_inv, mul_inv, inv_inv, smul_eq_mul, smul_eq_mul,
            inv_mul_cancel h', mul_one, mul_inv_cancel_left₀ (norm_ne_zero_iff.mpr h),
            inv_mul_cancel_right₀ (norm_ne_zero_iff.mpr h), mul_comm, inv_mul_cancel h'] } } }
end.

lemma compact_convex_with_nonempty_interior_homeo_to_ball
  {E : Type*} [normed_add_comm_group E]
  [normed_space ℝ E] (s : set E) (hs₁ : convex ℝ s) (hs₂ : (interior s).nonempty)
  (hs₃ : is_compact s)
  : ∃ (F : s ≃ₜ metric.closed_ball (0 : E) 1),
    F '' (coe ⁻¹' frontier s) = coe ⁻¹' metric.sphere (0 : E) 1 :=
begin
  obtain ⟨p, hp⟩ := hs₂,
  let s' := (λ x, (-p) + x) '' s,
  have hs₁' : convex ℝ s' := hs₁.translate (- p),
  have hs₂' : (0 : E) ∈ interior s',
  { change (0 : E) ∈ interior (homeomorph.add_left (-p) '' s),
    rw ← homeomorph.image_interior (homeomorph.add_left (- p)) s,
    refine ⟨p, hp, _⟩, simp },
  have hs₃' : is_compact s' := hs₃.image (continuous_const.add continuous_id'),
  let G := compact_convex_with_zero_in_interior_homeo_to_ball s' hs₁' hs₂' hs₃',
  refine ⟨homeomorph.trans (embedding_restricts_to_homeomorph s _ (homeomorph.add_left (-p)).embedding) G, _⟩,
  change (G ∘ embedding_restricts_to_homeomorph s _ (homeomorph.add_left (-p)).embedding)
         '' (coe ⁻¹' frontier s) = coe ⁻¹' metric.sphere (0 : E) 1,
  rw set.image_comp,
  transitivity G '' (coe ⁻¹' frontier s'),
  { congr,
    ext x, cases x with x hx,
    simp,
    simp [embedding_restricts_to_homeomorph, homeomorph.of_embedding],
    simp_rw [← sub_eq_neg_add, sub_eq_iff_eq_add, ← and_assoc],
    simp,
    rw (_ : s' = (homeomorph.add_left p ⁻¹' s)), swap, simp [s', homeomorph.add_left],
    rw ← homeomorph.preimage_frontier (homeomorph.add_left p) s,
    rw set.mem_preimage, simp [homeomorph.add_left],
    rw add_comm,
    simp, apply hs₃.is_closed.frontier_subset },
  { ext x, cases x with x hx,
    simp [G, compact_convex_with_zero_in_interior_homeo_to_ball, CompHaus.iso_of_bijective,
          set.restrict, set.cod_restrict],
    split,
    { rintros ⟨y, h1, h2, h3⟩,
      rw [← h3, norm_of_normalize_by_gauge],
      convert h2, symmetry,
      exact congr_arg2 (∈) (refl (-p + y)) (frontier_eq_gauge_one s' hs₁' hs₂') },
    { intro h,
      have H : normalize_by_gauge s' (G.symm ⟨x, hx⟩) = x,
      { transitivity (G (G.symm ⟨x, hx⟩)).val,
        { dsimp [G, compact_convex_with_zero_in_interior_homeo_to_ball,
                 CompHaus.iso_of_bijective], refl },
        { simp } },
      refine ⟨p + (G.inv_fun ⟨x, hx⟩).val, _, _, _⟩,
      { simp,
        obtain ⟨z, hz1, hz2⟩ := ((G.symm) ⟨x, hx⟩).property,
        rw subtype.val_eq_coe at hz2,
        rw ← hz2, simp, exact hz1 },
      { simp, rw frontier_eq_gauge_one s' hs₁' hs₂',
        simp,
        rw ← norm_of_normalize_by_gauge,
        convert h, },
      { simp, exact H } } }
end.

noncomputable
def affine_dim (k : Type*) [division_ring k]
  {E : Type*} [add_comm_group E] [module k E] (s : set E) :=
  module.rank k ((affine_span k s).direction)

-- noncomputable
-- def succ_affine_dim {E : Type*} [add_comm_group E] [module ℝ E] (s : set E)
--   := ⨆ (ι : {t : set E // t ⊆ s ∧ affine_independent ℝ (coe : t → E)}), cardinal.mk ι.val

/-
we will prove that if C is a compact convex set in E with succ_affine_dim C = n + 1 < ∞
then C is homeomorphic to the unit ball in ℝ^n
-/
lemma closed_ball_homeo_of_finite_dim (K : Type*) {V W : Type*} [is_R_or_C K]
  [normed_add_comm_group V] [normed_space K V] [finite_dimensional K V]
  [normed_add_comm_group W] [normed_space K W] [finite_dimensional K W]
  (H : finite_dimensional.finrank K V = finite_dimensional.finrank K W)
  : nonempty (metric.closed_ball (0 : V) 1 ≃ₜ metric.closed_ball (0 : W) 1) :=
begin
  obtain ⟨F⟩ := finite_dimensional.nonempty_continuous_linear_equiv_of_finrank_eq H,
  let G₁ : metric.closed_ball (0 : V) 1 → metric.closed_ball (0 : W) 1 := λ v, ⟨(∥v.val∥ * ∥F v.val∥⁻¹ : K) • F v.val, _⟩,
  swap,
  { rw [mem_closed_ball_zero_iff, norm_smul, norm_mul, norm_inv,
        is_R_or_C.norm_coe_norm, is_R_or_C.norm_coe_norm, mul_assoc],
    by_cases v.val = 0,
    { rw h, rw [norm_zero, zero_mul], exact zero_le_one },
    { rw [inv_mul_cancel, mul_one], exact mem_closed_ball_zero_iff.mp v.property,
      rw norm_ne_zero_iff, exact (linear_equiv.map_ne_zero_iff F.to_linear_equiv).mpr h } },
  let G₂ : metric.closed_ball (0 : W) 1 → metric.closed_ball (0 : V) 1 := λ v, ⟨(∥v.val∥ * ∥F.symm v.val∥⁻¹ : K) • F.symm v.val, _⟩,
  swap,
  { rw [mem_closed_ball_zero_iff, norm_smul, norm_mul, norm_inv,
        is_R_or_C.norm_coe_norm, is_R_or_C.norm_coe_norm, mul_assoc],
    by_cases v.val = 0,
    { rw h, rw [norm_zero, zero_mul], exact zero_le_one },
    { rw [inv_mul_cancel, mul_one], exact mem_closed_ball_zero_iff.mp v.property,
      rw norm_ne_zero_iff, exact (linear_equiv.map_ne_zero_iff F.symm.to_linear_equiv).mpr h } },
  refine ⟨⟨⟨G₁, G₂, _, _⟩, continuous_subtype_mk _ _, continuous_subtype_mk _ _⟩⟩,
  any_goals
  { rintro ⟨x, hx⟩, simp [G₁, G₂], by_cases x = 0, { rw h, simp },
    rw norm_smul_inv_norm' (norm_nonneg _),
    swap, exact (linear_equiv.map_ne_zero_iff (continuous_linear_equiv.to_linear_equiv _)).mpr h,
    rw [norm_smul, norm_mul, norm_inv, is_R_or_C.norm_coe_norm, is_R_or_C.norm_coe_norm,
        ← is_R_or_C.of_real_inv, mul_inv, mul_inv, inv_inv, ← mul_smul],
    convert one_smul _ _,
    simp, field_simp, rw mul_right_comm,
    apply div_self,
    refine mul_ne_zero (mul_self_ne_zero.mpr _) _; norm_cast; rw norm_eq_zero,
    exact h, exact (linear_equiv.map_ne_zero_iff (continuous_linear_equiv.to_linear_equiv _)).mpr h },
  { refine continuous.comp (_ : continuous (λ v : V,  ((∥v∥ : K) * ((∥F v∥)⁻¹ : K)) • F v))
                           continuous_subtype_val,
    convert continuous.comp (_ : continuous (λ w : W,  ((∥F.symm w∥ : K) * ((∥w∥)⁻¹ : K)) • w))
                            F.continuous_to_fun,
    { ext, simp },
    { apply normalize_by_continuous,
      { continuity },
      { simp } } },
  { refine continuous.comp (_ : continuous (λ w : W,  ((∥w∥ : K) * ((∥F.symm w∥)⁻¹ : K)) • F.symm w))
                           continuous_subtype_val,
    convert continuous.comp (_ : continuous (λ v : V,  ((∥F v∥ : K) * ((∥v∥)⁻¹ : K)) • v))
                            F.symm.continuous_to_fun,
    { ext, simp, congr, symmetry, exact F.to_linear_equiv.right_inv x },
    { apply normalize_by_continuous,
      { continuity },
      { simp } } }
end.

/-
Cool results that I did not end up needing
-/
lemma hahn_banach_finite_dim {K : Type*} [is_R_or_C K] {V E : Type*} [seminormed_add_comm_group E]
  [normed_space K E] [normed_add_comm_group V] [normed_space K V] [finite_dimensional K V]
  (p : subspace K E) (f : ↥p →L[K] V) : ∃ (g : E →L[K] V), ∀ (x : ↥p), g x = f x :=
begin
  let d := finite_dimensional.finrank K V,
  let b : basis (fin d) K V := finite_dimensional.fin_basis K V,
  let T := b.equiv_fun.to_continuous_linear_equiv,
  suffices : ∃ (g : E →L[K] (fin d → K)), ∀ (x : ↥p), g x = (T.to_continuous_linear_map.comp f) x,
  { obtain ⟨g, H⟩ := this,
    refine ⟨continuous_linear_map.comp T.symm.to_continuous_linear_map g, _⟩,
    intro x, convert congr_arg T.symm.to_continuous_linear_map (H x),
    symmetry, exact continuous_linear_equiv.symm_apply_apply T (f x) },
  let fi : fin d → ↥p →L[K] K := λ i, continuous_linear_map.comp ((pi.basis_fun K (fin d)).coord i).to_continuous_linear_map
                                                                 (T.to_continuous_linear_map.comp f),
  let gi : fin d → (E →L[K] K) := λ i, classical.some (exists_extension_norm_eq p (fi i)),
  have gi_spec : ∀ (i : fin d), (∀ (x : p), gi i x = fi i x) ∧ (∥gi i∥ = ∥fi i∥)
    := λ i, classical.some_spec (exists_extension_norm_eq p (fi i)),
  replace gi_spec := λ i, and.left (gi_spec i),
  refine ⟨continuous_linear_map.pi gi, _⟩,
  intro x, ext i,
  rw continuous_linear_map.coe_pi',
  dsimp,
  rw gi_spec,
  dsimp [fi],
  rw pi.basis_fun_repr
end.

lemma injective_continuous_linear_map_is_embedding (K : Type*) {V E : Type*} [is_R_or_C K]
  [normed_add_comm_group V] [normed_space K V] [finite_dimensional K V]
  [normed_add_comm_group E] [normed_space K E]
  (T : V →ₗ[K] E) (hT : function.injective T) : embedding T :=
begin
  suffices : ∃ S : E →L[K] V, function.left_inverse S T,
  { obtain ⟨S, hS⟩ := this,
    exact function.left_inverse.embedding hS (map_continuous S) (map_continuous T) },
  let p := T.range,
  let G : V ≃ₗ[K] p := linear_equiv.of_injective T hT,
  obtain ⟨g, hg⟩ := hahn_banach_finite_dim p G.symm.to_linear_map.to_continuous_linear_map,
  refine ⟨g, _⟩,
  intro, convert hg (G x), symmetry, exact linear_equiv.symm_apply_apply G x
end

lemma convex_spanning_set_has_nonempty_interior {V : Type*}
  [normed_add_comm_group V] [normed_space ℝ V] [finite_dimensional ℝ V]
  (s : set V) (hs₁ : convex ℝ s) (hs₂ : (0 : V) ∈ s) (hs₃ : submodule.span ℝ s = ⊤)
  : (interior s).nonempty :=
begin
  rw hs₁.interior_nonempty_iff_affine_span_eq_top,
  rw eq_top_iff at ⊢ hs₃, rw affine_subspace.le_def, rw ← set_like.coe_subset_coe at hs₃,
  refine subset_trans hs₃ _,
  simp [span_points], intros x hx,
  refine ⟨0, hs₂, x, _, (add_zero x).symm⟩,
  refine submodule.span_mono _ hx,
  intros y hy, refine ⟨y, 0, hy, hs₂, sub_zero y⟩
end

lemma convex_compact_homeo_to_ball {E : Type*} [normed_add_comm_group E] [normed_space ℝ E]
  (s : set E) (hs₁ : convex ℝ s) (hs₂ : is_compact s) (hs₃ : s.nonempty)
  (n : ℕ) (hs₄ : affine_dim ℝ s = n)
  : nonempty (s ≃ₜ metric.closed_ball (0 : euclidean_space ℝ (fin n)) 1) :=
begin
  obtain ⟨x0, hx0⟩ := hs₃,
  haveI : finite_dimensional ℝ (affine_span ℝ s).direction,
  { cases n,
    { exact finite_dimensional_of_dim_eq_zero hs₄ },
    { apply finite_dimensional.finite_dimensional_of_finrank_eq_succ, swap, exact n,
      refine eq.trans _ (cardinal.to_nat_cast (n + 1)), exact congr_arg cardinal.to_nat hs₄ } },
  suffices : nonempty (s ≃ₜ metric.closed_ball (0 : (affine_span ℝ s).direction) 1),
  { obtain ⟨F⟩ := this, refine ⟨F.trans _⟩,
    refine nonempty.some (closed_ball_homeo_of_finite_dim ℝ _),
    rw finrank_euclidean_space_fin,
    dsimp [finite_dimensional.finrank], dsimp [affine_dim] at hs₄,
    rw hs₄, exact cardinal.to_nat_cast n },
  let F : (affine_span ℝ s).direction → E := λ q, x0 +ᵥ q,
  have hF1 : s ⊆ set.range F,
  { refine subset_trans (subset_span_points ℝ s) (subset_of_eq _),
    ext, split,
    { rintros ⟨a, ha, v, hv, H⟩, rw H,
      rw ← direction_affine_span at hv,
      refine ⟨⟨v + (a -ᵥ x0), submodule.add_mem _ hv _⟩, _⟩,
      { rw direction_affine_span,
        apply vsub_mem_vector_span_of_mem_span_points_of_mem_span_points;
        apply mem_span_points; assumption },
      { simp [F], rw [subtype.coe_mk, add_left_comm, ← add_sub_assoc, add_sub_cancel'] } },
    { rintro ⟨a, ha⟩, rw ← ha, simp [F],
      rw [add_comm], apply vadd_mem_span_points_of_mem_span_points_of_mem_vector_span,
      { apply mem_span_points, assumption },
      { rw ← direction_affine_span, exact a.property } } },
  have hF2 : embedding F := (homeomorph.vadd x0).embedding.comp embedding_subtype_coe,
  have hF3 : s = F '' (F ⁻¹' s),
  { symmetry, rw set.image_preimage_eq_iff, exact hF1 },
  let F' : F ⁻¹' s ≃ₜ s, { convert embedding_restricts_to_homeomorph (F⁻¹' s) F hF2 },
  suffices : nonempty (F ⁻¹' s ≃ₜ metric.closed_ball (0 : (affine_span ℝ s).direction) 1),
  { obtain ⟨G⟩ := this, refine ⟨F'.symm.trans G⟩ },
  have hF' : convex ℝ (F ⁻¹' s),
  { intros a b ha hb u v hu hv huv, simp [F],
    have h : (x0 : E) = u • (x0 : E) + v • (x0 : E),
    { rw [← add_smul, huv, one_smul] },
    rw [h, ← add_assoc, add_right_comm (u • x0), add_assoc, ← smul_add, ← smul_add],
    exact hs₁ ha hb hu hv huv },
  refine nonempty_of_exists (compact_convex_with_nonempty_interior_homeo_to_ball _ hF' _ _),
  { apply convex_spanning_set_has_nonempty_interior _ hF',
    { simp [F], assumption },
    { rw eq_top_iff, rintros ⟨x, hx⟩ _,
      suffices : ∀ (y : E) (hy : y ∈ vector_span ℝ s),
               (⟨y, (direction_affine_span ℝ s).substr hy⟩ : (affine_span ℝ s).direction)
               ∈ submodule.span ℝ (F ⁻¹' s),
      { exact this x ((direction_affine_span ℝ s).subst hx) },
      intros y hy, refine submodule.span_induction' _ _ _ _ hy,
      { rintros z ⟨a, b, ha, hb, h⟩,
        have h1 : a -ᵥ x0 ∈ (affine_span ℝ s).direction,
        { rw direction_affine_span, apply vsub_mem_vector_span; assumption },
        have h2 : b -ᵥ x0 ∈ (affine_span ℝ s).direction,
        { rw direction_affine_span, apply vsub_mem_vector_span; assumption },
        suffices : (⟨_, h1⟩ : (affine_span ℝ s).direction) - (⟨_, h2⟩ : (affine_span ℝ s).direction)
                 ∈ submodule.span ℝ (F ⁻¹' s),
        { convert this, rw ← h, simp },
        refine submodule.sub_mem _ _ _;
        refine submodule.subset_span _;
        simp [F]; assumption },
      { exact submodule.zero_mem _ },
      { intros _ _ _ _ h1 h2, exact submodule.add_mem _ h1 h2 },
      { intros a _ _ h, exact submodule.smul_mem _ a h } } },
  { rw is_compact_iff_compact_space at ⊢ hs₂, haveI := hs₂, exact F'.symm.compact_space }
end.


/-
Copyright (c) 2021 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Yury Kudryashov, Sébastien Gouëzel
-/
import measure_theory.constructions.borel_space
import topology.algebra.order.left_right_lim

/-!
# Stieltjes measures on the real line

Consider a function `f : ℝ → ℝ` which is monotone and right-continuous. Then one can define a
corrresponding measure, giving mass `f b - f a` to the interval `(a, b]`.

## Main definitions

* `stieltjes_function` is a structure containing a function from `ℝ → ℝ`, together with the
assertions that it is monotone and right-continuous. To `f : stieltjes_function`, one associates
a Borel measure `f.measure`.
* `f.measure_Ioc` asserts that `f.measure (Ioc a b) = of_real (f b - f a)`
* `f.measure_Ioo` asserts that `f.measure (Ioo a b) = of_real (left_lim f b - f a)`.
* `f.measure_Icc` and `f.measure_Ico` are analogous.
-/

noncomputable theory
open classical set filter function
open ennreal (of_real)
open_locale big_operators ennreal nnreal topology measure_theory

/-! ### Basic properties of Stieltjes functions -/

/-- Bundled monotone right-continuous real functions, used to construct Stieltjes measures. -/
structure stieltjes_function :=
(to_fun : ℝ → ℝ)
(mono' : monotone to_fun)
(right_continuous' : ∀ x, continuous_within_at to_fun (Ici x) x)

namespace stieltjes_function

instance : has_coe_to_fun stieltjes_function (λ _, ℝ → ℝ) := ⟨to_fun⟩

initialize_simps_projections stieltjes_function (to_fun → apply)

variable (f : stieltjes_function)

lemma mono : monotone f := f.mono'

lemma right_continuous (x : ℝ) : continuous_within_at f (Ici x) x := f.right_continuous' x

/-- The identity of `ℝ` as a Stieltjes function, used to construct Lebesgue measure. -/
@[simps] protected def id : stieltjes_function :=
{ to_fun := id,
  mono' := λ x y, id,
  right_continuous' := λ x, continuous_within_at_id }

@[simp] lemma id_left_lim (x : ℝ) : left_lim stieltjes_function.id x = x :=
tendsto_nhds_unique (stieltjes_function.id.mono.tendsto_left_lim x) $
  (continuous_at_id).tendsto.mono_left nhds_within_le_nhds

instance : inhabited stieltjes_function := ⟨stieltjes_function.id⟩

/-- If a function `f : ℝ → ℝ` is monotone, then the function mapping `x` to the right limit of `f`
at `x` is a Stieltjes function, i.e., it is monotone and right-continuous. -/
noncomputable def _root_.monotone.stieltjes_function {f : ℝ → ℝ} (hf : monotone f) :
  stieltjes_function :=
{ to_fun := right_lim f,
  mono' := λ x y hxy, hf.right_lim hxy,
  right_continuous' :=
  begin
    assume x s hs,
    obtain ⟨l, u, hlu, lus⟩ : ∃ (l u : ℝ), right_lim f x ∈ Ioo l u ∧ Ioo l u ⊆ s :=
      mem_nhds_iff_exists_Ioo_subset.1 hs,
    obtain ⟨y, xy, h'y⟩ : ∃ (y : ℝ) (H : x < y), Ioc x y ⊆ f ⁻¹' (Ioo l u) :=
      mem_nhds_within_Ioi_iff_exists_Ioc_subset.1
        (hf.tendsto_right_lim x (Ioo_mem_nhds hlu.1 hlu.2)),
    change ∀ᶠ y in 𝓝[≥] x, right_lim f y ∈ s,
    filter_upwards [Ico_mem_nhds_within_Ici ⟨le_refl x, xy⟩] with z hz,
    apply lus,
    refine ⟨hlu.1.trans_le (hf.right_lim hz.1), _⟩,
    obtain ⟨a, za, ay⟩ : ∃ (a : ℝ), z < a ∧ a < y := exists_between hz.2,
    calc right_lim f z ≤ f a : hf.right_lim_le za
                   ... < u   : (h'y ⟨hz.1.trans_lt za, ay.le⟩).2,
  end }

lemma _root_.monotone.stieltjes_function_eq {f : ℝ → ℝ} (hf : monotone f) (x : ℝ) :
  hf.stieltjes_function x = right_lim f x := rfl

lemma countable_left_lim_ne (f : stieltjes_function) :
  set.countable {x | left_lim f x ≠ f x} :=
begin
  apply countable.mono _ (f.mono.countable_not_continuous_at),
  assume x hx h'x,
  apply hx,
  exact tendsto_nhds_unique (f.mono.tendsto_left_lim x) (h'x.tendsto.mono_left nhds_within_le_nhds),
end

/-! ### The outer measure associated to a Stieltjes function -/

/-- Length of an interval. This is the largest monotone function which correctly measures all
intervals. -/
def length (s : set ℝ) : ℝ≥0∞ := ⨅a b (h : s ⊆ Ioc a b), of_real (f b - f a)

@[simp] lemma length_empty : f.length ∅ = 0 :=
nonpos_iff_eq_zero.1 $ infi_le_of_le 0 $ infi_le_of_le 0 $ by simp

@[simp] lemma length_Ioc (a b : ℝ) :
  f.length (Ioc a b) = of_real (f b - f a) :=
begin
  refine le_antisymm (infi_le_of_le a $ infi₂_le b subset.rfl)
    (le_infi $ λ a', le_infi $ λ b', le_infi $ λ h, ennreal.coe_le_coe.2 _),
  cases le_or_lt b a with ab ab,
  { rw real.to_nnreal_of_nonpos (sub_nonpos.2 (f.mono ab)), apply zero_le, },
  cases (Ioc_subset_Ioc_iff ab).1 h with h₁ h₂,
  exact real.to_nnreal_le_to_nnreal (sub_le_sub (f.mono h₁) (f.mono h₂))
end

lemma length_mono {s₁ s₂ : set ℝ} (h : s₁ ⊆ s₂) : f.length s₁ ≤ f.length s₂ :=
infi_mono $ λ a, binfi_mono $ λ b, h.trans

open measure_theory

/-- The Stieltjes outer measure associated to a Stieltjes function. -/
protected def outer : outer_measure ℝ :=
outer_measure.of_function f.length f.length_empty

lemma outer_le_length (s : set ℝ) : f.outer s ≤ f.length s :=
outer_measure.of_function_le _

/-- If a compact interval `[a, b]` is covered by a union of open interval `(c i, d i)`, then
`f b - f a ≤ ∑ f (d i) - f (c i)`. This is an auxiliary technical statement to prove the same
statement for half-open intervals, the point of the current statement being that one can use
compactness to reduce it to a finite sum, and argue by induction on the size of the covering set. -/
lemma length_subadditive_Icc_Ioo {a b : ℝ} {c d : ℕ → ℝ}
  (ss : Icc a b ⊆ ⋃ i, Ioo (c i) (d i)) :
  of_real (f b - f a) ≤ ∑' i, of_real (f (d i) - f (c i)) :=
begin
  suffices : ∀ (s:finset ℕ) b
    (cv : Icc a b ⊆ ⋃ i ∈ (↑s:set ℕ), Ioo (c i) (d i)),
    (of_real (f b - f a) : ℝ≥0∞) ≤ ∑ i in s, of_real (f (d i) - f (c i)),
  { rcases is_compact_Icc.elim_finite_subcover_image (λ (i : ℕ) (_ : i ∈ univ),
      @is_open_Ioo _ _ _ _ (c i) (d i)) (by simpa using ss) with ⟨s, su, hf, hs⟩,
    have e : (⋃ i ∈ (↑hf.to_finset:set ℕ), Ioo (c i) (d i)) = (⋃ i ∈ s, Ioo (c i) (d i)),
      by simp only [ext_iff, exists_prop, finset.set_bUnion_coe, mem_Union, forall_const, iff_self,
                    finite.mem_to_finset],
    rw ennreal.tsum_eq_supr_sum,
    refine le_trans _ (le_supr _ hf.to_finset),
    exact this hf.to_finset _ (by simpa only [e]) },
  clear ss b,
  refine λ s, finset.strong_induction_on s (λ s IH b cv, _),
  cases le_total b a with ab ab,
  { rw ennreal.of_real_eq_zero.2 (sub_nonpos.2 (f.mono ab)), exact zero_le _, },
  have := cv ⟨ab, le_rfl⟩, simp at this,
  rcases this with ⟨i, is, cb, bd⟩,
  rw [← finset.insert_erase is] at cv ⊢,
  rw [finset.coe_insert, bUnion_insert] at cv,
  rw [finset.sum_insert (finset.not_mem_erase _ _)],
  refine le_trans _ (add_le_add_left (IH _ (finset.erase_ssubset is) (c i) _) _),
  { refine le_trans (ennreal.of_real_le_of_real _) ennreal.of_real_add_le,
    rw sub_add_sub_cancel,
    exact sub_le_sub_right (f.mono bd.le) _ },
  { rintro x ⟨h₁, h₂⟩,
    refine (cv ⟨h₁, le_trans h₂ (le_of_lt cb)⟩).resolve_left
      (mt and.left (not_lt_of_le h₂)) }
end

@[simp] lemma outer_Ioc (a b : ℝ) :
  f.outer (Ioc a b) = of_real (f b - f a) :=
begin
  /- It suffices to show that, if `(a, b]` is covered by sets `s i`, then `f b - f a` is bounded
  by `∑ f.length (s i) + ε`. The difficulty is that `f.length` is expressed in terms of half-open
  intervals, while we would like to have a compact interval covered by open intervals to use
  compactness and finite sums, as provided by `length_subadditive_Icc_Ioo`. The trick is to use the
  right-continuity of `f`. If `a'` is close enough to `a` on its right, then `[a', b]` is still
  covered by the sets `s i` and moreover `f b - f a'` is very close to `f b - f a` (up to `ε/2`).
  Also, by definition one can cover `s i` by a half-closed interval `(p i, q i]` with `f`-length
  very close to  that of `s i` (within a suitably small `ε' i`, say). If one moves `q i` very
  slightly to the right, then the `f`-length will change very little by right continuity, and we
  will get an open interval `(p i, q' i)` covering `s i` with `f (q' i) - f (p i)` within `ε' i`
  of the `f`-length of `s i`. -/
  refine le_antisymm (by { rw ← f.length_Ioc, apply outer_le_length })
    (le_infi₂ $ λ s hs, ennreal.le_of_forall_pos_le_add $ λ ε εpos h, _),
  let δ := ε / 2,
  have δpos : 0 < (δ : ℝ≥0∞), by simpa using εpos.ne',
  rcases ennreal.exists_pos_sum_of_countable δpos.ne' ℕ with ⟨ε', ε'0, hε⟩,
  obtain ⟨a', ha', aa'⟩ : ∃ a', f a' - f a < δ ∧ a < a',
  { have A : continuous_within_at (λ r, f r - f a) (Ioi a) a,
    { refine continuous_within_at.sub _ continuous_within_at_const,
      exact (f.right_continuous a).mono Ioi_subset_Ici_self },
    have B : f a - f a < δ, by rwa [sub_self, nnreal.coe_pos, ← ennreal.coe_pos],
    exact (((tendsto_order.1 A).2 _ B).and self_mem_nhds_within).exists },
  have : ∀ i, ∃ p:ℝ×ℝ, s i ⊆ Ioo p.1 p.2 ∧
                        (of_real (f p.2 - f p.1) : ℝ≥0∞) < f.length (s i) + ε' i,
  { intro i,
    have := (ennreal.lt_add_right ((ennreal.le_tsum i).trans_lt h).ne
        (ennreal.coe_ne_zero.2 (ε'0 i).ne')),
    conv at this { to_lhs, rw length },
    simp only [infi_lt_iff, exists_prop] at this,
    rcases this with ⟨p, q', spq, hq'⟩,
    have : continuous_within_at (λ r, of_real (f r - f p)) (Ioi q') q',
    { apply ennreal.continuous_of_real.continuous_at.comp_continuous_within_at,
      refine continuous_within_at.sub _ continuous_within_at_const,
      exact (f.right_continuous q').mono Ioi_subset_Ici_self },
    rcases (((tendsto_order.1 this).2 _ hq').and self_mem_nhds_within).exists with ⟨q, hq, q'q⟩,
    exact ⟨⟨p, q⟩, spq.trans (Ioc_subset_Ioo_right q'q), hq⟩ },
  choose g hg using this,
  have I_subset : Icc a' b ⊆ ⋃ i, Ioo (g i).1 (g i).2 := calc
    Icc a' b ⊆ Ioc a b : λ x hx, ⟨aa'.trans_le hx.1, hx.2⟩
    ... ⊆ ⋃ i, s i : hs
    ... ⊆ ⋃ i, Ioo (g i).1 (g i).2 : Union_mono (λ i, (hg i).1),
  calc of_real (f b - f a)
      = of_real ((f b - f a') + (f a' - f a)) : by rw sub_add_sub_cancel
  ... ≤ of_real (f b - f a') + of_real (f a' - f a) : ennreal.of_real_add_le
  ... ≤ (∑' i, of_real (f (g i).2 - f (g i).1)) + of_real δ :
    add_le_add (f.length_subadditive_Icc_Ioo I_subset) (ennreal.of_real_le_of_real ha'.le)
  ... ≤ (∑' i, (f.length (s i) + ε' i)) + δ :
    add_le_add (ennreal.tsum_le_tsum (λ i, (hg i).2.le))
      (by simp only [ennreal.of_real_coe_nnreal, le_rfl])
  ... = (∑' i, f.length (s i)) + (∑' i, ε' i) + δ : by rw [ennreal.tsum_add]
  ... ≤ (∑' i, f.length (s i)) + δ + δ : add_le_add (add_le_add le_rfl hε.le) le_rfl
  ... = ∑' (i : ℕ), f.length (s i) + ε : by simp [add_assoc, ennreal.add_halves]
end

lemma measurable_set_Ioi {c : ℝ} :
  measurable_set[f.outer.caratheodory] (Ioi c) :=
begin
  apply outer_measure.of_function_caratheodory (λ t, _),
  refine le_infi (λ a, le_infi (λ b, le_infi (λ h, _))),
  refine le_trans (add_le_add
    (f.length_mono $ inter_subset_inter_left _ h)
    (f.length_mono $ diff_subset_diff_left h)) _,
  cases le_total a c with hac hac; cases le_total b c with hbc hbc,
  { simp only [Ioc_inter_Ioi, f.length_Ioc, hac, sup_eq_max, hbc, le_refl, Ioc_eq_empty,
      max_eq_right, min_eq_left, Ioc_diff_Ioi, f.length_empty, zero_add, not_lt] },
  { simp only [hac, hbc, Ioc_inter_Ioi, Ioc_diff_Ioi, f.length_Ioc, min_eq_right,
      sup_eq_max, ←ennreal.of_real_add, f.mono hac, f.mono hbc, sub_nonneg, sub_add_sub_cancel,
      le_refl, max_eq_right] },
  { simp only [hbc, le_refl, Ioc_eq_empty, Ioc_inter_Ioi, min_eq_left, Ioc_diff_Ioi,
      f.length_empty, zero_add, or_true, le_sup_iff, f.length_Ioc, not_lt] },
  { simp only [hac, hbc, Ioc_inter_Ioi, Ioc_diff_Ioi, f.length_Ioc, min_eq_right,
      sup_eq_max, le_refl, Ioc_eq_empty, add_zero, max_eq_left, f.length_empty, not_lt] }
end

theorem outer_trim : f.outer.trim = f.outer :=
begin
  refine le_antisymm (λ s, _) (outer_measure.le_trim _),
  rw outer_measure.trim_eq_infi,
  refine le_infi (λ t, le_infi $ λ ht,
    ennreal.le_of_forall_pos_le_add $ λ ε ε0 h, _),
  rcases ennreal.exists_pos_sum_of_countable
    (ennreal.coe_pos.2 ε0).ne' ℕ with ⟨ε', ε'0, hε⟩,
  refine le_trans _ (add_le_add_left (le_of_lt hε) _),
  rw ← ennreal.tsum_add,
  choose g hg using show
    ∀ i, ∃ s, t i ⊆ s ∧ measurable_set s ∧
      f.outer s ≤ f.length (t i) + of_real (ε' i),
  { intro i,
    have := (ennreal.lt_add_right ((ennreal.le_tsum i).trans_lt h).ne
        (ennreal.coe_pos.2 (ε'0 i)).ne'),
    conv at this {to_lhs, rw length},
    simp only [infi_lt_iff] at this,
    rcases this with ⟨a, b, h₁, h₂⟩,
    rw ← f.outer_Ioc at h₂,
    exact ⟨_, h₁, measurable_set_Ioc, le_of_lt $ by simpa using h₂⟩ },
  simp at hg,
  apply infi_le_of_le (Union g) _,
  apply infi_le_of_le (ht.trans $ Union_mono (λ i, (hg i).1)) _,
  apply infi_le_of_le (measurable_set.Union (λ i, (hg i).2.1)) _,
  exact le_trans (f.outer.Union _) (ennreal.tsum_le_tsum $ λ i, (hg i).2.2)
end

lemma borel_le_measurable : borel ℝ ≤ f.outer.caratheodory :=
begin
  rw borel_eq_generate_from_Ioi,
  refine measurable_space.generate_from_le _,
  simp [f.measurable_set_Ioi] { contextual := tt }
end

/-! ### The measure associated to a Stieltjes function -/

/-- The measure associated to a Stieltjes function, giving mass `f b - f a` to the
interval `(a, b]`. -/
@[irreducible] protected def measure : measure ℝ :=
{ to_outer_measure := f.outer,
  m_Union := λ s hs, f.outer.Union_eq_of_caratheodory $
    λ i, f.borel_le_measurable _ (hs i),
  trimmed := f.outer_trim }

@[simp] lemma measure_Ioc (a b : ℝ) : f.measure (Ioc a b) = of_real (f b - f a) :=
by { rw stieltjes_function.measure, exact f.outer_Ioc a b }

@[simp] lemma measure_singleton (a : ℝ) : f.measure {a} = of_real (f a - left_lim f a) :=
begin
  obtain ⟨u, u_mono, u_lt_a, u_lim⟩ : ∃ (u : ℕ → ℝ), strict_mono u ∧ (∀ (n : ℕ), u n < a)
    ∧ tendsto u at_top (𝓝 a) := exists_seq_strict_mono_tendsto a,
  have A : {a} = ⋂ n, Ioc (u n) a,
  { refine subset.antisymm (λ x hx, by simp [mem_singleton_iff.1 hx, u_lt_a]) (λ x hx, _),
    simp at hx,
    have : a ≤ x := le_of_tendsto' u_lim (λ n, (hx n).1.le),
    simp [le_antisymm this (hx 0).2] },
  have L1 : tendsto (λ n, f.measure (Ioc (u n) a)) at_top (𝓝 (f.measure {a})),
  { rw A,
    refine tendsto_measure_Inter (λ n, measurable_set_Ioc) (λ m n hmn, _) _,
    { exact Ioc_subset_Ioc (u_mono.monotone hmn) le_rfl },
    { exact ⟨0, by simpa only [measure_Ioc] using ennreal.of_real_ne_top⟩ } },
  have L2 : tendsto (λ n, f.measure (Ioc (u n) a)) at_top (𝓝 (of_real (f a - left_lim f a))),
  { simp only [measure_Ioc],
    have : tendsto (λ n, f (u n)) at_top (𝓝 (left_lim f a)),
    { apply (f.mono.tendsto_left_lim a).comp,
      exact tendsto_nhds_within_of_tendsto_nhds_of_eventually_within _ u_lim
        (eventually_of_forall (λ n, u_lt_a n)) },
    exact ennreal.continuous_of_real.continuous_at.tendsto.comp (tendsto_const_nhds.sub this) },
  exact tendsto_nhds_unique L1 L2
end

@[simp] lemma measure_Icc (a b : ℝ) : f.measure (Icc a b) = of_real (f b - left_lim f a) :=
begin
  rcases le_or_lt a b with hab|hab,
  { have A : disjoint {a} (Ioc a b), by simp,
    simp [← Icc_union_Ioc_eq_Icc le_rfl hab, -singleton_union, ← ennreal.of_real_add,
      f.mono.left_lim_le, measure_union A measurable_set_Ioc, f.mono hab] },
  { simp only [hab, measure_empty, Icc_eq_empty, not_le],
    symmetry,
    simp [ennreal.of_real_eq_zero, f.mono.le_left_lim hab] }
end

@[simp] lemma measure_Ioo {a b : ℝ} : f.measure (Ioo a b) = of_real (left_lim f b - f a) :=
begin
  rcases le_or_lt b a with hab|hab,
  { simp only [hab, measure_empty, Ioo_eq_empty, not_lt],
    symmetry,
    simp [ennreal.of_real_eq_zero, f.mono.left_lim_le hab] },
  { have A : disjoint (Ioo a b) {b}, by simp,
    have D : f b - f a = (f b - left_lim f b) + (left_lim f b - f a), by abel,
    have := f.measure_Ioc a b,
    simp only [←Ioo_union_Icc_eq_Ioc hab le_rfl, measure_singleton,
      measure_union A (measurable_set_singleton b), Icc_self] at this,
    rw [D, ennreal.of_real_add, add_comm] at this,
    { simpa only [ennreal.add_right_inj ennreal.of_real_ne_top] },
    { simp only [f.mono.left_lim_le, sub_nonneg] },
    { simp only [f.mono.le_left_lim hab, sub_nonneg] } },
end

@[simp]

instance : is_locally_finite_measure f.measure :=
⟨λ x, ⟨Ioo (x-1) (x+1), Ioo_mem_nhds (by linarith) (by linarith), by simp⟩⟩

end stieltjes_function


/-
Copyright (c) 2018 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Reid Barton

Construction of the Stone-Čech compactification using ultrafilters.

Parts of the formalization are based on "Ultrafilters and Topology"
by Marius Stekelenburg, particularly section 5.
-/

import topology.constructions

noncomputable theory

open filter lattice set

universes u v

section ultrafilter
/- The set of ultrafilters on α carries a natural topology which makes
  it the Stone-Čech compactification of α (viewed as a discrete space). -/

/-- Basis for the topology on `ultrafilter α`. -/
def ultrafilter_basis (α : Type u) : set (set (ultrafilter α)) :=
{t | ∃ (s : set α), t = {u | s ∈ u.val}}

variables {α : Type u}

instance : topological_space (ultrafilter α) :=
topological_space.generate_from (ultrafilter_basis α)

lemma ultrafilter_basis_is_basis :
  topological_space.is_topological_basis (ultrafilter_basis α) :=
⟨begin
   rintros _ ⟨a, rfl⟩ _ ⟨b, rfl⟩ u ⟨ua, ub⟩,
   refine ⟨_, ⟨a ∩ b, rfl⟩, u.val.inter_sets ua ub, assume v hv, ⟨_, _⟩⟩;
   apply v.val.sets_of_superset hv; simp
 end,
 eq_univ_of_univ_subset $ subset_sUnion_of_mem $
   ⟨univ, eq.symm (eq_univ_of_forall (λ u, u.val.univ_sets))⟩,
 rfl⟩

/-- The basic open sets for the topology on ultrafilters are open. -/
lemma ultrafilter_is_open_basic (s : set α) :
  is_open {u : ultrafilter α | s ∈ u.val} :=
topological_space.is_open_of_is_topological_basis ultrafilter_basis_is_basis ⟨s, rfl⟩

/-- The basic open sets for the topology on ultrafilters are also closed. -/
lemma ultrafilter_is_closed_basic (s : set α) :
  is_closed {u : ultrafilter α | s ∈ u.val} :=
begin
  change is_open (- _),
  convert ultrafilter_is_open_basic (-s),
  ext u,
  exact (ultrafilter_iff_compl_mem_iff_not_mem.mp u.property s).symm
end

/-- Every ultrafilter `u` on `ultrafilter α` converges to a unique
  point of `ultrafilter α`, namely `mjoin u`. -/
lemma ultrafilter_converges_iff {u : ultrafilter (ultrafilter α)} {x : ultrafilter α} :
  u.val ≤ nhds x ↔ x = mjoin u :=
begin
  rw [eq_comm, ultrafilter.eq_iff_val_le_val],
  change u.val ≤ nhds x ↔ x.val.sets ⊆ {a | {v : ultrafilter α | a ∈ v.val} ∈ u.val},
  simp only [topological_space.nhds_generate_from, lattice.le_infi_iff, ultrafilter_basis,
    le_principal_iff],
  split; intro h,
  { intros a ha, exact h _ ⟨ha, a, rfl⟩ },
  { rintros _ ⟨xi, a, rfl⟩, exact h xi }
end

instance ultrafilter_compact : compact_space (ultrafilter α) :=
⟨compact_iff_ultrafilter_le_nhds.mpr $ assume f uf _,
   ⟨mjoin ⟨f, uf⟩, trivial, ultrafilter_converges_iff.mpr rfl⟩⟩

instance ultrafilter.t2_space : t2_space (ultrafilter α) :=
t2_iff_ultrafilter.mpr $ assume f x y u fx fy,
  have hx : x = mjoin ⟨f, u⟩, from ultrafilter_converges_iff.mp fx,
  have hy : y = mjoin ⟨f, u⟩, from ultrafilter_converges_iff.mp fy,
  hx.trans hy.symm

lemma ultrafilter_comap_pure_nhds (b : ultrafilter α) : comap pure (nhds b) ≤ b.val :=
begin
  rw topological_space.nhds_generate_from,
  simp only [comap_infi, comap_principal],
  intros s hs,
  rw ←le_principal_iff,
  refine lattice.infi_le_of_le {u | s ∈ u.val} _,
  refine lattice.infi_le_of_le ⟨hs, ⟨s, rfl⟩⟩ _,
  rw principal_mono,
  intros a ha,
  exact mem_pure_iff.mp ha
end

section embedding

lemma ultrafilter_pure_injective : function.injective (pure : α → ultrafilter α) :=
begin
  intros x y h,
  have : {x} ∈ (pure x : ultrafilter α).val := singleton_mem_pure_sets,
  rw h at this,
  exact (mem_singleton_iff.mp (mem_pure_sets.mp this)).symm
end

open topological_space

/-- `pure : α → ultrafilter α` defines a dense embedding of `α` in `ultrafilter α`. -/
lemma dense_embedding_pure : @dense_embedding _ _ ⊤ _ (pure : α → ultrafilter α) :=
by letI : topological_space α := ⊤; exact
dense_embedding.mk' pure continuous_top
  (assume x, mem_closure_iff_ultrafilter.mpr
     ⟨x.map ultrafilter.pure, range_mem_map,
      ultrafilter_converges_iff.mpr (bind_pure x).symm⟩)
  ultrafilter_pure_injective
  (assume a s as,
     ⟨{u | s ∈ u.val},
      mem_nhds_sets (ultrafilter_is_open_basic s) (mem_pure_sets.mpr (mem_of_nhds as)),
      assume b hb, mem_pure_sets.mp hb⟩)

end embedding

section extension
/- Goal: Any function `α → γ` to a compact Hausdorff space `γ` has a
  unique extension to a continuous function `ultrafilter α → γ`. We
  already know it must be unique because `α → ultrafilter α` is a
  dense embedding and `γ` is Hausdorff. For existence, we will invoke
  `dense_embedding.continuous_extend`. -/

variables {γ : Type*} [topological_space γ]

/-- The extension of a function `α → γ` to a function `ultrafilter α → γ`.
  When `γ` is a compact Hausdorff space it will be continuous. -/
def ultrafilter.extend (f : α → γ) : ultrafilter α → γ :=
by letI : topological_space α := ⊤; exact dense_embedding_pure.extend f

lemma ultrafilter_extend_extends (f : α → γ) : ultrafilter.extend f ∘ pure = f :=
by letI : topological_space α := ⊤; exact funext dense_embedding_pure.extend_e_eq

variables [t2_space γ] [compact_space γ]

lemma continuous_ultrafilter_extend (f : α → γ) : continuous (ultrafilter.extend f) :=
have ∀ (b : ultrafilter α), ∃ c, tendsto f (comap ultrafilter.pure (nhds b)) (nhds c) := assume b,
  -- b.map f is an ultrafilter on γ, which is compact, so it converges to some c in γ.
  let ⟨c, _, h⟩ := compact_iff_ultrafilter_le_nhds.mp compact_univ (b.map f).val (b.map f).property
    (by rw [le_principal_iff]; exact univ_mem_sets) in
  ⟨c, le_trans (map_mono (ultrafilter_comap_pure_nhds _)) h⟩,
begin
  letI : topological_space α := ⊤,
  letI : normal_space γ := normal_of_compact_t2,
  exact dense_embedding_pure.continuous_extend this
end

/-- The value of `ultrafilter.extend f` on an ultrafilter `b` is the
  unique limit of the ultrafilter `b.map f` in `γ`. -/
lemma ultrafilter_extend_eq_iff {f : α → γ} {b : ultrafilter α} {c : γ} :
  ultrafilter.extend f b = c ↔ b.val.map f ≤ nhds c :=
⟨assume h, begin
   -- Write b as an ultrafilter limit of pure ultrafilters, and use
   -- the facts that ultrafilter.extend is a continuous extension of f.
   let b' : ultrafilter (ultrafilter α) := b.map pure,
   have t : b'.val ≤ nhds b,
     from ultrafilter_converges_iff.mpr (by exact (bind_pure _).symm),
   rw ←h,
   have := (continuous_ultrafilter_extend f).tendsto b,
   refine le_trans _ (le_trans (map_mono t) this),
   change _ ≤ map (ultrafilter.extend f ∘ pure) b.val,
   rw ultrafilter_extend_extends,
   exact le_refl _
 end,
 assume h, by letI : topological_space α := ⊤; exact
   dense_embedding_pure.extend_eq (le_trans (map_mono (ultrafilter_comap_pure_nhds _)) h)⟩

end extension

end ultrafilter

section stone_cech
/- Now, we start with a (not necessarily discrete) topological space α
  and we want to construct its Stone-Čech compactification. We can
  build it as a quotient of `ultrafilter α` by the relation which
  identifies two points if the extension of every continuous function
  α → γ to a compact Hausdorff space sends the two points to the same
  point of γ. -/

variables (α : Type u) [topological_space α]

instance stone_cech_setoid : setoid (ultrafilter α) :=
{ r := λ x y, ∀ (γ : Type u) [topological_space γ], by exactI
    ∀ [t2_space γ] [compact_space γ] (f : α → γ) (hf : continuous f),
    ultrafilter.extend f x = ultrafilter.extend f y,
  iseqv :=
    ⟨assume x γ tγ h₁ h₂ f hf, rfl,
     assume x y xy γ tγ h₁ h₂ f hf, by exactI (xy γ f hf).symm,
     assume x y z xy yz γ tγ h₁ h₂ f hf, by exactI (xy γ f hf).trans (yz γ f hf)⟩ }

/-- The Stone-Čech compactification of a topological space. -/
def stone_cech : Type u := quotient (stone_cech_setoid α)

variables {α}
instance : topological_space (stone_cech α) := by unfold stone_cech; apply_instance

/-- The natural map from α to its Stone-Čech compactification. -/
def stone_cech_unit (x : α) : stone_cech α := ⟦pure x⟧

/-- The image of stone_cech_unit is dense. (But stone_cech_unit need
  not be an embedding, for example if α is not Hausdorff.) -/
lemma stone_cech_unit_dense : closure (range (@stone_cech_unit α _)) = univ :=
begin
  convert quotient_dense_of_dense (eq_univ_iff_forall.mp dense_embedding_pure.closure_range),
  rw [←range_comp], refl
end

section extension

variables {γ : Type u} [topological_space γ] [t2_space γ] [compact_space γ]
variables {f : α → γ} (hf : continuous f)

local attribute [elab_with_expected_type] quotient.lift

/-- The extension of a continuous function from α to a compact
  Hausdorff space γ to the Stone-Čech compactification of α. -/
def stone_cech_extend : stone_cech α → γ :=
quotient.lift (ultrafilter.extend f) (λ x y xy, xy γ f hf)

lemma stone_cech_extend_extends : stone_cech_extend hf ∘ stone_cech_unit = f :=
ultrafilter_extend_extends f

lemma continuous_stone_cech_extend : continuous (stone_cech_extend hf) :=
continuous_quot_lift _ (continuous_ultrafilter_extend f)

end extension

lemma convergent_eqv_pure {u : ultrafilter α} {x : α} (ux : u.val ≤ nhds x) : u ≈ pure x :=
assume γ tγ h₁ h₂ f hf, begin
  resetI,
  transitivity f x, swap, symmetry,
  all_goals { refine ultrafilter_extend_eq_iff.mpr (le_trans (map_mono _) (hf.tendsto _)) },
  { apply pure_le_nhds }, { exact ux }
end

lemma continuous_stone_cech_unit : continuous (stone_cech_unit : α → stone_cech α) :=
continuous_iff_ultrafilter.mpr $ λ x g u gx,
  let g' : ultrafilter α := ⟨g, u⟩ in
  have (g'.map ultrafilter.pure).val ≤ nhds g',
    by rw ultrafilter_converges_iff; exact (bind_pure _).symm,
  have (g'.map stone_cech_unit).val ≤ nhds ⟦g'⟧, from
    (continuous_at_iff_ultrafilter g').mp
      (continuous_quotient_mk.tendsto g') _ (ultrafilter_map u) this,
  by rwa (show ⟦g'⟧ = ⟦pure x⟧, from quotient.sound $ convergent_eqv_pure gx) at this

instance stone_cech.t2_space : t2_space (stone_cech α) :=
begin
  rw t2_iff_ultrafilter,
  rintros g ⟨x⟩ ⟨y⟩ u gx gy,
  apply quotient.sound,
  intros γ tγ h₁ h₂ f hf,
  resetI,
  change stone_cech_extend hf ⟦x⟧ = stone_cech_extend hf ⟦y⟧,
  refine tendsto_nhds_unique u.1 _ _,
  { exact stone_cech_extend hf },
  all_goals
  { refine le_trans (map_mono _) ((continuous_stone_cech_extend hf).tendsto _),
    assumption }
end

instance stone_cech.compact_space : compact_space (stone_cech α) :=
quotient.compact_space

end stone_cech


/-
Copyright (c) 2022 Damiano Testa. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Damiano Testa
-/
import algebra.monoid_algebra.basic

/-!
#  Lemmas about the support of a finitely supported function

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

universes u₁ u₂ u₃
namespace monoid_algebra

open finset finsupp
variables {k : Type u₁} {G : Type u₂} [semiring k]

lemma support_single_mul_subset [decidable_eq G] [has_mul G]
  (f : monoid_algebra k G) (r : k) (a : G) :
  (single a r * f : monoid_algebra k G).support ⊆ finset.image ((*) a) f.support :=
begin
  intros x hx,
  contrapose hx,
  have : ∀ y, a * y = x → f y = 0,
  { simpa only [not_and', mem_image, mem_support_iff, exists_prop, not_exists, not_not] using hx },
  simp only [mem_support_iff, mul_apply, sum_single_index, zero_mul, if_t_t, sum_zero, not_not],
  exact finset.sum_eq_zero (by simp only [this, mem_support_iff, mul_zero, ne.def,
    ite_eq_right_iff, eq_self_iff_true, implies_true_iff] {contextual := tt}),
end

lemma support_mul_single_subset [decidable_eq G] [has_mul G]
  (f : monoid_algebra k G) (r : k) (a : G) :
  (f * single a r).support ⊆ finset.image (* a) f.support :=
begin
  intros x hx,
  contrapose hx,
  have : ∀ y, y * a = x → f y = 0,
  { simpa only [not_and', mem_image, mem_support_iff, exists_prop, not_exists, not_not] using hx },
  simp only [mem_support_iff, mul_apply, sum_single_index, zero_mul, if_t_t, sum_zero, not_not],
  exact finset.sum_eq_zero (by simp only [this, sum_single_index, ite_eq_right_iff,
    eq_self_iff_true, implies_true_iff, zero_mul] {contextual := tt}),
end

lemma support_single_mul_eq_image [decidable_eq G] [has_mul G]
  (f : monoid_algebra k G) {r : k} (hr : ∀ y, r * y = 0 ↔ y = 0) {x : G} (lx : is_left_regular x) :
  (single x r * f : monoid_algebra k G).support = finset.image ((*) x) f.support :=
begin
  refine subset_antisymm (support_single_mul_subset f _ _) (λ y hy, _),
  obtain ⟨y, yf, rfl⟩ : ∃ (a : G), a ∈ f.support ∧ x * a = y,
  { simpa only [finset.mem_image, exists_prop] using hy },
  simp only [mul_apply, mem_support_iff.mp yf, hr, mem_support_iff, sum_single_index,
    finsupp.sum_ite_eq', ne.def, not_false_iff, if_true, zero_mul, if_t_t, sum_zero, lx.eq_iff]
end

lemma support_mul_single_eq_image [decidable_eq G] [has_mul G]
  (f : monoid_algebra k G) {r : k} (hr : ∀ y, y * r = 0 ↔ y = 0) {x : G} (rx : is_right_regular x) :
  (f * single x r).support = finset.image (* x) f.support :=
begin
  refine subset_antisymm (support_mul_single_subset f _ _) (λ y hy, _),
  obtain ⟨y, yf, rfl⟩ : ∃ (a : G), a ∈ f.support ∧ a * x = y,
  { simpa only [finset.mem_image, exists_prop] using hy },
  simp only [mul_apply, mem_support_iff.mp yf, hr, mem_support_iff, sum_single_index,
    finsupp.sum_ite_eq', ne.def, not_false_iff, if_true, mul_zero, if_t_t, sum_zero, rx.eq_iff]
end

lemma support_mul [has_mul G] [decidable_eq G] (a b : monoid_algebra k G) :
  (a * b).support ⊆ a.support.bUnion (λa₁, b.support.bUnion $ λa₂, {a₁ * a₂}) :=
subset.trans support_sum $ bUnion_mono $ assume a₁ _,
  subset.trans support_sum $ bUnion_mono $ assume a₂ _, support_single_subset

lemma support_mul_single [right_cancel_semigroup G]
  (f : monoid_algebra k G) (r : k) (hr : ∀ y, y * r = 0 ↔ y = 0) (x : G) :
  (f * single x r).support = f.support.map (mul_right_embedding x) :=
begin
  classical,
  ext,
  simp only [support_mul_single_eq_image f hr (is_right_regular_of_right_cancel_semigroup x),
    mem_image, mem_map, mul_right_embedding_apply],
end

section span

variables [mul_one_class G]

/-- An element of `monoid_algebra k G` is in the subalgebra generated by its support. -/
lemma mem_span_support (f : monoid_algebra k G) :
  f ∈ submodule.span k (of k G '' (f.support : set G)) :=
by rw [of, monoid_hom.coe_mk, ← finsupp.supported_eq_span_single, finsupp.mem_supported]

end span

end monoid_algebra

namespace add_monoid_algebra

open finset finsupp mul_opposite
variables {k : Type u₁} {G : Type u₂} [semiring k]

lemma support_mul [decidable_eq G] [has_add G] (a b : add_monoid_algebra k G) :
  (a * b).support ⊆ a.support.bUnion (λa₁, b.support.bUnion $ λa₂, {a₁ + a₂}) :=
@monoid_algebra.support_mul k (multiplicative G) _ _ _ _ _

lemma support_mul_single [add_right_cancel_semigroup G]
  (f : add_monoid_algebra k G) (r : k) (hr : ∀ y, y * r = 0 ↔ y = 0) (x : G) :
  (f * single x r : add_monoid_algebra k G).support = f.support.map (add_right_embedding x) :=
@monoid_algebra.support_mul_single k (multiplicative G) _ _ _ _ hr _

lemma support_single_mul [add_left_cancel_semigroup G]
  (f : add_monoid_algebra k G) (r : k) (hr : ∀ y, r * y = 0 ↔ y = 0) (x : G) :
  (single x r * f : add_monoid_algebra k G).support = f.support.map (add_left_embedding x) :=
@monoid_algebra.support_single_mul k (multiplicative G) _ _ _ _ hr _

section span

/-- An element of `add_monoid_algebra k G` is in the submodule generated by its support. -/
lemma mem_span_support [add_zero_class G] (f : add_monoid_algebra k G) :
  f ∈ submodule.span k (of k G '' (f.support : set G)) :=
by rw [of, monoid_hom.coe_mk, ← finsupp.supported_eq_span_single, finsupp.mem_supported]

/-- An element of `add_monoid_algebra k G` is in the subalgebra generated by its support, using
unbundled inclusion. -/
lemma mem_span_support' (f : add_monoid_algebra k G) :
  f ∈ submodule.span k (of' k G '' (f.support : set G)) :=
by rw [of', ← finsupp.supported_eq_span_single, finsupp.mem_supported]

end span

end add_monoid_algebra


/-
Copyright (c) 2019 Amelia Livingston. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Amelia Livingston, Bryan Gin-ge Chen
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.setoid.basic
import Mathlib.data.set.lattice
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# Equivalence relations: partitions

This file comprises properties of equivalence relations viewed as partitions.

## Tags

setoid, equivalence, iseqv, relation, equivalence relation, partition, equivalence class
-/

namespace setoid

/-- If x ∈ α is in 2 elements of a set of sets partitioning α, those 2 sets are equal. -/
theorem eq_of_mem_eqv_class {α : Type u_1} {c : set (set α)}
    (H : ∀ (a : α), exists_unique fun (b : set α) => exists_unique fun (H : b ∈ c) => a ∈ b) {x : α}
    {b : set α} {b' : set α} (hc : b ∈ c) (hb : x ∈ b) (hc' : b' ∈ c) (hb' : x ∈ b') : b = b' :=
  exists_unique.unique2 (H x) hc hb hc' hb'

/-- Makes an equivalence relation from a set of sets partitioning α. -/
def mk_classes {α : Type u_1} (c : set (set α))
    (H : ∀ (a : α), exists_unique fun (b : set α) => exists_unique fun (H : b ∈ c) => a ∈ b) :
    setoid α :=
  mk (fun (x y : α) => ∀ (s : set α), s ∈ c → x ∈ s → y ∈ s) sorry

/-- Makes the equivalence classes of an equivalence relation. -/
def classes {α : Type u_1} (r : setoid α) : set (set α) :=
  set_of fun (s : set α) => ∃ (y : α), s = set_of fun (x : α) => rel r x y

theorem mem_classes {α : Type u_1} (r : setoid α) (y : α) :
    (set_of fun (x : α) => rel r x y) ∈ classes r :=
  Exists.intro y rfl

/-- Two equivalence relations are equal iff all their equivalence classes are equal. -/
theorem eq_iff_classes_eq {α : Type u_1} {r₁ : setoid α} {r₂ : setoid α} :
    r₁ = r₂ ↔ ∀ (x : α), (set_of fun (y : α) => rel r₁ x y) = set_of fun (y : α) => rel r₂ x y :=
  sorry

theorem rel_iff_exists_classes {α : Type u_1} (r : setoid α) {x : α} {y : α} :
    rel r x y ↔ ∃ (c : set α), ∃ (H : c ∈ classes r), x ∈ c ∧ y ∈ c :=
  sorry

/-- Two equivalence relations are equal iff their equivalence classes are equal. -/
theorem classes_inj {α : Type u_1} {r₁ : setoid α} {r₂ : setoid α} :
    r₁ = r₂ ↔ classes r₁ = classes r₂ :=
  sorry

/-- The empty set is not an equivalence class. -/
theorem empty_not_mem_classes {α : Type u_1} {r : setoid α} : ¬∅ ∈ classes r := sorry

/-- Equivalence classes partition the type. -/
theorem classes_eqv_classes {α : Type u_1} {r : setoid α} (a : α) :
    exists_unique fun (b : set α) => exists_unique fun (H : b ∈ classes r) => a ∈ b :=
  sorry

/-- If x ∈ α is in 2 equivalence classes, the equivalence classes are equal. -/
theorem eq_of_mem_classes {α : Type u_1} {r : setoid α} {x : α} {b : set α} (hc : b ∈ classes r)
    (hb : x ∈ b) {b' : set α} (hc' : b' ∈ classes r) (hb' : x ∈ b') : b = b' :=
  eq_of_mem_eqv_class classes_eqv_classes hc hb hc' hb'

/-- The elements of a set of sets partitioning α are the equivalence classes of the
    equivalence relation defined by the set of sets. -/
theorem eq_eqv_class_of_mem {α : Type u_1} {c : set (set α)}
    (H : ∀ (a : α), exists_unique fun (b : set α) => exists_unique fun (H : b ∈ c) => a ∈ b)
    {s : set α} {y : α} (hs : s ∈ c) (hy : y ∈ s) :
    s = set_of fun (x : α) => rel (mk_classes c H) x y :=
  sorry

/-- The equivalence classes of the equivalence relation defined by a set of sets
    partitioning α are elements of the set of sets. -/
theorem eqv_class_mem {α : Type u_1} {c : set (set α)}
    (H : ∀ (a : α), exists_unique fun (b : set α) => exists_unique fun (H : b ∈ c) => a ∈ b)
    {y : α} : (set_of fun (x : α) => rel (mk_classes c H) x y) ∈ c :=
  exists_unique.elim2 (H y)
    fun (b : set α) (hc : b ∈ c) (hy : y ∈ b) (hb : ∀ (y_1 : set α), y_1 ∈ c → y ∈ y_1 → y_1 = b) =>
      eq_eqv_class_of_mem H hc hy ▸ hc

/-- Distinct elements of a set of sets partitioning α are disjoint. -/
theorem eqv_classes_disjoint {α : Type u_1} {c : set (set α)}
    (H : ∀ (a : α), exists_unique fun (b : set α) => exists_unique fun (H : b ∈ c) => a ∈ b) :
    set.pairwise_disjoint c :=
  sorry

/-- A set of disjoint sets covering α partition α (classical). -/
theorem eqv_classes_of_disjoint_union {α : Type u_1} {c : set (set α)} (hu : ⋃₀c = set.univ)
    (H : set.pairwise_disjoint c) (a : α) :
    exists_unique fun (b : set α) => exists_unique fun (H : b ∈ c) => a ∈ b :=
  sorry

/-- Makes an equivalence relation from a set of disjoints sets covering α. -/
def setoid_of_disjoint_union {α : Type u_1} {c : set (set α)} (hu : ⋃₀c = set.univ)
    (H : set.pairwise_disjoint c) : setoid α :=
  mk_classes c (eqv_classes_of_disjoint_union hu H)

/-- The equivalence relation made from the equivalence classes of an equivalence
    relation r equals r. -/
theorem mk_classes_classes {α : Type u_1} (r : setoid α) :
    mk_classes (classes r) classes_eqv_classes = r :=
  sorry

@[simp] theorem sUnion_classes {α : Type u_1} (r : setoid α) : ⋃₀classes r = set.univ :=
  set.eq_univ_of_forall
    fun (x : α) =>
      iff.mpr set.mem_sUnion
        (Exists.intro (set_of fun (y : α) => rel r y x)
          (Exists.intro (Exists.intro x rfl) (refl x)))

/-- A collection `c : set (set α)` of sets is a partition of `α` into pairwise
disjoint sets if `∅ ∉ c` and each element `a : α` belongs to a unique set `b ∈ c`. -/
def is_partition {α : Type u_1} (c : set (set α)) :=
  ¬∅ ∈ c ∧ ∀ (a : α), exists_unique fun (b : set α) => exists_unique fun (H : b ∈ c) => a ∈ b

/-- A partition of `α` does not contain the empty set. -/
theorem nonempty_of_mem_partition {α : Type u_1} {c : set (set α)} (hc : is_partition c) {s : set α}
    (h : s ∈ c) : set.nonempty s :=
  iff.mp set.ne_empty_iff_nonempty fun (hs0 : s = ∅) => and.left hc (hs0 ▸ h)

theorem is_partition_classes {α : Type u_1} (r : setoid α) : is_partition (classes r) :=
  { left := empty_not_mem_classes, right := classes_eqv_classes }

theorem is_partition.pairwise_disjoint {α : Type u_1} {c : set (set α)} (hc : is_partition c) :
    set.pairwise_disjoint c :=
  eqv_classes_disjoint (and.right hc)

theorem is_partition.sUnion_eq_univ {α : Type u_1} {c : set (set α)} (hc : is_partition c) :
    ⋃₀c = set.univ :=
  sorry

/-- All elements of a partition of α are the equivalence class of some y ∈ α. -/
theorem exists_of_mem_partition {α : Type u_1} {c : set (set α)} (hc : is_partition c) {s : set α}
    (hs : s ∈ c) : ∃ (y : α), s = set_of fun (x : α) => rel (mk_classes c (and.right hc)) x y :=
  sorry

/-- The equivalence classes of the equivalence relation defined by a partition of α equal
    the original partition. -/
theorem classes_mk_classes {α : Type u_1} (c : set (set α)) (hc : is_partition c) :
    classes (mk_classes c (and.right hc)) = c :=
  sorry

/-- Defining `≤` on partitions as the `≤` defined on their induced equivalence relations. -/
protected instance partition.le {α : Type u_1} : HasLessEq (Subtype is_partition) :=
  { LessEq :=
      fun (x y : Subtype is_partition) =>
        mk_classes (subtype.val x) sorry ≤ mk_classes (subtype.val y) sorry }

/-- Defining a partial order on partitions as the partial order on their induced
    equivalence relations. -/
protected instance partition.partial_order {α : Type u_1} : partial_order (Subtype is_partition) :=
  partial_order.mk LessEq (fun (x y : Subtype is_partition) => x ≤ y ∧ ¬y ≤ x) sorry sorry sorry

/-- The order-preserving bijection between equivalence relations and partitions of sets. -/
def partition.rel_iso (α : Type u_1) : setoid α ≃o Subtype is_partition :=
  rel_iso.mk
    (equiv.mk (fun (r : setoid α) => { val := classes r, property := sorry })
      (fun (x : Subtype is_partition) => mk_classes (subtype.val x) sorry) mk_classes_classes sorry)
    sorry

/-- A complete lattice instance for partitions; there is more infrastructure for the
    equivalent complete lattice on equivalence relations. -/
protected instance partition.complete_lattice {α : Type u_1} :
    complete_lattice (Subtype is_partition) :=
  galois_insertion.lift_complete_lattice (rel_iso.to_galois_insertion (partition.rel_iso α))

end Mathlib


import graphs.id

def 𝕀 (G : graph) : G ↦ G :=
  morphism.mk (id) (id) (by exact id_compatability G)

def isomorphism {G H : graph} (α : G ↦ H) : Prop :=
  ∃ β : H ↦ G, α ⊚ β = 𝕀 H ∧ β ⊚ α = 𝕀 G

lemma id_is_iso (G : graph) : isomorphism (𝕀 G) :=
begin
  use 𝕀 G,
  split,
  refl,
  refl,
end


import interior_world.level2 --hide

/-

# Level 3: The interior is open

-/
variables {X : Type} -- hide
variables [topological_space X] (x : X)  (A : set X) -- hide

namespace topological_space -- hide

/- Lemma
The interior of a set is open.
-/
@[simp] lemma interior_is_open : is_open (interior A) :=
begin
  rw interior_def',
  apply union,
  rintros B ⟨is_open_B, _⟩,
  exact is_open_B,

end

end topological_space -- hide


import data.complex.exponential

open complex

theorem t017 : Π (n : ℕ) (z : ℂ), (cos z + sin z * I) ^ n = cos (↑n * z) + sin (↑n * z) * I
:= cos_add_sin_mul_I_pow


import tactic

inductive colour : Type
| red : colour
| blue : colour
| green : colour

def horrify : ℕ × ℕ × ℕ → colour → ℕ × ℕ × ℕ
| (r, b + 1, g + 1) red   := (r + 2, b, g)
| (r + 1, b, g + 1) blue  := (r, b + 2, g)
| (r + 1, b + 1, g) green := (r, b, g + 2)
| (r, b, g) _             := (r, b, g)

/-- Critic Ivor Smallbrain is watching the horror movie Salamanders on a
Desert Island. In the film, there are 30 salamanders living on a desert
island: 15 are red, 7 blue and 8 green. When two of a different colour
meet, horrifyingly they both change into the third colour. (For example,
if a red and a green meet, they both become blue.) When two of the same
colour meet, they change into both of the other colours. (For example, if
two reds meet, one becomes green and one becomes blue.) It is all quite
terrifying.

In between being horrified and terrified, Ivor idly wonders whether it
could ever happen that at some instant in the future, all of the salaman-
ders would be red. It turns out that this would never happen. -/
lemma salamander : ¬ ∃ (l : list colour), list.foldl horrify (15, 7, 8) l = (30, 0, 0) :=
begin
  sorry
end


/-
Copyright (c) 2020 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson
-/
import linear_algebra.isomorphisms
import order.jordan_holder

/-!
# Simple Modules

## Main Definitions
  * `is_simple_module` indicates that a module has no proper submodules
  (the only submodules are `⊥` and `⊤`).
  * `is_semisimple_module` indicates that every submodule has a complement, or equivalently,
    the module is a direct sum of simple modules.
  * A `division_ring` structure on the endomorphism ring of a simple module.

## Main Results
  * Schur's Lemma: `bijective_or_eq_zero` shows that a linear map between simple modules
  is either bijective or 0, leading to a `division_ring` structure on the endomorphism ring.

## TODO
  * Artin-Wedderburn Theory
  * Unify with the work on Schur's Lemma in a category theory context

-/

variables (R : Type*) [ring R] (M : Type*) [add_comm_group M] [module R M]

/-- A module is simple when it has only two submodules, `⊥` and `⊤`. -/
abbreviation is_simple_module := (is_simple_order (submodule R M))

/-- A module is semisimple when every submodule has a complement, or equivalently, the module
  is a direct sum of simple modules. -/
abbreviation is_semisimple_module := (complemented_lattice (submodule R M))

-- Making this an instance causes the linter to complain of "dangerous instances"
theorem is_simple_module.nontrivial [is_simple_module R M] : nontrivial M :=
⟨⟨0, begin
  have h : (⊥ : submodule R M) ≠ ⊤ := bot_ne_top,
  contrapose! h,
  ext,
  simp [submodule.mem_bot,submodule.mem_top, h x],
end⟩⟩

variables {R} {M} {m : submodule R M} {N : Type*} [add_comm_group N] [module R N]

lemma is_simple_module.congr (l : M ≃ₗ[R] N) [is_simple_module R N] : is_simple_module R M :=
(submodule.order_iso_map_comap l).is_simple_order

theorem is_simple_module_iff_is_atom :
  is_simple_module R m ↔ is_atom m :=
begin
  rw ← set.is_simple_order_Iic_iff_is_atom,
  apply order_iso.is_simple_order_iff,
  exact submodule.map_subtype.rel_iso m,
end

theorem is_simple_module_iff_is_coatom :
  is_simple_module R (M ⧸ m) ↔ is_coatom m :=
begin
  rw ← set.is_simple_order_Ici_iff_is_coatom,
  apply order_iso.is_simple_order_iff,
  exact submodule.comap_mkq.rel_iso m,
end

theorem covby_iff_quot_is_simple {A B : submodule R M} (hAB : A ≤ B) :
  A ⋖ B ↔ is_simple_module R (B ⧸ submodule.comap B.subtype A) :=
begin
  set f : submodule R B ≃o set.Iic B := submodule.map_subtype.rel_iso B with hf,
  rw [covby_iff_coatom_Iic hAB, is_simple_module_iff_is_coatom, ←order_iso.is_coatom_iff f, hf],
  simp [-order_iso.is_coatom_iff, submodule.map_subtype.rel_iso, submodule.map_comap_subtype,
    inf_eq_right.2 hAB],
end

namespace is_simple_module

variable [hm : is_simple_module R m]

@[simp]
lemma is_atom : is_atom m := is_simple_module_iff_is_atom.1 hm

end is_simple_module

theorem is_semisimple_of_Sup_simples_eq_top
  (h : Sup {m : submodule R M | is_simple_module R m} = ⊤) :
  is_semisimple_module R M :=
complemented_lattice_of_Sup_atoms_eq_top (by simp_rw [← h, is_simple_module_iff_is_atom])

namespace is_semisimple_module

variable [is_semisimple_module R M]

theorem Sup_simples_eq_top : Sup {m : submodule R M | is_simple_module R m} = ⊤ :=
begin
  simp_rw is_simple_module_iff_is_atom,
  exact Sup_atoms_eq_top,
end

instance is_semisimple_submodule {m : submodule R M} : is_semisimple_module R m :=
begin
  have f : submodule R m ≃o set.Iic m := submodule.map_subtype.rel_iso m,
  exact f.complemented_lattice_iff.2 is_modular_lattice.complemented_lattice_Iic,
end

end is_semisimple_module

theorem is_semisimple_iff_top_eq_Sup_simples :
  Sup {m : submodule R M | is_simple_module R m} = ⊤ ↔ is_semisimple_module R M :=
⟨is_semisimple_of_Sup_simples_eq_top, by { introI, exact is_semisimple_module.Sup_simples_eq_top }⟩

namespace linear_map

theorem injective_or_eq_zero [is_simple_module R M] (f : M →ₗ[R] N) :
  function.injective f ∨ f = 0 :=
begin
  rw [← ker_eq_bot, ← ker_eq_top],
  apply eq_bot_or_eq_top,
end

theorem injective_of_ne_zero [is_simple_module R M] {f : M →ₗ[R] N} (h : f ≠ 0) :
  function.injective f :=
f.injective_or_eq_zero.resolve_right h

theorem surjective_or_eq_zero [is_simple_module R N] (f : M →ₗ[R] N) :
  function.surjective f ∨ f = 0 :=
begin
  rw [← range_eq_top, ← range_eq_bot, or_comm],
  apply eq_bot_or_eq_top,
end

theorem surjective_of_ne_zero [is_simple_module R N] {f : M →ₗ[R] N} (h : f ≠ 0) :
  function.surjective f :=
f.surjective_or_eq_zero.resolve_right h

/-- **Schur's Lemma** for linear maps between (possibly distinct) simple modules -/
theorem bijective_or_eq_zero [is_simple_module R M] [is_simple_module R N]
  (f : M →ₗ[R] N) :
  function.bijective f ∨ f = 0 :=
begin
  by_cases h : f = 0,
  { right,
    exact h },
  exact or.intro_left _ ⟨injective_of_ne_zero h, surjective_of_ne_zero h⟩,
end

theorem bijective_of_ne_zero [is_simple_module R M] [is_simple_module R N]
  {f : M →ₗ[R] N} (h : f ≠ 0):
  function.bijective f :=
f.bijective_or_eq_zero.resolve_right h

theorem is_coatom_ker_of_surjective [is_simple_module R N] {f : M →ₗ[R] N}
  (hf : function.surjective f) : is_coatom f.ker :=
begin
  rw ←is_simple_module_iff_is_coatom,
  exact is_simple_module.congr (f.quot_ker_equiv_of_surjective hf)
end

/-- Schur's Lemma makes the endomorphism ring of a simple module a division ring. -/
noncomputable instance _root_.module.End.division_ring
  [decidable_eq (module.End R M)] [is_simple_module R M] :
  division_ring (module.End R M) :=
{ inv := λ f, if h : f = 0 then 0 else (linear_map.inverse f
    (equiv.of_bijective _ (bijective_of_ne_zero h)).inv_fun
    (equiv.of_bijective _ (bijective_of_ne_zero h)).left_inv
    (equiv.of_bijective _ (bijective_of_ne_zero h)).right_inv),
  exists_pair_ne := ⟨0, 1, begin
    haveI := is_simple_module.nontrivial R M,
    have h := exists_pair_ne M,
    contrapose! h,
    intros x y,
    simp_rw [ext_iff, one_apply, zero_apply] at h,
    rw [← h x, h y],
  end⟩,
  mul_inv_cancel := begin
    intros a a0,
    change (a * (dite _ _ _)) = 1,
    ext,
    rw [dif_neg a0, mul_eq_comp, one_apply, comp_apply],
    exact (equiv.of_bijective _ (bijective_of_ne_zero a0)).right_inv x,
  end,
  inv_zero := dif_pos rfl,
.. (module.End.ring : ring (module.End R M))}

end linear_map

instance jordan_holder_module : jordan_holder_lattice (submodule R M) :=
{ is_maximal                            := (⋖),
  lt_of_is_maximal                      := λ x y, covby.lt,
  sup_eq_of_is_maximal                  := λ x y z hxz hyz, wcovby.sup_eq hxz.wcovby hyz.wcovby,
  is_maximal_inf_left_of_is_maximal_sup := λ A B, inf_covby_of_covby_sup_of_covby_sup_left,
  iso                                   := λ X Y,
    nonempty $ (X.2 ⧸ X.1.comap X.2.subtype) ≃ₗ[R] Y.2 ⧸ Y.1.comap Y.2.subtype,
  iso_symm                              := λ A B ⟨f⟩, ⟨f.symm⟩,
  iso_trans                             := λ A B C ⟨f⟩ ⟨g⟩, ⟨f.trans g⟩,
  second_iso                            := λ A B h,
    ⟨by { rw [sup_comm, inf_comm], exact (linear_map.quotient_inf_equiv_sup_quotient B A).symm }⟩}