/-
Copyright (c) 2019 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import analysis.calculus.times_cont_diff
import geometry.manifold.charted_space

/-!
# Smooth manifolds (possibly with boundary or corners)

A smooth manifold is a manifold modelled on a normed vector space, or a subset like a
half-space (to get manifolds with boundaries) for which the changes of coordinates are smooth maps.
We define a model with corners as a map `I : H → E` embedding nicely the topological space `H` in
the vector space `E` (or more precisely as a structure containing all the relevant properties).
Given such a model with corners `I` on `(E, H)`, we define the groupoid of local
homeomorphisms of `H` which are smooth when read in `E` (for any regularity `n : with_top ℕ`).
With this groupoid at hand and the general machinery of charted spaces, we thus get the notion
of `C^n` manifold with respect to any model with corners `I` on `(E, H)`. We also introduce a
specific type class for `C^∞` manifolds as these are the most commonly used.

## Main definitions

* `model_with_corners 𝕜 E H` :
  a structure containing informations on the way a space `H` embeds in a
  model vector space E over the field `𝕜`. This is all that is needed to
  define a smooth manifold with model space `H`, and model vector space `E`.
* `model_with_corners_self 𝕜 E` :
  trivial model with corners structure on the space `E` embedded in itself by the identity.
* `times_cont_diff_groupoid n I` :
  when `I` is a model with corners on `(𝕜, E, H)`, this is the groupoid of local homeos of `H`
  which are of class `C^n` over the normed field `𝕜`, when read in `E`.
* `smooth_manifold_with_corners I M` :
  a type class saying that the charted space `M`, modelled on the space `H`, has `C^∞` changes of
  coordinates with respect to the model with corners `I` on `(𝕜, E, H)`. This type class is just
  a shortcut for `has_groupoid M (times_cont_diff_groupoid ∞ I)`.
* `ext_chart_at I x`:
  in a smooth manifold with corners with the model `I` on `(E, H)`, the charts take values in `H`,
  but often we may want to use their `E`-valued version, obtained by composing the charts with `I`.
  Since the target is in general not open, we can not register them as local homeomorphisms, but
  we register them as local equivs. `ext_chart_at I x` is the canonical such local equiv around `x`.

As specific examples of models with corners, we define (in the file `real_instances.lean`)
* `model_with_corners_self ℝ (euclidean_space (fin n))` for the model space used to define
  `n`-dimensional real manifolds without boundary (with notation `𝓡 n` in the locale `manifold`)
* `model_with_corners ℝ (euclidean_space (fin n)) (euclidean_half_space n)` for the model space
  used to define `n`-dimensional real manifolds with boundary (with notation `𝓡∂ n` in the locale
  `manifold`)
* `model_with_corners ℝ (euclidean_space (fin n)) (euclidean_quadrant n)` for the model space used
  to define `n`-dimensional real manifolds with corners

With these definitions at hand, to invoke an `n`-dimensional real manifold without boundary,
one could use

  `variables {n : ℕ} {M : Type*} [topological_space M] [charted_space (euclidean_space (fin n)) M]
   [smooth_manifold_with_corners (𝓡 n) M]`.

However, this is not the recommended way: a theorem proved using this assumption would not apply
for instance to the tangent space of such a manifold, which is modelled on
`(euclidean_space (fin n)) × (euclidean_space (fin n))` and not on `euclidean_space (fin (2 * n))`!
In the same way, it would not apply to product manifolds, modelled on
`(euclidean_space (fin n)) × (euclidean_space (fin m))`.
The right invocation does not focus on one specific construction, but on all constructions sharing
the right properties, like

  `variables {E : Type*} [normed_group E] [normed_space ℝ E] [finite_dimensional ℝ E]
  {I : model_with_corners ℝ E E} [I.boundaryless]
  {M : Type*} [topological_space M] [charted_space E M] [smooth_manifold_with_corners I M]`

Here, `I.boundaryless` is a typeclass property ensuring that there is no boundary (this is for
instance the case for `model_with_corners_self`, or products of these). Note that one could consider
as a natural assumption to only use the trivial model with corners `model_with_corners_self ℝ E`,
but again in product manifolds the natural model with corners will not be this one but the product
one (and they are not defeq as `(λp : E × F, (p.1, p.2))` is not defeq to the identity). So, it is
important to use the above incantation to maximize the applicability of theorems.

## Implementation notes

We want to talk about manifolds modelled on a vector space, but also on manifolds with
boundary, modelled on a half space (or even manifolds with corners). For the latter examples,
we still want to define smooth functions, tangent bundles, and so on. As smooth functions are
well defined on vector spaces or subsets of these, one could take for model space a subtype of a
vector space. With the drawback that the whole vector space itself (which is the most basic
example) is not directly a subtype of itself: the inclusion of `univ : set E` in `set E` would
show up in the definition, instead of `id`.

A good abstraction covering both cases it to have a vector
space `E` (with basic example the Euclidean space), a model space `H` (with basic example the upper
half space), and an embedding of `H` into `E` (which can be the identity for `H = E`, or
`subtype.val` for manifolds with corners). We say that the pair `(E, H)` with their embedding is a
model with corners, and we encompass all the relevant properties (in particular the fact that the
image of `H` in `E` should have unique differentials) in the definition of `model_with_corners`.

We concentrate on `C^∞` manifolds: all the definitions work equally well for `C^n` manifolds, but
later on it is a pain to carry all over the smoothness parameter, especially when one wants to deal
with `C^k` functions as there would be additional conditions `k ≤ n` everywhere. Since one deals
almost all the time with `C^∞` (or analytic) manifolds, this seems to be a reasonable choice that
one could revisit later if needed. `C^k` manifolds are still available, but they should be called
using `has_groupoid M (times_cont_diff_groupoid k I)` where `I` is the model with corners.

I have considered using the model with corners `I` as a typeclass argument, possibly `out_param`, to
get lighter notations later on, but it did not turn out right, as on `E × F` there are two natural
model with corners, the trivial (identity) one, and the product one, and they are not defeq and one
needs to indicate to Lean which one we want to use.
This means that when talking on objects on manifolds one will most often need to specify the model
with corners one is using. For instance, the tangent bundle will be `tangent_bundle I M` and the
derivative will be `mfderiv I I' f`, instead of the more natural notations `tangent_bundle 𝕜 M` and
`mfderiv 𝕜 f` (the field has to be explicit anyway, as some manifolds could be considered both as
real and complex manifolds).
-/

noncomputable theory

universes u v w u' v' w'

open set filter
open_locale manifold filter topological_space

localized "notation `∞` := (⊤ : with_top ℕ)" in manifold

section model_with_corners
/-! ### Models with corners. -/

/-- A structure containing informations on the way a space `H` embeds in a
model vector space `E` over the field `𝕜`. This is all what is needed to
define a smooth manifold with model space `H`, and model vector space `E`.
-/
@[nolint has_inhabited_instance]
structure model_with_corners (𝕜 : Type*) [nondiscrete_normed_field 𝕜]
  (E : Type*) [normed_group E] [normed_space 𝕜 E] (H : Type*) [topological_space H]
  extends local_equiv H E :=
(source_eq          : source = univ)
(unique_diff'       : unique_diff_on 𝕜 to_local_equiv.target)
(continuous_to_fun  : continuous to_fun . tactic.interactive.continuity')
(continuous_inv_fun : continuous inv_fun . tactic.interactive.continuity')

attribute [simp, mfld_simps] model_with_corners.source_eq

/-- A vector space is a model with corners. -/
def model_with_corners_self (𝕜 : Type*) [nondiscrete_normed_field 𝕜]
  (E : Type*) [normed_group E] [normed_space 𝕜 E] : model_with_corners 𝕜 E E :=
{ to_local_equiv := local_equiv.refl E,
  source_eq    := rfl,
  unique_diff' := unique_diff_on_univ,
  continuous_to_fun  := continuous_id,
  continuous_inv_fun := continuous_id }

localized "notation `𝓘(` 𝕜 `, ` E `)` := model_with_corners_self 𝕜 E" in manifold

localized "notation `𝓘(` 𝕜 `)` := model_with_corners_self 𝕜 𝕜" in manifold

section
variables {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
  {E : Type*} [normed_group E] [normed_space 𝕜 E] {H : Type*} [topological_space H]
  (I : model_with_corners 𝕜 E H)

namespace model_with_corners

instance : has_coe_to_fun (model_with_corners 𝕜 E H) := ⟨_, λ e, e.to_fun⟩

/-- The inverse to a model with corners, only registered as a local equiv. -/
protected def symm : local_equiv E H := I.to_local_equiv.symm

/- Register a few lemmas to make sure that `simp` puts expressions in normal form -/
@[simp, mfld_simps] lemma to_local_equiv_coe : (I.to_local_equiv : H → E) = I :=
rfl

@[simp, mfld_simps] lemma mk_coe (e : local_equiv H E) (a b c d) :
  ((model_with_corners.mk e a b c d : model_with_corners 𝕜 E H) : H → E) = (e : H → E) := rfl

@[simp, mfld_simps] lemma to_local_equiv_coe_symm : (I.to_local_equiv.symm : E → H) = I.symm := rfl

@[simp, mfld_simps] lemma mk_symm (e : local_equiv H E) (a b c d) :
  (model_with_corners.mk e a b c d : model_with_corners 𝕜 E H).symm = e.symm :=
rfl

@[continuity] protected lemma continuous : continuous I := I.continuous_to_fun

protected lemma continuous_at {x} : continuous_at I x := I.continuous.continuous_at

protected lemma continuous_within_at {s x} : continuous_within_at I s x :=
I.continuous_at.continuous_within_at

@[continuity] lemma continuous_symm : continuous I.symm := I.continuous_inv_fun

lemma continuous_at_symm {x} : continuous_at I.symm x := I.continuous_symm.continuous_at

lemma continuous_within_at_symm {s x} : continuous_within_at I.symm s x :=
I.continuous_symm.continuous_within_at

@[simp, mfld_simps] lemma target_eq : I.target = range (I : H → E) :=
by { rw [← image_univ, ← I.source_eq], exact (I.to_local_equiv.image_source_eq_target).symm }

protected lemma unique_diff : unique_diff_on 𝕜 (range I) := I.target_eq ▸ I.unique_diff'

@[simp, mfld_simps] protected lemma left_inv (x : H) : I.symm (I x) = x :=
by { refine I.left_inv' _, simp }

protected lemma left_inverse : function.left_inverse I.symm I := I.left_inv

@[simp, mfld_simps] lemma symm_comp_self : I.symm ∘ I = id :=
I.left_inverse.comp_eq_id

protected lemma right_inv_on : right_inv_on I.symm I (range I) :=
I.left_inverse.right_inv_on_range

@[simp, mfld_simps] protected lemma right_inv {x : E} (hx : x ∈ range I) : I (I.symm x) = x :=
I.right_inv_on hx

protected lemma image_eq (s : set H) : I '' s = I.symm ⁻¹' s ∩ range I :=
begin
  refine (I.to_local_equiv.image_eq_target_inter_inv_preimage _).trans _,
  { rw I.source_eq, exact subset_univ _ },
  { rw [inter_comm, I.target_eq, I.to_local_equiv_coe_symm] }
end

protected lemma closed_embedding : closed_embedding I :=
I.left_inverse.closed_embedding I.continuous_symm I.continuous

lemma closed_range : is_closed (range I) :=
I.closed_embedding.closed_range

lemma map_nhds_eq (x : H) : map I (𝓝 x) = 𝓝[range I] (I x) :=
I.closed_embedding.to_embedding.map_nhds_eq x

lemma image_mem_nhds_within {x : H} {s : set H} (hs : s ∈ 𝓝 x) :
  I '' s ∈ 𝓝[range I] (I x) :=
I.map_nhds_eq x ▸ image_mem_map hs

lemma symm_map_nhds_within_range (x : H) :
  map I.symm (𝓝[range I] (I x)) = 𝓝 x :=
by rw [← I.map_nhds_eq, map_map, I.symm_comp_self, map_id]

lemma unique_diff_preimage {s : set H} (hs : is_open s) :
  unique_diff_on 𝕜 (I.symm ⁻¹' s ∩ range I) :=
by { rw inter_comm, exact I.unique_diff.inter (hs.preimage I.continuous_inv_fun) }

lemma unique_diff_preimage_source {β : Type*} [topological_space β]
  {e : local_homeomorph H β} : unique_diff_on 𝕜 (I.symm ⁻¹' (e.source) ∩ range I) :=
I.unique_diff_preimage e.open_source

lemma unique_diff_at_image {x : H} : unique_diff_within_at 𝕜 (range I) (I x) :=
I.unique_diff _ (mem_range_self _)

protected lemma locally_compact [locally_compact_space E] (I : model_with_corners 𝕜 E H) :
  locally_compact_space H :=
begin
  have : ∀ (x : H), (𝓝 x).has_basis (λ s, s ∈ 𝓝 (I x) ∧ is_compact s)
    (λ s, I.symm '' (s ∩ range ⇑I)),
  { intro x,
    rw ← I.symm_map_nhds_within_range,
    exact ((compact_basis_nhds (I x)).inf_principal _).map _ },
  refine locally_compact_space_of_has_basis this _,
  rintro x s ⟨-, hsc⟩,
  exact (hsc.inter_right I.closed_range).image I.continuous_symm
end

open topological_space

protected lemma second_countable_topology [second_countable_topology E]
  (I : model_with_corners 𝕜 E H) : second_countable_topology H :=
I.closed_embedding.to_embedding.second_countable_topology

end model_with_corners

section
variables (𝕜 E)

/-- In the trivial model with corners, the associated local equiv is the identity. -/
@[simp, mfld_simps] lemma model_with_corners_self_local_equiv :
  (𝓘(𝕜, E)).to_local_equiv = local_equiv.refl E := rfl

@[simp, mfld_simps] lemma model_with_corners_self_coe :
  (𝓘(𝕜, E) : E → E) = id := rfl

@[simp, mfld_simps] lemma model_with_corners_self_coe_symm :
  (𝓘(𝕜, E).symm : E → E) = id := rfl

end

end

section model_with_corners_prod

/-- Given two model_with_corners `I` on `(E, H)` and `I'` on `(E', H')`, we define the model with
corners `I.prod I'` on `(E × E', model_prod H H')`. This appears in particular for the manifold
structure on the tangent bundle to a manifold modelled on `(E, H)`: it will be modelled on
`(E × E, H × E)`. See note [Manifold type tags] for explanation about `model_prod H H'`
vs `H × H'`. -/
def model_with_corners.prod
  {𝕜 : Type u} [nondiscrete_normed_field 𝕜]
  {E : Type v} [normed_group E] [normed_space 𝕜 E] {H : Type w} [topological_space H]
  (I : model_with_corners 𝕜 E H)
  {E' : Type v'} [normed_group E'] [normed_space 𝕜 E'] {H' : Type w'} [topological_space H']
  (I' : model_with_corners 𝕜 E' H') : model_with_corners 𝕜 (E × E') (model_prod H H') :=
{ to_fun := λ x, (I x.1, I' x.2),
  inv_fun := λ x, (I.symm x.1, I'.symm x.2),
  source := {x | x.1 ∈ I.source ∧ x.2 ∈ I'.source},
  source_eq    := by simp only [set_of_true] with mfld_simps,
  unique_diff' := I.unique_diff'.prod I'.unique_diff',
  continuous_to_fun := I.continuous_to_fun.prod_map I'.continuous_to_fun,
  continuous_inv_fun := I.continuous_inv_fun.prod_map I'.continuous_inv_fun,
  .. I.to_local_equiv.prod I'.to_local_equiv }

/-- Special case of product model with corners, which is trivial on the second factor. This shows up
as the model to tangent bundles. -/
@[reducible] def model_with_corners.tangent
  {𝕜 : Type u} [nondiscrete_normed_field 𝕜]
  {E : Type v} [normed_group E] [normed_space 𝕜 E] {H : Type w} [topological_space H]
  (I : model_with_corners 𝕜 E H) : model_with_corners 𝕜 (E × E) (model_prod H E) :=
I.prod (𝓘(𝕜, E))

variables {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
{E : Type*} [normed_group E] [normed_space 𝕜 E] {E' : Type*} [normed_group E'] [normed_space 𝕜 E']
{F : Type*} [normed_group F] [normed_space 𝕜 F] {F' : Type*} [normed_group F'] [normed_space 𝕜 F']
{H : Type*} [topological_space H] {H' : Type*} [topological_space H']
{G : Type*} [topological_space G] {G' : Type*} [topological_space G']
{I : model_with_corners 𝕜 E H} {J : model_with_corners 𝕜 F G}

@[simp, mfld_simps] lemma model_with_corners_prod_to_local_equiv :
  (I.prod J).to_local_equiv = I.to_local_equiv.prod (J.to_local_equiv) :=
rfl

@[simp, mfld_simps] lemma model_with_corners_prod_coe
  (I : model_with_corners 𝕜 E H) (I' : model_with_corners 𝕜 E' H') :
  (I.prod I' : _ × _ → _ × _) = prod.map I I' := rfl

@[simp, mfld_simps] lemma model_with_corners_prod_coe_symm
  (I : model_with_corners 𝕜 E H) (I' : model_with_corners 𝕜 E' H') :
  ((I.prod I').symm : _ × _ → _ × _) = prod.map I.symm I'.symm := rfl

end model_with_corners_prod

section boundaryless

/-- Property ensuring that the model with corners `I` defines manifolds without boundary. -/
class model_with_corners.boundaryless {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
  {E : Type*} [normed_group E] [normed_space 𝕜 E] {H : Type*} [topological_space H]
  (I : model_with_corners 𝕜 E H) : Prop :=
(range_eq_univ : range I = univ)

/-- The trivial model with corners has no boundary -/
instance model_with_corners_self_boundaryless (𝕜 : Type*) [nondiscrete_normed_field 𝕜]
  (E : Type*) [normed_group E] [normed_space 𝕜 E] : (model_with_corners_self 𝕜 E).boundaryless :=
⟨by simp⟩

/-- If two model with corners are boundaryless, their product also is -/
instance model_with_corners.range_eq_univ_prod {𝕜 : Type u} [nondiscrete_normed_field 𝕜]
  {E : Type v} [normed_group E] [normed_space 𝕜 E] {H : Type w} [topological_space H]
  (I : model_with_corners 𝕜 E H) [I.boundaryless]
  {E' : Type v'} [normed_group E'] [normed_space 𝕜 E'] {H' : Type w'} [topological_space H']
  (I' : model_with_corners 𝕜 E' H') [I'.boundaryless] :
  (I.prod I').boundaryless :=
begin
  split,
  dsimp [model_with_corners.prod, model_prod],
  rw [← prod_range_range_eq, model_with_corners.boundaryless.range_eq_univ,
      model_with_corners.boundaryless.range_eq_univ, univ_prod_univ]
end

end boundaryless

section times_cont_diff_groupoid
/-! ### Smooth functions on models with corners -/

variables {m n : with_top ℕ} {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
{E : Type*} [normed_group E] [normed_space 𝕜 E]
{H : Type*} [topological_space H]
(I : model_with_corners 𝕜 E H)
{M : Type*} [topological_space M]

variable (n)
/-- Given a model with corners `(E, H)`, we define the groupoid of `C^n` transformations of `H` as
the maps that are `C^n` when read in `E` through `I`. -/
def times_cont_diff_groupoid : structure_groupoid H :=
pregroupoid.groupoid
{ property := λf s, times_cont_diff_on 𝕜 n (I ∘ f ∘ I.symm) (I.symm ⁻¹' s ∩ range I),
  comp     := λf g u v hf hg hu hv huv, begin
    have : I ∘ (g ∘ f) ∘ I.symm = (I ∘ g ∘ I.symm) ∘ (I ∘ f ∘ I.symm),
      by { ext x, simp },
    rw this,
    apply times_cont_diff_on.comp hg _,
    { rintros x ⟨hx1, hx2⟩,
      simp only with mfld_simps at ⊢ hx1,
      exact hx1.2 },
    { refine hf.mono _,
      rintros x ⟨hx1, hx2⟩,
      exact ⟨hx1.1, hx2⟩ }
  end,
  id_mem   := begin
    apply times_cont_diff_on.congr (times_cont_diff_id.times_cont_diff_on),
    rintros x ⟨hx1, hx2⟩,
    rcases mem_range.1 hx2 with ⟨y, hy⟩,
    rw ← hy,
    simp only with mfld_simps,
  end,
  locality := λf u hu H, begin
    apply times_cont_diff_on_of_locally_times_cont_diff_on,
    rintros y ⟨hy1, hy2⟩,
    rcases mem_range.1 hy2 with ⟨x, hx⟩,
    rw ← hx at ⊢ hy1,
    simp only with mfld_simps at ⊢ hy1,
    rcases H x hy1 with ⟨v, v_open, xv, hv⟩,
    have : ((I.symm ⁻¹' (u ∩ v)) ∩ (range I))
        = ((I.symm ⁻¹' u) ∩ (range I) ∩ I.symm ⁻¹' v),
    { rw [preimage_inter, inter_assoc, inter_assoc],
      congr' 1,
      rw inter_comm },
    rw this at hv,
    exact ⟨I.symm ⁻¹' v, v_open.preimage I.continuous_symm, by simpa, hv⟩
  end,
  congr    := λf g u hu fg hf, begin
    apply hf.congr,
    rintros y ⟨hy1, hy2⟩,
    rcases mem_range.1 hy2 with ⟨x, hx⟩,
    rw ← hx at ⊢ hy1,
    simp only with mfld_simps at ⊢ hy1,
    rw fg _ hy1
  end }

variable {n}
/-- Inclusion of the groupoid of `C^n` local diffeos in the groupoid of `C^m` local diffeos when
`m ≤ n` -/
lemma times_cont_diff_groupoid_le (h : m ≤ n) :
  times_cont_diff_groupoid n I ≤ times_cont_diff_groupoid m I :=
begin
  rw [times_cont_diff_groupoid, times_cont_diff_groupoid],
  apply groupoid_of_pregroupoid_le,
  assume f s hfs,
  exact times_cont_diff_on.of_le hfs h
end

/-- The groupoid of `0`-times continuously differentiable maps is just the groupoid of all
local homeomorphisms -/
lemma times_cont_diff_groupoid_zero_eq :
  times_cont_diff_groupoid 0 I = continuous_groupoid H :=
begin
  apply le_antisymm le_top,
  assume u hu,
  -- we have to check that every local homeomorphism belongs to `times_cont_diff_groupoid 0 I`,
  -- by unfolding its definition
  change u ∈ times_cont_diff_groupoid 0 I,
  rw [times_cont_diff_groupoid, mem_groupoid_of_pregroupoid],
  simp only [times_cont_diff_on_zero],
  split,
  { apply continuous_on.comp (@continuous.continuous_on _ _ _ _ _ univ I.continuous)
      _ (subset_univ _),
    apply continuous_on.comp u.continuous_to_fun I.continuous_symm.continuous_on
      (inter_subset_left _ _) },
  { apply continuous_on.comp (@continuous.continuous_on _ _ _ _ _ univ I.continuous)
      _ (subset_univ _),
    apply continuous_on.comp u.continuous_inv_fun I.continuous_inv_fun.continuous_on
      (inter_subset_left _ _) },
end

variable (n)
/-- An identity local homeomorphism belongs to the `C^n` groupoid. -/
lemma of_set_mem_times_cont_diff_groupoid {s : set H} (hs : is_open s) :
  local_homeomorph.of_set s hs ∈ times_cont_diff_groupoid n I :=
begin
  rw [times_cont_diff_groupoid, mem_groupoid_of_pregroupoid],
  suffices h : times_cont_diff_on 𝕜 n (I ∘ I.symm) (I.symm ⁻¹' s ∩ range I),
    by simp [h],
  have : times_cont_diff_on 𝕜 n id (univ : set E) :=
    times_cont_diff_id.times_cont_diff_on,
  exact this.congr_mono (λ x hx, by simp [hx.2]) (subset_univ _)
end

/-- The composition of a local homeomorphism from `H` to `M` and its inverse belongs to
the `C^n` groupoid. -/
lemma symm_trans_mem_times_cont_diff_groupoid (e : local_homeomorph M H) :
  e.symm.trans e ∈ times_cont_diff_groupoid n I :=
begin
  have : e.symm.trans e ≈ local_homeomorph.of_set e.target e.open_target :=
    local_homeomorph.trans_symm_self _,
  exact structure_groupoid.eq_on_source _
    (of_set_mem_times_cont_diff_groupoid n I e.open_target) this
end

variables {E' : Type*} [normed_group E'] [normed_space 𝕜 E'] {H' : Type*} [topological_space H']

/-- The product of two smooth local homeomorphisms is smooth. -/
lemma times_cont_diff_groupoid_prod
  {I : model_with_corners 𝕜 E H} {I' : model_with_corners 𝕜 E' H'}
  {e : local_homeomorph H H} {e' : local_homeomorph H' H'}
  (he : e ∈ times_cont_diff_groupoid ⊤ I) (he' : e' ∈ times_cont_diff_groupoid ⊤ I') :
  e.prod e' ∈ times_cont_diff_groupoid ⊤ (I.prod I') :=
begin
  cases he with he he_symm,
  cases he' with he' he'_symm,
  simp only at he he_symm he' he'_symm,
  split;
  simp only [local_equiv.prod_source, local_homeomorph.prod_to_local_equiv],
  { have h3 := times_cont_diff_on.prod_map he he',
    rw [← I.image_eq, ← I'.image_eq, set.prod_image_image_eq] at h3,
    rw ← (I.prod I').image_eq,
    exact h3, },
  { have h3 := times_cont_diff_on.prod_map he_symm he'_symm,
    rw [← I.image_eq, ← I'.image_eq, set.prod_image_image_eq] at h3,
    rw ← (I.prod I').image_eq,
    exact h3, }
end

/-- The `C^n` groupoid is closed under restriction. -/
instance : closed_under_restriction (times_cont_diff_groupoid n I) :=
(closed_under_restriction_iff_id_le _).mpr
begin
  apply structure_groupoid.le_iff.mpr,
  rintros e ⟨s, hs, hes⟩,
  apply (times_cont_diff_groupoid n I).eq_on_source' _ _ _ hes,
  exact of_set_mem_times_cont_diff_groupoid n I hs,
end

end times_cont_diff_groupoid

end model_with_corners

section smooth_manifold_with_corners

/-! ### Smooth manifolds with corners -/

set_option old_structure_cmd true

/-- Typeclass defining smooth manifolds with corners with respect to a model with corners, over a
field `𝕜` and with infinite smoothness to simplify typeclass search and statements later on. -/
@[ancestor has_groupoid]
class smooth_manifold_with_corners {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
  {E : Type*} [normed_group E] [normed_space 𝕜 E]
  {H : Type*} [topological_space H] (I : model_with_corners 𝕜 E H)
  (M : Type*) [topological_space M] [charted_space H M] extends
  has_groupoid M (times_cont_diff_groupoid ∞ I) : Prop

lemma smooth_manifold_with_corners.mk' {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
  {E : Type*} [normed_group E] [normed_space 𝕜 E]
  {H : Type*} [topological_space H] (I : model_with_corners 𝕜 E H)
  (M : Type*) [topological_space M] [charted_space H M]
  [gr : has_groupoid M (times_cont_diff_groupoid ∞ I)] :
  smooth_manifold_with_corners I M := { ..gr }

lemma smooth_manifold_with_corners_of_times_cont_diff_on
  {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
  {E : Type*} [normed_group E] [normed_space 𝕜 E]
  {H : Type*} [topological_space H] (I : model_with_corners 𝕜 E H)
  (M : Type*) [topological_space M] [charted_space H M]
  (h : ∀ (e e' : local_homeomorph M H), e ∈ atlas H M → e' ∈ atlas H M →
    times_cont_diff_on 𝕜 ⊤ (I ∘ (e.symm ≫ₕ e') ∘ I.symm)
      (I.symm ⁻¹' (e.symm ≫ₕ e').source ∩ range I)) :
  smooth_manifold_with_corners I M :=
{ compatible :=
  begin
    haveI : has_groupoid M (times_cont_diff_groupoid ∞ I) := has_groupoid_of_pregroupoid _ h,
    apply structure_groupoid.compatible,
  end }

/-- For any model with corners, the model space is a smooth manifold -/
instance model_space_smooth {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
  {E : Type*} [normed_group E] [normed_space 𝕜 E] {H : Type*} [topological_space H]
  {I : model_with_corners 𝕜 E H} :
  smooth_manifold_with_corners I H := { .. has_groupoid_model_space _ _ }

end smooth_manifold_with_corners

namespace smooth_manifold_with_corners
/- We restate in the namespace `smooth_manifolds_with_corners` some lemmas that hold for general
charted space with a structure groupoid, avoiding the need to specify the groupoid
`times_cont_diff_groupoid ∞ I` explicitly. -/

variables {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
  {E : Type*} [normed_group E] [normed_space 𝕜 E]
  {H : Type*} [topological_space H] (I : model_with_corners 𝕜 E H)
  (M : Type*) [topological_space M] [charted_space H M]

/-- The maximal atlas of `M` for the smooth manifold with corners structure corresponding to the
model with corners `I`. -/
def maximal_atlas := (times_cont_diff_groupoid ∞ I).maximal_atlas M

variable {M}

lemma mem_maximal_atlas_of_mem_atlas [smooth_manifold_with_corners I M]
  {e : local_homeomorph M H} (he : e ∈ atlas H M) : e ∈ maximal_atlas I M :=
structure_groupoid.mem_maximal_atlas_of_mem_atlas _ he

lemma chart_mem_maximal_atlas [smooth_manifold_with_corners I M] (x : M) :
  chart_at H x ∈ maximal_atlas I M :=
structure_groupoid.chart_mem_maximal_atlas _ x

variable {I}

lemma compatible_of_mem_maximal_atlas
  {e e' : local_homeomorph M H} (he : e ∈ maximal_atlas I M) (he' : e' ∈ maximal_atlas I M) :
  e.symm.trans e' ∈ times_cont_diff_groupoid ∞ I :=
structure_groupoid.compatible_of_mem_maximal_atlas he he'

/-- The product of two smooth manifolds with corners is naturally a smooth manifold with corners. -/
instance prod {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
  {E : Type*} [normed_group E] [normed_space 𝕜 E]
  {E' : Type*} [normed_group E'] [normed_space 𝕜 E']
  {H : Type*} [topological_space H] {I : model_with_corners 𝕜 E H}
  {H' : Type*} [topological_space H'] {I' : model_with_corners 𝕜 E' H'}
  (M : Type*) [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M]
  (M' : Type*) [topological_space M'] [charted_space H' M'] [smooth_manifold_with_corners I' M'] :
  smooth_manifold_with_corners (I.prod I') (M×M') :=
{ compatible :=
  begin
    rintros f g ⟨f1, hf1, f2, hf2, hf⟩ ⟨g1, hg1, g2, hg2, hg⟩,
    rw [hf, hg, local_homeomorph.prod_symm, local_homeomorph.prod_trans],
    have h1 := has_groupoid.compatible (times_cont_diff_groupoid ⊤ I) hf1 hg1,
    have h2 := has_groupoid.compatible (times_cont_diff_groupoid ⊤ I') hf2 hg2,
    exact times_cont_diff_groupoid_prod h1 h2,
  end }

end smooth_manifold_with_corners

lemma local_homeomorph.singleton_smooth_manifold_with_corners
  {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
  {E : Type*} [normed_group E] [normed_space 𝕜 E]
  {H : Type*} [topological_space H] (I : model_with_corners 𝕜 E H)
  {M : Type*} [topological_space M]
  (e : local_homeomorph M H) (h : e.source = set.univ) :
  @smooth_manifold_with_corners 𝕜 _ E _ _ H _ I M _ (e.singleton_charted_space h) :=
@smooth_manifold_with_corners.mk' _ _ _ _ _ _ _ _ _ _ (id _) $
e.singleton_has_groupoid h (times_cont_diff_groupoid ∞ I)

lemma open_embedding.singleton_smooth_manifold_with_corners
  {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
  {E : Type*} [normed_group E] [normed_space 𝕜 E]
  {H : Type*} [topological_space H] (I : model_with_corners 𝕜 E H)
  {M : Type*} [topological_space M]
  [nonempty M] {f : M → H} (h : open_embedding f) :
  @smooth_manifold_with_corners 𝕜 _ E _ _ H _ I M _ h.singleton_charted_space :=
(h.to_local_homeomorph f).singleton_smooth_manifold_with_corners I (by simp)

namespace topological_space.opens

open topological_space

variables  {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
  {E : Type*} [normed_group E] [normed_space 𝕜 E]
  {H : Type*} [topological_space H] (I : model_with_corners 𝕜 E H)
  {M : Type*} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M]
  (s : opens M)

instance : smooth_manifold_with_corners I s := { ..s.has_groupoid (times_cont_diff_groupoid ∞ I) }

end topological_space.opens

section extended_charts
open_locale topological_space

variables {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
  {E : Type*} [normed_group E] [normed_space 𝕜 E]
  {H : Type*} [topological_space H] (I : model_with_corners 𝕜 E H)
  {M : Type*} [topological_space M] [charted_space H M]
  (x : M) {s t : set M}

/-!
### Extended charts

In a smooth manifold with corners, the model space is the space `H`. However, we will also
need to use extended charts taking values in the model vector space `E`. These extended charts are
not `local_homeomorph` as the target is not open in `E` in general, but we can still register them
as `local_equiv`.
-/

/-- The preferred extended chart on a manifold with corners around a point `x`, from a neighborhood
of `x` to the model vector space. -/
@[simp, mfld_simps] def ext_chart_at (x : M) : local_equiv M E :=
(chart_at H x).to_local_equiv.trans I.to_local_equiv

lemma ext_chart_at_coe : ⇑(ext_chart_at I x) = I ∘ chart_at H x := rfl

lemma ext_chart_at_coe_symm :
  ⇑(ext_chart_at I x).symm = (chart_at H x).symm ∘ I.symm := rfl

lemma ext_chart_at_source : (ext_chart_at I x).source = (chart_at H x).source :=
by rw [ext_chart_at, local_equiv.trans_source, I.source_eq, preimage_univ, inter_univ]

lemma ext_chart_at_open_source : is_open (ext_chart_at I x).source :=
by { rw ext_chart_at_source, exact (chart_at H x).open_source }

lemma mem_ext_chart_source : x ∈ (ext_chart_at I x).source :=
by simp only [ext_chart_at_source, mem_chart_source]

lemma ext_chart_at_to_inv :
  (ext_chart_at I x).symm ((ext_chart_at I x) x) = x :=
(ext_chart_at I x).left_inv (mem_ext_chart_source I x)

lemma ext_chart_at_source_mem_nhds' {x' : M} (h : x' ∈ (ext_chart_at I x).source) :
  (ext_chart_at I x).source ∈ 𝓝 x' :=
mem_nhds_sets (ext_chart_at_open_source I x) h

lemma ext_chart_at_source_mem_nhds : (ext_chart_at I x).source ∈ 𝓝 x :=
ext_chart_at_source_mem_nhds' I x (mem_ext_chart_source I x)

lemma ext_chart_at_source_mem_nhds_within' {x' : M} (h : x' ∈ (ext_chart_at I x).source) :
  (ext_chart_at I x).source ∈ 𝓝[s] x' :=
mem_nhds_within_of_mem_nhds (ext_chart_at_source_mem_nhds' I x h)

lemma ext_chart_at_source_mem_nhds_within :
  (ext_chart_at I x).source ∈ 𝓝[s] x :=
mem_nhds_within_of_mem_nhds (ext_chart_at_source_mem_nhds I x)

lemma ext_chart_at_continuous_on :
  continuous_on (ext_chart_at I x) (ext_chart_at I x).source :=
begin
  refine I.continuous.comp_continuous_on _,
  rw ext_chart_at_source,
  exact (chart_at H x).continuous_on
end

lemma ext_chart_at_continuous_at' {x' : M} (h : x' ∈ (ext_chart_at I x).source) :
  continuous_at (ext_chart_at I x) x' :=
(ext_chart_at_continuous_on I x).continuous_at $ ext_chart_at_source_mem_nhds' I x h

lemma ext_chart_at_continuous_at : continuous_at (ext_chart_at I x) x :=
ext_chart_at_continuous_at' _ _ (mem_ext_chart_source I x)

lemma ext_chart_at_continuous_on_symm :
  continuous_on (ext_chart_at I x).symm (ext_chart_at I x).target :=
begin
  apply continuous_on.comp (chart_at H x).continuous_on_symm I.continuous_symm.continuous_on,
  simp [ext_chart_at, local_equiv.trans_target]
end

lemma ext_chart_at_map_nhds' {x y : M} (hy : y ∈ (ext_chart_at I x).source) :
  map (ext_chart_at I x) (𝓝 y) = 𝓝[range I] (ext_chart_at I x y) :=
begin
  rw [ext_chart_at_coe, (∘), ← I.map_nhds_eq, ← (chart_at H x).map_nhds_eq, map_map],
  rwa ext_chart_at_source at hy
end

lemma ext_chart_at_map_nhds :
  map (ext_chart_at I x) (𝓝 x) = 𝓝[range I] (ext_chart_at I x x) :=
ext_chart_at_map_nhds' I $ mem_ext_chart_source I x

lemma ext_chart_at_target_mem_nhds_within' {y : M} (hy : y ∈ (ext_chart_at I x).source) :
  (ext_chart_at I x).target ∈ 𝓝[range I] (ext_chart_at I x y) :=
begin
  rw [← local_equiv.image_source_eq_target, ← ext_chart_at_map_nhds' I hy],
  exact image_mem_map (ext_chart_at_source_mem_nhds' _ _ hy)
end

lemma ext_chart_at_target_mem_nhds_within :
  (ext_chart_at I x).target ∈ 𝓝[range I] (ext_chart_at I x x) :=
ext_chart_at_target_mem_nhds_within' I x (mem_ext_chart_source I x)

lemma ext_chart_at_target_subset_range : (ext_chart_at I x).target ⊆ range I :=
by simp only with mfld_simps

lemma nhds_within_ext_chart_target_eq' {y : M} (hy : y ∈ (ext_chart_at I x).source) :
  𝓝[(ext_chart_at I x).target] (ext_chart_at I x y) =
  𝓝[range I] (ext_chart_at I x y) :=
(nhds_within_mono _ (ext_chart_at_target_subset_range _ _)).antisymm $
  nhds_within_le_of_mem (ext_chart_at_target_mem_nhds_within' _ _ hy)

lemma nhds_within_ext_chart_target_eq :
  𝓝[(ext_chart_at I x).target] ((ext_chart_at I x) x) =
  𝓝[range I] ((ext_chart_at I x) x) :=
nhds_within_ext_chart_target_eq' I x (mem_ext_chart_source I x)

lemma ext_chart_continuous_at_symm'' {y : E} (h : y ∈ (ext_chart_at I x).target) :
  continuous_at (ext_chart_at I x).symm y :=
continuous_at.comp ((chart_at H x).continuous_at_symm h.2) (I.continuous_symm.continuous_at)

lemma ext_chart_continuous_at_symm' {x' : M} (h : x' ∈ (ext_chart_at I x).source) :
  continuous_at (ext_chart_at I x).symm (ext_chart_at I x x') :=
ext_chart_continuous_at_symm'' I _ $ (ext_chart_at I x).map_source h

lemma ext_chart_continuous_at_symm :
  continuous_at (ext_chart_at I x).symm ((ext_chart_at I x) x) :=
ext_chart_continuous_at_symm' I x (mem_ext_chart_source I x)

lemma ext_chart_continuous_on_symm :
  continuous_on (ext_chart_at I x).symm (ext_chart_at I x).target :=
λ y hy, (ext_chart_continuous_at_symm'' _ _ hy).continuous_within_at

lemma ext_chart_preimage_open_of_open' {s : set E} (hs : is_open s) :
  is_open ((ext_chart_at I x).source ∩ ext_chart_at I x ⁻¹' s) :=
(ext_chart_at_continuous_on I x).preimage_open_of_open (ext_chart_at_open_source _ _) hs

lemma ext_chart_preimage_open_of_open {s : set E} (hs : is_open s) :
  is_open ((chart_at H x).source ∩ ext_chart_at I x ⁻¹' s) :=
by { rw ← ext_chart_at_source I, exact ext_chart_preimage_open_of_open' I x hs }

lemma ext_chart_at_map_nhds_within_eq_image' {y : M} (hy : y ∈ (ext_chart_at I x).source) :
  map (ext_chart_at I x) (𝓝[s] y) =
    𝓝[ext_chart_at I x '' ((ext_chart_at I x).source ∩ s)] (ext_chart_at I x y) :=
by set e := ext_chart_at I x;
calc map e (𝓝[s] y) = map e (𝓝[e.source ∩ s] y) :
  congr_arg (map e) (nhds_within_inter_of_mem (ext_chart_at_source_mem_nhds_within' I x hy)).symm
... = 𝓝[e '' (e.source ∩ s)] (e y) :
  ((ext_chart_at I x).left_inv_on.mono $ inter_subset_left _ _).map_nhds_within_eq
    ((ext_chart_at I x).left_inv hy)
    (ext_chart_continuous_at_symm' I x hy).continuous_within_at
    (ext_chart_at_continuous_at' I x hy).continuous_within_at

lemma ext_chart_at_map_nhds_within_eq_image :
  map (ext_chart_at I x) (𝓝[s] x) =
    𝓝[ext_chart_at I x '' ((ext_chart_at I x).source ∩ s)] (ext_chart_at I x x) :=
ext_chart_at_map_nhds_within_eq_image' I x (mem_ext_chart_source I x)

lemma ext_chart_at_map_nhds_within' {y : M} (hy : y ∈ (ext_chart_at I x).source) :
  map (ext_chart_at I x) (𝓝[s] y) =
    𝓝[(ext_chart_at I x).symm ⁻¹' s ∩ range I] (ext_chart_at I x y) :=
by rw [ext_chart_at_map_nhds_within_eq_image' I x hy, nhds_within_inter,
  ← nhds_within_ext_chart_target_eq' _ _ hy, ← nhds_within_inter,
  (ext_chart_at I x).image_source_inter_eq', inter_comm]

lemma ext_chart_at_map_nhds_within :
  map (ext_chart_at I x) (𝓝[s] x) =
    𝓝[(ext_chart_at I x).symm ⁻¹' s ∩ range I] (ext_chart_at I x x) :=
ext_chart_at_map_nhds_within' I x (mem_ext_chart_source I x)

lemma ext_chart_at_symm_map_nhds_within' {y : M} (hy : y ∈ (ext_chart_at I x).source) :
  map (ext_chart_at I x).symm
    (𝓝[(ext_chart_at I x).symm ⁻¹' s ∩ range I] (ext_chart_at I x y)) = 𝓝[s] y :=
begin
  rw [← ext_chart_at_map_nhds_within' I x hy, map_map, map_congr, map_id],
  exact (ext_chart_at I x).left_inv_on.eq_on.eventually_eq_of_mem
    (ext_chart_at_source_mem_nhds_within' _ _ hy)
end

lemma ext_chart_at_symm_map_nhds_within_range' {y : M} (hy : y ∈ (ext_chart_at I x).source) :
  map (ext_chart_at I x).symm (𝓝[range I] (ext_chart_at I x y)) = 𝓝 y :=
by rw [← nhds_within_univ, ← ext_chart_at_symm_map_nhds_within' I x hy, preimage_univ, univ_inter]

lemma ext_chart_at_symm_map_nhds_within :
  map (ext_chart_at I x).symm
    (𝓝[(ext_chart_at I x).symm ⁻¹' s ∩ range I] (ext_chart_at I x x)) = 𝓝[s] x :=
ext_chart_at_symm_map_nhds_within' I x (mem_ext_chart_source I x)

lemma ext_chart_at_symm_map_nhds_within_range :
  map (ext_chart_at I x).symm (𝓝[range I] (ext_chart_at I x x)) = 𝓝 x :=
ext_chart_at_symm_map_nhds_within_range' I x (mem_ext_chart_source I x)

/-- Technical lemma ensuring that the preimage under an extended chart of a neighborhood of a point
in the source is a neighborhood of the preimage, within a set. -/
lemma ext_chart_preimage_mem_nhds_within' {x' : M} (h : x' ∈ (ext_chart_at I x).source)
  (ht : t ∈ 𝓝[s] x') :
  (ext_chart_at I x).symm ⁻¹' t ∈
    𝓝[(ext_chart_at I x).symm ⁻¹' s ∩ range I] ((ext_chart_at I x) x') :=
by rwa [← ext_chart_at_symm_map_nhds_within' I x h, mem_map] at ht

/-- Technical lemma ensuring that the preimage under an extended chart of a neighborhood of the
base point is a neighborhood of the preimage, within a set. -/
lemma ext_chart_preimage_mem_nhds_within (ht : t ∈ 𝓝[s] x) :
  (ext_chart_at I x).symm ⁻¹' t ∈
    𝓝[(ext_chart_at I x).symm ⁻¹' s ∩ range I] ((ext_chart_at I x) x) :=
ext_chart_preimage_mem_nhds_within' I x (mem_ext_chart_source I x) ht

/-- Technical lemma ensuring that the preimage under an extended chart of a neighborhood of a point
is a neighborhood of the preimage. -/
lemma ext_chart_preimage_mem_nhds (ht : t ∈ 𝓝 x) :
  (ext_chart_at I x).symm ⁻¹' t ∈ 𝓝 ((ext_chart_at I x) x) :=
begin
  apply (ext_chart_continuous_at_symm I x).preimage_mem_nhds,
  rwa (ext_chart_at I x).left_inv (mem_ext_chart_source _ _)
end

/-- Technical lemma to rewrite suitably the preimage of an intersection under an extended chart, to
bring it into a convenient form to apply derivative lemmas. -/
lemma ext_chart_preimage_inter_eq :
  ((ext_chart_at I x).symm ⁻¹' (s ∩ t) ∩ range I)
  = ((ext_chart_at I x).symm ⁻¹' s ∩ range I) ∩ ((ext_chart_at I x).symm ⁻¹' t) :=
by mfld_set_tac

end extended_charts

/-- In the case of the manifold structure on a vector space, the extended charts are just the
identity.-/
lemma ext_chart_model_space_eq_id (𝕜 : Type*) [nondiscrete_normed_field 𝕜]
  {E : Type*} [normed_group E] [normed_space 𝕜 E] (x : E) :
  ext_chart_at (model_with_corners_self 𝕜 E) x = local_equiv.refl E :=
by simp only with mfld_simps


/-
Copyright (c) 2020 Kevin Lacker. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kevin Lacker
-/

import data.nat.digits

/-!
# IMO 1960 Q1

Determine all three-digit numbers $N$ having the property that $N$ is divisible by 11, and
$\dfrac{N}{11}$ is equal to the sum of the squares of the digits of $N$.

Since Lean doesn't have a way to directly express problem statements of the form
"Determine all X satisfying Y", we express two predicates where proving that one implies the
other is equivalent to solving the problem. A human solver also has to discover the
second predicate.

The strategy here is roughly brute force, checking the possible multiples of 11.
-/

open nat

def sum_of_squares (L : list ℕ) : ℕ := (L.map (λ x, x * x)).sum

def problem_predicate (n : ℕ) : Prop :=
(nat.digits 10 n).length = 3 ∧ 11 ∣ n ∧ n / 11 = sum_of_squares (nat.digits 10 n)

def solution_predicate (n : ℕ) : Prop := n = 550 ∨ n = 803

/-
Proving that three digit numbers are the ones in [100, 1000).
-/

lemma not_zero {n : ℕ} (h1 : problem_predicate n) : n ≠ 0 :=
have h2 : nat.digits 10 n ≠ list.nil, from list.ne_nil_of_length_eq_succ h1.left,
digits_ne_nil_iff_ne_zero.mp h2

lemma ge_100 {n : ℕ} (h1 : problem_predicate n) : 100 ≤ n :=
have h2 : 10^3 ≤ 10 * n, begin
  rw ← h1.left,
  refine nat.base_pow_length_digits_le 10 n _ (not_zero h1),
  simp,
end,
by linarith

lemma lt_1000 {n : ℕ} (h1 : problem_predicate n) : n < 1000 :=
have h2 : n < 10^3, begin
  rw ← h1.left,
  refine nat.lt_base_pow_length_digits _,
  simp,
end,
by linarith

/-
We do an exhaustive search to show that all results are covered by `solution_predicate`.
-/

def search_up_to (c n : ℕ) : Prop :=
n = c * 11 ∧ ∀ m : ℕ, m < n → problem_predicate m → solution_predicate m

lemma search_up_to_start : search_up_to 9 99 := ⟨rfl, λ n h p, by linarith [ge_100 p]⟩

lemma search_up_to_step {c n} (H : search_up_to c n)
  {c' n'} (ec : c + 1 = c') (en : n + 11 = n')
  {l} (el : nat.digits 10 n = l)
  (H' : c = sum_of_squares l → c = 50 ∨ c = 73) :
  search_up_to c' n' :=
begin
  subst ec, subst en, subst el,
  obtain ⟨rfl, H⟩ := H,
  refine ⟨by ring, λ m l p, _⟩,
  obtain ⟨h₁, ⟨m, rfl⟩, h₂⟩ := id p,
  by_cases h : 11 * m < c * 11, { exact H _ h p },
  have : m = c, {linarith}, subst m,
  rw [nat.mul_div_cancel_left _ (by norm_num : 11 > 0), mul_comm] at h₂,
  refine (H' h₂).imp _ _; {rintro rfl, norm_num}
end

lemma search_up_to_end {c} (H : search_up_to c 1001)
  {n : ℕ} (ppn : problem_predicate n) : solution_predicate n :=
H.2 _ (by linarith [lt_1000 ppn]) ppn

lemma right_direction {n : ℕ} : problem_predicate n → solution_predicate n :=
begin
  have := search_up_to_start,
  iterate 82 {
    replace := search_up_to_step this (by norm_num1; refl) (by norm_num1; refl)
      (by norm_num1; refl) dec_trivial },
  exact search_up_to_end this
end

/-
Now we just need to prove the equivalence, for the precise problem statement.
-/

lemma left_direction (n : ℕ) (spn : solution_predicate n) : problem_predicate n :=
by rcases spn with (rfl | rfl); norm_num [problem_predicate, sum_of_squares]

theorem imo1960_q1 (n : ℕ) : problem_predicate n ↔ solution_predicate n :=
⟨right_direction, left_direction n⟩


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/

import category_theory.category
import category_theory.abelian.basic
import exact

/-!
# Pseudoelements in abelian categories

A *pseudoelement* of an object `X` in an abelian category `C` is an equivalence
class of arrows ending in `X`. While the construction shows that pseudoelements are actually
subobjects of `X` rather than "elements", it is possible to chase these pseudoelements through
commutative diagrams in an abelian category to prove exactness properties. This is done using
some "diagram-chasing metatheorems" proved in this file. In many cases, a proof in the category
of abelian groups can more or less directly be converted into a proof using pseudoelements.

A classical application of pseudoelements are diagram lemmas like the four lemma or the snake
lemma.

Pseudoelements are in some ways weaker than actual elements in a concrete category. The most
important limitation is that there is no existensionality principle: If `f g : X ⟶ Y`, then
`∀ x ∈ X, f x = g x` does not necessarily imply that `f = g` (however, if `f = 0` or `g = 0`,
it does). A corollary of this is that we can not define arrows in abelian categories by dictating
their action on pseudoelements. Thus, a usual style of proofs in abelian categories is this:
First, we construct some morphism using universal properties, and then we use diagram chasing
of pseudoelements to verify that is has some desirable property such as exactness.

It should be noted that the Freyd-Mitchell embedding theorem gives a vastly stronger notion of
pseudoelement (in particular one that gives existensionality). However, this theorem is quite
difficult to prove and probably out of reach for a formal proof for the time being.

## Main results

We define the type of pseudoelements of an object and, in particular, the zero pseudoelement.

We prove that every morphism maps the zero pseudoelement to the zero pseudoelement (`apply_zero`)
and that a zero morphism maps every pseudoelement to the zero pseudoelement (`zero_apply`)

Here are the metatheorems we provide:
* A morphism `f` is zero if and only if it is the zero function on pseudoelements.
* A morphism `f` is an epimorphism if and only if it is surjective on pseudoelements.
* A morphism `f` is a monomorphism if and only if it is injective on pseudoelements
  if and only if `∀ a, f a = 0 → f = 0`.
* A sequence `f, g` of morphisms is exact if and only if
  `∀ a, g (f a) = 0` and `∀ b, g b = 0 → ∃ a, f a = b`.
* If `f` is a morphism and `a, a'` are such that `f a = f a'`, then there is some
  pseudoelement `a''` such that `f a'' = 0` and for every `g` we have
  `g a' = 0 → g a = g a''`. We can think of `a''` as `a - a'`, but don't get too carried away
  by that: Pseudoelements of an object to not form an abelian group.

## Notations

We introduce coercions from an element of an abelian category to the set of its pseudoelements
and from a morphism to the function it induces on pseudoelements.

These coercions must be explicitly enabled via local instances.

## Implementation notes

It appears that sometimes the coercion from morphisms to functions does not work, i.e.,
writing `g a` raises a "function expected" error. This error can be fixed by writing
`(g : X ⟶ Y) a`.

## References

* [F. Borceux, *Handbook of Categorical Algebra 2*][borceux-vol2]
-/

open category_theory
open category_theory.limits
open category_theory.abelian
open category_theory.preadditive

universes v u

namespace category_theory.abelian

variables {C : Type u} [𝒞 : category.{v} C]
include 𝒞

/-- Arrows with codomain `P` -/
def with_codomain (P : C) := Σ Q, Q ⟶ P

/-- An arrow with codomain `P` can be taken to be a `with_codomain P` -/
def coe_with_codomain {P Q : C} : has_coe (Q ⟶ P) (with_codomain P) :=
{ coe := λ f, ⟨Q, f⟩ }

local attribute [instance] coe_with_codomain

/-- This is just composition of morphisms in `C`. -/
def app {P Q : C} (f : P ⟶ Q) (a : with_codomain P) : with_codomain Q :=
⟨a.1, a.2 ≫ f⟩

/-- Two arrows `f : X ⟶ P` and `g : Y ⟶ P are called pseudo-equal if there is some object
    `R` and epimorphisms `p : R ⟶ X` and `q : R ⟶ Y` such that `p ≫ f = q ≫ g`. -/
def pseudo_equal (P : C) (f g : with_codomain P) : Prop :=
∃ (R : C) (p : R ⟶ f.1) (q : R ⟶ g.1) [epi p] [epi q], p ≫ f.2 = q ≫ g.2

lemma pseudo_equal_refl {P : C} : reflexive (pseudo_equal P) :=
λ f, ⟨f.1, 𝟙 f.1, 𝟙 f.1, by apply_instance, by apply_instance, by simp⟩

lemma pseudo_equal_symm {P : C} : symmetric (pseudo_equal P) :=
λ f g ⟨R, p, q, ep, eq, comm⟩, ⟨R, q, p, eq, ep, comm.symm⟩

variables [abelian.{v} C]

/-- Pseudoequality is transitive: Just take the pullback. The pullback morphisms will
    be epimorphisms since in an abelian category, pullbacks of epimorphisms are epimorphisms. -/
lemma pseudo_equal_trans {P : C} : transitive (pseudo_equal P) :=
λ f g h ⟨R, p, q, ep, eq, comm⟩ ⟨R', p', q', ep', eq', comm'⟩,
begin
  refine ⟨pullback q p', pullback.fst ≫ p, pullback.snd ≫ q', _, _, _⟩,
  { resetI, exact epi_comp _ _ },
  { resetI, exact epi_comp _ _ },
  { rw [category.assoc, comm, ←category.assoc, pullback.condition,
      category.assoc, comm', category.assoc] }
end

lemma pseudo_equal_equiv {P : C} : equivalence (pseudo_equal P) :=
⟨pseudo_equal_refl, pseudo_equal_symm, pseudo_equal_trans⟩

/-- The arrows with codomain `P` equipped with the equivalence relation of being pseudo-equal. -/
def pseudoelements.setoid (P : C) : setoid (with_codomain P) :=
{ r := pseudo_equal P,
  iseqv := pseudo_equal_equiv }

local attribute [instance] pseudoelements.setoid

/-- A `pseudoelement` of `P` is just an equivalence class of arrows ending in `P` by being
    pseudo-equal. -/
def pseudoelements (P : C) : Type (max u v) := quotient (pseudoelements.setoid P)

namespace pseudoelements

/-- A coercion from an object of an abelian category to its pseudoelements. -/
def object_to_sort : has_coe_to_sort C :=
{ S := Type (max u v),
  coe := λ P, pseudoelements P }

local attribute [instance] object_to_sort

/-- A coercion from an arrow with codomain `P` to its associated pseudoelement. -/
def with_codomain_to_sort {P : C} : has_coe (with_codomain P) (pseudoelements P) :=
⟨quot.mk (pseudo_equal P)⟩

local attribute [instance] with_codomain_to_sort

/-- If two elements are pseudo-equal, then their composition with a morphism is, too. -/
lemma pseudo_apply_aux {P Q : C} (f : P ⟶ Q) (a b : with_codomain P) :
  a ≈ b → ⟦app f a⟧ = ⟦app f b⟧ :=
λ ⟨R, p, q, ep, eq, comm⟩, quotient.sound ⟨R, p, q, ep, eq,
  show p ≫ a.2 ≫ f = q ≫ b.2 ≫ f, by rw [←category.assoc, comm, category.assoc]⟩

/-- A morphism `f` induces a function `pseudo_apply f` on pseudoelements. -/
def pseudo_apply {P Q : C} (f : P ⟶ Q) : P → Q :=
quotient.lift (λ (g : with_codomain P), ⟦app f g⟧) (pseudo_apply_aux f)

/-- A coercion from morphisms to functions on pseudoelements -/
def hom_to_fun {P Q : C} : has_coe_to_fun (P ⟶ Q) := ⟨_, pseudo_apply⟩

local attribute [instance] hom_to_fun

lemma pseudo_apply_bar {P Q : C} (f : P ⟶ Q) (a : with_codomain P) : f ⟦a⟧ = ⟦a.2 ≫ f⟧ :=
rfl

/-- Applying a pseudoelement to a composition of morphisms is the same as composing
    with each morphism. Sadly, this is not a definition equality, but at least it is
    true. -/
theorem comp_apply {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) (a : P) : (f ≫ g) a = g (f a) :=
quotient.induction_on a $ λ x, quotient.sound $ by unfold app; rw category.assoc

/-- Composition of functions on pseudoelements is composition of morphisms -/
theorem comp_comp {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) : g ∘ f = f ≫ g :=
funext $ λ x, (comp_apply _ _ _).symm

section zero
/-!
In this section we prove that for every `P` there is an equivalence class that contains
precisely all the zero morphisms ending in `P` and use this to define *the* zero
pseudoelement.
-/

/-- The arrows pseudo-equal to a zero morphism are precisely the zero morphisms -/
lemma pseudo_zero_aux {P : C} (Q : C) (f : with_codomain P) : f ≈ (0 : Q ⟶ P) ↔ f.2 = 0 :=
⟨λ ⟨R, p, q, ep, eq, comm⟩, (preadditive.cancel_zero_iff_epi p).1 ep _ f.snd $
    by erw [comm, has_zero_morphisms.comp_zero],
  λ hf, ⟨biproduct f.1 Q, biproduct.fst, biproduct.snd, by apply_instance, by apply_instance,
    by erw [hf, has_zero_morphisms.comp_zero, has_zero_morphisms.comp_zero]⟩⟩

lemma zero_eq_zero {P Q R : C} :
  ⟦((0 : Q ⟶ P) : with_codomain P)⟧ = ⟦((0 : R ⟶ P) : with_codomain P)⟧ :=
quotient.sound $ (pseudo_zero_aux R _).2 rfl

/-- The zero pseudoelement is the class of a zero morphism -/
def pseudo_zero {P : C} : P := ⟦(0 : P ⟶ P)⟧

instance {P : C} : has_zero P := ⟨pseudo_zero⟩

/-- The pseudoelement induced by an arrow is zero precisely when that arrow is zero -/
lemma pseudo_zero_iff {P : C} (a : with_codomain P) : (a : P) = 0 ↔ a.2 = 0 :=
by rw ←pseudo_zero_aux P a; exact quotient.eq

end zero

/-- Morphisms map the zero pseudoelement to the zero pseudoelement -/
theorem apply_zero {P Q : C} (f : P ⟶ Q) : f 0 = 0 :=
by erw [pseudo_apply_bar, has_zero_morphisms.zero_comp]; exact zero_eq_zero

/-- The zero morphism maps every pseudoelement to 0. -/
theorem zero_apply {P : C} (Q : C) (a : P) : (0 : P ⟶ Q) a = 0 :=
quotient.induction_on a $ λ a',
  by erw [pseudo_apply_bar, has_zero_morphisms.comp_zero]; exact zero_eq_zero

/-- An existentionality lemma for being the zero arrow. -/
@[ext] theorem zero_morphism_ext {P Q : C} (f : P ⟶ Q) : (∀ a, f a = 0) → f = 0 :=
λ h, by { rw ←category.id_comp f,
  apply (pseudo_zero_iff ((𝟙 P ≫ f) : with_codomain Q)).1,
  exact h (𝟙 P) }

theorem zero_iff {P Q : C} (f : P ⟶ Q) : f = 0 ↔ ∀ a, f a = 0 :=
⟨λ h a, by rw h; exact zero_apply _ _, zero_morphism_ext _⟩

/-- A monomorphism is injective on pseudoelements. -/
theorem pseudo_injective_of_mono {P Q : C} (f : P ⟶ Q) [mono f] : function.injective f :=
λ abar abar', quotient.induction_on₂ abar abar' $ λ a a' ha, quotient.sound $
  have ⟦(a.2 ≫ f : with_codomain Q)⟧ = ⟦a'.2 ≫ f⟧, by convert ha,
  match quotient.exact this with ⟨R, p, q, ep, eq, comm⟩ :=
    ⟨R, p, q, ep, eq, (cancel_mono f).1 $ by simp only [category.assoc]; exact comm⟩
  end

/-- A morphism that is injective on pseudoelements only maps the zero element to zero. -/
lemma zero_of_map_zero {P Q : C} (f : P ⟶ Q) : function.injective f → ∀ a, f a = 0 → a = 0 :=
λ h a ha, by rw ←apply_zero f at ha; exact h ha

/-- A morphism that only maps the zero pseudoelement to zero is a monomorphism. -/
theorem mono_of_zero_of_map_zero {P Q : C} (f : P ⟶ Q) : (∀ a, f a = 0 → a = 0) → mono f :=
λ h, (cancel_zero_iff_mono _).2 $ λ R g hg, (pseudo_zero_iff (g : with_codomain P)).1 $ h _ $
  show f g = 0, from (pseudo_zero_iff ⟨R, g ≫ f⟩).2 hg

/-- An epimorphism is surjective on pseudoelements. -/
theorem pseudo_surjective_of_epi {P Q : C} (f : P ⟶ Q) [epi f] : function.surjective f :=
λ qbar, quotient.induction_on qbar $ λ q, ⟨(pullback.fst : pullback f q.2 ⟶ P), quotient.sound $
  ⟨pullback f q.2, 𝟙 (pullback f q.2), pullback.snd, by apply_instance, by apply_instance,
    by erw [category.id_comp, ←pullback.condition]; refl⟩⟩

/-- A morphism that is surjective on pseudoelements is an epimorphism. -/
theorem epi_of_pseudo_surjective {P Q : C} (f : P ⟶ Q) : function.surjective f → epi f :=
λ h, match h (𝟙 Q) with ⟨pbar, hpbar⟩ :=
  match quotient.exists_rep pbar with ⟨p, hp⟩ :=
    have ⟦(p.2 ≫ f : with_codomain Q)⟧ = ⟦𝟙 Q⟧, by rw ←hp at hpbar; exact hpbar,
    match quotient.exact this with ⟨R, x, y, ex, ey, comm⟩ :=
      @epi_of_epi_fac _ _ _ _ _ (x ≫ p.2) f y ey $ by erw [category.assoc, comm, category.comp_id]
    end
  end
end

/-- Two morphisms in an exact sequence are exact on pseudoelements. -/
theorem pseudo_exact_of_exact {P Q R : C} {f : P ⟶ Q} {g : Q ⟶ R} (h : exact f g) :
  (∀ a, g (f a) = 0) ∧ (∀ b, g b = 0 → ∃ a, f a = b) :=
⟨λ a, by rw [←comp_apply, h.1]; exact zero_apply _ _,
  λ b', quotient.induction_on b' $ λ b hb,
    have hb' : b.2 ≫ g = 0, from (pseudo_zero_iff _).1 hb,
    begin
      -- By exactness, b factors through im f = ker g via some c
      obtain ⟨c, hc⟩ := kernel_fork.is_limit.lift' (exact_ker _ _ h) _ hb',

      -- We compute the pullback of the map into the image and c.
      -- The pseudoelement induced by the first pullback map will be our preimage.
      use (pullback.fst : pullback (factor_thru_image f) c ⟶ P),

      -- It remains to show that the image of this element under f is pseudo-equal to b.
      apply quotient.sound,

      -- pullback.snd is an epimorphism because the map onto the image is!
      refine ⟨pullback (factor_thru_image f) c, 𝟙 _, pullback.snd,
        by apply_instance, by apply_instance, _⟩,

      -- Now we can verify that the diagram commutes.
      calc 𝟙 (pullback (factor_thru_image f) c) ≫ pullback.fst ≫ f = pullback.fst ≫ f
                : category.id_comp _
        ... = pullback.fst ≫ factor_thru_image f ≫ kernel.ι (cokernel.π f)
                : by rw image.fac
        ... = (pullback.snd ≫ c) ≫ kernel.ι (cokernel.π f)
                : by rw [←category.assoc, pullback.condition]
        ... = pullback.snd ≫ b.2
                : by erw [category.assoc, hc]
    end⟩

lemma comp_zero {P Q R : C} (f : Q ⟶ R) (a : P ⟶ Q) : a ≫ f = 0 → f a = 0 :=
λ h, by erw [pseudo_apply_bar, h]; exact zero_eq_zero

/-- If two morphisms are exact on pseudoelements, they are exact. -/
theorem exact_of_pseudo_exact {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) :
  (∀ a, g (f a) = 0) ∧ (∀ b, g b = 0 → ∃ a, f a = b) → exact f g :=
λ ⟨h₁, h₂⟩, ⟨zero_morphism_ext _ $ λ a, by rw [comp_apply, h₁ a],
begin
  -- If we apply g to the pseudoelement induced by its kernel, we get 0 (of course!).
  have : g (kernel.ι g) = 0 := comp_zero _ _ (kernel.condition _),

  -- By pseudo-exactness, we get a preimage.
  obtain ⟨a', ha⟩ := h₂ _ this,
  obtain ⟨a, ha'⟩ := quotient.exists_rep a',
  rw ←ha' at ha,
  obtain ⟨Z, r, q, er, eq, comm⟩ := quotient.exact ha,

  -- Consider the pullback of kernel.ι (cokernel.π f) and kernel.ι g.
  -- The commutative diagram given by the pseudo-equality f a = b induces
  -- a cone over this pullback, so we get a factorization z.
  obtain ⟨z, hz₁, hz₂⟩ := @pullback.lift' _ _ _ _ _ _ (kernel.ι (cokernel.π f)) (kernel.ι g) _
    (r ≫ a.2 ≫ factor_thru_image f) q (by simp only [category.assoc, image.fac]; exact comm),

  -- Let's give a name to the second pullback morphism.
  let j : pullback (kernel.ι (cokernel.π f)) (kernel.ι g) ⟶ kernel g := pullback.snd,

  -- Since q is an epimorphism, in particular this means that j is an epimorphism.
  haveI pe : epi j := by exactI epi_of_epi_fac hz₂,

  -- But is is also a monomorphism, because kernel.ι (cokernel.π f) is: A kernel is
  -- always a monomorphism and the pullback of a monomorphism is a monomorphism.
  -- But mono + epi = iso, so j is an isomorphism.
  haveI : is_iso j := mono_epi_iso _,

  -- But then kernel.ι g can be expressed using all of the maps of the pullback square, and we
  -- are done.
  rw (iso.eq_inv_comp (as_iso j)).2 pullback.condition.symm,
  simp only [category.assoc, kernel.condition, has_zero_morphisms.comp_zero]
end⟩

/-- If two pseudoelements `x` and `y` have the same image under some morphism `f`, then we can form
    their "difference" `z`. This pseudoelement has the properties that `f z = 0` and for all
    morphisms `g`, if `g y = 0` then `g z = g x`. -/
theorem sub_of_eq_image {P Q : C} (f : P ⟶ Q) (x y : P) : f x = f y →
  ∃ z, f z = 0 ∧ ∀ (R : C) (g : P ⟶ R), (g : P ⟶ R) y = 0 → g z = g x :=
quotient.induction_on₂ x y $ λ a a' h,
match quotient.exact h with ⟨R, p, q, ep, eq, comm⟩ :=
  let a'' : R ⟶ P := p ≫ a.2 - q ≫ a'.2 in ⟨a'',
    ⟨show ⟦((p ≫ a.2 - q ≫ a'.2) ≫ f : with_codomain Q)⟧ = ⟦(0 : Q ⟶ Q)⟧,
      by erw [distrib_left, neg_left, category.assoc, category.assoc,
        ←sub_eq_add_neg, sub_eq_zero.2 comm, zero_eq_zero],
      λ Z g hh,
      begin
        obtain ⟨X, p', q', ep', eq', comm'⟩ := quotient.exact hh,

        have : a'.snd ≫ g = 0,
        { apply (cancel_zero_iff_epi _).1 ep' _ (a'.snd ≫ g),
          erw [comm', has_zero_morphisms.comp_zero] },

        apply quotient.sound,
        refine ⟨R, 𝟙 R, p, by apply_instance, ep, _⟩,

        change 𝟙 R ≫ a'' ≫ g = p ≫ a.2 ≫ g,
        erw [category.id_comp, preadditive.distrib_left, neg_left, category.assoc,
          add_right_eq_self, neg_eq_zero, category.assoc, this, has_zero_morphisms.comp_zero]
      end⟩⟩
end

/-- If `f : P ⟶ R` and `g : Q ⟶ R` are morphisms and `p : P` and `q : Q` are pseudoelements such
    that `f p = g q`, then there is some `s : pullback f g` such that `fst s = p` and `snd s = q`.

    Remark: Borceux claims that `s` is unique. I was unable to transform his proof sketch into
    a pen-and-paper proof of this fact, so naturally I was not able to formalize the proof. -/
theorem pseudo_pullback {P Q R : C} {f : P ⟶ R} {g : Q ⟶ R} {p : P} {q : Q} : f p = g q →
  ∃ s, (pullback.fst : pullback f g ⟶ P) s = p ∧ (pullback.snd : pullback f g ⟶ Q) s = q :=
quotient.induction_on₂ p q $ λ x y h,
begin
  obtain ⟨Z, a, b, ea, eb, comm⟩ := quotient.exact h,

  obtain ⟨l, hl₁, hl₂⟩ := @pullback.lift' _ _ _ _ _ _ f g _ (a ≫ x.2) (b ≫ y.2)
    (by simp only [category.assoc]; exact comm),

  exact ⟨l, ⟨quotient.sound ⟨Z, 𝟙 Z, a, by apply_instance, ea, by rw category.id_comp; exact hl₁⟩,
    quotient.sound ⟨Z, 𝟙 Z, b, by apply_instance, eb, by rw category.id_comp; exact hl₂⟩⟩⟩
end

end pseudoelements
end category_theory.abelian


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

! This file was ported from Lean 3 source module field_theory.splitting_field
! leanprover-community/mathlib commit 6a5a6494968741677358457a806f487c7e293d39
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.FieldTheory.IntermediateField
import Mathbin.RingTheory.Adjoin.Field

/-!
# Splitting fields

This file introduces the notion of a splitting field of a polynomial and provides an embedding from
a splitting field to any field that splits the polynomial. A polynomial `f : K[X]` splits
over a field extension `L` of `K` if it is zero or all of its irreducible factors over `L` have
degree `1`. A field extension of `K` of a polynomial `f : K[X]` is called a splitting field
if it is the smallest field extension of `K` such that `f` splits.

## Main definitions

* `polynomial.splitting_field f`: A fixed splitting field of the polynomial `f`.
* `polynomial.is_splitting_field`: A predicate on a field to be a splitting field of a polynomial
  `f`.

## Main statements

* `polynomial.is_splitting_field.lift`: An embedding of a splitting field of the polynomial `f` into
  another field such that `f` splits.
* `polynomial.is_splitting_field.alg_equiv`: Every splitting field of a polynomial `f` is isomorphic
  to `splitting_field f` and thus, being a splitting field is unique up to isomorphism.

-/

noncomputable section

open Classical BigOperators Polynomial

universe u v w

variable {F : Type u} {K : Type v} {L : Type w}

namespace Polynomial

variable [Field K] [Field L] [Field F]

open Polynomial

section SplittingField

/-- Non-computably choose an irreducible factor from a polynomial. -/
def factor (f : K[X]) : K[X] :=
  if H : ∃ g, Irreducible g ∧ g ∣ f then Classical.choose H else X
#align polynomial.factor Polynomial.factor

theorem irreducible_factor (f : K[X]) : Irreducible (factor f) := by rw [factor]; split_ifs with H;
  · exact (Classical.choose_spec H).1; · exact irreducible_X
#align polynomial.irreducible_factor Polynomial.irreducible_factor

/-- See note [fact non-instances]. -/
theorem fact_irreducible_factor (f : K[X]) : Fact (Irreducible (factor f)) :=
  ⟨irreducible_factor f⟩
#align polynomial.fact_irreducible_factor Polynomial.fact_irreducible_factor

attribute [local instance] fact_irreducible_factor

theorem factor_dvd_of_not_isUnit {f : K[X]} (hf1 : ¬IsUnit f) : factor f ∣ f :=
  by
  by_cases hf2 : f = 0;
  · rw [hf2]
    exact dvd_zero _
  rw [factor, dif_pos (WfDvdMonoid.exists_irreducible_factor hf1 hf2)]
  exact (Classical.choose_spec <| WfDvdMonoid.exists_irreducible_factor hf1 hf2).2
#align polynomial.factor_dvd_of_not_is_unit Polynomial.factor_dvd_of_not_isUnit

theorem factor_dvd_of_degree_ne_zero {f : K[X]} (hf : f.degree ≠ 0) : factor f ∣ f :=
  factor_dvd_of_not_isUnit (mt degree_eq_zero_of_isUnit hf)
#align polynomial.factor_dvd_of_degree_ne_zero Polynomial.factor_dvd_of_degree_ne_zero

theorem factor_dvd_of_natDegree_ne_zero {f : K[X]} (hf : f.natDegree ≠ 0) : factor f ∣ f :=
  factor_dvd_of_degree_ne_zero (mt natDegree_eq_of_degree_eq_some hf)
#align polynomial.factor_dvd_of_nat_degree_ne_zero Polynomial.factor_dvd_of_natDegree_ne_zero

/-- Divide a polynomial f by X - C r where r is a root of f in a bigger field extension. -/
def removeFactor (f : K[X]) : Polynomial (AdjoinRoot <| factor f) :=
  map (AdjoinRoot.of f.factor) f /ₘ (X - C (AdjoinRoot.root f.factor))
#align polynomial.remove_factor Polynomial.removeFactor

theorem x_sub_c_mul_removeFactor (f : K[X]) (hf : f.natDegree ≠ 0) :
    (X - C (AdjoinRoot.root f.factor)) * f.removeFactor = map (AdjoinRoot.of f.factor) f :=
  let ⟨g, hg⟩ := factor_dvd_of_natDegree_ne_zero hf
  mul_divByMonic_eq_iff_isRoot.2 <| by
    rw [is_root.def, eval_map, hg, eval₂_mul, ← hg, AdjoinRoot.eval₂_root, MulZeroClass.zero_mul]
#align polynomial.X_sub_C_mul_remove_factor Polynomial.x_sub_c_mul_removeFactor

theorem natDegree_removeFactor (f : K[X]) : f.removeFactor.natDegree = f.natDegree - 1 := by
  rw [remove_factor, nat_degree_div_by_monic _ (monic_X_sub_C _), nat_degree_map,
    nat_degree_X_sub_C]
#align polynomial.nat_degree_remove_factor Polynomial.natDegree_removeFactor

theorem natDegree_remove_factor' {f : K[X]} {n : ℕ} (hfn : f.natDegree = n + 1) :
    f.removeFactor.natDegree = n := by rw [nat_degree_remove_factor, hfn, n.add_sub_cancel]
#align polynomial.nat_degree_remove_factor' Polynomial.natDegree_remove_factor'

/-- Auxiliary construction to a splitting field of a polynomial, which removes
`n` (arbitrarily-chosen) factors.

Uses recursion on the degree. For better definitional behaviour, structures
including `splitting_field_aux` (such as instances) should be defined using
this recursion in each field, rather than defining the whole tuple through
recursion.
-/
def SplittingFieldAux (n : ℕ) : ∀ {K : Type u} [Field K], ∀ f : K[X], Type u :=
  Nat.recOn n (fun K _ _ => K) fun n ih K _ f => ih f.remove_factor
#align polynomial.splitting_field_aux Polynomial.SplittingFieldAux

namespace SplittingFieldAux

theorem succ (n : ℕ) (f : K[X]) :
    SplittingFieldAux (n + 1) f = SplittingFieldAux n f.removeFactor :=
  rfl
#align polynomial.splitting_field_aux.succ Polynomial.SplittingFieldAux.succ

instance field (n : ℕ) : ∀ {K : Type u} [Field K], ∀ {f : K[X]}, Field (splitting_field_aux n f) :=
  Nat.recOn n (fun K _ _ => ‹Field K›) fun n ih K _ f => ih
#align polynomial.splitting_field_aux.field Polynomial.SplittingFieldAux.field

instance inhabited {n : ℕ} {f : K[X]} : Inhabited (SplittingFieldAux n f) :=
  ⟨37⟩
#align polynomial.splitting_field_aux.inhabited Polynomial.SplittingFieldAux.inhabited

/-
Note that the recursive nature of this definition and `splitting_field_aux.field` creates
non-definitionally-equal diamonds in the `ℕ`- and `ℤ`- actions.
```lean
example (n : ℕ) {K : Type u} [field K] {f : K[X]} (hfn : f.nat_degree = n) :
    (add_comm_monoid.nat_module : module ℕ (splitting_field_aux n f hfn)) =
  @algebra.to_module _ _ _ _ (splitting_field_aux.algebra n _ hfn) :=
rfl  -- fails
```
It's not immediately clear whether this _can_ be fixed; the failure is much the same as the reason
that the following fails:
```lean
def cases_twice {α} (a₀ aₙ : α) : ℕ → α × α
| 0 := (a₀, a₀)
| (n + 1) := (aₙ, aₙ)

example (x : ℕ) {α} (a₀ aₙ : α) : (cases_twice a₀ aₙ x).1 = (cases_twice a₀ aₙ x).2 := rfl  -- fails
```
We don't really care at this point because this is an implementation detail (which is why this is
not a docstring), but we do in `splitting_field.algebra'` below. -/
instance algebra (n : ℕ) :
    ∀ (R : Type _) {K : Type u} [CommSemiring R] [Field K],
      ∀ [Algebra R K] {f : K[X]}, Algebra R (splitting_field_aux n f) :=
  Nat.recOn n (fun R K _ _ _ _ => ‹Algebra R K›) fun n ih R K _ _ _ f => ih R
#align polynomial.splitting_field_aux.algebra Polynomial.SplittingFieldAux.algebra

instance isScalarTower (n : ℕ) :
    ∀ (R₁ R₂ : Type _) {K : Type u} [CommSemiring R₁] [CommSemiring R₂] [SMul R₁ R₂] [Field K],
      ∀ [Algebra R₁ K] [Algebra R₂ K],
        ∀ [IsScalarTower R₁ R₂ K] {f : K[X]}, IsScalarTower R₁ R₂ (splitting_field_aux n f) :=
  Nat.recOn n (fun R₁ R₂ K _ _ _ _ _ _ _ _ => ‹IsScalarTower R₁ R₂ K›)
    fun n ih R₁ R₂ K _ _ _ _ _ _ _ f => ih R₁ R₂
#align polynomial.splitting_field_aux.is_scalar_tower Polynomial.SplittingFieldAux.isScalarTower

instance algebra''' {n : ℕ} {f : K[X]} :
    Algebra (AdjoinRoot f.factor) (SplittingFieldAux n f.removeFactor) :=
  SplittingFieldAux.algebra n _
#align polynomial.splitting_field_aux.algebra''' Polynomial.SplittingFieldAux.algebra'''

instance algebra' {n : ℕ} {f : K[X]} : Algebra (AdjoinRoot f.factor) (SplittingFieldAux n.succ f) :=
  SplittingFieldAux.algebra'''
#align polynomial.splitting_field_aux.algebra' Polynomial.SplittingFieldAux.algebra'

instance algebra'' {n : ℕ} {f : K[X]} : Algebra K (SplittingFieldAux n f.removeFactor) :=
  SplittingFieldAux.algebra n K
#align polynomial.splitting_field_aux.algebra'' Polynomial.SplittingFieldAux.algebra''

instance scalar_tower' {n : ℕ} {f : K[X]} :
    IsScalarTower K (AdjoinRoot f.factor) (SplittingFieldAux n f.removeFactor) :=
  haveI-- finding this instance ourselves makes things faster
   : IsScalarTower K (AdjoinRoot f.factor) (AdjoinRoot f.factor) := IsScalarTower.right
  splitting_field_aux.is_scalar_tower n K (AdjoinRoot f.factor)
#align polynomial.splitting_field_aux.scalar_tower' Polynomial.SplittingFieldAux.scalar_tower'

instance scalar_tower {n : ℕ} {f : K[X]} :
    IsScalarTower K (AdjoinRoot f.factor) (SplittingFieldAux (n + 1) f) :=
  SplittingFieldAux.scalar_tower'
#align polynomial.splitting_field_aux.scalar_tower Polynomial.SplittingFieldAux.scalar_tower

theorem algebraMap_succ (n : ℕ) (f : K[X]) :
    algebraMap K (splitting_field_aux (n + 1) f) =
      (algebraMap (AdjoinRoot f.factor) (splitting_field_aux n f.remove_factor)).comp
        (AdjoinRoot.of f.factor) :=
  IsScalarTower.algebraMap_eq _ _ _
#align polynomial.splitting_field_aux.algebra_map_succ Polynomial.SplittingFieldAux.algebraMap_succ

protected theorem splits (n : ℕ) :
    ∀ {K : Type u} [Field K],
      ∀ (f : K[X]) (hfn : f.natDegree = n), splits (algebraMap K <| splitting_field_aux n f) f :=
  Nat.recOn n
    (fun K _ _ hf =>
      splits_of_degree_le_one _
        (le_trans degree_le_nat_degree <| hf.symm ▸ WithBot.coe_le_coe.2 zero_le_one))
    fun n ih K _ f hf => by
    skip
    rw [← splits_id_iff_splits, algebra_map_succ, ← map_map, splits_id_iff_splits, ←
      X_sub_C_mul_remove_factor f fun h => by
        rw [h] at hf
        cases hf]
    exact splits_mul _ (splits_X_sub_C _) (ih _ (nat_degree_remove_factor' hf))
#align polynomial.splitting_field_aux.splits Polynomial.SplittingFieldAux.splits

theorem exists_lift (n : ℕ) :
    ∀ {K : Type u} [Field K],
      ∀ (f : K[X]) (hfn : f.natDegree = n) {L : Type _} [Field L],
        ∀ (j : K →+* L) (hf : splits j f),
          ∃ k : splitting_field_aux n f →+* L, k.comp (algebraMap _ _) = j :=
  Nat.recOn n (fun K _ _ _ L _ j _ => ⟨j, j.comp_id⟩) fun n ih K _ f hf L _ j hj =>
    have hndf : f.nat_degree ≠ 0 := by
      intro h
      rw [h] at hf
      cases hf
    have hfn0 : f ≠ 0 := by
      intro h
      rw [h] at hndf
      exact hndf rfl
    let ⟨r, hr⟩ :=
      exists_root_of_splits _
        (splits_of_splits_of_dvd j hfn0 hj (factor_dvd_of_nat_degree_ne_zero hndf))
        (mt is_unit_iff_degree_eq_zero.2 f.irreducible_factor.1)
    have hmf0 : map (AdjoinRoot.of f.factor) f ≠ 0 := map_ne_zero hfn0
    have hsf : splits (AdjoinRoot.lift j r hr) f.remove_factor :=
      by
      rw [← X_sub_C_mul_remove_factor _ hndf] at hmf0
      refine' (splits_of_splits_mul _ hmf0 _).2
      rwa [X_sub_C_mul_remove_factor _ hndf, ← splits_id_iff_splits, map_map,
        AdjoinRoot.lift_comp_of, splits_id_iff_splits]
    let ⟨k, hk⟩ := ih f.remove_factor (nat_degree_remove_factor' hf) (AdjoinRoot.lift j r hr) hsf
    ⟨k, by rw [algebra_map_succ, ← RingHom.comp_assoc, hk, AdjoinRoot.lift_comp_of]⟩
#align polynomial.splitting_field_aux.exists_lift Polynomial.SplittingFieldAux.exists_lift

theorem adjoin_roots (n : ℕ) :
    ∀ {K : Type u} [Field K],
      ∀ (f : K[X]) (hfn : f.natDegree = n),
        Algebra.adjoin K
            (↑(f.map <| algebraMap K <| splitting_field_aux n f).roots.toFinset :
              Set (splitting_field_aux n f)) =
          ⊤ :=
  Nat.recOn n (fun K _ f hf => Algebra.eq_top_iff.2 fun x => Subalgebra.range_le _ ⟨x, rfl⟩)
    fun n ih K _ f hfn =>
    by
    have hndf : f.nat_degree ≠ 0 := by
      intro h
      rw [h] at hfn
      cases hfn
    have hfn0 : f ≠ 0 := by
      intro h
      rw [h] at hndf
      exact hndf rfl
    have hmf0 : map (algebraMap K (splitting_field_aux n.succ f)) f ≠ 0 := map_ne_zero hfn0
    rw [algebra_map_succ, ← map_map, ← X_sub_C_mul_remove_factor _ hndf, Polynomial.map_mul] at
      hmf0⊢
    rw [roots_mul hmf0, Polynomial.map_sub, map_X, map_C, roots_X_sub_C, Multiset.toFinset_add,
      Finset.coe_union, Multiset.toFinset_singleton, Finset.coe_singleton,
      Algebra.adjoin_union_eq_adjoin_adjoin, ← Set.image_singleton,
      Algebra.adjoin_algebraMap K (AdjoinRoot f.factor) (splitting_field_aux n f.remove_factor),
      AdjoinRoot.adjoinRoot_eq_top, Algebra.map_top,
      IsScalarTower.adjoin_range_toAlgHom K (AdjoinRoot f.factor)
        (splitting_field_aux n f.remove_factor),
      ih _ (nat_degree_remove_factor' hfn), Subalgebra.restrictScalars_top]
#align polynomial.splitting_field_aux.adjoin_roots Polynomial.SplittingFieldAux.adjoin_roots

end SplittingFieldAux

/-- A splitting field of a polynomial. -/
def SplittingField (f : K[X]) :=
  SplittingFieldAux f.natDegree f
#align polynomial.splitting_field Polynomial.SplittingField

namespace SplittingField

variable (f : K[X])

instance : Field (SplittingField f) :=
  SplittingFieldAux.field _

instance inhabited : Inhabited (SplittingField f) :=
  ⟨37⟩
#align polynomial.splitting_field.inhabited Polynomial.SplittingField.inhabited

/-- This should be an instance globally, but it creates diamonds with the `ℕ`, `ℤ`, and `ℚ` algebras
(via their `smul` and `to_fun` fields):

```lean
example :
  (algebra_nat : algebra ℕ (splitting_field f)) = splitting_field.algebra' f :=
rfl  -- fails

example :
  (algebra_int _ : algebra ℤ (splitting_field f)) = splitting_field.algebra' f :=
rfl  -- fails

example [char_zero K] [char_zero (splitting_field f)] :
  (algebra_rat : algebra ℚ (splitting_field f)) = splitting_field.algebra' f :=
rfl  -- fails
```

Until we resolve these diamonds, it's more convenient to only turn this instance on with
`local attribute [instance]` in places where the benefit of having the instance outweighs the cost.

In the meantime, the `splitting_field.algebra` instance below is immune to these particular diamonds
since `K = ℕ` and `K = ℤ` are not possible due to the `field K` assumption. Diamonds in
`algebra ℚ (splitting_field f)` instances are still possible via this instance unfortunately, but
these are less common as they require suitable `char_zero` instances to be present.
-/
instance algebra' {R} [CommSemiring R] [Algebra R K] : Algebra R (SplittingField f) :=
  SplittingFieldAux.algebra _ _
#align polynomial.splitting_field.algebra' Polynomial.SplittingField.algebra'

instance : Algebra K (SplittingField f) :=
  SplittingFieldAux.algebra _ _

protected theorem splits : Splits (algebraMap K (SplittingField f)) f :=
  SplittingFieldAux.splits _ _ rfl
#align polynomial.splitting_field.splits Polynomial.SplittingField.splits

variable [Algebra K L] (hb : Splits (algebraMap K L) f)

/-- Embeds the splitting field into any other field that splits the polynomial. -/
def lift : SplittingField f →ₐ[K] L :=
  { Classical.choose (SplittingFieldAux.exists_lift _ _ _ _ hb) with
    commutes' := fun r =>
      haveI := Classical.choose_spec (splitting_field_aux.exists_lift _ _ rfl _ hb)
      RingHom.ext_iff.1 this r }
#align polynomial.splitting_field.lift Polynomial.SplittingField.lift

theorem adjoin_roots :
    Algebra.adjoin K
        (↑(f.map (algebraMap K <| SplittingField f)).roots.toFinset : Set (SplittingField f)) =
      ⊤ :=
  SplittingFieldAux.adjoin_roots _ _ rfl
#align polynomial.splitting_field.adjoin_roots Polynomial.SplittingField.adjoin_roots

theorem adjoin_rootSet : Algebra.adjoin K (f.rootSet f.SplittingField) = ⊤ :=
  adjoin_roots f
#align polynomial.splitting_field.adjoin_root_set Polynomial.SplittingField.adjoin_rootSet

end SplittingField

variable (K L) [Algebra K L]

/- ./././Mathport/Syntax/Translate/Command.lean:388:30: infer kinds are unsupported in Lean 4: #[`Splits] [] -/
/- ./././Mathport/Syntax/Translate/Command.lean:388:30: infer kinds are unsupported in Lean 4: #[`adjoin_roots] [] -/
/-- Typeclass characterising splitting fields. -/
class IsSplittingField (f : K[X]) : Prop where
  Splits : Splits (algebraMap K L) f
  adjoin_roots : Algebra.adjoin K (↑(f.map (algebraMap K L)).roots.toFinset : Set L) = ⊤
#align polynomial.is_splitting_field Polynomial.IsSplittingField

namespace IsSplittingField

variable {K}

instance splittingField (f : K[X]) : IsSplittingField K (SplittingField f) f :=
  ⟨SplittingField.splits f, SplittingField.adjoin_roots f⟩
#align polynomial.is_splitting_field.splitting_field Polynomial.IsSplittingField.splittingField

section ScalarTower

variable {K L F} [Algebra F K] [Algebra F L] [IsScalarTower F K L]

variable {K}

instance map (f : F[X]) [IsSplittingField F L f] : IsSplittingField K L (f.map <| algebraMap F K) :=
  ⟨by
    rw [splits_map_iff, ← IsScalarTower.algebraMap_eq]
    exact splits L f,
    Subalgebra.restrictScalars_injective F <|
      by
      rw [map_map, ← IsScalarTower.algebraMap_eq, Subalgebra.restrictScalars_top, eq_top_iff, ←
        adjoin_roots L f, Algebra.adjoin_le_iff]
      exact fun x hx => @Algebra.subset_adjoin K _ _ _ _ _ _ hx⟩
#align polynomial.is_splitting_field.map Polynomial.IsSplittingField.map

variable {K} (L)

theorem splits_iff (f : K[X]) [IsSplittingField K L f] :
    Polynomial.Splits (RingHom.id K) f ↔ (⊤ : Subalgebra K L) = ⊥ :=
  ⟨fun h =>
    eq_bot_iff.2 <|
      adjoin_roots L f ▸
        (roots_map (algebraMap K L) h).symm ▸
          Algebra.adjoin_le_iff.2 fun y hy =>
            let ⟨x, hxs, hxy⟩ := Finset.mem_image.1 (by rwa [Multiset.toFinset_map] at hy)
            hxy ▸ SetLike.mem_coe.2 <| Subalgebra.algebraMap_mem _ _,
    fun h =>
    @RingEquiv.toRingHom_refl K _ ▸
      RingEquiv.self_trans_symm (RingEquiv.ofBijective _ <| Algebra.bijective_algebraMap_iff.2 h) ▸
        by
        rw [RingEquiv.toRingHom_trans]
        exact splits_comp_of_splits _ _ (splits L f)⟩
#align polynomial.is_splitting_field.splits_iff Polynomial.IsSplittingField.splits_iff

theorem mul (f g : F[X]) (hf : f ≠ 0) (hg : g ≠ 0) [IsSplittingField F K f]
    [IsSplittingField K L (g.map <| algebraMap F K)] : IsSplittingField F L (f * g) :=
  ⟨(IsScalarTower.algebraMap_eq F K L).symm ▸
      splits_mul _ (splits_comp_of_splits _ _ (splits K f))
        ((splits_map_iff _ _).1 (splits L <| g.map <| algebraMap F K)),
    by
    rw [Polynomial.map_mul,
      roots_mul (mul_ne_zero (map_ne_zero hf : f.map (algebraMap F L) ≠ 0) (map_ne_zero hg)),
      Multiset.toFinset_add, Finset.coe_union, Algebra.adjoin_union_eq_adjoin_adjoin,
      IsScalarTower.algebraMap_eq F K L, ← map_map,
      roots_map (algebraMap K L) ((splits_id_iff_splits <| algebraMap F K).2 <| splits K f),
      Multiset.toFinset_map, Finset.coe_image, Algebra.adjoin_algebraMap, adjoin_roots,
      Algebra.map_top, IsScalarTower.adjoin_range_toAlgHom, ← map_map, adjoin_roots,
      Subalgebra.restrictScalars_top]⟩
#align polynomial.is_splitting_field.mul Polynomial.IsSplittingField.mul

end ScalarTower

/-- Splitting field of `f` embeds into any field that splits `f`. -/
def lift [Algebra K F] (f : K[X]) [IsSplittingField K L f]
    (hf : Polynomial.Splits (algebraMap K F) f) : L →ₐ[K] F :=
  if hf0 : f = 0 then
    (Algebra.ofId K F).comp <|
      (Algebra.botEquiv K L : (⊥ : Subalgebra K L) →ₐ[K] K).comp <|
        by
        rw [← (splits_iff L f).1 (show f.splits (RingHom.id K) from hf0.symm ▸ splits_zero _)]
        exact Algebra.toTop
  else
    AlgHom.comp
      (by
        rw [← adjoin_roots L f]
        exact
          Classical.choice
            (lift_of_splits _ fun y hy =>
              have : aeval y f = 0 :=
                (eval₂_eq_eval_map _).trans <|
                  (mem_roots <| map_ne_zero hf0).1 (multiset.mem_to_finset.mp hy)
              ⟨isAlgebraic_iff_isIntegral.1 ⟨f, hf0, this⟩,
                splits_of_splits_of_dvd _ hf0 hf <| minpoly.dvd _ _ this⟩))
      Algebra.toTop
#align polynomial.is_splitting_field.lift Polynomial.IsSplittingField.lift

theorem finiteDimensional (f : K[X]) [IsSplittingField K L f] : FiniteDimensional K L :=
  ⟨@Algebra.top_toSubmodule K L _ _ _ ▸
      adjoin_roots L f ▸
        fg_adjoin_of_finite (Finset.finite_toSet _) fun y hy =>
          if hf : f = 0 then by
            rw [hf, Polynomial.map_zero, roots_zero] at hy
            cases hy
          else
            isAlgebraic_iff_isIntegral.1
              ⟨f, hf,
                (eval₂_eq_eval_map _).trans <|
                  (mem_roots <| map_ne_zero hf).1 (Multiset.mem_toFinset.mp hy)⟩⟩
#align polynomial.is_splitting_field.finite_dimensional Polynomial.IsSplittingField.finiteDimensional

instance (f : K[X]) : FiniteDimensional K f.SplittingField :=
  finiteDimensional f.SplittingField f

/-- Any splitting field is isomorphic to `splitting_field f`. -/
def algEquiv (f : K[X]) [IsSplittingField K L f] : L ≃ₐ[K] SplittingField f :=
  by
  refine'
    AlgEquiv.ofBijective (lift L f <| splits (splitting_field f) f)
      ⟨RingHom.injective (lift L f <| splits (splitting_field f) f).toRingHom, _⟩
  haveI := FiniteDimensional (splitting_field f) f
  haveI := FiniteDimensional L f
  have : FiniteDimensional.finrank K L = FiniteDimensional.finrank K (splitting_field f) :=
    le_antisymm
      (LinearMap.finrank_le_finrank_of_injective
        (show Function.Injective (lift L f <| splits (splitting_field f) f).toLinearMap from
          RingHom.injective (lift L f <| splits (splitting_field f) f : L →+* f.splitting_field)))
      (LinearMap.finrank_le_finrank_of_injective
        (show Function.Injective (lift (splitting_field f) f <| splits L f).toLinearMap from
          RingHom.injective (lift (splitting_field f) f <| splits L f : f.splitting_field →+* L)))
  change Function.Surjective (lift L f <| splits (splitting_field f) f).toLinearMap
  refine' (LinearMap.injective_iff_surjective_of_finrank_eq_finrank this).1 _
  exact RingHom.injective (lift L f <| splits (splitting_field f) f : L →+* f.splitting_field)
#align polynomial.is_splitting_field.alg_equiv Polynomial.IsSplittingField.algEquiv

theorem of_algEquiv [Algebra K F] (p : K[X]) (f : F ≃ₐ[K] L) [IsSplittingField K F p] :
    IsSplittingField K L p := by
  constructor
  · rw [← f.to_alg_hom.comp_algebra_map]
    exact splits_comp_of_splits _ _ (splits F p)
  ·
    rw [← (Algebra.range_top_iff_surjective f.to_alg_hom).mpr f.surjective, ← root_set,
      adjoin_root_set_eq_range (splits F p), root_set, adjoin_roots F p]
#align polynomial.is_splitting_field.of_alg_equiv Polynomial.IsSplittingField.of_algEquiv

end IsSplittingField

end SplittingField

end Polynomial

namespace IntermediateField

open Polynomial

variable [Field K] [Field L] [Algebra K L] {p : K[X]}

theorem splits_of_splits {F : IntermediateField K L} (h : p.Splits (algebraMap K L))
    (hF : ∀ x ∈ p.rootSet L, x ∈ F) : p.Splits (algebraMap K F) :=
  by
  simp_rw [root_set, Finset.mem_coe, Multiset.mem_toFinset] at hF
  rw [splits_iff_exists_multiset]
  refine' ⟨Multiset.pmap Subtype.mk _ hF, map_injective _ (algebraMap F L).Injective _⟩
  conv_lhs =>
    rw [Polynomial.map_map, ← IsScalarTower.algebraMap_eq, eq_prod_roots_of_splits h, ←
      Multiset.pmap_eq_map _ _ _ hF]
  simp_rw [Polynomial.map_mul, Polynomial.map_multiset_prod, Multiset.map_pmap, Polynomial.map_sub,
    map_C, map_X]
  rfl
#align intermediate_field.splits_of_splits IntermediateField.splits_of_splits

end IntermediateField


/-
Copyright (c) 2020 David Wärn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: David Wärn
-/
import order.ideal
import data.finset.lattice

/-!
# The back and forth method and countable dense linear orders

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

## Results

Suppose `α β` are linear orders, with `α` countable and `β` dense, nontrivial. Then there is an
order embedding `α ↪ β`. If in addition `α` is dense, nonempty, without endpoints and `β` is
countable, without endpoints, then we can upgrade this to an order isomorphism `α ≃ β`.

The idea for both results is to consider "partial isomorphisms", which identify a finite subset of
`α` with a finite subset of `β`, and prove that for any such partial isomorphism `f` and `a : α`, we
can extend `f` to include `a` in its domain.

## References

https://en.wikipedia.org/wiki/Back-and-forth_method

## Tags

back and forth, dense, countable, order
-/

noncomputable theory
open_locale classical

namespace order

/-- Suppose `α` is a nonempty dense linear order without endpoints, and
    suppose `lo`, `hi`, are finite subssets with all of `lo` strictly
    before `hi`. Then there is an element of `α` strictly between `lo`
    and `hi`. -/
lemma exists_between_finsets {α : Type*} [linear_order α]
  [densely_ordered α] [no_min_order α] [no_max_order α] [nonem : nonempty α]
  (lo hi : finset α) (lo_lt_hi : ∀ (x ∈ lo) (y ∈ hi), x < y) :
  ∃ m : α, (∀ x ∈ lo, x < m) ∧ (∀ y ∈ hi, m < y) :=
if nlo : lo.nonempty then
  if nhi : hi.nonempty then -- both sets are nonempty, use densely_ordered
    exists.elim (exists_between (lo_lt_hi _ (finset.max'_mem _ nlo) _ (finset.min'_mem _ nhi)))
      (λ m hm, ⟨m, λ x hx, lt_of_le_of_lt (finset.le_max' lo x hx) hm.1,
                   λ y hy, lt_of_lt_of_le hm.2 (finset.min'_le hi y hy)⟩)
  else -- upper set is empty, use `no_max_order`
    exists.elim (exists_gt (finset.max' lo nlo)) (λ m hm,
    ⟨m, λ x hx, lt_of_le_of_lt (finset.le_max' lo x hx) hm,
        λ y hy, (nhi ⟨y, hy⟩).elim⟩)
else
  if nhi : hi.nonempty then -- lower set is empty, use `no_min_order`
    exists.elim (exists_lt (finset.min' hi nhi)) (λ m hm,
    ⟨m, λ x hx, (nlo ⟨x, hx⟩).elim,
        λ y hy, lt_of_lt_of_le hm (finset.min'_le hi y hy)⟩)
  else -- both sets are empty, use nonempty
    nonem.elim (λ m,
    ⟨m, λ x hx, (nlo ⟨x, hx⟩).elim,
        λ y hy, (nhi ⟨y, hy⟩).elim⟩)

variables (α β : Type*) [linear_order α] [linear_order β]

/-- The type of partial order isomorphisms between `α` and `β` defined on finite subsets.
    A partial order isomorphism is encoded as a finite subset of `α × β`, consisting
    of pairs which should be identified. -/
def partial_iso : Type* :=
{ f : finset (α × β) // ∀ (p q ∈ f),
  cmp (prod.fst p) (prod.fst q) = cmp (prod.snd p) (prod.snd q) }

namespace partial_iso

instance : inhabited (partial_iso α β) := ⟨⟨∅, λ p h q, h.elim⟩⟩
instance : preorder (partial_iso α β) := subtype.preorder _

variables {α β}

/-- For each `a`, we can find a `b` in the codomain, such that `a`'s relation to
the domain of `f` is `b`'s relation to the image of `f`.

Thus, if `a` is not already in `f`, then we can extend `f` by sending `a` to `b`.
-/
lemma exists_across [densely_ordered β] [no_min_order β] [no_max_order β] [nonempty β]
  (f : partial_iso α β) (a : α) :
  ∃ b : β, ∀ (p ∈ f.val), cmp (prod.fst p) a = cmp (prod.snd p) b :=
begin
  by_cases h : ∃ b, (a, b) ∈ f.val,
  { cases h with b hb, exact ⟨b, λ p hp, f.prop _ hp _ hb⟩, },
  have : ∀ (x ∈ (f.val.filter (λ (p : α × β), p.fst < a)).image prod.snd)
           (y ∈ (f.val.filter (λ (p : α × β), a < p.fst)).image prod.snd),
    x < y,
  { intros x hx y hy,
    rw finset.mem_image at hx hy,
    rcases hx with ⟨p, hp1, rfl⟩,
    rcases hy with ⟨q, hq1, rfl⟩,
    rw finset.mem_filter at hp1 hq1,
    rw ←lt_iff_lt_of_cmp_eq_cmp (f.prop _ hp1.1 _ hq1.1),
    exact lt_trans hp1.right hq1.right, },
  cases exists_between_finsets _ _ this with b hb,
  use b,
  rintros ⟨p1, p2⟩ hp,
  have : p1 ≠ a := λ he, h ⟨p2, he ▸ hp⟩,
  cases lt_or_gt_of_ne this with hl hr,
  { have : p1 < a ∧ p2 < b := ⟨hl, hb.1 _ (finset.mem_image.mpr ⟨(p1, p2),
                        finset.mem_filter.mpr ⟨hp, hl⟩, rfl⟩)⟩,
    rw [←cmp_eq_lt_iff, ←cmp_eq_lt_iff] at this, cc, },
  { have : a < p1 ∧ b < p2 := ⟨hr, hb.2 _ (finset.mem_image.mpr ⟨(p1, p2),
                        finset.mem_filter.mpr ⟨hp, hr⟩, rfl⟩)⟩,
    rw [←cmp_eq_gt_iff, ←cmp_eq_gt_iff] at this, cc, },
end

/-- A partial isomorphism between `α` and `β` is also a partial isomorphism between `β` and `α`. -/
protected def comm : partial_iso α β → partial_iso β α :=
subtype.map (finset.image (equiv.prod_comm _ _)) $ λ f hf p hp q hq,
  eq.symm $ hf ((equiv.prod_comm α β).symm p)
(by { rw [←finset.mem_coe, finset.coe_image, equiv.image_eq_preimage] at hp, rwa ←finset.mem_coe })
 ((equiv.prod_comm α β).symm q)
(by { rw [←finset.mem_coe, finset.coe_image, equiv.image_eq_preimage] at hq, rwa ←finset.mem_coe })

variable (β)
/-- The set of partial isomorphisms defined at `a : α`, together with a proof that any
    partial isomorphism can be extended to one defined at `a`. -/
def defined_at_left [densely_ordered β] [no_min_order β] [no_max_order β] [nonempty β]
  (a : α) : cofinal (partial_iso α β) :=
{ carrier := λ f, ∃ b : β, (a, b) ∈ f.val,
  mem_gt := λ f, begin
    cases exists_across f a with b a_b,
    refine ⟨⟨insert (a, b) f.val, λ p hp q hq, _⟩, ⟨b, finset.mem_insert_self _ _⟩,
      finset.subset_insert _ _⟩,
    rw finset.mem_insert at hp hq,
    rcases hp with rfl | pf;
    rcases hq with rfl | qf,
    { simp only [cmp_self_eq_eq] },
    { rw cmp_eq_cmp_symm, exact a_b _ qf },
    { exact a_b _ pf },
    { exact f.prop _ pf _ qf },
  end }

variables (α) {β}
/-- The set of partial isomorphisms defined at `b : β`, together with a proof that any
    partial isomorphism can be extended to include `b`. We prove this by symmetry. -/
def defined_at_right [densely_ordered α] [no_min_order α] [no_max_order α] [nonempty α]
  (b : β) : cofinal (partial_iso α β) :=
{ carrier := λ f, ∃ a, (a, b) ∈ f.val,
  mem_gt := λ f, begin
    rcases (defined_at_left α b).mem_gt f.comm with ⟨f', ⟨a, ha⟩, hl⟩,
    refine ⟨f'.comm, ⟨a, _⟩, _⟩,
    { change (a, b) ∈ f'.val.image _,
      rwa [←finset.mem_coe, finset.coe_image, equiv.image_eq_preimage] },
    { change _ ⊆ f'.val.image _,
      rw [←finset.coe_subset, finset.coe_image, ← equiv.subset_image],
      change f.val.image _ ⊆ _ at hl,
      rwa [←finset.coe_subset, finset.coe_image] at hl }
  end }

variable {α}

/-- Given an ideal which intersects `defined_at_left β a`, pick `b : β` such that
    some partial function in the ideal maps `a` to `b`. -/
def fun_of_ideal [densely_ordered β] [no_min_order β] [no_max_order β] [nonempty β]
  (a : α) (I : ideal (partial_iso α β)) :
  (∃ f, f ∈ defined_at_left β a ∧ f ∈ I) → { b // ∃ f ∈ I, (a, b) ∈ subtype.val f } :=
classical.indefinite_description _ ∘ (λ ⟨f, ⟨b, hb⟩, hf⟩, ⟨b, f, hf, hb⟩)

/-- Given an ideal which intersects `defined_at_right α b`, pick `a : α` such that
    some partial function in the ideal maps `a` to `b`. -/
def inv_of_ideal [densely_ordered α] [no_min_order α] [no_max_order α] [nonempty α]
  (b : β) (I : ideal (partial_iso α β)) :
  (∃ f, f ∈ defined_at_right α b ∧ f ∈ I) → { a // ∃ f ∈ I, (a, b) ∈ subtype.val f } :=
classical.indefinite_description _ ∘ (λ ⟨f, ⟨a, ha⟩, hf⟩, ⟨a, f, hf, ha⟩)

end partial_iso
open partial_iso

variables (α β)

/-- Any countable linear order embeds in any nontrivial dense linear order. -/
theorem embedding_from_countable_to_dense [encodable α] [densely_ordered β] [nontrivial β] :
  nonempty (α ↪o β) :=
begin
  rcases exists_pair_lt β with ⟨x, y, hxy⟩,
  cases exists_between hxy with a ha,
  haveI : nonempty (set.Ioo x y) := ⟨⟨a, ha⟩⟩,
  let our_ideal : ideal (partial_iso α _) :=
    ideal_of_cofinals default (defined_at_left (set.Ioo x y)),
  let F := λ a, fun_of_ideal a our_ideal (cofinal_meets_ideal_of_cofinals _ _ a),
  refine ⟨rel_embedding.trans (order_embedding.of_strict_mono (λ a, (F a).val) (λ a₁ a₂, _))
    (order_embedding.subtype _)⟩,
  rcases (F a₁).prop with ⟨f, hf, ha₁⟩,
  rcases (F a₂).prop with ⟨g, hg, ha₂⟩,
  rcases our_ideal.directed _ hf _ hg with ⟨m, hm, fm, gm⟩,
  exact (lt_iff_lt_of_cmp_eq_cmp $ m.prop (a₁, _) (fm ha₁) (a₂, _) (gm ha₂)).mp
end

/-- Any two countable dense, nonempty linear orders without endpoints are order isomorphic. -/
theorem iso_of_countable_dense
  [encodable α] [densely_ordered α] [no_min_order α] [no_max_order α] [nonempty α]
  [encodable β] [densely_ordered β] [no_min_order β] [no_max_order β] [nonempty β] :
  nonempty (α ≃o β) :=
let to_cofinal : α ⊕ β → cofinal (partial_iso α β) :=
  λ p, sum.rec_on p (defined_at_left β) (defined_at_right α) in
let our_ideal : ideal (partial_iso α β) := ideal_of_cofinals default to_cofinal in
let F := λ a, fun_of_ideal a our_ideal (cofinal_meets_ideal_of_cofinals _ to_cofinal (sum.inl a)) in
let G := λ b, inv_of_ideal b our_ideal (cofinal_meets_ideal_of_cofinals _ to_cofinal (sum.inr b)) in
⟨order_iso.of_cmp_eq_cmp (λ a, (F a).val) (λ b, (G b).val) $ λ a b,
begin
  rcases (F a).prop with ⟨f, hf, ha⟩,
  rcases (G b).prop with ⟨g, hg, hb⟩,
  rcases our_ideal.directed _ hf _ hg with ⟨m, hm, fm, gm⟩,
  exact m.prop (a, _) (fm ha) (_, b) (gm hb)
end⟩

end order