/-
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

! This file was ported from Lean 3 source module analysis.normed_space.banach
! leanprover-community/mathlib commit f2ce6086713c78a7f880485f7917ea547a215982
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Topology.MetricSpace.Baire
import Mathbin.Analysis.NormedSpace.OperatorNorm
import Mathbin.Analysis.NormedSpace.AffineIsometry

/-!
# Banach open mapping theorem

This file contains the Banach open mapping theorem, i.e., the fact that a bijective
bounded linear map between Banach spaces has a bounded inverse.
-/

open Function Metric Set Filter Finset

open LinearMap (range ker)

open Classical Topology BigOperators NNReal

variable {𝕜 : Type _} [NontriviallyNormedField 𝕜] {E : Type _} [NormedAddCommGroup E]
  [NormedSpace 𝕜 E] {F : Type _} [NormedAddCommGroup F] [NormedSpace 𝕜 F] (f : E →L[𝕜] F)

include 𝕜

namespace ContinuousLinearMap

/-- A (possibly nonlinear) right inverse to a continuous linear map, which doesn't have to be
linear itself but which satisfies a bound `‖inverse x‖ ≤ C * ‖x‖`. A surjective continuous linear
map doesn't always have a continuous linear right inverse, but it always has a nonlinear inverse
in this sense, by Banach's open mapping theorem. -/
structure NonlinearRightInverse where
  toFun : F → E
  nnnorm : ℝ≥0
  bound' : ∀ y, ‖to_fun y‖ ≤ nnnorm * ‖y‖
  right_inv' : ∀ y, f (to_fun y) = y
#align continuous_linear_map.nonlinear_right_inverse ContinuousLinearMap.NonlinearRightInverse

instance : CoeFun (NonlinearRightInverse f) fun _ => F → E :=
  ⟨fun fsymm => fsymm.toFun⟩

@[simp]
theorem NonlinearRightInverse.right_inv {f : E →L[𝕜] F} (fsymm : NonlinearRightInverse f) (y : F) :
    f (fsymm y) = y :=
  fsymm.right_inv' y
#align continuous_linear_map.nonlinear_right_inverse.right_inv ContinuousLinearMap.NonlinearRightInverse.right_inv

theorem NonlinearRightInverse.bound {f : E →L[𝕜] F} (fsymm : NonlinearRightInverse f) (y : F) :
    ‖fsymm y‖ ≤ fsymm.nnnorm * ‖y‖ :=
  fsymm.bound' y
#align continuous_linear_map.nonlinear_right_inverse.bound ContinuousLinearMap.NonlinearRightInverse.bound

end ContinuousLinearMap

/-- Given a continuous linear equivalence, the inverse is in particular an instance of
`nonlinear_right_inverse` (which turns out to be linear). -/
noncomputable def ContinuousLinearEquiv.toNonlinearRightInverse (f : E ≃L[𝕜] F) :
    ContinuousLinearMap.NonlinearRightInverse (f : E →L[𝕜] F)
    where
  toFun := f.invFun
  nnnorm := ‖(f.symm : F →L[𝕜] E)‖₊
  bound' y := ContinuousLinearMap.le_op_norm (f.symm : F →L[𝕜] E) _
  right_inv' := f.apply_symm_apply
#align continuous_linear_equiv.to_nonlinear_right_inverse ContinuousLinearEquiv.toNonlinearRightInverse

noncomputable instance (f : E ≃L[𝕜] F) :
    Inhabited (ContinuousLinearMap.NonlinearRightInverse (f : E →L[𝕜] F)) :=
  ⟨f.toNonlinearRightInverse⟩

/-! ### Proof of the Banach open mapping theorem -/

variable [CompleteSpace F]

namespace ContinuousLinearMap

/-- First step of the proof of the Banach open mapping theorem (using completeness of `F`):
by Baire's theorem, there exists a ball in `E` whose image closure has nonempty interior.
Rescaling everything, it follows that any `y ∈ F` is arbitrarily well approached by
images of elements of norm at most `C * ‖y‖`.
For further use, we will only need such an element whose image
is within distance `‖y‖/2` of `y`, to apply an iterative process. -/
theorem exists_approx_preimage_norm_le (surj : Surjective f) :
    ∃ C ≥ 0, ∀ y, ∃ x, dist (f x) y ≤ 1 / 2 * ‖y‖ ∧ ‖x‖ ≤ C * ‖y‖ :=
  by
  have A : (⋃ n : ℕ, closure (f '' ball 0 n)) = univ :=
    by
    refine' subset.antisymm (subset_univ _) fun y hy => _
    rcases surj y with ⟨x, hx⟩
    rcases exists_nat_gt ‖x‖ with ⟨n, hn⟩
    refine' mem_Union.2 ⟨n, subset_closure _⟩
    refine' (mem_image _ _ _).2 ⟨x, ⟨_, hx⟩⟩
    rwa [mem_ball, dist_eq_norm, sub_zero]
  have : ∃ (n : ℕ)(x : _), x ∈ interior (closure (f '' ball 0 n)) :=
    nonempty_interior_of_unionᵢ_of_closed (fun n => isClosed_closure) A
  simp only [mem_interior_iff_mem_nhds, Metric.mem_nhds_iff] at this
  rcases this with ⟨n, a, ε, ⟨εpos, H⟩⟩
  rcases NormedField.exists_one_lt_norm 𝕜 with ⟨c, hc⟩
  refine' ⟨(ε / 2)⁻¹ * ‖c‖ * 2 * n, _, fun y => _⟩
  · refine' mul_nonneg (mul_nonneg (mul_nonneg _ (norm_nonneg _)) (by norm_num)) _
    exacts[inv_nonneg.2 (div_nonneg (le_of_lt εpos) (by norm_num)), n.cast_nonneg]
  · by_cases hy : y = 0
    · use 0
      simp [hy]
    · rcases rescale_to_shell hc (half_pos εpos) hy with ⟨d, hd, ydlt, leyd, dinv⟩
      let δ := ‖d‖ * ‖y‖ / 4
      have δpos : 0 < δ := div_pos (mul_pos (norm_pos_iff.2 hd) (norm_pos_iff.2 hy)) (by norm_num)
      have : a + d • y ∈ ball a ε := by
        simp [dist_eq_norm, lt_of_le_of_lt ydlt.le (half_lt_self εpos)]
      rcases Metric.mem_closure_iff.1 (H this) _ δpos with ⟨z₁, z₁im, h₁⟩
      rcases(mem_image _ _ _).1 z₁im with ⟨x₁, hx₁, xz₁⟩
      rw [← xz₁] at h₁
      rw [mem_ball, dist_eq_norm, sub_zero] at hx₁
      have : a ∈ ball a ε := by
        simp
        exact εpos
      rcases Metric.mem_closure_iff.1 (H this) _ δpos with ⟨z₂, z₂im, h₂⟩
      rcases(mem_image _ _ _).1 z₂im with ⟨x₂, hx₂, xz₂⟩
      rw [← xz₂] at h₂
      rw [mem_ball, dist_eq_norm, sub_zero] at hx₂
      let x := x₁ - x₂
      have I : ‖f x - d • y‖ ≤ 2 * δ :=
        calc
          ‖f x - d • y‖ = ‖f x₁ - (a + d • y) - (f x₂ - a)‖ :=
            by
            congr 1
            simp only [x, f.map_sub]
            abel
          _ ≤ ‖f x₁ - (a + d • y)‖ + ‖f x₂ - a‖ := (norm_sub_le _ _)
          _ ≤ δ + δ := by
            apply add_le_add
            · rw [← dist_eq_norm, dist_comm]
              exact le_of_lt h₁
            · rw [← dist_eq_norm, dist_comm]
              exact le_of_lt h₂
          _ = 2 * δ := (two_mul _).symm

      have J : ‖f (d⁻¹ • x) - y‖ ≤ 1 / 2 * ‖y‖ :=
        calc
          ‖f (d⁻¹ • x) - y‖ = ‖d⁻¹ • f x - (d⁻¹ * d) • y‖ := by
            rwa [f.map_smul _, inv_mul_cancel, one_smul]
          _ = ‖d⁻¹ • (f x - d • y)‖ := by rw [mul_smul, smul_sub]
          _ = ‖d‖⁻¹ * ‖f x - d • y‖ := by rw [norm_smul, norm_inv]
          _ ≤ ‖d‖⁻¹ * (2 * δ) := by
            apply mul_le_mul_of_nonneg_left I
            rw [inv_nonneg]
            exact norm_nonneg _
          _ = ‖d‖⁻¹ * ‖d‖ * ‖y‖ / 2 := by
            simp only [δ]
            ring
          _ = ‖y‖ / 2 := by
            rw [inv_mul_cancel, one_mul]
            simp [norm_eq_zero, hd]
          _ = 1 / 2 * ‖y‖ := by ring

      rw [← dist_eq_norm] at J
      have K : ‖d⁻¹ • x‖ ≤ (ε / 2)⁻¹ * ‖c‖ * 2 * ↑n * ‖y‖ :=
        calc
          ‖d⁻¹ • x‖ = ‖d‖⁻¹ * ‖x₁ - x₂‖ := by rw [norm_smul, norm_inv]
          _ ≤ (ε / 2)⁻¹ * ‖c‖ * ‖y‖ * (n + n) :=
            by
            refine' mul_le_mul dinv _ (norm_nonneg _) _
            · exact le_trans (norm_sub_le _ _) (add_le_add (le_of_lt hx₁) (le_of_lt hx₂))
            · apply mul_nonneg (mul_nonneg _ (norm_nonneg _)) (norm_nonneg _)
              exact inv_nonneg.2 (le_of_lt (half_pos εpos))
          _ = (ε / 2)⁻¹ * ‖c‖ * 2 * ↑n * ‖y‖ := by ring

      exact ⟨d⁻¹ • x, J, K⟩
#align continuous_linear_map.exists_approx_preimage_norm_le ContinuousLinearMap.exists_approx_preimage_norm_le

variable [CompleteSpace E]

/-- The Banach open mapping theorem: if a bounded linear map between Banach spaces is onto, then
any point has a preimage with controlled norm. -/
theorem exists_preimage_norm_le (surj : Surjective f) :
    ∃ C > 0, ∀ y, ∃ x, f x = y ∧ ‖x‖ ≤ C * ‖y‖ :=
  by
  obtain ⟨C, C0, hC⟩ := exists_approx_preimage_norm_le f surj
  /- Second step of the proof: starting from `y`, we want an exact preimage of `y`. Let `g y` be
    the approximate preimage of `y` given by the first step, and `h y = y - f(g y)` the part that
    has no preimage yet. We will iterate this process, taking the approximate preimage of `h y`,
    leaving only `h^2 y` without preimage yet, and so on. Let `u n` be the approximate preimage
    of `h^n y`. Then `u` is a converging series, and by design the sum of the series is a
    preimage of `y`. This uses completeness of `E`. -/
  choose g hg using hC
  let h y := y - f (g y)
  have hle : ∀ y, ‖h y‖ ≤ 1 / 2 * ‖y‖ := by
    intro y
    rw [← dist_eq_norm, dist_comm]
    exact (hg y).1
  refine' ⟨2 * C + 1, by linarith, fun y => _⟩
  have hnle : ∀ n : ℕ, ‖(h^[n]) y‖ ≤ (1 / 2) ^ n * ‖y‖ :=
    by
    intro n
    induction' n with n IH
    · simp only [one_div, Nat.zero_eq, one_mul, iterate_zero_apply, pow_zero]
    · rw [iterate_succ']
      apply le_trans (hle _) _
      rw [pow_succ, mul_assoc]
      apply mul_le_mul_of_nonneg_left IH
      norm_num
  let u n := g ((h^[n]) y)
  have ule : ∀ n, ‖u n‖ ≤ (1 / 2) ^ n * (C * ‖y‖) :=
    by
    intro n
    apply le_trans (hg _).2 _
    calc
      C * ‖(h^[n]) y‖ ≤ C * ((1 / 2) ^ n * ‖y‖) := mul_le_mul_of_nonneg_left (hnle n) C0
      _ = (1 / 2) ^ n * (C * ‖y‖) := by ring

  have sNu : Summable fun n => ‖u n‖ :=
    by
    refine' summable_of_nonneg_of_le (fun n => norm_nonneg _) ule _
    exact Summable.mul_right _ (summable_geometric_of_lt_1 (by norm_num) (by norm_num))
  have su : Summable u := summable_of_summable_norm sNu
  let x := tsum u
  have x_ineq : ‖x‖ ≤ (2 * C + 1) * ‖y‖ :=
    calc
      ‖x‖ ≤ ∑' n, ‖u n‖ := norm_tsum_le_tsum_norm sNu
      _ ≤ ∑' n, (1 / 2) ^ n * (C * ‖y‖) :=
        (tsum_le_tsum ule sNu (Summable.mul_right _ summable_geometric_two))
      _ = (∑' n, (1 / 2) ^ n) * (C * ‖y‖) := tsum_mul_right
      _ = 2 * C * ‖y‖ := by rw [tsum_geometric_two, mul_assoc]
      _ ≤ 2 * C * ‖y‖ + ‖y‖ := (le_add_of_nonneg_right (norm_nonneg y))
      _ = (2 * C + 1) * ‖y‖ := by ring

  have fsumeq : ∀ n : ℕ, f (∑ i in Finset.range n, u i) = y - (h^[n]) y :=
    by
    intro n
    induction' n with n IH
    · simp [f.map_zero]
    · rw [sum_range_succ, f.map_add, IH, iterate_succ', sub_add]
  have : tendsto (fun n => ∑ i in Finset.range n, u i) at_top (𝓝 x) := su.has_sum.tendsto_sum_nat
  have L₁ : tendsto (fun n => f (∑ i in Finset.range n, u i)) at_top (𝓝 (f x)) :=
    (f.continuous.tendsto _).comp this
  simp only [fsumeq] at L₁
  have L₂ : tendsto (fun n => y - (h^[n]) y) at_top (𝓝 (y - 0)) :=
    by
    refine' tendsto_const_nhds.sub _
    rw [tendsto_iff_norm_tendsto_zero]
    simp only [sub_zero]
    refine' squeeze_zero (fun _ => norm_nonneg _) hnle _
    rw [← MulZeroClass.zero_mul ‖y‖]
    refine' (tendsto_pow_atTop_nhds_0_of_lt_1 _ _).mul tendsto_const_nhds <;> norm_num
  have feq : f x = y - 0 := tendsto_nhds_unique L₁ L₂
  rw [sub_zero] at feq
  exact ⟨x, feq, x_ineq⟩
#align continuous_linear_map.exists_preimage_norm_le ContinuousLinearMap.exists_preimage_norm_le

/-- The Banach open mapping theorem: a surjective bounded linear map between Banach spaces is
open. -/
protected theorem isOpenMap (surj : Surjective f) : IsOpenMap f :=
  by
  intro s hs
  rcases exists_preimage_norm_le f surj with ⟨C, Cpos, hC⟩
  refine' is_open_iff.2 fun y yfs => _
  rcases mem_image_iff_bex.1 yfs with ⟨x, xs, fxy⟩
  rcases is_open_iff.1 hs x xs with ⟨ε, εpos, hε⟩
  refine' ⟨ε / C, div_pos εpos Cpos, fun z hz => _⟩
  rcases hC (z - y) with ⟨w, wim, wnorm⟩
  have : f (x + w) = z := by rw [f.map_add, wim, fxy, add_sub_cancel'_right]
  rw [← this]
  have : x + w ∈ ball x ε :=
    calc
      dist (x + w) x = ‖w‖ := by
        rw [dist_eq_norm]
        simp
      _ ≤ C * ‖z - y‖ := wnorm
      _ < C * (ε / C) := by
        apply mul_lt_mul_of_pos_left _ Cpos
        rwa [mem_ball, dist_eq_norm] at hz
      _ = ε := mul_div_cancel' _ (ne_of_gt Cpos)

  exact Set.mem_image_of_mem _ (hε this)
#align continuous_linear_map.is_open_map ContinuousLinearMap.isOpenMap

protected theorem quotientMap (surj : Surjective f) : QuotientMap f :=
  (f.IsOpenMap surj).to_quotientMap f.Continuous surj
#align continuous_linear_map.quotient_map ContinuousLinearMap.quotientMap

theorem AffineMap.isOpenMap {P Q : Type _} [MetricSpace P] [NormedAddTorsor E P] [MetricSpace Q]
    [NormedAddTorsor F Q] (f : P →ᵃ[𝕜] Q) (hf : Continuous f) (surj : Surjective f) : IsOpenMap f :=
  AffineMap.isOpenMap_linear_iff.mp <|
    ContinuousLinearMap.isOpenMap { f.linear with cont := AffineMap.continuous_linear_iff.mpr hf }
      (f.linear_surjective_iff.mpr surj)
#align affine_map.is_open_map AffineMap.isOpenMap

/-! ### Applications of the Banach open mapping theorem -/

theorem interior_preimage (hsurj : Surjective f) (s : Set F) :
    interior (f ⁻¹' s) = f ⁻¹' interior s :=
  ((f.IsOpenMap hsurj).preimage_interior_eq_interior_preimage f.Continuous s).symm
#align continuous_linear_map.interior_preimage ContinuousLinearMap.interior_preimage

theorem closure_preimage (hsurj : Surjective f) (s : Set F) : closure (f ⁻¹' s) = f ⁻¹' closure s :=
  ((f.IsOpenMap hsurj).preimage_closure_eq_closure_preimage f.Continuous s).symm
#align continuous_linear_map.closure_preimage ContinuousLinearMap.closure_preimage

theorem frontier_preimage (hsurj : Surjective f) (s : Set F) :
    frontier (f ⁻¹' s) = f ⁻¹' frontier s :=
  ((f.IsOpenMap hsurj).preimage_frontier_eq_frontier_preimage f.Continuous s).symm
#align continuous_linear_map.frontier_preimage ContinuousLinearMap.frontier_preimage

theorem exists_nonlinearRightInverse_of_surjective (f : E →L[𝕜] F) (hsurj : LinearMap.range f = ⊤) :
    ∃ fsymm : NonlinearRightInverse f, 0 < fsymm.nnnorm :=
  by
  choose C hC fsymm h using exists_preimage_norm_le _ (linear_map.range_eq_top.mp hsurj)
  use {
      toFun := fsymm
      nnnorm := ⟨C, hC.lt.le⟩
      bound' := fun y => (h y).2
      right_inv' := fun y => (h y).1 }
  exact hC
#align continuous_linear_map.exists_nonlinear_right_inverse_of_surjective ContinuousLinearMap.exists_nonlinearRightInverse_of_surjective

/-- A surjective continuous linear map between Banach spaces admits a (possibly nonlinear)
controlled right inverse. In general, it is not possible to ensure that such a right inverse
is linear (take for instance the map from `E` to `E/F` where `F` is a closed subspace of `E`
without a closed complement. Then it doesn't have a continuous linear right inverse.) -/
noncomputable irreducible_def nonlinearRightInverseOfSurjective (f : E →L[𝕜] F)
  (hsurj : LinearMap.range f = ⊤) : NonlinearRightInverse f :=
  Classical.choose (exists_nonlinearRightInverse_of_surjective f hsurj)
#align continuous_linear_map.nonlinear_right_inverse_of_surjective ContinuousLinearMap.nonlinearRightInverseOfSurjective

theorem nonlinearRightInverseOfSurjective_nnnorm_pos (f : E →L[𝕜] F)
    (hsurj : LinearMap.range f = ⊤) : 0 < (nonlinearRightInverseOfSurjective f hsurj).nnnorm :=
  by
  rw [nonlinear_right_inverse_of_surjective]
  exact Classical.choose_spec (exists_nonlinear_right_inverse_of_surjective f hsurj)
#align continuous_linear_map.nonlinear_right_inverse_of_surjective_nnnorm_pos ContinuousLinearMap.nonlinearRightInverseOfSurjective_nnnorm_pos

end ContinuousLinearMap

namespace LinearEquiv

variable [CompleteSpace E]

/-- If a bounded linear map is a bijection, then its inverse is also a bounded linear map. -/
@[continuity]
theorem continuous_symm (e : E ≃ₗ[𝕜] F) (h : Continuous e) : Continuous e.symm :=
  by
  rw [continuous_def]
  intro s hs
  rw [← e.image_eq_preimage]
  rw [← e.coe_coe] at h⊢
  exact ContinuousLinearMap.isOpenMap ⟨↑e, h⟩ e.surjective s hs
#align linear_equiv.continuous_symm LinearEquiv.continuous_symm

/-- Associating to a linear equivalence between Banach spaces a continuous linear equivalence when
the direct map is continuous, thanks to the Banach open mapping theorem that ensures that the
inverse map is also continuous. -/
def toContinuousLinearEquivOfContinuous (e : E ≃ₗ[𝕜] F) (h : Continuous e) : E ≃L[𝕜] F :=
  { e with
    continuous_toFun := h
    continuous_invFun := e.continuous_symm h }
#align linear_equiv.to_continuous_linear_equiv_of_continuous LinearEquiv.toContinuousLinearEquivOfContinuous

@[simp]
theorem coeFn_toContinuousLinearEquivOfContinuous (e : E ≃ₗ[𝕜] F) (h : Continuous e) :
    ⇑(e.toContinuousLinearEquivOfContinuous h) = e :=
  rfl
#align linear_equiv.coe_fn_to_continuous_linear_equiv_of_continuous LinearEquiv.coeFn_toContinuousLinearEquivOfContinuous

@[simp]
theorem coeFn_toContinuousLinearEquivOfContinuous_symm (e : E ≃ₗ[𝕜] F) (h : Continuous e) :
    ⇑(e.toContinuousLinearEquivOfContinuous h).symm = e.symm :=
  rfl
#align linear_equiv.coe_fn_to_continuous_linear_equiv_of_continuous_symm LinearEquiv.coeFn_toContinuousLinearEquivOfContinuous_symm

end LinearEquiv

namespace ContinuousLinearEquiv

variable [CompleteSpace E]

/-- Convert a bijective continuous linear map `f : E →L[𝕜] F` from a Banach space to a normed space
to a continuous linear equivalence. -/
noncomputable def ofBijective (f : E →L[𝕜] F) (hinj : ker f = ⊥) (hsurj : LinearMap.range f = ⊤) :
    E ≃L[𝕜] F :=
  (LinearEquiv.ofBijective ↑f
        ⟨LinearMap.ker_eq_bot.mp hinj,
          LinearMap.range_eq_top.mp hsurj⟩).toContinuousLinearEquivOfContinuous
    f.Continuous
#align continuous_linear_equiv.of_bijective ContinuousLinearEquiv.ofBijective

@[simp]
theorem coeFn_ofBijective (f : E →L[𝕜] F) (hinj : ker f = ⊥) (hsurj : LinearMap.range f = ⊤) :
    ⇑(ofBijective f hinj hsurj) = f :=
  rfl
#align continuous_linear_equiv.coe_fn_of_bijective ContinuousLinearEquiv.coeFn_ofBijective

theorem coe_ofBijective (f : E →L[𝕜] F) (hinj : ker f = ⊥) (hsurj : LinearMap.range f = ⊤) :
    ↑(ofBijective f hinj hsurj) = f := by
  ext
  rfl
#align continuous_linear_equiv.coe_of_bijective ContinuousLinearEquiv.coe_ofBijective

@[simp]
theorem ofBijective_symm_apply_apply (f : E →L[𝕜] F) (hinj : ker f = ⊥)
    (hsurj : LinearMap.range f = ⊤) (x : E) : (ofBijective f hinj hsurj).symm (f x) = x :=
  (ofBijective f hinj hsurj).symm_apply_apply x
#align continuous_linear_equiv.of_bijective_symm_apply_apply ContinuousLinearEquiv.ofBijective_symm_apply_apply

@[simp]
theorem ofBijective_apply_symm_apply (f : E →L[𝕜] F) (hinj : ker f = ⊥)
    (hsurj : LinearMap.range f = ⊤) (y : F) : f ((ofBijective f hinj hsurj).symm y) = y :=
  (ofBijective f hinj hsurj).apply_symm_apply y
#align continuous_linear_equiv.of_bijective_apply_symm_apply ContinuousLinearEquiv.ofBijective_apply_symm_apply

end ContinuousLinearEquiv

namespace ContinuousLinearMap

variable [CompleteSpace E]

/-- Intermediate definition used to show
`continuous_linear_map.closed_complemented_range_of_is_compl_of_ker_eq_bot`.

This is `f.coprod G.subtypeL` as an `continuous_linear_equiv`. -/
noncomputable def coprodSubtypeLEquivOfIsCompl (f : E →L[𝕜] F) {G : Submodule 𝕜 F}
    (h : IsCompl (LinearMap.range f) G) [CompleteSpace G] (hker : ker f = ⊥) : (E × G) ≃L[𝕜] F :=
  ContinuousLinearEquiv.ofBijective (f.coprod G.subtypeL)
    (by
      rw [ker_coprod_of_disjoint_range]
      · rw [hker, Submodule.ker_subtypeL, Submodule.prod_bot]
      · rw [Submodule.range_subtypeL]
        exact h.disjoint)
    (by simp only [range_coprod, h.sup_eq_top, Submodule.range_subtypeL])
#align continuous_linear_map.coprod_subtypeL_equiv_of_is_compl ContinuousLinearMap.coprodSubtypeLEquivOfIsCompl

theorem range_eq_map_coprodSubtypeLEquivOfIsCompl (f : E →L[𝕜] F) {G : Submodule 𝕜 F}
    (h : IsCompl (LinearMap.range f) G) [CompleteSpace G] (hker : ker f = ⊥) :
    LinearMap.range f =
      ((⊤ : Submodule 𝕜 E).Prod (⊥ : Submodule 𝕜 G)).map
        (f.coprodSubtypeLEquivOfIsCompl h hker : E × G →ₗ[𝕜] F) :=
  by
  rw [coprod_subtypeL_equiv_of_is_compl, _root_.coe_coe, ContinuousLinearEquiv.coe_ofBijective,
    coe_coprod, LinearMap.coprod_map_prod, Submodule.map_bot, sup_bot_eq, Submodule.map_top]
  rfl
#align continuous_linear_map.range_eq_map_coprod_subtypeL_equiv_of_is_compl ContinuousLinearMap.range_eq_map_coprodSubtypeLEquivOfIsCompl

/- TODO: remove the assumption `f.ker = ⊥` in the next lemma, by using the map induced by `f` on
`E / f.ker`, once we have quotient normed spaces. -/
theorem closed_complemented_range_of_isCompl_of_ker_eq_bot (f : E →L[𝕜] F) (G : Submodule 𝕜 F)
    (h : IsCompl (LinearMap.range f) G) (hG : IsClosed (G : Set F)) (hker : ker f = ⊥) :
    IsClosed (LinearMap.range f : Set F) :=
  by
  haveI : CompleteSpace G := hG.complete_space_coe
  let g := coprod_subtypeL_equiv_of_is_compl f h hker
  rw [congr_arg coe (range_eq_map_coprod_subtypeL_equiv_of_is_compl f h hker)]
  apply g.to_homeomorph.is_closed_image.2
  exact is_closed_univ.prod isClosed_singleton
#align continuous_linear_map.closed_complemented_range_of_is_compl_of_ker_eq_bot ContinuousLinearMap.closed_complemented_range_of_isCompl_of_ker_eq_bot

end ContinuousLinearMap

section ClosedGraphThm

variable [CompleteSpace E] (g : E →ₗ[𝕜] F)

/-- The **closed graph theorem** : a linear map between two Banach spaces whose graph is closed
is continuous. -/
theorem LinearMap.continuous_of_isClosed_graph (hg : IsClosed (g.graph : Set <| E × F)) :
    Continuous g :=
  by
  letI : CompleteSpace g.graph := complete_space_coe_iff_is_complete.mpr hg.is_complete
  let φ₀ : E →ₗ[𝕜] E × F := linear_map.id.prod g
  have : Function.LeftInverse Prod.fst φ₀ := fun x => rfl
  let φ : E ≃ₗ[𝕜] g.graph :=
    (LinearEquiv.ofLeftInverse this).trans (LinearEquiv.ofEq _ _ g.graph_eq_range_prod.symm)
  let ψ : g.graph ≃L[𝕜] E :=
    φ.symm.to_continuous_linear_equiv_of_continuous continuous_subtype_coe.fst
  exact (continuous_subtype_coe.comp ψ.symm.continuous).snd
#align linear_map.continuous_of_is_closed_graph LinearMap.continuous_of_isClosed_graph

/-- A useful form of the **closed graph theorem** : let `f` be a linear map between two Banach
spaces. To show that `f` is continuous, it suffices to show that for any convergent sequence
`uₙ ⟶ x`, if `f(uₙ) ⟶ y` then `y = f(x)`. -/
theorem LinearMap.continuous_of_seq_closed_graph
    (hg : ∀ (u : ℕ → E) (x y), Tendsto u atTop (𝓝 x) → Tendsto (g ∘ u) atTop (𝓝 y) → y = g x) :
    Continuous g :=
  by
  refine' g.continuous_of_is_closed_graph (IsSeqClosed.isClosed _)
  rintro φ ⟨x, y⟩ hφg hφ
  refine' hg (Prod.fst ∘ φ) x y ((continuous_fst.tendsto _).comp hφ) _
  have : g ∘ Prod.fst ∘ φ = Prod.snd ∘ φ := by
    ext n
    exact (hφg n).symm
  rw [this]
  exact (continuous_snd.tendsto _).comp hφ
#align linear_map.continuous_of_seq_closed_graph LinearMap.continuous_of_seq_closed_graph

variable {g}

namespace ContinuousLinearMap

/-- Upgrade a `linear_map` to a `continuous_linear_map` using the **closed graph theorem**. -/
def ofIsClosedGraph (hg : IsClosed (g.graph : Set <| E × F)) : E →L[𝕜] F
    where
  toLinearMap := g
  cont := g.continuous_of_isClosed_graph hg
#align continuous_linear_map.of_is_closed_graph ContinuousLinearMap.ofIsClosedGraph

@[simp]
theorem coeFn_ofIsClosedGraph (hg : IsClosed (g.graph : Set <| E × F)) :
    ⇑(ContinuousLinearMap.ofIsClosedGraph hg) = g :=
  rfl
#align continuous_linear_map.coe_fn_of_is_closed_graph ContinuousLinearMap.coeFn_ofIsClosedGraph

theorem coe_ofIsClosedGraph (hg : IsClosed (g.graph : Set <| E × F)) :
    ↑(ContinuousLinearMap.ofIsClosedGraph hg) = g :=
  by
  ext
  rfl
#align continuous_linear_map.coe_of_is_closed_graph ContinuousLinearMap.coe_ofIsClosedGraph

/-- Upgrade a `linear_map` to a `continuous_linear_map` using a variation on the
**closed graph theorem**. -/
def ofSeqClosedGraph
    (hg : ∀ (u : ℕ → E) (x y), Tendsto u atTop (𝓝 x) → Tendsto (g ∘ u) atTop (𝓝 y) → y = g x) :
    E →L[𝕜] F where
  toLinearMap := g
  cont := g.continuous_of_seq_closed_graph hg
#align continuous_linear_map.of_seq_closed_graph ContinuousLinearMap.ofSeqClosedGraph

@[simp]
theorem coeFn_ofSeqClosedGraph
    (hg : ∀ (u : ℕ → E) (x y), Tendsto u atTop (𝓝 x) → Tendsto (g ∘ u) atTop (𝓝 y) → y = g x) :
    ⇑(ContinuousLinearMap.ofSeqClosedGraph hg) = g :=
  rfl
#align continuous_linear_map.coe_fn_of_seq_closed_graph ContinuousLinearMap.coeFn_ofSeqClosedGraph

theorem coe_ofSeqClosedGraph
    (hg : ∀ (u : ℕ → E) (x y), Tendsto u atTop (𝓝 x) → Tendsto (g ∘ u) atTop (𝓝 y) → y = g x) :
    ↑(ContinuousLinearMap.ofSeqClosedGraph hg) = g :=
  by
  ext
  rfl
#align continuous_linear_map.coe_of_seq_closed_graph ContinuousLinearMap.coe_ofSeqClosedGraph

end ContinuousLinearMap

end ClosedGraphThm


/-
Copyright (c) 2020 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Reid Barton
-/
import data.set.finite

/-!
# Infinitude of intervals

Bounded intervals in dense orders are infinite, as are unbounded intervals
in orders that are unbounded on the appropriate side.
-/

namespace set

variables {α : Type*} [preorder α]

section bounded

variables [densely_ordered α]

lemma Ioo.infinite {a b : α} (h : a < b) : infinite (Ioo a b) :=
begin
  rintro (f : finite (Ioo a b)),
  obtain ⟨m, hm₁, hm₂⟩ : ∃ m ∈ Ioo a b, ∀ x ∈ Ioo a b, ¬x < m,
  { simpa [h] using finset.exists_minimal f.to_finset },
  obtain ⟨z, hz₁, hz₂⟩ : ∃ z, a < z ∧ z < m := exists_between hm₁.1,
  exact hm₂ z ⟨hz₁, lt_trans hz₂ hm₁.2⟩ hz₂,
end

lemma Ioc.infinite {a b : α} (h : a < b) : infinite (Ioc a b) :=
(Ioo.infinite h).mono Ioo_subset_Ioc_self

lemma Icc.infinite {a b : α} (h : a < b) : infinite (Icc a b) :=
(Ioo.infinite h).mono Ioo_subset_Icc_self

end bounded

section unbounded_below

variables [no_bot_order α]

lemma Iio.infinite {b : α} : infinite (Iio b) :=
begin
  rintro (f : finite (Iio b)),
  obtain ⟨m, hm₁, hm₂⟩ : ∃ m < b, ∀ x < b, ¬x < m,
  { simpa using finset.exists_minimal f.to_finset },
  obtain ⟨z, hz⟩ : ∃ z, z < m := no_bot _,
  exact hm₂ z (lt_trans hz hm₁) hz
end

lemma Iic.infinite {b : α} : infinite (Iic b) :=
Iio.infinite.mono Iio_subset_Iic_self

end unbounded_below

section unbounded_above

variables [no_top_order α]

lemma Ioi.infinite {a : α} : infinite (Ioi a) :=
by apply @Iio.infinite (order_dual α)

lemma Ici.infinite {a : α} : infinite (Ici a) :=
Ioi.infinite.mono Ioi_subset_Ici_self

end unbounded_above

end set


/-
Copyright (c) 2021 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import order.succ_pred.basic

/-!
# Successors and predecessors of naturals

In this file, we show that `ℕ` is both an archimedean `succ_order` and an archimedean `pred_order`.
-/

open function

namespace nat

@[reducible] -- so that Lean reads `nat.succ` through `succ_order.succ`
instance : succ_order ℕ :=
{ succ := succ,
  ..succ_order.of_succ_le_iff succ (λ a b, iff.rfl) }

@[reducible] -- so that Lean reads `nat.pred` through `pred_order.pred`
instance : pred_order ℕ :=
{ pred := pred,
  pred_le := pred_le,
  min_of_le_pred := λ a ha, begin
    cases a,
    { exact is_min_bot },
    { exact (not_succ_le_self _ ha).elim }
  end,
  le_pred_of_lt := λ a b h, begin
    cases b,
    { exact (a.not_lt_zero h).elim },
    { exact le_of_succ_le_succ h }
  end,
  le_of_pred_lt := λ a b h, begin
    cases a,
    { exact b.zero_le },
    { exact h }
  end }

@[simp] lemma succ_eq_succ : order.succ = succ := rfl
@[simp] lemma pred_eq_pred : order.pred = pred := rfl

lemma succ_iterate (a : ℕ) : ∀ n, succ^[n] a = a + n
| 0       := rfl
| (n + 1) := by { rw [function.iterate_succ', add_succ], exact congr_arg _ n.succ_iterate }

lemma pred_iterate (a : ℕ) : ∀ n, pred^[n] a = a - n
| 0       := rfl
| (n + 1) := by { rw [function.iterate_succ', sub_succ], exact congr_arg _ n.pred_iterate }

instance : is_succ_archimedean ℕ :=
⟨λ a b h, ⟨b - a, by rw [succ_eq_succ, succ_iterate, add_tsub_cancel_of_le h]⟩⟩

instance : is_pred_archimedean ℕ :=
⟨λ a b h, ⟨b - a, by rw [pred_eq_pred, pred_iterate, tsub_tsub_cancel_of_le h]⟩⟩

end nat


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Johannes Hölzl, Scott Morrison, Jens Wagemaker
-/
import data.polynomial.basic

/-!
# Univariate monomials

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

Preparatory lemmas for degree_basic.
-/

noncomputable theory

namespace polynomial
open_locale polynomial

universes u
variables {R : Type u} {a b : R} {m n : ℕ}
variables [semiring R] {p q r : R[X]}

lemma monomial_one_eq_iff [nontrivial R] {i j : ℕ} :
  (monomial i 1 : R[X]) = monomial j 1 ↔ i = j :=
begin
  simp_rw [←of_finsupp_single],
  exact add_monoid_algebra.of_injective.eq_iff
end

instance [nontrivial R] : infinite R[X] :=
infinite.of_injective (λ i, monomial i 1) $
λ m n h, by simpa [monomial_one_eq_iff] using h

lemma card_support_le_one_iff_monomial {f : R[X]} :
  finset.card f.support ≤ 1 ↔ ∃ n a, f = monomial n a :=
begin
  split,
  { assume H,
    rw finset.card_le_one_iff_subset_singleton at H,
    rcases H with ⟨n, hn⟩,
    refine ⟨n, f.coeff n, _⟩,
    ext i,
    by_cases hi : i = n,
    { simp [hi, coeff_monomial] },
    { have : f.coeff i = 0,
      { rw ← not_mem_support_iff,
        exact λ hi', hi (finset.mem_singleton.1 (hn hi')) },
      simp [this, ne.symm hi, coeff_monomial] } },
  { rintros ⟨n, a, rfl⟩,
    rw ← finset.card_singleton n,
    apply finset.card_le_of_subset,
    exact support_monomial' _ _ }
end

lemma ring_hom_ext {S} [semiring S] {f g : R[X] →+* S}
  (h₁ : ∀ a, f (C a) = g (C a)) (h₂ : f X = g X) : f = g :=
begin
  set f' := f.comp (to_finsupp_iso R).symm.to_ring_hom with hf',
  set g' := g.comp (to_finsupp_iso R).symm.to_ring_hom with hg',
  have A : f' = g',
  { ext,
    { simp [h₁, ring_equiv.to_ring_hom_eq_coe] },
    { simpa [ring_equiv.to_ring_hom_eq_coe] using h₂, } },
  have B : f = f'.comp (to_finsupp_iso R),
    by { rw [hf', ring_hom.comp_assoc], ext x, simp only [ring_equiv.to_ring_hom_eq_coe,
      ring_equiv.symm_apply_apply, function.comp_app, ring_hom.coe_comp,
      ring_equiv.coe_to_ring_hom] },
  have C : g = g'.comp (to_finsupp_iso R),
    by { rw [hg', ring_hom.comp_assoc], ext x, simp only [ring_equiv.to_ring_hom_eq_coe,
      ring_equiv.symm_apply_apply, function.comp_app, ring_hom.coe_comp,
      ring_equiv.coe_to_ring_hom] },
  rw [B, C, A]
end

@[ext] lemma ring_hom_ext' {S} [semiring S] {f g : R[X] →+* S}
  (h₁ : f.comp C = g.comp C) (h₂ : f X = g X) : f = g :=
ring_hom_ext (ring_hom.congr_fun h₁) h₂

end polynomial


def evenq (n: Nat) : Bool := Nat.mod n 2 = 0

private theorem pack_loop_terminates : (n : Nat) → n / 2 < n.succ
  | 0   => by decide
  | 1   => by decide
  | n+2 => by
    rw [Nat.div_eq]
    split
    . rw [Nat.add_sub_self_right]
      have := pack_loop_terminates n
      calc n/2 + 1 < Nat.succ n + 1   := Nat.add_le_add_right this 1
             _     < Nat.succ (n + 2) := Nat.succ_lt_succ (Nat.succ_lt_succ (Nat.lt_succ_self _))
    . apply Nat.zero_lt_succ

def pack (n: Nat) : List Nat :=
  let rec loop (n : Nat) (acc : Nat) (accs: List Nat) : List Nat :=
    let next (n: Nat) := n / 2;
    match n with
    | Nat.zero => List.cons acc accs
    | n+1 => match evenq n with
      | true => loop (next n) 0 (List.cons acc accs)
      | false => loop (next n) (acc+1) accs
  loop n 0 []
termination_by'
  invImage (fun ⟨n, _, _⟩ => n) Nat.lt_wfRel
decreasing_by
  simp [invImage, InvImage, Prod.lex, sizeOfWFRel, measure, Nat.lt_wfRel]
  apply pack_loop_terminates

#eval pack 27


import algebra.category.CommRing.basic
import algebra.ring
import tactic
open CommRing
universes v u

structure A2 (R : Type v)[comm_ring R] :=
(a : R)
(b : R)

namespace A2
    section
        variables {R : Type v} [comm_ring R]
@[ext]lemma ext :  ∀ {ζ1 ζ2 : A2 R}, (ζ1.a = ζ2.a) → (ζ1.b = ζ2.b) → ζ1 = ζ2 := λ ζ1 ζ2,
    begin
        intros h1 h2,
        cases ζ1,
        cases ζ2,
        -- let y := A2.mk ζ1_a ζ1_b,
        --     have j : y.a = ζ1_a,
        --         exact rfl,
            exact congr (congr_arg mk h1) h2,
        -- congr ; try { assumption },   --- ici je ne comprends pas trop ! Comment prouver les choses sans tatics
    end

    end  --- end section comprendre ?
end A2


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

! This file was ported from Lean 3 source module field_theory.separable_degree
! leanprover-community/mathlib commit d11893b411025250c8e61ff2f12ccbd7ee35ab15
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Algebra.Basic
import Mathbin.Algebra.CharP.ExpChar
import Mathbin.FieldTheory.Separable

/-!

# Separable degree

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

## Main results

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

## Tags

separable degree, degree, polynomial
-/

namespace Polynomial

noncomputable section

open Classical Polynomial

section CommSemiring

variable {F : Type _} [CommSemiring F] (q : ℕ)

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

/-- The condition of having a separable contration. -/
def HasSeparableContraction (f : F[X]) : Prop :=
  ∃ g : F[X], IsSeparableContraction q f g
#align polynomial.has_separable_contraction Polynomial.HasSeparableContraction

variable {q} {f : F[X]} (hf : HasSeparableContraction q f)

/-- A choice of a separable contraction. -/
def HasSeparableContraction.contraction : F[X] :=
  Classical.choose hf
#align polynomial.has_separable_contraction.contraction Polynomial.HasSeparableContraction.contraction

/-- The separable degree of a polynomial is the degree of a given separable contraction. -/
def HasSeparableContraction.degree : ℕ :=
  hf.contraction.natDegree
#align polynomial.has_separable_contraction.degree Polynomial.HasSeparableContraction.degree

/-- The separable degree divides the degree, in function of the exponential characteristic of F. -/
theorem IsSeparableContraction.dvd_degree' {g} (hf : IsSeparableContraction q f g) :
    ∃ m : ℕ, g.natDegree * q ^ m = f.natDegree :=
  by
  obtain ⟨m, rfl⟩ := hf.2
  use m
  rw [nat_degree_expand]
#align polynomial.is_separable_contraction.dvd_degree' Polynomial.IsSeparableContraction.dvd_degree'

theorem HasSeparableContraction.dvd_degree' : ∃ m : ℕ, hf.degree * q ^ m = f.natDegree :=
  (Classical.choose_spec hf).dvd_degree'
#align polynomial.has_separable_contraction.dvd_degree' Polynomial.HasSeparableContraction.dvd_degree'

/-- The separable degree divides the degree. -/
theorem HasSeparableContraction.dvd_degree : hf.degree ∣ f.natDegree :=
  let ⟨a, ha⟩ := hf.dvd_degree'
  Dvd.intro (q ^ a) ha
#align polynomial.has_separable_contraction.dvd_degree Polynomial.HasSeparableContraction.dvd_degree

/-- In exponential characteristic one, the separable degree equals the degree. -/
theorem HasSeparableContraction.eq_degree {f : F[X]} (hf : HasSeparableContraction 1 f) :
    hf.degree = f.natDegree := by
  let ⟨a, ha⟩ := hf.dvd_degree'
  rw [← ha, one_pow a, mul_one]
#align polynomial.has_separable_contraction.eq_degree Polynomial.HasSeparableContraction.eq_degree

end CommSemiring

section Field

variable {F : Type _} [Field F]

variable (q : ℕ) {f : F[X]} (hf : HasSeparableContraction q f)

/-- Every irreducible polynomial can be contracted to a separable polynomial.
https://stacks.math.columbia.edu/tag/09H0 -/
theorem Irreducible.hasSeparableContraction (q : ℕ) [hF : ExpChar F q] (f : F[X])
    (irred : Irreducible f) : HasSeparableContraction q f :=
  by
  cases hF
  · exact ⟨f, irred.separable, ⟨0, by rw [pow_zero, expand_one]⟩⟩
  · rcases exists_separable_of_irreducible q irred ‹q.prime›.NeZero with ⟨n, g, hgs, hge⟩
    exact ⟨g, hgs, n, hge⟩
#align irreducible.has_separable_contraction Irreducible.hasSeparableContraction

/-- If two expansions (along the positive characteristic) of two separable polynomials `g` and `g'`
agree, then they have the same degree. -/
theorem contraction_degree_eq_or_insep [hq : NeZero q] [CharP F q] (g g' : F[X]) (m m' : ℕ)
    (h_expand : expand F (q ^ m) g = expand F (q ^ m') g') (hg : g.Separable) (hg' : g'.Separable) :
    g.natDegree = g'.natDegree := by
  wlog hm : m ≤ m'
  · exact (this g' g m' m h_expand.symm hg' hg (le_of_not_le hm)).symm
  obtain ⟨s, rfl⟩ := exists_add_of_le hm
  rw [pow_add, expand_mul, expand_inj (pow_pos (NeZero.pos q) m)] at h_expand
  subst h_expand
  rcases is_unit_or_eq_zero_of_separable_expand q s (NeZero.pos q) hg with (h | rfl)
  · rw [nat_degree_expand, nat_degree_eq_zero_of_is_unit h, MulZeroClass.zero_mul]
  · rw [nat_degree_expand, pow_zero, mul_one]
#align polynomial.contraction_degree_eq_or_insep Polynomial.contraction_degree_eq_or_insep

/-- The separable degree equals the degree of any separable contraction, i.e., it is unique. -/
theorem IsSeparableContraction.degree_eq [hF : ExpChar F q] (g : F[X])
    (hg : IsSeparableContraction q f g) : g.natDegree = hf.degree :=
  by
  cases hF
  · rcases hg with ⟨g, m, hm⟩
    rw [one_pow, expand_one] at hm
    rw [hf.eq_degree]
    rw [hm]
  · rcases hg with ⟨hg, m, hm⟩
    let g' := Classical.choose hf
    cases' (Classical.choose_spec hf).2 with m' hm'
    haveI : Fact q.prime := fact_iff.2 hF_hprime
    apply contraction_degree_eq_or_insep q g g' m m'
    rw [hm, hm']
    exact hg
    exact (Classical.choose_spec hf).1
#align polynomial.is_separable_contraction.degree_eq Polynomial.IsSeparableContraction.degree_eq

end Field

end Polynomial


/-
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 data.polynomial.field_division
import topology.algebra.order.extend_from
import topology.algebra.polynomial
import topology.local_extr

/-!
# 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 topology classical polynomial

section module

variables {E : Type u} [normed_add_comm_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 `𝓝[>] a` and `𝓝[<] b`, then `f' c = 0`
for some `c ∈ (a, b)`.  -/
lemma exists_has_deriv_at_eq_zero' (hab : a < b)
  (hfa : tendsto f (𝓝[>] a) (𝓝 l)) (hfb : tendsto f (𝓝[<] 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.ne 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 `𝓝[>] a` and `𝓝[<] 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 (𝓝[>] a) (𝓝 l)) (hfb : tendsto f (𝓝[<] 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

open_locale big_operators

/-- The number of roots of a real polynomial `p` is at most the number of roots of its derivative
that are not roots of `p` plus one. -/
lemma card_roots_to_finset_le_card_roots_derivative_diff_roots_succ (p : ℝ[X]) :
  p.roots.to_finset.card ≤ (p.derivative.roots.to_finset \ p.roots.to_finset).card + 1 :=
begin
  cases eq_or_ne p.derivative 0 with hp' hp',
  { rw [eq_C_of_derivative_eq_zero hp', roots_C, multiset.to_finset_zero, finset.card_empty],
    exact zero_le _ },
  have hp : p ≠ 0, from ne_of_apply_ne derivative (by rwa [derivative_zero]),
  refine finset.card_le_diff_of_interleaved (λ x hx y hy hxy hxy', _),
  rw [multiset.mem_to_finset, mem_roots hp] at hx hy,
  obtain ⟨z, hz1, hz2⟩ := exists_deriv_eq_zero (λ x : ℝ, eval x p) hxy
    p.continuous_on (hx.trans hy.symm),
  refine ⟨z, _, hz1⟩,
  rwa [multiset.mem_to_finset, mem_roots hp', is_root, ← p.deriv]
end

/-- The number of roots of a real polynomial is at most the number of roots of its derivative plus
one. -/
lemma card_roots_to_finset_le_derivative (p : ℝ[X]) :
  p.roots.to_finset.card ≤ p.derivative.roots.to_finset.card + 1 :=
p.card_roots_to_finset_le_card_roots_derivative_diff_roots_succ.trans $
  add_le_add_right (finset.card_mono $ finset.sdiff_subset _ _) _

/-- The number of roots of a real polynomial (counted with multiplicities) is at most the number of
roots of its derivative (counted with multiplicities) plus one. -/
lemma card_roots_le_derivative (p : ℝ[X]) : p.roots.card ≤ p.derivative.roots.card + 1 :=
calc p.roots.card = ∑ x in p.roots.to_finset, p.roots.count x :
  (multiset.to_finset_sum_count_eq _).symm
... = ∑ x in p.roots.to_finset, (p.roots.count x - 1 + 1) :
  eq.symm $ finset.sum_congr rfl $ λ x hx, tsub_add_cancel_of_le $ nat.succ_le_iff.2 $
    multiset.count_pos.2 $ multiset.mem_to_finset.1 hx
... = ∑ x in p.roots.to_finset, (p.root_multiplicity x - 1) + p.roots.to_finset.card :
  by simp only [finset.sum_add_distrib, finset.card_eq_sum_ones, count_roots]
... ≤ ∑ x in p.roots.to_finset, p.derivative.root_multiplicity x +
  ((p.derivative.roots.to_finset \ p.roots.to_finset).card + 1) :
  add_le_add
    (finset.sum_le_sum $ λ x hx, root_multiplicity_sub_one_le_derivative_root_multiplicity _ _)
    p.card_roots_to_finset_le_card_roots_derivative_diff_roots_succ
... ≤ ∑ x in p.roots.to_finset, p.derivative.roots.count x +
  (∑ x in p.derivative.roots.to_finset \ p.roots.to_finset, p.derivative.roots.count x + 1) :
  begin
    simp only [← count_roots],
    refine add_le_add_left (add_le_add_right ((finset.card_eq_sum_ones _).trans_le _) _) _,
    refine finset.sum_le_sum (λ x hx, nat.succ_le_iff.2 $ _),
    rw [multiset.count_pos, ← multiset.mem_to_finset],
    exact (finset.mem_sdiff.1 hx).1
  end
... = p.derivative.roots.card + 1 :
  begin
    rw [← add_assoc, ← finset.sum_union finset.disjoint_sdiff, finset.union_sdiff_self_eq_union,
      ← multiset.to_finset_sum_count_eq, ← finset.sum_subset (finset.subset_union_right _ _)],
    intros x hx₁ hx₂,
    simpa only [multiset.mem_to_finset, multiset.count_eq_zero] using hx₂
  end

/-- The number of real roots of a polynomial is at most the number of roots of its derivative plus
one. -/
lemma card_root_set_le_derivative {F : Type*} [comm_ring F] [algebra F ℝ] (p : F[X]) :
  fintype.card (p.root_set ℝ) ≤ fintype.card (p.derivative.root_set ℝ) + 1 :=
by simpa only [root_set_def, finset.coe_sort_coe, fintype.card_coe, derivative_map]
  using card_roots_to_finset_le_derivative (p.map (algebra_map F ℝ))

end polynomial


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

! This file was ported from Lean 3 source module topology.metric_space.metric_separated
! leanprover-community/mathlib commit 57ac39bd365c2f80589a700f9fbb664d3a1a30c2
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Topology.MetricSpace.EMetricSpace

/-!
# Metric separated pairs of sets

In this file we define the predicate `IsMetricSeparated`. We say that two sets in an (extended)
metric space are *metric separated* if the (extended) distance between `x ∈ s` and `y ∈ t` is
bounded from below by a positive constant.

This notion is useful, e.g., to define metric outer measures.
-/

open EMetric Set

noncomputable section

/-- Two sets in an (extended) metric space are called *metric separated* if the (extended) distance
between `x ∈ s` and `y ∈ t` is bounded from below by a positive constant. -/
def IsMetricSeparated {X : Type _} [EMetricSpace X] (s t : Set X) :=
  ∃ r, r ≠ 0 ∧ ∀ x ∈ s, ∀ y ∈ t, r ≤ edist x y
#align is_metric_separated IsMetricSeparated

namespace IsMetricSeparated

variable {X : Type _} [EMetricSpace X] {s t : Set X} {x y : X}

@[symm]
theorem symm (h : IsMetricSeparated s t) : IsMetricSeparated t s :=
  let ⟨r, r0, hr⟩ := h
  ⟨r, r0, fun y hy x hx => edist_comm x y ▸ hr x hx y hy⟩
#align is_metric_separated.symm IsMetricSeparated.symm

theorem comm : IsMetricSeparated s t ↔ IsMetricSeparated t s :=
  ⟨symm, symm⟩
#align is_metric_separated.comm IsMetricSeparated.comm

@[simp]
theorem empty_left (s : Set X) : IsMetricSeparated ∅ s :=
  ⟨1, one_ne_zero, fun _x => False.elim⟩
#align is_metric_separated.empty_left IsMetricSeparated.empty_left

@[simp]
theorem empty_right (s : Set X) : IsMetricSeparated s ∅ :=
  (empty_left s).symm
#align is_metric_separated.empty_right IsMetricSeparated.empty_right

protected theorem disjoint (h : IsMetricSeparated s t) : Disjoint s t :=
  let ⟨r, r0, hr⟩ := h
  Set.disjoint_left.mpr fun x hx1 hx2 => r0 <| by simpa using hr x hx1 x hx2
#align is_metric_separated.disjoint IsMetricSeparated.disjoint

theorem subset_compl_right (h : IsMetricSeparated s t) : s ⊆ tᶜ := fun _ hs ht =>
  h.disjoint.le_bot ⟨hs, ht⟩
#align is_metric_separated.subset_compl_right IsMetricSeparated.subset_compl_right

@[mono]
theorem mono {s' t'} (hs : s ⊆ s') (ht : t ⊆ t') :
    IsMetricSeparated s' t' → IsMetricSeparated s t := fun ⟨r, r0, hr⟩ =>
  ⟨r, r0, fun x hx y hy => hr x (hs hx) y (ht hy)⟩
#align is_metric_separated.mono IsMetricSeparated.mono

theorem mono_left {s'} (h' : IsMetricSeparated s' t) (hs : s ⊆ s') : IsMetricSeparated s t :=
  h'.mono hs Subset.rfl
#align is_metric_separated.mono_left IsMetricSeparated.mono_left

theorem mono_right {t'} (h' : IsMetricSeparated s t') (ht : t ⊆ t') : IsMetricSeparated s t :=
  h'.mono Subset.rfl ht
#align is_metric_separated.mono_right IsMetricSeparated.mono_right

theorem union_left {s'} (h : IsMetricSeparated s t) (h' : IsMetricSeparated s' t) :
    IsMetricSeparated (s ∪ s') t := by
  rcases h, h' with ⟨⟨r, r0, hr⟩, ⟨r', r0', hr'⟩⟩
  refine' ⟨min r r', _, fun x hx y hy => hx.elim _ _⟩
  · rw [← pos_iff_ne_zero] at r0 r0'⊢
    exact lt_min r0 r0'
  · exact fun hx => (min_le_left _ _).trans (hr _ hx _ hy)
  · exact fun hx => (min_le_right _ _).trans (hr' _ hx _ hy)
#align is_metric_separated.union_left IsMetricSeparated.union_left

@[simp]
theorem union_left_iff {s'} :
    IsMetricSeparated (s ∪ s') t ↔ IsMetricSeparated s t ∧ IsMetricSeparated s' t :=
  ⟨fun h => ⟨h.mono_left (subset_union_left _ _), h.mono_left (subset_union_right _ _)⟩, fun h =>
    h.1.union_left h.2⟩
#align is_metric_separated.union_left_iff IsMetricSeparated.union_left_iff

theorem union_right {t'} (h : IsMetricSeparated s t) (h' : IsMetricSeparated s t') :
    IsMetricSeparated s (t ∪ t') :=
  (h.symm.union_left h'.symm).symm
#align is_metric_separated.union_right IsMetricSeparated.union_right

@[simp]
theorem union_right_iff {t'} :
    IsMetricSeparated s (t ∪ t') ↔ IsMetricSeparated s t ∧ IsMetricSeparated s t' :=
  comm.trans <| union_left_iff.trans <| and_congr comm comm
#align is_metric_separated.union_right_iff IsMetricSeparated.union_right_iff

theorem finite_unionᵢ_left_iff {ι : Type _} {I : Set ι} (hI : I.Finite) {s : ι → Set X}
    {t : Set X} : IsMetricSeparated (⋃ i ∈ I, s i) t ↔ ∀ i ∈ I, IsMetricSeparated (s i) t := by
  refine' Finite.induction_on hI (by simp) @fun i I _ _ hI => _
  rw [bunionᵢ_insert, ball_insert_iff, union_left_iff, hI]
#align is_metric_separated.finite_Union_left_iff IsMetricSeparated.finite_unionᵢ_left_iff

alias finite_unionᵢ_left_iff ↔ _ finite_unionᵢ_left
#align is_metric_separated.finite_Union_left IsMetricSeparated.finite_unionᵢ_left

theorem finite_unionᵢ_right_iff {ι : Type _} {I : Set ι} (hI : I.Finite) {s : Set X}
    {t : ι → Set X} : IsMetricSeparated s (⋃ i ∈ I, t i) ↔ ∀ i ∈ I, IsMetricSeparated s (t i) := by
  simpa only [@comm _ _ s] using finite_unionᵢ_left_iff hI
#align is_metric_separated.finite_Union_right_iff IsMetricSeparated.finite_unionᵢ_right_iff

@[simp]
theorem finset_unionᵢ_left_iff {ι : Type _} {I : Finset ι} {s : ι → Set X} {t : Set X} :
    IsMetricSeparated (⋃ i ∈ I, s i) t ↔ ∀ i ∈ I, IsMetricSeparated (s i) t :=
  finite_unionᵢ_left_iff I.finite_toSet
#align is_metric_separated.finset_Union_left_iff IsMetricSeparated.finset_unionᵢ_left_iff

alias finset_unionᵢ_left_iff ↔ _ finset_unionᵢ_left
#align is_metric_separated.finset_Union_left IsMetricSeparated.finset_unionᵢ_left

@[simp]
theorem finset_unionᵢ_right_iff {ι : Type _} {I : Finset ι} {s : Set X} {t : ι → Set X} :
    IsMetricSeparated s (⋃ i ∈ I, t i) ↔ ∀ i ∈ I, IsMetricSeparated s (t i) :=
  finite_unionᵢ_right_iff I.finite_toSet
#align is_metric_separated.finset_Union_right_iff IsMetricSeparated.finset_unionᵢ_right_iff

alias finset_unionᵢ_right_iff ↔ _ finset_unionᵢ_right
#align is_metric_separated.finset_Union_right IsMetricSeparated.finset_unionᵢ_right

end IsMetricSeparated


import M4R.Algebra.Group.SubGroup
import M4R.Algebra.Group.Sum

namespace M4R

  structure MHomomorphism (α : Type _) (β : Type _) [Monoid α] [Monoid β] where
    hom           : α → β
    preserve_zero : hom 0 = 0
    preserve_add  : ∀ a b, hom (a + b) = hom a + hom b
  infixr:25 " →₊ " => MHomomorphism
  instance MHomomorphismFun [Monoid α] [Monoid β] : CoeFun (α →₊ β) (fun _ => α → β) where
    coe := MHomomorphism.hom

  structure MIsomorphism (α : Type _) (β : Type _) [Monoid α] [Monoid β] extends α →₊ β where
    inv       : β → α
    left_inv  : Function.left_inverse inv hom
    right_inv : Function.right_inverse inv hom
  infixr:25 " ≅₊ " => MIsomorphism
  instance MIsomorphismFun [Monoid α] [Monoid β] : CoeFun (α ≅₊ β) (fun _ => α → β) where
    coe := fun f => f.hom

  structure GHomomorphism (α : Type _) (β : Type _) [Group α] [Group β] extends α →₊ β where
    preserve_neg  : ∀ a, hom (-a) = -hom a
  infixr:25 " →₋ " => GHomomorphism
  instance GHomomorphismFun [Group  α] [Group  β] : CoeFun (α →₋ β) (fun _ => α → β) where
    coe := fun f => f.hom

  structure GIsomorphism (α : Type _) (β : Type _) [Group α] [Group β] extends α →₋ β, α ≅₊ β
  infixr:25 " ≅₋ " => GIsomorphism
  instance GIsomorphismFun [Group  α] [Group  β] : CoeFun (α ≅₋ β) (fun _ => α → β) where
    coe := fun f => f.hom

  namespace MHomomorphism
    variable [Monoid α] [Monoid β] [Monoid γ] [Monoid δ]

    def kernel (mh : α →₊ β) : SubMonoid α where
      subset     := Function.fibre mh.hom 0
      has_zero   := mh.preserve_zero
      add_closed := fun _ x0 _ y0 => by
        simp only [Mem.mem, Set.mem, Function.fibre]; rw [mh.preserve_add, x0, y0, Monoid.add_zero]

    def image (mh : α →₊ β) : SubMonoid β where
      subset     := Function.image mh.hom
      has_zero   := ⟨0, mh.preserve_zero⟩
      add_closed := fun _ ⟨x, hx⟩ _ ⟨y, hy⟩ => ⟨x + y, hx ▸ hy ▸ mh.preserve_add x y⟩

    protected def comp (hab : α →₊ β) (hbc : β →₊ γ) : α →₊ γ where
      hom           := Function.comp hbc.hom hab.hom
      preserve_zero := by simp only [Function.comp]; rw [hab.preserve_zero, hbc.preserve_zero]
      preserve_add  := fun a b => by simp only [Function.comp]; rw [hab.preserve_add, hbc.preserve_add]

    protected def comp.hom (hab : α →₊ β) (hbc : β →₊ γ) :
      (hab.comp hbc).hom = hbc.hom ∘ hab.hom := rfl

    protected def Identity : α →₊ α where
      hom           := id
      preserve_zero := rfl
      preserve_add  := by intros; rfl

    protected theorem congr_fun {f g : α →₊ β} (h : f = g) (x : α) : f x = g x :=
      congrArg (· x) h

    protected theorem ext : ∀ {f g : α →₊ β}, f = g ↔ f.hom = g.hom
    | ⟨_, _, _⟩, ⟨_, _, _⟩ =>
      ⟨fun h => by rw [h], fun h => by rw [MHomomorphism.mk.injEq]; exact h⟩

    protected def Product (f : α →₊ γ) (g : β →₊ δ) : α × β →₊ γ × δ where
      hom           := fun (a, b) => (f a, g b)
      preserve_zero := congr (congrArg Prod.mk f.preserve_zero) g.preserve_zero
      preserve_add  := fun (a₁, b₁) (a₂, b₂) => congr (congrArg Prod.mk (f.preserve_add a₁ a₂)) (g.preserve_add b₁ b₂)

    open Classical

    protected noncomputable def MultiProd_cons {ι : Type _} (fι : ι → Type _) [∀ i, Monoid (fι i)] {s : Finset ι} {a : ι} (ha : a ∉ s) :
      MultiProd (fun i : s => fι i.val) × fι a →₊ MultiProd (fun i : s.cons a ha => fι i.val) where
        hom           := fun x ⟨i, hi⟩ => if h : i = a then by subst h; exact x.snd else x.fst ⟨i, (Finset.mem_cons.mp hi).resolve_left h⟩
        preserve_zero := funext fun ⟨i, hi⟩ => by
          byCases h : i = a
          { subst h; simp only [dite_true]; rfl }
          { simp only [h, dite_false]; rfl }
        preserve_add  := fun x y => funext fun ⟨i, hi⟩ => by
          simp only [Monoid.multi_product.Add_def, Monoid.product_add]
          byCases h : i = a
          { subst h; simp only [dite_true] }
          { simp only [h, dite_false] }

  end MHomomorphism

  theorem MHomomorphism.map_sum' [CommMonoid β] [CommMonoid γ] (g : β →₊ γ) (f : α → β) (s : UnorderedList α) :
    g (∑ f in s) = ∑ (g ∘ f) in s :=
      @UnorderedList.induction_on α (fun t => g (∑ f in t) = ∑ (g ∘ f) in t) s g.preserve_zero (by
        intro _ _ ih; rw [UnorderedList.map_sum.cons, UnorderedList.map_sum.cons,
          MHomomorphism.preserve_add, ih])

  theorem MHomomorphism.map_sum [CommMonoid β] [CommMonoid γ] (g : β →₊ γ) (f : α → β) (s : Finset α) :
    g (∑ f in s) = ∑ (g ∘ f) in s :=
      map_sum' g f s

  namespace MIsomorphism
    variable [Monoid α] [Monoid β] [Monoid γ] [Monoid δ]

    protected def inv_hom (f : α ≅₊ β) : β →₊ α where
      hom           := f.inv
      preserve_zero := by
        conv => lhs rw [←f.preserve_zero]
        rw [f.left_inv]
      preserve_add  := fun a b => by
        let ⟨_, ha⟩ := f.right_inv.surjective a
        let ⟨_, hb⟩ := f.right_inv.surjective b
        rw [←ha, ←hb, ←f.preserve_add, f.left_inv, f.left_inv, f.left_inv]

    protected def symm (f : α ≅₊ β) : β ≅₊ α where
      toMHomomorphism := f.inv_hom
      inv       := f
      left_inv  := f.right_inv
      right_inv := f.left_inv

    protected theorem comp (hab : α ≅₊ β) (hbc : β ≅₊ γ) : α ≅₊ γ where
      toMHomomorphism := hab.toMHomomorphism.comp hbc.toMHomomorphism
      inv := hab.inv ∘ hbc.inv
      left_inv := fun _ => by
        have : hab.toMHomomorphism.comp hbc.toMHomomorphism = hbc.hom ∘ hab.hom := rfl
        rw [this, ←Function.comp_eq, ←Function.comp_eq, hbc.left_inv, hab.left_inv]
      right_inv := fun _ => by
        have : hab.toMHomomorphism.comp hbc.toMHomomorphism = hbc.hom ∘ hab.hom := rfl
        rw [this, ←Function.comp_eq, ←Function.comp_eq, hab.right_inv, hbc.right_inv]

    protected noncomputable def of_bijection (f : α →₊ β) (hf : Function.bijective f.hom) : α ≅₊ β where
      toMHomomorphism := f
      inv       := fun b => Classical.choose (hf.surj b)
      left_inv  := fun a => hf.inj (Classical.choose_spec (hf.surj (f a)))
      right_inv := fun a => Classical.choose_spec (hf.surj a)

    protected def to_bijective (f : α ≅₊ β) : Function.bijective f.hom :=
      Function.bijective_of_inverse f.left_inv f.right_inv

    protected def to_injective (f : α ≅₊ β) : Function.injective f.hom :=
      (MIsomorphism.to_bijective f).left

    protected def to_surjective (f : α ≅₊ β) : Function.surjective f.hom :=
      (MIsomorphism.to_bijective f).right

    protected noncomputable def Identity : α ≅₊ α :=
      MIsomorphism.of_bijection _ (by apply Function.id_bijective : Function.bijective MHomomorphism.Identity.hom)

    protected def SelfInverse (f : α →₊ α) (h : ∀ a, f (f a) = a) : α ≅₊ α where
      toMHomomorphism := f
      inv       := f.hom
      left_inv  := h
      right_inv := h

    protected def Product (f : α ≅₊ γ) (g : β ≅₊ δ) : α × β ≅₊ γ × δ where
      toMHomomorphism := f.toMHomomorphism.Product g.toMHomomorphism
      inv             := fun (c, d) => (f.inv c, g.inv d)
      left_inv        := fun (a, b) => congr (congrArg Prod.mk (f.left_inv a)) (g.left_inv b)
      right_inv       := fun (c, d) => congr (congrArg Prod.mk (f.right_inv c)) (g.right_inv d)

    protected noncomputable def MultiProd_cons {ι : Type _} (fι : ι → Type _) [∀ i, Monoid (fι i)] {s : Finset ι} {a : ι} (ha : a ∉ s) :
      MultiProd (fun i : s => fι i.val) × fι a ≅₊ MultiProd (fun i : s.cons a ha => fι i.val) where
        toMHomomorphism := MHomomorphism.MultiProd_cons fι ha
        inv             := fun x => (fun ⟨i, hi⟩ => x ⟨i, Finset.mem_cons_self' ha hi⟩, x ⟨a, s.mem_cons_self ha⟩)
        left_inv        := fun (_, _) => congr (congrArg Prod.mk (funext fun ⟨i, hi⟩ => by
          have : i ≠ a := fun h => absurd (h ▸ hi) ha
          simp only [MHomomorphism.MultiProd_cons, this, dite_false]))
          (by simp only [MHomomorphism.MultiProd_cons, dite_true])
        right_inv       := fun x => funext fun ⟨i, hi⟩ => by
          simp only [MHomomorphism.MultiProd_cons]
          byCases h : i = a
          { subst h; simp only [dite_true] }
          { simp only [h, dite_false] }

  end MIsomorphism

  namespace GHomomorphism
    variable [Group α] [Group β] [Group γ] [Group δ]

    theorem preserve_sub (gh : α →₋ β) (a b : α) : gh (a - b) = gh a - gh b := by
      rw [Group.sub_def, gh.preserve_add, gh.preserve_neg]; rfl

    def kernel (gh : α →₋ β) : SubGroup α where
      toSubMonoid := MHomomorphism.kernel gh.toMHomomorphism
      neg_closed  := fun x x0 => by
        simp only [MHomomorphism.kernel, Mem.mem, Set.mem, Function.fibre]
        rw [gh.preserve_neg, x0, Group.neg_zero]

    def image (gh : α →₋ β) : SubGroup β where
      toSubMonoid := MHomomorphism.image gh.toMHomomorphism
      neg_closed  := fun _ ⟨x, hx⟩ => ⟨-x, hx ▸ gh.preserve_neg x⟩

    protected def comp (hab : α →₋ β) (hbc : β →₋ γ) : α →₋ γ where
      toMHomomorphism := hab.toMHomomorphism.comp hbc.toMHomomorphism
      preserve_neg  := fun a => by
        simp only [MHomomorphism.comp, Function.comp]
        rw [hab.preserve_neg, hbc.preserve_neg]

    protected def Identity : α →₋ α where
      toMHomomorphism := MHomomorphism.Identity
      preserve_neg    := by intros; rfl

    protected theorem ext : ∀ {f g : α →₋ β}, f = g ↔ f.hom = g.hom
    | ⟨_, _⟩, ⟨_, _⟩ =>
      ⟨fun h => by rw [h], fun h => by rw [GHomomorphism.mk.injEq]; exact MHomomorphism.ext.mpr h⟩

    theorem kernel_normal (f : α →₋ β) : f.kernel.is_normal :=
      fun a (ha : f a = 0) g => (by rw [MHomomorphism.preserve_add, MHomomorphism.preserve_add,
        GHomomorphism.preserve_neg, ha, Monoid.add_zero, Group.neg_add] : f _ = 0)

    protected def Product (f : α →₋ γ) (g : β →₋ δ) : α × β →₋ γ × δ where
      toMHomomorphism := f.toMHomomorphism.Product g.toMHomomorphism
      preserve_neg    := fun (a, b) => congr (congrArg Prod.mk (f.preserve_neg a)) (g.preserve_neg b)

    protected noncomputable def MultiProd_cons {ι : Type _} (fι : ι → Type _) [∀ i, Group (fι i)] {s : Finset ι} {a : ι} (ha : a ∉ s) :
      MultiProd (fun i : s => fι i.val) × fι a →₋ MultiProd (fun i : s.cons a ha => fι i.val) where
        toMHomomorphism := MHomomorphism.MultiProd_cons fι ha
        preserve_neg    := fun x => funext fun ⟨i, hi⟩ => by
          simp only [MHomomorphism.MultiProd_cons, Group.multi_product.Neg_def, Group.product_neg]
          byCases h : i = a
          { subst h; simp only [dite_true] }
          { simp only [h, dite_false] }

  end GHomomorphism

  namespace GIsomorphism
    variable [Group α] [Group β] [Group γ] [Group δ]

    protected def inv_hom (f : α ≅₋ β) : β →₋ α where
      toMHomomorphism := f.toMIsomorphism.inv_hom
      preserve_neg := fun a => by
        let ⟨_, ha⟩ := f.right_inv.surjective a
        have : f.toMIsomorphism.inv_hom.hom = f.inv := rfl
        rw [this, ←ha, ←f.preserve_neg, f.left_inv, f.left_inv]

    protected def symm (f : α ≅₋ β) : β ≅₋ α where
      toGHomomorphism := f.inv_hom
      inv := f
      left_inv := f.right_inv
      right_inv := f.left_inv

    protected theorem comp (hab : α ≅₋ β) (hbc : β ≅₋ γ) : α ≅₋ γ where
      toGHomomorphism := hab.toGHomomorphism.comp hbc.toGHomomorphism
      inv := hab.inv ∘ hbc.inv
      left_inv := fun _ => by
        have : hab.toGHomomorphism.comp hbc.toGHomomorphism = hbc.hom ∘ hab.hom := rfl
        rw [this, ←Function.comp_eq, ←Function.comp_eq, hbc.left_inv, hab.left_inv]
      right_inv := fun _ => by
        have : hab.toGHomomorphism.comp hbc.toGHomomorphism = hbc.hom ∘ hab.hom := rfl
        rw [this, ←Function.comp_eq, ←Function.comp_eq, hab.right_inv, hbc.right_inv]

    protected noncomputable def of_bijection (f : α →₋ β) (hf : Function.bijective f.hom) : α ≅₋ β where
      toGHomomorphism := f
      inv := fun b => Classical.choose (hf.surj b)
      left_inv := fun a => hf.inj (Classical.choose_spec (hf.surj (f a)))
      right_inv := fun a => Classical.choose_spec (hf.surj a)

    protected noncomputable def Identity : α ≅₋ α :=
      GIsomorphism.of_bijection _ (by apply Function.id_bijective : Function.bijective GHomomorphism.Identity.hom)

    protected def SelfInverse (f : α →₋ α) (h : ∀ a, f (f a) = a) : α ≅₋ α where
      toGHomomorphism := f
      inv := f.hom
      left_inv := h
      right_inv := h

    protected def Product (f : α ≅₋ γ) (g : β ≅₋ δ) : α × β ≅₋ γ × δ where
      toGHomomorphism := f.toGHomomorphism.Product g.toGHomomorphism
      inv             := (f.toMIsomorphism.Product g.toMIsomorphism).inv
      left_inv        := (f.toMIsomorphism.Product g.toMIsomorphism).left_inv
      right_inv       := (f.toMIsomorphism.Product g.toMIsomorphism).right_inv

    protected noncomputable def MultiProd_cons {ι : Type _} (fι : ι → Type _) [∀ i, Group (fι i)] {s : Finset ι} {a : ι} (ha : a ∉ s) :
      MultiProd (fun i : s => fι i.val) × fι a ≅₋ MultiProd (fun i : s.cons a ha => fι i.val) where
        toGHomomorphism := GHomomorphism.MultiProd_cons fι ha
        inv             := (MIsomorphism.MultiProd_cons fι ha).inv
        left_inv        := (MIsomorphism.MultiProd_cons fι ha).left_inv
        right_inv       := (MIsomorphism.MultiProd_cons fι ha).right_inv

  end GIsomorphism

  protected def AbelianGroup.NegHom [AbelianGroup α] : α →₋ α where
    hom := (- ·)
    preserve_zero := by simp only [Group.neg_zero]
    preserve_add := fun _ _ => by simp only [AbelianGroup.neg_add_distrib]
    preserve_neg := fun _ => by rfl

  protected def AbelianGroup.NegIso [AbelianGroup α] : α ≅₋ α := GIsomorphism.SelfInverse
    AbelianGroup.NegHom (fun _ => by simp only [AbelianGroup.NegHom, Group.neg_neg])

end M4R


/-
Copyright (c) 2023 Yaël Dillies, Sara Rousta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import order.locally_finite
import order.upper_lower.basic

/-!
# Upper and lower sets in a locally finite order

In this file we characterise the interaction of `upper_set`/`lower_set` and `locally_finite_order`.
-/

namespace set
variables {α : Type*} [preorder α] {s : set α}

protected lemma finite.upper_closure [locally_finite_order_top α] (hs : s.finite) :
  (upper_closure s : set α).finite :=
by { rw coe_upper_closure, exact hs.bUnion (λ _ _, finite_Ici _) }

protected lemma finite.lower_closure [locally_finite_order_bot α] (hs : s.finite) :
  (lower_closure s : set α).finite :=
by { rw coe_lower_closure, exact hs.bUnion (λ _ _, finite_Iic _) }

end set


/-
Copyright (c) 2020 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz
-/
import data.finset.basic

/-!
# Constructions involving sets of sets.

## Finite Intersections

We define a structure `has_finite_inter` which asserts that a set `S` of subsets of `α` is
closed under finite intersections.

We define `finite_inter_closure` which, given a set `S` of subsets of `α`, is the smallest
set of subsets of `α` which is closed under finite intersections.

`finite_inter_closure S` is endowed with a term of type `has_finite_inter` using
`finite_inter_closure_has_finite_inter`.

-/

variables {α : Type*} (S : set (set α))

/-- A structure encapsulating the fact that a set of sets is closed under finite intersection. -/
structure has_finite_inter :=
(univ_mem : set.univ ∈ S)
(inter_mem {s t} : s ∈ S → t ∈ S → s ∩ t ∈ S)

namespace has_finite_inter

-- Satisfying the inhabited linter...
instance : inhabited (has_finite_inter ({set.univ} : set (set α))) :=
⟨⟨by tauto, λ _ _ h1 h2, by finish⟩⟩

/-- The smallest set of sets containing `S` which is closed under finite intersections. -/
inductive finite_inter_closure : set (set α)
| basic {s} : s ∈ S → finite_inter_closure s
| univ : finite_inter_closure set.univ
| inter {s t} : finite_inter_closure s → finite_inter_closure t → finite_inter_closure (s ∩ t)

/-- Defines `has_finite_inter` for `finite_inter_closure S`. -/
def finite_inter_closure_has_finite_inter : has_finite_inter (finite_inter_closure S) :=
{ univ_mem := finite_inter_closure.univ,
  inter_mem := λ _ _, finite_inter_closure.inter }

variable {S}
lemma finite_inter_mem (cond : has_finite_inter S) (F : finset (set α)) :
  ↑F ⊆ S → ⋂₀ (↑F : set (set α)) ∈ S :=
begin
  classical,
  refine finset.induction_on F (λ _, _) _,
  { simp [cond.univ_mem] },
  { intros a s h1 h2 h3,
    suffices : a ∩ ⋂₀ ↑s ∈ S, by simpa,
    exact cond.inter_mem (h3 (finset.mem_insert_self a s))
                         (h2 $ λ x hx, h3 $ finset.mem_insert_of_mem hx) }
end

lemma finite_inter_closure_insert {A : set α} (cond : has_finite_inter S)
  (P ∈ finite_inter_closure (insert A S)) : P ∈ S ∨ ∃ Q ∈ S, P = A ∩ Q :=
begin
  induction H with S h T1 T2 _ _ h1 h2,
  { cases h,
    { exact or.inr ⟨set.univ, cond.univ_mem, by simpa⟩ },
    { exact or.inl h } },
  { exact or.inl cond.univ_mem },
  { rcases h1 with (h | ⟨Q, hQ, rfl⟩); rcases h2 with (i | ⟨R, hR, rfl⟩),
    { exact or.inl (cond.inter_mem h i) },
    { exact or.inr ⟨T1 ∩ R, cond.inter_mem h hR, by finish⟩ },
    { exact or.inr ⟨Q ∩ T2, cond.inter_mem hQ i, by finish⟩ },
    { exact or.inr ⟨Q ∩ R, cond.inter_mem hQ hR , by tidy⟩ } }
end

end has_finite_inter


/- LoVe Exercise 1: Definitions and Lemma Statements -/

/- Replace the placeholders (e.g., `:= sorry`) with your solutions. -/

import .love01_definitions_and_lemma_statements_demo

namespace LoVe

/- Question 1: Fibonacci Numbers -/

/- 1.1. Define the function `fib` that computes the Fibonacci numbers. -/

def fib : ℕ → ℕ
:= sorry

/- 1.2. Check that your function works as expected. -/

#reduce fib 0  -- expected: 0
#reduce fib 1  -- expected: 1
#reduce fib 2  -- expected: 1
#reduce fib 3  -- expected: 2
#reduce fib 4  -- expected: 3
#reduce fib 5  -- expected: 5
#reduce fib 6  -- expected: 8
#reduce fib 7  -- expected: 13
#reduce fib 8  -- expected: 21

/- Question 2: Arithmetic Expressions -/

/- Consider the type `aexp` from the lecture. -/

#print aexp
#check eval

/- 2.1. Test that `eval` behaves as expected. Making sure to exercise each
constructor at least once. You can use the following environment in your
tests. What happens if you divide by zero? -/

def some_env : string → ℤ
| "x" := 3
| "y" := 17
| _   := 201

-- invoke `#eval` here

/- 2.2. The following function simplifies arithmetic expressions involving
addition. It simplifies `0 + e` and `e + 0` to `e`. Complete the definition so
that it also simplifies expressions involving the other three binary
operators. -/

def simplify : aexp → aexp
| (aexp.add (aexp.num 0) e₂) := simplify e₂
| (aexp.add e₁ (aexp.num 0)) := simplify e₁
-- insert the missing cases here
-- catch-all cases below
| (aexp.num i)               := aexp.num i
| (aexp.var x)               := aexp.var x
| (aexp.add e₁ e₂)           := aexp.add (simplify e₁) (simplify e₂)
| (aexp.sub e₁ e₂)           := aexp.sub (simplify e₁) (simplify e₂)
| (aexp.mul e₁ e₂)           := aexp.mul (simplify e₁) (simplify e₂)
| (aexp.div e₁ e₂)           := aexp.div (simplify e₁) (simplify e₂)

/- 2.3. State the correctness lemma for `simplify`, namely that the simplified
expression should have the same semantics, with respect to `eval`, as the
original expression. -/

-- enter your lemma statement here

/- Question 3: λ-Terms -/

/- We start by declaring three new opaque types. -/

constants α β γ : Type

/- 3.1. Complete the following definitions, by replacing the `sorry` markers by
terms of the expected type.

Hint: You can use `_` as a placeholder while constructing a term. By hovering
over `_`, you will see the current logical context. -/

def I : α → α :=
λa, a

def K : α → β → α :=
λa b, a

def C : (α → β → γ) → β → α → γ :=
sorry

def proj_1st : α → α → α :=
sorry

-- please give a different answer than for `proj_1st`
def proj_2nd : α → α → α :=
sorry

def some_nonsense : (α → β → γ) → α → (α → γ) → β → γ :=
sorry

/- 3.2. Show the typing derivation for your definition of `C` above. -/

-- write your solution here in a comment or on paper

end LoVe


def f (x y z : Nat) : Nat :=
  match x, y, z with
  | 5, _, _ => y
  | _, 5, _ => y
  | _, _, 5 => y
  | _, _, _ => 1

example (x y z : Nat) : x ≠ 5 → y ≠ 5 → z ≠ 5 → f x y z = 1 := by
  intros
  simp (config := { iota := false }) [f]
  split
  · contradiction
  · contradiction
  · contradiction
  · rfl

example (x y z : Nat) : f x y z = y ∨ f x y z = 1 := by
  intros
  simp [f]
  split
  · exact Or.inl rfl
  · exact Or.inl rfl
  · exact Or.inl rfl
  · exact Or.inr rfl

example (x y z : Nat) : f x y z = y ∨ f x y z = 1 := by
  intros
  simp [f]
  split <;> (first | apply Or.inl rfl | apply Or.inr rfl)

def g (xs ys : List Nat) : Nat :=
  match xs, ys with
  | [a, b], _ => Nat.succ (a+b)
  | _, [b, c] => Nat.succ b
  | _, _   => 1

example (xs ys : List Nat) : g xs ys > 0 := by
  simp [g]
  split
  next a b      => show Nat.succ (a + b) > 0; apply Nat.zero_lt_succ
  next xs b c _ => show Nat.succ b > 0; apply Nat.zero_lt_succ
  next => decide


import convex convex_body finset

open_locale topological_space

-- needed to get decidable_eq for sets!
open classical
local attribute [instance] prop_decidable

variables {V: Type} [inner_product_space ℝ V] [finite_dimensional ℝ V]

def polytope (V : Type) [inner_product_space ℝ V] [finite_dimensional ℝ V] :=
{ P : set V // is_polytope P }

instance polytope.has_lift_t : has_lift_t (polytope V) (set V) :=
{
  lift := (coe : { P // is_polytope P } → set V)
}

lemma polytope_convex {P : set V} (hP : is_polytope P) :
convex ℝ P :=
begin
  obtain ⟨S, Sfin, Sne, rfl⟩ := hP,
  exact convex_convex_hull ℝ S,
end

lemma is_convex_body_of_is_polytope {P : set V} (hP : is_polytope P) :
is_convex_body P :=
begin
  --let hP' := hP,
  obtain ⟨S, Sfin, Sne, rfl⟩ := id hP,
  refine ⟨_, _, _⟩,
  {
    exact polytope_convex hP,
  },
  {
    exact Sfin.compact_convex_hull,
  },
  {
    exact Sne.convex_hull,
  },
end

def convex_body_of_polytope (P : polytope V) : convex_body V :=
⟨P.val, is_convex_body_of_is_polytope P.property⟩

lemma polytope_normal_face_nonempty {P : set V} (hP : is_polytope P) (u : V) :
(normal_face P u).nonempty :=
begin
  let K : convex_body V := ⟨P, is_convex_body_of_is_polytope hP⟩,
  exact K.normal_face_nonempty u,
end

@[simp]
lemma normal_face_idem_poly
(P : polytope V) (u : V) :
normal_face (normal_face ↑P u) u = normal_face ↑P u :=
begin
  ext,
  simp only [mem_normal_face, ge_iff_le, and_imp, and_iff_left_iff_imp],
  intros xK hx y yK hy,
  exact hx y yK,
end

/- lemma approximate_with_polytopes (K : convex_body V) :
∃ P : ℕ → polytope V,
filter.tendsto (convex_body_of_polytope ∘ P) filter.at_top (𝓝 K) := sorry -/

lemma finset_facial_gap {S : finset V} (u : V) (Sne : (normal_face ↑S u).nonempty) :
∃ ε : ℝ, ε > 0 ∧
∀ x y : V, x ∈ ↑S \ normal_face ↑S u → y ∈ normal_face ↑S u →
⟪(y - x), u⟫_ℝ > ε :=
begin
  by_cases hne : S.nonempty, rotate,
  {
    simp only [finset.not_nonempty_iff_eq_empty] at hne,
    obtain rfl := hne,
    refine ⟨1, zero_lt_one, _⟩,
    simp only [finset.coe_empty, set.empty_diff, set.mem_empty_eq, is_empty.forall_iff, forall_const, implies_true_iff],
  },
  by_cases h : normal_face ↑S u = ↑S,
  {
    refine ⟨1, zero_lt_one, _⟩,
    rw [h],
    intros x y hx xy,
    simp only [set.diff_self, set.mem_empty_eq] at hx,
    contradiction,
  },
  have Sfin : (↑S : set V).finite,
  {
    apply set.finite.of_finset S,
    simp only [finset.mem_coe, iff_self, forall_const],
  },
  have nSfin : (normal_face ↑S u).finite := Sfin.subset normal_face_subset,
  let nS' := nSfin.to_finset,
  have cSfin : (↑S \ normal_face ↑S u).finite := Sfin.subset (set.diff_subset _ _),
  have cSne : (↑S \ normal_face ↑S u).nonempty,
  {
    rw [←set.ne_empty_iff_nonempty],
    intro hc,
    apply h,
    refine subset_antisymm normal_face_subset _,
    rw [set.diff_eq_empty] at hc,
    exact hc,
  },
  let cS' := cSfin.to_finset,
  have nS'ne : nS'.nonempty,
  {
    obtain ⟨x, hx⟩ := Sne,
    refine ⟨x, _⟩,
    rw [set.finite.mem_to_finset],
    exact hx,
  },
  have cS'ne : cS'.nonempty,
  {
    obtain ⟨x, hx⟩ := cSne,
    refine ⟨x, _⟩,
    rw [set.finite.mem_to_finset],
    exact hx,
  },
  let T := finset.product nS' cS',
  let f : V × V → ℝ := λ pr, ⟪pr.snd - pr.fst, u⟫_ℝ,
  obtain ⟨p, hp, prop⟩ := ex_finset_argmax f (finset.nonempty_product.mpr ⟨nS'ne, cS'ne⟩),
  rw [finset.mem_product] at hp,
  let δ := f p,
  let ε := -(1/2) * δ,
  have hδ : δ < 0,
  {
    simp only [δ, f],
    by_contra,
    replace h := le_of_not_gt h,
    simp only [inner_sub_left, sub_nonneg] at h,
    rcases hp with ⟨hp₁, hp₂⟩,
    simp only [set.finite.mem_to_finset, set.mem_diff] at hp₁ hp₂,
    apply hp₂.2,
    simp only [mem_normal_face] at hp₁ ⊢,
    refine ⟨hp₂.1, _⟩,
    intros y hy,
    exact le_trans (hp₁.2 y hy) h,
  },
  refine ⟨ε, _, _⟩,
  {
    apply mul_pos_of_neg_of_neg,
    {simp only [one_div, right.neg_neg_iff, inv_pos, zero_lt_bit0, zero_lt_one]},
    {exact hδ},
  },
  {
    intros l m hl hm,
    simp only [ε],
    rw [←neg_sub, inner_neg_left, neg_mul, gt_iff_lt, neg_lt_neg_iff],
    simp only [finset.mem_product, set.finite.mem_to_finset] at prop,
    have hle := prop ⟨m, l⟩ ⟨hm, hl⟩,
    simp only [f, ge_iff_le] at hle,
    refine lt_of_le_of_lt hle _,
    change δ < 1 / 2 * δ,
    rw [←neg_lt_neg_iff, ←mul_neg],
    rw [←neg_neg δ] at hδ,
    refine lt_of_le_of_lt (le_of_eq _) (half_lt_self (pos_of_neg_neg hδ)),
    ring,
  },
end

lemma polytope_facial_gap {P : set V} (hP : is_polytope P) (u : V) :
∃ ε : ℝ, ε > 0 ∧ ∀ v ∈ metric.ball u ε,
normal_face P v ⊆ normal_face P u :=
begin
  obtain ⟨S, Sfin, Sne, rfl⟩ := id hP,
  let S' := Sfin.to_finset,
  have S'ne : S'.nonempty,
  {
    obtain ⟨x, hx⟩ := Sne,
    refine ⟨x, _⟩,
    simp only [set.finite.mem_to_finset],
    exact hx,
  },
  have fne := polytope_normal_face_nonempty hP u,
  have fne' : (normal_face ↑S' u).nonempty,
  {
    rw [normal_face_spanned_by_verts, convex_hull_nonempty_iff] at fne,
    obtain ⟨x, hx⟩ := fne,
    refine ⟨x, _⟩,
    simp only [set.finite.coe_to_finset],
    exact hx,
  },
  rcases finset_facial_gap u fne' with ⟨ε, hε, gap⟩,
  let g := λ x : V, ∥x∥,
  obtain ⟨z, zS, hz⟩ := ex_finset_argmax g S'ne,
  simp only [set.finite.mem_to_finset] at zS hz,
  simp only [g] at hz,

  let f := λ x : ℝ, (∥z∥ + ∥z∥) * x,
  have fcont : continuous f := by continuity,
  have ftt : filter.tendsto f (𝓝 0) (𝓝 _) := fcont.continuous_at,
  have f0 : f 0 = 0,
  {
    simp only [f],
    ring,
  },
  simp only [filter.tendsto_def, f0] at ftt,
  replace ftt := ftt _ (metric.ball_mem_nhds 0 hε),
  simp only [metric.mem_nhds_iff, real.ball_eq_Ioo] at ftt,
  rcases ftt with ⟨τ, hτ, balls⟩,
  let ρ := τ / 2,
  have hρ : ρ > 0 := by exact half_pos hτ,
  have fρ : f ρ < ε,
  {
    simp only [zero_add] at balls,
    refine (balls _).2,
    split,
    {
      simp only [ρ],
      apply sub_left_lt_of_lt_add,
      positivity,
    },
    {
      exact half_lt_self hτ,
    },
  },

  let δ : ℝ := ρ,
  have hδ : δ > 0 := hρ,
  refine ⟨δ, hδ, _⟩,
  intros v hv,
  simp only [normal_face_spanned_by_verts],
  apply convex_hull_mono,
  intros x hx,
  rw [mem_normal_face] at hx,
  obtain ⟨y, hy⟩ := fne',
  by_contradiction hc,
  replace hc : x ∈ ↑S' \ normal_face ↑S' u,
  {
    simp only [set.finite.coe_to_finset, set.mem_diff],
    exact ⟨hx.1, hc⟩,
  },
  replace gap := gap _ _ hc hy,
  rw [inner_sub_left, gt_iff_lt, lt_sub] at gap,
  have yS : y ∈ S,
  {
    simp only [set.finite.coe_to_finset] at hy,
    exact normal_face_subset hy,
  },
  have hx' := hx.2 y yS,
  have hyu : ⟪y, u⟫_ℝ ≤ ⟪y, v⟫_ℝ + ∥y∥ * δ,
  {
    rw [metric.mem_ball_comm, mem_ball_iff_norm] at hv,
    rw [←sub_le_iff_le_add', ←inner_sub_right],
    refine le_trans (real_inner_le_norm y (u - v)) _,
    exact mul_le_mul_of_nonneg_left (le_of_lt hv) (norm_nonneg _),
  },
  have hxv : ⟪x, v⟫_ℝ ≤ ⟪x, u⟫_ℝ + ∥x∥ * δ,
  {
    rw [mem_ball_iff_norm] at hv,
    rw [←sub_le_iff_le_add', ←inner_sub_right],
    refine le_trans (real_inner_le_norm x (v - u)) _,
    exact mul_le_mul_of_nonneg_left (le_of_lt hv) (norm_nonneg _),
  },
  have := gap,
  replace := lt_of_lt_of_le this (sub_le_sub_right hyu _),
  rw [add_sub_assoc] at this,
  replace := lt_of_lt_of_le this (add_le_add_right hx' _),
  replace := lt_of_lt_of_le this (add_le_add_right hxv _),
  rw [add_assoc, lt_add_iff_pos_right, ←add_sub_assoc, ←add_mul, sub_pos] at this,
  rw [set.finite.coe_to_finset] at hc,
  replace := lt_of_lt_of_le this
  (mul_le_mul_of_nonneg_right (
    add_le_add (hz x hc.1) (hz y yS)
  ) (le_of_lt hδ)),
  simp only [δ, f, ρ] at this fρ,
  linarith,
end


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

! This file was ported from Lean 3 source module group_theory.perm.subgroup
! leanprover-community/mathlib commit 4c19a16e4b705bf135cf9a80ac18fcc99c438514
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.GroupTheory.Perm.Basic
import Mathlib.Data.Fintype.Perm
import Mathlib.GroupTheory.Subgroup.Finite

/-!
# Lemmas about subgroups within the permutations (self-equivalences) of a type `α`

This file provides extra lemmas about some `Subgroup`s that exist within `Equiv.Perm α`.
`GroupTheory.Subgroup` depends on `GroupTheory.Perm.Basic`, so these need to be in a separate
file.

It also provides decidable instances on membership in these subgroups, since
`MonoidHom.decidableMemRange` cannot be inferred without the help of a lambda.
The presence of these instances induces a `Fintype` instance on the `QuotientGroup.Quotient` of
these subgroups.
-/

namespace Equiv

namespace Perm

universe u

instance sumCongrHom.decidableMemRange {α β : Type _} [DecidableEq α] [DecidableEq β] [Fintype α]
    [Fintype β] : DecidablePred (· ∈ (sumCongrHom α β).range) := fun _ => inferInstance
#align equiv.perm.sum_congr_hom.decidable_mem_range Equiv.Perm.sumCongrHom.decidableMemRange

@[simp]
theorem sumCongrHom.card_range {α β : Type _} [Fintype (sumCongrHom α β).range]
    [Fintype (Perm α × Perm β)] :
    Fintype.card (sumCongrHom α β).range = Fintype.card (Perm α × Perm β) :=
  Fintype.card_eq.mpr ⟨(ofInjective (sumCongrHom α β) sumCongrHom_injective).symm⟩
#align equiv.perm.sum_congr_hom.card_range Equiv.Perm.sumCongrHom.card_range

instance sigmaCongrRightHom.decidableMemRange {α : Type _} {β : α → Type _} [DecidableEq α]
    [∀ a, DecidableEq (β a)] [Fintype α] [∀ a, Fintype (β a)] :
    DecidablePred (· ∈ (sigmaCongrRightHom β).range) := fun _ => inferInstance
#align equiv.perm.sigma_congr_right_hom.decidable_mem_range Equiv.Perm.sigmaCongrRightHom.decidableMemRange

@[simp]
theorem sigmaCongrRightHom.card_range {α : Type _} {β : α → Type _}
    [Fintype (sigmaCongrRightHom β).range] [Fintype (∀ a, Perm (β a))] :
    Fintype.card (sigmaCongrRightHom β).range = Fintype.card (∀ a, Perm (β a)) :=
  Fintype.card_eq.mpr ⟨(ofInjective (sigmaCongrRightHom β) sigmaCongrRightHom_injective).symm⟩
#align equiv.perm.sigma_congr_right_hom.card_range Equiv.Perm.sigmaCongrRightHom.card_range

instance subtypeCongrHom.decidableMemRange {α : Type _} (p : α → Prop) [DecidablePred p]
    [Fintype (Perm { a // p a } × Perm { a // ¬p a })] [DecidableEq (Perm α)] :
    DecidablePred (· ∈ (subtypeCongrHom p).range) := fun _ => inferInstance
#align equiv.perm.subtype_congr_hom.decidable_mem_range Equiv.Perm.subtypeCongrHom.decidableMemRange

@[simp]
theorem subtypeCongrHom.card_range {α : Type _} (p : α → Prop) [DecidablePred p]
    [Fintype (subtypeCongrHom p).range] [Fintype (Perm { a // p a } × Perm { a // ¬p a })] :
    Fintype.card (subtypeCongrHom p).range =
      Fintype.card (Perm { a // p a } × Perm { a // ¬p a }) :=
  Fintype.card_eq.mpr ⟨(ofInjective (subtypeCongrHom p) (subtypeCongrHom_injective p)).symm⟩
#align equiv.perm.subtype_congr_hom.card_range Equiv.Perm.subtypeCongrHom.card_range

/-- **Cayley's theorem**: Every group G is isomorphic to a subgroup of the symmetric group acting on
`G`. Note that we generalize this to an arbitrary "faithful" group action by `G`. Setting `H = G`
recovers the usual statement of Cayley's theorem via `RightCancelMonoid.faithfulSMul` -/
noncomputable def subgroupOfMulAction (G H : Type _) [Group G] [MulAction G H] [FaithfulSMul G H] :
    G ≃* (MulAction.toPermHom G H).range :=
  MulEquiv.ofLeftInverse' _ (Classical.choose_spec MulAction.toPerm_injective.hasLeftInverse)
#align equiv.perm.subgroup_of_mul_action Equiv.Perm.subgroupOfMulAction

end Perm

end Equiv