/-
Copyright (c) 2021 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov, Alistair Tucker
-/
import order.complete_lattice_intervals
import topology.order.basic

/-!
# Intermediate Value Theorem

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

In this file we prove the Intermediate Value Theorem: if `f : α → β` is a function defined on a
connected set `s` that takes both values `≤ a` and values `≥ a` on `s`, then it is equal to `a` at
some point of `s`. We also prove that intervals in a dense conditionally complete order are
preconnected and any preconnected set is an interval. Then we specialize IVT to functions continuous
on intervals.

## Main results

* `is_preconnected_I??` : all intervals `I??` are preconnected,
* `is_preconnected.intermediate_value`, `intermediate_value_univ` : Intermediate Value Theorem for
  connected sets and connected spaces, respectively;
* `intermediate_value_Icc`, `intermediate_value_Icc'`: Intermediate Value Theorem for functions
  on closed intervals.

### Miscellaneous facts

* `is_closed.Icc_subset_of_forall_mem_nhds_within` : “Continuous induction” principle;
  if `s ∩ [a, b]` is closed, `a ∈ s`, and for each `x ∈ [a, b) ∩ s` some of its right neighborhoods
  is included `s`, then `[a, b] ⊆ s`.
* `is_closed.Icc_subset_of_forall_exists_gt`, `is_closed.mem_of_ge_of_forall_exists_gt` : two
  other versions of the “continuous induction” principle.

## Tags

intermediate value theorem, connected space, connected set
-/

open filter order_dual topological_space function set
open_locale topology filter

universes u v w

/-!
### Intermediate value theorem on a (pre)connected space

In this section we prove the following theorem (see `is_preconnected.intermediate_value₂`): if `f`
and `g` are two functions continuous on a preconnected set `s`, `f a ≤ g a` at some `a ∈ s` and
`g b ≤ f b` at some `b ∈ s`, then `f c = g c` at some `c ∈ s`. We prove several versions of this
statement, including the classical IVT that corresponds to a constant function `g`.
-/

section

variables {X : Type u} {α : Type v} [topological_space X]
  [linear_order α] [topological_space α] [order_closed_topology α]

/-- Intermediate value theorem for two functions: if `f` and `g` are two continuous functions
on a preconnected space and `f a ≤ g a` and `g b ≤ f b`, then for some `x` we have `f x = g x`. -/
lemma intermediate_value_univ₂ [preconnected_space X] {a b : X} {f g : X → α} (hf : continuous f)
  (hg : continuous g) (ha : f a ≤ g a) (hb : g b ≤ f b) :
  ∃ x, f x = g x :=
begin
  obtain ⟨x, h, hfg, hgf⟩ : (univ ∩ {x | f x ≤ g x ∧ g x ≤ f x}).nonempty,
    from is_preconnected_closed_iff.1 preconnected_space.is_preconnected_univ _ _
      (is_closed_le hf hg) (is_closed_le hg hf) (λ x hx, le_total _ _) ⟨a, trivial, ha⟩
      ⟨b, trivial, hb⟩,
  exact ⟨x, le_antisymm hfg hgf⟩
end

lemma intermediate_value_univ₂_eventually₁ [preconnected_space X] {a : X} {l : filter X} [ne_bot l]
  {f g : X → α} (hf : continuous f) (hg : continuous g) (ha : f a ≤ g a) (he : g ≤ᶠ[l] f) :
  ∃ x, f x = g x :=
let ⟨c, hc⟩ := he.frequently.exists in intermediate_value_univ₂ hf hg ha hc

lemma intermediate_value_univ₂_eventually₂ [preconnected_space X] {l₁ l₂ : filter X}
  [ne_bot l₁] [ne_bot l₂] {f g : X → α} (hf : continuous f) (hg : continuous g)
  (he₁ : f ≤ᶠ[l₁] g ) (he₂ : g ≤ᶠ[l₂] f) :
  ∃ x, f x = g x :=
let ⟨c₁, hc₁⟩ := he₁.frequently.exists, ⟨c₂, hc₂⟩ := he₂.frequently.exists in
intermediate_value_univ₂ hf hg hc₁ hc₂

/-- Intermediate value theorem for two functions: if `f` and `g` are two functions continuous
on a preconnected set `s` and for some `a b ∈ s` we have `f a ≤ g a` and `g b ≤ f b`,
then for some `x ∈ s` we have `f x = g x`. -/
lemma is_preconnected.intermediate_value₂ {s : set X} (hs : is_preconnected s)
  {a b : X} (ha : a ∈ s) (hb : b ∈ s) {f g : X → α}
  (hf : continuous_on f s) (hg : continuous_on g s) (ha' : f a ≤ g a) (hb' : g b ≤ f b) :
  ∃ x ∈ s, f x = g x :=
let ⟨x, hx⟩ := @intermediate_value_univ₂ s α _ _ _ _ (subtype.preconnected_space hs) ⟨a, ha⟩ ⟨b, hb⟩
  _ _ (continuous_on_iff_continuous_restrict.1 hf) (continuous_on_iff_continuous_restrict.1 hg)
  ha' hb'
in ⟨x, x.2, hx⟩

lemma is_preconnected.intermediate_value₂_eventually₁ {s : set X} (hs : is_preconnected s)
  {a : X} {l : filter X} (ha : a ∈ s) [ne_bot l] (hl : l ≤ 𝓟 s) {f g : X → α}
  (hf : continuous_on f s) (hg : continuous_on g s) (ha' : f a ≤ g a) (he : g ≤ᶠ[l] f) :
  ∃ x ∈ s, f x = g x :=
begin
  rw continuous_on_iff_continuous_restrict at hf hg,
  obtain ⟨b, h⟩ := @intermediate_value_univ₂_eventually₁ _ _ _ _ _ _ (subtype.preconnected_space hs)
    ⟨a, ha⟩ _ (comap_coe_ne_bot_of_le_principal hl) _ _ hf hg ha' (he.comap _),
  exact ⟨b, b.prop, h⟩,
end

lemma is_preconnected.intermediate_value₂_eventually₂ {s : set X} (hs : is_preconnected s)
  {l₁ l₂ : filter X} [ne_bot l₁] [ne_bot l₂] (hl₁ : l₁ ≤ 𝓟 s) (hl₂ : l₂ ≤ 𝓟 s) {f g : X → α}
  (hf : continuous_on f s) (hg : continuous_on g s) (he₁ : f ≤ᶠ[l₁] g) (he₂ : g ≤ᶠ[l₂] f) :
  ∃ x ∈ s, f x = g x :=
begin
  rw continuous_on_iff_continuous_restrict at hf hg,
  obtain ⟨b, h⟩ := @intermediate_value_univ₂_eventually₂ _ _ _ _ _ _ (subtype.preconnected_space hs)
    _ _ (comap_coe_ne_bot_of_le_principal hl₁) (comap_coe_ne_bot_of_le_principal hl₂)
    _ _ hf hg (he₁.comap _) (he₂.comap _),
  exact ⟨b, b.prop, h⟩,
end

/-- **Intermediate Value Theorem** for continuous functions on connected sets. -/
lemma is_preconnected.intermediate_value {s : set X} (hs : is_preconnected s)
  {a b : X} (ha : a ∈ s) (hb : b ∈ s) {f : X → α} (hf : continuous_on f s) :
  Icc (f a) (f b) ⊆ f '' s :=
λ x hx, mem_image_iff_bex.2 $ hs.intermediate_value₂ ha hb hf continuous_on_const hx.1 hx.2

lemma is_preconnected.intermediate_value_Ico {s : set X} (hs : is_preconnected s)
  {a : X} {l : filter X} (ha : a ∈ s) [ne_bot l] (hl : l ≤ 𝓟 s) {f : X → α}
  (hf : continuous_on f s) {v : α} (ht : tendsto f l (𝓝 v)) :
  Ico (f a) v ⊆ f '' s :=
λ y h, bex_def.1 $ hs.intermediate_value₂_eventually₁ ha hl
  hf continuous_on_const h.1 (eventually_ge_of_tendsto_gt h.2 ht)

lemma is_preconnected.intermediate_value_Ioc {s : set X} (hs : is_preconnected s)
  {a : X} {l : filter X} (ha : a ∈ s) [ne_bot l] (hl : l ≤ 𝓟 s) {f : X → α}
  (hf : continuous_on f s) {v : α} (ht : tendsto f l (𝓝 v)) :
  Ioc v (f a) ⊆ f '' s :=
λ y h, bex_def.1 $ bex.imp_right (λ x _, eq.symm) $ hs.intermediate_value₂_eventually₁ ha hl
  continuous_on_const hf h.2 (eventually_le_of_tendsto_lt h.1 ht)

lemma is_preconnected.intermediate_value_Ioo {s : set X} (hs : is_preconnected s)
  {l₁ l₂ : filter X} [ne_bot l₁] [ne_bot l₂] (hl₁ : l₁ ≤ 𝓟 s) (hl₂ : l₂ ≤ 𝓟 s) {f : X → α}
  (hf : continuous_on f s) {v₁ v₂ : α} (ht₁ : tendsto f l₁ (𝓝 v₁)) (ht₂ : tendsto f l₂ (𝓝 v₂)) :
  Ioo v₁ v₂ ⊆ f '' s :=
λ y h, bex_def.1 $ hs.intermediate_value₂_eventually₂ hl₁ hl₂
  hf continuous_on_const (eventually_le_of_tendsto_lt h.1 ht₁) (eventually_ge_of_tendsto_gt h.2 ht₂)

lemma is_preconnected.intermediate_value_Ici {s : set X} (hs : is_preconnected s)
  {a : X} {l : filter X} (ha : a ∈ s) [ne_bot l] (hl : l ≤ 𝓟 s) {f : X → α}
  (hf : continuous_on f s) (ht : tendsto f l at_top) :
  Ici (f a) ⊆ f '' s :=
λ y h, bex_def.1 $ hs.intermediate_value₂_eventually₁ ha hl
  hf continuous_on_const h (tendsto_at_top.1 ht y)

lemma is_preconnected.intermediate_value_Iic {s : set X} (hs : is_preconnected s)
  {a : X} {l : filter X} (ha : a ∈ s) [ne_bot l] (hl : l ≤ 𝓟 s) {f : X → α}
  (hf : continuous_on f s) (ht : tendsto f l at_bot) :
  Iic (f a) ⊆ f '' s :=
λ y h, bex_def.1 $ bex.imp_right (λ x _, eq.symm) $ hs.intermediate_value₂_eventually₁ ha hl
  continuous_on_const hf h (tendsto_at_bot.1 ht y)

lemma is_preconnected.intermediate_value_Ioi {s : set X} (hs : is_preconnected s)
  {l₁ l₂ : filter X} [ne_bot l₁] [ne_bot l₂] (hl₁ : l₁ ≤ 𝓟 s) (hl₂ : l₂ ≤ 𝓟 s) {f : X → α}
  (hf : continuous_on f s) {v : α} (ht₁ : tendsto f l₁ (𝓝 v)) (ht₂ : tendsto f l₂ at_top) :
  Ioi v ⊆ f '' s :=
λ y h, bex_def.1 $ hs.intermediate_value₂_eventually₂ hl₁ hl₂
  hf continuous_on_const (eventually_le_of_tendsto_lt h ht₁) (tendsto_at_top.1 ht₂ y)

lemma is_preconnected.intermediate_value_Iio {s : set X} (hs : is_preconnected s)
  {l₁ l₂ : filter X} [ne_bot l₁] [ne_bot l₂] (hl₁ : l₁ ≤ 𝓟 s) (hl₂ : l₂ ≤ 𝓟 s) {f : X → α}
  (hf : continuous_on f s) {v : α} (ht₁ : tendsto f l₁ at_bot) (ht₂ : tendsto f l₂ (𝓝 v)) :
  Iio v ⊆ f '' s :=
λ y h, bex_def.1 $ hs.intermediate_value₂_eventually₂ hl₁ hl₂
  hf continuous_on_const (tendsto_at_bot.1 ht₁ y) (eventually_ge_of_tendsto_gt h ht₂)

lemma is_preconnected.intermediate_value_Iii {s : set X} (hs : is_preconnected s)
  {l₁ l₂ : filter X} [ne_bot l₁] [ne_bot l₂] (hl₁ : l₁ ≤ 𝓟 s) (hl₂ : l₂ ≤ 𝓟 s) {f : X → α}
  (hf : continuous_on f s) (ht₁ : tendsto f l₁ at_bot) (ht₂ : tendsto f l₂ at_top) :
  univ ⊆ f '' s :=
λ y h, bex_def.1 $ hs.intermediate_value₂_eventually₂ hl₁ hl₂
  hf continuous_on_const (tendsto_at_bot.1 ht₁ y) (tendsto_at_top.1 ht₂ y)

/-- **Intermediate Value Theorem** for continuous functions on connected spaces. -/
lemma intermediate_value_univ [preconnected_space X] (a b : X) {f : X → α} (hf : continuous f) :
  Icc (f a) (f b) ⊆ range f :=
λ x hx, intermediate_value_univ₂ hf continuous_const hx.1 hx.2

/-- **Intermediate Value Theorem** for continuous functions on connected spaces. -/
lemma mem_range_of_exists_le_of_exists_ge [preconnected_space X] {c : α} {f : X → α}
  (hf : continuous f) (h₁ : ∃ a, f a ≤ c) (h₂ : ∃ b, c ≤ f b) :
  c ∈ range f :=
let ⟨a, ha⟩ := h₁, ⟨b, hb⟩ := h₂ in intermediate_value_univ a b hf ⟨ha, hb⟩

/-!
### (Pre)connected sets in a linear order

In this section we prove the following results:

* `is_preconnected.ord_connected`: any preconnected set `s` in a linear order is `ord_connected`,
  i.e. `a ∈ s` and `b ∈ s` imply `Icc a b ⊆ s`;

* `is_preconnected.mem_intervals`: any preconnected set `s` in a conditionally complete linear order
  is one of the intervals `set.Icc`, `set.`Ico`, `set.Ioc`, `set.Ioo`, ``set.Ici`, `set.Iic`,
  `set.Ioi`, `set.Iio`; note that this is false for non-complete orders: e.g., in `ℝ \ {0}`, the set
  of positive numbers cannot be represented as `set.Ioi _`.

-/

/-- If a preconnected set contains endpoints of an interval, then it includes the whole interval. -/
lemma is_preconnected.Icc_subset {s : set α} (hs : is_preconnected s)
  {a b : α} (ha : a ∈ s) (hb : b ∈ s) :
  Icc a b ⊆ s :=
by simpa only [image_id] using hs.intermediate_value ha hb continuous_on_id

lemma is_preconnected.ord_connected {s : set α} (h : is_preconnected s) :
  ord_connected s :=
⟨λ x hx y hy, h.Icc_subset hx hy⟩

/-- If a preconnected set contains endpoints of an interval, then it includes the whole interval. -/
lemma is_connected.Icc_subset {s : set α} (hs : is_connected s)
  {a b : α} (ha : a ∈ s) (hb : b ∈ s) :
  Icc a b ⊆ s :=
hs.2.Icc_subset ha hb

/-- If preconnected set in a linear order space is unbounded below and above, then it is the whole
space. -/
lemma is_preconnected.eq_univ_of_unbounded {s : set α} (hs : is_preconnected s) (hb : ¬bdd_below s)
  (ha : ¬bdd_above s) :
  s = univ :=
begin
  refine eq_univ_of_forall (λ x, _),
  obtain ⟨y, ys, hy⟩ : ∃ y ∈ s, y < x := not_bdd_below_iff.1 hb x,
  obtain ⟨z, zs, hz⟩ : ∃ z ∈ s, x < z := not_bdd_above_iff.1 ha x,
  exact hs.Icc_subset ys zs ⟨le_of_lt hy, le_of_lt hz⟩
end

end

variables {α : Type u} {β : Type v} {γ : Type w}
  [conditionally_complete_linear_order α] [topological_space α] [order_topology α]
  [conditionally_complete_linear_order β] [topological_space β] [order_topology β]
  [nonempty γ]

/-- A bounded connected subset of a conditionally complete linear order includes the open interval
`(Inf s, Sup s)`. -/
lemma is_connected.Ioo_cInf_cSup_subset {s : set α} (hs : is_connected s) (hb : bdd_below s)
  (ha : bdd_above s) :
  Ioo (Inf s) (Sup s) ⊆ s :=
λ x hx, let ⟨y, ys, hy⟩ := (is_glb_lt_iff (is_glb_cInf hs.nonempty hb)).1 hx.1 in
let ⟨z, zs, hz⟩ := (lt_is_lub_iff (is_lub_cSup hs.nonempty ha)).1 hx.2 in
hs.Icc_subset ys zs ⟨le_of_lt hy, le_of_lt hz⟩

lemma eq_Icc_cInf_cSup_of_connected_bdd_closed {s : set α} (hc : is_connected s) (hb : bdd_below s)
  (ha : bdd_above s) (hcl : is_closed s) :
  s = Icc (Inf s) (Sup s) :=
subset.antisymm (subset_Icc_cInf_cSup hb ha) $
  hc.Icc_subset (hcl.cInf_mem hc.nonempty hb) (hcl.cSup_mem hc.nonempty ha)

lemma is_preconnected.Ioi_cInf_subset {s : set α} (hs : is_preconnected s) (hb : bdd_below s)
  (ha : ¬bdd_above s) :
  Ioi (Inf s) ⊆ s :=
begin
  have sne : s.nonempty := @nonempty_of_not_bdd_above α _ s ⟨Inf ∅⟩ ha,
  intros x hx,
  obtain ⟨y, ys, hy⟩ : ∃ y ∈ s, y < x := (is_glb_lt_iff (is_glb_cInf sne hb)).1 hx,
  obtain ⟨z, zs, hz⟩ : ∃ z ∈ s, x < z := not_bdd_above_iff.1 ha x,
  exact hs.Icc_subset ys zs ⟨le_of_lt hy, le_of_lt hz⟩
end

lemma is_preconnected.Iio_cSup_subset {s : set α} (hs : is_preconnected s) (hb : ¬bdd_below s)
  (ha : bdd_above s) :
  Iio (Sup s) ⊆ s :=
@is_preconnected.Ioi_cInf_subset αᵒᵈ _ _ _ s hs ha hb

/-- A preconnected set in a conditionally complete linear order is either one of the intervals
`[Inf s, Sup s]`, `[Inf s, Sup s)`, `(Inf s, Sup s]`, `(Inf s, Sup s)`, `[Inf s, +∞)`,
`(Inf s, +∞)`, `(-∞, Sup s]`, `(-∞, Sup s)`, `(-∞, +∞)`, or `∅`. The converse statement requires
`α` to be densely ordererd. -/
lemma is_preconnected.mem_intervals {s : set α} (hs : is_preconnected s) :
  s ∈ ({Icc (Inf s) (Sup s), Ico (Inf s) (Sup s), Ioc (Inf s) (Sup s), Ioo (Inf s) (Sup s),
    Ici (Inf s), Ioi (Inf s), Iic (Sup s), Iio (Sup s), univ, ∅} : set (set α)) :=
begin
  rcases s.eq_empty_or_nonempty with rfl|hne,
  { apply_rules [or.inr, mem_singleton] },
  have hs' : is_connected s := ⟨hne, hs⟩,
  by_cases hb : bdd_below s; by_cases ha : bdd_above s,
  { rcases mem_Icc_Ico_Ioc_Ioo_of_subset_of_subset (hs'.Ioo_cInf_cSup_subset hb ha)
      (subset_Icc_cInf_cSup hb ha) with hs|hs|hs|hs,
    { exact (or.inl hs) },
    { exact (or.inr $ or.inl hs) },
    { exact (or.inr $ or.inr $ or.inl hs) },
    { exact (or.inr $ or.inr $ or.inr $ or.inl hs) } },
  { refine (or.inr $ or.inr $ or.inr $ or.inr _),
    cases mem_Ici_Ioi_of_subset_of_subset (hs.Ioi_cInf_subset hb ha) (λ x hx, cInf_le hb hx)
      with hs hs,
    { exact or.inl hs },
    { exact or.inr (or.inl hs) } },
  { iterate 6 { apply or.inr },
    cases mem_Iic_Iio_of_subset_of_subset (hs.Iio_cSup_subset hb ha) (λ x hx, le_cSup ha hx)
      with hs hs,
    { exact or.inl hs },
    { exact or.inr (or.inl hs) } },
  { iterate 8 { apply or.inr },
    exact or.inl (hs.eq_univ_of_unbounded hb ha) }
end

/-- A preconnected set is either one of the intervals `Icc`, `Ico`, `Ioc`, `Ioo`, `Ici`, `Ioi`,
`Iic`, `Iio`, or `univ`, or `∅`. The converse statement requires `α` to be densely ordered. Though
one can represent `∅` as `(Inf s, Inf s)`, we include it into the list of possible cases to improve
readability. -/
lemma set_of_is_preconnected_subset_of_ordered :
  {s : set α | is_preconnected s} ⊆
    -- bounded intervals
    (range (uncurry Icc) ∪ range (uncurry Ico) ∪ range (uncurry Ioc) ∪ range (uncurry Ioo)) ∪
    -- unbounded intervals and `univ`
    (range Ici ∪ range Ioi ∪ range Iic ∪ range Iio ∪ {univ, ∅}) :=
begin
  intros s hs,
  rcases hs.mem_intervals with hs|hs|hs|hs|hs|hs|hs|hs|hs|hs,
  { exact (or.inl $ or.inl $ or.inl $ or.inl ⟨(Inf s, Sup s), hs.symm⟩) },
  { exact (or.inl $ or.inl $ or.inl $ or.inr ⟨(Inf s, Sup s), hs.symm⟩) },
  { exact (or.inl $ or.inl $ or.inr ⟨(Inf s, Sup s), hs.symm⟩) },
  { exact (or.inl $ or.inr ⟨(Inf s, Sup s), hs.symm⟩) },
  { exact (or.inr $ or.inl $ or.inl $ or.inl $ or.inl ⟨Inf s, hs.symm⟩) },
  { exact (or.inr $ or.inl $ or.inl $ or.inl $ or.inr ⟨Inf s, hs.symm⟩) },
  { exact (or.inr $ or.inl $ or.inl  $ or.inr ⟨Sup s, hs.symm⟩) },
  { exact (or.inr $ or.inl $  or.inr ⟨Sup s, hs.symm⟩) },
  { exact (or.inr $ or.inr $ or.inl hs) },
  { exact (or.inr $ or.inr $ or.inr hs) }
end

/-!
### Intervals are connected

In this section we prove that a closed interval (hence, any `ord_connected` set) in a dense
conditionally complete linear order is preconnected.
-/

/-- A "continuous induction principle" for a closed interval: if a set `s` meets `[a, b]`
on a closed subset, contains `a`, and the set `s ∩ [a, b)` has no maximal point, then `b ∈ s`. -/
lemma is_closed.mem_of_ge_of_forall_exists_gt {a b : α} {s : set α} (hs : is_closed (s ∩ Icc a b))
  (ha : a ∈ s) (hab : a ≤ b) (hgt : ∀ x ∈ s ∩ Ico a b, (s ∩ Ioc x b).nonempty) :
  b ∈ s :=
begin
  let S := s ∩ Icc a b,
  replace ha : a ∈ S, from ⟨ha, left_mem_Icc.2 hab⟩,
  have Sbd : bdd_above S, from ⟨b, λ z hz, hz.2.2⟩,
  let c := Sup (s ∩ Icc a b),
  have c_mem : c ∈ S, from hs.cSup_mem ⟨_, ha⟩ Sbd,
  have c_le : c ≤ b, from cSup_le ⟨_, ha⟩ (λ x hx, hx.2.2),
  cases eq_or_lt_of_le c_le with hc hc, from hc ▸ c_mem.1,
  exfalso,
  rcases hgt c ⟨c_mem.1, c_mem.2.1, hc⟩ with ⟨x, xs, cx, xb⟩,
  exact not_lt_of_le (le_cSup Sbd ⟨xs, le_trans (le_cSup Sbd ha) (le_of_lt cx), xb⟩) cx
end

/-- A "continuous induction principle" for a closed interval: if a set `s` meets `[a, b]`
on a closed subset, contains `a`, and for any `a ≤ x < y ≤ b`, `x ∈ s`, the set `s ∩ (x, y]`
is not empty, then `[a, b] ⊆ s`. -/
lemma is_closed.Icc_subset_of_forall_exists_gt {a b : α} {s : set α} (hs : is_closed (s ∩ Icc a b))
  (ha : a ∈ s) (hgt : ∀ x ∈ s ∩ Ico a b, ∀ y ∈ Ioi x, (s ∩ Ioc x y).nonempty) :
  Icc a b ⊆ s :=
begin
  assume y hy,
  have : is_closed (s ∩ Icc a y),
  { suffices : s ∩ Icc a y = s ∩ Icc a b ∩ Icc a y,
    { rw this, exact is_closed.inter hs is_closed_Icc },
    rw [inter_assoc],
    congr,
    exact (inter_eq_self_of_subset_right $ Icc_subset_Icc_right hy.2).symm },
  exact is_closed.mem_of_ge_of_forall_exists_gt this ha hy.1
    (λ x hx, hgt x ⟨hx.1, Ico_subset_Ico_right hy.2 hx.2⟩ y hx.2.2)
end

variables [densely_ordered α] {a b : α}

/-- A "continuous induction principle" for a closed interval: if a set `s` meets `[a, b]`
on a closed subset, contains `a`, and for any `x ∈ s ∩ [a, b)` the set `s` includes some open
neighborhood of `x` within `(x, +∞)`, then `[a, b] ⊆ s`. -/
lemma is_closed.Icc_subset_of_forall_mem_nhds_within {a b : α} {s : set α}
  (hs : is_closed (s ∩ Icc a b)) (ha : a ∈ s)
  (hgt : ∀ x ∈ s ∩ Ico a b, s ∈ 𝓝[>] x) :
  Icc a b ⊆ s :=
begin
  apply hs.Icc_subset_of_forall_exists_gt ha,
  rintros x ⟨hxs, hxab⟩ y hyxb,
  have : s ∩ Ioc x y ∈ 𝓝[>] x,
    from inter_mem (hgt x ⟨hxs, hxab⟩) (Ioc_mem_nhds_within_Ioi ⟨le_rfl, hyxb⟩),
  exact (nhds_within_Ioi_self_ne_bot' ⟨b, hxab.2⟩).nonempty_of_mem this
end

lemma is_preconnected_Icc_aux (x y : α) (s t : set α) (hxy : x ≤ y)
  (hs : is_closed s) (ht : is_closed t) (hab : Icc a b ⊆ s ∪ t)
  (hx : x ∈ Icc a b ∩ s) (hy : y ∈ Icc a b ∩ t) : (Icc a b ∩ (s ∩ t)).nonempty :=
begin
  have xyab : Icc x y ⊆ Icc a b := Icc_subset_Icc hx.1.1 hy.1.2,
  by_contradiction hst,
  suffices : Icc x y ⊆ s,
    from hst ⟨y, xyab $ right_mem_Icc.2 hxy, this $ right_mem_Icc.2 hxy, hy.2⟩,
  apply (is_closed.inter hs is_closed_Icc).Icc_subset_of_forall_mem_nhds_within hx.2,
  rintros z ⟨zs, hz⟩,
  have zt : z ∈ tᶜ, from λ zt, hst ⟨z, xyab $ Ico_subset_Icc_self hz, zs, zt⟩,
  have : tᶜ ∩ Ioc z y ∈ 𝓝[>] z,
  { rw [← nhds_within_Ioc_eq_nhds_within_Ioi hz.2],
    exact mem_nhds_within.2 ⟨tᶜ, ht.is_open_compl, zt, subset.refl _⟩},
  apply mem_of_superset this,
  have : Ioc z y ⊆ s ∪ t, from λ w hw, hab (xyab ⟨le_trans hz.1 (le_of_lt hw.1), hw.2⟩),
  exact λ w ⟨wt, wzy⟩, (this wzy).elim id (λ h, (wt h).elim)
end

/-- A closed interval in a densely ordered conditionally complete linear order is preconnected. -/
lemma is_preconnected_Icc : is_preconnected (Icc a b) :=
is_preconnected_closed_iff.2
begin
  rintros s t hs ht hab ⟨x, hx⟩ ⟨y, hy⟩,
  -- This used to use `wlog`, but it was causing timeouts.
  cases le_total x y,
  { exact is_preconnected_Icc_aux x y s t h hs ht hab hx hy, },
  { rw inter_comm s t,
    rw union_comm s t at hab,
    exact is_preconnected_Icc_aux y x t s h ht hs hab hy hx, },
end

lemma is_preconnected_uIcc : is_preconnected (uIcc a b) := is_preconnected_Icc

lemma set.ord_connected.is_preconnected {s : set α} (h : s.ord_connected) :
  is_preconnected s :=
is_preconnected_of_forall_pair $ λ x hx y hy, ⟨uIcc x y, h.uIcc_subset hx hy,
  left_mem_uIcc, right_mem_uIcc, is_preconnected_uIcc⟩

lemma is_preconnected_iff_ord_connected {s : set α} :
  is_preconnected s ↔ ord_connected s :=
⟨is_preconnected.ord_connected, set.ord_connected.is_preconnected⟩

lemma is_preconnected_Ici : is_preconnected (Ici a) := ord_connected_Ici.is_preconnected
lemma is_preconnected_Iic : is_preconnected (Iic a) := ord_connected_Iic.is_preconnected
lemma is_preconnected_Iio : is_preconnected (Iio a) := ord_connected_Iio.is_preconnected
lemma is_preconnected_Ioi : is_preconnected (Ioi a) := ord_connected_Ioi.is_preconnected
lemma is_preconnected_Ioo : is_preconnected (Ioo a b) := ord_connected_Ioo.is_preconnected
lemma is_preconnected_Ioc : is_preconnected (Ioc a b) := ord_connected_Ioc.is_preconnected
lemma is_preconnected_Ico : is_preconnected (Ico a b) := ord_connected_Ico.is_preconnected

lemma is_connected_Ici : is_connected (Ici a) := ⟨nonempty_Ici, is_preconnected_Ici⟩

lemma is_connected_Iic : is_connected (Iic a) := ⟨nonempty_Iic, is_preconnected_Iic⟩

lemma is_connected_Ioi [no_max_order α] : is_connected (Ioi a) :=
⟨nonempty_Ioi, is_preconnected_Ioi⟩

lemma is_connected_Iio [no_min_order α] : is_connected (Iio a) :=
⟨nonempty_Iio, is_preconnected_Iio⟩

lemma is_connected_Icc (h : a ≤ b) : is_connected (Icc a b) :=
⟨nonempty_Icc.2 h, is_preconnected_Icc⟩

lemma is_connected_Ioo (h : a < b) : is_connected (Ioo a b) :=
⟨nonempty_Ioo.2 h, is_preconnected_Ioo⟩

lemma is_connected_Ioc (h : a < b) : is_connected (Ioc a b) :=
⟨nonempty_Ioc.2 h, is_preconnected_Ioc⟩

lemma is_connected_Ico (h : a < b) : is_connected (Ico a b) :=
⟨nonempty_Ico.2 h, is_preconnected_Ico⟩

@[priority 100]
instance ordered_connected_space : preconnected_space α :=
⟨ord_connected_univ.is_preconnected⟩

/-- In a dense conditionally complete linear order, the set of preconnected sets is exactly
the set of the intervals `Icc`, `Ico`, `Ioc`, `Ioo`, `Ici`, `Ioi`, `Iic`, `Iio`, `(-∞, +∞)`,
or `∅`. Though one can represent `∅` as `(Inf s, Inf s)`, we include it into the list of
possible cases to improve readability. -/
lemma set_of_is_preconnected_eq_of_ordered :
  {s : set α | is_preconnected s} =
    -- bounded intervals
    (range (uncurry Icc) ∪ range (uncurry Ico) ∪ range (uncurry Ioc) ∪ range (uncurry Ioo)) ∪
    -- unbounded intervals and `univ`
    (range Ici ∪ range Ioi ∪ range Iic ∪ range Iio ∪ {univ, ∅}) :=
begin
  refine subset.antisymm set_of_is_preconnected_subset_of_ordered _,
  simp only [subset_def, -mem_range, forall_range_iff, uncurry, or_imp_distrib, forall_and_distrib,
    mem_union, mem_set_of_eq, insert_eq, mem_singleton_iff, forall_eq, forall_true_iff, and_true,
    is_preconnected_Icc, is_preconnected_Ico, is_preconnected_Ioc,
    is_preconnected_Ioo, is_preconnected_Ioi, is_preconnected_Iio, is_preconnected_Ici,
    is_preconnected_Iic, is_preconnected_univ, is_preconnected_empty],
end

/-!
### Intermediate Value Theorem on an interval

In this section we prove several versions of the Intermediate Value Theorem for a function
continuous on an interval.
-/

variables {δ : Type*} [linear_order δ] [topological_space δ] [order_closed_topology δ]

/-- **Intermediate Value Theorem** for continuous functions on closed intervals, case
`f a ≤ t ≤ f b`.-/
lemma intermediate_value_Icc {a b : α} (hab : a ≤ b) {f : α → δ} (hf : continuous_on f (Icc a b)) :
  Icc (f a) (f b) ⊆ f '' (Icc a b) :=
is_preconnected_Icc.intermediate_value (left_mem_Icc.2 hab) (right_mem_Icc.2 hab) hf

/-- **Intermediate Value Theorem** for continuous functions on closed intervals, case
`f a ≥ t ≥ f b`.-/
lemma intermediate_value_Icc' {a b : α} (hab : a ≤ b) {f : α → δ} (hf : continuous_on f (Icc a b)) :
  Icc (f b) (f a) ⊆ f '' (Icc a b) :=
is_preconnected_Icc.intermediate_value (right_mem_Icc.2 hab) (left_mem_Icc.2 hab) hf

/-- **Intermediate Value Theorem** for continuous functions on closed intervals, unordered case. -/
lemma intermediate_value_uIcc {a b : α} {f : α → δ} (hf : continuous_on f (uIcc a b)) :
  uIcc (f a) (f b) ⊆ f '' uIcc a b :=
by cases le_total (f a) (f b); simp [*, is_preconnected_uIcc.intermediate_value]

lemma intermediate_value_Ico {a b : α} (hab : a ≤ b) {f : α → δ} (hf : continuous_on f (Icc a b)) :
  Ico (f a) (f b) ⊆ f '' (Ico a b) :=
or.elim (eq_or_lt_of_le hab) (λ he y h, absurd h.2 (not_lt_of_le (he ▸ h.1)))
(λ hlt, @is_preconnected.intermediate_value_Ico _ _ _ _ _ _ _ (is_preconnected_Ico)
  _ _ ⟨refl a, hlt⟩ (right_nhds_within_Ico_ne_bot hlt) inf_le_right _ (hf.mono Ico_subset_Icc_self)
  _ ((hf.continuous_within_at ⟨hab, refl b⟩).mono Ico_subset_Icc_self))

lemma intermediate_value_Ico' {a b : α} (hab : a ≤ b) {f : α → δ} (hf : continuous_on f (Icc a b)) :
  Ioc (f b) (f a) ⊆ f '' (Ico a b) :=
or.elim (eq_or_lt_of_le hab) (λ he y h, absurd h.1 (not_lt_of_le (he ▸ h.2)))
(λ hlt, @is_preconnected.intermediate_value_Ioc _ _ _ _ _ _ _ (is_preconnected_Ico)
  _ _ ⟨refl a, hlt⟩ (right_nhds_within_Ico_ne_bot hlt) inf_le_right _ (hf.mono Ico_subset_Icc_self)
  _ ((hf.continuous_within_at ⟨hab, refl b⟩).mono Ico_subset_Icc_self))

lemma intermediate_value_Ioc {a b : α} (hab : a ≤ b) {f : α → δ} (hf : continuous_on f (Icc a b)) :
  Ioc (f a) (f b) ⊆ f '' (Ioc a b) :=
or.elim (eq_or_lt_of_le hab) (λ he y h, absurd h.2 (not_le_of_lt (he ▸ h.1)))
(λ hlt, @is_preconnected.intermediate_value_Ioc _ _ _ _ _ _ _ (is_preconnected_Ioc)
  _ _ ⟨hlt, refl b⟩ (left_nhds_within_Ioc_ne_bot hlt) inf_le_right _ (hf.mono Ioc_subset_Icc_self)
  _ ((hf.continuous_within_at ⟨refl a, hab⟩).mono Ioc_subset_Icc_self))

lemma intermediate_value_Ioc' {a b : α} (hab : a ≤ b) {f : α → δ} (hf : continuous_on f (Icc a b)) :
  Ico (f b) (f a) ⊆ f '' (Ioc a b) :=
or.elim (eq_or_lt_of_le hab) (λ he y h, absurd h.1 (not_le_of_lt (he ▸ h.2)))
(λ hlt, @is_preconnected.intermediate_value_Ico _ _ _ _ _ _ _ (is_preconnected_Ioc)
  _ _ ⟨hlt, refl b⟩ (left_nhds_within_Ioc_ne_bot hlt) inf_le_right _ (hf.mono Ioc_subset_Icc_self)
  _ ((hf.continuous_within_at ⟨refl a, hab⟩).mono Ioc_subset_Icc_self))

lemma intermediate_value_Ioo {a b : α} (hab : a ≤ b) {f : α → δ} (hf : continuous_on f (Icc a b)) :
  Ioo (f a) (f b) ⊆ f '' (Ioo a b) :=
or.elim (eq_or_lt_of_le hab) (λ he y h, absurd h.2 (not_lt_of_lt (he ▸ h.1)))
(λ hlt, @is_preconnected.intermediate_value_Ioo _ _ _ _ _ _ _ (is_preconnected_Ioo)
  _ _ (left_nhds_within_Ioo_ne_bot hlt) (right_nhds_within_Ioo_ne_bot hlt)
  inf_le_right inf_le_right _ (hf.mono Ioo_subset_Icc_self)
  _ _ ((hf.continuous_within_at ⟨refl a, hab⟩).mono Ioo_subset_Icc_self)
  ((hf.continuous_within_at ⟨hab, refl b⟩).mono Ioo_subset_Icc_self))

lemma intermediate_value_Ioo' {a b : α} (hab : a ≤ b) {f : α → δ} (hf : continuous_on f (Icc a b)) :
  Ioo (f b) (f a) ⊆ f '' (Ioo a b) :=
or.elim (eq_or_lt_of_le hab) (λ he y h, absurd h.1 (not_lt_of_lt (he ▸ h.2)))
(λ hlt, @is_preconnected.intermediate_value_Ioo _ _ _ _ _ _ _ (is_preconnected_Ioo)
  _ _ (right_nhds_within_Ioo_ne_bot hlt) (left_nhds_within_Ioo_ne_bot hlt)
  inf_le_right inf_le_right _ (hf.mono Ioo_subset_Icc_self)
  _ _ ((hf.continuous_within_at ⟨hab, refl b⟩).mono Ioo_subset_Icc_self)
  ((hf.continuous_within_at ⟨refl a, hab⟩).mono Ioo_subset_Icc_self))

/-- **Intermediate value theorem**: if `f` is continuous on an order-connected set `s` and `a`,
`b` are two points of this set, then `f` sends `s` to a superset of `Icc (f x) (f y)`. -/
lemma continuous_on.surj_on_Icc {s : set α} [hs : ord_connected s] {f : α → δ}
  (hf : continuous_on f s) {a b : α} (ha : a ∈ s) (hb : b ∈ s) :
  surj_on f s (Icc (f a) (f b)) :=
hs.is_preconnected.intermediate_value ha hb hf

/-- **Intermediate value theorem**: if `f` is continuous on an order-connected set `s` and `a`,
`b` are two points of this set, then `f` sends `s` to a superset of `[f x, f y]`. -/
lemma continuous_on.surj_on_uIcc {s : set α} [hs : ord_connected s] {f : α → δ}
  (hf : continuous_on f s) {a b : α} (ha : a ∈ s) (hb : b ∈ s) :
  surj_on f s (uIcc (f a) (f b)) :=
by cases le_total (f a) (f b) with hab hab; simp [hf.surj_on_Icc, *]

/-- A continuous function which tendsto `at_top` `at_top` and to `at_bot` `at_bot` is surjective. -/
lemma continuous.surjective {f : α → δ} (hf : continuous f) (h_top : tendsto f at_top at_top)
  (h_bot : tendsto f at_bot at_bot) :
  function.surjective f :=
λ p, mem_range_of_exists_le_of_exists_ge hf
  (h_bot.eventually (eventually_le_at_bot p)).exists
  (h_top.eventually (eventually_ge_at_top p)).exists

/-- A continuous function which tendsto `at_bot` `at_top` and to `at_top` `at_bot` is surjective. -/
lemma continuous.surjective' {f : α → δ} (hf : continuous f) (h_top : tendsto f at_bot at_top)
  (h_bot : tendsto f at_top at_bot) :
  function.surjective f :=
@continuous.surjective αᵒᵈ _ _ _ _ _ _ _ _ _ hf h_top h_bot

/-- If a function `f : α → β` is continuous on a nonempty interval `s`, its restriction to `s`
tends to `at_bot : filter β` along `at_bot : filter ↥s` and tends to `at_top : filter β` along
`at_top : filter ↥s`, then the restriction of `f` to `s` is surjective. We formulate the
conclusion as `surj_on f s univ`. -/
lemma continuous_on.surj_on_of_tendsto {f : α → δ} {s : set α} [ord_connected s]
  (hs : s.nonempty) (hf : continuous_on f s) (hbot : tendsto (λ x : s, f x) at_bot at_bot)
  (htop : tendsto (λ x : s, f x) at_top at_top) :
  surj_on f s univ :=
by haveI := classical.inhabited_of_nonempty hs.to_subtype;
  exact (surj_on_iff_surjective.2 $
    (continuous_on_iff_continuous_restrict.1 hf).surjective htop hbot)

/-- If a function `f : α → β` is continuous on a nonempty interval `s`, its restriction to `s`
tends to `at_top : filter β` along `at_bot : filter ↥s` and tends to `at_bot : filter β` along
`at_top : filter ↥s`, then the restriction of `f` to `s` is surjective. We formulate the
conclusion as `surj_on f s univ`. -/
lemma continuous_on.surj_on_of_tendsto' {f : α → δ} {s : set α} [ord_connected s]
  (hs : s.nonempty) (hf : continuous_on f s) (hbot : tendsto (λ x : s, f x) at_bot at_top)
  (htop : tendsto (λ x : s, f x) at_top at_bot) :
  surj_on f s univ :=
@continuous_on.surj_on_of_tendsto α _ _ _ _ δᵒᵈ _ _ _ _ _ _ hs hf hbot htop


/-
Copyright (c) 2022 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta

! This file was ported from Lean 3 source module algebra.is_prime_pow
! leanprover-community/mathlib commit f7fc89d5d5ff1db2d1242c7bb0e9062ce47ef47c
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Associated
import Mathlib.NumberTheory.Divisors

/-!
# Prime powers

This file deals with prime powers: numbers which are positive integer powers of a single prime.
-/

variable {R : Type _} [CommMonoidWithZero R] (n p : R) (k : ℕ)

/-- `n` is a prime power if there is a prime `p` and a positive natural `k` such that `n` can be
written as `p^k`. -/
def IsPrimePow : Prop :=
  ∃ (p : R)(k : ℕ), Prime p ∧ 0 < k ∧ p ^ k = n
#align is_prime_pow IsPrimePow

theorem isPrimePow_def : IsPrimePow n ↔ ∃ (p : R)(k : ℕ), Prime p ∧ 0 < k ∧ p ^ k = n :=
  Iff.rfl
#align is_prime_pow_def isPrimePow_def

/-- An equivalent definition for prime powers: `n` is a prime power iff there is a prime `p` and a
natural `k` such that `n` can be written as `p^(k+1)`. -/
theorem isPrimePow_iff_pow_succ : IsPrimePow n ↔ ∃ (p : R)(k : ℕ), Prime p ∧ p ^ (k + 1) = n :=
  (isPrimePow_def _).trans
    ⟨fun ⟨p, k, hp, hk, hn⟩ => ⟨_, _, hp, by rwa [Nat.sub_add_cancel hk]⟩, fun ⟨p, k, hp, hn⟩ =>
      ⟨_, _, hp, Nat.succ_pos', hn⟩⟩
#align is_prime_pow_iff_pow_succ isPrimePow_iff_pow_succ

theorem not_isPrimePow_zero [NoZeroDivisors R] : ¬IsPrimePow (0 : R) := by
  simp only [isPrimePow_def, not_exists, not_and', and_imp]
  intro x n _hn hx
  rw [pow_eq_zero hx]
  simp
#align not_is_prime_pow_zero not_isPrimePow_zero

theorem IsPrimePow.not_unit {n : R} (h : IsPrimePow n) : ¬IsUnit n :=
  let ⟨_p, _k, hp, hk, hn⟩ := h
  hn ▸ (isUnit_pow_iff hk.ne').not.mpr hp.not_unit
#align is_prime_pow.not_unit IsPrimePow.not_unit

theorem IsUnit.not_isPrimePow {n : R} (h : IsUnit n) : ¬IsPrimePow n := fun h' => h'.not_unit h
#align is_unit.not_is_prime_pow IsUnit.not_isPrimePow

theorem not_isPrimePow_one : ¬IsPrimePow (1 : R) :=
  isUnit_one.not_isPrimePow
#align not_is_prime_pow_one not_isPrimePow_one

theorem Prime.isPrimePow {p : R} (hp : Prime p) : IsPrimePow p :=
  ⟨p, 1, hp, zero_lt_one, by simp⟩
#align prime.is_prime_pow Prime.isPrimePow

theorem IsPrimePow.pow {n : R} (hn : IsPrimePow n) {k : ℕ} (hk : k ≠ 0) : IsPrimePow (n ^ k) :=
  let ⟨p, k', hp, hk', hn⟩ := hn
  ⟨p, k * k', hp, mul_pos hk.bot_lt hk', by rw [pow_mul', hn]⟩
#align is_prime_pow.pow IsPrimePow.pow

theorem IsPrimePow.ne_zero [NoZeroDivisors R] {n : R} (h : IsPrimePow n) : n ≠ 0 := fun t =>
  not_isPrimePow_zero (t ▸ h)
#align is_prime_pow.ne_zero IsPrimePow.ne_zero

theorem IsPrimePow.ne_one {n : R} (h : IsPrimePow n) : n ≠ 1 := fun t =>
  not_isPrimePow_one (t ▸ h)
#align is_prime_pow.ne_one IsPrimePow.ne_one

section Nat

theorem isPrimePow_nat_iff (n : ℕ) : IsPrimePow n ↔ ∃ p k : ℕ, Nat.Prime p ∧ 0 < k ∧ p ^ k = n := by
  simp only [isPrimePow_def, Nat.prime_iff]
#align is_prime_pow_nat_iff isPrimePow_nat_iff

theorem Nat.Prime.isPrimePow {p : ℕ} (hp : p.Prime) : IsPrimePow p :=
  _root_.Prime.isPrimePow (prime_iff.mp hp)
#align nat.prime.is_prime_pow Nat.Prime.isPrimePow

theorem isPrimePow_nat_iff_bounded (n : ℕ) :
    IsPrimePow n ↔ ∃ p : ℕ, p ≤ n ∧ ∃ k : ℕ, k ≤ n ∧ p.Prime ∧ 0 < k ∧ p ^ k = n := by
  rw [isPrimePow_nat_iff]
  refine' Iff.symm ⟨fun ⟨p, _, k, _, hp, hk, hn⟩ => ⟨p, k, hp, hk, hn⟩, _⟩
  rintro ⟨p, k, hp, hk, rfl⟩
  refine' ⟨p, _, k, (Nat.lt_pow_self hp.one_lt _).le, hp, hk, rfl⟩
  conv => { lhs; rw [←(pow_one p)] }
  exact (Nat.pow_le_iff_le_right hp.two_le).mpr hk
#align is_prime_pow_nat_iff_bounded isPrimePow_nat_iff_bounded

instance {n : ℕ} : Decidable (IsPrimePow n) :=
  decidable_of_iff' _ (isPrimePow_nat_iff_bounded n)

theorem IsPrimePow.dvd {n m : ℕ} (hn : IsPrimePow n) (hm : m ∣ n) (hm₁ : m ≠ 1) : IsPrimePow m := by
  rw [isPrimePow_nat_iff] at hn⊢
  rcases hn with ⟨p, k, hp, _hk, rfl⟩
  obtain ⟨i, hik, rfl⟩ := (Nat.dvd_prime_pow hp).1 hm
  refine' ⟨p, i, hp, _, rfl⟩
  apply Nat.pos_of_ne_zero
  rintro rfl
  simp only [pow_zero, ne_eq] at hm₁
#align is_prime_pow.dvd IsPrimePow.dvd

theorem Nat.disjoint_divisors_filter_isPrimePow {a b : ℕ} (hab : a.coprime b) :
    Disjoint (a.divisors.filter IsPrimePow) (b.divisors.filter IsPrimePow) := by
  simp only [Finset.disjoint_left, Finset.mem_filter, and_imp, Nat.mem_divisors, not_and]
  rintro n han _ha hn hbn _hb -
  exact hn.ne_one (Nat.eq_one_of_dvd_coprimes hab han hbn)
#align nat.disjoint_divisors_filter_prime_pow Nat.disjoint_divisors_filter_isPrimePow

theorem IsPrimePow.two_le : ∀ {n : ℕ}, IsPrimePow n → 2 ≤ n
  | 0, h => (not_isPrimePow_zero h).elim
  | 1, h => (not_isPrimePow_one h).elim
  | _n + 2, _ => le_add_self
#align is_prime_pow.two_le IsPrimePow.two_le

theorem IsPrimePow.pos {n : ℕ} (hn : IsPrimePow n) : 0 < n :=
  pos_of_gt hn.two_le
#align is_prime_pow.pos IsPrimePow.pos

theorem IsPrimePow.one_lt {n : ℕ} (h : IsPrimePow n) : 1 < n :=
  h.two_le
#align is_prime_pow.one_lt IsPrimePow.one_lt

end Nat


/-
Copyright (c) 2014 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad

Here an "ordered_ring" is partially ordered ring, which is ordered with respect to both a weak
order and an associated strict order. Our numeric structures (int, rat, and real) will be instances
of "linear_ordered_comm_ring". This development is modeled after Isabelle's library.
-/
import .ordered_group .ring
universes u v w
hott_theory
set_option old_structure_cmd true

namespace hott
open algebra
variable {A : Type _}
namespace algebra
@[hott] private def absurd_a_lt_a {B : Type _} {a : A} [s : strict_order A] (H : a < a) : B :=
absurd H (lt.irrefl a)

/- semiring structures -/

@[hott] structure ordered_semiring (A : Type _)
  extends semiring A, ordered_mul_cancel_comm_monoid A renaming
  mul→add mul_assoc→add_assoc one→zero one_mul→zero_add mul_one→add_zero mul_comm→add_comm
  mul_left_cancel→add_left_cancel mul_right_cancel→add_right_cancel mul_le_mul_left→add_le_add_left
  mul_lt_mul_left→add_lt_add_left le_of_mul_le_mul_left→le_of_add_le_add_left
  lt_of_mul_lt_mul_left→lt_of_add_lt_add_left :=
(mul_le_mul_of_nonneg_left: Πa b c, le a b → le zero c → le (mul c a) (mul c b))
(mul_le_mul_of_nonneg_right: Πa b c, le a b → le zero c → le (mul a c) (mul b c))
(mul_lt_mul_of_pos_left: Πa b c, lt a b → lt zero c → lt (mul c a) (mul c b))
(mul_lt_mul_of_pos_right: Πa b c, lt a b → lt zero c → lt (mul a c) (mul b c))

-- /- we make it a class now (and not as part of the structure) to avoid
--   ordered_semiring.to_ordered_mul_cancel_comm_monoid to be an instance -/
attribute [class] ordered_semiring

@[hott, instance, reducible] def add_ab_group_of_ordered_semiring (A : Type _)
  [H : ordered_semiring A] : semiring A :=
@ordered_semiring.to_semiring A H

@[hott, instance, reducible] def monoid_of_ordered_semiring (A : Type _)
  [H : ordered_semiring A] : ordered_cancel_comm_monoid A :=
@ordered_semiring.to_ordered_mul_cancel_comm_monoid A H

section
  variable [s : ordered_semiring A]
  variables (a b c d e : A)
  include s

  @[hott] def mul_le_mul_of_nonneg_left {a b c : A} (Hab : a ≤ b) (Hc : 0 ≤ c) :
    c * a ≤ c * b :=
  ordered_semiring.mul_le_mul_of_nonneg_left _ _ _ _ Hab Hc

  @[hott] def mul_le_mul_of_nonneg_right {a b c : A} (Hab : a ≤ b) (Hc : 0 ≤ c) :
    a * c ≤ b * c :=
  ordered_semiring.mul_le_mul_of_nonneg_right _ _ _ _ Hab Hc

  @[hott] theorem mul_le_mul {a b c d : A} (Hac : a ≤ c) (Hbd : b ≤ d) (nn_b : 0 ≤ b)
    (nn_c : 0 ≤ c) :
    a * b ≤ c * d :=
  calc
    a * b ≤ c * b : mul_le_mul_of_nonneg_right Hac nn_b
      ... ≤ c * d : mul_le_mul_of_nonneg_left Hbd nn_c

  @[hott] theorem mul_nonneg {a b : A} (Ha : a ≥ 0) (Hb : b ≥ 0) : a * b ≥ 0 :=
  begin
    have H : 0 * b ≤ a * b, from mul_le_mul_of_nonneg_right Ha Hb,
    rwr zero_mul at H,
    exact H
  end

  @[hott] theorem mul_nonpos_of_nonneg_of_nonpos {a b : A} (Ha : a ≥ 0) (Hb : b ≤ 0) : a * b ≤ 0 :=
  begin
    have H : a * b ≤ a * 0, from mul_le_mul_of_nonneg_left Hb Ha,
    rwr mul_zero at H,
    exact H
  end

  @[hott] theorem mul_nonpos_of_nonpos_of_nonneg {a b : A} (Ha : a ≤ 0) (Hb : b ≥ 0) : a * b ≤ 0 :=
  begin
    have H : a * b ≤ 0 * b, from mul_le_mul_of_nonneg_right Ha Hb,
    rwr zero_mul at H,
    exact H
  end

  @[hott] def mul_lt_mul_of_pos_left {a b c : A} (Hab : a < b) (Hc : 0 < c) :
    c * a < c * b :=
  ordered_semiring.mul_lt_mul_of_pos_left _ _ _ _ Hab Hc

  @[hott] def mul_lt_mul_of_pos_right {a b c : A} (Hab : a < b) (Hc : 0 < c) :
    a * c < b * c :=
  ordered_semiring.mul_lt_mul_of_pos_right _ _ _ _ Hab Hc

  -- TODO: once again, there are variations
  @[hott] theorem mul_lt_mul {a b c d : A} (Hac : a < c) (Hbd : b ≤ d) (pos_b : 0 < b)
    (nn_c : 0 ≤ c) : a * b < c * d :=
  calc
    a * b < c * b : mul_lt_mul_of_pos_right Hac pos_b
      ... ≤ c * d : mul_le_mul_of_nonneg_left Hbd nn_c

  @[hott] def mul_pos {a b : A} (Ha : a > 0) (Hb : b > 0) : a * b > 0 :=
  begin
    have H : 0 * b < a * b, from mul_lt_mul_of_pos_right Ha Hb,
    rwr zero_mul at H,
    exact H
  end

  @[hott] def mul_neg_of_pos_of_neg {a b : A} (Ha : a > 0) (Hb : b < 0) : a * b < 0 :=
  begin
    have H : a * b < a * 0, from mul_lt_mul_of_pos_left Hb Ha,
    rwr mul_zero at H,
    exact H
  end

  @[hott] def mul_neg_of_neg_of_pos {a b : A} (Ha : a < 0) (Hb : b > 0) : a * b < 0 :=
  begin
    have H : a * b < 0 * b, from mul_lt_mul_of_pos_right Ha Hb,
    rwr zero_mul at  H,
    exact H
  end
end

@[hott, class] structure linear_ordered_semiring (A : Type _)
  extends ordered_semiring A, linear_strong_order_pair A :=
(zero_lt_one : lt zero one)

section
  variable [s : linear_ordered_semiring A]
  variables {a b c : A}
  include s

  @[hott] theorem zero_lt_one : 0 < (1:A) := linear_ordered_semiring.zero_lt_one A

  @[hott] theorem lt_of_mul_lt_mul_left (H : c * a < c * b) (Hc : c ≥ 0) : a < b :=
  lt_of_not_ge
    (assume H1 : b ≤ a,
      have H2 : c * b ≤ c * a, from mul_le_mul_of_nonneg_left H1 Hc,
      not_lt_of_ge H2 H)

  @[hott] theorem lt_of_mul_lt_mul_right (H : a * c < b * c) (Hc : c ≥ 0) : a < b :=
  lt_of_not_ge
    (assume H1 : b ≤ a,
      have H2 : b * c ≤ a * c, from mul_le_mul_of_nonneg_right H1 Hc,
      not_lt_of_ge H2 H)

  @[hott] theorem le_of_mul_le_mul_left (H : c * a ≤ c * b) (Hc : c > 0) : a ≤ b :=
  le_of_not_gt
    (assume H1 : b < a,
      have H2 : c * b < c * a, from mul_lt_mul_of_pos_left H1 Hc,
      not_le_of_gt H2 H)

  @[hott] theorem le_of_mul_le_mul_right (H : a * c ≤ b * c) (Hc : c > 0) : a ≤ b :=
  le_of_not_gt
    (assume H1 : b < a,
      have H2 : b * c < a * c, from mul_lt_mul_of_pos_right H1 Hc,
      not_le_of_gt H2 H)

  @[hott] theorem le_iff_mul_le_mul_left (a b : A) {c : A} (H : c > 0) : a ≤ b ↔ c * a ≤ c * b :=
  iff.intro
    (assume H', mul_le_mul_of_nonneg_left H' (le_of_lt H))
    (assume H', le_of_mul_le_mul_left H' H)

  @[hott] theorem le_iff_mul_le_mul_right (a b : A) {c : A} (H : c > 0) : a ≤ b ↔ a * c ≤ b * c :=
  iff.intro
    (assume H', mul_le_mul_of_nonneg_right H' (le_of_lt H))
    (assume H', le_of_mul_le_mul_right H' H)

  @[hott] theorem pos_of_mul_pos_left (H : 0 < a * b) (H1 : 0 ≤ a) : 0 < b :=
  lt_of_not_ge
    (assume H2 : b ≤ 0,
      have H3 : a * b ≤ 0, from mul_nonpos_of_nonneg_of_nonpos H1 H2,
      not_lt_of_ge H3 H)

  @[hott] theorem pos_of_mul_pos_right (H : 0 < a * b) (H1 : 0 ≤ b) : 0 < a :=
  lt_of_not_ge
    (assume H2 : a ≤ 0,
      have H3 : a * b ≤ 0, from mul_nonpos_of_nonpos_of_nonneg H2 H1,
      not_lt_of_ge H3 H)

  @[hott] theorem nonneg_of_mul_nonneg_left (H : 0 ≤ a * b) (H1 : 0 < a) : 0 ≤ b :=
  le_of_not_gt
    (assume H2 : b < 0,
      not_le_of_gt (mul_neg_of_pos_of_neg H1 H2) H)

  @[hott] theorem nonneg_of_mul_nonneg_right (H : 0 ≤ a * b) (H1 : 0 < b) : 0 ≤ a :=
  le_of_not_gt
    (assume H2 : a < 0,
      not_le_of_gt (mul_neg_of_neg_of_pos H2 H1) H)

  @[hott] theorem neg_of_mul_neg_left (H : a * b < 0) (H1 : 0 ≤ a) : b < 0 :=
  lt_of_not_ge
    (assume H2 : b ≥ 0,
      not_lt_of_ge (mul_nonneg H1 H2) H)

  @[hott] theorem neg_of_mul_neg_right (H : a * b < 0) (H1 : 0 ≤ b) : a < 0 :=
  lt_of_not_ge
    (assume H2 : a ≥ 0,
      not_lt_of_ge (mul_nonneg H2 H1) H)

  @[hott] theorem nonpos_of_mul_nonpos_left (H : a * b ≤ 0) (H1 : 0 < a) : b ≤ 0 :=
  le_of_not_gt
    (assume H2 : b > 0,
      not_le_of_gt (mul_pos H1 H2) H)

  @[hott] theorem nonpos_of_mul_nonpos_right (H : a * b ≤ 0) (H1 : 0 < b) : a ≤ 0 :=
  le_of_not_gt
    (assume H2 : a > 0,
      not_le_of_gt (mul_pos H2 H1) H)
end

@[hott, class] structure decidable_linear_ordered_semiring (A : Type _)
  extends linear_ordered_semiring A, decidable_linear_order A

/- ring structures -/

@[hott] structure ordered_ring (A : Type _) extends ring A, ordered_mul_ab_group A renaming
  mul→add mul_assoc→add_assoc one→zero one_mul→zero_add mul_one→add_zero inv→neg
  mul_left_inv→add_left_inv mul_comm→add_comm mul_le_mul_left→add_le_add_left
  mul_lt_mul_left→add_lt_add_left,
  zero_ne_one_class A :=
(mul_nonneg : Πa b, le zero a → le zero b → le zero (mul a b))
(mul_pos : Πa b, lt zero a → lt zero b → lt zero (mul a b))

-- /- we make it a class now (and not as part of the structure) to avoid
--   ordered_ring.to_ordered_mul_ab_group to be an instance -/
attribute [class] ordered_ring

@[hott, instance, reducible] def add_ab_group_of_ordered_ring (A : Type _)
  [H : ordered_ring A] : ring A :=
@ordered_ring.to_ring A H

@[hott, instance, reducible] def monoid_of_ordered_ring (A : Type _)
  [H : ordered_ring A] : ordered_ab_group A :=
@ordered_ring.to_ordered_mul_ab_group A H

@[hott, instance, reducible] def zero_ne_one_class_of_ordered_ring (A : Type _)
  [H : ordered_ring A] : zero_ne_one_class A :=
@ordered_ring.to_zero_ne_one_class A H

@[hott] def ordered_ring.mul_le_mul_of_nonneg_left [s : ordered_ring A] {a b c : A}
        (Hab : a ≤ b) (Hc : 0 ≤ c) : c * a ≤ c * b :=
have H1 : 0 ≤ b - a, from sub_nonneg_of_le Hab,
have H2 : 0 ≤ c * (b - a), from ordered_ring.mul_nonneg _ _ _ Hc H1,
begin
  rwr mul_sub_left_distrib at H2,
  exact (iff.mp (sub_nonneg_iff_le _ _) H2)
end

@[hott] def ordered_ring.mul_le_mul_of_nonneg_right [s : ordered_ring A] {a b c : A}
        (Hab : a ≤ b) (Hc : 0 ≤ c) : a * c ≤ b * c  :=
have H1 : 0 ≤ b - a, from iff.elim_right (sub_nonneg_iff_le _ _) Hab,
have H2 : 0 ≤ (b - a) * c, from ordered_ring.mul_nonneg _ _ _ H1 Hc,
begin
  rwr mul_sub_right_distrib at H2,
  exact le_of_sub_nonneg H2
end

@[hott] def ordered_ring.mul_lt_mul_of_pos_left [s : ordered_ring A] {a b c : A}
       (Hab : a < b) (Hc : 0 < c) : c * a < c * b :=
have H1 : 0 < b - a, from iff.elim_right (sub_pos_iff_lt _ _) Hab,
have H2 : 0 < c * (b - a), from ordered_ring.mul_pos _ _ _ Hc H1,
begin
  rwr mul_sub_left_distrib at H2,
  exact (iff.mp (sub_pos_iff_lt _ _) H2)
end

@[hott] def ordered_ring.mul_lt_mul_of_pos_right [s : ordered_ring A] {a b c : A}
       (Hab : a < b) (Hc : 0 < c) : a * c < b * c :=
have H1 : 0 < b - a, from iff.elim_right (sub_pos_iff_lt _ _) Hab,
have H2 : 0 < (b - a) * c, from ordered_ring.mul_pos _ _ _ H1 Hc,
begin
  rwr mul_sub_right_distrib at H2,
  exact (lt_of_sub_pos H2)
end

@[hott, instance, reducible] def ordered_ring.to_ordered_semiring [s : ordered_ring A] :
  ordered_semiring A :=
{ mul_zero                   := mul_zero,
  zero_mul                   := zero_mul,
  add_left_cancel            := @add.left_cancel A _,
  add_right_cancel           := @add.right_cancel A _,
  le_of_add_le_add_left      := @le_of_add_le_add_left A _,
  mul_le_mul_of_nonneg_left  := @ordered_ring.mul_le_mul_of_nonneg_left A _,
  mul_le_mul_of_nonneg_right := @ordered_ring.mul_le_mul_of_nonneg_right A _,
  mul_lt_mul_of_pos_left     := @ordered_ring.mul_lt_mul_of_pos_left A _,
  mul_lt_mul_of_pos_right    := @ordered_ring.mul_lt_mul_of_pos_right A _,
  lt_of_add_lt_add_left      := @lt_of_add_lt_add_left A _, ..s }

section
  variable [s : ordered_ring A]
  variables {a b c : A}
  include s

  @[hott] theorem mul_le_mul_of_nonpos_left (H : b ≤ a) (Hc : c ≤ 0) : c * a ≤ c * b :=
  have Hc' : -c ≥ 0, from iff.mpr (neg_nonneg_iff_nonpos _) Hc,
  have H1 : -c * b ≤ -c * a, from mul_le_mul_of_nonneg_left H Hc',
  have H2 : -(c * b) ≤ -(c * a),
    begin
      rwr [←neg_mul_eq_neg_mul, ←neg_mul_eq_neg_mul] at H1,
      exact H1
    end,
  le_of_neg_le_neg H2

  @[hott] theorem mul_le_mul_of_nonpos_right (H : b ≤ a) (Hc : c ≤ 0) : a * c ≤ b * c :=
  have Hc' : -c ≥ 0, from iff.mpr (neg_nonneg_iff_nonpos _) Hc,
  have H1 : b * -c ≤ a * -c, from mul_le_mul_of_nonneg_right H Hc',
  have H2 : -(b * c) ≤ -(a * c),
    begin
      rwr [←neg_mul_eq_mul_neg, ←neg_mul_eq_mul_neg] at H1,
      exact H1
    end,
  le_of_neg_le_neg H2

  @[hott] theorem mul_nonneg_of_nonpos_of_nonpos (Ha : a ≤ 0) (Hb : b ≤ 0) : 0 ≤ a * b :=
  begin
    have H : 0 * b ≤ a * b, from mul_le_mul_of_nonpos_right Ha Hb,
    rwr zero_mul at H,
    exact H
  end

  @[hott] def mul_lt_mul_of_neg_left (H : b < a) (Hc : c < 0) : c * a < c * b :=
  have Hc' : -c > 0, from iff.mpr (neg_pos_iff_neg _) Hc,
  have H1 : -c * b < -c * a, from mul_lt_mul_of_pos_left H Hc',
  have H2 : -(c * b) < -(c * a),
    begin
      rwr [←neg_mul_eq_neg_mul, ←neg_mul_eq_neg_mul] at H1,
      exact H1
    end,
  lt_of_neg_lt_neg H2

  @[hott] def mul_lt_mul_of_neg_right (H : b < a) (Hc : c < 0) : a * c < b * c :=
  have Hc' : -c > 0, from iff.mpr (neg_pos_iff_neg _) Hc,
  have H1 : b * -c < a * -c, from mul_lt_mul_of_pos_right H Hc',
  have H2 : -(b * c) < -(a * c),
    begin
      rwr [←neg_mul_eq_mul_neg, ←neg_mul_eq_mul_neg] at H1,
      exact H1
    end,
  lt_of_neg_lt_neg H2

  @[hott] def mul_pos_of_neg_of_neg (Ha : a < 0) (Hb : b < 0) : 0 < a * b :=
  begin
    have H : 0 * b < a * b, from mul_lt_mul_of_neg_right Ha Hb,
    rwr zero_mul at H,
    exact H
  end

end

-- TODO: we can eliminate mul_pos_of_pos, but now it is not worth the effort to redeclare the
-- class instance
@[hott, class] structure linear_ordered_ring (A : Type _)
    extends ordered_ring A, linear_strong_order_pair A :=
  (zero_lt_one : lt zero one)

@[hott, instance, reducible] def linear_ordered_ring.to_linear_ordered_semiring
  [s : linear_ordered_ring A] : linear_ordered_semiring A :=
{ mul_zero                   := mul_zero,
  zero_mul                   := zero_mul,
  add_left_cancel            := @add.left_cancel A _,
  add_right_cancel           := @add.right_cancel A _,
  le_of_add_le_add_left      := @le_of_add_le_add_left A _,
  mul_le_mul_of_nonneg_left  := @mul_le_mul_of_nonneg_left A _,
  mul_le_mul_of_nonneg_right := @mul_le_mul_of_nonneg_right A _,
  mul_lt_mul_of_pos_left     := @mul_lt_mul_of_pos_left A _,
  mul_lt_mul_of_pos_right    := @mul_lt_mul_of_pos_right A _,
  le_total                   := linear_ordered_ring.le_total,
  lt_of_add_lt_add_left      := @lt_of_add_lt_add_left A _, ..s }

@[hott, class] structure linear_ordered_comm_ring (A : Type _) extends
  linear_ordered_ring A, comm_monoid A

@[hott] def linear_ordered_comm_ring.eq_zero_sum_eq_zero_of_mul_eq_zero
  [s : linear_ordered_comm_ring A] {a b : A} (H : a * b = 0) : a = 0 ⊎ b = 0 :=
lt.by_cases
  (assume Ha : 0 < a,
    lt.by_cases
      (assume Hb : 0 < b,
        begin
          have H1 : 0 < a * b, from mul_pos Ha Hb,
          rwr H at H1,
          apply absurd_a_lt_a H1
        end)
      (assume Hb : 0 = b, sum.inr (Hb⁻¹))
      (assume Hb : 0 > b,
        begin
          have H1 : 0 > a * b, from mul_neg_of_pos_of_neg Ha Hb,
          rwr H at H1,
          apply absurd_a_lt_a H1
        end))
  (assume Ha : 0 = a, sum.inl (Ha⁻¹))
  (assume Ha : 0 > a,
    lt.by_cases
      (assume Hb : 0 < b,
        begin
          have H1 : 0 > a * b, from mul_neg_of_neg_of_pos Ha Hb,
          rwr H at H1,
          apply absurd_a_lt_a H1
        end)
      (assume Hb : 0 = b, sum.inr (Hb⁻¹))
      (assume Hb : 0 > b,
        begin
          have H1 : 0 < a * b, from mul_pos_of_neg_of_neg Ha Hb,
          rwr H at H1,
          apply absurd_a_lt_a H1
        end))

-- Linearity implies no zero divisors. Doesn't need commutativity.
@[hott, instance, reducible] def linear_ordered_comm_ring.to_integral_domain
    [s : linear_ordered_comm_ring A] : integral_domain A :=
{ eq_zero_sum_eq_zero_of_mul_eq_zero :=
     @linear_ordered_comm_ring.eq_zero_sum_eq_zero_of_mul_eq_zero A s, ..s }

section
variable [s : linear_ordered_ring A]
variables (a b c : A)
include s

@[hott] theorem mul_self_nonneg : a * a ≥ 0 :=
sum.elim (le.total 0 a)
  (assume H : a ≥ 0, mul_nonneg H H)
  (assume H : a ≤ 0, mul_nonneg_of_nonpos_of_nonpos H H)

@[hott] theorem zero_le_one : 0 ≤ (1:A) := by rwr [←one_mul (1 : A)]; exact mul_self_nonneg 1

@[hott] theorem pos_prod_pos_sum_neg_prod_neg_of_mul_pos {a b : A} (Hab : a * b > 0) :
  (a > 0 × b > 0) ⊎ (a < 0 × b < 0) :=
lt.by_cases
  (assume Ha : 0 < a,
    lt.by_cases
      (assume Hb : 0 < b, sum.inl (pair Ha Hb))
      (assume Hb : 0 = b,
        begin
          rwr [←Hb, mul_zero] at Hab,
          apply absurd_a_lt_a Hab
        end)
      (assume Hb : b < 0,
        absurd Hab (lt.asymm (mul_neg_of_pos_of_neg Ha Hb))))
  (assume Ha : 0 = a,
    begin
      rwr [←Ha, zero_mul] at Hab,
      apply absurd_a_lt_a Hab
    end)
  (assume Ha : a < 0,
    lt.by_cases
      (assume Hb : 0 < b,
        absurd Hab (lt.asymm (mul_neg_of_neg_of_pos Ha Hb)))
      (assume Hb : 0 = b,
        begin
          rwr [←Hb, mul_zero] at Hab,
          apply absurd_a_lt_a Hab
        end)
      (assume Hb : b < 0, sum.inr (pair Ha Hb)))

@[hott] theorem gt_of_mul_lt_mul_neg_left {a b c : A} (H : c * a < c * b) (Hc : c ≤ 0) : a > b :=
have nhc : -c ≥ 0, from neg_nonneg_of_nonpos Hc,
have H2 : -(c * b) < -(c * a), from iff.mpr (neg_lt_neg_iff_lt _ _) H,
have H3 : (-c) * b < (-c) * a, from calc
  (-c) * b = - (c * b)    : by rwr neg_mul_eq_neg_mul
       ... < -(c * a)     : H2
       ... = (-c) * a     : by rwr neg_mul_eq_neg_mul,
lt_of_mul_lt_mul_left H3 nhc

@[hott] theorem zero_gt_neg_one : - 1 < (0:A) :=
by rwr ←neg_zero; exact neg_lt_neg zero_lt_one

@[hott] theorem le_of_mul_le_of_ge_one {a b c : A} (H : a * c ≤ b) (Hb : b ≥ 0) (Hc : c ≥ 1) :
a ≤ b :=
have H' : a * c ≤ b * c, from calc
  a * c ≤ b : H
    ... = b * 1 : by rwr mul_one
    ... ≤ b * c : mul_le_mul_of_nonneg_left Hc Hb,
le_of_mul_le_mul_right H' (lt_of_lt_of_le zero_lt_one Hc)

@[hott] theorem nonneg_le_nonneg_of_squares_le {a b : A} (Ha : a ≥ 0) (Hb : b ≥ 0)
  (H : a * a ≤ b * b) : a ≤ b :=
begin
  apply le_of_not_gt,
  intro Hab,
  let Hposa := lt_of_le_of_lt Hb Hab,
  let H' := calc
    b * b ≤ a * b : mul_le_mul_of_nonneg_right (le_of_lt Hab) Hb
    ... < a * a : mul_lt_mul_of_pos_left Hab Hposa,
  apply (not_le_of_gt H') H
end
end

/- TODO: Isabelle's library has all kinds of cancelation rules for the simplifier.
   Search on mult_le_cancel_right1 in Rings.thy. -/

@[hott] structure decidable_linear_ordered_comm_ring (A : Type _) extends linear_ordered_comm_ring A,
    decidable_linear_ordered_mul_ab_group A renaming
  mul→add mul_assoc→add_assoc one→zero one_mul→zero_add mul_one→add_zero inv→neg
  mul_left_inv→add_left_inv mul_comm→add_comm mul_le_mul_left→add_le_add_left
  mul_lt_mul_left→add_lt_add_left

/- we make it a class now (and not as part of the structure) to avoid
  ordered_semiring.to_ordered_mul_cancel_comm_monoid to be an instance -/
attribute [class] decidable_linear_ordered_comm_ring

@[hott, instance, reducible] def linear_ordered_comm_ring_of_decidable_linear_ordered_comm_ring
  (A : Type _) [H : decidable_linear_ordered_comm_ring A] : linear_ordered_comm_ring A :=
@decidable_linear_ordered_comm_ring.to_linear_ordered_comm_ring A H

@[hott, instance, reducible]
def decidable_linear_ordered_ab_group_of_decidable_linear_ordered_comm_ring
  (A : Type _) [H : decidable_linear_ordered_comm_ring A] : decidable_linear_ordered_ab_group A :=
@decidable_linear_ordered_comm_ring.to_decidable_linear_ordered_mul_ab_group A H

section
variable [s : decidable_linear_ordered_comm_ring A]
variables {a b c : A}
include s

@[hott] def sign (a : A) : A := lt.cases a 0 (- 1) 0 1

@[hott] theorem sign_of_neg (H : a < 0) : sign a = - 1 := lt.cases_of_lt H

@[hott] theorem sign_zero : sign 0 = (0:A) := lt.cases_of_eq rfl

@[hott] theorem sign_of_pos (H : a > 0) : sign a = 1 := lt.cases_of_gt H

@[hott] theorem sign_one : sign 1 = (1:A) := sign_of_pos zero_lt_one

@[hott] theorem sign_neg_one : sign (- 1) = -(1:A) := sign_of_neg (neg_neg_of_pos zero_lt_one)

@[hott] theorem sign_sign (a : A) : sign (sign a) = sign a :=
lt.by_cases
  (assume H : a > 0,
    calc
      sign (sign a) = sign 1 : by rwr (sign_of_pos H)
                ... = 1      : by rwr sign_one
                ... = sign a : by rwr (sign_of_pos H))
  (assume H : 0 = a,
    calc
      sign (sign a) = sign (sign 0) : by rwr H
                ... = sign 0        : by rwr ap sign sign_zero
                ... = sign a        : by rwr ←H)
  (assume H : a < 0,
    calc
      sign (sign a) = sign (- 1) : by rwr (sign_of_neg H)
                ... = - 1        : by rwr sign_neg_one
                ... = sign a     : by rwr (sign_of_neg H))

@[hott] theorem pos_of_sign_eq_one (H : sign a = 1) : a > 0 :=
lt.by_cases
  (assume H1 : 0 < a, H1)
  (assume H1 : 0 = a,
    begin
      rwr [←H1, sign_zero] at H,
      apply absurd H zero_ne_one
    end)
  (assume H1 : 0 > a,
    have H2 : - 1 = 1 :> A, from (sign_of_neg H1)⁻¹ ⬝ H,
    absurd ((eq_zero_of_neg_eq H2)⁻¹ᵖ) zero_ne_one)

@[hott] theorem eq_zero_of_sign_eq_zero (H : sign a = 0) : a = 0 :=
lt.by_cases
  (assume H1 : 0 < a,
    absurd (H⁻¹ ⬝ sign_of_pos H1) zero_ne_one)
  (assume H1 : 0 = a, H1⁻¹)
  (assume H1 : 0 > a,
    have H2 : 0 = - 1 :> A, from H⁻¹ ⬝ sign_of_neg H1,
    have H3 : 1 = 0 :> A, from eq_neg_of_eq_neg H2 ⬝ neg_zero,
    absurd (H3⁻¹) zero_ne_one)

@[hott] theorem neg_of_sign_eq_neg_one (H : sign a = - 1) : a < 0 :=
lt.by_cases
  (assume H1 : 0 < a,
    have H2 : - 1 = 1 :> A, from H⁻¹ ⬝ (sign_of_pos H1),
    absurd ((eq_zero_of_neg_eq H2)⁻¹) zero_ne_one)
  (assume H1 : 0 = a,
    have H2 : 0 = - 1 :> A,
      begin
        rwr [←H1, sign_zero] at H,
        exact H
      end,
    have H3 : 1 = 0 :> A, from eq_neg_of_eq_neg H2 ⬝ neg_zero,
    absurd (H3⁻¹) zero_ne_one)
  (assume H1 : 0 > a, H1)

@[hott] theorem sign_neg (a : A) : sign (-a) = -(sign a) :=
lt.by_cases
  (assume H1 : 0 < a,
    calc
      sign (-a) = - 1        : sign_of_neg (neg_neg_of_pos H1)
            ... = -(sign a) : by rwr (sign_of_pos H1))
  (assume H1 : 0 = a,
    calc
      sign (-a) = sign (-0) : by rwr ←H1
            ... = sign 0    : by rwr neg_zero
            ... = 0         : by rwr sign_zero
            ... = -0        : by rwr neg_zero
            ... = -(sign 0) : by rwr sign_zero
            ... = -(sign a) : by rwr ←H1)
  (assume H1 : 0 > a,
    calc
      sign (-a) = 1         : sign_of_pos (neg_pos_of_neg H1)
            ... = -(- 1)    : by rwr neg_neg
            ... = -(sign a) : by rwr sign_of_neg H1)

@[hott] theorem sign_mul (a b : A) : sign (a * b) = sign a * sign b :=
hott.algebra.lt.by_cases
  (assume z_lt_a : 0 < a,
    lt.by_cases
     (assume z_lt_b : 0 < b,
       by rwr [sign_of_pos z_lt_a, sign_of_pos z_lt_b,
                   sign_of_pos (mul_pos z_lt_a z_lt_b), one_mul])
     (assume z_eq_b : 0 = b, by rwr [←z_eq_b, mul_zero, sign_zero, mul_zero])
     (assume z_gt_b : 0 > b,
       by rwr [sign_of_pos z_lt_a, sign_of_neg z_gt_b,
                   sign_of_neg (mul_neg_of_pos_of_neg z_lt_a z_gt_b), one_mul]))
  (assume z_eq_a : 0 = a, by rwr [←z_eq_a, zero_mul, sign_zero, zero_mul])
  (assume z_gt_a : 0 > a,
    lt.by_cases
     (assume z_lt_b : 0 < b,
       by rwr [sign_of_neg z_gt_a, sign_of_pos z_lt_b,
                   sign_of_neg (mul_neg_of_neg_of_pos z_gt_a z_lt_b), mul_one])
     (assume z_eq_b : 0 = b, by rwr [←z_eq_b, mul_zero, sign_zero, mul_zero])
     (assume z_gt_b : 0 > b,
       by rwr [sign_of_neg z_gt_a, sign_of_neg z_gt_b,
                   sign_of_pos (mul_pos_of_neg_of_neg z_gt_a z_gt_b),
                   neg_mul_neg, one_mul]))

@[hott] theorem abs_eq_sign_mul (a : A) : abs a = sign a * a :=
lt.by_cases
  (assume H1 : 0 < a,
    calc
      abs a = a          : abs_of_pos H1
      ... = 1 * a        : by rwr one_mul
      ... = sign a * a   : by rwr (sign_of_pos H1))
  (assume H1 : 0 = a,
    calc
      abs a = abs 0    : by rwr ←H1
      ... = 0          : abs_zero
      ... = 0 * a      : by rwr zero_mul
      ... = sign 0 * a : by rwr sign_zero
      ... = sign a * a : by rwr ←H1)
  (assume H1 : a < 0,
    calc
      abs a = -a         : abs_of_neg H1
        ... = - 1 * a     : by rwr neg_eq_neg_one_mul
        ... = sign a * a : by rwr (sign_of_neg H1))

@[hott] theorem eq_sign_mul_abs (a : A) : a = sign a * abs a :=
lt.by_cases
  (assume H1 : 0 < a,
    calc
      a = abs a              : by rwr abs_of_pos H1
        ... = 1 * abs a      : by rwr one_mul
        ... = sign a * abs a : by rwr (sign_of_pos H1))
  (assume H1 : 0 = a,
    calc
      a = 0                  : H1⁻¹
        ... = 0 * abs a      : by rwr zero_mul
        ... = sign 0 * abs a : by rwr sign_zero
        ... = sign a * abs a : by rwr H1)
  (assume H1 : a < 0,
    calc
      a = -(-a)              : by rwr neg_neg
        ... = -abs a         : by rwr (abs_of_neg H1)
        ... = - 1 * abs a     : by rwr neg_eq_neg_one_mul
        ... = sign a * abs a : by rwr (sign_of_neg H1))

-- @[hott] theorem abs_dvd_iff (a b : A) : abs a ∣ b ↔ a ∣ b :=
-- abs.by_cases iff.rfl (neg_dvd_iff_dvd _ _)

-- @[hott] theorem abs_dvd_of_dvd {a b : A} : a ∣ b → abs a ∣ b :=
--   iff.mpr !abs_dvd_iff

-- @[hott] theorem dvd_abs_iff (a b : A) : a ∣ abs b ↔ a ∣ b :=
-- abs.by_cases iff.rfl !dvd_neg_iff_dvd

-- @[hott] theorem dvd_abs_of_dvd {a b : A} : a ∣ b → a ∣ abs b :=
--   iff.mpr !dvd_abs_iff

-- @[hott] theorem abs_mul (a b : A) : abs (a * b) = abs a * abs b :=
-- sum.elim (le.total 0 a)
--   (assume H1 : 0 ≤ a,
--     sum.elim (le.total 0 b)
--       (assume H2 : 0 ≤ b,
--         calc
--           abs (a * b) = a * b         : abs_of_nonneg (mul_nonneg H1 H2)
--                   ... = abs a * b     : by rwr (abs_of_nonneg H1)
--                   ... = abs a * abs b : by rwr (abs_of_nonneg H2))
--       (assume H2 : b ≤ 0,
--         calc
--           abs (a * b) = -(a * b)      : abs_of_nonpos (mul_nonpos_of_nonneg_of_nonpos H1 H2)
--                   ... = a * -b        : by rwr neg_mul_eq_mul_neg
--                   ... = abs a * -b    : by rwr (abs_of_nonneg H1)
--                   ... = abs a * abs b : by rwr (abs_of_nonpos H2)))
--   (assume H1 : a ≤ 0,
--     sum.elim (le.total 0 b)
--       (assume H2 : 0 ≤ b,
--         calc
--           abs (a * b) = -(a * b)      : abs_of_nonpos (mul_nonpos_of_nonpos_of_nonneg H1 H2)
--                   ... = -a * b        : by rwr neg_mul_eq_neg_mul
--                   ... = abs a * b     : by rwr (abs_of_nonpos H1)
--                   ... = abs a * abs b : by rwr (abs_of_nonneg H2))
--       (assume H2 : b ≤ 0,
--         calc
--           abs (a * b) = a * b         : abs_of_nonneg (mul_nonneg_of_nonpos_of_nonpos H1 H2)
--                   ... = -a * -b       : by rwr neg_mul_neg
--                   ... = abs a * -b    : by rwr (abs_of_nonpos H1)
--                   ... = abs a * abs b : by rwr (abs_of_nonpos H2)))

-- @[hott] theorem abs_mul_abs_self (a : A) : abs a * abs a = a * a :=
-- abs.by_cases rfl !neg_mul_neg

-- @[hott] theorem abs_mul_self (a : A) : abs (a * a) = a * a :=
-- by rwr [abs_mul, abs_mul_abs_self]

-- @[hott] theorem sub_le_of_abs_sub_le_left (H : abs (a - b) ≤ c) : b - c ≤ a :=
--   if Hz : 0 ≤ a - b then
--     (calc
--       a ≥ b : (iff.mp (sub_nonneg_iff_le _ _)) Hz
--     ... ≥ b - c : sub_le_of_nonneg _ (le.trans !abs_nonneg H))
--   else
--     (have Habs : b - a ≤ c, by rwr [abs_of_neg (lt_of_not_ge Hz), neg_sub] at H; apply H,
--      have Habs' : b ≤ c + a, from (iff.mpr !le_add_iff_sub_right_le) Habs,
--      (iff.mp !le_add_iff_sub_left_le) Habs')

-- @[hott] theorem sub_le_of_abs_sub_le_right (H : abs (a - b) ≤ c) : a - c ≤ b :=
--   sub_le_of_abs_sub_le_left (!abs_sub ▸ H)

-- @[hott] theorem sub_lt_of_abs_sub_lt_left (H : abs (a - b) < c) : b - c < a :=
--   if Hz : 0 ≤ a - b then
--     (calc
--       a ≥ b : (iff.mp (sub_nonneg_iff_le _ _)) Hz
--     ... > b - c : sub_lt_of_pos _ (lt_of_le_of_lt !abs_nonneg H))
--   else
--     (have Habs : b - a < c, by rwr [abs_of_neg (lt_of_not_ge Hz), neg_sub] at H; apply H,
--      have Habs' : b < c + a, from lt_add_of_sub_lt_right Habs,
--      sub_lt_left_of_lt_add Habs')

-- @[hott] theorem sub_lt_of_abs_sub_lt_right (H : abs (a - b) < c) : a - c < b :=
--   sub_lt_of_abs_sub_lt_left (!abs_sub ▸ H)

-- @[hott] theorem abs_sub_square (a b : A) : abs (a - b) * abs (a - b) = a * a + b * b - (1 + 1) * a * b :=
--   begin
--     rwr [abs_mul_abs_self, *mul_sub_left_distrib, *mul_sub_right_distrib,
--              sub_eq_add_neg (a*b), sub_add_eq_sub_sub, sub_neg_eq_add, *right_distrib, sub_add_eq_sub_sub, *one_mul,
--              *add.assoc, {_ + b * b}add.comm, *sub_eq_add_neg],
--     rwr [{a*a + b*b}add.comm],
--     rwr [mul.comm b a, *add.assoc]
--   end

-- @[hott] theorem abs_abs_sub_abs_le_abs_sub (a b : A) : abs (abs a - abs b) ≤ abs (a - b) :=
-- begin
--   apply nonneg_le_nonneg_of_squares_le,
--   repeat apply abs_nonneg,
--   rwr [*abs_sub_square, *abs_abs, *abs_mul_abs_self],
--   apply sub_le_sub_left,
--   rwr *mul.assoc,
--   apply mul_le_mul_of_nonneg_left,
--   rwr ←abs_mul,
--   apply le_abs_self,
--   apply le_of_lt,
--   apply add_pos,
--   apply zero_lt_one,
--   apply zero_lt_one
-- end

end

/- TODO: Multiplication and one, starting with mult_right_le_one_le. -/

-- namespace norm_num

-- @[hott] theorem pos_bit0_helper [s : linear_ordered_semiring A] (a : A) (H : a > 0) : bit0 a > 0 :=
--   by rwr ↑bit0; apply add_pos H H

-- @[hott] theorem nonneg_bit0_helper [s : linear_ordered_semiring A] (a : A) (H : a ≥ 0) : bit0 a ≥ 0 :=
--   by rwr ↑bit0; apply add_nonneg H H

-- @[hott] theorem pos_bit1_helper [s : linear_ordered_semiring A] (a : A) (H : a ≥ 0) : bit1 a > 0 :=
--   begin
--     rwr ↑bit1,
--     apply add_pos_of_nonneg_of_pos,
--     apply nonneg_bit0_helper _ H,
--     apply zero_lt_one
--   end

-- @[hott] theorem nonneg_bit1_helper [s : linear_ordered_semiring A] (a : A) (H : a ≥ 0) : bit1 a ≥ 0 :=
--   by apply le_of_lt; apply pos_bit1_helper _ H

-- @[hott] theorem nonzero_of_pos_helper [s : linear_ordered_semiring A] (a : A) (H : a > 0) : a ≠ 0 :=
--   ne_of_gt H

-- @[hott] theorem nonzero_of_neg_helper [s : linear_ordered_ring A] (a : A) (H : a ≠ 0) : -a ≠ 0 :=
--   begin intro Ha, apply H, apply eq_of_neg_eq_neg, rwr neg_zero, exact Ha end

-- end norm_num
end algebra
end hott


/-
Copyright (c) 2022 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash

! This file was ported from Lean 3 source module measure_theory.covering.density_theorem
! 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.MeasureTheory.Measure.Doubling
import Mathbin.MeasureTheory.Covering.Vitali
import Mathbin.MeasureTheory.Covering.Differentiation

/-!
# Doubling measures and Lebesgue's density theorem

Lebesgue's density theorem states that given a set `S` in a sigma compact metric space with
locally-finite doubling measure `μ` then for almost all points `x` in `S`, for any sequence of
closed balls `B₀, B₁, B₂, ...` containing `x`, the limit `μ (S ∩ Bⱼ) / μ (Bⱼ) → 1` as `j → ∞`.

In this file we combine general results about existence of Vitali families for doubling measures
with results about differentiation along a Vitali family to obtain an explicit form of Lebesgue's
density theorem.

## Main results
  * `is_doubling_measure.ae_tendsto_measure_inter_div`: a version of Lebesgue's density theorem for
  sequences of balls converging on a point but whose centres are not required to be fixed.

-/

noncomputable section

open Set Filter Metric MeasureTheory TopologicalSpace

open NNReal Topology

namespace IsDoublingMeasure

variable {α : Type _} [MetricSpace α] [MeasurableSpace α] (μ : Measure α) [IsDoublingMeasure μ]

section

variable [SecondCountableTopology α] [BorelSpace α] [IsLocallyFiniteMeasure μ]

open Topology

/-- A Vitali family in a space with a doubling measure, designed so that the sets at `x` contain
all `closed_ball y r` when `dist x y ≤ K * r`. -/
irreducible_def vitaliFamily (K : ℝ) : VitaliFamily μ :=
  by
  /- the Vitali covering theorem gives a family that works well at small scales, thanks to the
    doubling property. We enlarge this family to add large sets, to make sure that all balls and not
    only small ones belong to the family, for convenience. -/
  let R := scaling_scale_of μ (max (4 * K + 3) 3)
  have Rpos : 0 < R := scaling_scale_of_pos _ _
  have A :
    ∀ x : α,
      ∃ᶠ r in 𝓝[>] (0 : ℝ),
        μ (closed_ball x (3 * r)) ≤
          scaling_constant_of μ (max (4 * K + 3) 3) * μ (closed_ball x r) :=
    by
    intro x
    apply frequently_iff.2 fun U hU => _
    obtain ⟨ε, εpos, hε⟩ := mem_nhdsWithin_Ioi_iff_exists_Ioc_subset.1 hU
    refine' ⟨min ε R, hε ⟨lt_min εpos Rpos, min_le_left _ _⟩, _⟩
    exact
      measure_mul_le_scaling_constant_of_mul μ ⟨zero_lt_three, le_max_right _ _⟩ (min_le_right _ _)
  exact
    (Vitali.vitaliFamily μ (scaling_constant_of μ (max (4 * K + 3) 3)) A).enlarge (R / 4)
      (by linarith)
#align is_doubling_measure.vitali_family IsDoublingMeasure.vitaliFamily

/-- In the Vitali family `is_doubling_measure.vitali_family K`, the sets based at `x` contain all
balls `closed_ball y r` when `dist x y ≤ K * r`. -/
theorem closedBall_mem_vitaliFamily_of_dist_le_mul {K : ℝ} {x y : α} {r : ℝ} (h : dist x y ≤ K * r)
    (rpos : 0 < r) : closedBall y r ∈ (vitaliFamily μ K).setsAt x :=
  by
  let R := scaling_scale_of μ (max (4 * K + 3) 3)
  simp only [VitaliFamily, VitaliFamily.enlarge, Vitali.vitaliFamily, mem_union, mem_set_of_eq,
    is_closed_ball, true_and_iff, (nonempty_ball.2 rpos).mono ball_subset_interior_closed_ball,
    measurableSet_closedBall]
  /- The measure is doubling on scales smaller than `R`. Therefore, we treat differently small
    and large balls. For large balls, this follows directly from the enlargement we used in the
    definition. -/
  by_cases H : closed_ball y r ⊆ closed_ball x (R / 4)
  swap; · exact Or.inr H
  left
  /- For small balls, there is the difficulty that `r` could be large but still the ball could be
    small, if the annulus `{y | ε ≤ dist y x ≤ R/4}` is empty. We split between the cases `r ≤ R`
    and `r < R`, and use the doubling for the former and rough estimates for the latter. -/
  rcases le_or_lt r R with (hr | hr)
  · refine' ⟨(K + 1) * r, _⟩
    constructor
    · apply closed_ball_subset_closed_ball'
      rw [dist_comm]
      linarith
    · have I1 : closed_ball x (3 * ((K + 1) * r)) ⊆ closed_ball y ((4 * K + 3) * r) :=
        by
        apply closed_ball_subset_closed_ball'
        linarith
      have I2 : closed_ball y ((4 * K + 3) * r) ⊆ closed_ball y (max (4 * K + 3) 3 * r) :=
        by
        apply closed_ball_subset_closed_ball
        exact mul_le_mul_of_nonneg_right (le_max_left _ _) rpos.le
      apply (measure_mono (I1.trans I2)).trans
      exact
        measure_mul_le_scaling_constant_of_mul _ ⟨zero_lt_three.trans_le (le_max_right _ _), le_rfl⟩
          hr
  · refine' ⟨R / 4, H, _⟩
    have : closed_ball x (3 * (R / 4)) ⊆ closed_ball y r :=
      by
      apply closed_ball_subset_closed_ball'
      have A : y ∈ closed_ball y r := mem_closed_ball_self rpos.le
      have B := mem_closed_ball'.1 (H A)
      linarith
    apply (measure_mono this).trans _
    refine' le_mul_of_one_le_left (zero_le _) _
    exact ENNReal.one_le_coe_iff.2 (le_max_right _ _)
#align is_doubling_measure.closed_ball_mem_vitali_family_of_dist_le_mul IsDoublingMeasure.closedBall_mem_vitaliFamily_of_dist_le_mul

theorem tendsto_closedBall_filterAt {K : ℝ} {x : α} {ι : Type _} {l : Filter ι} (w : ι → α)
    (δ : ι → ℝ) (δlim : Tendsto δ l (𝓝[>] 0)) (xmem : ∀ᶠ j in l, x ∈ closedBall (w j) (K * δ j)) :
    Tendsto (fun j => closedBall (w j) (δ j)) l ((vitaliFamily μ K).filterAt x) :=
  by
  refine' (VitaliFamily μ K).tendsto_filterAt_iff.mpr ⟨_, fun ε hε => _⟩
  · filter_upwards [xmem, δlim self_mem_nhdsWithin]with j hj h'j
    exact closed_ball_mem_vitali_family_of_dist_le_mul μ hj h'j
  · by_cases l.ne_bot
    swap
    · simp [not_ne_bot.1 h]
    have hK : 0 ≤ K := by
      skip
      rcases(xmem.and (δlim self_mem_nhdsWithin)).exists with ⟨j, hj, h'j⟩
      have : 0 ≤ K * δ j := nonempty_closed_ball.1 ⟨x, hj⟩
      exact (mul_nonneg_iff_left_nonneg_of_pos (mem_Ioi.1 h'j)).1 this
    have δpos := eventually_mem_of_tendsto_nhdsWithin δlim
    replace δlim := tendsto_nhds_of_tendsto_nhdsWithin δlim
    replace hK : 0 < K + 1
    · linarith
    apply (((metric.tendsto_nhds.mp δlim _ (div_pos hε hK)).And δpos).And xmem).mono
    rintro j ⟨⟨hjε, hj₀ : 0 < δ j⟩, hx⟩ y hy
    replace hjε : (K + 1) * δ j < ε := by
      simpa [abs_eq_self.mpr hj₀.le] using (lt_div_iff' hK).mp hjε
    simp only [mem_closed_ball] at hx hy⊢
    linarith [dist_triangle_right y x (w j)]
#align is_doubling_measure.tendsto_closed_ball_filter_at IsDoublingMeasure.tendsto_closedBall_filterAt

end

section Applications

variable [SecondCountableTopology α] [BorelSpace α] [IsLocallyFiniteMeasure μ] {E : Type _}
  [NormedAddCommGroup E]

/-- A version of *Lebesgue's density theorem* for a sequence of closed balls whose centers are
not required to be fixed.

See also `besicovitch.ae_tendsto_measure_inter_div`. -/
theorem ae_tendsto_measure_inter_div (S : Set α) (K : ℝ) :
    ∀ᵐ x ∂μ.restrict S,
      ∀ {ι : Type _} {l : Filter ι} (w : ι → α) (δ : ι → ℝ) (δlim : Tendsto δ l (𝓝[>] 0))
        (xmem : ∀ᶠ j in l, x ∈ closedBall (w j) (K * δ j)),
        Tendsto (fun j => μ (S ∩ closedBall (w j) (δ j)) / μ (closedBall (w j) (δ j))) l (𝓝 1) :=
  by
  filter_upwards [(VitaliFamily μ K).ae_tendsto_measure_inter_div
      S]with x hx ι l w δ δlim xmem using hx.comp (tendsto_closed_ball_filter_at μ _ _ δlim xmem)
#align is_doubling_measure.ae_tendsto_measure_inter_div IsDoublingMeasure.ae_tendsto_measure_inter_div

/-- A version of *Lebesgue differentiation theorem* for a sequence of closed balls whose
centers are not required to be fixed. -/
theorem ae_tendsto_average_norm_sub {f : α → E} (hf : Integrable f μ) (K : ℝ) :
    ∀ᵐ x ∂μ,
      ∀ {ι : Type _} {l : Filter ι} (w : ι → α) (δ : ι → ℝ) (δlim : Tendsto δ l (𝓝[>] 0))
        (xmem : ∀ᶠ j in l, x ∈ closedBall (w j) (K * δ j)),
        Tendsto (fun j => ⨍ y in closedBall (w j) (δ j), ‖f y - f x‖ ∂μ) l (𝓝 0) :=
  by
  filter_upwards [(VitaliFamily μ K).ae_tendsto_average_norm_sub
      hf]with x hx ι l w δ δlim xmem using hx.comp (tendsto_closed_ball_filter_at μ _ _ δlim xmem)
#align is_doubling_measure.ae_tendsto_average_norm_sub IsDoublingMeasure.ae_tendsto_average_norm_sub

/-- A version of *Lebesgue differentiation theorem* for a sequence of closed balls whose
centers are not required to be fixed. -/
theorem ae_tendsto_average [NormedSpace ℝ E] [CompleteSpace E] {f : α → E} (hf : Integrable f μ)
    (K : ℝ) :
    ∀ᵐ x ∂μ,
      ∀ {ι : Type _} {l : Filter ι} (w : ι → α) (δ : ι → ℝ) (δlim : Tendsto δ l (𝓝[>] 0))
        (xmem : ∀ᶠ j in l, x ∈ closedBall (w j) (K * δ j)),
        Tendsto (fun j => ⨍ y in closedBall (w j) (δ j), f y ∂μ) l (𝓝 (f x)) :=
  by
  filter_upwards [(VitaliFamily μ K).ae_tendsto_average
      hf]with x hx ι l w δ δlim xmem using hx.comp (tendsto_closed_ball_filter_at μ _ _ δlim xmem)
#align is_doubling_measure.ae_tendsto_average IsDoublingMeasure.ae_tendsto_average

end Applications

end IsDoublingMeasure


/-
Copyright (c) 2022 Joseph Myers. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joseph Myers

! This file was ported from Lean 3 source module geometry.euclidean.sphere.second_inter
! 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.Geometry.Euclidean.Sphere.Basic

/-!
# Second intersection of a sphere and a line

This file defines and proves basic results about the second intersection of a sphere with a line
through a point on that sphere.

## Main definitions

* `euclidean_geometry.sphere.second_inter` is the second intersection of a sphere with a line
  through a point on that sphere.

-/

noncomputable section

open RealInnerProductSpace

namespace EuclideanGeometry

variable {V : Type _} {P : Type _} [NormedAddCommGroup V] [InnerProductSpace ℝ V] [MetricSpace P]
  [NormedAddTorsor V P]

include V

/-- The second intersection of a sphere with a line through a point on that sphere; that point
if it is the only point of intersection of the line with the sphere. The intended use of this
definition is when `p ∈ s`; the definition does not use `s.radius`, so in general it returns
the second intersection with the sphere through `p` and with center `s.center`. -/
def Sphere.secondInter (s : Sphere P) (p : P) (v : V) : P :=
  (-2 * ⟪v, p -ᵥ s.center⟫ / ⟪v, v⟫) • v +ᵥ p
#align euclidean_geometry.sphere.second_inter EuclideanGeometry.Sphere.secondInter

/-- The distance between `second_inter` and the center equals the distance between the original
point and the center. -/
@[simp]
theorem Sphere.secondInter_dist (s : Sphere P) (p : P) (v : V) :
    dist (s.secondInter p v) s.center = dist p s.center :=
  by
  rw [sphere.second_inter]
  by_cases hv : v = 0; · simp [hv]
  rw [dist_smul_vadd_eq_dist _ _ hv]
  exact Or.inr rfl
#align euclidean_geometry.sphere.second_inter_dist EuclideanGeometry.Sphere.secondInter_dist

/-- The point given by `second_inter` lies on the sphere. -/
@[simp]
theorem Sphere.secondInter_mem {s : Sphere P} {p : P} (v : V) : s.secondInter p v ∈ s ↔ p ∈ s := by
  simp_rw [mem_sphere, sphere.second_inter_dist]
#align euclidean_geometry.sphere.second_inter_mem EuclideanGeometry.Sphere.secondInter_mem

variable (V)

/-- If the vector is zero, `second_inter` gives the original point. -/
@[simp]
theorem Sphere.secondInter_zero (s : Sphere P) (p : P) : s.secondInter p (0 : V) = p := by
  simp [sphere.second_inter]
#align euclidean_geometry.sphere.second_inter_zero EuclideanGeometry.Sphere.secondInter_zero

variable {V}

/-- The point given by `second_inter` equals the original point if and only if the line is
orthogonal to the radius vector. -/
theorem Sphere.secondInter_eq_self_iff {s : Sphere P} {p : P} {v : V} :
    s.secondInter p v = p ↔ ⟪v, p -ᵥ s.center⟫ = 0 :=
  by
  refine' ⟨fun hp => _, fun hp => _⟩
  · by_cases hv : v = 0
    · simp [hv]
    rwa [sphere.second_inter, eq_comm, eq_vadd_iff_vsub_eq, vsub_self, eq_comm, smul_eq_zero,
      or_iff_left hv, div_eq_zero_iff, inner_self_eq_zero, or_iff_left hv, mul_eq_zero,
      or_iff_right (by norm_num : (-2 : ℝ) ≠ 0)] at hp
  · rw [sphere.second_inter, hp, MulZeroClass.mul_zero, zero_div, zero_smul, zero_vadd]
#align euclidean_geometry.sphere.second_inter_eq_self_iff EuclideanGeometry.Sphere.secondInter_eq_self_iff

/-- A point on a line through a point on a sphere equals that point or `second_inter`. -/
theorem Sphere.eq_or_eq_secondInter_of_mem_mk'_span_singleton_iff_mem {s : Sphere P} {p : P}
    (hp : p ∈ s) {v : V} {p' : P} (hp' : p' ∈ AffineSubspace.mk' p (ℝ ∙ v)) :
    p' = p ∨ p' = s.secondInter p v ↔ p' ∈ s :=
  by
  refine' ⟨fun h => _, fun h => _⟩
  · rcases h with (h | h)
    · rwa [h]
    · rwa [h, sphere.second_inter_mem]
  · rw [AffineSubspace.mem_mk'_iff_vsub_mem, Submodule.mem_span_singleton] at hp'
    rcases hp' with ⟨r, hr⟩
    rw [eq_comm, ← eq_vadd_iff_vsub_eq] at hr
    subst hr
    by_cases hv : v = 0
    · simp [hv]
    rw [sphere.second_inter]
    rw [mem_sphere] at h hp
    rw [← hp, dist_smul_vadd_eq_dist _ _ hv] at h
    rcases h with (h | h) <;> simp [h]
#align euclidean_geometry.sphere.eq_or_eq_second_inter_of_mem_mk'_span_singleton_iff_mem EuclideanGeometry.Sphere.eq_or_eq_secondInter_of_mem_mk'_span_singleton_iff_mem

/-- `second_inter` is unchanged by multiplying the vector by a nonzero real. -/
@[simp]
theorem Sphere.secondInter_smul (s : Sphere P) (p : P) (v : V) {r : ℝ} (hr : r ≠ 0) :
    s.secondInter p (r • v) = s.secondInter p v :=
  by
  simp_rw [sphere.second_inter, real_inner_smul_left, inner_smul_right, smul_smul,
    div_mul_eq_div_div]
  rw [mul_comm, ← mul_div_assoc, ← mul_div_assoc, mul_div_cancel_left _ hr, mul_comm, mul_assoc,
    mul_div_cancel_left _ hr, mul_comm]
#align euclidean_geometry.sphere.second_inter_smul EuclideanGeometry.Sphere.secondInter_smul

/-- `second_inter` is unchanged by negating the vector. -/
@[simp]
theorem Sphere.secondInter_neg (s : Sphere P) (p : P) (v : V) :
    s.secondInter p (-v) = s.secondInter p v := by
  rw [← neg_one_smul ℝ v, s.second_inter_smul p v (by norm_num : (-1 : ℝ) ≠ 0)]
#align euclidean_geometry.sphere.second_inter_neg EuclideanGeometry.Sphere.secondInter_neg

/-- Applying `second_inter` twice returns the original point. -/
@[simp]
theorem Sphere.secondInter_secondInter (s : Sphere P) (p : P) (v : V) :
    s.secondInter (s.secondInter p v) v = p :=
  by
  by_cases hv : v = 0; · simp [hv]
  have hv' : ⟪v, v⟫ ≠ 0 := inner_self_ne_zero.2 hv
  simp only [sphere.second_inter, vadd_vsub_assoc, vadd_vadd, inner_add_right, inner_smul_right,
    div_mul_cancel _ hv']
  rw [← @vsub_eq_zero_iff_eq V, vadd_vsub, ← add_smul, ← add_div]
  convert zero_smul ℝ _
  convert zero_div _
  ring
#align euclidean_geometry.sphere.second_inter_second_inter EuclideanGeometry.Sphere.secondInter_secondInter

/-- If the vector passed to `second_inter` is given by a subtraction involving the point in
`second_inter`, the result of `second_inter` may be expressed using `line_map`. -/
theorem Sphere.secondInter_eq_lineMap (s : Sphere P) (p p' : P) :
    s.secondInter p (p' -ᵥ p) =
      AffineMap.lineMap p p' (-2 * ⟪p' -ᵥ p, p -ᵥ s.center⟫ / ⟪p' -ᵥ p, p' -ᵥ p⟫) :=
  rfl
#align euclidean_geometry.sphere.second_inter_eq_line_map EuclideanGeometry.Sphere.secondInter_eq_lineMap

/-- If the vector passed to `second_inter` is given by a subtraction involving the point in
`second_inter`, the result lies in the span of the two points. -/
theorem Sphere.secondInter_vsub_mem_affineSpan (s : Sphere P) (p₁ p₂ : P) :
    s.secondInter p₁ (p₂ -ᵥ p₁) ∈ line[ℝ, p₁, p₂] :=
  smul_vsub_vadd_mem_affineSpan_pair _ _ _
#align euclidean_geometry.sphere.second_inter_vsub_mem_affine_span EuclideanGeometry.Sphere.secondInter_vsub_mem_affineSpan

/-- If the vector passed to `second_inter` is given by a subtraction involving the point in
`second_inter`, the three points are collinear. -/
theorem Sphere.secondInter_collinear (s : Sphere P) (p p' : P) :
    Collinear ℝ ({p, p', s.secondInter p (p' -ᵥ p)} : Set P) :=
  by
  rw [Set.pair_comm, Set.insert_comm]
  exact
    (collinear_insert_iff_of_mem_affineSpan (s.second_inter_vsub_mem_affine_span _ _)).2
      (collinear_pair ℝ _ _)
#align euclidean_geometry.sphere.second_inter_collinear EuclideanGeometry.Sphere.secondInter_collinear

/-- If the vector passed to `second_inter` is given by a subtraction involving the point in
`second_inter`, and the second point is not outside the sphere, the second point is weakly
between the first point and the result of `second_inter`. -/
theorem Sphere.wbtw_secondInter {s : Sphere P} {p p' : P} (hp : p ∈ s)
    (hp' : dist p' s.center ≤ s.radius) : Wbtw ℝ p p' (s.secondInter p (p' -ᵥ p)) :=
  by
  by_cases h : p' = p; · simp [h]
  refine'
    wbtw_of_collinear_of_dist_center_le_radius (s.second_inter_collinear p p') hp hp'
      ((sphere.second_inter_mem _).2 hp) _
  intro he
  rw [eq_comm, sphere.second_inter_eq_self_iff, ← neg_neg (p' -ᵥ p), inner_neg_left,
    neg_vsub_eq_vsub_rev, neg_eq_zero, eq_comm] at he
  exact ((inner_pos_or_eq_of_dist_le_radius hp hp').resolve_right (Ne.symm h)).Ne he
#align euclidean_geometry.sphere.wbtw_second_inter EuclideanGeometry.Sphere.wbtw_secondInter

/-- If the vector passed to `second_inter` is given by a subtraction involving the point in
`second_inter`, and the second point is inside the sphere, the second point is strictly between
the first point and the result of `second_inter`. -/
theorem Sphere.sbtw_secondInter {s : Sphere P} {p p' : P} (hp : p ∈ s)
    (hp' : dist p' s.center < s.radius) : Sbtw ℝ p p' (s.secondInter p (p' -ᵥ p)) :=
  by
  refine' ⟨sphere.wbtw_second_inter hp hp'.le, _, _⟩
  · rintro rfl
    rw [mem_sphere] at hp
    simpa [hp] using hp'
  · rintro h
    rw [h, mem_sphere.1 ((sphere.second_inter_mem _).2 hp)] at hp'
    exact lt_irrefl _ hp'
#align euclidean_geometry.sphere.sbtw_second_inter EuclideanGeometry.Sphere.sbtw_secondInter

end EuclideanGeometry


import data.set

section
    variable U : Type
    variables A B C : set U

    example : ∀ x, x ∈ A ∩ C → x ∈ A ∪ B :=
        assume x,
        show x ∈ A ∩ C → x ∈ A ∪ B, from
            assume h1 : x ∈ A ∩ C,
            show x ∈ A ∪ B, from or.inl h1.left

    example : ∀ x, x ∈ -(A ∪ B) → x ∈ -A :=
        assume x,
        show x ∈ -(A ∪ B) → x ∈ -A, from
            assume h1 : x ∈ -(A ∪ B),
            show x ∈ -A, from
                assume h2 : x ∈ A,
                show false, from h1 $ or.inl h2
end

open set

section
    variable {U : Type}

    /- defining "disjoint" -/

    def disj (A B : set U) : Prop := ∀ ⦃x⦄, x ∈ A → x ∈ B → false

    example (A B : set U) (h : ∀ x, ¬ (x ∈ A ∧ x ∈ B)) : disj A B :=
        assume x,
            assume h1 : x ∈ A,
                assume h2 : x ∈ B,
                have h3 : x ∈ A ∧ x ∈ B, from and.intro h1 h2,
                show false, from h x h3

    -- notice that we do not have to mention x when applying
    --   h : disj A B
    example (A B : set U) (h1 : disj A B) (x : U) (h2 : x ∈ A) (h3 : x ∈ B) :
    false :=
        h1 h2 h3

    -- the same is true of ⊆
    example (A B : set U) (x : U) (h : A ⊆ B) (h1 : x ∈ A) :
    x ∈ B :=
        h h1

    example (A B C D : set U) (h1 : disj A B) (h2 : C ⊆ A) (h3 : D ⊆ B) :
    disj C D :=
        assume x,
        show x ∈ C → x ∈ D → false, from
            assume h4 : x ∈ C,
            show x ∈ D → false, from
                assume h5 : x ∈ D,
                show false, from h1 (h2 h4) (h3 h5)
end

section

    variables {I U : Type}
    variables {A B : I → set U}

    theorem Inter.intro {x : U} (h : ∀ i, x ∈ A i) : x ∈ ⋂ i, A i :=
    by simp; assumption

    @[elab_simple]
    theorem Inter.elim {x : U} (h : x ∈ ⋂ i, A i) (i : I) : x ∈ A i :=
    by simp at h; apply h

    theorem Union.intro {x : U} (i : I) (h : x ∈ A i) : x ∈ ⋃ i, A i :=
    by {simp, existsi i, exact h}

    theorem Union.elim {b : Prop} {x : U}
    (h₁ : x ∈ ⋃ i, A i) (h₂ : ∀ (i : I), x ∈ A i → b) : b :=
    by {simp at h₁, cases h₁ with i h, exact h₂ i h}

end

section

    -- BEGIN
    variables {I U : Type}
    variables (A : I → set U) (B : I → set U) (C : set U)

    example : (⋂ i, A i) ∩ (⋂ i, B i) ⊆ (⋂ i, A i ∩ B i) :=
        assume x,
        show x ∈ (⋂ i, A i) ∩ (⋂ i, B i) → x ∈ (⋂ i, A i ∩ B i), from
            assume h1 : x ∈ (⋂ i, A i) ∩ (⋂ i, B i),
            have h2 : x ∈ (⋂ i, A i), from h1.left,
            have h3 : x ∈ (⋂ i, B i), from h1.right,
            show x ∈ (⋂ i, A i ∩ B i), from Inter.intro $
                assume i,
                have h4 : x ∈ A i, from Inter.elim h2 i,
                have h5 : x ∈ B i, from Inter.elim h3 i,
                show x ∈ A i ∩ B i, from and.intro h4 h5

    variable j : I

    example : C ∩ (⋃i, A i) ⊆ ⋃i, C ∩ A i :=
        assume x,
        show x ∈ C ∩ (⋃i, A i) → x ∈ ⋃i, C ∩ A i, from
            assume h1 : x ∈ C ∩ (⋃i, A i),
            have h2 : x ∈ ⋃i, A i, from h1.right,
            have h5 : x ∈ C, from h1.left,
            show x ∈ ⋃i, C ∩ A i, from Union.elim h2 $
                assume i,
                show x ∈ A i →  x ∈ ⋃j, C ∩ A j, from
                    assume h3 : x ∈ A i,
                    have h4 : x ∈ C ∩ A i, from and.intro h5 h3,
                    show x ∈ ⋃j, C ∩ A j, from Union.intro i h4
    -- END

end

section

    -- BEGIN
    variable  {U : Type}
    variables A B C : set U

    -- For this exercise these two facts are useful
    example (h1 : A ⊆ B) (h2 : B ⊆ C) : A ⊆ C :=
        subset.trans h1 h2

    example : A ⊆ A :=
        subset.refl A

    example (h : A ⊆ B) : powerset A ⊆ powerset B :=
        assume X : set U,
        show X ∈ powerset A → X ∈ powerset B, from
            assume h1 : X ∈ powerset A,
            have h2 : X ⊆ A, from h1,
            have h3 : X ⊆ B, from subset.trans h2 h,
            show X ∈ powerset B, from h3

    example (h : powerset A ⊆ powerset B) : A ⊆ B :=
        assume x,
        show x ∈ A → x ∈ B, from
            assume h1 : x ∈ A,
            have h2 : ∀ X, X ⊆ A → X ⊆ B, from h,
            have h3 : A ⊆ A, from subset.refl A,
            have h4 : A ⊆ B, from h2 A h3,
            show x ∈ B, from h4 h1

    -- END

end


/-
Copyright (c) 2021 Jakob Scholbach. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jakob Scholbach
-/
import algebra.algebra.basic
import algebra.char_p.exp_char
import field_theory.separable

/-!

# Separable degree

This file contains basics about the separable degree of a polynomial.

## Main results

- `is_separable_contraction`: is the condition that `g(x^(q^m)) = f(x)` for some `m : ℕ`
- `has_separable_contraction`: the condition of having a separable contraction
- `has_separable_contraction.degree`: the separable degree, defined as the degree of some
  separable contraction
- `irreducible_has_separable_contraction`: any irreducible polynomial can be contracted
  to a separable polynomial
- `has_separable_contraction.dvd_degree'`: the degree of a separable contraction divides the degree,
  in function of the exponential characteristic of the field
- `has_separable_contraction.dvd_degree` and `has_separable_contraction.eq_degree` specialize the
  statement of `separable_degree_dvd_degree`
- `is_separable_contraction.degree_eq`: the separable degree is well-defined, implemented as the
  statement that the degree of any separable contraction equals `has_separable_contraction.degree`

## Tags

separable degree, degree, polynomial
-/

namespace polynomial

noncomputable theory
open_locale classical

section comm_semiring

variables {F : Type} [comm_semiring F] (q : ℕ)

/-- A separable contraction of a polynomial `f` is a separable polynomial `g` such that
`g(x^(q^m)) = f(x)` for some `m : ℕ`.-/
def is_separable_contraction (f : polynomial F) (g : polynomial F) : Prop :=
g.separable ∧ ∃ m : ℕ, expand F (q^m) g = f

/-- The condition of having a separable contration. -/
def has_separable_contraction (f : polynomial F) : Prop :=
∃ g : polynomial F, is_separable_contraction q f g

variables {q} {f : polynomial F} (hf : has_separable_contraction q f)

/-- A choice of a separable contraction. -/
def has_separable_contraction.contraction : polynomial F := classical.some hf

/-- The separable degree of a polynomial is the degree of a given separable contraction. -/
def has_separable_contraction.degree : ℕ := hf.contraction.nat_degree

/-- The separable degree divides the degree, in function of the exponential characteristic of F. -/
lemma is_separable_contraction.dvd_degree' {g} (hf : is_separable_contraction q f g) :
  ∃ m : ℕ, g.nat_degree * (q ^ m) = f.nat_degree :=
begin
  obtain ⟨m, rfl⟩ := hf.2,
  use m,
  rw nat_degree_expand,
end

lemma has_separable_contraction.dvd_degree' : ∃ m : ℕ, hf.degree * (q ^ m) = f.nat_degree :=
(classical.some_spec hf).dvd_degree'

/-- The separable degree divides the degree. -/
lemma has_separable_contraction.dvd_degree :
  hf.degree ∣ f.nat_degree :=
let ⟨a, ha⟩ := hf.dvd_degree' in dvd.intro (q ^ a) ha

/-- In exponential characteristic one, the separable degree equals the degree. -/
lemma has_separable_contraction.eq_degree {f : polynomial F}
  (hf : has_separable_contraction 1 f) : hf.degree = f.nat_degree :=
let ⟨a, ha⟩ := hf.dvd_degree' in by rw [←ha, one_pow a, mul_one]

end comm_semiring

section field

variables {F : Type} [field F]
variables (q : ℕ) {f : polynomial F} (hf : has_separable_contraction q f)

/-- Every irreducible polynomial can be contracted to a separable polynomial.
https://stacks.math.columbia.edu/tag/09H0 -/
lemma irreducible_has_separable_contraction (q : ℕ) [hF : exp_char F q]
  (f : polynomial F) [irred : irreducible f] : has_separable_contraction q f :=
begin
  casesI hF,
  { exact ⟨f, irred.separable, ⟨0, by rw [pow_zero, expand_one]⟩⟩ },
  { rcases exists_separable_of_irreducible q irred ‹q.prime›.ne_zero with ⟨n, g, hgs, hge⟩,
    exact ⟨g, hgs, n, hge⟩, }
end

/-- A helper lemma: if two expansions (along the positive characteristic) of two polynomials `g` and
`g'` agree, and the one with the larger degree is separable, then their degrees are the same. -/
lemma contraction_degree_eq_aux [hq : fact q.prime] [hF : char_p F q]
  (g g' : polynomial F) (m m' : ℕ)
  (h_expand : expand F (q^m) g = expand F (q^m') g')
  (h : m < m') (hg : g.separable):
  g.nat_degree =  g'.nat_degree :=
begin
  obtain ⟨s, rfl⟩ := nat.exists_eq_add_of_lt h,
  rw [add_assoc, pow_add, expand_mul] at h_expand,
  let aux := expand_injective (pow_pos hq.1.pos m) h_expand,
  rw aux at hg,
  have := (is_unit_or_eq_zero_of_separable_expand q (s + 1) hq.out.pos hg).resolve_right
    s.succ_ne_zero,
  rw [aux, nat_degree_expand,
    nat_degree_eq_of_degree_eq_some (degree_eq_zero_of_is_unit this),
    zero_mul]
end

/-- If two expansions (along the positive characteristic) of two separable polynomials
`g` and `g'` agree, then they have the same degree. -/
theorem contraction_degree_eq_or_insep
  [hq : fact q.prime] [char_p F q]
  (g g' : polynomial F) (m m' : ℕ)
  (h_expand : expand F (q^m) g = expand F (q^m') g')
  (hg : g.separable) (hg' : g'.separable) :
  g.nat_degree = g'.nat_degree :=
begin
  by_cases h : m = m',
  { -- if `m = m'` then we show `g.nat_degree = g'.nat_degree` by unfolding the definitions
    rw h at h_expand,
    have expand_deg : ((expand F (q ^ m')) g).nat_degree =
      (expand F (q ^ m') g').nat_degree, by rw h_expand,
    rw [nat_degree_expand (q^m') g, nat_degree_expand (q^m') g'] at expand_deg,
    apply nat.eq_of_mul_eq_mul_left (pow_pos hq.1.pos m'),
    rw [mul_comm] at expand_deg, rw expand_deg, rw [mul_comm] },
  { cases ne.lt_or_lt h,
    { exact contraction_degree_eq_aux q g g' m m' h_expand h_1 hg },
    { exact (contraction_degree_eq_aux q g' g m' m h_expand.symm h_1 hg').symm, } }
end

/-- The separable degree equals the degree of any separable contraction, i.e., it is unique. -/
theorem is_separable_contraction.degree_eq [hF : exp_char F q]
  (g : polynomial F) (hg : is_separable_contraction q f g) :
  g.nat_degree = hf.degree :=
begin
  casesI hF,
  { rcases hg with ⟨g, m, hm⟩,
    rw [one_pow, expand_one] at hm,
    rw hf.eq_degree,
    rw hm, },
  { rcases hg with ⟨hg, m, hm⟩,
    let g' := classical.some hf,
    cases (classical.some_spec hf).2 with m' hm',
    haveI : fact q.prime := fact_iff.2 hF_hprime,
    apply contraction_degree_eq_or_insep q g g' m m',
    rw [hm, hm'],
    exact hg, exact (classical.some_spec hf).1 }
end

end field

end polynomial