import data.finset
import data.finsupp
import algebra.big_operators.order

namespace finset

section to_list

variables {α : Type*} {β : Type*} {γ : Type*}
/-- Produce a list of the elements in the finite set using choice. -/
@[reducible] noncomputable def to_list (s : finset α) : list α := s.1.to_list

lemma nodup_to_list (s : finset α) : s.to_list.nodup :=
by { rw [to_list, ←multiset.coe_nodup, multiset.coe_to_list], exact s.nodup }

@[simp] lemma mem_to_list {a : α} (s : finset α) : a ∈ s.to_list ↔ a ∈ s :=
by { rw [to_list, ←multiset.mem_coe, multiset.coe_to_list], exact iff.rfl }

@[simp] lemma length_to_list (s : finset α) : s.to_list.length = s.card :=
by { rw [to_list, ←multiset.coe_card, multiset.coe_to_list], refl }

@[simp] lemma to_list_empty : (∅ : finset α).to_list = [] :=
by simp [to_list]

@[simp, norm_cast]
lemma coe_to_list (s : finset α) : (s.to_list : multiset α) = s.val :=
by { classical, ext, simp }

@[simp] lemma to_list_to_finset [decidable_eq α] (s : finset α) : s.to_list.to_finset = s :=
by { ext, simp }

@[to_additive] lemma prod_to_list [comm_monoid β]
  (s : finset α) (f : α → β) :
  (list.map f s.to_list).prod = finset.prod s f :=
begin
  delta finset.prod,
  rw [← multiset.coe_prod, ← multiset.coe_map, finset.coe_to_list],
end

lemma to_list_cons {a : α} {s : finset α} (h : a ∉ s) : (cons a s h).to_list ~ a :: s.to_list :=
(list.perm_ext (nodup_to_list _) (by simp [h, nodup_to_list s])).2 $
  λ x, by simp only [list.mem_cons_iff, finset.mem_to_list, finset.mem_cons]

lemma to_list_insert [decidable_eq α] {a : α} {s : finset α} (h : a ∉ s) :
  (insert a s).to_list ~ a :: s.to_list :=
cons_eq_insert _ _ h ▸ to_list_cons _

end to_list

lemma filter_mem_set_of_subset_set {α} {s : set α} [decidable_pred (λ x, x ∈ s)]
  {fs : finset α} (h : ↑fs ⊆ s) :
  filter (λ x, x ∈ s) fs = fs :=
begin
  ext x,
  split,
  { apply filter_subset },
  { intro hmem, rw mem_filter, exact ⟨ hmem , h hmem ⟩ },
end

end finset

namespace finsupp

lemma le_sum {σ : Type*}
  (f : σ →₀ ℕ) (x : σ) :
  f x ≤ f.support.sum f :=
dite (f x = 0)
(λ h, by simp [h])
(λ h, finset.single_le_sum (λ s hs, nat.zero_le _) (finsupp.mem_support_iff.2 h))

end finsupp


/-
Copyright (c) 2019 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import analysis.calculus.deriv
import topology.algebra.ordered.extend_from
import topology.algebra.polynomial
import topology.local_extr
import data.polynomial.field_division

/-!
# Local extrema of smooth functions

## Main definitions

In a real normed space `E` we define `pos_tangent_cone_at (s : set E) (x : E)`.
This would be the same as `tangent_cone_at ℝ≥0 s x` if we had a theory of normed semifields.
This set is used in the proof of Fermat's Theorem (see below), and can be used to formalize
[Lagrange multipliers](https://en.wikipedia.org/wiki/Lagrange_multiplier) and/or
[Karush–Kuhn–Tucker conditions](https://en.wikipedia.org/wiki/Karush–Kuhn–Tucker_conditions).

## Main statements

For each theorem name listed below,
we also prove similar theorems for `min`, `extr` (if applicable)`,
and `(f)deriv` instead of `has_fderiv`.

* `is_local_max_on.has_fderiv_within_at_nonpos` : `f' y ≤ 0` whenever `a` is a local maximum
  of `f` on `s`, `f` has derivative `f'` at `a` within `s`, and `y` belongs to the positive tangent
  cone of `s` at `a`.

* `is_local_max_on.has_fderiv_within_at_eq_zero` : In the settings of the previous theorem, if both
  `y` and `-y` belong to the positive tangent cone, then `f' y = 0`.

* `is_local_max.has_fderiv_at_eq_zero` :
  [Fermat's Theorem](https://en.wikipedia.org/wiki/Fermat's_theorem_(stationary_points)),
  the derivative of a differentiable function at a local extremum point equals zero.

* `exists_has_deriv_at_eq_zero` :
  [Rolle's Theorem](https://en.wikipedia.org/wiki/Rolle's_theorem): given a function `f` continuous
  on `[a, b]` and differentiable on `(a, b)`, there exists `c ∈ (a, b)` such that `f' c = 0`.

## Implementation notes

For each mathematical fact we prove several versions of its formalization:

* for maxima and minima;
* using `has_fderiv*`/`has_deriv*` or `fderiv*`/`deriv*`.

For the `fderiv*`/`deriv*` versions we omit the differentiability condition whenever it is possible
due to the fact that `fderiv` and `deriv` are defined to be zero for non-differentiable functions.

## References

* [Fermat's Theorem](https://en.wikipedia.org/wiki/Fermat's_theorem_(stationary_points));
* [Rolle's Theorem](https://en.wikipedia.org/wiki/Rolle's_theorem);
* [Tangent cone](https://en.wikipedia.org/wiki/Tangent_cone);

## Tags

local extremum, Fermat's Theorem, Rolle's Theorem
-/

universes u v

open filter set
open_locale topological_space classical

section module

variables {E : Type u} [normed_group E] [normed_space ℝ E] {f : E → ℝ} {a : E}
  {f' : E →L[ℝ] ℝ}

/-- "Positive" tangent cone to `s` at `x`; the only difference from `tangent_cone_at`
is that we require `c n → ∞` instead of `∥c n∥ → ∞`. One can think about `pos_tangent_cone_at`
as `tangent_cone_at nnreal` but we have no theory of normed semifields yet. -/
def pos_tangent_cone_at (s : set E) (x : E) : set E :=
{y : E | ∃(c : ℕ → ℝ) (d : ℕ → E), (∀ᶠ n in at_top, x + d n ∈ s) ∧
  (tendsto c at_top at_top) ∧ (tendsto (λn, c n • d n) at_top (𝓝 y))}

lemma pos_tangent_cone_at_mono : monotone (λ s, pos_tangent_cone_at s a) :=
begin
  rintros s t hst y ⟨c, d, hd, hc, hcd⟩,
  exact ⟨c, d, mem_of_superset hd $ λ h hn, hst hn, hc, hcd⟩
end

lemma mem_pos_tangent_cone_at_of_segment_subset {s : set E} {x y : E} (h : segment ℝ x y ⊆ s) :
  y - x ∈ pos_tangent_cone_at s x :=
begin
  let c := λn:ℕ, (2:ℝ)^n,
  let d := λn:ℕ, (c n)⁻¹ • (y-x),
  refine ⟨c, d, filter.univ_mem' (λn, h _),
    tendsto_pow_at_top_at_top_of_one_lt one_lt_two, _⟩,
  show x + d n ∈ segment ℝ x y,
  { rw segment_eq_image',
    refine ⟨(c n)⁻¹, ⟨_, _⟩, rfl⟩,
    exacts [inv_nonneg.2 (pow_nonneg zero_le_two _),
      inv_le_one (one_le_pow_of_one_le one_le_two _)] },
  show tendsto (λ n, c n • d n) at_top (𝓝 (y - x)),
  { convert tendsto_const_nhds, ext n,
    simp only [d, smul_smul],
    rw [mul_inv_cancel, one_smul],
    exact pow_ne_zero _ two_ne_zero }
end

lemma mem_pos_tangent_cone_at_of_segment_subset' {s : set E} {x y : E}
  (h : segment ℝ x (x + y) ⊆ s) :
  y ∈ pos_tangent_cone_at s x :=
by simpa only [add_sub_cancel'] using mem_pos_tangent_cone_at_of_segment_subset h

lemma pos_tangent_cone_at_univ : pos_tangent_cone_at univ a = univ :=
eq_univ_of_forall $ λ x, mem_pos_tangent_cone_at_of_segment_subset' (subset_univ _)

/-- If `f` has a local max on `s` at `a`, `f'` is the derivative of `f` at `a` within `s`, and
`y` belongs to the positive tangent cone of `s` at `a`, then `f' y ≤ 0`. -/
lemma is_local_max_on.has_fderiv_within_at_nonpos {s : set E} (h : is_local_max_on f s a)
  (hf : has_fderiv_within_at f f' s a) {y} (hy : y ∈ pos_tangent_cone_at s a) :
  f' y ≤ 0 :=
begin
  rcases hy with ⟨c, d, hd, hc, hcd⟩,
  have hc' : tendsto (λ n, ∥c n∥) at_top at_top,
    from tendsto_at_top_mono (λ n, le_abs_self _) hc,
  refine le_of_tendsto (hf.lim at_top hd hc' hcd) _,
  replace hd : tendsto (λ n, a + d n) at_top (𝓝[s] (a + 0)),
  from tendsto_inf.2 ⟨tendsto_const_nhds.add (tangent_cone_at.lim_zero _ hc' hcd),
    by rwa tendsto_principal⟩,
  rw [add_zero] at hd,
  replace h : ∀ᶠ n in at_top, f (a + d n) ≤ f a, from mem_map.1 (hd h),
  replace hc : ∀ᶠ n in at_top, 0 ≤ c n, from mem_map.1 (hc (mem_at_top (0:ℝ))),
  filter_upwards [h, hc],
  simp only [smul_eq_mul, mem_preimage, subset_def],
  assume n hnf hn,
  exact mul_nonpos_of_nonneg_of_nonpos hn (sub_nonpos.2 hnf)
end

/-- If `f` has a local max on `s` at `a` and `y` belongs to the positive tangent cone
of `s` at `a`, then `f' y ≤ 0`. -/
lemma is_local_max_on.fderiv_within_nonpos {s : set E} (h : is_local_max_on f s a)
  {y} (hy : y ∈ pos_tangent_cone_at s a) :
  (fderiv_within ℝ f s a : E → ℝ) y ≤ 0 :=
if hf : differentiable_within_at ℝ f s a
then h.has_fderiv_within_at_nonpos hf.has_fderiv_within_at hy
else by { rw fderiv_within_zero_of_not_differentiable_within_at hf, refl }

/-- If `f` has a local max on `s` at `a`, `f'` is a derivative of `f` at `a` within `s`, and
both `y` and `-y` belong to the positive tangent cone of `s` at `a`, then `f' y ≤ 0`. -/
lemma is_local_max_on.has_fderiv_within_at_eq_zero {s : set E} (h : is_local_max_on f s a)
  (hf : has_fderiv_within_at f f' s a) {y} (hy : y ∈ pos_tangent_cone_at s a)
  (hy' : -y ∈ pos_tangent_cone_at s a) :
  f' y = 0 :=
le_antisymm (h.has_fderiv_within_at_nonpos hf hy) $
  by simpa using h.has_fderiv_within_at_nonpos hf hy'

/-- If `f` has a local max on `s` at `a` and both `y` and `-y` belong to the positive tangent cone
of `s` at `a`, then `f' y = 0`. -/
lemma is_local_max_on.fderiv_within_eq_zero {s : set E} (h : is_local_max_on f s a)
  {y} (hy : y ∈ pos_tangent_cone_at s a) (hy' : -y ∈ pos_tangent_cone_at s a) :
  (fderiv_within ℝ f s a : E → ℝ) y = 0 :=
if hf : differentiable_within_at ℝ f s a
then h.has_fderiv_within_at_eq_zero hf.has_fderiv_within_at hy hy'
else by { rw fderiv_within_zero_of_not_differentiable_within_at hf, refl }

/-- If `f` has a local min on `s` at `a`, `f'` is the derivative of `f` at `a` within `s`, and
`y` belongs to the positive tangent cone of `s` at `a`, then `0 ≤ f' y`. -/
lemma is_local_min_on.has_fderiv_within_at_nonneg {s : set E} (h : is_local_min_on f s a)
  (hf : has_fderiv_within_at f f' s a) {y} (hy : y ∈ pos_tangent_cone_at s a) :
  0 ≤ f' y :=
by simpa using h.neg.has_fderiv_within_at_nonpos hf.neg hy

/-- If `f` has a local min on `s` at `a` and `y` belongs to the positive tangent cone
of `s` at `a`, then `0 ≤ f' y`. -/
lemma is_local_min_on.fderiv_within_nonneg {s : set E} (h : is_local_min_on f s a)
  {y} (hy : y ∈ pos_tangent_cone_at s a) :
  (0:ℝ) ≤ (fderiv_within ℝ f s a : E → ℝ) y :=
if hf : differentiable_within_at ℝ f s a
then h.has_fderiv_within_at_nonneg hf.has_fderiv_within_at hy
else by { rw [fderiv_within_zero_of_not_differentiable_within_at hf], refl }

/-- If `f` has a local max on `s` at `a`, `f'` is a derivative of `f` at `a` within `s`, and
both `y` and `-y` belong to the positive tangent cone of `s` at `a`, then `f' y ≤ 0`. -/
lemma is_local_min_on.has_fderiv_within_at_eq_zero {s : set E} (h : is_local_min_on f s a)
  (hf : has_fderiv_within_at f f' s a) {y} (hy : y ∈ pos_tangent_cone_at s a)
  (hy' : -y ∈ pos_tangent_cone_at s a) :
  f' y = 0 :=
by simpa using h.neg.has_fderiv_within_at_eq_zero hf.neg hy hy'

/-- If `f` has a local min on `s` at `a` and both `y` and `-y` belong to the positive tangent cone
of `s` at `a`, then `f' y = 0`. -/
lemma is_local_min_on.fderiv_within_eq_zero {s : set E} (h : is_local_min_on f s a)
  {y} (hy : y ∈ pos_tangent_cone_at s a) (hy' : -y ∈ pos_tangent_cone_at s a) :
  (fderiv_within ℝ f s a : E → ℝ) y = 0 :=
if hf : differentiable_within_at ℝ f s a
then h.has_fderiv_within_at_eq_zero hf.has_fderiv_within_at hy hy'
else by { rw fderiv_within_zero_of_not_differentiable_within_at hf, refl }

/-- **Fermat's Theorem**: the derivative of a function at a local minimum equals zero. -/
lemma is_local_min.has_fderiv_at_eq_zero (h : is_local_min f a) (hf : has_fderiv_at f f' a) :
  f' = 0 :=
begin
  ext y,
  apply (h.on univ).has_fderiv_within_at_eq_zero hf.has_fderiv_within_at;
    rw pos_tangent_cone_at_univ; apply mem_univ
end

/-- **Fermat's Theorem**: the derivative of a function at a local minimum equals zero. -/
lemma is_local_min.fderiv_eq_zero (h : is_local_min f a) : fderiv ℝ f a = 0 :=
if hf : differentiable_at ℝ f a then h.has_fderiv_at_eq_zero hf.has_fderiv_at
else fderiv_zero_of_not_differentiable_at hf

/-- **Fermat's Theorem**: the derivative of a function at a local maximum equals zero. -/
lemma is_local_max.has_fderiv_at_eq_zero (h : is_local_max f a) (hf : has_fderiv_at f f' a) :
  f' = 0 :=
neg_eq_zero.1 $ h.neg.has_fderiv_at_eq_zero hf.neg

/-- **Fermat's Theorem**: the derivative of a function at a local maximum equals zero. -/
lemma is_local_max.fderiv_eq_zero (h : is_local_max f a) : fderiv ℝ f a = 0 :=
if hf : differentiable_at ℝ f a then h.has_fderiv_at_eq_zero hf.has_fderiv_at
else fderiv_zero_of_not_differentiable_at hf

/-- **Fermat's Theorem**: the derivative of a function at a local extremum equals zero. -/
lemma is_local_extr.has_fderiv_at_eq_zero (h : is_local_extr f a) :
  has_fderiv_at f f' a → f' = 0 :=
h.elim is_local_min.has_fderiv_at_eq_zero is_local_max.has_fderiv_at_eq_zero

/-- **Fermat's Theorem**: the derivative of a function at a local extremum equals zero. -/
lemma is_local_extr.fderiv_eq_zero (h : is_local_extr f a) : fderiv ℝ f a = 0 :=
h.elim is_local_min.fderiv_eq_zero is_local_max.fderiv_eq_zero

end module

section real

variables {f : ℝ → ℝ} {f' : ℝ} {a b : ℝ}

/-- **Fermat's Theorem**: the derivative of a function at a local minimum equals zero. -/
lemma is_local_min.has_deriv_at_eq_zero (h : is_local_min f a) (hf : has_deriv_at f f' a) :
  f' = 0 :=
by simpa using continuous_linear_map.ext_iff.1
  (h.has_fderiv_at_eq_zero (has_deriv_at_iff_has_fderiv_at.1 hf)) 1

/-- **Fermat's Theorem**: the derivative of a function at a local minimum equals zero. -/
lemma is_local_min.deriv_eq_zero (h : is_local_min f a) : deriv f a = 0 :=
if hf : differentiable_at ℝ f a then h.has_deriv_at_eq_zero hf.has_deriv_at
else deriv_zero_of_not_differentiable_at hf

/-- **Fermat's Theorem**: the derivative of a function at a local maximum equals zero. -/
lemma is_local_max.has_deriv_at_eq_zero (h : is_local_max f a) (hf : has_deriv_at f f' a) :
  f' = 0 :=
neg_eq_zero.1 $ h.neg.has_deriv_at_eq_zero hf.neg

/-- **Fermat's Theorem**: the derivative of a function at a local maximum equals zero. -/
lemma is_local_max.deriv_eq_zero (h : is_local_max f a) : deriv f a = 0 :=
if hf : differentiable_at ℝ f a then h.has_deriv_at_eq_zero hf.has_deriv_at
else deriv_zero_of_not_differentiable_at hf

/-- **Fermat's Theorem**: the derivative of a function at a local extremum equals zero. -/
lemma is_local_extr.has_deriv_at_eq_zero (h : is_local_extr f a) :
  has_deriv_at f f' a → f' = 0 :=
h.elim is_local_min.has_deriv_at_eq_zero is_local_max.has_deriv_at_eq_zero

/-- **Fermat's Theorem**: the derivative of a function at a local extremum equals zero. -/
lemma is_local_extr.deriv_eq_zero (h : is_local_extr f a) : deriv f a = 0 :=
h.elim is_local_min.deriv_eq_zero is_local_max.deriv_eq_zero

end real

section Rolle

variables (f f' : ℝ → ℝ) {a b : ℝ}

/-- A continuous function on a closed interval with `f a = f b` takes either its maximum
or its minimum value at a point in the interior of the interval. -/
lemma exists_Ioo_extr_on_Icc (hab : a < b) (hfc : continuous_on f (Icc a b)) (hfI : f a = f b) :
  ∃ c ∈ Ioo a b, is_extr_on f (Icc a b) c :=
begin
  have ne : (Icc a b).nonempty, from nonempty_Icc.2 (le_of_lt hab),
  -- Consider absolute min and max points
  obtain ⟨c, cmem, cle⟩ : ∃ c ∈ Icc a b, ∀ x ∈ Icc a b, f c ≤ f x,
    from is_compact_Icc.exists_forall_le ne hfc,
  obtain ⟨C, Cmem, Cge⟩ : ∃ C ∈ Icc a b, ∀ x ∈ Icc a b, f x ≤ f C,
    from is_compact_Icc.exists_forall_ge ne hfc,
  by_cases hc : f c = f a,
  { by_cases hC : f C = f a,
    { have : ∀ x ∈ Icc a b, f x = f a,
        from λ x hx, le_antisymm (hC ▸ Cge x hx) (hc ▸ cle x hx),
      -- `f` is a constant, so we can take any point in `Ioo a b`
      rcases exists_between hab with ⟨c', hc'⟩,
      refine ⟨c', hc', or.inl _⟩,
      assume x hx,
      rw [mem_set_of_eq, this x hx, ← hC],
      exact Cge c' ⟨le_of_lt hc'.1, le_of_lt hc'.2⟩ },
    { refine ⟨C, ⟨lt_of_le_of_ne Cmem.1 $ mt _ hC, lt_of_le_of_ne Cmem.2 $ mt _ hC⟩, or.inr Cge⟩,
      exacts [λ h, by rw h, λ h, by rw [h, hfI]] } },
  { refine ⟨c, ⟨lt_of_le_of_ne cmem.1 $ mt _ hc, lt_of_le_of_ne cmem.2 $ mt _ hc⟩, or.inl cle⟩,
      exacts [λ h, by rw h, λ h, by rw [h, hfI]] }
end

/-- A continuous function on a closed interval with `f a = f b` has a local extremum at some
point of the corresponding open interval. -/
lemma exists_local_extr_Ioo (hab : a < b) (hfc : continuous_on f (Icc a b)) (hfI : f a = f b) :
  ∃ c ∈ Ioo a b, is_local_extr f c :=
let ⟨c, cmem, hc⟩ := exists_Ioo_extr_on_Icc f hab hfc hfI
in ⟨c, cmem, hc.is_local_extr $ Icc_mem_nhds cmem.1 cmem.2⟩

/-- **Rolle's Theorem** `has_deriv_at` version -/
lemma exists_has_deriv_at_eq_zero (hab : a < b) (hfc : continuous_on f (Icc a b)) (hfI : f a = f b)
  (hff' : ∀ x ∈ Ioo a b, has_deriv_at f (f' x) x) :
  ∃ c ∈ Ioo a b, f' c = 0 :=
let ⟨c, cmem, hc⟩ := exists_local_extr_Ioo f hab hfc hfI in
  ⟨c, cmem, hc.has_deriv_at_eq_zero $ hff' c cmem⟩

/-- **Rolle's Theorem** `deriv` version -/
lemma exists_deriv_eq_zero (hab : a < b) (hfc : continuous_on f (Icc a b)) (hfI : f a = f b) :
  ∃ c ∈ Ioo a b, deriv f c = 0 :=
let ⟨c, cmem, hc⟩ := exists_local_extr_Ioo f hab hfc hfI in
  ⟨c, cmem, hc.deriv_eq_zero⟩

variables {f f'} {l : ℝ}

/-- **Rolle's Theorem**, a version for a function on an open interval: if `f` has derivative `f'`
on `(a, b)` and has the same limit `l` at `𝓝[Ioi a] a` and `𝓝[Iio b] b`, then `f' c = 0`
for some `c ∈ (a, b)`.  -/
lemma exists_has_deriv_at_eq_zero' (hab : a < b)
  (hfa : tendsto f (𝓝[Ioi a] a) (𝓝 l)) (hfb : tendsto f (𝓝[Iio b] b) (𝓝 l))
  (hff' : ∀ x ∈ Ioo a b, has_deriv_at f (f' x) x) :
  ∃ c ∈ Ioo a b, f' c = 0 :=
begin
  have : continuous_on f (Ioo a b) := λ x hx, (hff' x hx).continuous_at.continuous_within_at,
  have hcont := continuous_on_Icc_extend_from_Ioo hab this hfa hfb,
  obtain ⟨c, hc, hcextr⟩ : ∃ c ∈ Ioo a b, is_local_extr (extend_from (Ioo a b) f) c,
  { apply exists_local_extr_Ioo _ hab hcont,
    rw eq_lim_at_right_extend_from_Ioo hab hfb,
    exact eq_lim_at_left_extend_from_Ioo hab hfa },
  use [c, hc],
  apply (hcextr.congr _).has_deriv_at_eq_zero (hff' c hc),
  rw eventually_eq_iff_exists_mem,
  exact ⟨Ioo a b, Ioo_mem_nhds hc.1 hc.2, extend_from_extends this⟩
end

/-- **Rolle's Theorem**, a version for a function on an open interval: if `f` has the same limit
`l` at `𝓝[Ioi a] a` and `𝓝[Iio b] b`, then `deriv f c = 0` for some `c ∈ (a, b)`. This version
does not require differentiability of `f` because we define `deriv f c = 0` whenever `f` is not
differentiable at `c`. -/
lemma exists_deriv_eq_zero' (hab : a < b)
  (hfa : tendsto f (𝓝[Ioi a] a) (𝓝 l)) (hfb : tendsto f (𝓝[Iio b] b) (𝓝 l)) :
  ∃ c ∈ Ioo a b, deriv f c = 0 :=
classical.by_cases
  (assume h : ∀ x ∈ Ioo a b, differentiable_at ℝ f x,
    show ∃ c ∈ Ioo a b, deriv f c = 0,
      from exists_has_deriv_at_eq_zero' hab hfa hfb (λ x hx, (h x hx).has_deriv_at))
  (assume h : ¬∀ x ∈ Ioo a b, differentiable_at ℝ f x,
    have h : ∃ x, x ∈ Ioo a b ∧ ¬differentiable_at ℝ f x, by { push_neg at h, exact h },
      let ⟨c, hc, hcdiff⟩ := h in ⟨c, hc, deriv_zero_of_not_differentiable_at hcdiff⟩)

end Rolle

namespace polynomial

lemma card_root_set_le_derivative {F : Type*} [field F] [algebra F ℝ] (p : polynomial F) :
  fintype.card (p.root_set ℝ) ≤ fintype.card (p.derivative.root_set ℝ) + 1 :=
begin
  haveI : char_zero F :=
    (ring_hom.char_zero_iff (algebra_map F ℝ).injective).mpr (by apply_instance),
  by_cases hp : p = 0,
  { simp_rw [hp, derivative_zero, root_set_zero, set.empty_card', zero_le_one] },
  by_cases hp' : p.derivative = 0,
  { rw eq_C_of_nat_degree_eq_zero (nat_degree_eq_zero_of_derivative_eq_zero hp'),
    simp_rw [root_set_C, set.empty_card', zero_le] },
  simp_rw [root_set_def, finset.coe_sort_coe, fintype.card_coe],
  refine finset.card_le_of_interleaved (λ x y hx hy hxy, _),
  rw [←finset.mem_coe, ←root_set_def, mem_root_set hp] at hx hy,
  obtain ⟨z, hz1, hz2⟩ := exists_deriv_eq_zero (λ x : ℝ, aeval x p) hxy
    p.continuous_aeval.continuous_on (hx.trans hy.symm),
  refine ⟨z, _, hz1⟩,
  rw [←finset.mem_coe, ←root_set_def, mem_root_set hp', ←hz2],
  simp_rw [aeval_def, ←eval_map, polynomial.deriv, derivative_map],
end

end polynomial


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

! This file was ported from Lean 3 source module measure_theory.group.measurable_equiv
! leanprover-community/mathlib commit 95413e23e3d29b45c701fcd31f2dbadaf1b79cba
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.MeasureTheory.Group.Arithmetic

/-!
# (Scalar) multiplication and (vector) addition as measurable equivalences

In this file we define the following measurable equivalences:

* `measurable_equiv.smul`: if a group `G` acts on `α` by measurable maps, then each element `c : G`
  defines a measurable automorphism of `α`;
* `measurable_equiv.vadd`: additive version of `measurable_equiv.smul`;
* `measurable_equiv.smul₀`: if a group with zero `G` acts on `α` by measurable maps, then each
  nonzero element `c : G` defines a measurable automorphism of `α`;
* `measurable_equiv.mul_left`: if `G` is a group with measurable multiplication, then left
  multiplication by `g : G` is a measurable automorphism of `G`;
* `measurable_equiv.add_left`: additive version of `measurable_equiv.mul_left`;
* `measurable_equiv.mul_right`: if `G` is a group with measurable multiplication, then right
  multiplication by `g : G` is a measurable automorphism of `G`;
* `measurable_equiv.add_right`: additive version of `measurable_equiv.mul_right`;
* `measurable_equiv.mul_left₀`, `measurable_equiv.mul_right₀`: versions of
  `measurable_equiv.mul_left` and `measurable_equiv.mul_right` for groups with zero;
* `measurable_equiv.inv`: `has_inv.inv` as a measurable automorphism
  of a group (or a group with zero);
* `measurable_equiv.neg`: negation as a measurable automorphism of an additive group.

We also deduce that the corresponding maps are measurable embeddings.

## Tags

measurable, equivalence, group action
-/

namespace MeasurableEquiv

variable {G G₀ α : Type _} [MeasurableSpace G] [MeasurableSpace G₀] [MeasurableSpace α] [Group G]
  [GroupWithZero G₀] [MulAction G α] [MulAction G₀ α] [HasMeasurableSmul G α]
  [HasMeasurableSmul G₀ α]

/-- If a group `G` acts on `α` by measurable maps, then each element `c : G` defines a measurable
automorphism of `α`. -/
@[to_additive
      "If an additive group `G` acts on `α` by measurable maps, then each element `c : G`\ndefines a measurable automorphism of `α`.",
  simps (config := { fullyApplied := false }) toEquiv apply]
def smul (c : G) : α ≃ᵐ α where
  toEquiv := MulAction.toPerm c
  measurable_to_fun := measurable_const_smul c
  measurable_inv_fun := measurable_const_smul c⁻¹
#align measurable_equiv.smul MeasurableEquiv.smul
#align measurable_equiv.vadd MeasurableEquiv.vadd

@[to_additive]
theorem measurableEmbedding_const_smul (c : G) : MeasurableEmbedding ((· • ·) c : α → α) :=
  (smul c).MeasurableEmbedding
#align measurable_embedding_const_smul measurableEmbedding_const_smul
#align measurable_embedding_const_vadd measurableEmbedding_const_vadd

@[simp, to_additive]
theorem symm_smul (c : G) : (smul c : α ≃ᵐ α).symm = smul c⁻¹ :=
  ext rfl
#align measurable_equiv.symm_smul MeasurableEquiv.symm_smul
#align measurable_equiv.symm_vadd MeasurableEquiv.symm_vadd

/-- If a group with zero `G₀` acts on `α` by measurable maps, then each nonzero element `c : G₀`
defines a measurable automorphism of `α` -/
def smul₀ (c : G₀) (hc : c ≠ 0) : α ≃ᵐ α :=
  MeasurableEquiv.smul (Units.mk0 c hc)
#align measurable_equiv.smul₀ MeasurableEquiv.smul₀

@[simp]
theorem coe_smul₀ {c : G₀} (hc : c ≠ 0) : ⇑(smul₀ c hc : α ≃ᵐ α) = (· • ·) c :=
  rfl
#align measurable_equiv.coe_smul₀ MeasurableEquiv.coe_smul₀

@[simp]
theorem symm_smul₀ {c : G₀} (hc : c ≠ 0) :
    (smul₀ c hc : α ≃ᵐ α).symm = smul₀ c⁻¹ (inv_ne_zero hc) :=
  ext rfl
#align measurable_equiv.symm_smul₀ MeasurableEquiv.symm_smul₀

theorem measurableEmbedding_const_smul₀ {c : G₀} (hc : c ≠ 0) :
    MeasurableEmbedding ((· • ·) c : α → α) :=
  (smul₀ c hc).MeasurableEmbedding
#align measurable_embedding_const_smul₀ measurableEmbedding_const_smul₀

section Mul

variable [HasMeasurableMul G] [HasMeasurableMul G₀]

/-- If `G` is a group with measurable multiplication, then left multiplication by `g : G` is a
measurable automorphism of `G`. -/
@[to_additive
      "If `G` is an additive group with measurable addition, then addition of `g : G`\non the left is a measurable automorphism of `G`."]
def mulLeft (g : G) : G ≃ᵐ G :=
  smul g
#align measurable_equiv.mul_left MeasurableEquiv.mulLeft
#align measurable_equiv.add_left MeasurableEquiv.addLeft

@[simp, to_additive]
theorem coe_mulLeft (g : G) : ⇑(mulLeft g) = (· * ·) g :=
  rfl
#align measurable_equiv.coe_mul_left MeasurableEquiv.coe_mulLeft
#align measurable_equiv.coe_add_left MeasurableEquiv.coe_add_left

@[simp, to_additive]
theorem symm_mulLeft (g : G) : (mulLeft g).symm = mulLeft g⁻¹ :=
  ext rfl
#align measurable_equiv.symm_mul_left MeasurableEquiv.symm_mulLeft
#align measurable_equiv.symm_add_left MeasurableEquiv.symm_add_left

@[simp, to_additive]
theorem toEquiv_mulLeft (g : G) : (mulLeft g).toEquiv = Equiv.mulLeft g :=
  rfl
#align measurable_equiv.to_equiv_mul_left MeasurableEquiv.toEquiv_mulLeft
#align measurable_equiv.to_equiv_add_left MeasurableEquiv.toEquiv_add_left

@[to_additive]
theorem measurableEmbedding_mul_left (g : G) : MeasurableEmbedding ((· * ·) g) :=
  (mulLeft g).MeasurableEmbedding
#align measurable_embedding_mul_left measurableEmbedding_mul_left
#align measurable_embedding_add_left measurableEmbedding_add_left

/-- If `G` is a group with measurable multiplication, then right multiplication by `g : G` is a
measurable automorphism of `G`. -/
@[to_additive
      "If `G` is an additive group with measurable addition, then addition of `g : G`\non the right is a measurable automorphism of `G`."]
def mulRight (g : G) : G ≃ᵐ G where
  toEquiv := Equiv.mulRight g
  measurable_to_fun := measurable_mul_const g
  measurable_inv_fun := measurable_mul_const g⁻¹
#align measurable_equiv.mul_right MeasurableEquiv.mulRight
#align measurable_equiv.add_right MeasurableEquiv.addRight

@[to_additive]
theorem measurableEmbedding_mul_right (g : G) : MeasurableEmbedding fun x => x * g :=
  (mulRight g).MeasurableEmbedding
#align measurable_embedding_mul_right measurableEmbedding_mul_right
#align measurable_embedding_add_right measurableEmbedding_add_right

@[simp, to_additive]
theorem coe_mulRight (g : G) : ⇑(mulRight g) = fun x => x * g :=
  rfl
#align measurable_equiv.coe_mul_right MeasurableEquiv.coe_mulRight
#align measurable_equiv.coe_add_right MeasurableEquiv.coe_add_right

@[simp, to_additive]
theorem symm_mulRight (g : G) : (mulRight g).symm = mulRight g⁻¹ :=
  ext rfl
#align measurable_equiv.symm_mul_right MeasurableEquiv.symm_mulRight
#align measurable_equiv.symm_add_right MeasurableEquiv.symm_add_right

@[simp, to_additive]
theorem toEquiv_mulRight (g : G) : (mulRight g).toEquiv = Equiv.mulRight g :=
  rfl
#align measurable_equiv.to_equiv_mul_right MeasurableEquiv.toEquiv_mulRight
#align measurable_equiv.to_equiv_add_right MeasurableEquiv.toEquiv_add_right

/-- If `G₀` is a group with zero with measurable multiplication, then left multiplication by a
nonzero element `g : G₀` is a measurable automorphism of `G₀`. -/
def mulLeft₀ (g : G₀) (hg : g ≠ 0) : G₀ ≃ᵐ G₀ :=
  smul₀ g hg
#align measurable_equiv.mul_left₀ MeasurableEquiv.mulLeft₀

theorem measurableEmbedding_mul_left₀ {g : G₀} (hg : g ≠ 0) : MeasurableEmbedding ((· * ·) g) :=
  (mulLeft₀ g hg).MeasurableEmbedding
#align measurable_embedding_mul_left₀ measurableEmbedding_mul_left₀

@[simp]
theorem coe_mulLeft₀ {g : G₀} (hg : g ≠ 0) : ⇑(mulLeft₀ g hg) = (· * ·) g :=
  rfl
#align measurable_equiv.coe_mul_left₀ MeasurableEquiv.coe_mulLeft₀

@[simp]
theorem symm_mulLeft₀ {g : G₀} (hg : g ≠ 0) :
    (mulLeft₀ g hg).symm = mulLeft₀ g⁻¹ (inv_ne_zero hg) :=
  ext rfl
#align measurable_equiv.symm_mul_left₀ MeasurableEquiv.symm_mulLeft₀

@[simp]
theorem toEquiv_mulLeft₀ {g : G₀} (hg : g ≠ 0) : (mulLeft₀ g hg).toEquiv = Equiv.mulLeft₀ g hg :=
  rfl
#align measurable_equiv.to_equiv_mul_left₀ MeasurableEquiv.toEquiv_mulLeft₀

/-- If `G₀` is a group with zero with measurable multiplication, then right multiplication by a
nonzero element `g : G₀` is a measurable automorphism of `G₀`. -/
def mulRight₀ (g : G₀) (hg : g ≠ 0) : G₀ ≃ᵐ G₀
    where
  toEquiv := Equiv.mulRight₀ g hg
  measurable_to_fun := measurable_mul_const g
  measurable_inv_fun := measurable_mul_const g⁻¹
#align measurable_equiv.mul_right₀ MeasurableEquiv.mulRight₀

theorem measurableEmbedding_mul_right₀ {g : G₀} (hg : g ≠ 0) : MeasurableEmbedding fun x => x * g :=
  (mulRight₀ g hg).MeasurableEmbedding
#align measurable_embedding_mul_right₀ measurableEmbedding_mul_right₀

@[simp]
theorem coe_mulRight₀ {g : G₀} (hg : g ≠ 0) : ⇑(mulRight₀ g hg) = fun x => x * g :=
  rfl
#align measurable_equiv.coe_mul_right₀ MeasurableEquiv.coe_mulRight₀

@[simp]
theorem symm_mulRight₀ {g : G₀} (hg : g ≠ 0) :
    (mulRight₀ g hg).symm = mulRight₀ g⁻¹ (inv_ne_zero hg) :=
  ext rfl
#align measurable_equiv.symm_mul_right₀ MeasurableEquiv.symm_mulRight₀

@[simp]
theorem toEquiv_mulRight₀ {g : G₀} (hg : g ≠ 0) : (mulRight₀ g hg).toEquiv = Equiv.mulRight₀ g hg :=
  rfl
#align measurable_equiv.to_equiv_mul_right₀ MeasurableEquiv.toEquiv_mulRight₀

end Mul

/-- Inversion as a measurable automorphism of a group or group with zero. -/
@[to_additive "Negation as a measurable automorphism of an additive group.",
  simps (config := { fullyApplied := false }) toEquiv apply]
def inv (G) [MeasurableSpace G] [InvolutiveInv G] [HasMeasurableInv G] : G ≃ᵐ G
    where
  toEquiv := Equiv.inv G
  measurable_to_fun := measurable_inv
  measurable_inv_fun := measurable_inv
#align measurable_equiv.inv MeasurableEquiv.inv
#align measurable_equiv.neg MeasurableEquiv.neg

@[simp, to_additive]
theorem symm_inv {G} [MeasurableSpace G] [InvolutiveInv G] [HasMeasurableInv G] :
    (inv G).symm = inv G :=
  rfl
#align measurable_equiv.symm_inv MeasurableEquiv.symm_inv
#align measurable_equiv.symm_neg MeasurableEquiv.symm_neg

/-- `equiv.div_right` as a `measurable_equiv`. -/
@[to_additive " `equiv.sub_right` as a `measurable_equiv` "]
def divRight [HasMeasurableMul G] (g : G) : G ≃ᵐ G
    where
  toEquiv := Equiv.divRight g
  measurable_to_fun := measurable_div_const' g
  measurable_inv_fun := measurable_mul_const g
#align measurable_equiv.div_right MeasurableEquiv.divRight
#align measurable_equiv.sub_right MeasurableEquiv.subRight

/-- `equiv.div_left` as a `measurable_equiv` -/
@[to_additive " `equiv.sub_left` as a `measurable_equiv` "]
def divLeft [HasMeasurableMul G] [HasMeasurableInv G] (g : G) : G ≃ᵐ G
    where
  toEquiv := Equiv.divLeft g
  measurable_to_fun := measurable_id.const_div g
  measurable_inv_fun := measurable_inv.mul_const g
#align measurable_equiv.div_left MeasurableEquiv.divLeft
#align measurable_equiv.sub_left MeasurableEquiv.subLeft

end MeasurableEquiv


import Playlean4.Basic

set_option quotPrecheck false

section

variable (G : Type) (law : G → G → G)

local infixl:70 " * " => id' law
@[appUnexpander id'] def unexpandMul : Lean.PrettyPrinter.Unexpander
  | `(id' law $x $y) => `($x * $y)
  | _ => throw ()

class Group where
  one' : G -- Name hack
  assoc : ∀ g₁ g₂ g₃ : G, (g₁ * g₂) * g₃ = g₁ * (g₂ * g₃)
  oneNeutralRight : ∀ g : G, g * one' = g
  invertible : ∀ g : G, ∃ g' : G, g * g' = one'

end

namespace Group

section

variable {G : Type} {law : G → G → G} [grp : Group G law]

local infixl:70 " * " => id' law
@[appUnexpander id'] def unexpandMul : Lean.PrettyPrinter.Unexpander
  | `(id' law $x $y) => `($x * $y)
  | _ => throw ()
local notation "one" => grp.one' -- HACK

theorem inverseComm {g h : G} (inv : g * h = one) : h * g = one :=
by match grp.invertible h with
| ⟨ k, inv' ⟩ =>
  have p₁ : h * g = h * g * one := (Group.oneNeutralRight _).symm
  have p₂ : h * g * one = h * g * h * k := by rw [Group.assoc (h * g), inv']
  have p₃ : h * g * h * k = h * k := by rw [Group.assoc h, inv, Group.oneNeutralRight]
  exact p₁.trans <| p₂.trans $ p₃.trans inv'

@[simp]
protected theorem oneNeutralRight' (g : G) : g * one = g := Group.oneNeutralRight g

@[simp]
theorem oneNeutralLeft (g : G) : one * g = g :=
by match grp.invertible g with
| ⟨ h, inv ⟩ =>
  rw [← inv, Group.assoc, inverseComm inv, Group.oneNeutralRight]

theorem inverseUnique {g h h' : G} (h₁ : g * h = one) (h₂ : g * h' = one) : h = h' :=
by
  have p₁ : g * h = g * h' := h₂.symm ▸ h₁
  have p₂ : h * g * h = h * g * h' := by simp [grp.assoc h, p₁]
  simp [inverseComm h₁, oneNeutralLeft] at p₂
  exact p₂

def inv (g : G) : G := (grp.invertible g).1

local notation g "⁻¹" => grp.inv g

@[simp]
theorem invCancelRight (g : G) : g * g⁻¹ = one := (Group.invertible g).2

@[simp]
theorem invCancelLeft (g : G) : g⁻¹ * g = one := inverseComm (invCancelRight g)

@[simp]
theorem invCancelRightTail {g₀ : G} (g : G) : g₀ * g * g⁻¹ = g₀ := by rw [assoc]; simp

@[simp]
theorem invCancelLeftTail {g₀ : G} (g : G) : g₀ * g⁻¹ * g = g₀ := by rw [assoc]; simp

@[simp]
theorem normalizeAssoc (g₁ g₂ g₃ : G) : g₁ * (g₂ * g₃) = g₁ * g₂ * g₃ := (assoc _ _ _).symm

theorem isInvOfCancelLeft {g h : G} (inv : g * h = one) : h = g⁻¹ :=
inverseUnique inv <| invCancelRight g

theorem isInvOfCancelRight {g h : G} (inv : h * g = one) : h = g⁻¹ :=
isInvOfCancelLeft <| inverseComm inv

@[simp]
theorem invInvolutive (g : G) : (g⁻¹)⁻¹ = g :=
Eq.symm <| isInvOfCancelRight $ invCancelRight g

@[simp]
theorem invMul (g g' : G) : (g * g')⁻¹ = g'⁻¹ * g⁻¹ :=
Eq.symm <| isInvOfCancelLeft <| by simp

@[simp]
theorem invOne : one⁻¹ = one := Eq.symm <| isInvOfCancelLeft <| by simp

theorem oneUnique {g : G} (h : ∃ g' : G, g' * g = g') : g = one :=
match h with
| ⟨ g', h ⟩ => by
  have p : g'⁻¹ * g' * g = g'⁻¹ * g' := by rw [Group.assoc, h]
  simp at p
  exact p

end

section

variable (G : Type) (lawG : G → G → G) [grpG : Group G lawG]
variable (H : Type) (lawH : H → H → H) [grpH : Group H lawH]

local infixl " * " => lawG
local infixl " * " => lawH

structure Morphism where
  f : G → H
  respectMul' : ∀ g g' : G, f ((g * g') : G) = f g * f g'

end

namespace Morphism

variable {G : Type} {lawG : G → G → G} [grpG : Group G lawG]
variable {H : Type} {lawH : H → H → H} [grpH : Group H lawH]

instance : CoeFun (Morphism G lawG H lawH) (fun _ => G → H) where
  coe φ := φ.f

variable (φ : Morphism G lawG H lawH)

local infixl " * " => id' lawG
@[appUnexpander id'] def unexpandGMul : Lean.PrettyPrinter.Unexpander
  | `(id' lawG $x $y) => `($x * $y)
  | _ => throw ()
local infixl " * " => id' lawH
@[appUnexpander id'] def unexpandHMul : Lean.PrettyPrinter.Unexpander
  | `(id' lawH $x $y) => `($x * $y)
  | _ => throw ()
local notation "one" => Group.one' -- HACK

@[simp]
theorem respectMul (g g' : G) : φ (g * g') = φ g * φ g' := φ.respectMul' g g'

@[simp]
theorem respectOne : φ (one lawG) = (one lawH) := by
  apply oneUnique
  exact ⟨ φ (one lawG), by rw [← φ.respectMul, oneNeutralRight] ⟩

@[simp]
theorem respectInv (g : G) : φ (grpG.inv g) = grpH.inv (φ g) :=
isInvOfCancelLeft <| φ.respectMul g (inv g) ▸ invCancelRight g ▸ φ.respectOne

end Morphism

def op {G : Type} (law : G → G → G) [grp : Group G law] : G → G → G := λ g₁ g₂ => law g₂ g₁

notation law "ᵒᵖ" => op law

instance opGroup (G : Type) (law : G → G → G) [h : Group G law] : Group G (lawᵒᵖ) where
  one' := h.1 -- HACK
  assoc := λ g₁ g₂ g₃ => (h.assoc g₃ g₂ g₁).symm
  oneNeutralRight := h.oneNeutralLeft
  invertible := λ g => ⟨ h.inv g, h.invCancelLeft g ⟩

@[simp]
theorem opInvolutive (G : Type) (law : G → G → G) [grp : Group G law] : op (op law) = law := rfl

namespace opGroup

def op (G : Type) (law : G → G → G) [grp : Group G law] : Morphism G law G (lawᵒᵖ) where
  f := inv
  respectMul' := invMul

end opGroup

end Group


/-
References:

http://sourceforge.net/projects/hol/files/hol/kananaskis-14/kananaskis-14-logic.pdf/download

https://www.cl.cam.ac.uk/~jrh13/papers/holhol.pdf
-/

import data.finset

abbreviation type_name_symbols := ℕ -- ν
abbreviation type_var_symbols := ℕ -- α, β, ...

-- σ
inductive hol_type : Type
| var : type_var_symbols → hol_type
| const (n : ℕ) : type_name_symbols → (fin n → hol_type) → hol_type
| func : hol_type → hol_type → hol_type

def pi_decide
  {a b : Prop}
  [decidable a]
  (h : a → decidable b) :
  decidable (a ∧ b) :=
if hp : a then
  by haveI := h hp; exact
  if hq : b then is_true (and.intro hp hq)
  else is_false (assume h : a ∧ b, hq (and.right h))
else is_false (assume h : a ∧ b, hp (and.left h))

instance hol_type.decidable_eq : decidable_eq hol_type
| (hol_type.var α) (hol_type.var α') :=
    decidable_of_decidable_of_iff
      (by apply_instance : decidable (α = α')) (by simp only)
| (hol_type.var α) (hol_type.const n ν t) := is_false (by simp only [not_false_iff])
| (hol_type.var α) (hol_type.func σ₁ σ₂) := is_false (by simp only [not_false_iff])
| (hol_type.const n ν t) (hol_type.var α) := is_false (by simp only [not_false_iff])
| (hol_type.const n ν t) (hol_type.const n' ν' t') := decidable_of_decidable_of_iff
  (begin
    apply' pi_decide,
    intro h,
    apply' and.decidable,
    rewrite fin.heq_fun_iff h,
    apply' fintype.decidable_forall_fintype,
    intro a,
    apply hol_type.decidable_eq,
  end : decidable (n = n' ∧ ν = ν' ∧ t == t')) (by simp only)
| (hol_type.const n ν t) (hol_type.func σ₁ σ₂) := is_false (by simp only [not_false_iff])
| (hol_type.func σ₁ σ₂) (hol_type.var α) := is_false (by simp only [not_false_iff])
| (hol_type.func σ₁ σ₂) (hol_type.const n ν t) := is_false (by simp only [not_false_iff])
| (hol_type.func σ₁ σ₂) (hol_type.func σ₁' σ₂') := decidable_of_decidable_of_iff
	(begin
    apply' pi_decide,
    apply hol_type.decidable_eq,
		intro h,
		apply hol_type.decidable_eq
	end : decidable (σ₁ = σ₁' ∧ σ₂ = σ₂')) (by simp only)

/-
The finite set of all of the type variable symbols occurring in a given hol type.
-/
def hol_type.var_set : hol_type → finset type_var_symbols
| (hol_type.var α) := {α}
| (hol_type.const n _ args) := finset.univ.bUnion (fun (i : fin n), (args i).var_set)
| (hol_type.func σ₁ σ₂) := σ₁.var_set ∪ σ₂.var_set

-- The semantics of hol types.

/-
const : (n : ℕ, ν : const_name_symbols) → (op : (args : fin n → Type) → T : Type)
The type of mappings of n-ary hol type constant symbols to operations on Lean types.
n : The arity of the hol type constant symbol.
ν : The hol type constant symbol.
op : The operation on Lean types that the hol type constant symbol is mapped to.
args : The n arguments of the operation expressed as a finite function.
T : The result of the operation. A Lean type.

default : A Lean term belonging to the Lean type mapped to by const.
(A proof by construction that the Lean type mapped to by const is not empty.)
-/
structure type_const_valuation :=
(const : Π (n : ℕ), type_name_symbols → ((fin n → Type) → Type))
(default : Π (n : ℕ) (ν : type_name_symbols) (args : fin n → Type), const n ν args)

/-
The type of mappings of hol type variable symbols to Lean types.
default : A Lean term belonging to the Lean type mapped to by var.
(A proof by construction that the Lean type mapped to by var is not empty.)
-/
structure type_var_valuation :=
(var : type_var_symbols → Type)
(default : Π (α : type_var_symbols), var α)

/-
The function mapping each hol type to a Lean type for a given
type constant valuation and type variable valuation.
-/
def eval_type
	(C : type_const_valuation)
	(V : type_var_valuation) :
	hol_type → Type
| (hol_type.var α) := V.var α
| (hol_type.const n ν args) := C.const n ν (fun (i : fin n), eval_type (args i))
| (hol_type.func σ₁ σ₂) := eval_type σ₁ → eval_type σ₂

/-
The function mapping each hol type to the default Lean term of the Lean type
that the hol type is evaluated to.
-/
def eval_type_default
	(C : type_const_valuation)
	(V : type_var_valuation) :
	Π (σ : hol_type), eval_type C V σ
| (hol_type.var α) := V.default α
| (hol_type.const n ν args) := C.default n ν (fun (i : fin n), eval_type C V (args i))
| (hol_type.func σ₁ σ₂) := fun (x : eval_type C V σ₁), eval_type_default σ₂

instance
	(C : type_const_valuation)
	(V : type_var_valuation)
	(σ : hol_type) :
	inhabited (eval_type C V σ) :=
	{default := eval_type_default C V σ}

abbreviation term_name_symbols := ℕ
abbreviation term_var_symbols := ℕ

inductive hol_term : Type
| var : term_var_symbols → hol_type → hol_term
| const : term_name_symbols → hol_type → hol_term
| app : hol_term → hol_term → hol_term
| abs : term_var_symbols → hol_type → hol_term → hol_term

/-
hol_term.has_type t σ = t : σ
-/
inductive hol_term.has_type : hol_term → hol_type → Prop
| var {x : term_var_symbols} {σ : hol_type} :
	hol_term.has_type (hol_term.var x σ) σ
| const {c : term_name_symbols} {σ : hol_type} :
	hol_term.has_type (hol_term.const c σ) σ
| app {t₁ t₂ : hol_term} {σ₁ σ₂ : hol_type} :
	hol_term.has_type t₁ (hol_type.func σ₁ σ₂) →
	hol_term.has_type t₂ σ₁ →
	hol_term.has_type (hol_term.app t₁ t₂) σ₂
| abs {x : term_var_symbols} {σₓ σₜ : hol_type} {t : hol_term} :
	hol_term.has_type t σₜ →
	hol_term.has_type (hol_term.abs x σₓ t) (hol_type.func σₓ σₜ)

-- The hol type of a hol term if the hol term is syntactically valid.
def hol_term.type : hol_term → option hol_type
| (hol_term.var x σ) := some σ
| (hol_term.const c σ) := some σ
| (hol_term.app t₁ t₂) := do
	hol_type.func σ₁₁ σ₁₂ <- t₁.type | none,
	σ₂ <- t₂.type,
	if σ₁₁ = σ₂ then return σ₁₂ else none
| (hol_term.abs x σₓ t) := do
	σₜ <- t.type,
	return (hol_type.func σₓ σₜ)

/-
A mapping of each hol term variable symbol and hol type to a Lean term
belonging to the Lean type that the hol type is evaluated to.
-/
def term_var_valuation
	(C : type_const_valuation)
	(V : type_var_valuation) :
	Type :=
	term_var_symbols → Π (σ : hol_type), eval_type C V σ

/-
A mapping of each hol term constant symbol and hol type to a Lean term
belonging to the Lean type that the hol type is evaluated to.
-/
def term_const_valuation
	(C : type_const_valuation)
	(V : type_var_valuation) :
	Type :=
	term_name_symbols → Π σ : hol_type, eval_type C V σ

def term_var_valuation.update
	(C : type_const_valuation)
	(V : type_var_valuation)
	(f : term_var_valuation C V)
  (x : term_var_symbols)
	(σ : hol_type)
	(y : eval_type C V σ) :
	term_var_valuation C V :=
	function.update f x (function.update (f x) σ y)

instance
	{C : type_const_valuation}
	{V : type_var_valuation}
	{σ : hol_type} :
	has_coe (eval_type C V σ) (option Σ σ : hol_type, eval_type C V σ) :=
	{coe := fun (x : eval_type C V σ), some {fst := σ, snd := x}}

def as_eval_type
	(C : type_const_valuation)
	(V : type_var_valuation)
	(σ : hol_type) :
	(option Σ σ : hol_type, eval_type C V σ) → eval_type C V σ
| (some {fst := σ', snd := x}) := if h : σ = σ' then by rewrite h; exact x else default
| _ := default

def app
	{C : type_const_valuation}
	{V : type_var_valuation} :
	(option Σ σ : hol_type, eval_type C V σ) →
		(option Σ σ : hol_type, eval_type C V σ) →
			(option Σ σ : hol_type, eval_type C V σ)
| (some {fst := hol_type.func σ τ, snd := f}) x := some {fst := τ, snd := f (as_eval_type C V σ x)}
| _ _ := none

def hol_term.semantics
	(C : type_const_valuation)
  (V : type_var_valuation)
  (m : term_const_valuation C V) :
  hol_term → term_var_valuation C V → option (Σ σ : hol_type, eval_type C V σ)
| (hol_term.var x σ) v := some {fst := σ, snd := v x σ}
| (hol_term.const c σ) _ := some {fst := σ, snd := m c σ}
| (hol_term.app t₁ t₂) v :=
		app (hol_term.semantics t₁ v) (hol_term.semantics t₂ v)
| (hol_term.abs x σ t) v := do
  σ₂ ← t.type,
  some {fst := hol_type.func σ σ₂,
				snd := fun (a : eval_type C V σ),
				as_eval_type C V σ₂ (hol_term.semantics t (term_var_valuation.update C V v x σ a))
			 }

theorem hol_term.semantics_type
  (C : type_const_valuation)
  (V : type_var_valuation)
  (m : term_const_valuation C V)
  (v : term_var_valuation C V)
	(t : hol_term)
  (σ : hol_type)
	(h : t.type = some σ) :
	(t.semantics C V m v).map sigma.fst = some σ :=
begin
	sorry
end

theorem hol_term.semantics_val
  (C : type_const_valuation)
  (V : type_var_valuation)
  (m : term_const_valuation C V)
	(v : term_var_valuation C V)
	(t : hol_term)
  (σ : hol_type)
	(h : t.type = some σ) :
	hol_term.semantics C V m t v = as_eval_type C V σ (hol_term.semantics C V m t v) :=
begin
	sorry
end

-- Type substitution.

/-
sub_type_var_type τ σ = The replacement of each var symbol α in the
hol type σ by the hol type τ α.
-/
def sub_type_var_type
	(τ : type_var_symbols → hol_type) :
	hol_type → hol_type
| (hol_type.var α) := τ α
| (hol_type.const n ν args) := hol_type.const n ν (fun (i : fin n), sub_type_var_type (args i))
| (hol_type.func σ₁ σ₂) := hol_type.func (sub_type_var_type σ₁) (sub_type_var_type σ₂)

lemma lem_1
	(σ : hol_type)
	(τ₁ τ₂ : type_var_symbols → hol_type)
	(h1 : sub_type_var_type τ₁ σ = sub_type_var_type τ₂ σ) :
	∀ α ∈ σ.var_set, τ₁ α = τ₂ α :=
begin
	intros α' h2,
	induction σ,
	case hol_type.var : α
  {
		unfold sub_type_var_type at h1, unfold hol_type.var_set at h2,
		simp only [finset.mem_singleton] at h2, subst h2, exact h1,
	},
  case hol_type.const : n ν args σ_ih
  {
		unfold sub_type_var_type at h1, unfold hol_type.var_set at h2,
		simp only [eq_self_iff_true, heq_iff_eq, true_and] at h1,
		simp only [finset.mem_bUnion, finset.mem_univ, exists_true_left] at h2,
		apply exists.elim h2, intros i h3,
		apply σ_ih i, apply congr_fun h1, exact h3
	},
  case hol_type.func : σ₁ σ₂ σ₁_ih σ₂_ih
  {
		unfold sub_type_var_type at h1, unfold hol_type.var_set at h2,
		simp at h1, cases h1,
		simp at h2, cases h2,
		exact σ₁_ih h1_left h2,
		exact σ₂_ih h1_right h2,
	},
end

lemma lem_2
	(σ : hol_type)
	(τ : type_var_symbols → hol_type)
	(C : type_const_valuation)
	(V : type_var_valuation) :
  eval_type C V (sub_type_var_type τ σ) =
		eval_type C {var := fun (α : type_var_symbols), eval_type C V (τ α),
								default := fun (α : type_var_symbols), eval_type_default C V (τ α)} σ :=
begin
	induction σ,
	case hol_type.var : α
  {
		unfold sub_type_var_type, unfold eval_type
	},
  case hol_type.const : n ν args σ_ih
  {
		unfold sub_type_var_type at *, unfold eval_type at *,
		congr, funext, apply σ_ih
	},
  case hol_type.func : σ₁ σ₂ σ₁_ih σ₂_ih
  {
		unfold sub_type_var_type at *, unfold eval_type at *,
		rewrite σ₁_ih, rewrite σ₂_ih
	},
end


theorem and_swap (p q : Prop) : p ∧ q → q ∧ p :=
begin
    assume h : (p ∧ q), -- assume p ∧ q is true
    cases h, -- extract the individual propositions from the conjunction
    split, -- split the goal conjunction into two cases: prove p and prove q separately
    repeat { assumption }
end


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

open_locale nat rat real big_operators topological_space

theorem numbertheory_2dvd4expn
  (n : ℕ)
  (h₀ : n ≠ 0) :
  2 ∣ 4^n :=
begin
  apply dvd_pow _ h₀,
  norm_num,
end


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

! This file was ported from Lean 3 source module category_theory.limits.constructions.limits_of_products_and_equalizers
! leanprover-community/mathlib commit c3019c79074b0619edb4b27553a91b2e82242395
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Fintype.Prod
import Mathlib.Data.Fintype.Sigma
import Mathlib.CategoryTheory.Limits.Shapes.Equalizers
import Mathlib.CategoryTheory.Limits.Shapes.FiniteProducts
import Mathlib.CategoryTheory.Limits.Preserves.Shapes.Products
import Mathlib.CategoryTheory.Limits.Preserves.Shapes.Equalizers
import Mathlib.CategoryTheory.Limits.Preserves.Finite
import Mathlib.CategoryTheory.Limits.Constructions.FiniteProductsOfBinaryProducts
import Mathlib.CategoryTheory.Limits.Constructions.Equalizers
import Mathlib.CategoryTheory.Limits.Constructions.BinaryProducts

/-!
# Constructing limits from products and equalizers.

If a category has all products, and all equalizers, then it has all limits.
Similarly, if it has all finite products, and all equalizers, then it has all finite limits.

If a functor preserves all products and equalizers, then it preserves all limits.
Similarly, if it preserves all finite products and equalizers, then it preserves all finite limits.

# TODO

Provide the dual results.
Show the analogous results for functors which reflect or create (co)limits.
-/

open CategoryTheory

open Opposite

namespace CategoryTheory.Limits

universe w v v₂ u u₂

variable {C : Type u} [Category.{v} C]

variable {J : Type w} [SmallCategory J]

-- We hide the "implementation details" inside a namespace
namespace HasLimitOfHasProductsOfHasEqualizers

variable {F : J ⥤ C} {c₁ : Fan F.obj} {c₂ : Fan fun f : Σp : J × J, p.1 ⟶ p.2 => F.obj f.1.2}
  (s t : c₁.pt ⟶ c₂.pt)
  (hs : ∀ f : Σp : J × J, p.1 ⟶ p.2, s ≫ c₂.π.app ⟨f⟩ = c₁.π.app ⟨f.1.1⟩ ≫ F.map f.2)
  (ht : ∀ f : Σp : J × J, p.1 ⟶ p.2, t ≫ c₂.π.app ⟨f⟩ = c₁.π.app ⟨f.1.2⟩) (i : Fork s t)

/--
(Implementation) Given the appropriate product and equalizer cones, build the cone for `F` which is
limiting if the given cones are also.
-/
@[simps]
def buildLimit : Cone F where
  pt := i.pt
  π :=
    { app := fun j => i.ι ≫ c₁.π.app ⟨_⟩
      naturality := fun j₁ j₂ f => by
        dsimp
        rw [Category.id_comp, Category.assoc, ← hs ⟨⟨_, _⟩, f⟩, i.condition_assoc, ht] }
#align category_theory.limits.has_limit_of_has_products_of_has_equalizers.build_limit CategoryTheory.Limits.HasLimitOfHasProductsOfHasEqualizers.buildLimit

variable {i}

/--
(Implementation) Show the cone constructed in `buildLimit` is limiting, provided the cones used in
its construction are.
-/
def buildIsLimit (t₁ : IsLimit c₁) (t₂ : IsLimit c₂) (hi : IsLimit i) :
    IsLimit (buildLimit s t hs ht i) where
  lift q := by
    refine' hi.lift (Fork.ofι _ _)
    · refine' t₁.lift (Fan.mk _ fun j => _)
      apply q.π.app j
    · apply t₂.hom_ext
      intro ⟨j⟩
      simp [hs, ht]
  uniq q m w :=
    hi.hom_ext
      (i.equalizer_ext
        (t₁.hom_ext fun j => by
          cases' j with j
          simpa using w j))
  fac s j := by simp
#align category_theory.limits.has_limit_of_has_products_of_has_equalizers.build_is_limit CategoryTheory.Limits.HasLimitOfHasProductsOfHasEqualizers.buildIsLimit

end HasLimitOfHasProductsOfHasEqualizers

open HasLimitOfHasProductsOfHasEqualizers

/-- Given the existence of the appropriate (possibly finite) products and equalizers,
we can construct a limit cone for `F`.
(This assumes the existence of all equalizers, which is technically stronger than needed.)
-/
noncomputable def limitConeOfEqualizerAndProduct (F : J ⥤ C) [HasLimit (Discrete.functor F.obj)]
    [HasLimit (Discrete.functor fun f : Σp : J × J, p.1 ⟶ p.2 => F.obj f.1.2)] [HasEqualizers C] :
    LimitCone F where
  cone := _
  isLimit :=
    buildIsLimit (Pi.lift fun f => limit.π (Discrete.functor F.obj) ⟨_⟩ ≫ F.map f.2)
      (Pi.lift fun f => limit.π (Discrete.functor F.obj) ⟨f.1.2⟩) (by simp) (by simp)
      (limit.isLimit _) (limit.isLimit _) (limit.isLimit _)
#align category_theory.limits.limit_cone_of_equalizer_and_product CategoryTheory.Limits.limitConeOfEqualizerAndProduct

/--
Given the existence of the appropriate (possibly finite) products and equalizers, we know a limit of
`F` exists.
(This assumes the existence of all equalizers, which is technically stronger than needed.)
-/
theorem hasLimit_of_equalizer_and_product (F : J ⥤ C) [HasLimit (Discrete.functor F.obj)]
    [HasLimit (Discrete.functor fun f : Σp : J × J, p.1 ⟶ p.2 => F.obj f.1.2)] [HasEqualizers C] :
    HasLimit F :=
  HasLimit.mk (limitConeOfEqualizerAndProduct F)
#align category_theory.limits.has_limit_of_equalizer_and_product CategoryTheory.Limits.hasLimit_of_equalizer_and_product

/-- A limit can be realised as a subobject of a product. -/
noncomputable def limitSubobjectProduct [HasLimitsOfSize.{w, w} C] (F : J ⥤ C) :
    limit F ⟶ ∏ fun j => F.obj j :=
  (limit.isoLimitCone (limitConeOfEqualizerAndProduct F)).hom ≫ equalizer.ι _ _
#align category_theory.limits.limit_subobject_product CategoryTheory.Limits.limitSubobjectProduct

instance limitSubobjectProduct_mono [HasLimitsOfSize.{w, w} C] (F : J ⥤ C) :
    Mono (limitSubobjectProduct F) :=
  mono_comp _ _
#align category_theory.limits.limit_subobject_product_mono CategoryTheory.Limits.limitSubobjectProduct_mono

/-- Any category with products and equalizers has all limits.

See <https://stacks.math.columbia.edu/tag/002N>.
-/
theorem has_limits_of_hasEqualizers_and_products [HasProducts.{w} C] [HasEqualizers C] :
    HasLimitsOfSize.{w, w} C :=
  { has_limits_of_shape :=
    fun _ _ => { has_limit := fun F => hasLimit_of_equalizer_and_product F } }
#align category_theory.limits.has_limits_of_has_equalizers_and_products CategoryTheory.Limits.has_limits_of_hasEqualizers_and_products

/-- Any category with finite products and equalizers has all finite limits.

See <https://stacks.math.columbia.edu/tag/002O>.
-/
theorem hasFiniteLimits_of_hasEqualizers_and_finite_products [HasFiniteProducts C]
    [HasEqualizers C] : HasFiniteLimits C where
  out _ := { has_limit := fun F => hasLimit_of_equalizer_and_product F }
#align category_theory.limits.has_finite_limits_of_has_equalizers_and_finite_products CategoryTheory.Limits.hasFiniteLimits_of_hasEqualizers_and_finite_products

variable {D : Type u₂} [Category.{v₂} D]

/- Porting note: original file have noncomputable theory which made everything after
noncomputable. Removed this and made whatever necessary noncomputable -/
-- noncomputable section

section

variable [HasLimitsOfShape (Discrete J) C] [HasLimitsOfShape (Discrete (Σp : J × J, p.1 ⟶ p.2)) C]
  [HasEqualizers C]

variable (G : C ⥤ D) [PreservesLimitsOfShape WalkingParallelPair G]
  -- [PreservesFiniteProducts G]
  [PreservesLimitsOfShape (Discrete.{w} J) G]
  [PreservesLimitsOfShape (Discrete.{w} (Σp : J × J, p.1 ⟶ p.2)) G]

/-- If a functor preserves equalizers and the appropriate products, it preserves limits. -/
noncomputable def preservesLimitOfPreservesEqualizersAndProduct : PreservesLimitsOfShape J G where
  preservesLimit {K} := by
    let P := ∏ K.obj
    let Q := ∏ fun f : Σp : J × J, p.fst ⟶ p.snd => K.obj f.1.2
    let s : P ⟶ Q := Pi.lift fun f => limit.π (Discrete.functor K.obj) ⟨_⟩ ≫ K.map f.2
    let t : P ⟶ Q := Pi.lift fun f => limit.π (Discrete.functor K.obj) ⟨f.1.2⟩
    let I := equalizer s t
    let i : I ⟶ P := equalizer.ι s t
    apply
      preservesLimitOfPreservesLimitCone
        (buildIsLimit s t (by simp) (by simp) (limit.isLimit _) (limit.isLimit _)
          (limit.isLimit _))
    refine' IsLimit.ofIsoLimit (buildIsLimit _ _ _ _ _ _ _) _
    · exact Fan.mk _ fun j => G.map (Pi.π _ j)
    · exact Fan.mk (G.obj Q) fun f => G.map (Pi.π _ f)
    · apply G.map s
    · apply G.map t
    · intro f
      dsimp [Fan.mk]
      simp only [← G.map_comp, limit.lift_π]
      congr
    · intro f
      dsimp [Fan.mk]
      simp only [← G.map_comp, limit.lift_π]
      apply congrArg G.map
      dsimp
    · apply Fork.ofι (G.map i)
      rw [← G.map_comp, ← G.map_comp]
      apply congrArg G.map
      exact equalizer.condition s t
    · apply isLimitOfHasProductOfPreservesLimit
    · apply isLimitOfHasProductOfPreservesLimit
    · apply isLimitForkMapOfIsLimit
      apply equalizerIsEqualizer
    · refine Cones.ext (Iso.refl _) ?_
      intro j; dsimp; simp
-- See note [dsimp, simp].
#align category_theory.limits.preserves_limit_of_preserves_equalizers_and_product CategoryTheory.Limits.preservesLimitOfPreservesEqualizersAndProduct

end

/- Porting note: the original parameter [∀ (J) [Fintype J], PreservesColimitsOfShape
(Discrete.{0} J) G] triggered the error "invalid parametric local instance, parameter
with type Fintype J does not have forward dependencies, type class resolution cannot
use this kind of local instance because it will not be able to infer a value for this
parameter." Factored out this as new class in `CategoryTheory.Limits.Preserves.Finite` -/
/-- If G preserves equalizers and finite products, it preserves finite limits. -/
noncomputable def preservesFiniteLimitsOfPreservesEqualizersAndFiniteProducts [HasEqualizers C]
    [HasFiniteProducts C] (G : C ⥤ D) [PreservesLimitsOfShape WalkingParallelPair G]
    [PreservesFiniteProducts G] : PreservesFiniteLimits G where
  preservesFiniteLimits := by
    intro J sJ fJ
    haveI : Fintype J := inferInstance
    haveI : Fintype ((p : J × J) × (p.fst ⟶  p.snd)) := inferInstance
    apply @preservesLimitOfPreservesEqualizersAndProduct _ _ _ sJ _ _ ?_ ?_ _ G _ ?_ ?_
    · apply hasLimitsOfShape_discrete _ _
    · apply hasLimitsOfShape_discrete _
    · apply PreservesFiniteProducts.preserves _
    · apply PreservesFiniteProducts.preserves _
#align category_theory.limits.preserves_finite_limits_of_preserves_equalizers_and_finite_products CategoryTheory.Limits.preservesFiniteLimitsOfPreservesEqualizersAndFiniteProducts

/-- If G preserves equalizers and products, it preserves all limits. -/
noncomputable def preservesLimitsOfPreservesEqualizersAndProducts [HasEqualizers C]
    [HasProducts.{w} C] (G : C ⥤ D) [PreservesLimitsOfShape WalkingParallelPair G]
    [∀ J, PreservesLimitsOfShape (Discrete.{w} J) G] : PreservesLimitsOfSize.{w, w} G where
  preservesLimitsOfShape := preservesLimitOfPreservesEqualizersAndProduct G
#align category_theory.limits.preserves_limits_of_preserves_equalizers_and_products CategoryTheory.Limits.preservesLimitsOfPreservesEqualizersAndProducts

theorem hasFiniteLimits_of_hasTerminal_and_pullbacks [HasTerminal C] [HasPullbacks C] :
    HasFiniteLimits C :=
  @hasFiniteLimits_of_hasEqualizers_and_finite_products C _
    (@hasFiniteProducts_of_has_binary_and_terminal C _
      (hasBinaryProducts_of_hasTerminal_and_pullbacks C) inferInstance)
    (@hasEqualizers_of_hasPullbacks_and_binary_products C _
      (hasBinaryProducts_of_hasTerminal_and_pullbacks C) inferInstance)
#align category_theory.limits.has_finite_limits_of_has_terminal_and_pullbacks CategoryTheory.Limits.hasFiniteLimits_of_hasTerminal_and_pullbacks

/-- If G preserves terminal objects and pullbacks, it preserves all finite limits. -/
noncomputable def preservesFiniteLimitsOfPreservesTerminalAndPullbacks [HasTerminal C]
    [HasPullbacks C] (G : C ⥤ D) [PreservesLimitsOfShape (Discrete.{0} PEmpty) G]
    [PreservesLimitsOfShape WalkingCospan G] : PreservesFiniteLimits G := by
  haveI : HasFiniteLimits C := hasFiniteLimits_of_hasTerminal_and_pullbacks
  haveI : PreservesLimitsOfShape (Discrete WalkingPair) G :=
    preservesBinaryProductsOfPreservesTerminalAndPullbacks G
  haveI : PreservesLimitsOfShape WalkingParallelPair G :=
      preservesEqualizersOfPreservesPullbacksAndBinaryProducts G
  apply
    @preservesFiniteLimitsOfPreservesEqualizersAndFiniteProducts _ _ _ _ _ _ G _ ?_
  apply PreservesFiniteProducts.mk
  apply preservesFiniteProductsOfPreservesBinaryAndTerminal G
#align category_theory.limits.preserves_finite_limits_of_preserves_terminal_and_pullbacks CategoryTheory.Limits.preservesFiniteLimitsOfPreservesTerminalAndPullbacks

/-!
We now dualize the above constructions, resorting to copy-paste.
-/

-- We hide the "implementation details" inside a namespace
namespace HasColimitOfHasCoproductsOfHasCoequalizers

variable {F : J ⥤ C} {c₁ : Cofan fun f : Σp : J × J, p.1 ⟶ p.2 => F.obj f.1.1} {c₂ : Cofan F.obj}
  (s t : c₁.pt ⟶ c₂.pt)
  (hs : ∀ f : Σp : J × J, p.1 ⟶ p.2, c₁.ι.app ⟨f⟩ ≫ s = F.map f.2 ≫ c₂.ι.app ⟨f.1.2⟩)
  (ht : ∀ f : Σp : J × J, p.1 ⟶ p.2, c₁.ι.app ⟨f⟩ ≫ t = c₂.ι.app ⟨f.1.1⟩) (i : Cofork s t)

/-- (Implementation) Given the appropriate coproduct and coequalizer cocones,
build the cocone for `F` which is colimiting if the given cocones are also.
-/
@[simps]
def buildColimit : Cocone F where
  pt := i.pt
  ι :=
    { app := fun j => c₂.ι.app ⟨_⟩ ≫ i.π
      naturality := fun j₁ j₂ f => by
        dsimp
        have reassoced (f : (p : J × J) × (p.fst ⟶  p.snd)) {W : C} {h : _ ⟶  W} :
          c₁.ι.app ⟨f⟩ ≫ s ≫ h = F.map f.snd ≫ c₂.ι.app ⟨f.fst.snd⟩ ≫ h := by
            simp only [← Category.assoc, eq_whisker (hs f)]
        rw [Category.comp_id, ← reassoced ⟨⟨_, _⟩, f⟩, i.condition, ← Category.assoc, ht] }
#align category_theory.limits.has_colimit_of_has_coproducts_of_has_coequalizers.build_colimit CategoryTheory.Limits.HasColimitOfHasCoproductsOfHasCoequalizers.buildColimit

variable {i}

/-- (Implementation) Show the cocone constructed in `buildColimit` is colimiting,
provided the cocones used in its construction are.
-/
def buildIsColimit (t₁ : IsColimit c₁) (t₂ : IsColimit c₂) (hi : IsColimit i) :
    IsColimit (buildColimit s t hs ht i) where
  desc q := by
    refine' hi.desc (Cofork.ofπ _ _)
    · refine' t₂.desc (Cofan.mk _ fun j => _)
      apply q.ι.app j
    · apply t₁.hom_ext
      intro j
      cases' j with j
      have reassoced_s (f : (p : J ×  J) × (p.fst ⟶  p.snd)) {W : C} (h : _ ⟶  W) :
        c₁.ι.app ⟨f⟩ ≫ s ≫ h = F.map f.snd ≫ c₂.ι.app ⟨f.fst.snd⟩ ≫ h := by
          simp only [← Category.assoc]
          apply eq_whisker (hs f)
      have reassoced_t (f : (p : J ×  J) × (p.fst ⟶  p.snd)) {W : C} (h : _ ⟶  W) :
        c₁.ι.app ⟨f⟩ ≫ t ≫ h = c₂.ι.app ⟨f.fst.fst⟩ ≫ h := by
          simp only [← Category.assoc]
          apply eq_whisker (ht f)
      simp [reassoced_s, reassoced_t]
  uniq q m w :=
    hi.hom_ext
      (i.coequalizer_ext
        (t₂.hom_ext fun j => by
          cases' j with j
          simpa using w j))
  fac s j := by simp
#align category_theory.limits.has_colimit_of_has_coproducts_of_has_coequalizers.build_is_colimit CategoryTheory.Limits.HasColimitOfHasCoproductsOfHasCoequalizers.buildIsColimit

end HasColimitOfHasCoproductsOfHasCoequalizers

open HasColimitOfHasCoproductsOfHasCoequalizers

/-- Given the existence of the appropriate (possibly finite) coproducts and coequalizers,
we can construct a colimit cocone for `F`.
(This assumes the existence of all coequalizers, which is technically stronger than needed.)
-/
noncomputable def colimitCoconeOfCoequalizerAndCoproduct (F : J ⥤ C)
    [HasColimit (Discrete.functor F.obj)]
    [HasColimit (Discrete.functor fun f : Σp : J × J, p.1 ⟶ p.2 => F.obj f.1.1)]
    [HasCoequalizers C] : ColimitCocone F where
  cocone := _
  isColimit :=
    buildIsColimit (Sigma.desc fun f => F.map f.2 ≫ colimit.ι (Discrete.functor F.obj) ⟨f.1.2⟩)
      (Sigma.desc fun f => colimit.ι (Discrete.functor F.obj) ⟨f.1.1⟩) (by simp) (by simp)
      (colimit.isColimit _) (colimit.isColimit _) (colimit.isColimit _)
#align category_theory.limits.colimit_cocone_of_coequalizer_and_coproduct CategoryTheory.Limits.colimitCoconeOfCoequalizerAndCoproduct

/-- Given the existence of the appropriate (possibly finite) coproducts and coequalizers,
we know a colimit of `F` exists.
(This assumes the existence of all coequalizers, which is technically stronger than needed.)
-/
theorem hasColimit_of_coequalizer_and_coproduct (F : J ⥤ C) [HasColimit (Discrete.functor F.obj)]
    [HasColimit (Discrete.functor fun f : Σp : J × J, p.1 ⟶ p.2 => F.obj f.1.1)]
    [HasCoequalizers C] : HasColimit F :=
  HasColimit.mk (colimitCoconeOfCoequalizerAndCoproduct F)
#align category_theory.limits.has_colimit_of_coequalizer_and_coproduct CategoryTheory.Limits.hasColimit_of_coequalizer_and_coproduct

/-- A colimit can be realised as a quotient of a coproduct. -/
noncomputable def colimitQuotientCoproduct [HasColimitsOfSize.{w, w} C] (F : J ⥤ C) :
    (∐ fun j => F.obj j) ⟶ colimit F :=
  coequalizer.π _ _ ≫ (colimit.isoColimitCocone (colimitCoconeOfCoequalizerAndCoproduct F)).inv
#align category_theory.limits.colimit_quotient_coproduct CategoryTheory.Limits.colimitQuotientCoproduct

instance colimitQuotientCoproduct_epi [HasColimitsOfSize.{w, w} C] (F : J ⥤ C) :
    Epi (colimitQuotientCoproduct F) :=
  epi_comp _ _
#align category_theory.limits.colimit_quotient_coproduct_epi CategoryTheory.Limits.colimitQuotientCoproduct_epi

/-- Any category with coproducts and coequalizers has all colimits.

See <https://stacks.math.columbia.edu/tag/002P>.
-/
theorem has_colimits_of_hasCoequalizers_and_coproducts [HasCoproducts.{w} C] [HasCoequalizers C] :
    HasColimitsOfSize.{w, w} C where
  has_colimits_of_shape := fun _ _ =>
      { has_colimit := fun F => hasColimit_of_coequalizer_and_coproduct F }
#align category_theory.limits.has_colimits_of_has_coequalizers_and_coproducts CategoryTheory.Limits.has_colimits_of_hasCoequalizers_and_coproducts

/-- Any category with finite coproducts and coequalizers has all finite colimits.

See <https://stacks.math.columbia.edu/tag/002Q>.
-/
theorem hasFiniteColimits_of_hasCoequalizers_and_finite_coproducts [HasFiniteCoproducts C]
    [HasCoequalizers C] : HasFiniteColimits C where
  out _ := { has_colimit := fun F => hasColimit_of_coequalizer_and_coproduct F }
#align category_theory.limits.has_finite_colimits_of_has_coequalizers_and_finite_coproducts CategoryTheory.Limits.hasFiniteColimits_of_hasCoequalizers_and_finite_coproducts

-- Porting note: removed and added individually
-- noncomputable section
section

variable [HasColimitsOfShape (Discrete.{w} J) C]
  [HasColimitsOfShape (Discrete.{w} (Σp : J × J, p.1 ⟶ p.2)) C] [HasCoequalizers C]

variable (G : C ⥤ D) [PreservesColimitsOfShape WalkingParallelPair G]
  [PreservesColimitsOfShape (Discrete.{w} J) G]
  [PreservesColimitsOfShape (Discrete.{w} (Σp : J × J, p.1 ⟶ p.2)) G]

/-- If a functor preserves coequalizers and the appropriate coproducts, it preserves colimits. -/
noncomputable def preservesColimitOfPreservesCoequalizersAndCoproduct :
    PreservesColimitsOfShape J G where
  preservesColimit {K} := by
    let P := ∐ K.obj
    let Q := ∐ fun f : Σp : J × J, p.fst ⟶ p.snd => K.obj f.1.1
    let s : Q ⟶ P := Sigma.desc fun f => K.map f.2 ≫ colimit.ι (Discrete.functor K.obj) ⟨_⟩
    let t : Q ⟶ P := Sigma.desc fun f => colimit.ι (Discrete.functor K.obj) ⟨f.1.1⟩
    let I := coequalizer s t
    let i : P ⟶ I := coequalizer.π s t
    apply
      preservesColimitOfPreservesColimitCocone
        (buildIsColimit s t (by simp) (by simp) (colimit.isColimit _) (colimit.isColimit _)
          (colimit.isColimit _))
    refine' IsColimit.ofIsoColimit (buildIsColimit _ _ _ _ _ _ _) _
    · refine Cofan.mk (G.obj Q) fun j => G.map ?_
      apply Sigma.ι _ j
    -- fun j => G.map (Sigma.ι _ j)
    · exact Cofan.mk _ fun f => G.map (Sigma.ι _ f)
    · apply G.map s
    · apply G.map t
    · intro f
      dsimp [Cofan.mk]
      simp only [← G.map_comp, colimit.ι_desc]
      congr
    · intro f
      dsimp [Cofan.mk]
      simp only [← G.map_comp, colimit.ι_desc]
      dsimp
    · refine Cofork.ofπ (G.map i) ?_
      rw [← G.map_comp, ← G.map_comp]
      apply congrArg G.map
      apply coequalizer.condition
    · apply isColimitOfHasCoproductOfPreservesColimit
    · apply isColimitOfHasCoproductOfPreservesColimit
    · apply isColimitCoforkMapOfIsColimit
      apply coequalizerIsCoequalizer
    refine' Cocones.ext (Iso.refl _) _
    intro j
    dsimp
    simp
-- See note [dsimp, simp].
#align category_theory.limits.preserves_colimit_of_preserves_coequalizers_and_coproduct CategoryTheory.Limits.preservesColimitOfPreservesCoequalizersAndCoproduct

end

/- Porting note: the original parameter [∀ (J) [Fintype J], PreservesColimitsOfShape
(Discrete.{0} J) G]  triggered the error "invalid parametric local instance, parameter
with type Fintype J does not have forward dependencies, type class resolution cannot use
this kind of local instance because it will not be able to infer a value for this parameter."
Factored out this as new class in `CategoryTheory.Limits.Preserves.Finite` -/
/-- If G preserves coequalizers and finite coproducts, it preserves finite colimits. -/
noncomputable def preservesFiniteColimitsOfPreservesCoequalizersAndFiniteCoproducts
    [HasCoequalizers C] [HasFiniteCoproducts C] (G : C ⥤ D)
    [PreservesColimitsOfShape WalkingParallelPair G]
    [PreservesFiniteCoproducts G] : PreservesFiniteColimits G where
  preservesFiniteColimits := by
    intro J sJ fJ
    haveI : Fintype J := inferInstance
    haveI : Fintype ((p : J × J) × (p.fst ⟶  p.snd)) := inferInstance
    apply @preservesColimitOfPreservesCoequalizersAndCoproduct _ _ _ sJ _ _ ?_ ?_ _ G _ ?_ ?_
    · apply hasColimitsOfShape_discrete _ _
    · apply hasColimitsOfShape_discrete _
    · apply PreservesFiniteCoproducts.preserves _
    · apply PreservesFiniteCoproducts.preserves _
#align category_theory.limits.preserves_finite_colimits_of_preserves_coequalizers_and_finite_coproducts CategoryTheory.Limits.preservesFiniteColimitsOfPreservesCoequalizersAndFiniteCoproducts

/-- If G preserves coequalizers and coproducts, it preserves all colimits. -/
noncomputable def preservesColimitsOfPreservesCoequalizersAndCoproducts [HasCoequalizers C]
    [HasCoproducts.{w} C] (G : C ⥤ D) [PreservesColimitsOfShape WalkingParallelPair G]
    [∀ J, PreservesColimitsOfShape (Discrete.{w} J) G] : PreservesColimitsOfSize.{w} G where
  preservesColimitsOfShape := preservesColimitOfPreservesCoequalizersAndCoproduct G
#align category_theory.limits.preserves_colimits_of_preserves_coequalizers_and_coproducts CategoryTheory.Limits.preservesColimitsOfPreservesCoequalizersAndCoproducts

theorem hasFiniteColimits_of_hasInitial_and_pushouts [HasInitial C] [HasPushouts C] :
    HasFiniteColimits C :=
  @hasFiniteColimits_of_hasCoequalizers_and_finite_coproducts C _
    (@hasFiniteCoproducts_of_has_binary_and_initial C _
      (hasBinaryCoproducts_of_hasInitial_and_pushouts C) inferInstance)
    (@hasCoequalizers_of_hasPushouts_and_binary_coproducts C _
      (hasBinaryCoproducts_of_hasInitial_and_pushouts C) inferInstance)
#align category_theory.limits.has_finite_colimits_of_has_initial_and_pushouts CategoryTheory.Limits.hasFiniteColimits_of_hasInitial_and_pushouts

/-- If G preserves initial objects and pushouts, it preserves all finite colimits. -/
noncomputable def preservesFiniteColimitsOfPreservesInitialAndPushouts [HasInitial C]
    [HasPushouts C] (G : C ⥤ D) [PreservesColimitsOfShape (Discrete.{0} PEmpty) G]
    [PreservesColimitsOfShape WalkingSpan G] : PreservesFiniteColimits G := by
  haveI : HasFiniteColimits C := hasFiniteColimits_of_hasInitial_and_pushouts
  haveI : PreservesColimitsOfShape (Discrete WalkingPair) G :=
    preservesBinaryCoproductsOfPreservesInitialAndPushouts G
  haveI : PreservesColimitsOfShape (WalkingParallelPair) G :=
      (preservesCoequalizersOfPreservesPushoutsAndBinaryCoproducts G)
  refine
    @preservesFiniteColimitsOfPreservesCoequalizersAndFiniteCoproducts _ _ _ _ _ _ G _ ?_
  apply PreservesFiniteCoproducts.mk
  apply preservesFiniteCoproductsOfPreservesBinaryAndInitial G

#align category_theory.limits.preserves_finite_colimits_of_preserves_initial_and_pushouts CategoryTheory.Limits.preservesFiniteColimitsOfPreservesInitialAndPushouts

end CategoryTheory.Limits


/-
Copyright (c) 2020 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Thomas Browning, Patrick Lutz
-/

import field_theory.adjoin
import field_theory.tower
import group_theory.solvable
import ring_theory.power_basis

/-!
# Normal field extensions

In this file we define normal field extensions and prove that for a finite extension, being normal
is the same as being a splitting field (`normal.of_is_splitting_field` and
`normal.exists_is_splitting_field`).

## Main Definitions

- `normal F K` where `K` is a field extension of `F`.
-/

noncomputable theory

open_locale big_operators
open_locale classical

open polynomial is_scalar_tower

variables (F K : Type*) [field F] [field K] [algebra F K]

--TODO(Commelin): refactor normal to extend `is_algebraic`??

/-- Typeclass for normal field extension: `K` is a normal extension of `F` iff the minimal
polynomial of every element `x` in `K` splits in `K`, i.e. every conjugate of `x` is in `K`. -/
class normal : Prop :=
(is_integral' (x : K) : is_integral F x)
(splits' (x : K) : splits (algebra_map F K) (minpoly F x))

variables {F K}

theorem normal.is_integral (h : normal F K) (x : K) : is_integral F x := normal.is_integral' x

theorem normal.splits (h : normal F K) (x : K) :
  splits (algebra_map F K) (minpoly F x) := normal.splits' x

theorem normal_iff : normal F K ↔
  ∀ x : K, is_integral F x ∧ splits (algebra_map F K) (minpoly F x) :=
⟨λ h x, ⟨h.is_integral x, h.splits x⟩, λ h, ⟨λ x, (h x).1, λ x, (h x).2⟩⟩

theorem normal.out : normal F K →
  ∀ x : K, is_integral F x ∧ splits (algebra_map F K) (minpoly F x) := normal_iff.1

variables (F K)

instance normal_self : normal F F :=
⟨λ x, is_integral_algebra_map, λ x, by { rw minpoly.eq_X_sub_C', exact splits_X_sub_C _ }⟩

variables {K}

variables (K)

theorem normal.exists_is_splitting_field [h : normal F K] [finite_dimensional F K] :
  ∃ p : polynomial F, is_splitting_field F K p :=
begin
  let s := basis.of_vector_space F K,
  refine ⟨∏ x, minpoly F (s x),
    splits_prod _ $ λ x hx, h.splits (s x),
    subalgebra.to_submodule_injective _⟩,
  rw [algebra.top_to_submodule, eq_top_iff, ← s.span_eq, submodule.span_le, set.range_subset_iff],
  refine λ x, algebra.subset_adjoin (multiset.mem_to_finset.mpr $
    (mem_roots $ mt (map_eq_zero $ algebra_map F K).1 $
    finset.prod_ne_zero_iff.2 $ λ x hx, _).2 _),
  { exact minpoly.ne_zero (h.is_integral (s x)) },
  rw [is_root.def, eval_map, ← aeval_def, alg_hom.map_prod],
  exact finset.prod_eq_zero (finset.mem_univ _) (minpoly.aeval _ _)
end

section normal_tower

variables (E : Type*) [field E] [algebra F E] [algebra K E] [is_scalar_tower F K E]

lemma normal.tower_top_of_normal [h : normal F E] : normal K E :=
normal_iff.2 $ λ x, begin
  cases h.out x with hx hhx,
  rw algebra_map_eq F K E at hhx,
  exact ⟨is_integral_of_is_scalar_tower x hx, polynomial.splits_of_splits_of_dvd (algebra_map K E)
    (polynomial.map_ne_zero (minpoly.ne_zero hx))
    ((polynomial.splits_map_iff (algebra_map F K) (algebra_map K E)).mpr hhx)
    (minpoly.dvd_map_of_is_scalar_tower F K x)⟩,
end

lemma alg_hom.normal_bijective [h : normal F E] (ϕ : E →ₐ[F] K) : function.bijective ϕ :=
⟨ϕ.to_ring_hom.injective, λ x, by
{ letI : algebra E K := ϕ.to_ring_hom.to_algebra,
  obtain ⟨h1, h2⟩ := h.out (algebra_map K E x),
  cases minpoly.mem_range_of_degree_eq_one E x (or.resolve_left h2 (minpoly.ne_zero h1)
    (minpoly.irreducible (is_integral_of_is_scalar_tower x
      ((is_integral_algebra_map_iff (algebra_map K E).injective).mp h1)))
    (minpoly.dvd E x ((algebra_map K E).injective (by
    { rw [ring_hom.map_zero, aeval_map, ←is_scalar_tower.to_alg_hom_apply F K E,
          ←alg_hom.comp_apply, ←aeval_alg_hom],
      exact minpoly.aeval F (algebra_map K E x) })))) with y hy,
  exact ⟨y, hy⟩ }⟩

variables {F} {E} {E' : Type*} [field E'] [algebra F E']

lemma normal.of_alg_equiv [h : normal F E] (f : E ≃ₐ[F] E') : normal F E' :=
normal_iff.2 $ λ x, begin
  cases h.out (f.symm x) with hx hhx,
  have H := is_integral_alg_hom f.to_alg_hom hx,
  rw [alg_equiv.to_alg_hom_eq_coe, alg_equiv.coe_alg_hom, alg_equiv.apply_symm_apply] at H,
  use H,
  apply polynomial.splits_of_splits_of_dvd (algebra_map F E') (minpoly.ne_zero hx),
  { rw ← alg_hom.comp_algebra_map f.to_alg_hom,
    exact polynomial.splits_comp_of_splits (algebra_map F E) f.to_alg_hom.to_ring_hom hhx },
  { apply minpoly.dvd _ _,
    rw ← add_equiv.map_eq_zero_iff f.symm.to_add_equiv,
    exact eq.trans (polynomial.aeval_alg_hom_apply f.symm.to_alg_hom x
      (minpoly F (f.symm x))).symm (minpoly.aeval _ _) },
end

lemma alg_equiv.transfer_normal (f : E ≃ₐ[F] E') : normal F E ↔ normal F E' :=
⟨λ h, by exactI normal.of_alg_equiv f, λ h, by exactI normal.of_alg_equiv f.symm⟩

lemma normal.of_is_splitting_field (p : polynomial F) [hFEp : is_splitting_field F E p] :
  normal F E :=
begin
  by_cases hp : p = 0,
  { haveI : is_splitting_field F F p, { rw hp, exact ⟨splits_zero _, subsingleton.elim _ _⟩ },
    exactI (alg_equiv.transfer_normal ((is_splitting_field.alg_equiv F p).trans
      (is_splitting_field.alg_equiv E p).symm)).mp (normal_self F) },
  refine normal_iff.2 (λ x, _),
  haveI hFE : finite_dimensional F E := is_splitting_field.finite_dimensional E p,
  have Hx : is_integral F x := is_integral_of_noetherian (is_noetherian.iff_fg.2 hFE) x,
  refine ⟨Hx, or.inr _⟩,
  rintros q q_irred ⟨r, hr⟩,
  let D := adjoin_root q,
  let pbED := adjoin_root.power_basis q_irred.ne_zero,
  haveI : finite_dimensional E D := power_basis.finite_dimensional pbED,
  have finrankED : finite_dimensional.finrank E D = q.nat_degree := power_basis.finrank pbED,
  letI : algebra F D := ring_hom.to_algebra ((algebra_map E D).comp (algebra_map F E)),
  haveI : is_scalar_tower F E D := of_algebra_map_eq (λ _, rfl),
  haveI : finite_dimensional F D := finite_dimensional.trans F E D,
  suffices : nonempty (D →ₐ[F] E),
  { cases this with ϕ,
    rw [←with_bot.coe_one, degree_eq_iff_nat_degree_eq q_irred.ne_zero, ←finrankED],
    have nat_lemma : ∀ a b c : ℕ, a * b = c → c ≤ a → 0 < c → b = 1,
    { intros a b c h1 h2 h3, nlinarith },
    exact nat_lemma _ _ _ (finite_dimensional.finrank_mul_finrank F E D)
      (linear_map.finrank_le_finrank_of_injective (show function.injective ϕ.to_linear_map,
        from ϕ.to_ring_hom.injective)) finite_dimensional.finrank_pos, },
  let C := adjoin_root (minpoly F x),
  have Hx_irred := minpoly.irreducible Hx,
  letI : algebra C D := ring_hom.to_algebra (adjoin_root.lift
    (algebra_map F D) (adjoin_root.root q) (by rw [algebra_map_eq F E D, ←eval₂_map, hr,
      adjoin_root.algebra_map_eq, eval₂_mul, adjoin_root.eval₂_root, zero_mul])),
  letI : algebra C E := ring_hom.to_algebra (adjoin_root.lift
    (algebra_map F E) x (minpoly.aeval F x)),
  haveI : is_scalar_tower F C D := of_algebra_map_eq (λ x, (adjoin_root.lift_of _).symm),
  haveI : is_scalar_tower F C E := of_algebra_map_eq (λ x, (adjoin_root.lift_of _).symm),
  suffices : nonempty (D →ₐ[C] E),
  { exact nonempty.map (alg_hom.restrict_scalars F) this },
  let S : set D := ((p.map (algebra_map F E)).roots.map (algebra_map E D)).to_finset,
  suffices : ⊤ ≤ intermediate_field.adjoin C S,
  { refine intermediate_field.alg_hom_mk_adjoin_splits' (top_le_iff.mp this) (λ y hy, _),
    rcases multiset.mem_map.mp (multiset.mem_to_finset.mp hy) with ⟨z, hz1, hz2⟩,
    have Hz : is_integral F z := is_integral_of_noetherian (is_noetherian.iff_fg.2 hFE) z,
    use (show is_integral C y, from is_integral_of_noetherian
      (is_noetherian.iff_fg.2 (finite_dimensional.right F C D)) y),
    apply splits_of_splits_of_dvd (algebra_map C E) (map_ne_zero (minpoly.ne_zero Hz)),
    { rw [splits_map_iff, ←algebra_map_eq F C E],
      exact splits_of_splits_of_dvd _ hp hFEp.splits (minpoly.dvd F z
        (eq.trans (eval₂_eq_eval_map _) ((mem_roots (map_ne_zero hp)).mp hz1))) },
    { apply minpoly.dvd,
      rw [←hz2, aeval_def, eval₂_map, ←algebra_map_eq F C D, algebra_map_eq F E D, ←hom_eval₂,
          ←aeval_def, minpoly.aeval F z, ring_hom.map_zero] } },
  rw [←intermediate_field.to_subalgebra_le_to_subalgebra, intermediate_field.top_to_subalgebra],
  apply ge_trans (intermediate_field.algebra_adjoin_le_adjoin C S),
  suffices : (algebra.adjoin C S).restrict_scalars F
           = (algebra.adjoin E {adjoin_root.root q}).restrict_scalars F,
  { rw [adjoin_root.adjoin_root_eq_top, subalgebra.restrict_scalars_top,
      ←@subalgebra.restrict_scalars_top F C] at this,
    exact top_le_iff.mpr (subalgebra.restrict_scalars_injective F this) },
  dsimp only [S],
  rw [←finset.image_to_finset, finset.coe_image],
  apply eq.trans (algebra.adjoin_res_eq_adjoin_res F E C D
    hFEp.adjoin_roots adjoin_root.adjoin_root_eq_top),
  rw [set.image_singleton, ring_hom.algebra_map_to_algebra, adjoin_root.lift_root]
end

instance (p : polynomial F) : normal F p.splitting_field := normal.of_is_splitting_field p

end normal_tower

variables {F} {K} (ϕ ψ : K →ₐ[F] K) (χ ω : K ≃ₐ[F] K)

section restrict

variables (E : Type*) [field E] [algebra F E] [algebra E K] [is_scalar_tower F E K]

/-- Restrict algebra homomorphism to image of normal subfield -/
def alg_hom.restrict_normal_aux [h : normal F E] :
  (to_alg_hom F E K).range →ₐ[F] (to_alg_hom F E K).range :=
{ to_fun := λ x, ⟨ϕ x, by
  { suffices : (to_alg_hom F E K).range.map ϕ ≤ _,
    { exact this ⟨x, subtype.mem x, rfl⟩ },
    rintros x ⟨y, ⟨z, hy⟩, hx⟩,
    rw [←hx, ←hy],
    apply minpoly.mem_range_of_degree_eq_one E,
    exact or.resolve_left (h.splits z) (minpoly.ne_zero (h.is_integral z))
      (minpoly.irreducible $ is_integral_of_is_scalar_tower _ $
        is_integral_alg_hom ϕ $ is_integral_alg_hom _ $ h.is_integral z)
      (minpoly.dvd E _ $ by rw [aeval_map, aeval_alg_hom, aeval_alg_hom, alg_hom.comp_apply,
        alg_hom.comp_apply, minpoly.aeval, alg_hom.map_zero, alg_hom.map_zero]) }⟩,
  map_zero' := subtype.ext ϕ.map_zero,
  map_one' := subtype.ext ϕ.map_one,
  map_add' := λ x y, subtype.ext (ϕ.map_add x y),
  map_mul' := λ x y, subtype.ext (ϕ.map_mul x y),
  commutes' := λ x, subtype.ext (ϕ.commutes x) }

/-- Restrict algebra homomorphism to normal subfield -/
def alg_hom.restrict_normal [normal F E] : E →ₐ[F] E :=
((alg_equiv.of_injective_field (is_scalar_tower.to_alg_hom F E K)).symm.to_alg_hom.comp
  (ϕ.restrict_normal_aux E)).comp
    (alg_equiv.of_injective_field (is_scalar_tower.to_alg_hom F E K)).to_alg_hom

@[simp] lemma alg_hom.restrict_normal_commutes [normal F E] (x : E) :
  algebra_map E K (ϕ.restrict_normal E x) = ϕ (algebra_map E K x) :=
subtype.ext_iff.mp (alg_equiv.apply_symm_apply (alg_equiv.of_injective_field
  (is_scalar_tower.to_alg_hom F E K)) (ϕ.restrict_normal_aux E
    ⟨is_scalar_tower.to_alg_hom F E K x, x, rfl⟩))

lemma alg_hom.restrict_normal_comp [normal F E] :
  (ϕ.restrict_normal E).comp (ψ.restrict_normal E) = (ϕ.comp ψ).restrict_normal E :=
alg_hom.ext (λ _, (algebra_map E K).injective
  (by simp only [alg_hom.comp_apply, alg_hom.restrict_normal_commutes]))

/-- Restrict algebra isomorphism to a normal subfield -/
def alg_equiv.restrict_normal [h : normal F E] : E ≃ₐ[F] E :=
alg_equiv.of_bijective (χ.to_alg_hom.restrict_normal E) (alg_hom.normal_bijective F E E _)

@[simp] lemma alg_equiv.restrict_normal_commutes [normal F E] (x : E) :
  algebra_map E K (χ.restrict_normal E x) = χ (algebra_map E K x) :=
χ.to_alg_hom.restrict_normal_commutes E x

lemma alg_equiv.restrict_normal_trans [normal F E] :
  (χ.trans ω).restrict_normal E = (χ.restrict_normal E).trans (ω.restrict_normal E) :=
alg_equiv.ext (λ _, (algebra_map E K).injective
(by simp only [alg_equiv.trans_apply, alg_equiv.restrict_normal_commutes]))

/-- Restriction to an normal subfield as a group homomorphism -/
def alg_equiv.restrict_normal_hom [normal F E] : (K ≃ₐ[F] K) →* (E ≃ₐ[F] E) :=
monoid_hom.mk' (λ χ, χ.restrict_normal E) (λ ω χ, (χ.restrict_normal_trans ω E))

end restrict

section lift

variables {F} {K} (E : Type*) [field E] [algebra F E] [algebra K E] [is_scalar_tower F K E]

/-- If `E/K/F` is a tower of fields with `E/F` normal then we can lift
  an algebra homomorphism `ϕ : K →ₐ[F] K` to `ϕ.lift_normal E : E →ₐ[F] E`. -/
noncomputable def alg_hom.lift_normal [h : normal F E] : E →ₐ[F] E :=
@alg_hom.restrict_scalars F K E E _ _ _ _ _ _
  ((is_scalar_tower.to_alg_hom F K E).comp ϕ).to_ring_hom.to_algebra _ _ _ _
  (nonempty.some (@intermediate_field.alg_hom_mk_adjoin_splits' K E E _ _ _ _
  ((is_scalar_tower.to_alg_hom F K E).comp ϕ).to_ring_hom.to_algebra ⊤ rfl
  (λ x hx, ⟨is_integral_of_is_scalar_tower x (h.out x).1,
  splits_of_splits_of_dvd _ (map_ne_zero (minpoly.ne_zero (h.out x).1))
  (by { rw [splits_map_iff, ←is_scalar_tower.algebra_map_eq], exact (h.out x).2 })
  (minpoly.dvd_map_of_is_scalar_tower F K x)⟩)))

@[simp] lemma alg_hom.lift_normal_commutes [normal F E] (x : K) :
  ϕ.lift_normal E (algebra_map K E x) = algebra_map K E (ϕ x) :=
@alg_hom.commutes K E E _ _ _ _
  ((is_scalar_tower.to_alg_hom F K E).comp ϕ).to_ring_hom.to_algebra _ x

@[simp] lemma alg_hom.restrict_lift_normal [normal F K] [normal F E] :
  (ϕ.lift_normal E).restrict_normal K = ϕ :=
alg_hom.ext (λ x, (algebra_map K E).injective
  (eq.trans (alg_hom.restrict_normal_commutes _ K x) (ϕ.lift_normal_commutes E x)))

/-- If `E/K/F` is a tower of fields with `E/F` normal then we can lift
  an algebra isomorphism `ϕ : K ≃ₐ[F] K` to `ϕ.lift_normal E : E ≃ₐ[F] E`. -/
noncomputable def alg_equiv.lift_normal [normal F E] : E ≃ₐ[F] E :=
alg_equiv.of_bijective (χ.to_alg_hom.lift_normal E) (alg_hom.normal_bijective F E E _)

@[simp] lemma alg_equiv.lift_normal_commutes [normal F E] (x : K) :
  χ.lift_normal E (algebra_map K E x) = algebra_map K E (χ x) :=
χ.to_alg_hom.lift_normal_commutes E x

@[simp] lemma alg_equiv.restrict_lift_normal [normal F K] [normal F E] :
  (χ.lift_normal E).restrict_normal K = χ :=
alg_equiv.ext (λ x, (algebra_map K E).injective
  (eq.trans (alg_equiv.restrict_normal_commutes _ K x) (χ.lift_normal_commutes E x)))

lemma alg_equiv.restrict_normal_hom_surjective [normal F K] [normal F E] :
  function.surjective (alg_equiv.restrict_normal_hom K : (E ≃ₐ[F] E) → (K ≃ₐ[F] K)) :=
λ χ, ⟨χ.lift_normal E, χ.restrict_lift_normal E⟩

variables (F) (K) (E)

lemma is_solvable_of_is_scalar_tower [normal F K] [h1 : is_solvable (K ≃ₐ[F] K)]
  [h2 : is_solvable (E ≃ₐ[K] E)] : is_solvable (E ≃ₐ[F] E) :=
begin
  let f : (E ≃ₐ[K] E) →* (E ≃ₐ[F] E) :=
  { to_fun := λ ϕ, alg_equiv.of_alg_hom (ϕ.to_alg_hom.restrict_scalars F)
      (ϕ.symm.to_alg_hom.restrict_scalars F)
      (alg_hom.ext (λ x, ϕ.apply_symm_apply x))
      (alg_hom.ext (λ x, ϕ.symm_apply_apply x)),
    map_one' := alg_equiv.ext (λ _, rfl),
    map_mul' := λ _ _, alg_equiv.ext (λ _, rfl) },
  refine solvable_of_ker_le_range f (alg_equiv.restrict_normal_hom K)
    (λ ϕ hϕ, ⟨{commutes' := λ x, _, .. ϕ}, alg_equiv.ext (λ _, rfl)⟩),
  exact (eq.trans (ϕ.restrict_normal_commutes K x).symm (congr_arg _ (alg_equiv.ext_iff.mp hϕ x))),
end

end lift


import data.finsupp.basic

section

/-- An inductive type from which to index the variables of the multi-variable polynomials the proof manages -/
@[derive decidable_eq]
inductive vars : Type
| r_v : vars
| r_w : vars
| α_v : vars
| α_w : vars
| α_y : vars
| β : vars
| γ : vars

lemma finsupp_vars_eq_ext (f g : vars →₀ ℕ) : f = g ↔
  f vars.r_v = g vars.r_v
  ∧ f vars.r_w = g vars.r_w
  ∧ f vars.α_v = g vars.α_v
  ∧ f vars.α_w = g vars.α_w
  ∧ f vars.α_y = g vars.α_y
  ∧ f vars.β = g vars.β
  ∧ f vars.γ = g vars.γ :=
begin
  rw finsupp.ext_iff,
  split,
    {
      intro h,
      split, exact h vars.r_v,
      split, exact h vars.r_w,
      split, exact h vars.α_v,
      split, exact h vars.α_w,
      split, exact h vars.α_y,
      split, exact h vars.β,
      exact h vars.γ,
    },
    {
      intro h,
      intro a,
      induction a,
      finish,
      finish,
      finish,
      finish,
      finish,
      finish,
      finish,
    },
  -- induction,
end

end


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.multiset.finset_ops
import Mathlib.data.multiset.fold
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# Lattice operations on multisets
-/

namespace multiset

/-! ### sup -/

/-- Supremum of a multiset: `sup {a, b, c} = a ⊔ b ⊔ c` -/
def sup {α : Type u_1} [semilattice_sup_bot α] (s : multiset α) : α := fold has_sup.sup ⊥ s

@[simp] theorem sup_zero {α : Type u_1} [semilattice_sup_bot α] : sup 0 = ⊥ :=
  fold_zero has_sup.sup ⊥

@[simp] theorem sup_cons {α : Type u_1} [semilattice_sup_bot α] (a : α) (s : multiset α) :
    sup (a ::ₘ s) = a ⊔ sup s :=
  fold_cons_left has_sup.sup ⊥ a s

@[simp] theorem sup_singleton {α : Type u_1} [semilattice_sup_bot α] {a : α} : sup (a ::ₘ 0) = a :=
  sorry

@[simp] theorem sup_add {α : Type u_1} [semilattice_sup_bot α] (s₁ : multiset α) (s₂ : multiset α) :
    sup (s₁ + s₂) = sup s₁ ⊔ sup s₂ :=
  sorry

theorem sup_le {α : Type u_1} [semilattice_sup_bot α] {s : multiset α} {a : α} :
    sup s ≤ a ↔ ∀ (b : α), b ∈ s → b ≤ a :=
  sorry

theorem le_sup {α : Type u_1} [semilattice_sup_bot α] {s : multiset α} {a : α} (h : a ∈ s) :
    a ≤ sup s :=
  iff.mp sup_le (le_refl (sup s)) a h

theorem sup_mono {α : Type u_1} [semilattice_sup_bot α] {s₁ : multiset α} {s₂ : multiset α}
    (h : s₁ ⊆ s₂) : sup s₁ ≤ sup s₂ :=
  iff.mpr sup_le fun (b : α) (hb : b ∈ s₁) => le_sup (h hb)

@[simp] theorem sup_erase_dup {α : Type u_1} [semilattice_sup_bot α] [DecidableEq α]
    (s : multiset α) : sup (erase_dup s) = sup s :=
  fold_erase_dup_idem has_sup.sup s ⊥

@[simp] theorem sup_ndunion {α : Type u_1} [semilattice_sup_bot α] [DecidableEq α] (s₁ : multiset α)
    (s₂ : multiset α) : sup (ndunion s₁ s₂) = sup s₁ ⊔ sup s₂ :=
  sorry

@[simp] theorem sup_union {α : Type u_1} [semilattice_sup_bot α] [DecidableEq α] (s₁ : multiset α)
    (s₂ : multiset α) : sup (s₁ ∪ s₂) = sup s₁ ⊔ sup s₂ :=
  sorry

@[simp] theorem sup_ndinsert {α : Type u_1} [semilattice_sup_bot α] [DecidableEq α] (a : α)
    (s : multiset α) : sup (ndinsert a s) = a ⊔ sup s :=
  sorry

/-! ### inf -/

/-- Infimum of a multiset: `inf {a, b, c} = a ⊓ b ⊓ c` -/
def inf {α : Type u_1} [semilattice_inf_top α] (s : multiset α) : α := fold has_inf.inf ⊤ s

@[simp] theorem inf_zero {α : Type u_1} [semilattice_inf_top α] : inf 0 = ⊤ :=
  fold_zero has_inf.inf ⊤

@[simp] theorem inf_cons {α : Type u_1} [semilattice_inf_top α] (a : α) (s : multiset α) :
    inf (a ::ₘ s) = a ⊓ inf s :=
  fold_cons_left has_inf.inf ⊤ a s

@[simp] theorem inf_singleton {α : Type u_1} [semilattice_inf_top α] {a : α} : inf (a ::ₘ 0) = a :=
  sorry

@[simp] theorem inf_add {α : Type u_1} [semilattice_inf_top α] (s₁ : multiset α) (s₂ : multiset α) :
    inf (s₁ + s₂) = inf s₁ ⊓ inf s₂ :=
  sorry

theorem le_inf {α : Type u_1} [semilattice_inf_top α] {s : multiset α} {a : α} :
    a ≤ inf s ↔ ∀ (b : α), b ∈ s → a ≤ b :=
  sorry

theorem inf_le {α : Type u_1} [semilattice_inf_top α] {s : multiset α} {a : α} (h : a ∈ s) :
    inf s ≤ a :=
  iff.mp le_inf (le_refl (inf s)) a h

theorem inf_mono {α : Type u_1} [semilattice_inf_top α] {s₁ : multiset α} {s₂ : multiset α}
    (h : s₁ ⊆ s₂) : inf s₂ ≤ inf s₁ :=
  iff.mpr le_inf fun (b : α) (hb : b ∈ s₁) => inf_le (h hb)

@[simp] theorem inf_erase_dup {α : Type u_1} [semilattice_inf_top α] [DecidableEq α]
    (s : multiset α) : inf (erase_dup s) = inf s :=
  fold_erase_dup_idem has_inf.inf s ⊤

@[simp] theorem inf_ndunion {α : Type u_1} [semilattice_inf_top α] [DecidableEq α] (s₁ : multiset α)
    (s₂ : multiset α) : inf (ndunion s₁ s₂) = inf s₁ ⊓ inf s₂ :=
  sorry

@[simp] theorem inf_union {α : Type u_1} [semilattice_inf_top α] [DecidableEq α] (s₁ : multiset α)
    (s₂ : multiset α) : inf (s₁ ∪ s₂) = inf s₁ ⊓ inf s₂ :=
  sorry

@[simp] theorem inf_ndinsert {α : Type u_1} [semilattice_inf_top α] [DecidableEq α] (a : α)
    (s : multiset α) : inf (ndinsert a s) = a ⊓ inf s :=
  sorry

end Mathlib