/-
Copyright (c) 2021 Paul Lezeau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen, Paul Lezeau
-/
import algebra.is_prime_pow
import algebra.squarefree
import order.hom.bounded
import algebra.gcd_monoid.basic

/-!

# Chains of divisors

The results in this file show that in the monoid `associates M` of a `unique_factorization_monoid`
`M`, an element `a` is an n-th prime power iff its set of divisors is a strictly increasing chain
of length `n + 1`, meaning that we can find a strictly increasing bijection between `fin (n + 1)`
and the set of factors of `a`.

## Main results
- `divisor_chain.exists_chain_of_prime_pow` : existence of a chain for prime powers.
- `divisor_chain.is_prime_pow_of_has_chain` : elements that have a chain are prime powers.
- `multiplicity_prime_eq_multiplicity_image_by_factor_order_iso` : if there is a
  monotone bijection `d` between the set of factors of `a : associates M` and the set of factors of
  `b : associates N` then for any prime `p ∣ a`, `multiplicity p a = multiplicity (d p) b`.
- `multiplicity_eq_multiplicity_factor_dvd_iso_of_mem_normalized_factor` : if there is a bijection
  between the set of factors of `a : M` and `b : N` then for any prime `p ∣ a`,
  `multiplicity p a = multiplicity (d p) b`

## Todo
- Create a structure for chains of divisors.
- Simplify proof of `mem_normalized_factors_factor_dvd_iso_of_mem_normalized_factors` using
  `mem_normalized_factors_factor_order_iso_of_mem_normalized_factors` or vice versa.

-/

variables {M : Type*} [cancel_comm_monoid_with_zero M]

open unique_factorization_monoid multiplicity irreducible associates

namespace divisor_chain

lemma exists_chain_of_prime_pow {p : associates M} {n : ℕ} (hn : n ≠ 0) (hp : prime p) :
  ∃ c : fin (n + 1) → associates M,
    c 1 = p ∧ strict_mono c ∧
    ∀ {r : associates M}, r ≤ p^n ↔ ∃ i, r = c i :=
begin
  refine ⟨λ i, p^(i : ℕ), _, λ n m h, _, λ y, ⟨λ h, _, _⟩⟩,
  { rw [fin.coe_one', nat.mod_eq_of_lt, pow_one],
    exact nat.lt_succ_of_le (nat.one_le_iff_ne_zero.mpr hn) },
  { exact associates.dvd_not_unit_iff_lt.mp ⟨pow_ne_zero n hp.ne_zero, p^(m - n : ℕ),
      not_is_unit_of_not_is_unit_dvd hp.not_unit (dvd_pow dvd_rfl (nat.sub_pos_of_lt h).ne'),
      (pow_mul_pow_sub p h.le).symm⟩ },
  { obtain ⟨i, i_le, hi⟩ := (dvd_prime_pow hp n).1 h,
    rw associated_iff_eq at hi,
    exact ⟨⟨i, nat.lt_succ_of_le i_le⟩, hi⟩ },
  { rintro ⟨i, rfl⟩,
    exact ⟨p^(n - i : ℕ), (pow_mul_pow_sub p (nat.succ_le_succ_iff.mp i.2)).symm⟩ }
end

lemma element_of_chain_not_is_unit_of_index_ne_zero {n : ℕ} {i : fin (n + 1)} (i_pos : i ≠ 0)
  {c : fin (n + 1) → associates M} (h₁ : strict_mono c) :
  ¬ is_unit (c i) :=
dvd_not_unit.not_unit (associates.dvd_not_unit_iff_lt.2
  (h₁ $ show (0 : fin (n + 1)) < i, from i.pos_iff_ne_zero.mpr i_pos))

lemma first_of_chain_is_unit {q : associates M} {n : ℕ} {c : fin (n + 1) → associates M}
  (h₁ : strict_mono c) (h₂ : ∀ {r}, r ≤ q ↔ ∃ i, r = c i) : is_unit (c 0) :=
begin
  obtain ⟨i, hr⟩ := h₂.mp associates.one_le,
  rw [associates.is_unit_iff_eq_one, ← associates.le_one_iff, hr],
  exact h₁.monotone (fin.zero_le i)
end

/-- The second element of a chain is irreducible. -/
lemma second_of_chain_is_irreducible {q : associates M} {n : ℕ} (hn : n ≠ 0)
  {c : fin (n + 1) → associates M} (h₁ : strict_mono c) (h₂ : ∀ {r}, r ≤ q ↔ ∃ i, r = c i)
  (hq : q ≠ 0) : irreducible (c 1) :=
begin
  cases n, { contradiction },
  refine (associates.is_atom_iff (ne_zero_of_dvd_ne_zero hq (h₂.2 ⟨1, rfl⟩))).mp ⟨_, λ b hb, _⟩,
  { exact ne_bot_of_gt (h₁ (show (0 : fin (n + 2)) < 1, from fin.one_pos)) },
  obtain ⟨⟨i, hi⟩, rfl⟩ := h₂.1 (hb.le.trans (h₂.2 ⟨1, rfl⟩)),
  cases i,
  { exact (associates.is_unit_iff_eq_one _).mp (first_of_chain_is_unit h₁ @h₂) },
  { simpa [fin.lt_iff_coe_lt_coe] using h₁.lt_iff_lt.mp hb },
end

lemma eq_second_of_chain_of_prime_dvd {p q r : associates M} {n : ℕ} (hn : n ≠ 0)
  {c : fin (n + 1) → associates M} (h₁ : strict_mono c)
  (h₂ : ∀ {r : associates M}, r ≤ q ↔ ∃ i, r = c i) (hp : prime p) (hr : r ∣ q) (hp' : p ∣ r) :
  p = c 1 :=
begin
  cases n,
  { contradiction },
  obtain ⟨i, rfl⟩ := h₂.1 (dvd_trans hp' hr),
  refine congr_arg c (eq_of_ge_of_not_gt _ $ λ hi, _),
  { rw [fin.le_iff_coe_le_coe, fin.coe_one, nat.succ_le_iff, ← fin.coe_zero,
        ← fin.lt_iff_coe_lt_coe, fin.pos_iff_ne_zero],
    rintro rfl,
    exact hp.not_unit (first_of_chain_is_unit h₁ @h₂) },
  obtain (rfl | ⟨j, rfl⟩) := i.eq_zero_or_eq_succ,
  { cases hi },
  refine not_irreducible_of_not_unit_dvd_not_unit
    (dvd_not_unit.not_unit (associates.dvd_not_unit_iff_lt.2
    (h₁ (show (0 : fin (n + 2)) < j, from _)) )) _ hp.irreducible,
  { simpa [← fin.succ_zero_eq_one, fin.succ_lt_succ_iff] using hi },
  { refine associates.dvd_not_unit_iff_lt.2 (h₁ _),
    simpa only [fin.coe_eq_cast_succ] using fin.lt_succ }
end

lemma card_subset_divisors_le_length_of_chain {q : associates M}
  {n : ℕ} {c : fin (n + 1) → associates M} (h₂ : ∀ {r}, r ≤ q ↔ ∃ i, r = c i)
  {m : finset (associates M)} (hm : ∀ r, r ∈ m → r ≤ q) : m.card ≤ n + 1 :=
begin
  classical,
  have mem_image : ∀ (r : associates M), r ≤ q → r ∈ finset.univ.image c,
  { intros r hr,
    obtain ⟨i, hi⟩ := h₂.1 hr,
    exact finset.mem_image.2 ⟨i, finset.mem_univ _, hi.symm⟩ },
  rw ←finset.card_fin (n + 1),
  exact (finset.card_le_of_subset $ λ x hx, mem_image x $ hm x hx).trans finset.card_image_le,
end

variables [unique_factorization_monoid M]

lemma element_of_chain_eq_pow_second_of_chain {q r : associates M} {n : ℕ} (hn : n ≠ 0)
  {c : fin (n + 1) → associates M} (h₁ : strict_mono c)
  (h₂ : ∀ {r}, r ≤ q ↔ ∃ i, r = c i) (hr : r ∣ q)
  (hq : q ≠ 0) : ∃ (i : fin (n + 1)), r = (c 1) ^ (i : ℕ) :=
begin
  classical,
  let i := (normalized_factors r).card,
  have hi : normalized_factors r = multiset.repeat (c 1) i,
  { apply multiset.eq_repeat_of_mem,
    intros b hb,
    refine eq_second_of_chain_of_prime_dvd hn h₁ (λ r', h₂) (prime_of_normalized_factor b hb) hr
      (dvd_of_mem_normalized_factors hb) },
  have H : r = (c 1)^i,
  { have := unique_factorization_monoid.normalized_factors_prod (ne_zero_of_dvd_ne_zero hq hr),
    rw [associated_iff_eq, hi, multiset.prod_repeat] at this,
    rw this },

  refine ⟨⟨i, _⟩, H⟩,
  have : (finset.univ.image (λ (m : fin (i + 1)), (c 1) ^ (m : ℕ))).card = i + 1,
  { conv_rhs { rw [← finset.card_fin (i+1)] },
    cases n, { contradiction },
    rw finset.card_image_iff,
    refine set.inj_on_of_injective (λ m m' h, fin.ext _) _,
    refine pow_injective_of_not_unit
      (element_of_chain_not_is_unit_of_index_ne_zero (by simp) h₁) _ h,
    exact irreducible.ne_zero (second_of_chain_is_irreducible hn h₁ @h₂ hq) },

  suffices H' : ∀ r ∈ (finset.univ.image (λ (m : fin (i + 1)), (c 1) ^ (m : ℕ))), r ≤ q,
  { simp only [← nat.succ_le_iff, nat.succ_eq_add_one, ← this],
    apply card_subset_divisors_le_length_of_chain @h₂ H' },

  simp only [finset.mem_image],
  rintros r ⟨a, ha, rfl⟩,
  refine dvd_trans _ hr,
  use (c 1)^(i - a),
  rw pow_mul_pow_sub (c 1),
  { exact H },
  { exact nat.succ_le_succ_iff.mp a.2 }
end

lemma eq_pow_second_of_chain_of_has_chain {q : associates M} {n : ℕ} (hn : n ≠ 0)
  {c : fin (n + 1) → associates M} (h₁ : strict_mono c)
  (h₂ : ∀ {r : associates M}, r ≤ q ↔ ∃ i, r = c i) (hq : q ≠ 0) : q = (c 1)^n :=
begin
  classical,
  obtain ⟨i, hi'⟩ := element_of_chain_eq_pow_second_of_chain hn h₁ (λ r, h₂) (dvd_refl q) hq,
  convert hi',
  refine (nat.lt_succ_iff.1 i.prop).antisymm' (nat.le_of_succ_le_succ _),
  calc n + 1 = (finset.univ : finset (fin (n + 1))).card : (finset.card_fin _).symm
         ... = (finset.univ.image c).card :
    (finset.card_image_iff.mpr (h₁.injective.inj_on _)).symm
         ... ≤ (finset.univ.image (λ (m : fin (i + 1)), (c 1)^(m : ℕ))).card :
          finset.card_le_of_subset _
         ... ≤ (finset.univ : finset (fin (i + 1))).card : finset.card_image_le
         ... = i + 1 : finset.card_fin _,
  intros r hr,
  obtain ⟨j, -, rfl⟩ := finset.mem_image.1 hr,
  have := h₂.2 ⟨j, rfl⟩,
  rw hi' at this,
  obtain ⟨u, hu, hu'⟩ := (dvd_prime_pow (show prime (c 1), from _) i).1 this,
  refine finset.mem_image.mpr ⟨u, finset.mem_univ _, _⟩,
  { rw associated_iff_eq at hu', rw [fin.coe_coe_of_lt (nat.lt_succ_of_le hu), hu'] },
  { rw ← irreducible_iff_prime, exact second_of_chain_is_irreducible hn h₁ @h₂ hq, }
end

lemma is_prime_pow_of_has_chain {q : associates M} {n : ℕ} (hn : n ≠ 0)
  {c : fin (n + 1) → associates M} (h₁ : strict_mono c)
  (h₂ : ∀ {r : associates M}, r ≤ q ↔ ∃ i, r = c i) (hq : q ≠ 0) : is_prime_pow q :=
⟨c 1, n, irreducible_iff_prime.mp (second_of_chain_is_irreducible hn h₁ @h₂ hq),
  zero_lt_iff.mpr hn, (eq_pow_second_of_chain_of_has_chain hn h₁ @h₂ hq).symm⟩

end divisor_chain

variables {N : Type*} [cancel_comm_monoid_with_zero N]

lemma factor_order_iso_map_one_eq_bot {m : associates M} {n : associates N}
  (d : {l : associates M // l ≤ m} ≃o {l : associates N // l ≤ n}) :
  (d ⟨1, one_dvd m⟩ : associates N) = 1 :=
begin
  letI : order_bot {l : associates M // l ≤ m} := subtype.order_bot bot_le,
  letI : order_bot {l : associates N // l ≤ n} := subtype.order_bot bot_le,
  simp [←associates.bot_eq_one]
end

lemma coe_factor_order_iso_map_eq_one_iff {m u : associates M} {n : associates N}
  (hu' : u ≤ m) (d : set.Iic m ≃o set.Iic n) :
  (d ⟨u, hu'⟩ : associates N) = 1 ↔ u = 1 :=
⟨λ hu, by { rw (show u = ↑(d.symm ⟨↑(d ⟨u, hu'⟩), (d ⟨u, hu'⟩).prop⟩), by simp only
    [subtype.coe_eta, order_iso.symm_apply_apply, subtype.coe_mk]),
  convert factor_order_iso_map_one_eq_bot d.symm },
  λ hu, by {simp_rw hu, convert factor_order_iso_map_one_eq_bot d } ⟩

section

variables [unique_factorization_monoid N] [unique_factorization_monoid M]

open divisor_chain

lemma pow_image_of_prime_by_factor_order_iso_dvd [decidable_eq (associates M)] {m p : associates M}
  {n : associates N} (hn : n ≠ 0) (hp : p ∈ normalized_factors m)
  (d : set.Iic m ≃o set.Iic n) {s : ℕ} (hs' : p^s ≤ m) :
  (d ⟨p, dvd_of_mem_normalized_factors hp⟩ : associates N)^s ≤ n :=
begin
  by_cases hs : s = 0,
  { simp [hs], },
  suffices : (d ⟨p, dvd_of_mem_normalized_factors hp⟩ : associates N)^s = ↑(d ⟨p^s, hs'⟩),
  { rw this,
    apply subtype.prop (d ⟨p^s, hs'⟩) },
  obtain ⟨c₁, rfl, hc₁', hc₁''⟩ := exists_chain_of_prime_pow hs (prime_of_normalized_factor p hp),

  set c₂ : fin (s + 1) → associates N := λ t, d ⟨c₁ t, le_trans (hc₁''.2 ⟨t, by simp⟩) hs'⟩,
  have c₂.def : ∀ (t), c₂ t = d ⟨c₁ t, _⟩ := λ t, rfl,
  refine (congr_arg (^s) (c₂.def 1).symm).trans _,
  refine (eq_pow_second_of_chain_of_has_chain hs (λ t u h, _) (λ r, ⟨λ hr, _, _⟩) _).symm,
  { rw [c₂.def, c₂.def, subtype.coe_lt_coe, d.lt_iff_lt, subtype.mk_lt_mk, (hc₁').lt_iff_lt],
    exact h },
  { have : r ≤ n := hr.trans (d ⟨c₁ 1 ^ s, _⟩).2,
    suffices : d.symm ⟨r, this⟩ ≤ ⟨c₁ 1 ^ s, hs'⟩,
    { obtain ⟨i, hi⟩ := hc₁''.1 this,
      use i,
      simp only [c₂.def, ← hi, d.apply_symm_apply, subtype.coe_eta, subtype.coe_mk] },
    conv_rhs { rw ← d.symm_apply_apply ⟨c₁ 1 ^ s, hs'⟩ },
    rw d.symm.le_iff_le,
    simpa only [← subtype.coe_le_coe, subtype.coe_mk] using hr },
  { rintros ⟨i, hr⟩,
    rw [hr, c₂.def, subtype.coe_le_coe, d.le_iff_le],
    simpa [subtype.mk_le_mk] using hc₁''.2 ⟨i, rfl⟩ },
  exact ne_zero_of_dvd_ne_zero hn (subtype.prop (d ⟨c₁ 1 ^ s, _⟩))
end

lemma map_prime_of_factor_order_iso [decidable_eq (associates M)]
  {m p : associates M} {n : associates N} (hn : n ≠ 0) (hp : p ∈ normalized_factors m)
  (d : set.Iic m ≃o set.Iic n) : prime (d ⟨p, dvd_of_mem_normalized_factors hp⟩ : associates N) :=
begin
  rw ← irreducible_iff_prime,
  refine (associates.is_atom_iff $ ne_zero_of_dvd_ne_zero hn (d ⟨p, _⟩).prop).mp ⟨_, λ b hb, _⟩,
  { rw [ne.def, ← associates.is_unit_iff_eq_bot, associates.is_unit_iff_eq_one,
      coe_factor_order_iso_map_eq_one_iff _ d],
    rintro rfl,
    exact (prime_of_normalized_factor 1 hp).not_unit is_unit_one },
  { obtain ⟨x, hx⟩ := d.surjective ⟨b, le_trans (le_of_lt hb)
      (d ⟨p, dvd_of_mem_normalized_factors hp⟩).prop⟩,
    rw [← subtype.coe_mk b _ , subtype.coe_lt_coe, ← hx] at hb,
    letI : order_bot {l : associates M // l ≤ m} := subtype.order_bot bot_le,
    letI : order_bot {l : associates N // l ≤ n} := subtype.order_bot bot_le,
    suffices : x = ⊥,
    { rw [this, order_iso.map_bot d] at hx,
      refine (subtype.mk_eq_bot_iff _ _).mp hx.symm,
      exact bot_le },
    obtain ⟨a, ha⟩ := x,
    rw subtype.mk_eq_bot_iff,
    { exact ((associates.is_atom_iff $ prime.ne_zero $ prime_of_normalized_factor p hp).mpr $
      irreducible_of_normalized_factor p hp).right a (subtype.mk_lt_mk.mp $ d.lt_iff_lt.mp hb) },
  exact bot_le }
end

lemma mem_normalized_factors_factor_order_iso_of_mem_normalized_factors
  [decidable_eq (associates M)] [decidable_eq (associates N)] {m p : associates M}
  {n : associates N} (hn : n ≠ 0) (hp : p ∈ normalized_factors m)
  (d : set.Iic m ≃o set.Iic n) :
  ↑(d ⟨p, dvd_of_mem_normalized_factors hp⟩) ∈ normalized_factors n :=
begin
  obtain ⟨q, hq, hq'⟩ := exists_mem_normalized_factors_of_dvd hn
    (map_prime_of_factor_order_iso hn hp d).irreducible
    (d ⟨p, dvd_of_mem_normalized_factors hp⟩).prop,
  rw associated_iff_eq at hq',
  rwa hq'
end

variables [decidable_rel ((∣) : M → M → Prop)] [decidable_rel ((∣) : N → N → Prop)]

lemma multiplicity_prime_le_multiplicity_image_by_factor_order_iso [decidable_eq (associates M)]
  {m p : associates M} {n : associates N} (hp : p ∈ normalized_factors m)
  (d : set.Iic m ≃o set.Iic n) :
  multiplicity p m ≤ multiplicity ↑(d ⟨p, dvd_of_mem_normalized_factors hp⟩) n :=
begin
  by_cases hn : n = 0,
  { simp [hn], },
  by_cases hm : m = 0,
  { simpa [hm] using hp, },
  rw [←enat.coe_get (finite_iff_dom.1 $ finite_prime_left (prime_of_normalized_factor p hp) hm),
    ←pow_dvd_iff_le_multiplicity],
  exact pow_image_of_prime_by_factor_order_iso_dvd hn hp d (pow_multiplicity_dvd _),
end

lemma multiplicity_prime_eq_multiplicity_image_by_factor_order_iso [decidable_eq (associates M)]
  {m p : associates M} {n : associates N} (hn : n ≠ 0)
  (hp : p ∈ normalized_factors m) (d : set.Iic m ≃o set.Iic n) :
  multiplicity p m = multiplicity ↑(d ⟨p, dvd_of_mem_normalized_factors hp⟩) n :=
begin
  refine le_antisymm (multiplicity_prime_le_multiplicity_image_by_factor_order_iso hp d) _,
  suffices : multiplicity ↑(d ⟨p, dvd_of_mem_normalized_factors hp⟩) n ≤
    multiplicity ↑(d.symm (d ⟨p, dvd_of_mem_normalized_factors hp⟩)) m,
  { rw [d.symm_apply_apply ⟨p, dvd_of_mem_normalized_factors hp⟩, subtype.coe_mk] at this,
    exact this },
  letI := classical.dec_eq (associates N),
  simpa only [subtype.coe_eta] using
    (multiplicity_prime_le_multiplicity_image_by_factor_order_iso
      (mem_normalized_factors_factor_order_iso_of_mem_normalized_factors hn hp d) d.symm),
end

end

variables [unique (Mˣ)] [unique (Nˣ)]

/-- The order isomorphism between the factors of `mk m` and the factors of `mk n` induced by a
  bijection between the factors of `m` and the factors of `n` that preserves `∣`. -/
@[simps]
def mk_factor_order_iso_of_factor_dvd_equiv
  {m : M} {n : N} (d : {l : M // l ∣ m} ≃ {l : N // l ∣ n})
  (hd : ∀ l l', ((d l) : N) ∣ (d l') ↔ (l : M) ∣ (l' : M)) :
   set.Iic (associates.mk m) ≃o set.Iic (associates.mk n) :=
{ to_fun := λ l, ⟨associates.mk (d ⟨associates_equiv_of_unique_units ↑l,
    by { obtain ⟨x, hx⟩ := l, rw [subtype.coe_mk,  associates_equiv_of_unique_units_apply,
      out_dvd_iff], exact hx } ⟩),
    mk_le_mk_iff_dvd_iff.mpr (subtype.prop (d ⟨associates_equiv_of_unique_units ↑l, _ ⟩)) ⟩,
  inv_fun := λ l, ⟨associates.mk (d.symm (⟨(associates_equiv_of_unique_units ↑l),
      by obtain ⟨x, hx⟩ := l ; rw [subtype.coe_mk, associates_equiv_of_unique_units_apply,
      out_dvd_iff] ; exact hx ⟩)),
    mk_le_mk_iff_dvd_iff.mpr (subtype.prop (d.symm ⟨associates_equiv_of_unique_units ↑l, _ ⟩)) ⟩,
  left_inv := λ ⟨l, hl⟩, by simp only [subtype.coe_eta, equiv.symm_apply_apply, subtype.coe_mk,
    associates_equiv_of_unique_units_apply, mk_out, out_mk, normalize_eq],
  right_inv := λ ⟨l, hl⟩, by simp only [subtype.coe_eta, equiv.apply_symm_apply, subtype.coe_mk,
    associates_equiv_of_unique_units_apply, out_mk, normalize_eq, mk_out],
  map_rel_iff' :=
    by rintros ⟨a, ha⟩ ⟨b, hb⟩ ; simp only [equiv.coe_fn_mk, subtype.mk_le_mk,
      associates.mk_le_mk_iff_dvd_iff, hd, subtype.coe_mk, associates_equiv_of_unique_units_apply,
      out_dvd_iff, mk_out] }

variables [unique_factorization_monoid M] [unique_factorization_monoid N]
  [decidable_eq M]

lemma mem_normalized_factors_factor_dvd_iso_of_mem_normalized_factors [decidable_eq N] {m p : M}
  {n : N} (hm : m ≠ 0) (hn : n ≠ 0) (hp : p ∈ normalized_factors m)
  (d : {l : M // l ∣ m} ≃ {l : N // l ∣ n})
  (hd : ∀ l l', ((d l) : N) ∣ (d l') ↔ (l : M) ∣ (l' : M)) :
    ↑(d ⟨p, dvd_of_mem_normalized_factors hp⟩) ∈ normalized_factors n :=
begin
  suffices : prime ↑(d ⟨associates_equiv_of_unique_units (associates_equiv_of_unique_units.symm p),
    by simp [dvd_of_mem_normalized_factors hp]⟩),
  { simp only [associates_equiv_of_unique_units_apply, out_mk, normalize_eq,
      associates_equiv_of_unique_units_symm_apply] at this,
    obtain ⟨q, hq, hq'⟩ := exists_mem_normalized_factors_of_dvd hn (this.irreducible)
      (d ⟨p, by apply dvd_of_mem_normalized_factors ; convert hp⟩).prop,
    rwa associated_iff_eq.mp hq' },
  have : associates.mk ↑(d ⟨associates_equiv_of_unique_units
    (associates_equiv_of_unique_units.symm p), by simp only [dvd_of_mem_normalized_factors hp,
      associates_equiv_of_unique_units_apply, out_mk, normalize_eq,
      associates_equiv_of_unique_units_symm_apply] ⟩)
    = ↑(mk_factor_order_iso_of_factor_dvd_equiv d hd ⟨( associates_equiv_of_unique_units.symm p),
      by simp only [associates_equiv_of_unique_units_symm_apply] ;
        exact mk_dvd_mk.mpr (dvd_of_mem_normalized_factors hp) ⟩),
  { rw mk_factor_order_iso_of_factor_dvd_equiv_apply_coe,
    simp only [subtype.coe_mk] },
  rw [ ← associates.prime_mk, this],
  letI := classical.dec_eq (associates M),
  refine map_prime_of_factor_order_iso (mk_ne_zero.mpr hn) _ _,
  obtain ⟨q, hq, hq'⟩ := exists_mem_normalized_factors_of_dvd (mk_ne_zero.mpr hm)
    ((prime_mk p).mpr (prime_of_normalized_factor p (by convert hp))).irreducible
      (mk_le_mk_of_dvd (dvd_of_mem_normalized_factors hp)),
  simpa only [associated_iff_eq.mp hq', associates_equiv_of_unique_units_symm_apply] using hq,
end

variables [decidable_rel ((∣) : M → M → Prop)] [decidable_rel ((∣) : N → N → Prop)]

lemma multiplicity_eq_multiplicity_factor_dvd_iso_of_mem_normalized_factor {m p : M} {n : N}
  (hm : m ≠ 0) (hn : n ≠ 0) (hp : p ∈ normalized_factors m)
  (d : {l : M // l ∣ m} ≃ {l : N // l ∣ n}) (hd : ∀ l l', ((d l) : N) ∣ (d l') ↔ (l : M) ∣ l') :
    multiplicity p m = multiplicity ((d ⟨p, dvd_of_mem_normalized_factors hp⟩) : N) n :=
begin
  suffices : multiplicity (associates.mk p) (associates.mk m) = multiplicity (associates.mk
    ↑(d ⟨associates_equiv_of_unique_units (associates_equiv_of_unique_units.symm p),
      by simp [dvd_of_mem_normalized_factors hp]⟩))
    (associates.mk n),
  { simpa only [multiplicity_mk_eq_multiplicity, associates_equiv_of_unique_units_symm_apply,
      associates_equiv_of_unique_units_apply, out_mk, normalize_eq] using this },
  have : associates.mk ↑(d ⟨associates_equiv_of_unique_units
    (associates_equiv_of_unique_units.symm p), by simp only [dvd_of_mem_normalized_factors hp,
      associates_equiv_of_unique_units_symm_apply, associates_equiv_of_unique_units_apply,
      out_mk, normalize_eq] ⟩)
      = ↑(mk_factor_order_iso_of_factor_dvd_equiv d hd ⟨(associates_equiv_of_unique_units.symm p),
        by rw [associates_equiv_of_unique_units_symm_apply] ;
          exact mk_le_mk_of_dvd (dvd_of_mem_normalized_factors hp) ⟩),
  { rw mk_factor_order_iso_of_factor_dvd_equiv_apply_coe, refl },
  rw this,
  letI := classical.dec_eq (associates M),
  refine multiplicity_prime_eq_multiplicity_image_by_factor_order_iso (mk_ne_zero.mpr hn) _
    (mk_factor_order_iso_of_factor_dvd_equiv d hd),
  obtain ⟨q, hq, hq'⟩ := exists_mem_normalized_factors_of_dvd (mk_ne_zero.mpr hm)
    ((prime_mk p).mpr (prime_of_normalized_factor p hp)).irreducible
      (mk_le_mk_of_dvd (dvd_of_mem_normalized_factors hp)),
  rwa associated_iff_eq.mp hq',
end


import tactic

/-!

Упражнения в этом файле взяты из курса Formalising Mathematics:
https://github.com/ImperialCollegeLondon/formalising-mathematics/blob/master/src/week_1/Part_D_relations.lean

Рассмотрим тип `α` и бинарные отношения над `α`: `R : α → α → Prop`.
Для бинарных отношений в Lean определены понятия рефлексивности, симметричности и транзитивности:

`reflexive R := ∀ (x : α), R x x`
`symmetric R := ∀ ⦃x y : α⦄, R x y → R y x`
`transitive R := ∀ ⦃x y z : α⦄, R x y → R y z → R x z`

Отношение `R` является отношением эквивалентности, если оно удовлетворяет всем трем определенным выше утверждениям:

`equivalence R := reflexive R ∧ symmetric R ∧ transitive R`

В этом файле мы построим биекцию между отношениями эквивалентности на типе `α` и разбиениями элементов `α` на подмножества (чтобы не путаться, множества в разбиении будем называть блоками).

Определим тип разбиений элементов типа `α`. Разбиение состоит из четырех элементов:
1) `C : set (set α)` - множество блоков.
2) `Hnonempty` - доказательство того, что все блоки непусты.
3) `Hcover` - доказательство того, что любой элемент `a : α` лежит в каком-то блоке.
4) `Hdisjoint` - доказательство того, что разные блоки не пересекаются.

Ключевое слово `structure` задает тип с одним конструктором (он сгенерируется с названием `partition.mk`) и именными "полями". Если `P : partition α`, то можно писать `P.C`, `P.Hnonempty` и остальные.
-/

@[ext] structure partition (α : Type) :=
(C : set (set α))
(Hnonempty : ∀ X ∈ C, (X : set α).nonempty)
(Hcover : ∀ a, ∃ X ∈ C, a ∈ X)
(Hdisjoint : ∀ X Y ∈ C, (X ∩ Y : set α).nonempty → X = Y)

namespace partition

variables {α : Type} {P : partition α} {X Y : set α}

-- `X.nonempty` (или `set.nonempty X`) означает, что существует элемент, принадлежащий множеству `X`
lemma nonempty_def : X.nonempty ↔ ∃ a, a ∈ X :=
begin
  refl,
end

/-- Если `a` содержится в двух блоках `X` и `Y` -/
theorem eq_of_mem (hX : X ∈ P.C) (hY : Y ∈ P.C) {a : α} (haX : a ∈ X)
  (haY : a ∈ Y) : X = Y :=
begin
  sorry,
end

theorem mem_of_mem (hX : X ∈ P.C) (hY : Y ∈ P.C) {a b : α}
  (haX : a ∈ X) (haY : a ∈ Y) (hbX : b ∈ X) : b ∈ Y :=
begin
  sorry,
end

end partition

section equivalence_classes

variables {α : Type} (R : α → α → Prop) (hR : equivalence R)

-- Классом эквивалентности `a` назовем множество таких `b`, что `R b a`
def cl (a : α) := {b : α | R b a}

-- По определению, `b` лежит в классе эквивалентности `a`, если `R b a`
lemma mem_cl_iff {a b : α} : b ∈ cl R a ↔ R b a :=
begin
  refl
end

-- `a` принадлежит классу эквивалентности `a`
lemma mem_cl_self (hR : equivalence R) (a : α) : a ∈ cl R a :=
begin
  -- Чтобы использовать рефлексивность `R`, нужно распаковать `hR`
  -- Это можно сделать с помощью `rcases`: `rcases hR with ⟨hrefl, hsymm, htrans⟩`, или
  -- `obtain ⟨hrefl, hsymm, htrans⟩ := hR`
  sorry,
end

-- Если `a` лежит в классе `b`, то весь класс `a` - подмножество класса `b`
lemma cl_sub_cl_of_mem_cl {a b : α} (hR : equivalence R) : a ∈ cl R b → cl R a ⊆ cl R b :=
begin
  sorry,
end

-- Напоминание: `set.subset.antisymm : X ⊆ Y → Y ⊆ X → X = Y`
lemma cl_eq_cl_of_mem_cl {a b : α} (hR : equivalence R) : a ∈ cl R b → cl R a = cl R b :=
begin
  sorry,
end

end equivalence_classes

open partition

-- Чтобы доказать эквивалентность двух типов `X ≃ Y`, нужно построить преобразование `X → Y`, обратное преобразование `Y → X`, а также доказать, что эти два преобразования взаимнообратны

-- Далее внутри будут огромные и страшные цели, но мы их будем менять на эквивалентные с помощью тактик `change` и `show`

example (α : Type) : {R : α → α → Prop // equivalence R} ≃ partition α :=
{ -- Преобразуем отношение эквивалентности `R` в разбиение:
  to_fun := λ R, {
    -- Возьмем за `C` множество классов эквивалентности всех элементов типа `α` по отношению R
    C := { B : set α | ∃ x : α, B = cl R.1 x},
    -- Докажем, что такое множество блоков является разбиением. Для этого нужно доказать три свойства разбиений: `Hnonempty`, `Hcover` и `Hdisjoint`. Докажем их:
    Hnonempty := begin
      -- Любый класс эквивалентности непуст.
      cases R with R hR,
      change ∀ (X : set α), (∃ (a : α), X = cl R a) → X.nonempty,
      sorry,
    end,
    Hcover := begin
      -- Каждый элемент типа `α` содержится хотя бы в одном классе эквивалентности.
      cases R with R hR,
      change ∀ (a : α), ∃ (X : set α) (H : ∃ (b : α), X = cl R b), a ∈ X,
      sorry,
    end,
    Hdisjoint := begin
      -- Если два класса эквивалентности пересекаются, то они равны.
      cases R with R hR,
      change ∀ (X Y : set α), (∃ (a : α), X = cl R a) →
        (∃ (b : α), Y = cl _ b) → (X ∩ Y).nonempty → X = Y,
      sorry,
    end },
  -- Теперь построим отношение эквивалентности по разбиению
  inv_fun := λ P,
    -- Определим бинарное отношение `R`:
    -- `R a b` если любой блок, содержащий `a`, также содержит `b`.
    ⟨λ a b, ∀ X ∈ P.C, a ∈ X → b ∈ X, begin
      -- Докажем, что это отношение эквивалентности
    split,
    { -- Оно рефлексивно
      unfold reflexive,
      sorry,
    },
    split,
    { -- Оно симметрично
      unfold symmetric,
      sorry,
    },
    { -- Оно транзитивно
      unfold transitive,
      show ∀ (a b c : α),
        (∀ (X : set α), X ∈ P.C → a ∈ X → b ∈ X) →
        (∀ (X : set α), X ∈ P.C → b ∈ X → c ∈ X) →
         ∀ (X : set α), X ∈ P.C → a ∈ X → c ∈ X,
      sorry,
    }
  end⟩,
  -- Если начать с отношения `R` и сделать оба преобразования, снова получится `R`
  left_inv := begin
    rintro ⟨R, hR⟩,
    -- Страшная цель, но она эквивалентна следующей:
    suffices h : (λ (a b : α), ∀ (c : α), a ∈ cl R c → b ∈ cl R c) = R,
    simpa using h,
    -- И теперь докажем, что два отношения совпадают, тактика `ext` превратит цель в ↔ для конкретных `a` и `b`
    ext a b,
    sorry,
  end,
  -- Аналогично, если начать с разбиения `P` и сделать два преобразования, получится оригинальное разбиение
  right_inv := begin
    intro P,
    ext X,
    show (∃ (a : α), X = cl _ a) ↔ X ∈ P.C,
    dsimp only,
    sorry,
  end }


import algebra.field
import gtm106.weierstrass_equation.linear_change_of_variable
import gtm106.weierstrass_equation.group_law.basic
import tactic

namespace weierstrass_equation

-- ================
-- P ↦ -P
-- ================

namespace neg_of_affine_plane_point

lemma lcov {K : Type*} [field K] (E : weierstrass_equation K)
(P : affine_plane_point K) (cov : linear_change_of_variable K)
: (cov.change_curve E).neg_of_affine_plane_point (cov.change_affine_point P)
= cov.change_affine_point (E.neg_of_affine_plane_point P) :=
begin
  simp only [linear_change_of_variable.change_affine_point,
    linear_change_of_variable.change_curve,
    neg_of_affine_plane_point],
  split,
  { refl, },
  field_simp [cov.hu],
  ring,
end

end neg_of_affine_plane_point

-- ================
-- Intersection with line
-- ================

namespace intersection_with_line

def A_lcov {K : Type*} [field K]
(A : K) (cov : linear_change_of_variable K) : K
:= (A - cov.s) / cov.u

@[simp]
lemma B_lcov {K : Type*} [field K]
(P : affine_plane_point K)
(A : K) (cov : linear_change_of_variable K)
: B (cov.change_affine_point P) (A_lcov A cov)
= (B P A + A * cov.r - cov.t) / cov.u ^ 3 :=
begin
  simp only [linear_change_of_variable.change_affine_point,
    A_lcov, B],
  field_simp [cov.hu],
  ring,
end

@[simp]
lemma a_lcov {K : Type*} [field K] (E : weierstrass_equation K)
(A : K) (cov : linear_change_of_variable K)
: a (cov.change_curve E) (A_lcov A cov)
= (a E A + 3 * cov.r) / cov.u ^ 2 :=
begin
  simp only [linear_change_of_variable.change_curve,
    a, A_lcov],
  field_simp [cov.hu],
  ring,
end

@[simp]
lemma b_lcov {K : Type*} [field K] (E : weierstrass_equation K)
(P : affine_plane_point K)
(A : K) (cov : linear_change_of_variable K)
: b (cov.change_curve E) (cov.change_affine_point P) (A_lcov A cov)
= (b E P A + 2 * a E A * cov.r + 3 * cov.r ^ 2) / cov.u ^ 4 :=
begin
  unfold b,
  rw B_lcov,
  simp only [linear_change_of_variable.change_curve,
    a, A_lcov, B],
  field_simp [cov.hu],
  ring,
end

@[simp]
lemma c_lcov {K : Type*} [field K] (E : weierstrass_equation K)
(P : affine_plane_point K)
(A : K) (cov : linear_change_of_variable K)
: c (cov.change_curve E) (cov.change_affine_point P) (A_lcov A cov)
= (c E P A + b E P A * cov.r + a E A * cov.r ^ 2 + cov.r ^ 3) / cov.u ^ 6 :=
begin
  unfold c,
  rw B_lcov,
  simp only [linear_change_of_variable.change_curve,
    b, a, B],
  field_simp [cov.hu],
  ring,
end

@[simp]
lemma disc_lcov {K : Type*} [field K] (E : weierstrass_equation K)
(P : affine_plane_point K)
(A : K) (cov : linear_change_of_variable K)
: monic_cubic_poly.disc ⟨ a (cov.change_curve E) (A_lcov A cov),
  b (cov.change_curve E) (cov.change_affine_point P) (A_lcov A cov),
  c (cov.change_curve E) (cov.change_affine_point P) (A_lcov A cov) ⟩
= monic_cubic_poly.disc ⟨ a E A,
  b E P A,
  c E P A ⟩ / cov.u ^ 12
:=
begin
  simp only [a_lcov, b_lcov, c_lcov,
    monic_cubic_poly.disc],
  field_simp [cov.hu, pow_succ],
  ring,
end

@[simp]
lemma eval_at_lcov {K : Type*} [field K] (E : weierstrass_equation K)
(P : affine_plane_point K)
(A : K) (cov : linear_change_of_variable K) (x : K)
: eval_at (cov.change_curve E) (cov.change_affine_point P) (A_lcov A cov) (x/cov.u^2 - cov.r/cov.u^2)
= eval_at E P A x / cov.u ^ 6 :=
begin
  simp only [eval_at, monic_cubic_poly.eval_at,
    a_lcov, b_lcov, c_lcov],
  field_simp [cov.hu, pow_succ],
  ring,
end

@[simp]
lemma eval_dx_at_lcov {K : Type*} [field K] (E : weierstrass_equation K)
(P : affine_plane_point K)
(A : K) (cov : linear_change_of_variable K) (x : K)
: monic_cubic_poly.eval_dx_at ⟨ a (cov.change_curve E) (A_lcov A cov),
  b (cov.change_curve E) (cov.change_affine_point P) (A_lcov A cov),
  c (cov.change_curve E) (cov.change_affine_point P) (A_lcov A cov) ⟩
  (x/cov.u^2 - cov.r/cov.u^2)
= monic_cubic_poly.eval_dx_at ⟨ a E A,
  b E P A,
  c E P A ⟩ x / cov.u ^ 4 :=
begin
  simp only [monic_cubic_poly.eval_dx_at,
    a_lcov, b_lcov, c_lcov],
  field_simp [cov.hu, pow_succ],
  ring,
end

lemma is_on_lcov {K : Type*} [field K] (E : weierstrass_equation K)
(P : affine_plane_point K)
(A : K) (cov : linear_change_of_variable K) (x : K)
: is_on (cov.change_curve E) (cov.change_affine_point P) (A_lcov A cov) (x/cov.u^2 - cov.r/cov.u^2)
↔ is_on E P A x :=
begin
  unfold is_on,
  rw eval_at_lcov E P A cov x,
  simp,
end

lemma is_on_2_lcov {K : Type*} [field K] (E : weierstrass_equation K)
(P : affine_plane_point K)
(A : K) (cov : linear_change_of_variable K) (x : K)
: is_on_2 (cov.change_curve E) (cov.change_affine_point P) (A_lcov A cov) (x/cov.u^2 - cov.r/cov.u^2)
↔ is_on_2 E P A x :=
begin
  unfold is_on_2,
  rw eval_dx_at_lcov E P A cov x,
  simp,
end

end intersection_with_line

-- ================
-- P ↦ -2*P
-- ================

namespace neg_of_double_of_affine_plane_point

@[simp]
lemma A_lcov {K : Type*} [field K] (E : weierstrass_equation K)
(P : affine_plane_point K)
(cov : linear_change_of_variable K)
: A (cov.change_curve E) (cov.change_affine_point P)
= (A E P - C E P * cov.s) / cov.u ^ 4 :=
begin
  simp only [A1, C1, linear_change_of_variable.eval_dx_at_affine_point],
  ring,
end

@[simp]
lemma C_lcov {K : Type*} [field K] (E : weierstrass_equation K)
(P : affine_plane_point K)
(cov : linear_change_of_variable K)
: C (cov.change_curve E) (cov.change_affine_point P)
= C E P / cov.u ^ 3 :=
begin
  simp only [A1, C1, linear_change_of_variable.eval_dy_at_affine_point],
end

lemma x_lcov {K : Type*} [field K] (E : weierstrass_equation K)
(P : affine_plane_point K) (h : E.affine_point_on_curve P) (hC : C E P ≠ 0)
(cov : linear_change_of_variable K)
: x (cov.change_curve E) (cov.change_affine_point P)
= x E P/cov.u^2 - cov.r/cov.u^2 :=
begin
  have h' := (cov.preserve_affine_point E P).1 h,
  have hC' : C (cov.change_curve E) (cov.change_affine_point P) ≠ 0 := by {
    simp [hC],
  },
  have hC2 : (C E P / cov.u ^ 3) ^ 2 = C E P ^ 2 / cov.u ^ 6 := by {
    field_simp [pow_succ],
    ring,
  },
  rw [x' _ _ h hC, x' _ _ h' hC', ← C' _ _ h, ← C' _ _ h', C_lcov, hC2],
  replace hC : C E P ^ 2 ≠ 0 := by simp [hC],
  rw C' _ _ h at hC ⊢,
  simp [linear_change_of_variable.change_affine_point],
  field_simp [hC],
  field_simp [pow_succ],
  ring,
end

lemma y_lcov {K : Type*} [field K] (E : weierstrass_equation K)
(P : affine_plane_point K) (h : E.affine_point_on_curve P) (hC : C E P ≠ 0)
(cov : linear_change_of_variable K)
: y (cov.change_curve E) (cov.change_affine_point P)
= y E P/cov.u^3 - cov.s*x E P/cov.u^3 + (cov.r*cov.s-cov.t)/cov.u^3 :=
begin
  unfold y,
  simp [x_lcov E P h hC],
  simp only [linear_change_of_variable.change_affine_point],
  field_simp [hC],
  ring,
end

lemma lcov {K : Type*} [field K] (E : weierstrass_equation K)
(P : affine_plane_point K) (h : E.affine_point_on_curve P) (hC : C E P ≠ 0)
(cov : linear_change_of_variable K)
: (cov.change_curve E).neg_of_double_of_affine_plane_point (cov.change_affine_point P)
= cov.change_affine_point (E.neg_of_double_of_affine_plane_point P) :=
begin
  simp only [affine_plane_point.ext_iff],
  exact ⟨ x_lcov E P h hC cov, y_lcov E P h hC cov ⟩,
end

end neg_of_double_of_affine_plane_point

-- ================
-- (P1, P2) ↦ -(P1 + P2)
-- ================

-- TODO:

namespace neg_of_add_of_affine_plane_point

end neg_of_add_of_affine_plane_point

-- ================
-- (P1, P2) ↦ P1 + P2
-- ================

-- TODO:

end weierstrass_equation


import topology.basic
import data.real.basic
import topology.continuous_function.basic
import tactic
import topology.instances.real
import Homotopy
import Path

open topological_space

noncomputable theory

namespace Alg_Top

variables {X Y: Type} [topological_space X][topological_space Y]
variables {x₀ : X}

instance loop_setoid : setoid (Path x₀ x₀) :=
begin
    split, rotate 1,
    use Path_Homotopic, apply @Path_Hom_Equiv,
end

def π₁ (x₀:X):= quotient (@Alg_Top.loop_setoid X _ x₀)
def foo : Path x₀ x₀ := Id

@[simp] lemma equiv_def (x y : Path x₀ x₀) : x ≈ y ↔ Path_Homotopic x y:=
begin
  refl
end

#check ⟦foo⟧
#check foo
#check π₁

example (x y : x₀ ⟶ x₀) : x ≈ y → ⟦x⟧ = ⟦y⟧ :=
quotient.sound

example (x y : x₀ ⟶ x₀) : ⟦x⟧ = ⟦y⟧ → x ≈ y :=
quotient.exact

example (x y : x₀ ⟶ x₀) : ⟦x⟧ = ⟦y⟧ ↔ x ≈ y :=
quotient.eq

@[simp] def id : π₁ x₀ := ⟦Id⟧

def inverse : π₁ x₀ → π₁ x₀ :=
begin
  apply quotient.lift,
  rotate, intro x, use ⟦x⁻¹⟧,
  intros x y rxy,simp, apply Inverse_Homotopic, rw ← equiv_def, exact rxy,
end

@[simp] lemma inv_def (a : x₀ ⟶ x₀) :  inverse ⟦a⟧ = ⟦a⁻¹⟧  :=
begin
  refl,
end

def multiply : π₁ x₀ → π₁ x₀ → π₁ x₀ :=
begin
  apply quotient.lift₂,
  rotate,
  intros x y,
  exact ⟦x ∘ y⟧,
  intros x y a b rxa ryb, simp,
  apply Path_Comp_Preserve_Path_Hom,
  exact rxa, exact ryb,
end

@[simp] lemma multiply_def (a b : x₀ ⟶ x₀) : multiply ⟦a⟧ ⟦b⟧ = ⟦a∘b⟧ :=
begin
  refl,
end

@[simp] lemma mul_inv (a : x₀ ⟶ x₀) : multiply (inverse ⟦a⟧) ⟦a⟧ = id :=
begin
  simp, exact left_handed_inverse a,
end
  /-{
    intros a b c, apply quotient.induction_on₃ a b c, clear a b c,
    intros a b c, simp, exact Path_Assoc a b c,
  }, -/

def group_structure : group (π₁ x₀) :=
{
  mul := multiply,
  one := id,
  inv := inverse,
  mul_assoc := begin
    intros a b c, apply quotient.induction_on₃ a b c, clear a b c,
    intros a b c, simp, exact Path_Assoc a b c,
  end,
  one_mul := begin
    intro a, apply quotient.induction_on a, clear a,
    intro a, simp, exact left_handed_id a,
  end,
  mul_one := begin
    intro a, apply quotient.induction_on a, clear a,
    intro a, simp, exact right_handed_id a,
  end,
  mul_left_inv := begin
    intro a,  apply quotient.induction_on a, clear a,
    intro a, exact mul_inv a,
  end,
}

#check Alg_Top.loop_setoid

end Alg_Top


/-
Copyright (c) 2022 Daniel Roca González. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Daniel Roca González

! This file was ported from Lean 3 source module analysis.inner_product_space.lax_milgram
! leanprover-community/mathlib commit 46b633fd842bef9469441c0209906f6dddd2b4f5
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.InnerProductSpace.Projection
import Mathbin.Analysis.InnerProductSpace.Dual
import Mathbin.Analysis.NormedSpace.Banach
import Mathbin.Analysis.NormedSpace.OperatorNorm
import Mathbin.Topology.MetricSpace.Antilipschitz

/-!
# The Lax-Milgram Theorem

We consider an Hilbert space `V` over `ℝ`
equipped with a bounded bilinear form `B : V →L[ℝ] V →L[ℝ] ℝ`.

Recall that a bilinear form `B : V →L[ℝ] V →L[ℝ] ℝ` is *coercive*
iff `∃ C, (0 < C) ∧ ∀ u, C * ‖u‖ * ‖u‖ ≤ B u u`.
Under the hypothesis that `B` is coercive
we prove the Lax-Milgram theorem:
that is, the map `inner_product_space.continuous_linear_map_of_bilin` from
`analysis.inner_product_space.dual` can be upgraded to a continuous equivalence
`is_coercive.continuous_linear_equiv_of_bilin : V ≃L[ℝ] V`.

## References

* We follow the notes of Peter Howard's Spring 2020 *M612: Partial Differential Equations* lecture,
  see[howard]

## Tags

dual, Lax-Milgram
-/

noncomputable section

open IsROrC LinearMap ContinuousLinearMap InnerProductSpace

open LinearMap (ker range)

open RealInnerProductSpace NNReal

universe u

namespace IsCoercive

variable {V : Type u} [NormedAddCommGroup V] [InnerProductSpace ℝ V] [CompleteSpace V]

variable {B : V →L[ℝ] V →L[ℝ] ℝ}

-- mathport name: «expr ♯»
local postfix:1024 "♯" => @continuousLinearMapOfBilin ℝ V _ _ _ _

theorem bounded_below (coercive : IsCoercive B) : ∃ C, 0 < C ∧ ∀ v, C * ‖v‖ ≤ ‖B♯ v‖ :=
  by
  rcases coercive with ⟨C, C_ge_0, coercivity⟩
  refine' ⟨C, C_ge_0, _⟩
  intro v
  by_cases h : 0 < ‖v‖
  · refine' (mul_le_mul_right h).mp _
    calc
      C * ‖v‖ * ‖v‖ ≤ B v v := coercivity v
      _ = ⟪B♯ v, v⟫_ℝ := (continuous_linear_map_of_bilin_apply ℝ B v v).symm
      _ ≤ ‖B♯ v‖ * ‖v‖ := real_inner_le_norm (B♯ v) v

  · have : v = 0 := by simpa using h
    simp [this]
#align is_coercive.bounded_below IsCoercive.bounded_below

theorem antilipschitz (coercive : IsCoercive B) : ∃ C : ℝ≥0, 0 < C ∧ AntilipschitzWith C B♯ :=
  by
  rcases coercive.bounded_below with ⟨C, C_pos, below_bound⟩
  refine' ⟨C⁻¹.toNNReal, real.to_nnreal_pos.mpr (inv_pos.mpr C_pos), _⟩
  refine' ContinuousLinearMap.antilipschitz_of_bound B♯ _
  simp_rw [Real.coe_toNNReal', max_eq_left_of_lt (inv_pos.mpr C_pos), ←
    inv_mul_le_iff (inv_pos.mpr C_pos)]
  simpa using below_bound
#align is_coercive.antilipschitz IsCoercive.antilipschitz

theorem ker_eq_bot (coercive : IsCoercive B) : ker B♯ = ⊥ :=
  by
  rw [LinearMapClass.ker_eq_bot]
  rcases coercive.antilipschitz with ⟨_, _, antilipschitz⟩
  exact antilipschitz.injective
#align is_coercive.ker_eq_bot IsCoercive.ker_eq_bot

theorem closed_range (coercive : IsCoercive B) : IsClosed (range B♯ : Set V) :=
  by
  rcases coercive.antilipschitz with ⟨_, _, antilipschitz⟩
  exact antilipschitz.is_closed_range B♯.UniformContinuous
#align is_coercive.closed_range IsCoercive.closed_range

theorem range_eq_top (coercive : IsCoercive B) : range B♯ = ⊤ :=
  by
  haveI := coercive.closed_range.complete_space_coe
  rw [← (range B♯).orthogonal_orthogonal]
  rw [Submodule.eq_top_iff']
  intro v w mem_w_orthogonal
  rcases coercive with ⟨C, C_pos, coercivity⟩
  obtain rfl : w = 0 :=
    by
    rw [← norm_eq_zero, ← mul_self_eq_zero, ← mul_right_inj' C_pos.ne', MulZeroClass.mul_zero, ←
      mul_assoc]
    apply le_antisymm
    ·
      calc
        C * ‖w‖ * ‖w‖ ≤ B w w := coercivity w
        _ = ⟪B♯ w, w⟫_ℝ := (continuous_linear_map_of_bilin_apply ℝ B w w).symm
        _ = 0 := mem_w_orthogonal _ ⟨w, rfl⟩

    · exact mul_nonneg (mul_nonneg C_pos.le (norm_nonneg w)) (norm_nonneg w)
  exact inner_zero_left _
#align is_coercive.range_eq_top IsCoercive.range_eq_top

/-- The Lax-Milgram equivalence of a coercive bounded bilinear operator:
for all `v : V`, `continuous_linear_equiv_of_bilin B v` is the unique element `V`
such that `⟪continuous_linear_equiv_of_bilin B v, w⟫ = B v w`.
The Lax-Milgram theorem states that this is a continuous equivalence.
-/
def continuousLinearEquivOfBilin (coercive : IsCoercive B) : V ≃L[ℝ] V :=
  ContinuousLinearEquiv.ofBijective B♯ coercive.ker_eq_bot coercive.range_eq_top
#align is_coercive.continuous_linear_equiv_of_bilin IsCoercive.continuousLinearEquivOfBilin

@[simp]
theorem continuousLinearEquivOfBilin_apply (coercive : IsCoercive B) (v w : V) :
    ⟪coercive.continuousLinearEquivOfBilin v, w⟫_ℝ = B v w :=
  continuousLinearMapOfBilin_apply ℝ B v w
#align is_coercive.continuous_linear_equiv_of_bilin_apply IsCoercive.continuousLinearEquivOfBilin_apply

theorem unique_continuousLinearEquivOfBilin (coercive : IsCoercive B) {v f : V}
    (is_lax_milgram : ∀ w, ⟪f, w⟫_ℝ = B v w) : f = coercive.continuousLinearEquivOfBilin v :=
  unique_continuousLinearMapOfBilin ℝ B is_lax_milgram
#align is_coercive.unique_continuous_linear_equiv_of_bilin IsCoercive.unique_continuousLinearEquivOfBilin

end IsCoercive


instance : Trans (α := Nat) (β := Nat) (γ := Nat) (.≤.) (.≤.) (.≤.) where
  trans := Nat.le_trans

instance : Trans (α := Int) (β := Int) (γ := Int) (.≤.) (.≤.) (.≤.) where
  trans := sorry

theorem ex1 {a b c d : Nat} (h1 : a ≤ b) (h2 : b ≤ c) (h3 : c ≤ d) : a ≤ d :=
  trans h1 <| trans h2 h3

theorem ex2 {a b c d : Int} (h1 : a ≤ b) (h2 : b ≤ c) (h3 : c ≤ d) : a ≤ d :=
  trans h1 <| trans h2 h3


import data.real.basic

variables {a b : ℝ}

-- 1ª demostración
-- ===============

example
  (h : b ≠ 0)
  : a = b * (a / b) :=
(mul_div_cancel' _ h).symm

-- 2ª demostración
-- ===============

example : b ≠ 0 → a = b * (a / b) :=
begin
  intro h,
  field_simp [h],
  ring,
end


import mini_crush.nano_crush
/- "Proving in the Large" chapter of CPDT -/

inductive exp : Type
| Const (n : nat) : exp
| Plus (e1 e2 : exp) : exp
| Mult (e1 e2 : exp) : exp

open exp

def eeval : exp → nat
| (Const n)    := n
| (Plus e1 e2) := eeval e1 + eeval e2
| (Mult e1 e2) := eeval e1 * eeval e2

def times (k : nat) : exp → exp
| (Const n)    := Const (k * n)
| (Plus e1 e2) := Plus (times e1) (times e2)
| (Mult e1 e2) := Mult (times e1) e2

def reassoc : exp → exp
| (Const n)    := (Const n)
| (Plus e1 e2) :=
  let e1' := reassoc e1 in
  let e2' := reassoc e2 in
  match e2' with
  | (Plus e21 e22) := Plus (Plus e1' e21) e22
  | _              := Plus e1' e2'
  end
| (Mult e1 e2) :=
  let e1' := reassoc e1 in
  let e2' := reassoc e2 in
  match e2' with
  | (Mult e21 e22) := Mult (Mult e1' e21) e22
  | _              := Mult e1' e2'
  end

attribute [simp] mul_add

theorem eeval_times (k e) : eeval (times k e) = k * eeval e :=
by nano_crush 0

theorem reassoc_correct (e) : eeval (reassoc e) = eeval e :=
by nano_crush 1


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Patrick Massot
-/
import algebra.ring.pi
import algebra.big_operators.basic
import data.fintype.basic
import algebra.group.prod
/-!
# Big operators for Pi Types

This file contains theorems relevant to big operators in binary and arbitrary product
of monoids and groups
-/

open_locale big_operators

namespace pi

@[to_additive]
lemma list_prod_apply {α : Type*} {β : α → Type*} [Πa, monoid (β a)] (a : α) (l : list (Πa, β a)) :
  l.prod a = (l.map (λf:Πa, β a, f a)).prod :=
(monoid_hom.apply β a).map_list_prod _

@[to_additive]
lemma multiset_prod_apply {α : Type*} {β : α → Type*} [∀a, comm_monoid (β a)] (a : α)
  (s : multiset (Πa, β a)) : s.prod a = (s.map (λf:Πa, β a, f a)).prod :=
(monoid_hom.apply β a).map_multiset_prod _

end pi

@[simp, to_additive]
lemma finset.prod_apply {α : Type*} {β : α → Type*} {γ} [∀a, comm_monoid (β a)] (a : α)
  (s : finset γ) (g : γ → Πa, β a) : (∏ c in s, g c) a = ∏ c in s, g c a :=
(monoid_hom.apply β a).map_prod _ _

/-- An 'unapplied' analogue of `finset.prod_apply`. -/
@[to_additive "An 'unapplied' analogue of `finset.sum_apply`."]
lemma finset.prod_fn {α : Type*} {β : α → Type*} {γ} [∀a, comm_monoid (β a)]
  (s : finset γ) (g : γ → Πa, β a) : (∏ c in s, g c) = (λ a, ∏ c in s, g c a) :=
funext (λ a, finset.prod_apply _ _ _)

@[simp, to_additive]
lemma fintype.prod_apply {α : Type*} {β : α → Type*} {γ : Type*} [fintype γ]
  [∀a, comm_monoid (β a)] (a : α) (g : γ → Πa, β a) : (∏ c, g c) a = ∏ c, g c a :=
finset.prod_apply a finset.univ g

@[to_additive prod_mk_sum]
lemma prod_mk_prod {α β γ : Type*} [comm_monoid α] [comm_monoid β] (s : finset γ)
  (f : γ → α) (g : γ → β) : (∏ x in s, f x, ∏ x in s, g x) = ∏ x in s, (f x, g x) :=
by haveI := classical.dec_eq γ; exact
finset.induction_on s rfl (by simp [prod.ext_iff] {contextual := tt})

section single
variables {I : Type*} [decidable_eq I] {Z : I → Type*}
variables [Π i, add_comm_monoid (Z i)]

-- As we only defined `single` into `add_monoid`, we only prove the `finset.sum` version here.
lemma finset.univ_sum_single [fintype I] (f : Π i, Z i) :
  ∑ i, pi.single i (f i) = f :=
by { ext a, simp }

lemma add_monoid_hom.functions_ext [fintype I] (G : Type*)
  [add_comm_monoid G] (g h : (Π i, Z i) →+ G)
  (w : ∀ (i : I) (x : Z i), g (pi.single i x) = h (pi.single i x)) : g = h :=
begin
  ext k,
  rw [← finset.univ_sum_single k, g.map_sum, h.map_sum],
  simp only [w]
end

/-- This is used as the ext lemma instead of `add_monoid_hom.functions_ext` for reasons explained in
note [partially-applied ext lemmas]. -/
@[ext]
lemma add_monoid_hom.functions_ext' [fintype I] (M : Type*) [add_comm_monoid M]
  (g h : (Π i, Z i) →+ M)
  (H : ∀ i, g.comp (add_monoid_hom.single Z i) = h.comp (add_monoid_hom.single Z i)) :
  g = h :=
have _ := λ i, add_monoid_hom.congr_fun (H i), -- elab without an expected type
g.functions_ext M h this

end single

section ring_hom
open pi
variables {I : Type*} [decidable_eq I] {f : I → Type*}
variables [Π i, semiring (f i)]

@[ext] lemma ring_hom.functions_ext [fintype I] (G : Type*) [semiring G] (g h : (Π i, f i) →+* G)
  (w : ∀ (i : I) (x : f i), g (single i x) = h (single i x)) : g = h :=
ring_hom.coe_add_monoid_hom_injective $
 add_monoid_hom.functions_ext G (g : (Π i, f i) →+ G) h w

end ring_hom

namespace prod

variables {α β γ : Type*} [comm_monoid α] [comm_monoid β] {s : finset γ} {f : γ → α × β}

@[to_additive]
lemma fst_prod : (∏ c in s, f c).1 = ∏ c in s, (f c).1 :=
(monoid_hom.fst α β).map_prod f s

@[to_additive]
lemma snd_prod  : (∏ c in s, f c).2 = ∏ c in s, (f c).2 :=
(monoid_hom.snd α β).map_prod f s

end prod


/-
Copyright (c) 2022 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel

! This file was ported from Lean 3 source module probability.ident_distrib
! leanprover-community/mathlib commit f2ce6086713c78a7f880485f7917ea547a215982
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Probability.Variance
import Mathbin.MeasureTheory.Function.UniformIntegrable

/-!
# Identically distributed random variables

Two random variables defined on two (possibly different) probability spaces but taking value in
the same space are *identically distributed* if their distributions (i.e., the image probability
measures on the target space) coincide. We define this concept and establish its basic properties
in this file.

## Main definitions and results

* `ident_distrib f g μ ν` registers that the image of `μ` under `f` coincides with the image of `ν`
  under `g` (and that `f` and `g` are almost everywhere measurable, as otherwise the image measures
  don't make sense). The measures can be kept implicit as in `ident_distrib f g` if the spaces
  are registered as measure spaces.
* `ident_distrib.comp`: being identically distributed is stable under composition with measurable
  maps.

There are two main kind of lemmas, under the assumption that `f` and `g` are identically
distributed: lemmas saying that two quantities computed for `f` and `g` are the same, and lemmas
saying that if `f` has some property then `g` also has it. The first kind is registered as
`ident_distrib.foo_eq`, the second one as `ident_distrib.foo_snd` (in the latter case, to deduce
a property of `f` from one of `g`, use `h.symm.foo_snd` where `h : ident_distrib f g μ ν`). For
instance:

* `ident_distrib.measure_mem_eq`: if `f` and `g` are identically distributed, then the probabilities
  that they belong to a given measurable set are the same.
* `ident_distrib.integral_eq`: if `f` and `g` are identically distributed, then their integrals
  are the same.
* `ident_distrib.variance_eq`: if `f` and `g` are identically distributed, then their variances
  are the same.

* `ident_distrib.ae_strongly_measurable_snd`: if `f` and `g` are identically distributed and `f`
  is almost everywhere strongly measurable, then so is `g`.
* `ident_distrib.mem_ℒp_snd`: if `f` and `g` are identically distributed and `f`
  belongs to `ℒp`, then so does `g`.

We also register several dot notation shortcuts for convenience.
For instance, if `h : ident_distrib f g μ ν`, then `h.sq` states that `f^2` and `g^2` are
identically distributed, and `h.norm` states that `‖f‖` and `‖g‖` are identically distributed, and
so on.
-/

open MeasureTheory Filter Finset

noncomputable section

open Topology BigOperators MeasureTheory ENNReal NNReal

variable {α β γ δ : Type _} [MeasurableSpace α] [MeasurableSpace β] [MeasurableSpace γ]
  [MeasurableSpace δ]

namespace ProbabilityTheory

/-- Two functions defined on two (possibly different) measure spaces are identically distributed if
their image measures coincide. This only makes sense when the functions are ae measurable
(as otherwise the image measures are not defined), so we require this as well in the definition. -/
structure IdentDistrib (f : α → γ) (g : β → γ)
  (μ : Measure α := by exact MeasureTheory.MeasureSpace.volume)
  (ν : Measure β := by exact MeasureTheory.MeasureSpace.volume) : Prop where
  aeMeasurableFst : AeMeasurable f μ
  aeMeasurableSnd : AeMeasurable g ν
  map_eq : Measure.map f μ = Measure.map g ν
#align probability_theory.ident_distrib ProbabilityTheory.IdentDistrib

namespace IdentDistrib

open TopologicalSpace

variable {μ : Measure α} {ν : Measure β} {f : α → γ} {g : β → γ}

protected theorem refl (hf : AeMeasurable f μ) : IdentDistrib f f μ μ :=
  { aeMeasurableFst := hf
    aeMeasurableSnd := hf
    map_eq := rfl }
#align probability_theory.ident_distrib.refl ProbabilityTheory.IdentDistrib.refl

protected theorem symm (h : IdentDistrib f g μ ν) : IdentDistrib g f ν μ :=
  { aeMeasurableFst := h.aeMeasurableSnd
    aeMeasurableSnd := h.aeMeasurableFst
    map_eq := h.map_eq.symm }
#align probability_theory.ident_distrib.symm ProbabilityTheory.IdentDistrib.symm

protected theorem trans {ρ : Measure δ} {h : δ → γ} (h₁ : IdentDistrib f g μ ν)
    (h₂ : IdentDistrib g h ν ρ) : IdentDistrib f h μ ρ :=
  { aeMeasurableFst := h₁.aeMeasurableFst
    aeMeasurableSnd := h₂.aeMeasurableSnd
    map_eq := h₁.map_eq.trans h₂.map_eq }
#align probability_theory.ident_distrib.trans ProbabilityTheory.IdentDistrib.trans

protected theorem compOfAeMeasurable {u : γ → δ} (h : IdentDistrib f g μ ν)
    (hu : AeMeasurable u (Measure.map f μ)) : IdentDistrib (u ∘ f) (u ∘ g) μ ν :=
  { aeMeasurableFst := hu.compAeMeasurable h.aeMeasurableFst
    aeMeasurableSnd := by
      rw [h.map_eq] at hu
      exact hu.comp_ae_measurable h.ae_measurable_snd
    map_eq :=
      by
      rw [← AeMeasurable.map_map_of_aeMeasurable hu h.ae_measurable_fst, ←
        AeMeasurable.map_map_of_aeMeasurable _ h.ae_measurable_snd, h.map_eq]
      rwa [← h.map_eq] }
#align probability_theory.ident_distrib.comp_of_ae_measurable ProbabilityTheory.IdentDistrib.compOfAeMeasurable

protected theorem comp {u : γ → δ} (h : IdentDistrib f g μ ν) (hu : Measurable u) :
    IdentDistrib (u ∘ f) (u ∘ g) μ ν :=
  h.compOfAeMeasurable hu.AeMeasurable
#align probability_theory.ident_distrib.comp ProbabilityTheory.IdentDistrib.comp

protected theorem ofAeEq {g : α → γ} (hf : AeMeasurable f μ) (heq : f =ᵐ[μ] g) :
    IdentDistrib f g μ μ :=
  { aeMeasurableFst := hf
    aeMeasurableSnd := hf.congr HEq
    map_eq := Measure.map_congr HEq }
#align probability_theory.ident_distrib.of_ae_eq ProbabilityTheory.IdentDistrib.ofAeEq

theorem measure_mem_eq (h : IdentDistrib f g μ ν) {s : Set γ} (hs : MeasurableSet s) :
    μ (f ⁻¹' s) = ν (g ⁻¹' s) := by
  rw [← measure.map_apply_of_ae_measurable h.ae_measurable_fst hs, ←
    measure.map_apply_of_ae_measurable h.ae_measurable_snd hs, h.map_eq]
#align probability_theory.ident_distrib.measure_mem_eq ProbabilityTheory.IdentDistrib.measure_mem_eq

alias measure_mem_eq ← measure_preimage_eq
#align probability_theory.ident_distrib.measure_preimage_eq ProbabilityTheory.IdentDistrib.measure_preimage_eq

theorem ae_snd (h : IdentDistrib f g μ ν) {p : γ → Prop} (pmeas : MeasurableSet { x | p x })
    (hp : ∀ᵐ x ∂μ, p (f x)) : ∀ᵐ x ∂ν, p (g x) :=
  by
  apply (ae_map_iff h.ae_measurable_snd pmeas).1
  rw [← h.map_eq]
  exact (ae_map_iff h.ae_measurable_fst pmeas).2 hp
#align probability_theory.ident_distrib.ae_snd ProbabilityTheory.IdentDistrib.ae_snd

theorem ae_mem_snd (h : IdentDistrib f g μ ν) {t : Set γ} (tmeas : MeasurableSet t)
    (ht : ∀ᵐ x ∂μ, f x ∈ t) : ∀ᵐ x ∂ν, g x ∈ t :=
  h.ae_snd tmeas ht
#align probability_theory.ident_distrib.ae_mem_snd ProbabilityTheory.IdentDistrib.ae_mem_snd

/-- In a second countable topology, the first function in an identically distributed pair is a.e.
strongly measurable. So is the second function, but use `h.symm.ae_strongly_measurable_fst` as
`h.ae_strongly_measurable_snd` has a different meaning.-/
theorem aeStronglyMeasurableFst [TopologicalSpace γ] [MetrizableSpace γ] [OpensMeasurableSpace γ]
    [SecondCountableTopology γ] (h : IdentDistrib f g μ ν) : AeStronglyMeasurable f μ :=
  h.aeMeasurableFst.AeStronglyMeasurable
#align probability_theory.ident_distrib.ae_strongly_measurable_fst ProbabilityTheory.IdentDistrib.aeStronglyMeasurableFst

/-- If `f` and `g` are identically distributed and `f` is a.e. strongly measurable, so is `g`. -/
theorem aeStronglyMeasurableSnd [TopologicalSpace γ] [MetrizableSpace γ] [BorelSpace γ]
    (h : IdentDistrib f g μ ν) (hf : AeStronglyMeasurable f μ) : AeStronglyMeasurable g ν :=
  by
  refine' aeStronglyMeasurable_iff_aeMeasurable_separable.2 ⟨h.ae_measurable_snd, _⟩
  rcases(aeStronglyMeasurable_iff_aeMeasurable_separable.1 hf).2 with ⟨t, t_sep, ht⟩
  refine' ⟨closure t, t_sep.closure, _⟩
  apply h.ae_mem_snd is_closed_closure.measurable_set
  filter_upwards [ht]with x hx using subset_closure hx
#align probability_theory.ident_distrib.ae_strongly_measurable_snd ProbabilityTheory.IdentDistrib.aeStronglyMeasurableSnd

theorem aeStronglyMeasurable_iff [TopologicalSpace γ] [MetrizableSpace γ] [BorelSpace γ]
    (h : IdentDistrib f g μ ν) : AeStronglyMeasurable f μ ↔ AeStronglyMeasurable g ν :=
  ⟨fun hf => h.aeStronglyMeasurableSnd hf, fun hg => h.symm.aeStronglyMeasurableSnd hg⟩
#align probability_theory.ident_distrib.ae_strongly_measurable_iff ProbabilityTheory.IdentDistrib.aeStronglyMeasurable_iff

theorem essSup_eq [ConditionallyCompleteLinearOrder γ] [TopologicalSpace γ] [OpensMeasurableSpace γ]
    [OrderClosedTopology γ] (h : IdentDistrib f g μ ν) : essSup f μ = essSup g ν :=
  by
  have I : ∀ a, μ { x : α | a < f x } = ν { x : β | a < g x } := fun a =>
    h.measure_mem_eq measurableSet_Ioi
  simp_rw [essSup_eq_infₛ, I]
#align probability_theory.ident_distrib.ess_sup_eq ProbabilityTheory.IdentDistrib.essSup_eq

theorem lintegral_eq {f : α → ℝ≥0∞} {g : β → ℝ≥0∞} (h : IdentDistrib f g μ ν) :
    (∫⁻ x, f x ∂μ) = ∫⁻ x, g x ∂ν :=
  by
  change (∫⁻ x, id (f x) ∂μ) = ∫⁻ x, id (g x) ∂ν
  rw [← lintegral_map' aeMeasurableId h.ae_measurable_fst, ←
    lintegral_map' aeMeasurableId h.ae_measurable_snd, h.map_eq]
#align probability_theory.ident_distrib.lintegral_eq ProbabilityTheory.IdentDistrib.lintegral_eq

theorem integral_eq [NormedAddCommGroup γ] [NormedSpace ℝ γ] [CompleteSpace γ] [BorelSpace γ]
    (h : IdentDistrib f g μ ν) : (∫ x, f x ∂μ) = ∫ x, g x ∂ν :=
  by
  by_cases hf : ae_strongly_measurable f μ
  · have A : ae_strongly_measurable id (measure.map f μ) :=
      by
      rw [aeStronglyMeasurable_iff_aeMeasurable_separable]
      rcases(aeStronglyMeasurable_iff_aeMeasurable_separable.1 hf).2 with ⟨t, t_sep, ht⟩
      refine' ⟨aeMeasurableId, ⟨closure t, t_sep.closure, _⟩⟩
      rw [ae_map_iff h.ae_measurable_fst]
      · filter_upwards [ht]with x hx using subset_closure hx
      · exact is_closed_closure.measurable_set
    change (∫ x, id (f x) ∂μ) = ∫ x, id (g x) ∂ν
    rw [← integral_map h.ae_measurable_fst A]
    rw [h.map_eq] at A
    rw [← integral_map h.ae_measurable_snd A, h.map_eq]
  · rw [integral_non_ae_strongly_measurable hf]
    rw [h.ae_strongly_measurable_iff] at hf
    rw [integral_non_ae_strongly_measurable hf]
#align probability_theory.ident_distrib.integral_eq ProbabilityTheory.IdentDistrib.integral_eq

theorem snorm_eq [NormedAddCommGroup γ] [OpensMeasurableSpace γ] (h : IdentDistrib f g μ ν)
    (p : ℝ≥0∞) : snorm f p μ = snorm g p ν :=
  by
  by_cases h0 : p = 0
  · simp [h0]
  by_cases h_top : p = ∞
  · simp only [h_top, snorm, snorm_ess_sup, ENNReal.top_ne_zero, eq_self_iff_true, if_true,
      if_false]
    apply ess_sup_eq
    exact h.comp (measurable_coe_nnreal_ennreal.comp measurable_nnnorm)
  simp only [snorm_eq_snorm' h0 h_top, snorm', one_div]
  congr 1
  apply lintegral_eq
  exact
    h.comp (Measurable.pow_const (measurable_coe_nnreal_ennreal.comp measurable_nnnorm) p.to_real)
#align probability_theory.ident_distrib.snorm_eq ProbabilityTheory.IdentDistrib.snorm_eq

theorem memℒpSnd [NormedAddCommGroup γ] [BorelSpace γ] {p : ℝ≥0∞} (h : IdentDistrib f g μ ν)
    (hf : Memℒp f p μ) : Memℒp g p ν :=
  by
  refine' ⟨h.ae_strongly_measurable_snd hf.ae_strongly_measurable, _⟩
  rw [← h.snorm_eq]
  exact hf.2
#align probability_theory.ident_distrib.mem_ℒp_snd ProbabilityTheory.IdentDistrib.memℒpSnd

theorem memℒp_iff [NormedAddCommGroup γ] [BorelSpace γ] {p : ℝ≥0∞} (h : IdentDistrib f g μ ν) :
    Memℒp f p μ ↔ Memℒp g p ν :=
  ⟨fun hf => h.memℒpSnd hf, fun hg => h.symm.memℒpSnd hg⟩
#align probability_theory.ident_distrib.mem_ℒp_iff ProbabilityTheory.IdentDistrib.memℒp_iff

theorem integrableSnd [NormedAddCommGroup γ] [BorelSpace γ] (h : IdentDistrib f g μ ν)
    (hf : Integrable f μ) : Integrable g ν :=
  by
  rw [← mem_ℒp_one_iff_integrable] at hf⊢
  exact h.mem_ℒp_snd hf
#align probability_theory.ident_distrib.integrable_snd ProbabilityTheory.IdentDistrib.integrableSnd

theorem integrable_iff [NormedAddCommGroup γ] [BorelSpace γ] (h : IdentDistrib f g μ ν) :
    Integrable f μ ↔ Integrable g ν :=
  ⟨fun hf => h.integrableSnd hf, fun hg => h.symm.integrableSnd hg⟩
#align probability_theory.ident_distrib.integrable_iff ProbabilityTheory.IdentDistrib.integrable_iff

protected theorem norm [NormedAddCommGroup γ] [BorelSpace γ] (h : IdentDistrib f g μ ν) :
    IdentDistrib (fun x => ‖f x‖) (fun x => ‖g x‖) μ ν :=
  h.comp measurable_norm
#align probability_theory.ident_distrib.norm ProbabilityTheory.IdentDistrib.norm

protected theorem nnnorm [NormedAddCommGroup γ] [BorelSpace γ] (h : IdentDistrib f g μ ν) :
    IdentDistrib (fun x => ‖f x‖₊) (fun x => ‖g x‖₊) μ ν :=
  h.comp measurable_nnnorm
#align probability_theory.ident_distrib.nnnorm ProbabilityTheory.IdentDistrib.nnnorm

protected theorem pow [Pow γ ℕ] [HasMeasurablePow γ ℕ] (h : IdentDistrib f g μ ν) {n : ℕ} :
    IdentDistrib (fun x => f x ^ n) (fun x => g x ^ n) μ ν :=
  h.comp (measurable_id.pow_const n)
#align probability_theory.ident_distrib.pow ProbabilityTheory.IdentDistrib.pow

protected theorem sq [Pow γ ℕ] [HasMeasurablePow γ ℕ] (h : IdentDistrib f g μ ν) :
    IdentDistrib (fun x => f x ^ 2) (fun x => g x ^ 2) μ ν :=
  h.comp (measurable_id.pow_const 2)
#align probability_theory.ident_distrib.sq ProbabilityTheory.IdentDistrib.sq

protected theorem coeNnrealEnnreal {f : α → ℝ≥0} {g : β → ℝ≥0} (h : IdentDistrib f g μ ν) :
    IdentDistrib (fun x => (f x : ℝ≥0∞)) (fun x => (g x : ℝ≥0∞)) μ ν :=
  h.comp measurable_coe_nNReal_eNNReal
#align probability_theory.ident_distrib.coe_nnreal_ennreal ProbabilityTheory.IdentDistrib.coeNnrealEnnreal

@[to_additive]
theorem mulConst [Mul γ] [HasMeasurableMul γ] (h : IdentDistrib f g μ ν) (c : γ) :
    IdentDistrib (fun x => f x * c) (fun x => g x * c) μ ν :=
  h.comp (measurable_mul_const c)
#align probability_theory.ident_distrib.mul_const ProbabilityTheory.IdentDistrib.mulConst
#align probability_theory.ident_distrib.add_const ProbabilityTheory.IdentDistrib.add_const

@[to_additive]
theorem constMul [Mul γ] [HasMeasurableMul γ] (h : IdentDistrib f g μ ν) (c : γ) :
    IdentDistrib (fun x => c * f x) (fun x => c * g x) μ ν :=
  h.comp (measurable_const_mul c)
#align probability_theory.ident_distrib.const_mul ProbabilityTheory.IdentDistrib.constMul
#align probability_theory.ident_distrib.const_add ProbabilityTheory.IdentDistrib.const_add

@[to_additive]
theorem divConst [Div γ] [HasMeasurableDiv γ] (h : IdentDistrib f g μ ν) (c : γ) :
    IdentDistrib (fun x => f x / c) (fun x => g x / c) μ ν :=
  h.comp (HasMeasurableDiv.measurable_div_const c)
#align probability_theory.ident_distrib.div_const ProbabilityTheory.IdentDistrib.divConst
#align probability_theory.ident_distrib.sub_const ProbabilityTheory.IdentDistrib.sub_const

@[to_additive]
theorem constDiv [Div γ] [HasMeasurableDiv γ] (h : IdentDistrib f g μ ν) (c : γ) :
    IdentDistrib (fun x => c / f x) (fun x => c / g x) μ ν :=
  h.comp (HasMeasurableDiv.measurable_const_div c)
#align probability_theory.ident_distrib.const_div ProbabilityTheory.IdentDistrib.constDiv
#align probability_theory.ident_distrib.const_sub ProbabilityTheory.IdentDistrib.const_sub

theorem evariance_eq {f : α → ℝ} {g : β → ℝ} (h : IdentDistrib f g μ ν) :
    evariance f μ = evariance g ν :=
  by
  convert(h.sub_const (∫ x, f x ∂μ)).nnnorm.coe_nNReal_eNNReal.sq.lintegral_eq
  rw [h.integral_eq]
  rfl
#align probability_theory.ident_distrib.evariance_eq ProbabilityTheory.IdentDistrib.evariance_eq

theorem variance_eq {f : α → ℝ} {g : β → ℝ} (h : IdentDistrib f g μ ν) :
    variance f μ = variance g ν := by
  rw [variance, h.evariance_eq]
  rfl
#align probability_theory.ident_distrib.variance_eq ProbabilityTheory.IdentDistrib.variance_eq

end IdentDistrib

section UniformIntegrable

open TopologicalSpace

variable {E : Type _} [MeasurableSpace E] [NormedAddCommGroup E] [BorelSpace E]
  [SecondCountableTopology E] {μ : Measure α} [IsFiniteMeasure μ]

/-- This lemma is superceded by `mem_ℒp.uniform_integrable_of_ident_distrib` which only require
`ae_strongly_measurable`. -/
theorem Memℒp.uniformIntegrableOfIdentDistribAux {ι : Type _} {f : ι → α → E} {j : ι} {p : ℝ≥0∞}
    (hp : 1 ≤ p) (hp' : p ≠ ∞) (hℒp : Memℒp (f j) p μ) (hfmeas : ∀ i, StronglyMeasurable (f i))
    (hf : ∀ i, IdentDistrib (f i) (f j) μ μ) : UniformIntegrable f p μ :=
  by
  refine' uniform_integrable_of' hp hp' hfmeas fun ε hε => _
  by_cases hι : Nonempty ι
  swap
  · exact ⟨0, fun i => False.elim (hι <| Nonempty.intro i)⟩
  obtain ⟨C, hC₁, hC₂⟩ := hℒp.snorm_indicator_norm_ge_pos_le μ (hfmeas _) hε
  have hmeas : ∀ i, MeasurableSet { x | (⟨C, hC₁.le⟩ : ℝ≥0) ≤ ‖f i x‖₊ } := fun i =>
    measurableSet_le measurable_const (hfmeas _).Measurable.nnnorm
  refine' ⟨⟨C, hC₁.le⟩, fun i => le_trans (le_of_eq _) hC₂⟩
  have :
    { x : α | (⟨C, hC₁.le⟩ : ℝ≥0) ≤ ‖f i x‖₊ }.indicator (f i) =
      (fun x : E => if (⟨C, hC₁.le⟩ : ℝ≥0) ≤ ‖x‖₊ then x else 0) ∘ f i :=
    by
    ext x
    simp only [Set.indicator, Set.mem_setOf_eq]
  simp_rw [coe_nnnorm, this]
  rw [← snorm_map_measure _ (hf i).aeMeasurableFst, (hf i).map_eq,
    snorm_map_measure _ (hf j).aeMeasurableFst]
  · rfl
  all_goals
    exact ae_strongly_measurable_id.indicator (measurableSet_le measurable_const measurable_nnnorm)
#align probability_theory.mem_ℒp.uniform_integrable_of_ident_distrib_aux ProbabilityTheory.Memℒp.uniformIntegrableOfIdentDistribAux

/-- A sequence of identically distributed Lᵖ functions is p-uniformly integrable. -/
theorem Memℒp.uniformIntegrableOfIdentDistrib {ι : Type _} {f : ι → α → E} {j : ι} {p : ℝ≥0∞}
    (hp : 1 ≤ p) (hp' : p ≠ ∞) (hℒp : Memℒp (f j) p μ) (hf : ∀ i, IdentDistrib (f i) (f j) μ μ) :
    UniformIntegrable f p μ :=
  by
  have hfmeas : ∀ i, ae_strongly_measurable (f i) μ := fun i =>
    (hf i).aeStronglyMeasurable_iff.2 hℒp.1
  set g : ι → α → E := fun i => (hfmeas i).some
  have hgmeas : ∀ i, strongly_measurable (g i) := fun i => (Exists.choose_spec <| hfmeas i).1
  have hgeq : ∀ i, g i =ᵐ[μ] f i := fun i => (Exists.choose_spec <| hfmeas i).2.symm
  have hgℒp : mem_ℒp (g j) p μ := hℒp.ae_eq (hgeq j).symm
  exact
    uniform_integrable.ae_eq
      (mem_ℒp.uniform_integrable_of_ident_distrib_aux hp hp' hgℒp hgmeas fun i =>
        (ident_distrib.of_ae_eq (hgmeas i).AeMeasurable (hgeq i)).trans
          ((hf i).trans <| ident_distrib.of_ae_eq (hfmeas j).AeMeasurable (hgeq j).symm))
      hgeq
#align probability_theory.mem_ℒp.uniform_integrable_of_ident_distrib ProbabilityTheory.Memℒp.uniformIntegrableOfIdentDistrib

end UniformIntegrable

end ProbabilityTheory


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro
-/
import topology.metric_space.basic
import topology.algebra.uniform_group
import topology.algebra.ring
import ring_theory.subring
import group_theory.archimedean
/-!
# Topological properties of ℝ
-/

noncomputable theory
open classical set filter topological_space metric
open_locale classical
open_locale topological_space

universes u v w
variables {α : Type u} {β : Type v} {γ : Type w}

instance : metric_space ℚ :=
metric_space.induced coe rat.cast_injective real.metric_space

theorem rat.dist_eq (x y : ℚ) : dist x y = abs (x - y) := rfl

@[norm_cast, simp] lemma rat.dist_cast (x y : ℚ) : dist (x : ℝ) y = dist x y := rfl

section low_prio
-- we want to ignore this instance for the next declaration
local attribute [instance, priority 10] int.uniform_space
instance : metric_space ℤ :=
begin
  letI M := metric_space.induced coe int.cast_injective real.metric_space,
  refine @metric_space.replace_uniformity _ int.uniform_space M
    (le_antisymm refl_le_uniformity $ λ r ru,
      mem_uniformity_dist.2 ⟨1, zero_lt_one, λ a b h,
      mem_principal_sets.1 ru $ dist_le_zero.1 (_ : (abs (a - b) : ℝ) ≤ 0)⟩),
  have : (abs (↑a - ↑b) : ℝ) < 1 := h,
  have : abs (a - b) < 1, by norm_cast at this; assumption,
  have : abs (a - b) ≤ 0 := (@int.lt_add_one_iff _ 0).mp this,
  norm_cast, assumption
end
end low_prio

theorem int.dist_eq (x y : ℤ) : dist x y = abs (x - y) := rfl

@[norm_cast, simp] theorem int.dist_cast_real (x y : ℤ) : dist (x : ℝ) y = dist x y := rfl

@[norm_cast, simp] theorem int.dist_cast_rat (x y : ℤ) : dist (x : ℚ) y = dist x y :=
by rw [← int.dist_cast_real, ← rat.dist_cast]; congr' 1; norm_cast

instance : proper_space ℤ :=
⟨ begin
    intros x r,
    apply set.finite.is_compact,
    have : closed_ball x r = coe ⁻¹' (closed_ball (x:ℝ) r) := rfl,
    simp [this, closed_ball_Icc, set.Icc_ℤ_finite],
  end ⟩

theorem uniform_continuous_of_rat : uniform_continuous (coe : ℚ → ℝ) :=
uniform_continuous_comap

theorem uniform_embedding_of_rat : uniform_embedding (coe : ℚ → ℝ) :=
uniform_embedding_comap rat.cast_injective

theorem dense_embedding_of_rat : dense_embedding (coe : ℚ → ℝ) :=
uniform_embedding_of_rat.dense_embedding $
λ x, mem_closure_iff_nhds.2 $ λ t ht,
let ⟨ε,ε0, hε⟩ := mem_nhds_iff.1 ht in
let ⟨q, h⟩ := exists_rat_near x ε0 in
⟨_, hε (mem_ball'.2 h), q, rfl⟩

theorem embedding_of_rat : embedding (coe : ℚ → ℝ) := dense_embedding_of_rat.to_embedding

theorem continuous_of_rat : continuous (coe : ℚ → ℝ) := uniform_continuous_of_rat.continuous

theorem real.uniform_continuous_add : uniform_continuous (λp : ℝ × ℝ, p.1 + p.2) :=
metric.uniform_continuous_iff.2 $ λ ε ε0,
let ⟨δ, δ0, Hδ⟩ := rat_add_continuous_lemma abs ε0 in
⟨δ, δ0, λ a b h, let ⟨h₁, h₂⟩ := max_lt_iff.1 h in Hδ h₁ h₂⟩

-- TODO(Mario): Find a way to use rat_add_continuous_lemma
theorem rat.uniform_continuous_add : uniform_continuous (λp : ℚ × ℚ, p.1 + p.2) :=
uniform_embedding_of_rat.to_uniform_inducing.uniform_continuous_iff.2 $ by simp [(∘)]; exact
real.uniform_continuous_add.comp ((uniform_continuous_of_rat.comp uniform_continuous_fst).prod_mk
  (uniform_continuous_of_rat.comp uniform_continuous_snd))

theorem real.uniform_continuous_neg : uniform_continuous (@has_neg.neg ℝ _) :=
metric.uniform_continuous_iff.2 $ λ ε ε0, ⟨_, ε0, λ a b h,
  by rw dist_comm at h; simpa [real.dist_eq] using h⟩

theorem rat.uniform_continuous_neg : uniform_continuous (@has_neg.neg ℚ _) :=
metric.uniform_continuous_iff.2 $ λ ε ε0, ⟨_, ε0, λ a b h,
  by rw dist_comm at h; simpa [rat.dist_eq] using h⟩

instance : uniform_add_group ℝ :=
uniform_add_group.mk' real.uniform_continuous_add real.uniform_continuous_neg

instance : uniform_add_group ℚ :=
uniform_add_group.mk' rat.uniform_continuous_add rat.uniform_continuous_neg

 -- short-circuit type class inference
instance : topological_add_group ℝ := by apply_instance
instance : topological_add_group ℚ := by apply_instance

instance : order_topology ℚ :=
induced_order_topology _ (λ x y, rat.cast_lt) (@exists_rat_btwn _ _ _)

instance : proper_space ℝ :=
{ compact_ball := λx r, by { rw closed_ball_Icc, apply compact_Icc } }

instance : second_countable_topology ℝ := second_countable_of_proper

lemma real.is_topological_basis_Ioo_rat :
  @is_topological_basis ℝ _ (⋃(a b : ℚ) (h : a < b), {Ioo a b}) :=
is_topological_basis_of_open_of_nhds
  (by simp [is_open_Ioo] {contextual:=tt})
  (assume a v hav hv,
    let ⟨l, u, ⟨hl, hu⟩, h⟩ := mem_nhds_iff_exists_Ioo_subset.mp (mem_nhds_sets hv hav),
        ⟨q, hlq, hqa⟩ := exists_rat_btwn hl,
        ⟨p, hap, hpu⟩ := exists_rat_btwn hu in
    ⟨Ioo q p,
      by { simp only [mem_Union], exact ⟨q, p, rat.cast_lt.1 $ hqa.trans hap, rfl⟩ },
      ⟨hqa, hap⟩, assume a' ⟨hqa', ha'p⟩, h ⟨hlq.trans hqa', ha'p.trans hpu⟩⟩)

/- TODO(Mario): Prove that these are uniform isomorphisms instead of uniform embeddings
lemma uniform_embedding_add_rat {r : ℚ} : uniform_embedding (λp:ℚ, p + r) :=
_

lemma uniform_embedding_mul_rat {q : ℚ} (hq : q ≠ 0) : uniform_embedding ((*) q) :=
_ -/

lemma real.mem_closure_iff {s : set ℝ} {x : ℝ} :
  x ∈ closure s ↔ ∀ ε > 0, ∃ y ∈ s, abs (y - x) < ε :=
by simp [mem_closure_iff_nhds_basis nhds_basis_ball, real.dist_eq]

lemma real.uniform_continuous_inv (s : set ℝ) {r : ℝ} (r0 : 0 < r) (H : ∀ x ∈ s, r ≤ abs x) :
  uniform_continuous (λp:s, p.1⁻¹) :=
metric.uniform_continuous_iff.2 $ λ ε ε0,
let ⟨δ, δ0, Hδ⟩ := rat_inv_continuous_lemma abs ε0 r0 in
⟨δ, δ0, λ a b h, Hδ (H _ a.2) (H _ b.2) h⟩

lemma real.uniform_continuous_abs : uniform_continuous (abs : ℝ → ℝ) :=
metric.uniform_continuous_iff.2 $ λ ε ε0,
  ⟨ε, ε0, λ a b, lt_of_le_of_lt (abs_abs_sub_abs_le_abs_sub _ _)⟩

lemma rat.uniform_continuous_abs : uniform_continuous (abs : ℚ → ℚ) :=
metric.uniform_continuous_iff.2 $ λ ε ε0,
  ⟨ε, ε0, λ a b h, lt_of_le_of_lt
    (by simpa [rat.dist_eq] using abs_abs_sub_abs_le_abs_sub _ _) h⟩

lemma real.tendsto_inv {r : ℝ} (r0 : r ≠ 0) : tendsto (λq, q⁻¹) (𝓝 r) (𝓝 r⁻¹) :=
by rw ← abs_pos at r0; exact
tendsto_of_uniform_continuous_subtype
  (real.uniform_continuous_inv {x | abs r / 2 < abs x} (half_pos r0) (λ x h, le_of_lt h))
  (mem_nhds_sets ((is_open_lt' (abs r / 2)).preimage continuous_abs) (half_lt_self r0))

lemma real.continuous_inv : continuous (λa:{r:ℝ // r ≠ 0}, a.val⁻¹) :=
continuous_iff_continuous_at.mpr $ assume ⟨r, hr⟩,
  tendsto.comp (real.tendsto_inv hr) (continuous_iff_continuous_at.mp continuous_subtype_val _)

lemma real.continuous.inv [topological_space α] {f : α → ℝ} (h : ∀a, f a ≠ 0) (hf : continuous f) :
  continuous (λa, (f a)⁻¹) :=
show continuous ((has_inv.inv ∘ @subtype.val ℝ (λr, r ≠ 0)) ∘ λa, ⟨f a, h a⟩),
  from real.continuous_inv.comp (continuous_subtype_mk _ hf)

lemma real.uniform_continuous_mul_const {x : ℝ} : uniform_continuous ((*) x) :=
metric.uniform_continuous_iff.2 $ λ ε ε0, begin
  cases no_top (abs x) with y xy,
  have y0 := lt_of_le_of_lt (abs_nonneg _) xy,
  refine ⟨_, div_pos ε0 y0, λ a b h, _⟩,
  rw [real.dist_eq, ← mul_sub, abs_mul, ← mul_div_cancel' ε (ne_of_gt y0)],
  exact mul_lt_mul' (le_of_lt xy) h (abs_nonneg _) y0
end

lemma real.uniform_continuous_mul (s : set (ℝ × ℝ))
  {r₁ r₂ : ℝ} (H : ∀ x ∈ s, abs (x : ℝ × ℝ).1 < r₁ ∧ abs x.2 < r₂) :
  uniform_continuous (λp:s, p.1.1 * p.1.2) :=
metric.uniform_continuous_iff.2 $ λ ε ε0,
let ⟨δ, δ0, Hδ⟩ := rat_mul_continuous_lemma abs ε0 in
⟨δ, δ0, λ a b h,
  let ⟨h₁, h₂⟩ := max_lt_iff.1 h in Hδ (H _ a.2).1 (H _ b.2).2 h₁ h₂⟩

protected lemma real.continuous_mul : continuous (λp : ℝ × ℝ, p.1 * p.2) :=
continuous_iff_continuous_at.2 $ λ ⟨a₁, a₂⟩,
tendsto_of_uniform_continuous_subtype
  (real.uniform_continuous_mul
    ({x | abs x < abs a₁ + 1}.prod {x | abs x < abs a₂ + 1})
    (λ x, id))
  (mem_nhds_sets
    (((is_open_gt' (abs a₁ + 1)).preimage continuous_abs).prod
      ((is_open_gt' (abs a₂ + 1)).preimage continuous_abs ))
    ⟨lt_add_one (abs a₁), lt_add_one (abs a₂)⟩)

instance : topological_ring ℝ :=
{ continuous_mul := real.continuous_mul, ..real.topological_add_group }

instance : topological_semiring ℝ := by apply_instance  -- short-circuit type class inference

lemma rat.continuous_mul : continuous (λp : ℚ × ℚ, p.1 * p.2) :=
embedding_of_rat.continuous_iff.2 $ by simp [(∘)]; exact
real.continuous_mul.comp ((continuous_of_rat.comp continuous_fst).prod_mk
  (continuous_of_rat.comp continuous_snd))

instance : topological_ring ℚ :=
{ continuous_mul := rat.continuous_mul, ..rat.topological_add_group }

theorem real.ball_eq_Ioo (x ε : ℝ) : ball x ε = Ioo (x - ε) (x + ε) :=
set.ext $ λ y, by rw [mem_ball, real.dist_eq,
  abs_sub_lt_iff, sub_lt_iff_lt_add', and_comm, sub_lt]; refl

theorem real.Ioo_eq_ball (x y : ℝ) : Ioo x y = ball ((x + y) / 2) ((y - x) / 2) :=
by rw [real.ball_eq_Ioo, ← sub_div, add_comm, ← sub_add,
  add_sub_cancel', add_self_div_two, ← add_div,
  add_assoc, add_sub_cancel'_right, add_self_div_two]

instance : complete_space ℝ :=
begin
  apply complete_of_cauchy_seq_tendsto,
  intros u hu,
  let c : cau_seq ℝ abs := ⟨u, cauchy_seq_iff'.1 hu⟩,
  refine ⟨c.lim, λ s h, _⟩,
  rcases metric.mem_nhds_iff.1 h with ⟨ε, ε0, hε⟩,
  have := c.equiv_lim ε ε0,
  simp only [mem_map, mem_at_top_sets, mem_set_of_eq],
  refine this.imp (λ N hN n hn, hε (hN n hn))
end

lemma real.totally_bounded_ball (x ε : ℝ) : totally_bounded (ball x ε) :=
by rw real.ball_eq_Ioo; apply totally_bounded_Ioo

lemma rat.totally_bounded_Icc (a b : ℚ) : totally_bounded (Icc a b) :=
begin
  have := totally_bounded_preimage uniform_embedding_of_rat (totally_bounded_Icc a b),
  rwa (set.ext (λ q, _) : Icc _ _ = _), simp
end

section

lemma closure_of_rat_image_lt {q : ℚ} : closure ((coe:ℚ → ℝ) '' {x | q < x}) = {r | ↑q ≤ r} :=
subset.antisymm
  ((is_closed_ge' _).closure_subset_iff.2
    (image_subset_iff.2 $ λ p h, le_of_lt $ (@rat.cast_lt ℝ _ _ _).2 h)) $
λ x hx, mem_closure_iff_nhds.2 $ λ t ht,
let ⟨ε, ε0, hε⟩ := metric.mem_nhds_iff.1 ht in
let ⟨p, h₁, h₂⟩ := exists_rat_btwn ((lt_add_iff_pos_right x).2 ε0) in
⟨_, hε (show abs _ < _,
    by rwa [abs_of_nonneg (le_of_lt $ sub_pos.2 h₁), sub_lt_iff_lt_add']),
  p, rat.cast_lt.1 (@lt_of_le_of_lt ℝ _ _ _ _ hx h₁), rfl⟩

/- TODO(Mario): Put these back only if needed later
lemma closure_of_rat_image_le_eq {q : ℚ} : closure ((coe:ℚ → ℝ) '' {x | q ≤ x}) = {r | ↑q ≤ r} :=
_

lemma closure_of_rat_image_le_le_eq {a b : ℚ} (hab : a ≤ b) :
  closure (of_rat '' {q:ℚ | a ≤ q ∧ q ≤ b}) = {r:ℝ | of_rat a ≤ r ∧ r ≤ of_rat b} :=
_-/

lemma real.bounded_iff_bdd_below_bdd_above {s : set ℝ} : bounded s ↔ bdd_below s ∧ bdd_above s :=
⟨begin
  assume bdd,
  rcases (bounded_iff_subset_ball 0).1 bdd with ⟨r, hr⟩, -- hr : s ⊆ closed_ball 0 r
  rw closed_ball_Icc at hr, -- hr : s ⊆ Icc (0 - r) (0 + r)
  exact ⟨⟨-r, λy hy, by simpa using (hr hy).1⟩, ⟨r, λy hy, by simpa using (hr hy).2⟩⟩
end,
begin
  rintros ⟨⟨m, hm⟩, ⟨M, hM⟩⟩,
  have I : s ⊆ Icc m M := λx hx, ⟨hm hx, hM hx⟩,
  have : Icc m M = closed_ball ((m+M)/2) ((M-m)/2) :=
    by rw closed_ball_Icc; congr; ring,
  rw this at I,
  exact bounded.subset I bounded_closed_ball
end⟩

lemma real.image_Icc {f : ℝ → ℝ} {a b : ℝ} (hab : a ≤ b) (h : continuous_on f $ Icc a b) :
  f '' Icc a b = Icc (Inf $ f '' Icc a b) (Sup $ f '' Icc a b) :=
eq_Icc_of_connected_compact ⟨(nonempty_Icc.2 hab).image f, is_preconnected_Icc.image f h⟩
  (compact_Icc.image_of_continuous_on h)

end

section subgroups

/-- Given a nontrivial subgroup `G ⊆ ℝ`, if `G ∩ ℝ_{>0}` has no minimum then `G` is dense. -/
lemma real.subgroup_dense_of_no_min {G : add_subgroup ℝ} {g₀ : ℝ} (g₀_in : g₀ ∈ G) (g₀_ne : g₀ ≠ 0)
  (H' : ¬ ∃ a : ℝ, is_least {g : ℝ | g ∈ G ∧ 0 < g} a) :
  dense (G : set ℝ) :=
begin
  let G_pos := {g : ℝ | g ∈ G ∧ 0 < g},
  push_neg at H',
  intros x,
  suffices : ∀ ε > (0 : ℝ), ∃ g ∈ G, abs (x - g) < ε,
    by simpa only [real.mem_closure_iff, abs_sub],
  intros ε ε_pos,
  obtain ⟨g₁, g₁_in, g₁_pos⟩ : ∃ g₁ : ℝ, g₁ ∈ G ∧ 0 < g₁,
  { cases lt_or_gt_of_ne g₀_ne with Hg₀ Hg₀,
    { exact ⟨-g₀, G.neg_mem g₀_in, neg_pos.mpr Hg₀⟩ },
    { exact ⟨g₀, g₀_in, Hg₀⟩ } },
  obtain ⟨a, ha⟩ : ∃ a, is_glb G_pos a :=
    ⟨Inf G_pos, is_glb_cInf ⟨g₁, g₁_in, g₁_pos⟩ ⟨0, λ _ hx, le_of_lt hx.2⟩⟩,
  have a_notin : a ∉ G_pos,
  { intros H,
    exact H' a ⟨H, ha.1⟩ },
  obtain ⟨g₂, g₂_in, g₂_pos, g₂_lt⟩ : ∃ g₂ : ℝ, g₂ ∈ G ∧ 0 < g₂ ∧ g₂ < ε,
  { obtain ⟨b, hb, hb', hb''⟩ := ha.exists_between_self_add' a_notin ε_pos,
    obtain ⟨c, hc, hc', hc''⟩ := ha.exists_between_self_add' a_notin (sub_pos.2 hb'),
    refine ⟨b - c, G.sub_mem hb.1 hc.1, _, _⟩ ;
    linarith },
  refine ⟨floor (x/g₂) * g₂, _, _⟩,
  { exact add_subgroup.int_mul_mem _ g₂_in },
  { rw abs_of_nonneg (sub_floor_div_mul_nonneg x g₂_pos),
    linarith [sub_floor_div_mul_lt x g₂_pos] }
end

/-- Subgroups of `ℝ` are either dense or cyclic. See `real.subgroup_dense_of_no_min` and
`subgroup_cyclic_of_min` for more precise statements. -/
lemma real.subgroup_dense_or_cyclic (G : add_subgroup ℝ) :
  dense (G : set ℝ) ∨ ∃ a : ℝ, G = add_subgroup.closure {a} :=
begin
  cases add_subgroup.bot_or_exists_ne_zero G with H H,
  { right,
    use 0,
    rw [H, add_subgroup.closure_singleton_zero] },
  { let G_pos := {g : ℝ | g ∈ G ∧ 0 < g},
    by_cases H' : ∃ a, is_least G_pos a,
    { right,
      rcases H' with ⟨a, ha⟩,
      exact ⟨a, add_subgroup.cyclic_of_min ha⟩ },
    { left,
      rcases H with ⟨g₀, g₀_in, g₀_ne⟩,
      exact real.subgroup_dense_of_no_min g₀_in g₀_ne H' } }
end

end subgroups


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import algebra.ordered_ring algebra.field

section linear_ordered_field
variables {α : Type*} [linear_ordered_field α] {a b c d : α}

def div_pos := @div_pos_of_pos_of_pos

lemma inv_pos {a : α} : 0 < a → 0 < a⁻¹ :=
by rw [inv_eq_one_div]; exact div_pos zero_lt_one

lemma inv_lt_zero {a : α} : a < 0 → a⁻¹ < 0 :=
by rw [inv_eq_one_div]; exact div_neg_of_pos_of_neg zero_lt_one

lemma one_le_div_iff_le (hb : 0 < b) : 1 ≤ a / b ↔ b ≤ a :=
⟨le_of_one_le_div a hb, one_le_div_of_le a hb⟩

lemma one_lt_div_iff_lt (hb : 0 < b) : 1 < a / b ↔ b < a :=
⟨lt_of_one_lt_div a hb, one_lt_div_of_lt a hb⟩

lemma div_le_one_iff_le (hb : 0 < b) : a / b ≤ 1 ↔ a ≤ b :=
le_iff_le_iff_lt_iff_lt.2 (one_lt_div_iff_lt hb)

lemma div_lt_one_iff_lt (hb : 0 < b) : a / b < 1 ↔ a < b :=
le_iff_le_iff_lt_iff_lt.1 (one_le_div_iff_le hb)

lemma le_div_iff (hc : 0 < c) : a ≤ b / c ↔ a * c ≤ b :=
⟨mul_le_of_le_div hc, le_div_of_mul_le hc⟩

lemma le_div_iff' (hc : 0 < c) : a ≤ b / c ↔ c * a ≤ b :=
by rw [mul_comm, le_div_iff hc]

lemma div_le_iff (hb : 0 < b) : a / b ≤ c ↔ a ≤ c * b :=
⟨le_mul_of_div_le hb, by rw [mul_comm]; exact div_le_of_le_mul hb⟩

lemma div_le_iff' (hb : 0 < b) : a / b ≤ c ↔ a ≤ b * c :=
by rw [mul_comm, div_le_iff hb]

lemma lt_div_iff (hc : 0 < c) : a < b / c ↔ a * c < b :=
⟨mul_lt_of_lt_div hc, lt_div_of_mul_lt hc⟩

lemma lt_div_iff' (hc : 0 < c) : a < b / c ↔ c * a < b :=
by rw [mul_comm, lt_div_iff hc]

lemma div_le_iff_of_neg (hc : c < 0) : b / c ≤ a ↔ a * c ≤ b :=
⟨mul_le_of_div_le_of_neg hc, div_le_of_mul_le_of_neg hc⟩

lemma div_lt_iff (hc : 0 < c) : b / c < a ↔ b < a * c :=
le_iff_le_iff_lt_iff_lt.1 (le_div_iff hc)

lemma div_lt_iff' (hc : 0 < c) : b / c < a ↔ b < c * a :=
by rw [mul_comm, div_lt_iff hc]

lemma div_lt_iff_of_neg (hc : c < 0) : b / c < a ↔ a * c < b :=
⟨mul_lt_of_gt_div_of_neg hc, div_lt_of_mul_gt_of_neg hc⟩

lemma inv_le_inv (ha : 0 < a) (hb : 0 < b) : a⁻¹ ≤ b⁻¹ ↔ b ≤ a :=
by rw [inv_eq_one_div, div_le_iff ha,
       ← div_eq_inv_mul, one_le_div_iff_le hb]

lemma inv_le (ha : 0 < a) (hb : 0 < b) : a⁻¹ ≤ b ↔ b⁻¹ ≤ a :=
by rw [← inv_le_inv hb (inv_pos ha), division_ring.inv_inv (ne_of_gt ha)]

lemma le_inv (ha : 0 < a) (hb : 0 < b) : a ≤ b⁻¹ ↔ b ≤ a⁻¹ :=
by rw [← inv_le_inv (inv_pos hb) ha, division_ring.inv_inv (ne_of_gt hb)]

lemma one_div_le_one_div (ha : 0 < a) (hb : 0 < b) : 1 / a ≤ 1 / b ↔ b ≤ a :=
by simpa [one_div_eq_inv] using inv_le_inv ha hb

lemma inv_lt_inv (ha : 0 < a) (hb : 0 < b) : a⁻¹ < b⁻¹ ↔ b < a :=
le_iff_le_iff_lt_iff_lt.1 (inv_le_inv hb ha)

lemma inv_lt (ha : 0 < a) (hb : 0 < b) : a⁻¹ < b ↔ b⁻¹ < a :=
le_iff_le_iff_lt_iff_lt.1 (le_inv hb ha)

lemma lt_inv (ha : 0 < a) (hb : 0 < b) : a < b⁻¹ ↔ b < a⁻¹ :=
le_iff_le_iff_lt_iff_lt.1 (inv_le hb ha)

lemma one_div_lt_one_div (ha : 0 < a) (hb : 0 < b) : 1 / a < 1 / b ↔ b < a :=
le_iff_le_iff_lt_iff_lt.1 (one_div_le_one_div hb ha)

def div_nonneg := @div_nonneg_of_nonneg_of_pos

lemma div_lt_div_right (hc : 0 < c) : a / c < b / c ↔ a < b :=
⟨le_imp_le_iff_lt_imp_lt.1 (λ h, div_le_div_of_le_of_pos h hc),
 λ h, div_lt_div_of_lt_of_pos h hc⟩

lemma div_le_div_right (hc : 0 < c) : a / c ≤ b / c ↔ a ≤ b :=
le_iff_le_iff_lt_iff_lt.2 (div_lt_div_right hc)

lemma div_lt_div_right_of_neg (hc : c < 0) : a / c < b / c ↔ b < a :=
⟨le_imp_le_iff_lt_imp_lt.1 (λ h, div_le_div_of_le_of_neg h hc),
 λ h, div_lt_div_of_lt_of_neg h hc⟩

lemma div_le_div_right_of_neg (hc : c < 0) : a / c ≤ b / c ↔ b ≤ a :=
le_iff_le_iff_lt_iff_lt.2 (div_lt_div_right_of_neg hc)

lemma div_lt_div_left (ha : 0 < a) (hb : 0 < b) (hc : 0 < c) : a / b < a / c ↔ c < b :=
(mul_lt_mul_left ha).trans (inv_lt_inv hb hc)

lemma div_le_div_left (ha : 0 < a) (hb : 0 < b) (hc : 0 < c) : a / b ≤ a / c ↔ c ≤ b :=
le_iff_le_iff_lt_iff_lt.2 (div_lt_div_left ha hc hb)

lemma div_lt_div_iff (b0 : 0 < b) (d0 : 0 < d) :
  a / b < c / d ↔ a * d < c * b :=
by rw [lt_div_iff d0, div_mul_eq_mul_div, div_lt_iff b0]

lemma div_lt_div (hac : a < c) (hbd : d ≤ b) (c0 : 0 ≤ c) (d0 : 0 < d) :
  a / b < c / d :=
(div_lt_div_iff (lt_of_lt_of_le d0 hbd) d0).2 (mul_lt_mul hac hbd d0 c0)

lemma div_lt_div' (hac : a ≤ c) (hbd : d < b) (c0 : 0 < c) (d0 : 0 < d) :
  a / b < c / d :=
(div_lt_div_iff (lt_trans d0 hbd) d0).2 (mul_lt_mul' hac hbd (le_of_lt d0) c0)

lemma half_pos {a : α} (h : 0 < a) : 0 < a / 2 := div_pos h two_pos

lemma one_half_pos : (0:α) < 1 / 2 := half_pos zero_lt_one

def half_lt_self := @div_two_lt_of_pos

lemma one_half_lt_one : (1 / 2 : α) < 1 := half_lt_self zero_lt_one

lemma ivl_translate : (λx, x + c) '' {r:α | a ≤ r ∧ r ≤ b } = {r:α | a + c ≤ r ∧ r ≤ b + c} :=
calc (λx, x + c) '' {r | a ≤ r ∧ r ≤ b } = (λx, x - c) ⁻¹' {r | a ≤ r ∧ r ≤ b } :
    congr_fun (set.image_eq_preimage_of_inverse
      (assume a, add_sub_cancel a c) (assume b, sub_add_cancel b c)) _
  ... = {r | a + c ≤ r ∧ r ≤ b + c} :
    set.ext $ by simp [-sub_eq_add_neg, le_sub_iff_add_le, sub_le_iff_le_add]

lemma ivl_stretch (hc : 0 < c) : (λx, x * c) '' {r | a ≤ r ∧ r ≤ b } = {r | a * c ≤ r ∧ r ≤ b * c} :=
calc (λx, x * c) '' {r | a ≤ r ∧ r ≤ b } = (λx, x / c) ⁻¹' {r | a ≤ r ∧ r ≤ b } :
    congr_fun (set.image_eq_preimage_of_inverse
      (assume a, mul_div_cancel _ $ ne_of_gt hc) (assume b, div_mul_cancel _ $ ne_of_gt hc)) _
  ... = {r | a * c ≤ r ∧ r ≤ b * c} :
    set.ext $ by simp [le_div_iff, div_le_iff, hc]

instance linear_ordered_field.to_densely_ordered [linear_ordered_field α] : densely_ordered α :=
{ dense := assume a₁ a₂ h, ⟨(a₁ + a₂) / 2,
  calc a₁ = (a₁ + a₁) / 2 : (add_self_div_two a₁).symm
    ... < (a₁ + a₂) / 2 : div_lt_div_of_lt_of_pos (add_lt_add_left h _) two_pos,
  calc (a₁ + a₂) / 2 < (a₂ + a₂) / 2 : div_lt_div_of_lt_of_pos (add_lt_add_right h _) two_pos
    ... = a₂ : add_self_div_two a₂⟩ }

instance linear_ordered_field.to_no_top_order [linear_ordered_field α] : no_top_order α :=
{ no_top := assume a, ⟨a + 1, lt_add_of_le_of_pos (le_refl a) zero_lt_one ⟩ }

instance linear_ordered_field.to_no_bot_order [linear_ordered_field α] : no_bot_order α :=
{ no_bot := assume a, ⟨a + -1,
    add_lt_of_le_of_neg (le_refl _) (neg_lt_of_neg_lt $ by simp [zero_lt_one]) ⟩ }

lemma inv_lt_one {a : α} (ha : 1 < a) : a⁻¹ < 1 :=
by rw [inv_eq_one_div]; exact div_lt_of_mul_lt_of_pos (lt_trans zero_lt_one ha) (by simp *)

lemma one_lt_inv (h₁ : 0 < a) (h₂ : a < 1) : 1 < a⁻¹ :=
by rw [inv_eq_one_div, lt_div_iff h₁]; simp [h₂]

lemma inv_le_one {a : α} (ha : 1 ≤ a) : a⁻¹ ≤ 1 :=
by rw [inv_eq_one_div]; exact div_le_of_le_mul (lt_of_lt_of_le zero_lt_one ha) (by simp *)

lemma mul_self_inj_of_nonneg {a b : α} (a0 : 0 ≤ a) (b0 : 0 ≤ b) : a * a = b * b ↔ a = b :=
(mul_self_eq_mul_self_iff a b).trans $ or_iff_left_of_imp $
λ h, by subst a; rw [le_antisymm (neg_nonneg.1 a0) b0, neg_zero]

end linear_ordered_field

section
variables {α : Type*} [discrete_linear_ordered_field α] (a b c : α)

lemma inv_pos' {a : α} : 0 < a⁻¹ ↔ 0 < a :=
⟨by rw [inv_eq_one_div]; exact pos_of_one_div_pos, inv_pos⟩

lemma inv_neg' {a : α} : a⁻¹ < 0 ↔ a < 0 :=
⟨by rw [inv_eq_one_div]; exact neg_of_one_div_neg, inv_lt_zero⟩

lemma inv_nonneg {a : α} : 0 ≤ a⁻¹ ↔ 0 ≤ a :=
le_iff_le_iff_lt_iff_lt.2 inv_neg'

lemma inv_nonpos {a : α} : a⁻¹ ≤ 0 ↔ a ≤ 0 :=
le_iff_le_iff_lt_iff_lt.2 inv_pos'

lemma abs_inv : abs a⁻¹ = (abs a)⁻¹ :=
have h : abs (1 / a) = 1 / abs a,
  begin rw [abs_div, abs_of_nonneg], exact zero_le_one end,
by simp [*] at *

lemma inv_neg : (-a)⁻¹ = -(a⁻¹) :=
if h : a = 0
then by simp [h, inv_zero]
else by rwa [inv_eq_one_div, inv_eq_one_div, div_neg_eq_neg_div]

lemma inv_le_inv_of_le {a b : α} (hb : 0 < b) (h : b ≤ a) : a⁻¹ ≤ b⁻¹ :=
begin
  rw [inv_eq_one_div, inv_eq_one_div],
  exact one_div_le_one_div_of_le hb h
end

lemma div_nonneg' {a b : α} (ha : 0 ≤ a) (hb : 0 ≤ b) : 0 ≤ a / b :=
(lt_or_eq_of_le hb).elim (div_nonneg ha) (λ h, by simp [h.symm])

end