import Category.Init

/-!
# Category **Mon**

`Mon` is the **Mon** category:
- objects are all the monoids, and
- arrows are all the *monoid homomorphisms*.

*Monoid homomorphisms* preserve the neutral element and are proper *w.r.t.* the monoid's
multiplication.
-/

namespace Mon

  structure All where
    Elm : α
    mon : Monoid α

  def All.mul {self : All} (a b : self.Elm) : self.Elm :=
    self.mon.mul a b

  local infixl:70 " * " => All.mul

  structure Homo (m₁ m₂ : All) where
    apply (a₁ : m₁.Elm) : m₂.Elm
    apply_one : apply m₁.mon.one = m₂.mon.one
    apply_proper (a₁ b₁ : m₁.Elm) :
      apply (a₁ * b₁) = apply a₁ * apply b₁

  def Homo.compose
    (g : Homo m₂ m₃)
    (f : Homo m₁ m₂)
    : Homo m₁ m₃
  where
    apply a₁ := g.apply (f.apply a₁)
    apply_one :=
      by
        simp
        rw [f.apply_one, g.apply_one]
    apply_proper a₁ b₁ :=
      by
        simp
        rw [f.apply_proper, g.apply_proper]

  def Homo.compose_assoc
    (h : Homo s₃ s₄)
    (g : Homo s₂ s₃)
    (f : Homo s₁ s₂)
    : h.compose (g.compose f) = (h.compose g).compose f
  :=
    rfl

  protected def Homo.id {s : outParam All} : Homo s s where
    apply := id
    apply_one := rfl
    apply_proper _ _ := rfl

  theorem Homo.compose_id
    (f : Homo m₁ m₂)
    : f.compose Homo.id = f
  :=
    rfl

  theorem Homo.id_compose
    (f : Homo m₁ m₂)
    : Homo.id.compose f = f
  :=
    rfl

end Mon

instance Cat.Mon : Cat.Abstract Mon.All Mon.Homo where
  compose :=
    Mon.Homo.compose
  compose_assoc :=
    Mon.Homo.compose_assoc

  id :=
    @Mon.Homo.id
  id_compose :=
    Mon.Homo.id_compose
  compose_id :=
    Mon.Homo.compose_id

structure Cat.SingleMon.Arrow (Elm : Sort e) where
  val : Elm

instance Cat.SingleMon
  [mon : Monoid Elm]
: Cat.Abstract Unit (fun _ _ => SingleMon.Arrow Elm) where
  compose f g :=
    ⟨f.val * g.val⟩
  compose_assoc f g h :=
    by simp [mon.mul_assoc f.val g.val h.val]

  id := ⟨1⟩
  id_compose :=
    by simp at *
  compose_id :=
    by simp at *


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import analysis.calculus.specific_functions
import geometry.manifold.diffeomorph
import geometry.manifold.instances.real

/-!
# Smooth bump functions on a smooth manifold

In this file we define `smooth_bump_function I c` to be a bundled smooth "bump" function centered at
`c`. It is a structure that consists of two real numbers `0 < r < R` with small enough `R`. We
define a coercion to function for this type, and for `f : smooth_bump_function I c`, the function
`⇑f` written in the extended chart at `f.c` has the following properties:

* `f x = 1` in the closed euclidean ball of radius `f.r` centered at `f.c`;
* `f x = 0` outside of the euclidean ball of radius `f.R` centered at `f.c`;
* `0 ≤ f x ≤ 1` for all `x`.

The actual statements involve (pre)images under `ext_chart_at I f.c` and are given as lemmas in the
`smooth_bump_function` namespace.

We also define `smooth_bump_covering` of a set `s : set M` to be a collection of
`smooth_bump_function`s such that their supports is a locally finite family of sets, and for each
point `x ∈ s` there exists a bump function `f i` in the collection such that `f i =ᶠ[𝓝 x] 1`. This
structure is the main building block in the construction of a smooth partition of unity (see TODO),
and can be used instead of a partition of unity in some proofs.

We say that `f : smooth_bump_covering I s` is *subordinate* to a map `U : M → set M` if for each
index `i`, we have `closure (support (f i)) ⊆ U (f i).c`. This notion is a bit more general than
being subordinate to an open covering of `M`, because we make no assumption about the way `U x`
depends on `x`.

We prove that on a smooth finitely dimensional real manifold with `σ`-compact Hausdorff topology,
for any `U : M → set M` such that `∀ x ∈ s, U x ∈ 𝓝 x` there exists a `smooth_bump_covering I s`
subordinate to `U`. Then we use this fact to prove a version of the Whitney embedding theorem: any
compact real manifold can be embedded into `ℝ^n` for large enough `n`.

## TODO

* Prove the weak Whitney embedding theorem: any `σ`-compact smooth `m`-dimensional manifold can be
  embedded into `ℝ^(2m+1)`. This requires a version of Sard's theorem: for a locally Lipschitz
  continuous map `f : ℝ^m → ℝ^n`, `m < n`, the range has Hausdorff dimension at most `m`, hence it
  has measure zero.

* Construct a smooth partition of unity. While we can do it now, the formulas will be much nicer if
  we wait for `finprod` and `finsum` coming in #6355.

* Deduce some corollaries from existence of a smooth partition of unity.

  - Prove that for any disjoint closed sets `s`, `t` there exists a smooth function `f` suth that
  `f` equals zero on `s` and `f` equals one on `t`.

  - Build a framework for to transfer local definitions to global using partition of unity and use
    it to define, e.g., the integral of a differential form over a manifold.

## Tags

manifold, smooth bump function, partition of unity, Whitney theorem
-/

universes uE uF uH uM
variables
{E : Type uE} [normed_group E] [normed_space ℝ E] [finite_dimensional ℝ E]
{H : Type uH} [topological_space H] (I : model_with_corners ℝ E H)
{M : Type uM} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M]

open function filter finite_dimensional set
open_locale topological_space manifold classical filter big_operators

noncomputable theory

/-!
### Smooth bump function

In this section we define a structure for a bundled smooth bump function and prove its properties.
-/

/-- Given a smooth manifold modelled on a finite dimensional space `E`,
`f : smooth_bump_function I M` is a smooth function on `M` such that in the extended chart `e` at
`f.c`:

* `f x = 1` in the closed euclidean ball of radius `f.r` centered at `f.c`;
* `f x = 0` outside of the euclidean ball of radius `f.R` centered at `f.c`;
* `0 ≤ f x ≤ 1` for all `x`.

The structure contains data required to construct a function with these properties. The function is
available as `⇑f` or `f x`. Formal statements of the properties listed above involve some
(pre)images under `ext_chart_at I f.c` and are given as lemmas in the `msmooth_bump_function`
namespace. -/
structure smooth_bump_function (c : M) extends times_cont_diff_bump (ext_chart_at I c c) :=
(closed_ball_subset :
  (euclidean.closed_ball (ext_chart_at I c c) R) ∩ range I ⊆ (ext_chart_at I c).target)

variable {M}

namespace smooth_bump_function

open euclidean (renaming dist -> eudist)

variables {c : M} (f : smooth_bump_function I c) {x : M} {I}

/-- The function defined by `f : smooth_bump_function c`. Use automatic coercion to function
instead. -/
def to_fun : M → ℝ :=
indicator (chart_at H c).source (f.to_times_cont_diff_bump ∘ ext_chart_at I c)

instance : has_coe_to_fun (smooth_bump_function I c) := ⟨_, to_fun⟩

lemma coe_def :
  ⇑f = indicator (chart_at H c).source (f.to_times_cont_diff_bump ∘ ext_chart_at I c) :=
rfl

lemma R_pos : 0 < f.R := f.to_times_cont_diff_bump.R_pos

lemma ball_subset :
  ball (ext_chart_at I c c) f.R ∩ range I ⊆ (ext_chart_at I c).target :=
subset.trans (inter_subset_inter_left _ ball_subset_closed_ball) f.closed_ball_subset

lemma eq_on_source :
  eq_on f (f.to_times_cont_diff_bump ∘ ext_chart_at I c) (chart_at H c).source :=
eq_on_indicator

lemma eventually_eq_of_mem_source (hx : x ∈ (chart_at H c).source) :
  f =ᶠ[𝓝 x] f.to_times_cont_diff_bump ∘ ext_chart_at I c :=
f.eq_on_source.eventually_eq_of_mem $ mem_nhds_sets (chart_at H c).open_source hx

lemma one_of_dist_le (hs : x ∈ (chart_at H c).source)
  (hd : eudist (ext_chart_at I c x) (ext_chart_at I c c) ≤ f.r) :
  f x = 1 :=
by simp only [f.eq_on_source hs, (∘), f.to_times_cont_diff_bump.one_of_mem_closed_ball hd]

lemma support_eq_inter_preimage :
  support f =
    (chart_at H c).source ∩ (ext_chart_at I c ⁻¹' ball (ext_chart_at I c c) f.R) :=
by rw [coe_def, support_indicator, (∘), support_comp_eq_preimage, ← ext_chart_at_source I,
  ← (ext_chart_at I c).symm_image_target_inter_eq',
  ← (ext_chart_at I c).symm_image_target_inter_eq', f.to_times_cont_diff_bump.support_eq]

lemma open_support : is_open (support f) :=
by { rw support_eq_inter_preimage, exact ext_chart_preimage_open_of_open I c is_open_ball }

lemma support_eq_symm_image :
  support f = (ext_chart_at I c).symm '' (ball (ext_chart_at I c c) f.R ∩ range I) :=
begin
  rw [f.support_eq_inter_preimage, ← ext_chart_at_source I,
    ← (ext_chart_at I c).symm_image_target_inter_eq', inter_comm],
  congr' 1 with y,
  exact and.congr_right_iff.2
    (λ hy, ⟨λ h, ext_chart_at_target_subset_range _ _ h, λ h, f.ball_subset ⟨hy, h⟩⟩)
end

lemma support_subset_source : support f ⊆ (chart_at H c).source :=
by { rw [f.support_eq_inter_preimage, ← ext_chart_at_source I], exact inter_subset_left _ _ }

lemma image_eq_inter_preimage_of_subset_support {s : set M} (hs : s ⊆ support f) :
  ext_chart_at I c '' s =
    closed_ball (ext_chart_at I c c) f.R ∩ range I ∩ (ext_chart_at I c).symm ⁻¹' s :=
begin
  rw [support_eq_inter_preimage, subset_inter_iff, ← ext_chart_at_source I,
    ← image_subset_iff] at hs,
  cases hs with hse hsf,
  apply subset.antisymm,
  { refine subset_inter (subset_inter (subset.trans hsf ball_subset_closed_ball) _) _,
    { rintro _ ⟨x, -, rfl⟩, exact mem_range_self _ },
    { rw [(ext_chart_at I c).image_eq_target_inter_inv_preimage hse],
      exact inter_subset_right _ _ } },
  { refine subset.trans (inter_subset_inter_left _ f.closed_ball_subset) _,
    rw [(ext_chart_at I c).image_eq_target_inter_inv_preimage hse] }
end

lemma mem_Icc : f x ∈ Icc (0 : ℝ) 1 :=
begin
  have : f x = 0 ∨ f x = _, from indicator_eq_zero_or_self _ _ _,
  cases this; rw this,
  exacts [left_mem_Icc.2 zero_le_one,
    ⟨f.to_times_cont_diff_bump.nonneg, f.to_times_cont_diff_bump.le_one⟩]
end

lemma nonneg : 0 ≤ f x := f.mem_Icc.1

lemma le_one : f x ≤ 1 := f.mem_Icc.2

lemma eventually_eq_one_of_dist_lt (hs : x ∈ (chart_at H c).source)
  (hd : eudist (ext_chart_at I c x) (ext_chart_at I c c) < f.r) :
  f =ᶠ[𝓝 x] 1 :=
begin
  filter_upwards [mem_nhds_sets (ext_chart_preimage_open_of_open I c is_open_ball) ⟨hs, hd⟩],
  rintro z ⟨hzs, hzd : _ < _⟩,
  exact f.one_of_dist_le hzs hzd.le
end

lemma eventually_eq_one : f =ᶠ[𝓝 c] 1 :=
f.eventually_eq_one_of_dist_lt (mem_chart_source _ _) $
by { rw [euclidean.dist, dist_self], exact f.r_pos }

@[simp] lemma eq_one : f c = 1 := f.eventually_eq_one.eq_of_nhds

lemma support_mem_nhds : support f ∈ 𝓝 c :=
f.eventually_eq_one.mono $ λ x hx, by { rw hx, exact one_ne_zero }

lemma closure_support_mem_nhds : closure (support f) ∈ 𝓝 c :=
mem_sets_of_superset f.support_mem_nhds subset_closure

lemma c_mem_support : c ∈ support f := mem_of_nhds f.support_mem_nhds

lemma nonempty_support : (support f).nonempty := ⟨c, f.c_mem_support⟩

lemma compact_symm_image_closed_ball :
  is_compact ((ext_chart_at I c).symm '' (closed_ball (ext_chart_at I c c) f.R ∩ range I)) :=
(compact_ball.inter_right I.closed_range).image_of_continuous_on $
  (ext_chart_at_continuous_on_symm _ _).mono f.closed_ball_subset

/-- Given a smooth bump function `f : smooth_bump_function I c`, the closed ball of radius `f.R` is
known to include the support of `f`. These closed balls (in the model normed space `E`) intersected
with `set.range I` form a basis of `𝓝[range I] (ext_chart_at I c c)`. -/
lemma nhds_within_range_basis :
  (𝓝[range I] (ext_chart_at I c c)).has_basis (λ f : smooth_bump_function I c, true)
    (λ f, closed_ball (ext_chart_at I c c) f.R ∩ range I) :=
begin
  refine ((nhds_within_has_basis euclidean.nhds_basis_closed_ball _).restrict_subset
      (ext_chart_at_target_mem_nhds_within _ _)).to_has_basis' _ _,
  { rintro R ⟨hR0, hsub⟩,
    exact ⟨⟨⟨⟨R / 2, R, half_pos hR0, half_lt_self hR0⟩⟩, hsub⟩, trivial, subset.rfl⟩ },
  { exact λ f _, inter_mem_sets (mem_nhds_within_of_mem_nhds $ closed_ball_mem_nhds f.R_pos)
      self_mem_nhds_within }
end

lemma closed_image_of_closed {s : set M} (hsc : is_closed s) (hs : s ⊆ support f) :
  is_closed (ext_chart_at I c '' s) :=
begin
  rw f.image_eq_inter_preimage_of_subset_support hs,
  refine continuous_on.preimage_closed_of_closed
    ((ext_chart_continuous_on_symm _ _).mono f.closed_ball_subset) _ hsc,
  exact is_closed_inter is_closed_closed_ball I.closed_range
end

/-- If `f` is a smooth bump function and `s` closed subset of the support of `f` (i.e., of the open
ball of radius `f.R`), then there exists `0 < r < f.R` such that `s` is a subset of the open ball of
radius `r`. Formally, `s ⊆ e.source ∩ e ⁻¹' (ball (e c) r)`, where `e = ext_chart_at I c`. -/
lemma exists_r_pos_lt_subset_ball {s : set M} (hsc : is_closed s) (hs : s ⊆ support f) :
  ∃ r (hr : r ∈ Ioo 0 f.R), s ⊆
    (chart_at H c).source ∩ ext_chart_at I c ⁻¹' (ball (ext_chart_at I c c) r) :=
begin
  set e := ext_chart_at I c,
  have : is_closed (e '' s) := f.closed_image_of_closed hsc hs,
  rw [support_eq_inter_preimage, subset_inter_iff, ← image_subset_iff] at hs,
  rcases euclidean.exists_pos_lt_subset_ball f.R_pos this hs.2 with ⟨r, hrR, hr⟩,
  exact ⟨r, hrR, subset_inter hs.1 (image_subset_iff.1 hr)⟩
end

/-- Replace `r` with another value in the interval `(0, f.R)`. -/
def update_r (r : ℝ) (hr : r ∈ Ioo 0 f.R) : smooth_bump_function I c :=
⟨⟨⟨r, f.R, hr.1, hr.2⟩⟩, f.closed_ball_subset⟩

@[simp] lemma update_r_R {r : ℝ} (hr : r ∈ Ioo 0 f.R) : (f.update_r r hr).R = f.R := rfl

@[simp] lemma update_r_r {r : ℝ} (hr : r ∈ Ioo 0 f.R) : (f.update_r r hr).r = r := rfl

@[simp] lemma support_update_r {r : ℝ} (hr : r ∈ Ioo 0 f.R) :
  support (f.update_r r hr) = support f :=
by simp only [support_eq_inter_preimage, update_r_R]

instance : inhabited (smooth_bump_function I c) :=
classical.inhabited_of_nonempty nhds_within_range_basis.nonempty

variables [t2_space M]

lemma closed_symm_image_closed_ball :
  is_closed ((ext_chart_at I c).symm '' (closed_ball (ext_chart_at I c c) f.R ∩ range I)) :=
f.compact_symm_image_closed_ball.is_closed

lemma closure_support_subset_symm_image_closed_ball :
  closure (support f) ⊆
    (ext_chart_at I c).symm '' (closed_ball (ext_chart_at I c c) f.R ∩ range I) :=
begin
  rw support_eq_symm_image,
  exact closure_minimal (image_subset _ $ inter_subset_inter_left _ ball_subset_closed_ball)
    f.closed_symm_image_closed_ball
end

lemma closure_support_subset_ext_chart_at_source :
  closure (support f) ⊆ (ext_chart_at I c).source :=
calc closure (support f)
    ⊆ (ext_chart_at I c).symm '' (closed_ball (ext_chart_at I c c) f.R ∩ range I) :
  f.closure_support_subset_symm_image_closed_ball
... ⊆ (ext_chart_at I c).symm '' (ext_chart_at I c).target :
  image_subset _ f.closed_ball_subset
... = (ext_chart_at I c).source :
  (ext_chart_at I c).symm_image_target_eq_source

lemma closure_support_subset_chart_at_source :
  closure (support f) ⊆ (chart_at H c).source :=
by simpa only [ext_chart_at_source] using f.closure_support_subset_ext_chart_at_source

lemma compact_closure_support : is_compact (closure $ support f) :=
compact_of_is_closed_subset f.compact_symm_image_closed_ball is_closed_closure
 f.closure_support_subset_symm_image_closed_ball

variables (I c)

/-- The closures of supports of smooth bump functions centered at `c` form a basis of `𝓝 c`.
In other words, each of these closures is a neighborhood of `c` and each neighborhood of `c`
includes `closure (support f)` for some `f : smooth_bump_function I c`. -/
lemma nhds_basis_closure_support :
  (𝓝 c).has_basis (λ f : smooth_bump_function I c, true) (λ f, closure $ support f) :=
begin
  have : (𝓝 c).has_basis (λ f : smooth_bump_function I c, true)
    (λ f, (ext_chart_at I c).symm '' (closed_ball (ext_chart_at I c c) f.R ∩ range I)),
  { rw [← ext_chart_at_symm_map_nhds_within_range I c],
    exact nhds_within_range_basis.map _ },
  refine this.to_has_basis' (λ f hf, ⟨f, trivial, f.closure_support_subset_symm_image_closed_ball⟩)
    (λ f _, f.closure_support_mem_nhds),
end

variable {c}

/-- Given `s ∈ 𝓝 c`, the supports of smooth bump functions `f : smooth_bump_function I c` such that
`closure (support f) ⊆ s` form a basis of `𝓝 c`.  In other words, each of these supports is a
neighborhood of `c` and each neighborhood of `c` includes `support f` for some `f :
smooth_bump_function I c` such that `closure (support f) ⊆ s`. -/
lemma nhds_basis_support {s : set M} (hs : s ∈ 𝓝 c) :
  (𝓝 c).has_basis (λ f : smooth_bump_function I c, closure (support f) ⊆ s) (λ f, support f) :=
((nhds_basis_closure_support I c).restrict_subset hs).to_has_basis'
  (λ f hf, ⟨f, hf.2, subset_closure⟩) (λ f hf, f.support_mem_nhds)

variables [smooth_manifold_with_corners I M] {I}

/-- A smooth bump function is infinitely smooth. -/
protected lemma smooth : smooth I 𝓘(ℝ) f :=
begin
  refine times_cont_mdiff_of_support (λ x hx, _),
  have : x ∈ (chart_at H c).source := f.closure_support_subset_chart_at_source hx,
  refine times_cont_mdiff_at.congr_of_eventually_eq _
    (f.eq_on_source.eventually_eq_of_mem $ mem_nhds_sets (chart_at _ _).open_source this),
  exact f.to_times_cont_diff_bump.times_cont_diff_at.times_cont_mdiff_at.comp _
    (times_cont_mdiff_at_ext_chart_at' this)
end

protected lemma smooth_at {x} : smooth_at I 𝓘(ℝ) f x := f.smooth.smooth_at

/-- If `f : smooth_bump_function I c` is a smooth bump function and `g : M → G` is a function smooth
on the source of the chart at `c`, then `f • g` is smooth on the whole manifold. -/
lemma smooth_smul {G} [normed_group G] [normed_space ℝ G]
  {g : M → G} (hg : smooth_on I 𝓘(ℝ, G) g (chart_at H c).source) :
  smooth I 𝓘(ℝ, G) (λ x, f x • g x) :=
begin
  apply times_cont_mdiff_of_support (λ x hx, _),
  have : x ∈ (chart_at H c).source,
  calc x ∈ closure (support (λ x, f x • g x)) : hx
     ... ⊆ closure (support f) : closure_mono (support_smul_subset_left _ _)
     ... ⊆ (chart_at _ c).source : f.closure_support_subset_chart_at_source,
  exact f.smooth_at.smul ((hg _ this).times_cont_mdiff_at $
    mem_nhds_sets (chart_at _ _).open_source this)
end

end smooth_bump_function

/-!
### Covering by supports of smooth bump functions

In this section we define `smooth_bump_covering I s` to be a collection of `smooth_bump_function`s
such that their supports is a locally finite family of sets and for each `x ∈ s` some function `f i`
from the collection is equal to `1` in a neighborhood of `x`. A covering of this type is useful to
construct a smooth partition of unity and can be used instead of a partition of unity in some
proofs.

We prove that on a smooth finite dimensional real manifold with `σ`-compact Hausdorff topology,
for any `U : M → set M` such that `∀ x ∈ s, U x ∈ 𝓝 x` there exists a `smooth_bump_covering I s`
subordinate to `U`. Then we use this fact to prove a version of the Whitney embedding theorem: any
compact real manifold can be embedded into `ℝ^n` for large enough `n`.
-/

/-- We say that a collection of `smooth_bump_function`s is a `smooth_bump_covering` of a set `s` if

* `(f i).c ∈ s` for all `i`;
* the family `λ i, support (f i)` is locally finite;
* for each point `x ∈ s` there exists `i` such that `f i =ᶠ[𝓝 x] 1`;
  in other words, `x` belongs to the interior of `{y | f i y = 1}`;

If `M` is a finite dimensional real manifold which is a sigma-compact Hausdorff topological space,
then a choice of `smooth_bump_covering` is available as `smooth_bump_covering.choice_set`, see also
`smooth_bump_covering.choice` for the case `s = univ` and
`smooth_bump_covering.exists_is_subordinate` for a lemma providing a covering subordinate to a given
`U : M → set M`.

This covering can be used, e.g., to construct a partition of unity and to prove the weak
Whitney embedding theorem. -/
structure smooth_bump_covering (s : set M) :=
(ι : Type uM)
(c : ι → M)
(to_fun : Π i, smooth_bump_function I (c i))
(c_mem' : ∀ i, c i ∈ s)
(locally_finite' : locally_finite (λ i, support (to_fun i)))
(eventually_eq_one' : ∀ x ∈ s, ∃ i, to_fun i =ᶠ[𝓝 x] 1)

namespace smooth_bump_covering

variables {s : set M} {U : M → set M} (fs : smooth_bump_covering I s) {I}

instance : has_coe_to_fun (smooth_bump_covering I s) := ⟨_, to_fun⟩

@[simp] lemma coe_mk (ι : Type uM) (c : ι → M) (to_fun : Π i, smooth_bump_function I (c i))
  (h₁ h₂ h₃) : ⇑(mk ι c to_fun h₁ h₂ h₃ : smooth_bump_covering I s) = to_fun :=
rfl

/--
We say that `f : smooth_bump_covering I s` is *subordinate* to a map `U : M → set M` if for each
index `i`, we have `closure (support (f i)) ⊆ U (f i).c`. This notion is a bit more general than
being subordinate to an open covering of `M`, because we make no assumption about the way `U x`
depends on `x`.
-/
def is_subordinate {s : set M} (f : smooth_bump_covering I s) (U : M → set M) :=
∀ i, closure (support $ f i) ⊆ U (f.c i)

variable (I)

/-- Let `M` be a smooth manifold with corners modelled on a finite dimensional real vector space.
Suppose also that `M` is a Hausdorff `σ`-compact topological space. Let `s` be a closed set
in `M` and `U : M → set M` be a collection of sets such that `U x ∈ 𝓝 x` for every `x ∈ s`.
Then there exists a smooth bump covering of `s` that is subordinate to `U`. -/
lemma exists_is_subordinate [t2_space M] [sigma_compact_space M] (hs : is_closed s)
  (hU : ∀ x ∈ s, U x ∈ 𝓝 x) :
  ∃ f : smooth_bump_covering I s, f.is_subordinate U :=
begin
  -- First we deduce some missing instances
  haveI : locally_compact_space H := I.locally_compact,
  haveI : locally_compact_space M := charted_space.locally_compact H,
  haveI : normal_space M := normal_of_paracompact_t2,
  -- Next we choose a covering by supports of smooth bump functions
  have hB := λ x hx, smooth_bump_function.nhds_basis_support I (hU x hx),
  rcases refinement_of_locally_compact_sigma_compact_of_nhds_basis_set hs hB
    with ⟨ι, c, f, hf, hsub', hfin⟩, choose hcs hfU using hf,
  /- Then we use the shrinking lemma to get a covering by smaller open -/
  rcases exists_subset_Union_closed_subset hs (λ i, (f i).open_support)
    (λ x hx, hfin.point_finite x) hsub' with ⟨V, hsV, hVc, hVf⟩,
  choose r hrR hr using λ i, (f i).exists_r_pos_lt_subset_ball (hVc i) (hVf i),
  refine ⟨⟨ι, c, λ i, (f i).update_r (r i) (hrR i), hcs, _, λ x hx, _⟩, λ i, _⟩,
  { simpa only [smooth_bump_function.support_update_r] },
  { refine (mem_Union.1 $ hsV hx).imp (λ i hi, _),
    exact ((f i).update_r _ _).eventually_eq_one_of_dist_lt
      ((f i).support_subset_source $ hVf _ hi) (hr i hi).2 },
  { simpa only [coe_mk, smooth_bump_function.support_update_r] using hfU i }
end

/-- Choice of a covering of a closed set `s` by supports of smooth bump functions. -/
def choice_set [t2_space M] [sigma_compact_space M] (s : set M) (hs : is_closed s) :
  smooth_bump_covering I s :=
(exists_is_subordinate I hs (λ x hx, univ_mem_sets)).some

instance [t2_space M] [sigma_compact_space M] {s : set M} [is_closed s] :
  inhabited (smooth_bump_covering I s) :=
⟨choice_set I s ‹_›⟩

variable (M)

/-- Choice of a covering of a manifold by supports of smooth bump functions. -/
def choice [t2_space M] [sigma_compact_space M] :
  smooth_bump_covering I (univ : set M) :=
choice_set I univ is_closed_univ

variables {I M}

protected lemma locally_finite : locally_finite (λ i, support (fs i)) := fs.locally_finite'

protected lemma point_finite (x : M) : {i | fs i x ≠ 0}.finite :=
fs.locally_finite.point_finite x

lemma mem_chart_at_source_of_eq_one {i : fs.ι} {x : M} (h : fs i x = 1) :
  x ∈ (chart_at H (fs.c i)).source :=
(fs i).support_subset_source $ by simp [h]

lemma mem_ext_chart_at_source_of_eq_one {i : fs.ι} {x : M} (h : fs i x = 1) :
  x ∈ (ext_chart_at I (fs.c i)).source :=
by { rw ext_chart_at_source, exact fs.mem_chart_at_source_of_eq_one h }

/-- Index of a bump function such that `fs i =ᶠ[𝓝 x] 1`. -/
def ind (x : M) (hx : x ∈ s) : fs.ι := (fs.eventually_eq_one' x hx).some

lemma eventually_eq_one (x : M) (hx : x ∈ s) : fs (fs.ind x hx) =ᶠ[𝓝 x] 1 :=
(fs.eventually_eq_one' x hx).some_spec

lemma apply_ind (x : M) (hx : x ∈ s) : fs (fs.ind x hx) x = 1 :=
(fs.eventually_eq_one x hx).eq_of_nhds

lemma mem_support_ind (x : M) (hx : x ∈ s) : x ∈ support (fs $ fs.ind x hx) :=
by simp [fs.apply_ind x hx]

lemma mem_chart_at_ind_source (x : M) (hx : x ∈ s) :
  x ∈ (chart_at H (fs.c (fs.ind x hx))).source :=
fs.mem_chart_at_source_of_eq_one (fs.apply_ind x hx)

lemma mem_ext_chart_at_ind_source (x : M) (hx : x ∈ s) :
  x ∈ (ext_chart_at I (fs.c (fs.ind x hx))).source :=
fs.mem_ext_chart_at_source_of_eq_one (fs.apply_ind x hx)

section embedding

/-!
### Whitney embedding theorem

In this section we prove a version of the Whitney embedding theorem: for any compact real manifold
`M`, for sufficiently large `n` there exists a smooth embedding `M → ℝ^n`.
-/

instance fintype_ι_of_compact [compact_space M] : fintype fs.ι :=
fs.locally_finite.fintype_of_compact $ λ i, (fs i).nonempty_support

variables [t2_space M] [fintype fs.ι] (f : smooth_bump_covering I (univ : set M))
  [fintype f.ι]

/-- Smooth embedding of `M` into `(E × ℝ) ^ f.ι`. -/
def embedding_pi_tangent : C^∞⟮I, M; 𝓘(ℝ, fs.ι → (E × ℝ)), fs.ι → (E × ℝ)⟯ :=
{ to_fun := λ x i, (fs i x • ext_chart_at I (fs.c i) x, fs i x),
  times_cont_mdiff_to_fun := times_cont_mdiff_pi_space.2 $ λ i,
    ((fs i).smooth_smul times_cont_mdiff_on_ext_chart_at).prod_mk_space ((fs i).smooth) }

local attribute [simp] lemma embedding_pi_tangent_coe :
  ⇑fs.embedding_pi_tangent = λ x i, (fs i x • ext_chart_at I (fs.c i) x, fs i x) :=
rfl

lemma embedding_pi_tangent_inj_on : inj_on fs.embedding_pi_tangent s :=
begin
  intros x hx y hy h,
  simp only [embedding_pi_tangent_coe, funext_iff] at h,
  obtain ⟨h₁, h₂⟩ := prod.mk.inj_iff.1 (h (fs.ind x hx)),
  rw [fs.apply_ind x hx] at h₂,
  rw [← h₂, fs.apply_ind x hx, one_smul, one_smul] at h₁,
  have := fs.mem_ext_chart_at_source_of_eq_one h₂.symm,
  exact (ext_chart_at I (fs.c _)).inj_on (fs.mem_ext_chart_at_ind_source x hx) this h₁
end

lemma embedding_pi_tangent_injective :
  injective f.embedding_pi_tangent :=
injective_iff_inj_on_univ.2 f.embedding_pi_tangent_inj_on

lemma comp_embedding_pi_tangent_mfderiv (x : M) (hx : x ∈ s) :
  ((continuous_linear_map.fst ℝ E ℝ).comp
    (@continuous_linear_map.proj ℝ _ fs.ι (λ _, E × ℝ) _ _
      (λ _, infer_instance) (fs.ind x hx))).comp
      (mfderiv I 𝓘(ℝ, fs.ι → (E × ℝ)) fs.embedding_pi_tangent x) =
  mfderiv I I (chart_at H (fs.c (fs.ind x hx))) x :=
begin
  set L := ((continuous_linear_map.fst ℝ E ℝ).comp
    (@continuous_linear_map.proj ℝ _ fs.ι (λ _, E × ℝ) _ _ (λ _, infer_instance) (fs.ind x hx))),
  have := (L.has_mfderiv_at.comp x (fs.embedding_pi_tangent.mdifferentiable_at.has_mfderiv_at)),
  convert has_mfderiv_at_unique this _,
  refine (has_mfderiv_at_ext_chart_at I (fs.mem_chart_at_ind_source x hx)).congr_of_eventually_eq _,
  refine (fs.eventually_eq_one x hx).mono (λ y hy, _),
  simp only [embedding_pi_tangent_coe, continuous_linear_map.coe_comp', (∘),
    continuous_linear_map.coe_fst', continuous_linear_map.proj_apply],
  rw [hy, pi.one_apply, one_smul]
end

lemma embedding_pi_tangent_ker_mfderiv (x : M) (hx : x ∈ s) :
  (mfderiv I 𝓘(ℝ, fs.ι → (E × ℝ)) fs.embedding_pi_tangent x).ker = ⊥ :=
begin
  apply bot_unique,
  rw [← (mdifferentiable_chart I (fs.c (fs.ind x hx))).ker_mfderiv_eq_bot
    (fs.mem_chart_at_ind_source x hx), ← comp_embedding_pi_tangent_mfderiv],
  exact linear_map.ker_le_ker_comp _ _
end

lemma embedding_pi_tangent_injective_mfderiv (x : M) (hx : x ∈ s) :
  injective (mfderiv I 𝓘(ℝ, fs.ι → (E × ℝ)) fs.embedding_pi_tangent x) :=
linear_map.ker_eq_bot.1 (fs.embedding_pi_tangent_ker_mfderiv x hx)

end embedding

/-- Baby version of the Whitney weak embedding theorem: if `M` admits a finite covering by
supports of bump functions, then for some `n` it can be immersed into the `n`-dimensional
Euclidean space. -/
lemma exists_immersion_finrank [t2_space M] (f : smooth_bump_covering I (univ : set M))
  [fintype f.ι] :
  ∃ (n : ℕ) (e : M → euclidean_space ℝ (fin n)), smooth I (𝓡 n) e ∧
    injective e ∧ ∀ x : M, injective (mfderiv I (𝓡 n) e x) :=
begin
  set F := euclidean_space ℝ (fin $ finrank ℝ (f.ι → (E × ℝ))),
  letI : finite_dimensional ℝ (E × ℝ) := by apply_instance,
  set eEF : (f.ι → (E × ℝ)) ≃L[ℝ] F :=
    continuous_linear_equiv.of_finrank_eq finrank_euclidean_space_fin.symm,
  refine ⟨_, eEF ∘ f.embedding_pi_tangent,
    eEF.to_diffeomorph.smooth.comp f.embedding_pi_tangent.smooth,
    eEF.injective.comp f.embedding_pi_tangent_injective, λ x, _⟩,
  rw [mfderiv_comp _ eEF.differentiable_at.mdifferentiable_at
    f.embedding_pi_tangent.mdifferentiable_at, eEF.mfderiv_eq],
  exact eEF.injective.comp (f.embedding_pi_tangent_injective_mfderiv _ trivial)
end

end smooth_bump_covering

/-- Baby version of the Whitney weak embedding theorem: if `M` admits a finite covering by
supports of bump functions, then for some `n` it can be embedded into the `n`-dimensional
Euclidean space. -/
lemma exists_embedding_finrank_of_compact [t2_space M] [compact_space M] :
  ∃ (n : ℕ) (e : M → euclidean_space ℝ (fin n)), smooth I (𝓡 n) e ∧
    closed_embedding e ∧ ∀ x : M, injective (mfderiv I (𝓡 n) e x) :=
begin
  rcases (smooth_bump_covering.choice I M).exists_immersion_finrank
    with ⟨n, e, hsmooth, hinj, hinj_mfderiv⟩,
  exact ⟨n, e, hsmooth, hsmooth.continuous.closed_embedding hinj, hinj_mfderiv⟩
end


/-
Copyright (c) 2019 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Chris Hughes
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.zsqrtd.gaussian_int
import Mathlib.PostPort

namespace Mathlib

/-!
# Sums of two squares

Proof of Fermat's theorem on the sum of two squares. Every prime congruent to 1 mod 4 is the sum
of two squares
-/

namespace nat

namespace prime

/-- Fermat's theorem on the sum of two squares. Every prime congruent to 1 mod 4 is the sum
of two squares -/
theorem sum_two_squares (p : ℕ) [hp : fact (prime p)] (hp1 : p % bit0 (bit0 1) = 1) : ∃ (a : ℕ), ∃ (b : ℕ), a ^ bit0 1 + b ^ bit0 1 = p := sorry


/-
Copyright (c) 2021 David Kurniadi Angdinata. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: David Kurniadi Angdinata
-/

import algebra.cubic_discriminant

import algebraic_geometry.EllipticCurve.point

/-!
# Torsion points of an elliptic curve over a field
-/

noncomputable theory
open_locale classical

universe u

variables (n : ℕ)
variables {F : Type u} [field F]
variables {E : EllipticCurve F}
variables {K : Type u} [field K] [algebra F K]
variables {L : Type u} [field L] [algebra F L] [algebra K L] [is_scalar_tower F K L]

----------------------------------------------------------------------------------------------------

namespace EllipticCurve

open point

----------------------------------------------------------------------------------------------------
/-! ## Multiplication by `n` on `E(L)` -/

section multiplication

/-- The Galois-equivariant multiplication by `n` isogeny. -/
def mul_by' : E⟮L⟯ →+[L ≃ₐ[K] L] E⟮L⟯ :=
{ to_fun    := (•) n,
  map_smul' := λ _ _,
  begin
    induction n with n h,
    { refl },
    { simp only [nat.succ_eq_add_one, add_smul, smul_add, one_smul, h] }
  end,
  map_zero' := smul_zero n,
  map_add'  := smul_add n }

/-- The multiplication by `n` isogeny. -/
def mul_by : E⟮K⟯ →+ E⟮K⟯ := (mul_by' n : E⟮K⟯ →+[K ≃ₐ[K] K] E⟮K⟯)

lemma mul_by.map_smul (σ : L ≃ₐ[K] L) (P : E⟮L⟯) : n • σ • P = σ • n • P :=
(mul_by' n).map_smul' σ P

lemma mul_by.map_zero : n • 0 = (0 : E⟮L⟯) :=
(mul_by' n : E⟮L⟯ →+[L ≃ₐ[K] L] E⟮L⟯).map_zero'

lemma mul_by.map_add (P Q : E⟮L⟯) : n • (P + Q) = n • P + n • Q :=
(mul_by' n : E⟮L⟯ →+[L ≃ₐ[K] L] E⟮L⟯).map_add' P Q

notation E⟮K⟯[n] := (mul_by n : E⟮K⟯ →+ E⟮K⟯).ker
notation E⟮K⟯`⬝`n := (mul_by n : E⟮K⟯ →+ E⟮K⟯).range
notation E⟮K⟯/n := E⟮K⟯ ⧸ E⟮K⟯⬝n

end multiplication

----------------------------------------------------------------------------------------------------
/-! ## Functoriality of `K ↦ E(K)[n]` -/

section functoriality

variables (φ : K →ₐ[F] L)

/-- Group homomorphism `E(K)[n] → E(L)[n]`. -/
def ker_hom : E⟮K⟯[n] →+ E⟮L⟯[n] :=
{ to_fun    := λ ⟨P, hP⟩, ⟨point_hom φ P,
  by { change n • P = 0 at hP, change n • _ = (0 : E⟮L⟯), rw [← map_nsmul, hP], refl }⟩,
  map_zero' := rfl,
  map_add'  := λ ⟨_, _⟩ ⟨_, _⟩, by { change (⟨_, _⟩ : E⟮L⟯[n]) = ⟨_, _⟩, simp only, apply map_add } }

@[simp] lemma ker_hom.map_zero : ker_hom n φ 0 = (0 : E⟮L⟯[n]) := (ker_hom n φ).map_zero'

@[simp] lemma ker_hom.map_add (P Q : E⟮K⟯[n]) :
  ker_hom n φ (P + Q) = ker_hom n φ P + ker_hom n φ Q :=
(ker_hom n φ).map_add P Q

@[simp] lemma ker_hom.id (P : E⟮K⟯[n]) : ker_hom n (K⟶[F]K) P = P := by rcases P with _ | _; refl

@[simp] lemma ker_hom.comp {M : Type u} [field M] [algebra F M] [algebra K M] [algebra L M]
  [is_scalar_tower F L M] [is_scalar_tower F K M] (P : E⟮K⟯[n]) :
  ker_hom n (L⟶[F]M) (ker_hom n (K⟶[F]L) P) = ker_hom n ((L⟶[F]M).comp (K⟶[F]L)) P :=
by rcases P with _ | _; refl

lemma ker_hom.injective : function.injective $ @ker_hom n _ _ E _ _ _ _ _ _ _ _ φ :=
begin
  intros P Q hPQ,
  rcases ⟨P, Q⟩ with ⟨⟨P, _⟩, ⟨Q, _⟩⟩,
  change (⟨point_hom φ P, _⟩ : E⟮L⟯[n]) = ⟨point_hom φ Q, _⟩ at hPQ,
  simp only at hPQ,
  simpa only [subtype.mk_eq_mk] using point_hom.injective φ hPQ
end

/-- Canonical inclusion map `E(K)[n] ↪ E(L)[n]`. -/
def ιₙ : E⟮K⟯[n] →+ E⟮L⟯[n] := ker_hom n $ K⟶[F]L

end functoriality

----------------------------------------------------------------------------------------------------
/-! ## Galois module structure of `E(L)[n]` -/

section galois

variables (σ τ : L ≃ₐ[K] L)

/-- The Galois action `Gal(L/K) ↷ E(L)[n]`. -/
def ker_gal : E⟮L⟯[n] → E⟮L⟯[n] := λ ⟨P, hP⟩, ⟨σ • P,
by { change n • P = 0 at hP, change n • σ • P = 0, rw [mul_by.map_smul, hP], refl }⟩

/-- `Gal(L/K) ↷ E(L)[n]` is a scalar action. -/
instance : has_scalar (L ≃ₐ[K] L) E⟮L⟯[n] := ⟨ker_gal n⟩

/-- `Gal(L/K) ↷ E(L)[n]` is a multiplicative action. -/
instance : mul_action (L ≃ₐ[K] L) E⟮L⟯[n] :=
{ smul     := ker_gal n,
  one_smul := λ ⟨_, _⟩,
  by { simp only [ker_gal, subtype.mk_eq_mk], apply point.distrib_mul_action.one_smul },
  mul_smul := λ σ τ ⟨_, _⟩,
  by { simp only [ker_gal, subtype.mk_eq_mk], apply point.distrib_mul_action.mul_smul } }

/-- The Galois invariant subgroup `E(L)[n]ᴷ` of `E(L)[n]` fixed by `Gal(L/K)`. -/
def ker_gal.fixed : add_subgroup E⟮L⟯[n] :=
{ carrier   := mul_action.fixed_points (L ≃ₐ[K] L) E⟮L⟯[n],
  zero_mem' := λ _, rfl,
  add_mem'  :=
  begin
    rintro ⟨P, _⟩ ⟨Q, _⟩ hP hQ,
    change ∀ σ : L ≃ₐ[K] L, (⟨σ • P, _⟩ : E⟮L⟯[n]) = ⟨P, _⟩ at hP,
    change ∀ σ : L ≃ₐ[K] L, (⟨σ • Q, _⟩ : E⟮L⟯[n]) = ⟨Q, _⟩ at hQ,
    simp only at hP hQ,
    change ∀ σ : L ≃ₐ[K] L, (⟨σ • (P + Q), _⟩ : E⟮L⟯[n]) = ⟨P + Q, _⟩,
    simp only,
    exact point_gal.fixed.add_mem hP hQ
  end,
  neg_mem'  :=
  begin
    rintro ⟨P, _⟩ hP,
    change ∀ σ : L ≃ₐ[K] L, (⟨σ • P, _⟩ : E⟮L⟯[n]) = ⟨P, _⟩ at hP,
    simp only at hP,
    change ∀ σ : L ≃ₐ[K] L, (⟨σ • -P, _⟩ : E⟮L⟯[n]) = ⟨-P, _⟩,
    simp only,
    exact point_gal.fixed.neg_mem hP
  end }

notation E⟮L⟯[n`]^`K := @ker_gal.fixed n _ _ E K _ _ L _ _ _ _

lemma ker_gal.fixed.zero_mem : (0 : E⟮L⟯[n]) ∈ E⟮L⟯[n]^K := (ker_gal.fixed n).zero_mem'

lemma ker_gal.fixed.add_mem {P Q : E⟮L⟯[n]} (hP : P ∈ E⟮L⟯[n]^K) (hQ : Q ∈ E⟮L⟯[n]^K) :
  P + Q ∈ E⟮L⟯[n]^K :=
(ker_gal.fixed n).add_mem' hP hQ

lemma ker_gal.fixed.neg_mem {P : E⟮L⟯[n]} (hP : P ∈ E⟮L⟯[n]^K) : -P ∈ E⟮L⟯[n]^K :=
(ker_gal.fixed n).neg_mem' hP

variables [finite_dimensional K L] [is_galois K L]

lemma ker_gal.fixed.eq : (E⟮L⟯[n]^K) = (ιₙ n : E⟮K⟯[n] →+ E⟮L⟯[n]).range :=
begin
  ext ⟨P, hP⟩,
  change n • P = 0 at hP,
  change (∀ σ : L ≃ₐ[K] L, (⟨σ • P, _⟩ : E⟮L⟯[n]) = ⟨P, hP⟩) ↔ _,
  simp only,
  change P ∈ (E⟮L⟯^K) ↔ _,
  rw [point_gal.fixed.eq],
  split,
  { rintro ⟨Q, hQ⟩,
    existsi [(⟨Q, _⟩ : E⟮K⟯[n])],
    { change (⟨ιₚ Q, _⟩ : E⟮L⟯[n]) = _,
      simp only [hQ] },
    { rw [← hQ, ← map_nsmul] at hP,
      change n • Q = 0,
      apply_fun (ιₚ : E⟮K⟯ →+ E⟮L⟯) using point_hom.injective,
      rw [hP],
      refl } },
  { rintro ⟨⟨Q⟩, hQ⟩,
    exact ⟨Q, by injection hQ⟩ }
end

end galois

----------------------------------------------------------------------------------------------------
/-! ## The 2-torsion polynomial -/

section ψ₂_x

/-- The cubic polynomial `ψ₂(x)` of the `x`-coordinate in `E(K)[2]`. -/
def ψ₂_x (E : EllipticCurve F) (K : Type u) [field K] [algebra F K] : cubic K :=
⟨4, (F↑K)E.a₁ ^ 2 + 4 * (F↑K)E.a₂, 4 * (F↑K)E.a₄ + 2 * (F↑K)E.a₁ * (F↑K)E.a₃,
  (F↑K)E.a₃ ^ 2 + 4 * (F↑K)E.a₆⟩

notation F⟮E`[2]⟯` := (ψ₂_x E F).to_poly.splitting_field

lemma ψ₂_x.eq_map : ψ₂_x E K = cubic.map (F↑K) (ψ₂_x E F) :=
begin
  rw [ψ₂_x, cubic.map, ψ₂_x],
  simp only [map_add, map_mul, map_pow],
  simp only [map_one, map_bit0, map_bit1, algebra.id.map_eq_self],
  exact ⟨rfl, rfl, rfl, rfl⟩
end

lemma ψ₂_x.eq_cov (s t : F) : ψ₂_x E K = ψ₂_x (E.cov 1 0 s t) K :=
begin
  simp only [ψ₂_x, cov, units.inv],
  simp only [map_add, map_sub, map_mul, map_pow],
  simp only [map_zero, map_one, map_bit0, map_bit1],
  exact ⟨rfl, by ring1, by ring1, by ring1⟩
end

lemma ψ₂_x.disc_eq_disc : (ψ₂_x E K).disc = 4 * 4 * (F↑K)E.disc :=
begin
  rw [cubic.disc, ψ₂_x, disc, disc_aux],
  simp only [map_neg, map_add, map_sub, map_mul, map_pow],
  simp only [map_one, map_bit0, map_bit1],
  ring1
end

lemma ψ₂_x.splits (K : Type u) [field K] [algebra F K] [algebra F⟮E[2]⟯ K]
  [is_scalar_tower F F⟮E[2]⟯ K] : polynomial.splits (F↑K) (ψ₂_x E F).to_poly :=
begin
  convert polynomial.splits_comp_of_splits (F↑F⟮E[2]⟯) (F⟮E[2]⟯↑K)
    (polynomial.splitting_field.splits (ψ₂_x E F).to_poly),
  symmetry,
  exact ring_hom.ext (alg_hom.commutes $ (ψ₂_x E F).to_poly.splitting_field⟶[F]K)
end

variables [invertible (2 : F)]

private def invertible_two (K : Type u) [field K] [algebra F K] (h2 : invertible (2 : F)) :
  invertible (2 : K) :=
begin
  rw [← algebra.id.map_eq_self (2 : F)] at h2,
  replace h2 := @is_scalar_tower.invertible.algebra_tower _ _ K _ _ _ _ _ _ _ _ h2,
  rw [map_bit0, map_one] at h2,
  exact h2
end

private lemma two_ne_zero (K : Type u) [field K] [algebra F K] (h2 : invertible (2 : F)) :
  2 ≠ (0 : K) :=
@nonzero_of_invertible _ _ (2 : K) _ $ invertible_two K h2

private lemma four_ne_zero (K : Type u) [field K] [algebra F K] (h2 : invertible (2 : F)) :
  4 ≠ (0 : K) :=
begin
  convert_to 2 * 2 ≠ (0 : K),
  { norm_num1 },
  exact mul_ne_zero (two_ne_zero K h2) (two_ne_zero K h2)
end

lemma ψ₂_x.a_ne_zero (E : EllipticCurve F) (K : Type u) [field K] [algebra F K] :
  (ψ₂_x E K).a ≠ 0 :=
four_ne_zero K _inst_8

lemma ψ₂_x.eq_covₘ : ψ₂_x E K = ψ₂_x E.covₘ K := ψ₂_x.eq_cov (-⅟2 * E.a₁) (-⅟2 * E.a₃)

lemma ψ₂_x.mem_roots_iff (x : K) :
  x ∈ (ψ₂_x E K).roots ↔ ((F↑K)E.a₁ * x + (F↑K)E.a₃) ^ 2 +
                         4 * (x ^ 3 + (F↑K)E.a₂ * x ^ 2 + (F↑K)E.a₄ * x + (F↑K)E.a₆) = 0 :=
begin
  have rhs_rw : ∀ a₁ a₂ a₃ a₄ a₆ : K,
    (a₁ * x + a₃) ^ 2 + 4 * (x ^ 3 + a₂ * x ^ 2 + a₄ * x + a₆)
      = 4 * x ^ 3 + (a₁ ^ 2 + 4 * a₂) * x ^ 2 + (4 * a₄ + 2 * a₁ * a₃) * x + (a₃ ^ 2 + 4 * a₆) :=
  by { intros, ring1 },
  rw [cubic.mem_roots_iff $ cubic.ne_zero_of_a_ne_zero $ ψ₂_x.a_ne_zero E K, ψ₂_x, rhs_rw]
end

lemma ψ₂_x.disc_ne_zero : (ψ₂_x E K).disc ≠ 0 :=
begin
  rw [ψ₂_x.disc_eq_disc],
  apply mul_ne_zero,
  apply mul_ne_zero,
  any_goals { exact four_ne_zero K _inst_8 },
  simpa only [ring_hom.map_ne_zero, disc, ← disc_unit_eq] using units.ne_zero E.disc_unit
end

lemma ψ₂_x.roots_ne {a b c : K} (h3 : (cubic.map (F↑K) $ ψ₂_x E F).roots = {a, b, c}) :
  a ≠ b ∧ a ≠ c ∧ b ≠ c :=
(cubic.disc_ne_zero_iff_roots_ne (ψ₂_x.a_ne_zero E F) h3).mp ψ₂_x.disc_ne_zero

end ψ₂_x

----------------------------------------------------------------------------------------------------
/-! ## Structure of `E(K)[2]` -/

section E₂

variables [invertible (2 : F)]

lemma E₂_y {x y w} : some x y w ∈ E⟮K⟯[2] ↔ y = 2⁻¹ * -((F↑K)E.a₁ * x + (F↑K)E.a₃) :=
begin
  change 2 • some x y w = 0 ↔ _,
  rw [two_smul, add_eq_zero_iff_eq_neg, EllipticCurve.neg_some,
      eq_inv_mul_iff_mul_eq₀ $ two_ne_zero K _inst_8, two_mul, ← eq_neg_add_iff_add_eq,
      ← sub_eq_add_neg, sub_add_eq_sub_sub],
  simp only [true_and, eq_self_iff_true]
end

lemma E₂_x {x y w} : some x y w ∈ E⟮K⟯[2] ↔ x ∈ (ψ₂_x E K).roots :=
begin
  have lhs_rw : ∀ a₁ a₃ : K,
    (a₁ * x + a₃) ^ 2 + 4 * (y ^ 2 + a₁ * x * y + a₃ * y) = (2 * y + a₁ * x + a₃) ^ 2 :=
  by { intros, ring1 },
  rw [E₂_y, eq_inv_mul_iff_mul_eq₀ $ two_ne_zero K _inst_8, eq_neg_iff_add_eq_zero,
      ← add_semigroup.add_assoc, ψ₂_x.mem_roots_iff, ← w, lhs_rw, pow_eq_zero_iff zero_lt_two],
  { refl },
  { exact is_domain.to_no_zero_divisors K }
end

/-- The projection map `E₂_to_ψ₂ : E(K)[2] → {0} ∪ ψ₂(x).roots`. -/
def E₂_to_ψ₂ : E⟮K⟯[2] → option ({x // x ∈ (ψ₂_x E K).roots})
| ⟨0         , _⟩ := none
| ⟨some x y w, h⟩ := some ⟨x, E₂_x.mp h⟩

lemma E₂_to_ψ₂.injective : function.injective $ @E₂_to_ψ₂ _ _ E K _ _ _ :=
begin
  rintro ⟨_ | _, hP⟩ ⟨_ | _, hQ⟩ hPQ,
  any_goals { contradiction },
  { refl },
  { simp only [E₂_to_ψ₂] at hPQ,
    rw [E₂_y] at hP hQ,
    substs hP hQ hPQ }
end

/-- `E(K)[2]` is finite. -/
instance : fintype E⟮K⟯[2] := fintype.of_injective E₂_to_ψ₂ E₂_to_ψ₂.injective

theorem E₂.card_le_four : fintype.card E⟮K⟯[2] ≤ 4 :=
begin
  change fintype.card E⟮K⟯[2] ≤ 3 + 1,
  apply le_trans (fintype.card_le_of_injective E₂_to_ψ₂ E₂_to_ψ₂.injective),
  rw [fintype.card_option, add_le_add_iff_right,
      fintype.card_of_subtype (ψ₂_x E K).roots.to_finset (λ _, multiset.mem_to_finset)],
  { exact cubic.card_roots_le },
  { exact _inst_8 }
end

lemma E₂_to_ψ₂.surjective : function.surjective $ @E₂_to_ψ₂ _ _ E K _ _ _ :=
begin
  rintro (_ | ⟨x⟩),
  { exact ⟨⟨0, add_subgroup.zero_mem E⟮K⟯[2]⟩, rfl⟩ },
  { existsi [(⟨some x (2⁻¹ * -((F↑K)E.a₁ * x + (F↑K)E.a₃)) _, E₂_y.mpr rfl⟩ : E⟮K⟯[2])],
    { rw [E₂_to_ψ₂, subtype.coe_eta] },
    convert_to 4⁻¹ * -((F↑K)E.a₁ * x + (F↑K)E.a₃) ^ 2
               = x ^ 3 + (F↑K)E.a₂ * x ^ 2 + (F↑K)E.a₄ * x + (F↑K)E.a₆,
    { have lhs_rw : ∀ a₁ a₃ t : K,
      (t * -(a₁ * x + a₃)) ^ 2 + a₁ * x * (t * -(a₁ * x + a₃)) + a₃ * (t * -(a₁ * x + a₃))
        = (1 - t) * t * -(a₁ * x + a₃) ^ 2 :=
      by { intros, ring1 },
      have half_sub_fourth : ((1 : K) - 2⁻¹) * 2⁻¹ = 4⁻¹ :=
      by { nth_rewrite 0 [← mul_inv_cancel $ two_ne_zero K _inst_8],
           rw [two_mul, add_sub_cancel, ← mul_inv₀], norm_num1 },
      rw [lhs_rw, half_sub_fourth] },
    rw [inv_mul_eq_iff_eq_mul₀ $ four_ne_zero K _inst_8, neg_eq_iff_add_eq_zero,
        ← ψ₂_x.mem_roots_iff],
    exact x.property }
end

lemma E₂_to_ψ₂.bijective : function.bijective $ @E₂_to_ψ₂ _ _ E K _ _ _ :=
⟨E₂_to_ψ₂.injective, E₂_to_ψ₂.surjective⟩

/-- `E(K)[2] ≃ {0} ∪ ψ₂(x).roots`. -/
def E₂_to_ψ₂.equiv : E⟮K⟯[2] ≃ option {x // x ∈ (ψ₂_x E K).roots} :=
equiv.of_bijective E₂_to_ψ₂ E₂_to_ψ₂.bijective

variables [algebra F⟮E[2]⟯ K] [is_scalar_tower F F⟮E[2]⟯ K]
variables [algebra F⟮E[2]⟯ L] [is_scalar_tower F F⟮E[2]⟯ L]

theorem E₂.card_eq_four : fintype.card E⟮K⟯[2] = 4 :=
begin
  let h3 := ((cubic.splits_iff_roots_eq_three $ ψ₂_x.a_ne_zero E F).mp $ ψ₂_x.splits K)
    .some_spec.some_spec.some_spec,
  change fintype.card E⟮K⟯[2] = 3 + 1,
  rw [fintype.card_congr E₂_to_ψ₂.equiv, fintype.card_option, add_left_inj,
      fintype.card_of_subtype (ψ₂_x E K).roots.to_finset $ λ _, multiset.mem_to_finset, ψ₂_x.eq_map,
      cubic.card_roots_of_disc_ne_zero (ψ₂_x.a_ne_zero E F) h3 ψ₂_x.disc_ne_zero],
  exact _inst_8
end

lemma E₂.hom.bijective : function.bijective $ @ιₙ 2 _ _ E K _ _ L _ _ _ _ :=
begin
  rw [fintype.bijective_iff_injective_and_card],
  exact ⟨ker_hom.injective 2 $ K⟶[F]L, by rw [E₂.card_eq_four, E₂.card_eq_four]⟩
end

/-- `E(K)[2] ≃ E(L)[2]`. -/
def E₂.hom.equiv : E⟮K⟯[2] ≃ E⟮L⟯[2] := equiv.of_bijective (ιₙ 2) E₂.hom.bijective

variables [finite_dimensional K L] [is_galois K L]

lemma E₂.gal.fixed.smul (σ : L ≃ₐ[K] L) (P : E⟮L⟯[2]) : σ • P = P :=
begin
  revert σ,
  change P ∈ E⟮L⟯[2]^K,
  rw [ker_gal.fixed.eq],
  exact ⟨E₂.hom.equiv.inv_fun P, function.surj_inv_eq E₂.hom.bijective.surjective P⟩
end

end E₂

----------------------------------------------------------------------------------------------------

end EllipticCurve


import tactic

/-- An infinite subset of `ℕ`, viewed as a subsequence. -/
@[reducible] def subseq : Type := ℕ ↪o ℕ

section mul

variables {α : Type*} [has_mul α] [has_zero α] [partial_order α]

def mul_left_order_embedding [pos_mul_mono_rev α] [pos_mul_mono α] {a : α} (ha : 0 < a) : α ↪o α :=
{ to_fun := λ n, a * n,
  inj' := λ _ _ h,
  (le_of_mul_le_mul_of_pos_left h.le ha).antisymm (le_of_mul_le_mul_of_pos_left h.symm.le ha),
  map_rel_iff' := λ _ _,  mul_le_mul_left ha}

@[simp] lemma mul_left_order_embedding_apply [pos_mul_mono_rev α] [pos_mul_mono α] {a : α}
(ha : 0 < a) {x : α}:
  mul_left_order_embedding ha x = a * x := rfl

def mul_right_order_embedding [mul_pos_mono_rev α] [mul_pos_mono α] {a : α} (ha : 0 < a) : α ↪o α :=
{ to_fun := λ n, n * a,
  inj' := λ _ _ h,
  (le_of_mul_le_mul_of_pos_right h.le ha).antisymm (le_of_mul_le_mul_of_pos_right h.symm.le ha),
  map_rel_iff' := λ _ _,  mul_le_mul_right ha}

@[simp] lemma mul_right_order_embedding_apply [mul_pos_mono_rev α] [mul_pos_mono α] {a : α}
(ha : 0 < a) {x : α}:
  mul_right_order_embedding ha x = x * a := rfl

end mul

section update

variables {α β : Type*} [decidable_eq α]

lemma function.injective.update {f : α → β} {a : α} {b : β} (hf : f.injective)
(h : ∀ a', f a' = b → a' = a) : (f.update a b).injective :=
begin
  intros x y hxy,
  obtain ⟨rfl | hx, rfl | hy⟩ := ⟨eq_or_ne x a, eq_or_ne y a⟩,
  { simp, },
  { rw [function.update_same, function.update_noteq hy] at hxy,
    exact (hy (h _ hxy.symm)).elim},
  { rw [function.update_same, function.update_noteq hx] at hxy,
    exact (hx (h _ hxy)).elim},
  rw [function.update_noteq hx, function.update_noteq hy] at hxy,
  exact hf hxy,
end

variables  [partial_order α] [partial_order β]

/--
Update an order_embedding `e` by changing the value of `e a` to `b`.
-/
def order_embedding.update (e : α ↪o β) (a : α) (b : β) (h_le : ∀ x ≠ a, x ≤ a ↔ e x ≤ b)
(h_ge : ∀ x ≠ a, a ≤ x ↔ b ≤ e x) : α ↪o β :=
{ to_fun := function.update e a b,
  inj' := e.injective.update
  begin
    rintros x rfl,
    by_contradiction,
    exact h (le_antisymm (by simpa using h_le _ h) (by simpa using h_ge _ h)),
  end ,
  map_rel_iff' := by {
    intros x y,
    simp only [function.embedding.coe_fn_mk, function.update_apply],
    split_ifs with h h' h',
    { simp [h,h']},
    { subst h,
      rw h_ge _ h', },
    { subst h',
      rw h_le _ h,  },
    rw e.le_iff_le} }

@[simp] lemma order_embedding.update_apply (e : α ↪o β) (a : α) (b : β)
(h_le : ∀ x ≠ a, x ≤ a ↔ e x ≤ b) (h_ge : ∀ x ≠ a, a ≤ x ↔ b ≤ e x) (x : α) :
  (e.update a b h_le h_ge) x = if x = a then b else e x :=
  function.update_apply e a b x

end update

-- order_embedding.of_map_le_iff (function.update e a b)
-- begin
--   intros x y ,
--   obtain ⟨rfl | hx, rfl | hy⟩ := ⟨eq_or_ne a x, eq_or_ne a y⟩,
--   { simp, },
--   { rw [function.update_same, function.update_noteq hy.symm, hy.le_iff_lt],

--     refine ⟨λ h, _,λ h, _⟩,
--     { rw ← e.le_iff_le,
--       have := e.le_iff_le }, },
--   -- rw [function.update_apply, function.update_apply, le_iff_eq_or_lt],
--   -- split_ifs,
--   -- { simp [h,h_1]},
--   -- { subst h, }

-- end


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import topology.urysohns_lemma
import topology.continuous_function.bounded

/-!
# Metrizability of a regular topological space with second countable topology

In this file we define metrizable topological spaces, i.e., topological spaces for which there
exists a metric space structure that generates the same topology.

We also show that a regular topological space with second countable topology `X` is metrizable.

First we prove that `X` can be embedded into `l^∞`, then use this embedding to pull back the metric
space structure.
-/

open set filter metric
open_locale bounded_continuous_function filter topological_space

namespace topological_space

variables {ι X Y : Type*} {π : ι → Type*} [topological_space X] [topological_space Y]
  [fintype ι] [Π i, topological_space (π i)]

/-- A topological space is *pseudo metrizable* if there exists a pseudo metric space structure
compatible with the topology. To endow such a space with a compatible distance, use
`letI : pseudo_metric_space X := topological_space.pseudo_metrizable_space_pseudo_metric X`. -/
class pseudo_metrizable_space (X : Type*) [t : topological_space X] : Prop :=
(exists_pseudo_metric : ∃ (m : pseudo_metric_space X), m.to_uniform_space.to_topological_space = t)

@[priority 100]
instance _root_.pseudo_metric_space.to_pseudo_metrizable_space {X : Type*}
  [m : pseudo_metric_space X] :
  pseudo_metrizable_space X :=
⟨⟨m, rfl⟩⟩

/-- Construct on a metrizable space a metric compatible with the topology. -/
noncomputable def pseudo_metrizable_space_pseudo_metric
  (X : Type*) [topological_space X] [h : pseudo_metrizable_space X] :
  pseudo_metric_space X :=
h.exists_pseudo_metric.some.replace_topology h.exists_pseudo_metric.some_spec.symm

instance pseudo_metrizable_space_prod [pseudo_metrizable_space X] [pseudo_metrizable_space Y] :
  pseudo_metrizable_space (X × Y) :=
begin
  letI : pseudo_metric_space X := pseudo_metrizable_space_pseudo_metric X,
  letI : pseudo_metric_space Y := pseudo_metrizable_space_pseudo_metric Y,
  apply_instance
end

/-- Given an inducing map of a topological space into a pseudo metrizable space, the source space
is also pseudo metrizable. -/
lemma _root_.inducing.pseudo_metrizable_space [pseudo_metrizable_space Y] {f : X → Y}
  (hf : inducing f) :
  pseudo_metrizable_space X :=
begin
  letI : pseudo_metric_space Y := pseudo_metrizable_space_pseudo_metric Y,
  exact ⟨⟨hf.comap_pseudo_metric_space, rfl⟩⟩
end

instance pseudo_metrizable_space.subtype [pseudo_metrizable_space X]
  (s : set X) : pseudo_metrizable_space s :=
inducing_coe.pseudo_metrizable_space

instance pseudo_metrizable_space_pi [Π i, pseudo_metrizable_space (π i)] :
  pseudo_metrizable_space (Π i, π i) :=
by { letI := λ i, pseudo_metrizable_space_pseudo_metric (π i), apply_instance }

/-- A topological space is metrizable if there exists a metric space structure compatible with the
topology. To endow such a space with a compatible distance, use
`letI : metric_space X := topological_space.metrizable_space_metric X` -/
class metrizable_space (X : Type*) [t : topological_space X] : Prop :=
(exists_metric : ∃ (m : metric_space X), m.to_uniform_space.to_topological_space = t)

@[priority 100]
instance _root_.metric_space.to_metrizable_space {X : Type*} [m : metric_space X] :
  metrizable_space X :=
⟨⟨m, rfl⟩⟩

@[priority 100]
instance metrizable_space.to_pseudo_metrizable_space [h : metrizable_space X] :
  pseudo_metrizable_space X :=
⟨let ⟨m, hm⟩ := h.1 in ⟨m.to_pseudo_metric_space, hm⟩⟩

/-- Construct on a metrizable space a metric compatible with the topology. -/
noncomputable def metrizable_space_metric (X : Type*) [topological_space X]
  [h : metrizable_space X] :
  metric_space X :=
h.exists_metric.some.replace_topology h.exists_metric.some_spec.symm

@[priority 100]
instance t2_space_of_metrizable_space [metrizable_space X] : t2_space X :=
by { letI : metric_space X := metrizable_space_metric X, apply_instance }

instance metrizable_space_prod [metrizable_space X] [metrizable_space Y] :
  metrizable_space (X × Y) :=
begin
  letI : metric_space X := metrizable_space_metric X,
  letI : metric_space Y := metrizable_space_metric Y,
  apply_instance
end

/-- Given an embedding of a topological space into a metrizable space, the source space is also
metrizable. -/
lemma _root_.embedding.metrizable_space [metrizable_space Y] {f : X → Y} (hf : embedding f) :
  metrizable_space X :=
begin
  letI : metric_space Y := metrizable_space_metric Y,
  exact ⟨⟨hf.comap_metric_space f, rfl⟩⟩
end

instance metrizable_space.subtype [metrizable_space X] (s : set X) : metrizable_space s :=
embedding_subtype_coe.metrizable_space

instance metrizable_space_pi [Π i, metrizable_space (π i)] : metrizable_space (Π i, π i) :=
by { letI := λ i, metrizable_space_metric (π i), apply_instance }

variables (X) [regular_space X] [second_countable_topology X]

/-- A regular topological space with second countable topology can be embedded into `l^∞ = ℕ →ᵇ ℝ`.
-/
lemma exists_embedding_l_infty : ∃ f : X → (ℕ →ᵇ ℝ), embedding f :=
begin
  haveI : normal_space X := normal_space_of_regular_second_countable X,
  -- Choose a countable basis, and consider the set `s` of pairs of set `(U, V)` such that `U ∈ B`,
  -- `V ∈ B`, and `closure U ⊆ V`.
  rcases exists_countable_basis X with ⟨B, hBc, -, hB⟩,
  set s : set (set X × set X) := {UV ∈ B ×ˢ B| closure UV.1 ⊆ UV.2},
  -- `s` is a countable set.
  haveI : encodable s := ((hBc.prod hBc).mono (inter_subset_left _ _)).to_encodable,
  -- We don't have the space of bounded (possibly discontinuous) functions, so we equip `s`
  -- with the discrete topology and deal with `s →ᵇ ℝ` instead.
  letI : topological_space s := ⊥, haveI : discrete_topology s := ⟨rfl⟩,
  suffices : ∃ f : X → (s →ᵇ ℝ), embedding f,
  { rcases this with ⟨f, hf⟩,
    exact ⟨λ x, (f x).extend (encodable.encode' s) 0, (bounded_continuous_function.isometry_extend
      (encodable.encode' s) (0 : ℕ →ᵇ ℝ)).embedding.comp hf⟩ },
  have hd : ∀ UV : s, disjoint (closure UV.1.1) (UV.1.2ᶜ) :=
    λ UV, disjoint_compl_right.mono_right (compl_subset_compl.2 UV.2.2),
  -- Choose a sequence of `εₙ > 0`, `n : s`, that is bounded above by `1` and tends to zero
  -- along the `cofinite` filter.
  obtain ⟨ε, ε01, hε⟩ : ∃ ε : s → ℝ, (∀ UV, ε UV ∈ Ioc (0 : ℝ) 1) ∧ tendsto ε cofinite (𝓝 0),
  { rcases pos_sum_of_encodable zero_lt_one s with ⟨ε, ε0, c, hεc, hc1⟩,
    refine ⟨ε, λ UV, ⟨ε0 UV, _⟩, hεc.summable.tendsto_cofinite_zero⟩,
    exact (le_has_sum hεc UV $ λ _ _, (ε0 _).le).trans hc1 },
  /- For each `UV = (U, V) ∈ s` we use Urysohn's lemma to choose a function `f UV` that is equal to
  zero on `U` and is equal to `ε UV` on the complement to `V`. -/
  have : ∀ UV : s, ∃ f : C(X, ℝ), eq_on f 0 UV.1.1 ∧ eq_on f (λ _, ε UV) UV.1.2ᶜ ∧
    ∀ x, f x ∈ Icc 0 (ε UV),
  { intro UV,
    rcases exists_continuous_zero_one_of_closed is_closed_closure
      (hB.is_open UV.2.1.2).is_closed_compl (hd UV) with ⟨f, hf₀, hf₁, hf01⟩,
    exact ⟨ε UV • f, λ x hx, by simp [hf₀ (subset_closure hx)], λ x hx, by simp [hf₁ hx],
      λ x, ⟨mul_nonneg (ε01 _).1.le (hf01 _).1, mul_le_of_le_one_right (ε01 _).1.le (hf01 _).2⟩⟩ },
  choose f hf0 hfε hf0ε,
  have hf01 : ∀ UV x, f UV x ∈ Icc (0 : ℝ) 1,
    from λ UV x, Icc_subset_Icc_right (ε01 _).2 (hf0ε _ _),
  /- The embedding is given by `F x UV = f UV x`. -/
  set F : X → s →ᵇ ℝ := λ x, ⟨⟨λ UV, f UV x, continuous_of_discrete_topology⟩, 1, λ UV₁ UV₂,
    real.dist_le_of_mem_Icc_01 (hf01 _ _) (hf01 _ _)⟩,
  have hF : ∀ x UV, F x UV = f UV x := λ _ _, rfl,
  refine ⟨F, embedding.mk' _ (λ x y hxy, _) (λ x, le_antisymm _ _)⟩,
  { /- First we prove that `F` is injective. Indeed, if `F x = F y` and `x ≠ y`, then we can find
    `(U, V) ∈ s` such that `x ∈ U` and `y ∉ V`, hence `F x UV = 0 ≠ ε UV = F y UV`. -/
    refine not_not.1 (λ Hne, _), -- `by_contra Hne` timeouts
    rcases hB.mem_nhds_iff.1 (is_open_ne.mem_nhds Hne) with ⟨V, hVB, hxV, hVy⟩,
    rcases hB.exists_closure_subset (hB.mem_nhds hVB hxV) with ⟨U, hUB, hxU, hUV⟩,
    set UV : ↥s := ⟨(U, V), ⟨hUB, hVB⟩, hUV⟩,
    apply (ε01 UV).1.ne,
    calc (0 : ℝ) = F x UV : (hf0 UV hxU).symm
             ... = F y UV : by rw hxy
             ... = ε UV   : hfε UV (λ h : y ∈ V, hVy h rfl) },
  { /- Now we prove that each neighborhood `V` of `x : X` include a preimage of a neighborhood of
    `F x` under `F`. Without loss of generality, `V` belongs to `B`. Choose `U ∈ B` such that
    `x ∈ V` and `closure V ⊆ U`. Then the preimage of the `(ε (U, V))`-neighborhood of `F x`
    is included by `V`. -/
    refine ((nhds_basis_ball.comap _).le_basis_iff hB.nhds_has_basis).2 _,
    rintro V ⟨hVB, hxV⟩,
    rcases hB.exists_closure_subset (hB.mem_nhds hVB hxV) with ⟨U, hUB, hxU, hUV⟩,
    set UV : ↥s := ⟨(U, V), ⟨hUB, hVB⟩, hUV⟩,
    refine ⟨ε UV, (ε01 UV).1, λ y (hy : dist (F y) (F x) < ε UV), _⟩,
    replace hy : dist (F y UV) (F x UV) < ε UV,
      from (bounded_continuous_function.dist_coe_le_dist _).trans_lt hy,
    contrapose! hy,
    rw [hF, hF, hfε UV hy, hf0 UV hxU, pi.zero_apply, dist_zero_right],
    exact le_abs_self _ },
  { /- Finally, we prove that `F` is continuous. Given `δ > 0`, consider the set `T` of `(U, V) ∈ s`
    such that `ε (U, V) ≥ δ`. Since `ε` tends to zero, `T` is finite. Since each `f` is continuous,
    we can choose a neighborhood such that `dist (F y (U, V)) (F x (U, V)) ≤ δ` for any
    `(U, V) ∈ T`. For `(U, V) ∉ T`, the same inequality is true because both `F y (U, V)` and
    `F x (U, V)` belong to the interval `[0, ε (U, V)]`. -/
    refine (nhds_basis_closed_ball.comap _).ge_iff.2 (λ δ δ0, _),
    have h_fin : {UV : s | δ ≤ ε UV}.finite, by simpa only [← not_lt] using hε (gt_mem_nhds δ0),
    have : ∀ᶠ y in 𝓝 x, ∀ UV, δ ≤ ε UV → dist (F y UV) (F x UV) ≤ δ,
    { refine (eventually_all_finite h_fin).2 (λ UV hUV, _),
      exact (f UV).continuous.tendsto x (closed_ball_mem_nhds _ δ0) },
    refine this.mono (λ y hy, (bounded_continuous_function.dist_le δ0.le).2 $ λ UV, _),
    cases le_total δ (ε UV) with hle hle,
    exacts [hy _ hle, (real.dist_le_of_mem_Icc (hf0ε _ _) (hf0ε _ _)).trans (by rwa sub_zero)] }
end

/-- *Urysohn's metrization theorem* (Tychonoff's version): a regular topological space with second
countable topology `X` is metrizable, i.e., there exists a metric space structure that generates the
same topology. -/
lemma metrizable_space_of_regular_second_countable : metrizable_space X :=
let ⟨f, hf⟩ := exists_embedding_l_infty X in hf.metrizable_space

instance : metrizable_space ennreal := metrizable_space_of_regular_second_countable ennreal

end topological_space


/-

A demonstration of the at-most-one encodings for Sudoku

-/

import cnf.literal
import cnf.assignment
import cnf.cnf
import cnf.encoding

import cardinality.direct_amo
import cardinality.sinz_amo
import cardinality.distinct
import cardinality.alk
import cardinality.amk

import data.nat.basic
import data.list.basic
import data.list.range

import system.io  -- Used to print the Sudoku formula to a file

open nat fin list function
open literal encoding constraint clause cnf assignment
open alk amk distinct
open direct_amo sinz_amo

variables {α V : Type*} [decidable_eq V] [inhabited V] {n : nat} (srow scol : fin n) (row col num : fin (n^2))

def grid_coords : list (fin (n^2) × fin (n^2)) :=
  join ((fin.range n).map (λ ro, (fin.range n).map (λ co,
    (fin.square_add srow ro, fin.square_add scol co))))

def cell_idx : nat := (row.val * (n^4)) + (col.val * (n^2)) + num.val

def is_cell_lit := λ idx, idx ∈ (fin.range (n^2)).map (λ num, cell_idx row col num)
def is_row_lit := λ idx, idx ∈ (fin.range (n^2)).map (λ col, cell_idx row col num)
def is_col_lit := λ idx, idx ∈ (fin.range (n^2)).map (λ row, cell_idx row col num)
def is_square_lit := λ idx, idx ∈ (grid_coords srow scol).map (λ ⟨row, col⟩, cell_idx row col num)

instance is_cell_lit_is_decidable : decidable_pred (is_cell_lit row col) :=
begin
  unfold is_cell_lit, intro idx, simp only,
  exact list.decidable_mem idx (map (cell_idx row col) (range (n^2)))
end

instance is_row_lit_is_decidable : decidable_pred (is_row_lit col num) :=
begin
  unfold is_row_lit, intro idx, simp only,
  exact list.decidable_mem idx (map (λ (col_1 : fin (n^2)), cell_idx col col_1 num) (range (n ^ 2)))
end

instance is_col_lit_is_decidable : decidable_pred (is_col_lit row num) :=
begin
  unfold is_col_lit, intro idx, simp only,
  exact list.decidable_mem idx (map (λ (row_1 : fin (n^2)), cell_idx row_1 row num) (range (n ^ 2)))
end

instance is_square_lit_is_decidable (srow scol : fin n) : decidable_pred (is_square_lit srow scol num) :=
begin
  unfold is_square_lit, intro idx, simp only,
  exact list.decidable_mem idx (map (is_square_lit._match_1 num) (grid_coords srow scol))
end

@[inline, reducible] def validity_base (p : nat → Prop) [decidable_pred p] : constraint :=
  (constraint.append (amk 1) (alk 1)) ∘ (filter_by_idx p)

@[inline, reducible] def weak_validity_base (p : nat → Prop) [decidable_pred p] := (amk 1) ∘ (filter_by_idx p)

def is_cell_valid := validity_base (is_cell_lit row col)
def is_row_valid' := validity_base (is_row_lit col num)
def is_col_valid' := validity_base (is_col_lit row num)
def is_square_valid' := validity_base (is_square_lit srow scol num)

def is_row_valid := weak_validity_base (is_row_lit col num)
def is_col_valid := weak_validity_base (is_col_lit row num)
def is_square_valid := weak_validity_base (is_square_lit srow scol num)

def is_valid_sudoku (n : nat) : constraint :=
let L := cp (n^2) (n^2) in
constraint.len_check (
  (fold (L.map (λ ⟨row, col⟩, is_cell_valid row col))) ++
  (fold (L.map (λ ⟨col, num⟩, is_row_valid col num))) ++
  (fold (L.map (λ ⟨row, num⟩, is_col_valid row num))) ++
  (fold ((list.zip (cp n n) (fin.range (n^2))).map (λ
    ⟨⟨srow, scol⟩, num⟩, is_square_valid srow scol num))))
(λ len, len = n^6)

def is_valid_sudoku' (n : nat) : constraint :=
let L := cp (n^2) (n^2) in
constraint.len_check (
  (fold (L.map (λ ⟨row, col⟩, is_cell_valid row col))) ++
  (fold (L.map (λ ⟨col, num⟩, is_row_valid' col num))) ++
  (fold (L.map (λ ⟨row, num⟩, is_col_valid' row num))) ++
  (fold ((list.zip (cp n n) (fin.range (n^2))).map (λ
    ⟨⟨srow, scol⟩, num⟩, is_square_valid' srow scol num))))
(λ len, len = n^6)

def alo_enc : enc_fn V := direct_alo
def amo_enc : enc_fn V := direct_amo

theorem amo_enc_is_correct : encodes (amk 1) (amo_enc : enc_fn V) :=
direct_amo_encodes_amo

theorem alo_enc_is_correct : encodes (alk 1) (alo_enc : enc_fn V) :=
direct_alo_encodes_alo

def sudoku_encoding (n : nat) : enc_fn V :=
let L : list (fin (n^2) × fin (n^2)) := cp (n^2) (n^2) in
encoding.len_check (
  (fold (L.map (λ ⟨row, col⟩,
    (append amo_enc alo_enc) ∘ (filter_by_idx (is_cell_lit row col))))) ++
  (fold (L.map (λ ⟨col, num⟩,
    amo_enc ∘ (filter_by_idx (is_row_lit col num))))) ++
  (fold (L.map (λ ⟨row, num⟩,
    amo_enc ∘ (filter_by_idx (is_col_lit row num))))) ++
  (fold ((list.zip (cp n n) (fin.range (n^2))).map (λ ⟨⟨srow, scol⟩, num⟩,
    amo_enc ∘ (filter_by_idx (is_square_lit srow scol num))))))
(λ len, len = n^6)

theorem encodes_sudoku (n : nat) : encodes (is_valid_sudoku n) (sudoku_encoding n : enc_fn V) :=
begin
  apply check_encodes_of_encodes,
  repeat { apply encodes_append },
  { apply encodes_fold_fold,
    rintros ⟨fin₁, fin₂⟩ hfin,
    apply filter_by_idx_encodes_of_encodes,
    exact encodes_append amo_enc_is_correct alo_enc_is_correct },
  repeat { apply encodes_fold_fold,
           rintros ⟨fin₁, fin₂⟩ hfin,
           exact filter_by_idx_encodes_of_encodes _ amo_enc_is_correct },
  apply encodes_fold_fold,
  rintros ⟨⟨fin₁, fin₂⟩, fin₃⟩ hfins,
  exact filter_by_idx_encodes_of_encodes _ amo_enc_is_correct
end

/-! # Printing out the CNF file -/

def L₀ : list (literal nat) := (list.range (3^6)).map (λ n, Pos (n + 1))
def g₀ : gensym nat := ⟨3^6 + 1, id, injective_id⟩
def F₀ : cnf nat := (sudoku_encoding 3 L₀ g₀).1

-- #eval F₀.toCNF id -- uncomment to see the formula in the Lean output window

-- This function prints a formula string to a file
-- Warning: Be very careful with this. Lean can overwrite files easily.
def strToFile (filename formula : string) : io unit := do
  h ← io.mk_file_handle filename io.mode.write,
  io.fs.put_str_ln h formula,
  io.fs.close h

-- #eval strToFile "./sudoku.cnf" (F₀.toCNF id) -- uncomment this to trigger the write


/-
Copyright (c) 2021 OpenAI. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kunhao Zheng, Stanislas Polu, David Renshaw, OpenAI GPT-f
-/
import mathzoo.imports.miniF2F

open_locale nat rat real big_operators topological_space

theorem imo_1961_p1
  (x y z a b : ℝ)
  (h₀ : 0 < x ∧ 0 < y ∧ 0 < z)
  (h₁ : x ≠ y)
  (h₂ : y ≠ z)
  (h₃ : z ≠ x)
  (h₄ : x + y + z = a)
  (h₅ : x^2 + y^2 + z^2 = b^2)
  (h₆ : x * y = z^2) :
  0 < a ∧ b^2 < a^2 ∧ a^2 < 3 * b^2 :=
begin
  simp [*, sq] at *,
  split,
  nlinarith,
  split,
  apply lt_of_not_ge,
  cases a,
  rw add_comm at *,
  nlinarith,
  apply lt_of_not_ge,
  contrapose! h₂,
  apply le_antisymm,
  contrapose! h₃,
  apply eq_of_sub_eq_zero,
  symmetry,
  nlinarith,
  apply le_of_not_gt,
  intros h1,
  apply_assumption,
  nlinarith [h1],
end


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

import field_theory.galois
import topology.algebra.filter_basis
import algebra.algebra.subalgebra

/-!
# Krull topology

We define the Krull topology on `L ≃ₐ[K] L` for an arbitrary field extension `L/K`. In order to do
this, we first define a `group_filter_basis` on `L ≃ₐ[K] L`, whose sets are `E.fixing_subgroup` for
all intermediate fields `E` with `E/K` finite dimensional.

## Main Definitions

- `finite_exts K L`. Given a field extension `L/K`, this is the set of intermediate fields that are
  finite-dimensional over `K`.

- `fixed_by_finite K L`. Given a field extension `L/K`, `fixed_by_finite K L` is the set of
  subsets `Gal(L/E)` of `Gal(L/K)`, where `E/K` is finite

- `gal_basis K L`. Given a field extension `L/K`, this is the filter basis on `L ≃ₐ[K] L` whose
  sets are `Gal(L/E)` for intermediate fields `E` with `E/K` finite.

- `gal_group_basis K L`. This is the same as `gal_basis K L`, but with the added structure
  that it is a group filter basis on `L ≃ₐ[K] L`, rather than just a filter basis.

- `krull_topology K L`. Given a field extension `L/K`, this is the topology on `L ≃ₐ[K] L`, induced
  by the group filter basis `gal_group_basis K L`.

## Notations

- In docstrings, we will write `Gal(L/E)` to denote the fixing subgroup of an intermediate field
  `E`. That is, `Gal(L/E)` is the subgroup of `L ≃ₐ[K] L` consisting of automorphisms that fix
  every element of `E`. In particular, we distinguish between `L ≃ₐ[E] L` and `Gal(L/E)`, since the
  former is defined to be a subgroup of `L ≃ₐ[K] L`, while the latter is a group in its own right.

## Implementation Notes

- `krull_topology K L` is defined as an instance for type class inference.
-/

open_locale classical

/-- Mapping intermediate fields along algebra equivalences preserves the partial order -/
lemma intermediate_field.map_mono {K L M : Type*} [field K] [field L] [field M]
  [algebra K L] [algebra K M] {E1 E2 : intermediate_field K L}
  (e : L ≃ₐ[K] M) (h12 : E1 ≤ E2) : E1.map e.to_alg_hom ≤ E2.map e.to_alg_hom :=
set.image_subset e h12

/-- Mapping intermediate fields along the identity does not change them -/
lemma intermediate_field.map_id {K L : Type*} [field K] [field L] [algebra K L]
  (E : intermediate_field K L) :
  E.map (alg_hom.id K L) = E :=
set_like.coe_injective $ set.image_id _

/-- Mapping a finite dimensional intermediate field along an algebra equivalence gives
a finite-dimensional intermediate field. -/
instance im_finite_dimensional {K L : Type*} [field K] [field L] [algebra K L]
  {E : intermediate_field K L} (σ : L ≃ₐ[K] L) [finite_dimensional K E]:
  finite_dimensional K (E.map σ.to_alg_hom) :=
linear_equiv.finite_dimensional (intermediate_field.intermediate_field_map σ E).to_linear_equiv

/-- Given a field extension `L/K`, `finite_exts K L` is the set of
intermediate field extensions `L/E/K` such that `E/K` is finite -/
def finite_exts (K : Type*) [field K] (L : Type*) [field L] [algebra K L] :
  set (intermediate_field K L) :=
{E | finite_dimensional K E}

/-- Given a field extension `L/K`, `fixed_by_finite K L` is the set of
subsets `Gal(L/E)` of `L ≃ₐ[K] L`, where `E/K` is finite -/
def fixed_by_finite (K L : Type*) [field K] [field L] [algebra K L]: set (subgroup (L ≃ₐ[K] L)) :=
intermediate_field.fixing_subgroup '' (finite_exts K L)

/-- For an field extension `L/K`, the intermediate field `K` is finite-dimensional over `K` -/
lemma intermediate_field.finite_dimensional_bot (K L : Type*) [field K]
  [field L] [algebra K L] : finite_dimensional K (⊥ : intermediate_field K L) :=
finite_dimensional_of_dim_eq_one intermediate_field.dim_bot

/-- This lemma says that `Gal(L/K) = L ≃ₐ[K] L` -/
lemma intermediate_field.fixing_subgroup.bot {K L : Type*} [field K]
  [field L] [algebra K L] :
  intermediate_field.fixing_subgroup (⊥ : intermediate_field K L) = ⊤ :=
begin
  ext f,
  refine ⟨λ _, subgroup.mem_top _, λ _, _⟩,
  rintro ⟨x, hx⟩,
  rw intermediate_field.mem_bot at hx,
  rcases hx with ⟨y, rfl⟩,
  exact f.commutes y,
end

/-- If `L/K` is a field extension, then we have `Gal(L/K) ∈ fixed_by_finite K L` -/
lemma top_fixed_by_finite {K L : Type*} [field K] [field L] [algebra K L] :
  ⊤ ∈ fixed_by_finite K L :=
⟨⊥, intermediate_field.finite_dimensional_bot K L, intermediate_field.fixing_subgroup.bot⟩

/-- If `E1` and `E2` are finite-dimensional intermediate fields, then so is their compositum.
This rephrases a result already in mathlib so that it is compatible with our type classes -/
lemma finite_dimensional_sup {K L: Type*} [field K] [field L] [algebra K L]
  (E1 E2 : intermediate_field K L) (h1 : finite_dimensional K E1)
  (h2 : finite_dimensional K E2) : finite_dimensional K ↥(E1 ⊔ E2) :=
by exactI intermediate_field.finite_dimensional_sup E1 E2

/-- An element of `L ≃ₐ[K] L` is in `Gal(L/E)` if and only if it fixes every element of `E`-/
lemma mem_fixing_subgroup_iff {K L : Type*} [field K] [field L] [algebra K L]
  (E : intermediate_field K L) (σ : (L ≃ₐ[K] L)) :
  σ ∈ E.fixing_subgroup ↔∀ (x : L), x ∈ E → σ x = x :=
⟨λ hσ x hx, hσ ⟨x, hx⟩, λ h ⟨x, hx⟩, h x hx⟩

/-- The map `E ↦ Gal(L/E)` is inclusion-reversing -/
lemma intermediate_field.fixing_subgroup.antimono {K L : Type*} [field K] [field L] [algebra K L]
  {E1 E2 : intermediate_field K L} (h12 : E1 ≤ E2) : E2.fixing_subgroup ≤ E1.fixing_subgroup :=
begin
  rintro σ hσ ⟨x, hx⟩,
  exact hσ ⟨x, h12 hx⟩,
end

/-- Given a field extension `L/K`, `gal_basis K L` is the filter basis on `L ≃ₐ[K] L` whose sets
are `Gal(L/E)` for intermediate fields `E` with `E/K` finite dimensional -/
def gal_basis (K L : Type*) [field K] [field L] [algebra K L] : filter_basis (L ≃ₐ[K] L) :=
{ sets := subgroup.carrier '' (fixed_by_finite K L),
  nonempty := ⟨⊤, ⊤, top_fixed_by_finite, rfl⟩,
  inter_sets :=
  begin
    rintros X Y ⟨H1, ⟨E1, h_E1, rfl⟩, rfl⟩ ⟨H2, ⟨E2, h_E2, rfl⟩, rfl⟩,
    use (intermediate_field.fixing_subgroup (E1 ⊔ E2)).carrier,
    refine ⟨⟨_, ⟨_, finite_dimensional_sup E1 E2 h_E1 h_E2, rfl⟩, rfl⟩, _⟩,
    rw set.subset_inter_iff,
    exact ⟨intermediate_field.fixing_subgroup.antimono le_sup_left,
      intermediate_field.fixing_subgroup.antimono le_sup_right⟩,
  end }

/-- A subset of `L ≃ₐ[K] L` is a member of `gal_basis K L` if and only if it is the underlying set
of `Gal(L/E)` for some finite subextension `E/K`-/
lemma mem_gal_basis_iff (K L : Type*) [field K] [field L] [algebra K L]
  (U : set (L ≃ₐ[K] L)) : U ∈ gal_basis K L ↔ U ∈ subgroup.carrier '' (fixed_by_finite K L) :=
iff.rfl

/-- For a field extension `L/K`, `gal_group_basis K L` is the group filter basis on `L ≃ₐ[K] L`
whose sets are `Gal(L/E)` for finite subextensions `E/K` -/
def gal_group_basis (K L : Type*) [field K] [field L] [algebra K L] :
  group_filter_basis (L ≃ₐ[K] L) :=
{ to_filter_basis := gal_basis K L,
  one' := λ U ⟨H, hH, h2⟩, h2 ▸ H.one_mem,
  mul' := λ U hU, ⟨U, hU, begin
    rcases hU with ⟨H, hH, rfl⟩,
    rintros x ⟨a, b, haH, hbH, rfl⟩,
    exact H.mul_mem haH hbH,
  end⟩,
  inv' := λ U hU, ⟨U, hU, begin
    rcases hU with ⟨H, hH, rfl⟩,
    exact H.inv_mem',
  end⟩,
  conj' :=
  begin
    rintros σ U ⟨H, ⟨E, hE, rfl⟩, rfl⟩,
    let F : intermediate_field K L := E.map (σ.symm.to_alg_hom),
    refine ⟨F.fixing_subgroup.carrier, ⟨⟨F.fixing_subgroup, ⟨F,
      _, rfl⟩, rfl⟩, λ g hg, _⟩⟩,
    { apply im_finite_dimensional σ.symm,
      exact hE },
    change σ * g * σ⁻¹ ∈ E.fixing_subgroup,
    rw mem_fixing_subgroup_iff,
    intros x hx,
    change σ(g(σ⁻¹ x)) = x,
    have h_in_F : σ⁻¹ x ∈ F := ⟨x, hx, by {dsimp, rw ← alg_equiv.inv_fun_eq_symm, refl }⟩,
    have h_g_fix : g (σ⁻¹ x) = (σ⁻¹ x),
    { rw [subgroup.mem_carrier, mem_fixing_subgroup_iff F g] at hg,
      exact hg (σ⁻¹ x) h_in_F },
    rw h_g_fix,
    change σ(σ⁻¹ x) = x,
    exact alg_equiv.apply_symm_apply σ x,
  end }

/-- For a field extension `L/K`, `krull_topology K L` is the topological space structure on
`L ≃ₐ[K] L` induced by the group filter basis `gal_group_basis K L` -/
instance krull_topology (K L : Type*) [field K] [field L] [algebra K L] :
  topological_space (L ≃ₐ[K] L) :=
group_filter_basis.topology (gal_group_basis K L)

/-- For a field extension `L/K`, the Krull topology on `L ≃ₐ[K] L` makes it a topological group. -/
instance (K L : Type*) [field K] [field L] [algebra K L] :
  topological_group (L ≃ₐ[K] L) :=
group_filter_basis.is_topological_group (gal_group_basis K L)