/-
Copyright (c) 2020 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 analysis.inner_product_space.calculus
! leanprover-community/mathlib commit 46b633fd842bef9469441c0209906f6dddd2b4f5
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.InnerProductSpace.PiL2
import Mathbin.Analysis.SpecialFunctions.Sqrt

/-!
# Calculus in inner product spaces

In this file we prove that the inner product and square of the norm in an inner space are
infinitely `ℝ`-smooth. In order to state these results, we need a `normed_space ℝ E`
instance. Though we can deduce this structure from `inner_product_space 𝕜 E`, this instance may be
not definitionally equal to some other “natural” instance. So, we assume `[normed_space ℝ E]`.

We also prove that functions to a `euclidean_space` are (higher) differentiable if and only if
their components are. This follows from the corresponding fact for finite product of normed spaces,
and from the equivalence of norms in finite dimensions.

## TODO

The last part of the file should be generalized to `pi_Lp`.
-/

noncomputable section

open IsROrC Real Filter

open BigOperators Classical Topology

section DerivInner

variable {𝕜 E F : Type _} [IsROrC 𝕜]

variable [NormedAddCommGroup E] [InnerProductSpace 𝕜 E]

variable [NormedAddCommGroup F] [InnerProductSpace ℝ F]

-- mathport name: «expr⟪ , ⟫»
local notation "⟪" x ", " y "⟫" => @inner 𝕜 _ _ x y

variable (𝕜) [NormedSpace ℝ E]

/-- Derivative of the inner product. -/
def fderivInnerClm (p : E × E) : E × E →L[ℝ] 𝕜 :=
  isBoundedBilinearMapInner.deriv p
#align fderiv_inner_clm fderivInnerClm

@[simp]
theorem fderivInnerClm_apply (p x : E × E) : fderivInnerClm 𝕜 p x = ⟪p.1, x.2⟫ + ⟪x.1, p.2⟫ :=
  rfl
#align fderiv_inner_clm_apply fderivInnerClm_apply

theorem contDiff_inner {n} : ContDiff ℝ n fun p : E × E => ⟪p.1, p.2⟫ :=
  isBoundedBilinearMapInner.ContDiff
#align cont_diff_inner contDiff_inner

theorem contDiffAt_inner {p : E × E} {n} : ContDiffAt ℝ n (fun p : E × E => ⟪p.1, p.2⟫) p :=
  contDiff_inner.ContDiffAt
#align cont_diff_at_inner contDiffAt_inner

theorem differentiable_inner : Differentiable ℝ fun p : E × E => ⟪p.1, p.2⟫ :=
  isBoundedBilinearMapInner.DifferentiableAt
#align differentiable_inner differentiable_inner

variable {G : Type _} [NormedAddCommGroup G] [NormedSpace ℝ G] {f g : G → E} {f' g' : G →L[ℝ] E}
  {s : Set G} {x : G} {n : ℕ∞}

include 𝕜

theorem ContDiffWithinAt.inner (hf : ContDiffWithinAt ℝ n f s x) (hg : ContDiffWithinAt ℝ n g s x) :
    ContDiffWithinAt ℝ n (fun x => ⟪f x, g x⟫) s x :=
  contDiffAt_inner.comp_contDiffWithinAt x (hf.Prod hg)
#align cont_diff_within_at.inner ContDiffWithinAt.inner

theorem ContDiffAt.inner (hf : ContDiffAt ℝ n f x) (hg : ContDiffAt ℝ n g x) :
    ContDiffAt ℝ n (fun x => ⟪f x, g x⟫) x :=
  hf.inner 𝕜 hg
#align cont_diff_at.inner ContDiffAt.inner

theorem ContDiffOn.inner (hf : ContDiffOn ℝ n f s) (hg : ContDiffOn ℝ n g s) :
    ContDiffOn ℝ n (fun x => ⟪f x, g x⟫) s := fun x hx => (hf x hx).inner 𝕜 (hg x hx)
#align cont_diff_on.inner ContDiffOn.inner

theorem ContDiff.inner (hf : ContDiff ℝ n f) (hg : ContDiff ℝ n g) :
    ContDiff ℝ n fun x => ⟪f x, g x⟫ :=
  contDiff_inner.comp (hf.Prod hg)
#align cont_diff.inner ContDiff.inner

theorem HasFderivWithinAt.inner (hf : HasFderivWithinAt f f' s x)
    (hg : HasFderivWithinAt g g' s x) :
    HasFderivWithinAt (fun t => ⟪f t, g t⟫) ((fderivInnerClm 𝕜 (f x, g x)).comp <| f'.Prod g') s
      x :=
  (isBoundedBilinearMapInner.HasFderivAt (f x, g x)).comp_hasFderivWithinAt x (hf.Prod hg)
#align has_fderiv_within_at.inner HasFderivWithinAt.inner

theorem HasStrictFderivAt.inner (hf : HasStrictFderivAt f f' x) (hg : HasStrictFderivAt g g' x) :
    HasStrictFderivAt (fun t => ⟪f t, g t⟫) ((fderivInnerClm 𝕜 (f x, g x)).comp <| f'.Prod g') x :=
  (isBoundedBilinearMapInner.HasStrictFderivAt (f x, g x)).comp x (hf.Prod hg)
#align has_strict_fderiv_at.inner HasStrictFderivAt.inner

theorem HasFderivAt.inner (hf : HasFderivAt f f' x) (hg : HasFderivAt g g' x) :
    HasFderivAt (fun t => ⟪f t, g t⟫) ((fderivInnerClm 𝕜 (f x, g x)).comp <| f'.Prod g') x :=
  (isBoundedBilinearMapInner.HasFderivAt (f x, g x)).comp x (hf.Prod hg)
#align has_fderiv_at.inner HasFderivAt.inner

theorem HasDerivWithinAt.inner {f g : ℝ → E} {f' g' : E} {s : Set ℝ} {x : ℝ}
    (hf : HasDerivWithinAt f f' s x) (hg : HasDerivWithinAt g g' s x) :
    HasDerivWithinAt (fun t => ⟪f t, g t⟫) (⟪f x, g'⟫ + ⟪f', g x⟫) s x := by
  simpa using (hf.has_fderiv_within_at.inner 𝕜 hg.has_fderiv_within_at).HasDerivWithinAt
#align has_deriv_within_at.inner HasDerivWithinAt.inner

theorem HasDerivAt.inner {f g : ℝ → E} {f' g' : E} {x : ℝ} :
    HasDerivAt f f' x →
      HasDerivAt g g' x → HasDerivAt (fun t => ⟪f t, g t⟫) (⟪f x, g'⟫ + ⟪f', g x⟫) x :=
  by simpa only [← hasDerivWithinAt_univ] using HasDerivWithinAt.inner 𝕜
#align has_deriv_at.inner HasDerivAt.inner

theorem DifferentiableWithinAt.inner (hf : DifferentiableWithinAt ℝ f s x)
    (hg : DifferentiableWithinAt ℝ g s x) : DifferentiableWithinAt ℝ (fun x => ⟪f x, g x⟫) s x :=
  ((differentiable_inner _).HasFderivAt.comp_hasFderivWithinAt x
      (hf.Prod hg).HasFderivWithinAt).DifferentiableWithinAt
#align differentiable_within_at.inner DifferentiableWithinAt.inner

theorem DifferentiableAt.inner (hf : DifferentiableAt ℝ f x) (hg : DifferentiableAt ℝ g x) :
    DifferentiableAt ℝ (fun x => ⟪f x, g x⟫) x :=
  (differentiable_inner _).comp x (hf.Prod hg)
#align differentiable_at.inner DifferentiableAt.inner

theorem DifferentiableOn.inner (hf : DifferentiableOn ℝ f s) (hg : DifferentiableOn ℝ g s) :
    DifferentiableOn ℝ (fun x => ⟪f x, g x⟫) s := fun x hx => (hf x hx).inner 𝕜 (hg x hx)
#align differentiable_on.inner DifferentiableOn.inner

theorem Differentiable.inner (hf : Differentiable ℝ f) (hg : Differentiable ℝ g) :
    Differentiable ℝ fun x => ⟪f x, g x⟫ := fun x => (hf x).inner 𝕜 (hg x)
#align differentiable.inner Differentiable.inner

theorem fderiv_inner_apply (hf : DifferentiableAt ℝ f x) (hg : DifferentiableAt ℝ g x) (y : G) :
    fderiv ℝ (fun t => ⟪f t, g t⟫) x y = ⟪f x, fderiv ℝ g x y⟫ + ⟪fderiv ℝ f x y, g x⟫ :=
  by
  rw [(hf.has_fderiv_at.inner 𝕜 hg.has_fderiv_at).fderiv]
  rfl
#align fderiv_inner_apply fderiv_inner_apply

theorem deriv_inner_apply {f g : ℝ → E} {x : ℝ} (hf : DifferentiableAt ℝ f x)
    (hg : DifferentiableAt ℝ g x) :
    deriv (fun t => ⟪f t, g t⟫) x = ⟪f x, deriv g x⟫ + ⟪deriv f x, g x⟫ :=
  (hf.HasDerivAt.inner 𝕜 hg.HasDerivAt).deriv
#align deriv_inner_apply deriv_inner_apply

theorem contDiff_norm_sq : ContDiff ℝ n fun x : E => ‖x‖ ^ 2 :=
  by
  simp only [sq, ← @inner_self_eq_norm_mul_norm 𝕜]
  exact (re_clm : 𝕜 →L[ℝ] ℝ).ContDiff.comp (cont_diff_id.inner 𝕜 contDiff_id)
#align cont_diff_norm_sq contDiff_norm_sq

theorem ContDiff.norm_sq (hf : ContDiff ℝ n f) : ContDiff ℝ n fun x => ‖f x‖ ^ 2 :=
  (contDiff_norm_sq 𝕜).comp hf
#align cont_diff.norm_sq ContDiff.norm_sq

theorem ContDiffWithinAt.norm_sq (hf : ContDiffWithinAt ℝ n f s x) :
    ContDiffWithinAt ℝ n (fun y => ‖f y‖ ^ 2) s x :=
  (contDiff_norm_sq 𝕜).ContDiffAt.comp_contDiffWithinAt x hf
#align cont_diff_within_at.norm_sq ContDiffWithinAt.norm_sq

theorem ContDiffAt.norm_sq (hf : ContDiffAt ℝ n f x) : ContDiffAt ℝ n (fun y => ‖f y‖ ^ 2) x :=
  hf.normSq 𝕜
#align cont_diff_at.norm_sq ContDiffAt.norm_sq

theorem contDiffAt_norm {x : E} (hx : x ≠ 0) : ContDiffAt ℝ n norm x :=
  by
  have : ‖id x‖ ^ 2 ≠ 0 := pow_ne_zero _ (norm_pos_iff.2 hx).ne'
  simpa only [id, sqrt_sq, norm_nonneg] using (cont_diff_at_id.norm_sq 𝕜).sqrt this
#align cont_diff_at_norm contDiffAt_norm

theorem ContDiffAt.norm (hf : ContDiffAt ℝ n f x) (h0 : f x ≠ 0) :
    ContDiffAt ℝ n (fun y => ‖f y‖) x :=
  (contDiffAt_norm 𝕜 h0).comp x hf
#align cont_diff_at.norm ContDiffAt.norm

theorem ContDiffAt.dist (hf : ContDiffAt ℝ n f x) (hg : ContDiffAt ℝ n g x) (hne : f x ≠ g x) :
    ContDiffAt ℝ n (fun y => dist (f y) (g y)) x :=
  by
  simp only [dist_eq_norm]
  exact (hf.sub hg).norm 𝕜 (sub_ne_zero.2 hne)
#align cont_diff_at.dist ContDiffAt.dist

theorem ContDiffWithinAt.norm (hf : ContDiffWithinAt ℝ n f s x) (h0 : f x ≠ 0) :
    ContDiffWithinAt ℝ n (fun y => ‖f y‖) s x :=
  (contDiffAt_norm 𝕜 h0).comp_contDiffWithinAt x hf
#align cont_diff_within_at.norm ContDiffWithinAt.norm

theorem ContDiffWithinAt.dist (hf : ContDiffWithinAt ℝ n f s x) (hg : ContDiffWithinAt ℝ n g s x)
    (hne : f x ≠ g x) : ContDiffWithinAt ℝ n (fun y => dist (f y) (g y)) s x :=
  by
  simp only [dist_eq_norm]
  exact (hf.sub hg).norm 𝕜 (sub_ne_zero.2 hne)
#align cont_diff_within_at.dist ContDiffWithinAt.dist

theorem ContDiffOn.norm_sq (hf : ContDiffOn ℝ n f s) : ContDiffOn ℝ n (fun y => ‖f y‖ ^ 2) s :=
  fun x hx => (hf x hx).normSq 𝕜
#align cont_diff_on.norm_sq ContDiffOn.norm_sq

theorem ContDiffOn.norm (hf : ContDiffOn ℝ n f s) (h0 : ∀ x ∈ s, f x ≠ 0) :
    ContDiffOn ℝ n (fun y => ‖f y‖) s := fun x hx => (hf x hx).norm 𝕜 (h0 x hx)
#align cont_diff_on.norm ContDiffOn.norm

theorem ContDiffOn.dist (hf : ContDiffOn ℝ n f s) (hg : ContDiffOn ℝ n g s)
    (hne : ∀ x ∈ s, f x ≠ g x) : ContDiffOn ℝ n (fun y => dist (f y) (g y)) s := fun x hx =>
  (hf x hx).dist 𝕜 (hg x hx) (hne x hx)
#align cont_diff_on.dist ContDiffOn.dist

theorem ContDiff.norm (hf : ContDiff ℝ n f) (h0 : ∀ x, f x ≠ 0) : ContDiff ℝ n fun y => ‖f y‖ :=
  contDiff_iff_contDiffAt.2 fun x => hf.ContDiffAt.norm 𝕜 (h0 x)
#align cont_diff.norm ContDiff.norm

theorem ContDiff.dist (hf : ContDiff ℝ n f) (hg : ContDiff ℝ n g) (hne : ∀ x, f x ≠ g x) :
    ContDiff ℝ n fun y => dist (f y) (g y) :=
  contDiff_iff_contDiffAt.2 fun x => hf.ContDiffAt.dist 𝕜 hg.ContDiffAt (hne x)
#align cont_diff.dist ContDiff.dist

omit 𝕜

theorem hasStrictFderivAt_norm_sq (x : F) :
    HasStrictFderivAt (fun x => ‖x‖ ^ 2) (bit0 (innerSL ℝ x)) x :=
  by
  simp only [sq, ← @inner_self_eq_norm_mul_norm ℝ]
  convert(hasStrictFderivAt_id x).inner ℝ (hasStrictFderivAt_id x)
  ext y
  simp [bit0, real_inner_comm]
#align has_strict_fderiv_at_norm_sq hasStrictFderivAt_norm_sq

include 𝕜

theorem DifferentiableAt.norm_sq (hf : DifferentiableAt ℝ f x) :
    DifferentiableAt ℝ (fun y => ‖f y‖ ^ 2) x :=
  ((contDiffAt_id.normSq 𝕜).DifferentiableAt le_rfl).comp x hf
#align differentiable_at.norm_sq DifferentiableAt.norm_sq

theorem DifferentiableAt.norm (hf : DifferentiableAt ℝ f x) (h0 : f x ≠ 0) :
    DifferentiableAt ℝ (fun y => ‖f y‖) x :=
  ((contDiffAt_norm 𝕜 h0).DifferentiableAt le_rfl).comp x hf
#align differentiable_at.norm DifferentiableAt.norm

theorem DifferentiableAt.dist (hf : DifferentiableAt ℝ f x) (hg : DifferentiableAt ℝ g x)
    (hne : f x ≠ g x) : DifferentiableAt ℝ (fun y => dist (f y) (g y)) x :=
  by
  simp only [dist_eq_norm]
  exact (hf.sub hg).norm 𝕜 (sub_ne_zero.2 hne)
#align differentiable_at.dist DifferentiableAt.dist

theorem Differentiable.norm_sq (hf : Differentiable ℝ f) : Differentiable ℝ fun y => ‖f y‖ ^ 2 :=
  fun x => (hf x).normSq 𝕜
#align differentiable.norm_sq Differentiable.norm_sq

theorem Differentiable.norm (hf : Differentiable ℝ f) (h0 : ∀ x, f x ≠ 0) :
    Differentiable ℝ fun y => ‖f y‖ := fun x => (hf x).norm 𝕜 (h0 x)
#align differentiable.norm Differentiable.norm

theorem Differentiable.dist (hf : Differentiable ℝ f) (hg : Differentiable ℝ g)
    (hne : ∀ x, f x ≠ g x) : Differentiable ℝ fun y => dist (f y) (g y) := fun x =>
  (hf x).dist 𝕜 (hg x) (hne x)
#align differentiable.dist Differentiable.dist

theorem DifferentiableWithinAt.norm_sq (hf : DifferentiableWithinAt ℝ f s x) :
    DifferentiableWithinAt ℝ (fun y => ‖f y‖ ^ 2) s x :=
  ((contDiffAt_id.normSq 𝕜).DifferentiableAt le_rfl).comp_differentiableWithinAt x hf
#align differentiable_within_at.norm_sq DifferentiableWithinAt.norm_sq

theorem DifferentiableWithinAt.norm (hf : DifferentiableWithinAt ℝ f s x) (h0 : f x ≠ 0) :
    DifferentiableWithinAt ℝ (fun y => ‖f y‖) s x :=
  ((contDiffAt_id.norm 𝕜 h0).DifferentiableAt le_rfl).comp_differentiableWithinAt x hf
#align differentiable_within_at.norm DifferentiableWithinAt.norm

theorem DifferentiableWithinAt.dist (hf : DifferentiableWithinAt ℝ f s x)
    (hg : DifferentiableWithinAt ℝ g s x) (hne : f x ≠ g x) :
    DifferentiableWithinAt ℝ (fun y => dist (f y) (g y)) s x :=
  by
  simp only [dist_eq_norm]
  exact (hf.sub hg).norm 𝕜 (sub_ne_zero.2 hne)
#align differentiable_within_at.dist DifferentiableWithinAt.dist

theorem DifferentiableOn.norm_sq (hf : DifferentiableOn ℝ f s) :
    DifferentiableOn ℝ (fun y => ‖f y‖ ^ 2) s := fun x hx => (hf x hx).normSq 𝕜
#align differentiable_on.norm_sq DifferentiableOn.norm_sq

theorem DifferentiableOn.norm (hf : DifferentiableOn ℝ f s) (h0 : ∀ x ∈ s, f x ≠ 0) :
    DifferentiableOn ℝ (fun y => ‖f y‖) s := fun x hx => (hf x hx).norm 𝕜 (h0 x hx)
#align differentiable_on.norm DifferentiableOn.norm

theorem DifferentiableOn.dist (hf : DifferentiableOn ℝ f s) (hg : DifferentiableOn ℝ g s)
    (hne : ∀ x ∈ s, f x ≠ g x) : DifferentiableOn ℝ (fun y => dist (f y) (g y)) s := fun x hx =>
  (hf x hx).dist 𝕜 (hg x hx) (hne x hx)
#align differentiable_on.dist DifferentiableOn.dist

end DerivInner

section PiLike

open ContinuousLinearMap

variable {𝕜 ι H : Type _} [IsROrC 𝕜] [NormedAddCommGroup H] [NormedSpace 𝕜 H] [Fintype ι]
  {f : H → EuclideanSpace 𝕜 ι} {f' : H →L[𝕜] EuclideanSpace 𝕜 ι} {t : Set H} {y : H}

theorem differentiableWithinAt_euclidean :
    DifferentiableWithinAt 𝕜 f t y ↔ ∀ i, DifferentiableWithinAt 𝕜 (fun x => f x i) t y :=
  by
  rw [← (EuclideanSpace.equiv ι 𝕜).comp_differentiableWithinAt_iff, differentiableWithinAt_pi]
  rfl
#align differentiable_within_at_euclidean differentiableWithinAt_euclidean

theorem differentiableAt_euclidean :
    DifferentiableAt 𝕜 f y ↔ ∀ i, DifferentiableAt 𝕜 (fun x => f x i) y :=
  by
  rw [← (EuclideanSpace.equiv ι 𝕜).comp_differentiableAt_iff, differentiableAt_pi]
  rfl
#align differentiable_at_euclidean differentiableAt_euclidean

theorem differentiableOn_euclidean :
    DifferentiableOn 𝕜 f t ↔ ∀ i, DifferentiableOn 𝕜 (fun x => f x i) t :=
  by
  rw [← (EuclideanSpace.equiv ι 𝕜).comp_differentiableOn_iff, differentiableOn_pi]
  rfl
#align differentiable_on_euclidean differentiableOn_euclidean

theorem differentiable_euclidean : Differentiable 𝕜 f ↔ ∀ i, Differentiable 𝕜 fun x => f x i :=
  by
  rw [← (EuclideanSpace.equiv ι 𝕜).comp_differentiable_iff, differentiable_pi]
  rfl
#align differentiable_euclidean differentiable_euclidean

theorem hasStrictFderivAt_euclidean :
    HasStrictFderivAt f f' y ↔
      ∀ i, HasStrictFderivAt (fun x => f x i) (EuclideanSpace.proj i ∘L f') y :=
  by
  rw [← (EuclideanSpace.equiv ι 𝕜).comp_hasStrictFderivAt_iff, hasStrictFderivAt_pi']
  rfl
#align has_strict_fderiv_at_euclidean hasStrictFderivAt_euclidean

theorem hasFderivWithinAt_euclidean :
    HasFderivWithinAt f f' t y ↔
      ∀ i, HasFderivWithinAt (fun x => f x i) (EuclideanSpace.proj i ∘L f') t y :=
  by
  rw [← (EuclideanSpace.equiv ι 𝕜).comp_hasFderivWithinAt_iff, hasFderivWithinAt_pi']
  rfl
#align has_fderiv_within_at_euclidean hasFderivWithinAt_euclidean

theorem contDiffWithinAt_euclidean {n : ℕ∞} :
    ContDiffWithinAt 𝕜 n f t y ↔ ∀ i, ContDiffWithinAt 𝕜 n (fun x => f x i) t y :=
  by
  rw [← (EuclideanSpace.equiv ι 𝕜).comp_contDiffWithinAt_iff, contDiffWithinAt_pi]
  rfl
#align cont_diff_within_at_euclidean contDiffWithinAt_euclidean

theorem contDiffAt_euclidean {n : ℕ∞} :
    ContDiffAt 𝕜 n f y ↔ ∀ i, ContDiffAt 𝕜 n (fun x => f x i) y :=
  by
  rw [← (EuclideanSpace.equiv ι 𝕜).comp_contDiffAt_iff, contDiffAt_pi]
  rfl
#align cont_diff_at_euclidean contDiffAt_euclidean

theorem contDiffOn_euclidean {n : ℕ∞} :
    ContDiffOn 𝕜 n f t ↔ ∀ i, ContDiffOn 𝕜 n (fun x => f x i) t :=
  by
  rw [← (EuclideanSpace.equiv ι 𝕜).comp_contDiffOn_iff, contDiffOn_pi]
  rfl
#align cont_diff_on_euclidean contDiffOn_euclidean

theorem contDiff_euclidean {n : ℕ∞} : ContDiff 𝕜 n f ↔ ∀ i, ContDiff 𝕜 n fun x => f x i :=
  by
  rw [← (EuclideanSpace.equiv ι 𝕜).comp_contDiff_iff, contDiff_pi]
  rfl
#align cont_diff_euclidean contDiff_euclidean

end PiLike

section DiffeomorphUnitBall

open Metric hiding mem_nhds_iffₓ

variable {n : ℕ∞} {E : Type _} [NormedAddCommGroup E] [InnerProductSpace ℝ E]

theorem contDiff_homeomorphUnitBall : ContDiff ℝ n fun x : E => (homeomorphUnitBall x : E) :=
  by
  suffices ContDiff ℝ n fun x => (1 + ‖x‖ ^ 2).sqrt⁻¹ by exact this.smul contDiff_id
  have h : ∀ x : E, 0 < 1 + ‖x‖ ^ 2 := fun x => by positivity
  refine' ContDiff.inv _ fun x => real.sqrt_ne_zero'.mpr (h x)
  exact (cont_diff_const.add <| contDiff_norm_sq ℝ).sqrt fun x => (h x).Ne.symm
#align cont_diff_homeomorph_unit_ball contDiff_homeomorphUnitBall

theorem contDiffOn_homeomorphUnitBall_symm {f : E → E}
    (h : ∀ (y) (hy : y ∈ ball (0 : E) 1), f y = homeomorphUnitBall.symm ⟨y, hy⟩) :
    ContDiffOn ℝ n f <| ball 0 1 := by
  intro y hy
  apply ContDiffAt.contDiffWithinAt
  have hf : f =ᶠ[𝓝 y] fun y => (1 - ‖(y : E)‖ ^ 2).sqrt⁻¹ • (y : E) :=
    by
    rw [eventually_eq_iff_exists_mem]
    refine'
      ⟨ball (0 : E) 1, mem_nhds_iff.mpr ⟨ball (0 : E) 1, Set.Subset.refl _, is_open_ball, hy⟩,
        fun z hz => _⟩
    rw [h z hz]
    rfl
  refine' ContDiffAt.congr_of_eventuallyEq _ hf
  suffices ContDiffAt ℝ n (fun y => (1 - ‖(y : E)‖ ^ 2).sqrt⁻¹) y by exact this.smul contDiffAt_id
  have h : 0 < 1 - ‖(y : E)‖ ^ 2 := by
    rwa [mem_ball_zero_iff, ← _root_.abs_one, ← abs_norm_eq_norm, ← sq_lt_sq, one_pow, ← sub_pos] at
      hy
  refine' ContDiffAt.inv _ (real.sqrt_ne_zero'.mpr h)
  refine' ContDiffAt.comp _ (cont_diff_at_sqrt h.ne.symm) _
  exact cont_diff_at_const.sub (contDiff_norm_sq ℝ).ContDiffAt
#align cont_diff_on_homeomorph_unit_ball_symm contDiffOn_homeomorphUnitBall_symm

end DiffeomorphUnitBall


/-
Copyright (c) 2020 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov
-/
import order.conditionally_complete_lattice
import logic.function.conjugate
import order.ord_continuous
import data.equiv.mul_add

/-!
# Semiconjugate by `Sup`

In this file we prove two facts about semiconjugate (families of) functions.

First, if an order isomorphism `fa : α → α` is semiconjugate to an order embedding `fb : β → β` by
`g : α → β`, then `fb` is semiconjugate to `fa` by `y ↦ Sup {x | g x ≤ y}`, see
`semiconj.symm_adjoint`.

Second, consider two actions `f₁ f₂ : G → α → α` of a group on a complete lattice by order
isomorphisms. Then the map `x ↦ ⨆ g : G, (f₁ g)⁻¹ (f₂ g x)` semiconjugates each `f₁ g'` to `f₂ g'`,
see `function.Sup_div_semiconj`.  In the case of a conditionally complete lattice, a similar
statement holds true under an additional assumption that each set `{(f₁ g)⁻¹ (f₂ g x) | g : G}` is
bounded above, see `function.cSup_div_semiconj`.

The lemmas come from [Étienne Ghys, Groupes d'homeomorphismes du cercle et cohomologie
bornee][ghys87:groupes], Proposition 2.1 and 5.4 respectively. In the paper they are formulated for
homeomorphisms of the circle, so in order to apply results from this file one has to lift these
homeomorphisms to the real line first.
-/

variables {α : Type*} {β : Type*}

open set

/-- We say that `g : β → α` is an order right adjoint function for `f : α → β` if it sends each `y`
to a least upper bound for `{x | f x ≤ y}`. If `α` is a partial order, and `f : α → β` has
a right adjoint, then this right adjoint is unique. -/
def is_order_right_adjoint [preorder α] [preorder β] (f : α → β) (g : β → α) :=
∀ y, is_lub {x | f x ≤ y} (g y)

lemma is_order_right_adjoint_Sup [complete_lattice α] [preorder β] (f : α → β) :
  is_order_right_adjoint f (λ y, Sup {x | f x ≤ y}) :=
λ y, is_lub_Sup _

lemma is_order_right_adjoint_cSup [conditionally_complete_lattice α] [preorder β] (f : α → β)
  (hne : ∀ y, ∃ x, f x ≤ y) (hbdd : ∀ y, ∃ b, ∀ x, f x ≤ y → x ≤ b) :
  is_order_right_adjoint f (λ y, Sup {x | f x ≤ y}) :=
λ y, is_lub_cSup (hne y) (hbdd y)

lemma is_order_right_adjoint.unique [partial_order α] [preorder β] {f : α → β} {g₁ g₂ : β → α}
  (h₁ : is_order_right_adjoint f g₁) (h₂ : is_order_right_adjoint f g₂) :
  g₁ = g₂ :=
funext $ λ y, (h₁ y).unique (h₂ y)

lemma is_order_right_adjoint.right_mono [preorder α] [preorder β] {f : α → β} {g : β → α}
  (h : is_order_right_adjoint f g) :
  monotone g :=
λ y₁ y₂ hy, (h y₁).mono (h y₂) $ λ x hx, le_trans hx hy

namespace function

/-- If an order automorphism `fa` is semiconjugate to an order embedding `fb` by a function `g`
and `g'` is an order right adjoint of `g` (i.e. `g' y = Sup {x | f x ≤ y}`), then `fb` is
semiconjugate to `fa` by `g'`.

This is a version of Proposition 2.1 from [Étienne Ghys, Groupes d'homeomorphismes du cercle et
cohomologie bornee][ghys87:groupes]. -/
lemma semiconj.symm_adjoint [partial_order α] [preorder β]
  {fa : α ≃o α}
  {fb : β ↪o β} {g : α → β}
  (h : function.semiconj g fa fb) {g' : β → α} (hg' : is_order_right_adjoint g g') :
  function.semiconj g' fb fa :=
begin
  refine λ y, (hg' _).unique _,
  rw [← fa.surjective.image_preimage {x | g x ≤ fb y}, preimage_set_of_eq],
  simp only [h.eq, fb.le_iff_le, fa.left_ord_continuous (hg' _)]
end

variable {G : Type*}

lemma semiconj_of_is_lub [partial_order α] [group G]
  (f₁ f₂ : G →* (α ≃o α)) {h : α → α}
  (H : ∀ x, is_lub (range (λ g', (f₁ g')⁻¹ (f₂ g' x))) (h x)) (g : G) :
  function.semiconj h (f₂ g) (f₁ g) :=
begin
  refine λ y, (H _).unique _,
  have := (f₁ g).left_ord_continuous (H y),
  rw [← range_comp, ← (equiv.mul_right g).surjective.range_comp _] at this,
  simpa [(∘)] using this
end

/-- Consider two actions `f₁ f₂ : G → α → α` of a group on a complete lattice by order
isomorphisms. Then the map `x ↦ ⨆ g : G, (f₁ g)⁻¹ (f₂ g x)` semiconjugates each `f₁ g'` to `f₂ g'`.

This is a version of Proposition 5.4 from [Étienne Ghys, Groupes d'homeomorphismes du cercle et
cohomologie bornee][ghys87:groupes]. -/
lemma Sup_div_semiconj [complete_lattice α] [group G]
  (f₁ f₂ : G →* (α ≃o α)) (g : G) :
  function.semiconj (λ x, ⨆ g' : G, (f₁ g')⁻¹ (f₂ g' x)) (f₂ g) (f₁ g) :=
semiconj_of_is_lub f₁ f₂ (λ x, is_lub_supr) _

/-- Consider two actions `f₁ f₂ : G → α → α` of a group on a conditionally complete lattice by order
isomorphisms. Suppose that each set $s(x)=\{f_1(g)^{-1} (f_2(g)(x)) | g \in G\}$ is bounded above.
Then the map `x ↦ Sup s(x)` semiconjugates each `f₁ g'` to `f₂ g'`.

This is a version of Proposition 5.4 from [Étienne Ghys, Groupes d'homeomorphismes du cercle et
cohomologie bornee][ghys87:groupes]. -/
lemma cSup_div_semiconj [conditionally_complete_lattice α] [group G]
  (f₁ f₂ : G →* (α ≃o α))
  (hbdd : ∀ x, bdd_above (range $ λ g, (f₁ g)⁻¹ (f₂ g x))) (g : G) :
  function.semiconj (λ x, ⨆ g' : G, (f₁ g')⁻¹ (f₂ g' x)) (f₂ g) (f₁ g) :=
semiconj_of_is_lub f₁ f₂ (λ x, is_lub_cSup (range_nonempty _) (hbdd x)) _

end function


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Yaël Dillies
-/
import data.set.lattice
import data.set_like.basic
import order.galois_connection
import order.hom.basic

/-!
# Closure operators between preorders

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

We define (bundled) closure operators on a preorder as monotone (increasing), extensive
(inflationary) and idempotent functions.
We define closed elements for the operator as elements which are fixed by it.

Lower adjoints to a function between preorders `u : β → α` allow to generalise closure operators to
situations where the closure operator we are dealing with naturally decomposes as `u ∘ l` where `l`
is a worthy function to have on its own. Typical examples include
`l : set G → subgroup G := subgroup.closure`, `u : subgroup G → set G := coe`, where `G` is a group.
This shows there is a close connection between closure operators, lower adjoints and Galois
connections/insertions: every Galois connection induces a lower adjoint which itself induces a
closure operator by composition (see `galois_connection.lower_adjoint` and
`lower_adjoint.closure_operator`), and every closure operator on a partial order induces a Galois
insertion from the set of closed elements to the underlying type (see `closure_operator.gi`).

## Main definitions

* `closure_operator`: A closure operator is a monotone function `f : α → α` such that
  `∀ x, x ≤ f x` and `∀ x, f (f x) = f x`.
* `lower_adjoint`: A lower adjoint to `u : β → α` is a function `l : α → β` such that `l` and `u`
  form a Galois connection.

## Implementation details

Although `lower_adjoint` is technically a generalisation of `closure_operator` (by defining
`to_fun := id`), it is desirable to have both as otherwise `id`s would be carried all over the
place when using concrete closure operators such as `convex_hull`.

`lower_adjoint` really is a semibundled `structure` version of `galois_connection`.

## References

* https://en.wikipedia.org/wiki/Closure_operator#Closure_operators_on_partially_ordered_sets
-/

universe u

/-! ### Closure operator -/

variables (α : Type*) {ι : Sort*} {κ : ι → Sort*}

/-- A closure operator on the preorder `α` is a monotone function which is extensive (every `x`
is less than its closure) and idempotent. -/
structure closure_operator [preorder α] extends α →o α :=
(le_closure' : ∀ x, x ≤ to_fun x)
(idempotent' : ∀ x, to_fun (to_fun x) = to_fun x)

namespace closure_operator

instance [preorder α] : has_coe_to_fun (closure_operator α) (λ _, α → α) := ⟨λ c, c.to_fun⟩

/-- See Note [custom simps projection] -/
def simps.apply [preorder α] (f : closure_operator α) : α → α := f

initialize_simps_projections closure_operator (to_order_hom_to_fun → apply, -to_order_hom)

section partial_order
variable [partial_order α]

/-- The identity function as a closure operator. -/
@[simps]
def id : closure_operator α :=
{ to_order_hom := order_hom.id,
  le_closure' := λ _, le_rfl,
  idempotent' := λ _, rfl }

instance : inhabited (closure_operator α) := ⟨id α⟩

variables {α} (c : closure_operator α)

@[ext] lemma ext :
  ∀ (c₁ c₂ : closure_operator α), (c₁ : α → α) = (c₂ : α → α) → c₁ = c₂
| ⟨⟨c₁, _⟩, _, _⟩ ⟨⟨c₂, _⟩, _, _⟩ h := by { congr, exact h }

/-- Constructor for a closure operator using the weaker idempotency axiom: `f (f x) ≤ f x`. -/
@[simps]
def mk' (f : α → α) (hf₁ : monotone f) (hf₂ : ∀ x, x ≤ f x) (hf₃ : ∀ x, f (f x) ≤ f x) :
  closure_operator α :=
{ to_fun := f,
  monotone' := hf₁,
  le_closure' := hf₂,
  idempotent' := λ x, (hf₃ x).antisymm (hf₁ (hf₂ x)) }

/-- Convenience constructor for a closure operator using the weaker minimality axiom:
`x ≤ f y → f x ≤ f y`, which is sometimes easier to prove in practice. -/
@[simps]
def mk₂ (f : α → α) (hf : ∀ x, x ≤ f x) (hmin : ∀ ⦃x y⦄, x ≤ f y → f x ≤ f y) :
  closure_operator α :=
{ to_fun := f,
  monotone' := λ x y hxy, hmin (hxy.trans (hf y)),
  le_closure' := hf,
  idempotent' := λ x, (hmin le_rfl).antisymm (hf _) }

/-- Expanded out version of `mk₂`. `p` implies being closed. This constructor should be used when
you already know a sufficient condition for being closed and using `mem_mk₃_closed` will avoid you
the (slight) hassle of having to prove it both inside and outside the constructor. -/
@[simps]
def mk₃ (f : α → α) (p : α → Prop) (hf : ∀ x, x ≤ f x) (hfp : ∀ x, p (f x))
  (hmin : ∀ ⦃x y⦄, x ≤ y → p y → f x ≤ y) :
  closure_operator α :=
mk₂ f hf (λ x y hxy, hmin hxy (hfp y))

/-- This lemma shows that the image of `x` of a closure operator built from the `mk₃` constructor
respects `p`, the property that was fed into it. -/
lemma closure_mem_mk₃ {f : α → α} {p : α → Prop} {hf : ∀ x, x ≤ f x} {hfp : ∀ x, p (f x)}
  {hmin : ∀ ⦃x y⦄, x ≤ y → p y → f x ≤ y} (x : α) :
  p (mk₃ f p hf hfp hmin x) :=
hfp x

/-- Analogue of `closure_le_closed_iff_le` but with the `p` that was fed into the `mk₃` constructor.
-/
lemma closure_le_mk₃_iff {f : α → α} {p : α → Prop} {hf : ∀ x, x ≤ f x} {hfp : ∀ x, p (f x)}
  {hmin : ∀ ⦃x y⦄, x ≤ y → p y → f x ≤ y} {x y : α} (hxy : x ≤ y) (hy : p y) :
  mk₃ f p hf hfp hmin x ≤ y :=
hmin hxy hy

@[mono]

/-- Every element is less than its closure. This property is sometimes referred to as extensivity or
inflationarity. -/
lemma le_closure (x : α) : x ≤ c x := c.le_closure' x

@[simp] lemma idempotent (x : α) : c (c x) = c x := c.idempotent' x

lemma le_closure_iff (x y : α) : x ≤ c y ↔ c x ≤ c y :=
⟨λ h, c.idempotent y ▸ c.monotone h, λ h, (c.le_closure x).trans h⟩

/-- An element `x` is closed for the closure operator `c` if it is a fixed point for it. -/
def closed : set α := λ x, c x = x

lemma mem_closed_iff (x : α) : x ∈ c.closed ↔ c x = x := iff.rfl

lemma mem_closed_iff_closure_le (x : α) : x ∈ c.closed ↔ c x ≤ x :=
⟨le_of_eq, λ h, h.antisymm (c.le_closure x)⟩

lemma closure_eq_self_of_mem_closed {x : α} (h : x ∈ c.closed) : c x = x := h

@[simp] lemma closure_is_closed (x : α) : c x ∈ c.closed := c.idempotent x

/-- The set of closed elements for `c` is exactly its range. -/
lemma closed_eq_range_close : c.closed = set.range c :=
set.ext $ λ x, ⟨λ h, ⟨x, h⟩, by { rintro ⟨y, rfl⟩, apply c.idempotent }⟩

/-- Send an `x` to an element of the set of closed elements (by taking the closure). -/
def to_closed (x : α) : c.closed := ⟨c x, c.closure_is_closed x⟩

@[simp] lemma closure_le_closed_iff_le (x : α) {y : α} (hy : c.closed y) : c x ≤ y ↔ x ≤ y :=
by rw [←c.closure_eq_self_of_mem_closed hy, ←le_closure_iff]

/-- A closure operator is equal to the closure operator obtained by feeding `c.closed` into the
`mk₃` constructor. -/
lemma eq_mk₃_closed (c : closure_operator α) :
  c = mk₃ c c.closed c.le_closure c.closure_is_closed
  (λ x y hxy hy, (c.closure_le_closed_iff_le x hy).2 hxy) :=
by { ext, refl }

/-- The property `p` fed into the `mk₃` constructor implies being closed. -/
lemma mem_mk₃_closed {f : α → α} {p : α → Prop} {hf : ∀ x, x ≤ f x} {hfp : ∀ x, p (f x)}
  {hmin : ∀ ⦃x y⦄, x ≤ y → p y → f x ≤ y} {x : α} (hx : p x) :
  x ∈ (mk₃ f p hf hfp hmin).closed :=
(hmin le_rfl hx).antisymm (hf _)

end partial_order

variable {α}

section order_top
variables [partial_order α] [order_top α] (c : closure_operator α)

@[simp] lemma closure_top : c ⊤ = ⊤ :=
le_top.antisymm (c.le_closure _)

lemma top_mem_closed : ⊤ ∈ c.closed :=
c.closure_top

end order_top

lemma closure_inf_le [semilattice_inf α] (c : closure_operator α) (x y : α) :
  c (x ⊓ y) ≤ c x ⊓ c y :=
c.monotone.map_inf_le _ _

section semilattice_sup
variables [semilattice_sup α] (c : closure_operator α)

lemma closure_sup_closure_le (x y : α) :
  c x ⊔ c y ≤ c (x ⊔ y) :=
c.monotone.le_map_sup _ _

lemma closure_sup_closure_left (x y : α) :
  c (c x ⊔ y) = c (x ⊔ y) :=
((c.le_closure_iff _ _).1 (sup_le (c.monotone le_sup_left) (le_sup_right.trans
  (c.le_closure _)))).antisymm (c.monotone (sup_le_sup_right (c.le_closure _) _))

lemma closure_sup_closure_right (x y : α) :
  c (x ⊔ c y) = c (x ⊔ y) :=
by rw [sup_comm, closure_sup_closure_left, sup_comm]

lemma closure_sup_closure (x y : α) :
  c (c x ⊔ c y) = c (x ⊔ y) :=
by rw [closure_sup_closure_left, closure_sup_closure_right]

end semilattice_sup

section complete_lattice
variables [complete_lattice α] (c : closure_operator α)

@[simp] lemma closure_supr_closure (f : ι → α) : c (⨆ i, c (f i)) = c (⨆ i, f i) :=
le_antisymm ((c.le_closure_iff _ _).1 $ supr_le $ λ i, c.monotone $ le_supr f i) $
  c.monotone $ supr_mono $ λ i, c.le_closure _

@[simp] lemma closure_supr₂_closure (f : Π i, κ i → α) : c (⨆ i j, c (f i j)) = c (⨆ i j, f i j) :=
le_antisymm ((c.le_closure_iff _ _).1 $ supr₂_le $ λ i j, c.monotone $ le_supr₂ i j) $
  c.monotone $ supr₂_mono $ λ i j, c.le_closure _

end complete_lattice
end closure_operator

/-! ### Lower adjoint -/

variables {α} {β : Type*}

/-- A lower adjoint of `u` on the preorder `α` is a function `l` such that `l` and `u` form a Galois
connection. It allows us to define closure operators whose output does not match the input. In
practice, `u` is often `coe : β → α`. -/
structure lower_adjoint [preorder α] [preorder β] (u : β → α) :=
(to_fun : α → β)
(gc' : galois_connection to_fun u)

namespace lower_adjoint

variable (α)

/-- The identity function as a lower adjoint to itself. -/
@[simps]
protected def id [preorder α] : lower_adjoint (id : α → α) :=
{ to_fun := λ x, x,
  gc' := galois_connection.id }

variable {α}

instance [preorder α] : inhabited (lower_adjoint (id : α → α)) := ⟨lower_adjoint.id α⟩

section preorder
variables [preorder α] [preorder β] {u : β → α} (l : lower_adjoint u)

instance : has_coe_to_fun (lower_adjoint u) (λ _, α → β) := { coe := to_fun }

/-- See Note [custom simps projection] -/
def simps.apply : α → β := l

lemma gc : galois_connection l u := l.gc'

@[ext] lemma ext :
  ∀ (l₁ l₂ : lower_adjoint u), (l₁ : α → β) = (l₂ : α → β) → l₁ = l₂
| ⟨l₁, _⟩ ⟨l₂, _⟩ h := by { congr, exact h }

@[mono] lemma monotone : monotone (u ∘ l) := l.gc.monotone_u.comp l.gc.monotone_l

/-- Every element is less than its closure. This property is sometimes referred to as extensivity or
inflationarity. -/
lemma le_closure (x : α) : x ≤ u (l x) := l.gc.le_u_l _

end preorder

section partial_order
variables [partial_order α] [preorder β] {u : β → α} (l : lower_adjoint u)

/-- Every lower adjoint induces a closure operator given by the composition. This is the partial
order version of the statement that every adjunction induces a monad. -/
@[simps]
def closure_operator :
  closure_operator α :=
{ to_fun := λ x, u (l x),
  monotone' := l.monotone,
  le_closure' := l.le_closure,
  idempotent' := λ x, l.gc.u_l_u_eq_u (l x) }

lemma idempotent (x : α) : u (l (u (l x))) = u (l x) :=
l.closure_operator.idempotent _

lemma le_closure_iff (x y : α) : x ≤ u (l y) ↔ u (l x) ≤ u (l y) :=
l.closure_operator.le_closure_iff _ _

end partial_order

section preorder
variables [preorder α] [preorder β] {u : β → α} (l : lower_adjoint u)

/-- An element `x` is closed for `l : lower_adjoint u` if it is a fixed point: `u (l x) = x` -/
def closed : set α := λ x, u (l x) = x

lemma mem_closed_iff (x : α) : x ∈ l.closed ↔ u (l x) = x := iff.rfl

lemma closure_eq_self_of_mem_closed {x : α} (h : x ∈ l.closed) : u (l x) = x := h

end preorder

section partial_order
variables [partial_order α] [partial_order β] {u : β → α} (l : lower_adjoint u)

lemma mem_closed_iff_closure_le (x : α) : x ∈ l.closed ↔ u (l x) ≤ x :=
l.closure_operator.mem_closed_iff_closure_le _

@[simp] lemma closure_is_closed (x : α) : u (l x) ∈ l.closed := l.idempotent x

/-- The set of closed elements for `l` is the range of `u ∘ l`. -/
lemma closed_eq_range_close : l.closed = set.range (u ∘ l) :=
l.closure_operator.closed_eq_range_close

/-- Send an `x` to an element of the set of closed elements (by taking the closure). -/
def to_closed (x : α) : l.closed := ⟨u (l x), l.closure_is_closed x⟩

@[simp] lemma closure_le_closed_iff_le (x : α) {y : α} (hy : l.closed y) : u (l x) ≤ y ↔ x ≤ y :=
l.closure_operator.closure_le_closed_iff_le x hy

end partial_order

lemma closure_top [partial_order α] [order_top α] [preorder β] {u : β → α} (l : lower_adjoint u) :
  u (l ⊤) = ⊤ :=
l.closure_operator.closure_top

lemma closure_inf_le [semilattice_inf α] [preorder β] {u : β → α} (l : lower_adjoint u) (x y : α) :
  u (l (x ⊓ y)) ≤ u (l x) ⊓ u (l y) :=
l.closure_operator.closure_inf_le x y

section semilattice_sup
variables [semilattice_sup α] [preorder β] {u : β → α} (l : lower_adjoint u)

lemma closure_sup_closure_le (x y : α) :
  u (l x) ⊔ u (l y) ≤ u (l (x ⊔ y)) :=
l.closure_operator.closure_sup_closure_le x y

lemma closure_sup_closure_left (x y : α) :
  u (l (u (l x) ⊔ y)) = u (l (x ⊔ y)) :=
l.closure_operator.closure_sup_closure_left x y

lemma closure_sup_closure_right (x y : α) :
  u (l (x ⊔ u (l y))) = u (l (x ⊔ y)) :=
l.closure_operator.closure_sup_closure_right x y

lemma closure_sup_closure (x y : α) :
  u (l (u (l x) ⊔ u (l y))) = u (l (x ⊔ y)) :=
l.closure_operator.closure_sup_closure x y

end semilattice_sup

section complete_lattice
variables [complete_lattice α] [preorder β] {u : β → α} (l : lower_adjoint u)

lemma closure_supr_closure (f : ι → α) : u (l (⨆ i, u (l (f i)))) = u (l (⨆ i, f i)) :=
l.closure_operator.closure_supr_closure _

lemma closure_supr₂_closure (f : Π i, κ i → α) :
  u (l $ ⨆ i j, u (l $ f i j)) = u (l $ ⨆ i j, f i j) :=
l.closure_operator.closure_supr₂_closure _

end complete_lattice

/- Lemmas for `lower_adjoint (coe : α → set β)`, where `set_like α β` -/
section coe_to_set
variables [set_like α β] (l : lower_adjoint (coe : α → set β))

lemma subset_closure (s : set β) : s ⊆ l s :=
l.le_closure s

lemma not_mem_of_not_mem_closure {s : set β} {P : β} (hP : P ∉ l s) : P ∉ s :=
λ h, hP (subset_closure _ s h)

lemma le_iff_subset (s : set β) (S : α) : l s ≤ S ↔ s ⊆ S :=
l.gc s S

lemma mem_iff (s : set β) (x : β) : x ∈ l s ↔ ∀ S : α, s ⊆ S → x ∈ S :=
by { simp_rw [←set_like.mem_coe, ←set.singleton_subset_iff, ←l.le_iff_subset],
  exact ⟨λ h S, h.trans, λ h, h _ le_rfl⟩ }

lemma eq_of_le {s : set β} {S : α} (h₁ : s ⊆ S) (h₂ : S ≤ l s) : l s = S :=
((l.le_iff_subset _ _).2 h₁).antisymm h₂

lemma closure_union_closure_subset (x y : α) :
  (l x : set β) ∪ (l y) ⊆ l (x ∪ y) :=
l.closure_sup_closure_le x y

@[simp] lemma closure_union_closure_left (x y : α) :
  l ((l x) ∪ y) = l (x ∪ y) :=
set_like.coe_injective (l.closure_sup_closure_left x y)

@[simp] lemma closure_union_closure_right (x y : α) :
  l (x ∪ (l y)) = l (x ∪ y) :=
set_like.coe_injective (l.closure_sup_closure_right x y)

lemma closure_union_closure (x y : α) :
  l ((l x) ∪ (l y)) = l (x ∪ y) :=
set_like.coe_injective (l.closure_operator.closure_sup_closure x y)

@[simp] lemma closure_Union_closure (f : ι → α) : l (⋃ i, l (f i)) = l (⋃ i, f i) :=
set_like.coe_injective $ l.closure_supr_closure _

@[simp] lemma closure_Union₂_closure (f : Π i, κ i → α) : l (⋃ i j, l (f i j)) = l (⋃ i j, f i j) :=
set_like.coe_injective $ l.closure_supr₂_closure _

end coe_to_set

end lower_adjoint

/-! ### Translations between `galois_connection`, `lower_adjoint`, `closure_operator` -/

variable {α}

/-- Every Galois connection induces a lower adjoint. -/
@[simps]
def galois_connection.lower_adjoint [preorder α] [preorder β] {l : α → β} {u : β → α}
  (gc : galois_connection l u) :
  lower_adjoint u :=
{ to_fun := l,
  gc' := gc }

/-- Every Galois connection induces a closure operator given by the composition. This is the partial
order version of the statement that every adjunction induces a monad. -/
@[simps]
def galois_connection.closure_operator [partial_order α] [preorder β] {l : α → β} {u : β → α}
  (gc : galois_connection l u) :
  closure_operator α :=
gc.lower_adjoint.closure_operator

/-- The set of closed elements has a Galois insertion to the underlying type. -/
def closure_operator.gi [partial_order α] (c : closure_operator α) :
  galois_insertion c.to_closed coe :=
{ choice := λ x hx, ⟨x, hx.antisymm (c.le_closure x)⟩,
  gc := λ x y, (c.closure_le_closed_iff_le _ y.2),
  le_l_u := λ x, c.le_closure _,
  choice_eq := λ x hx, le_antisymm (c.le_closure x) hx }

/-- The Galois insertion associated to a closure operator can be used to reconstruct the closure
operator.
Note that the inverse in the opposite direction does not hold in general. -/
@[simp]
lemma closure_operator_gi_self [partial_order α] (c : closure_operator α) :
  c.gi.gc.closure_operator = c :=
by { ext x, refl }


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Joey van Langen, Casper Putz
-/

import data.int.modeq
import algebra.iterate_hom
import data.nat.choose.sum
import group_theory.order_of_element
import data.nat.choose.dvd
/-!
# Characteristic of semirings
-/

universes u v

variables (R : Type u)

/-- The generator of the kernel of the unique homomorphism ℕ → R for a semiring R -/
class char_p [add_monoid R] [has_one R] (p : ℕ) : Prop :=
(cast_eq_zero_iff [] : ∀ x:ℕ, (x:R) = 0 ↔ p ∣ x)

theorem char_p.cast_eq_zero [add_monoid R] [has_one R] (p : ℕ) [char_p R p] :
  (p:R) = 0 :=
(char_p.cast_eq_zero_iff R p p).2 (dvd_refl p)

@[simp] lemma char_p.cast_card_eq_zero [add_group R] [has_one R] [fintype R] :
  (fintype.card R : R) = 0 :=
by rw [← nsmul_one, card_nsmul_eq_zero]

lemma char_p.int_cast_eq_zero_iff [add_group R] [has_one R] (p : ℕ) [char_p R p]
  (a : ℤ) :
  (a : R) = 0 ↔ (p:ℤ) ∣ a :=
begin
  rcases lt_trichotomy a 0 with h|rfl|h,
  { rw [← neg_eq_zero, ← int.cast_neg, ← dvd_neg],
    lift -a to ℕ using neg_nonneg.mpr (le_of_lt h) with b,
    rw [int.cast_coe_nat, char_p.cast_eq_zero_iff R p, int.coe_nat_dvd] },
  { simp only [int.cast_zero, eq_self_iff_true, dvd_zero] },
  { lift a to ℕ using (le_of_lt h) with b,
    rw [int.cast_coe_nat, char_p.cast_eq_zero_iff R p, int.coe_nat_dvd] }
end

lemma char_p.int_coe_eq_int_coe_iff [add_group R] [has_one R] (p : ℕ) [char_p R p] (a b : ℤ) :
  (a : R) = (b : R) ↔ a ≡ b [ZMOD p] :=
by rw [eq_comm, ←sub_eq_zero, ←int.cast_sub,
       char_p.int_cast_eq_zero_iff R p, int.modeq_iff_dvd]

theorem char_p.eq [add_monoid R] [has_one R] {p q : ℕ} (c1 : char_p R p) (c2 : char_p R q) :
  p = q :=
nat.dvd_antisymm
  ((char_p.cast_eq_zero_iff R p q).1 (char_p.cast_eq_zero _ _))
  ((char_p.cast_eq_zero_iff R q p).1 (char_p.cast_eq_zero _ _))

instance char_p.of_char_zero [add_monoid R] [has_one R] [char_zero R] : char_p R 0 :=
⟨λ x, by rw [zero_dvd_iff, ← nat.cast_zero, nat.cast_inj]⟩

theorem char_p.exists [non_assoc_semiring R] : ∃ p, char_p R p :=
by letI := classical.dec_eq R; exact
classical.by_cases
  (assume H : ∀ p:ℕ, (p:R) = 0 → p = 0, ⟨0,
    ⟨λ x, by rw [zero_dvd_iff]; exact ⟨H x, by rintro rfl; refl⟩⟩⟩)
  (λ H, ⟨nat.find (not_forall.1 H), ⟨λ x,
    ⟨λ H1, nat.dvd_of_mod_eq_zero (by_contradiction $ λ H2,
      nat.find_min (not_forall.1 H)
        (nat.mod_lt x $ nat.pos_of_ne_zero $ not_of_not_imp $
          nat.find_spec (not_forall.1 H))
        (not_imp_of_and_not ⟨by rwa [← nat.mod_add_div x (nat.find (not_forall.1 H)),
          nat.cast_add, nat.cast_mul, of_not_not (not_not_of_not_imp $ nat.find_spec
            (not_forall.1 H)),
          zero_mul, add_zero] at H1, H2⟩)),
    λ H1, by rw [← nat.mul_div_cancel' H1, nat.cast_mul,
      of_not_not (not_not_of_not_imp $ nat.find_spec (not_forall.1 H)), zero_mul]⟩⟩⟩)

theorem char_p.exists_unique [non_assoc_semiring R] : ∃! p, char_p R p :=
let ⟨c, H⟩ := char_p.exists R in ⟨c, H, λ y H2, char_p.eq R H2 H⟩

theorem char_p.congr {R : Type u} [add_monoid R] [has_one R] {p : ℕ} (q : ℕ) [hq : char_p R q]
  (h : q = p) :
  char_p R p :=
h ▸ hq

/-- Noncomputable function that outputs the unique characteristic of a semiring. -/
noncomputable def ring_char [non_assoc_semiring R] : ℕ :=
classical.some (char_p.exists_unique R)

namespace ring_char
variables [non_assoc_semiring R]

theorem spec : ∀ x:ℕ, (x:R) = 0 ↔ ring_char R ∣ x :=
by letI := (classical.some_spec (char_p.exists_unique R)).1;
unfold ring_char; exact char_p.cast_eq_zero_iff R (ring_char R)

theorem eq {p : ℕ} (C : char_p R p) : p = ring_char R :=
(classical.some_spec (char_p.exists_unique R)).2 p C

instance char_p : char_p R (ring_char R) :=
⟨spec R⟩

variables {R}

theorem of_eq {p : ℕ} (h : ring_char R = p) : char_p R p :=
char_p.congr (ring_char R) h

theorem eq_iff {p : ℕ} : ring_char R = p ↔ char_p R p :=
⟨of_eq, eq.symm ∘ eq R⟩

theorem dvd {x : ℕ} (hx : (x : R) = 0) : ring_char R ∣ x :=
(spec R x).1 hx

@[simp]
lemma eq_zero [char_zero R] : ring_char R = 0 := (eq R (char_p.of_char_zero R)).symm

end ring_char

theorem add_pow_char_of_commute [semiring R] {p : ℕ} [fact p.prime]
  [char_p R p] (x y : R) (h : commute x y) :
  (x + y)^p = x^p + y^p :=
begin
  rw [commute.add_pow h, finset.sum_range_succ_comm, tsub_self, pow_zero, nat.choose_self],
  rw [nat.cast_one, mul_one, mul_one], congr' 1,
  convert finset.sum_eq_single 0 _ _,
  { simp only [mul_one, one_mul, nat.choose_zero_right, tsub_zero, nat.cast_one, pow_zero] },
  { intros b h1 h2,
    suffices : (p.choose b : R) = 0, { rw this, simp },
    rw char_p.cast_eq_zero_iff R p,
    refine nat.prime.dvd_choose_self (pos_iff_ne_zero.mpr h2) _ (fact.out _),
    rwa ← finset.mem_range },
  { intro h1,
    contrapose! h1,
    rw finset.mem_range,
    exact nat.prime.pos (fact.out _) }
end

theorem add_pow_char_pow_of_commute [semiring R] {p : ℕ} [fact p.prime]
  [char_p R p] {n : ℕ} (x y : R) (h : commute x y) :
  (x + y) ^ (p ^ n) = x ^ (p ^ n) + y ^ (p ^ n) :=
begin
  induction n, { simp, },
  rw [pow_succ', pow_mul, pow_mul, pow_mul, n_ih],
  apply add_pow_char_of_commute, apply commute.pow_pow h,
end

theorem sub_pow_char_of_commute [ring R] {p : ℕ} [fact p.prime]
  [char_p R p] (x y : R) (h : commute x y) :
  (x - y)^p = x^p - y^p :=
begin
  rw [eq_sub_iff_add_eq, ← add_pow_char_of_commute _ _ _ (commute.sub_left h rfl)],
  simp, repeat {apply_instance},
end

theorem sub_pow_char_pow_of_commute [ring R] {p : ℕ} [fact p.prime]
  [char_p R p] {n : ℕ} (x y : R) (h : commute x y) :
  (x - y) ^ (p ^ n) = x ^ (p ^ n) - y ^ (p ^ n) :=
begin
  induction n, { simp, },
  rw [pow_succ', pow_mul, pow_mul, pow_mul, n_ih],
  apply sub_pow_char_of_commute, apply commute.pow_pow h,
end

theorem add_pow_char [comm_semiring R] {p : ℕ} [fact p.prime]
  [char_p R p] (x y : R) : (x + y)^p = x^p + y^p :=
add_pow_char_of_commute _ _ _ (commute.all _ _)

theorem add_pow_char_pow [comm_semiring R] {p : ℕ} [fact p.prime]
  [char_p R p] {n : ℕ} (x y : R) :
  (x + y) ^ (p ^ n) = x ^ (p ^ n) + y ^ (p ^ n) :=
add_pow_char_pow_of_commute _ _ _ (commute.all _ _)

theorem sub_pow_char [comm_ring R] {p : ℕ} [fact p.prime]
  [char_p R p] (x y : R) : (x - y)^p = x^p - y^p :=
sub_pow_char_of_commute _ _ _ (commute.all _ _)

theorem sub_pow_char_pow [comm_ring R] {p : ℕ} [fact p.prime]
  [char_p R p] {n : ℕ} (x y : R) :
  (x - y) ^ (p ^ n) = x ^ (p ^ n) - y ^ (p ^ n) :=
sub_pow_char_pow_of_commute _ _ _ (commute.all _ _)

lemma eq_iff_modeq_int [ring R] (p : ℕ) [char_p R p] (a b : ℤ) :
  (a : R) = b ↔ a ≡ b [ZMOD p] :=
by rw [eq_comm, ←sub_eq_zero, ←int.cast_sub,
       char_p.int_cast_eq_zero_iff R p, int.modeq_iff_dvd]

lemma char_p.neg_one_ne_one [ring R] (p : ℕ) [char_p R p] [fact (2 < p)] :
  (-1 : R) ≠ (1 : R) :=
begin
  suffices : (2 : R) ≠ 0,
  { symmetry, rw [ne.def, ← sub_eq_zero, sub_neg_eq_add], exact this },
  assume h,
  rw [show (2 : R) = (2 : ℕ), by norm_cast] at h,
  have := (char_p.cast_eq_zero_iff R p 2).mp h,
  have := nat.le_of_dvd dec_trivial this,
  rw fact_iff at *, linarith,
end

lemma char_p.neg_one_pow_char [comm_ring R] (p : ℕ) [char_p R p] [fact p.prime] :
  (-1 : R) ^ p = -1 :=
begin
  rw eq_neg_iff_add_eq_zero,
  nth_rewrite 1 ← one_pow p,
  rw [← add_pow_char, add_left_neg, zero_pow (fact.out (nat.prime p)).pos],
end

lemma char_p.neg_one_pow_char_pow [comm_ring R] (p n : ℕ) [char_p R p] [fact p.prime] :
  (-1 : R) ^ p ^ n = -1 :=
begin
  rw eq_neg_iff_add_eq_zero,
  nth_rewrite 1 ← one_pow (p ^ n),
  rw [← add_pow_char_pow, add_left_neg, zero_pow (pow_pos (fact.out (nat.prime p)).pos _)],
end

lemma ring_hom.char_p_iff_char_p {K L : Type*} [division_ring K] [semiring L] [nontrivial L]
  (f : K →+* L) (p : ℕ) :
  char_p K p ↔ char_p L p :=
begin
  split;
  { introI _c, constructor, intro n,
    rw [← @char_p.cast_eq_zero_iff _ _ _ p _c n, ← f.injective.eq_iff, f.map_nat_cast, f.map_zero] }
end

section frobenius

section comm_semiring

variables [comm_semiring R] {S : Type v} [comm_semiring S] (f : R →* S) (g : R →+* S)
  (p : ℕ) [fact p.prime] [char_p R p] [char_p S p] (x y : R)

/-- The frobenius map that sends x to x^p -/
def frobenius : R →+* R :=
{ to_fun := λ x, x^p,
  map_one' := one_pow p,
  map_mul' := λ x y, mul_pow x y p,
  map_zero' := zero_pow (fact.out (nat.prime p)).pos,
  map_add' := add_pow_char R }

variable {R}

theorem frobenius_def : frobenius R p x = x ^ p := rfl

theorem iterate_frobenius (n : ℕ) : (frobenius R p)^[n] x = x ^ p ^ n :=
begin
  induction n, {simp},
  rw [function.iterate_succ', pow_succ', pow_mul, function.comp_apply, frobenius_def, n_ih]
end

theorem frobenius_mul : frobenius R p (x * y) = frobenius R p x * frobenius R p y :=
(frobenius R p).map_mul x y

theorem frobenius_one : frobenius R p 1 = 1 := one_pow _

theorem monoid_hom.map_frobenius : f (frobenius R p x) = frobenius S p (f x) :=
f.map_pow x p

theorem ring_hom.map_frobenius : g (frobenius R p x) = frobenius S p (g x) :=
g.map_pow x p

theorem monoid_hom.map_iterate_frobenius (n : ℕ) :
  f (frobenius R p^[n] x) = (frobenius S p^[n] (f x)) :=
function.semiconj.iterate_right (f.map_frobenius p) n x

theorem ring_hom.map_iterate_frobenius (n : ℕ) :
  g (frobenius R p^[n] x) = (frobenius S p^[n] (g x)) :=
g.to_monoid_hom.map_iterate_frobenius p x n

theorem monoid_hom.iterate_map_frobenius (f : R →* R) (p : ℕ) [fact p.prime] [char_p R p] (n : ℕ) :
  f^[n] (frobenius R p x) = frobenius R p (f^[n] x) :=
f.iterate_map_pow _ _ _

theorem ring_hom.iterate_map_frobenius (f : R →+* R) (p : ℕ) [fact p.prime] [char_p R p] (n : ℕ) :
  f^[n] (frobenius R p x) = frobenius R p (f^[n] x) :=
f.iterate_map_pow _ _ _

variable (R)

theorem frobenius_zero : frobenius R p 0 = 0 := (frobenius R p).map_zero

theorem frobenius_add : frobenius R p (x + y) = frobenius R p x + frobenius R p y :=
(frobenius R p).map_add x y

theorem frobenius_nat_cast (n : ℕ) : frobenius R p n = n := (frobenius R p).map_nat_cast n

open_locale big_operators
variables {R}

lemma list_sum_pow_char (l : list R) : l.sum ^ p = (l.map (^ p)).sum :=
(frobenius R p).map_list_sum _

lemma multiset_sum_pow_char (s : multiset R) : s.sum ^ p = (s.map (^ p)).sum :=
(frobenius R p).map_multiset_sum _

lemma sum_pow_char {ι : Type*} (s : finset ι) (f : ι → R) :
  (∑ i in s, f i) ^ p = ∑ i in s, f i ^ p :=
(frobenius R p).map_sum _ _

end comm_semiring

section comm_ring

variables [comm_ring R] {S : Type v} [comm_ring S] (f : R →* S) (g : R →+* S)
  (p : ℕ) [fact p.prime] [char_p R p]  [char_p S p] (x y : R)

theorem frobenius_neg : frobenius R p (-x) = -frobenius R p x := (frobenius R p).map_neg x

theorem frobenius_sub : frobenius R p (x - y) = frobenius R p x - frobenius R p y :=
(frobenius R p).map_sub x y

end comm_ring

end frobenius

theorem frobenius_inj [comm_ring R] [no_zero_divisors R]
  (p : ℕ) [fact p.prime] [char_p R p] :
  function.injective (frobenius R p) :=
λ x h H, by { rw ← sub_eq_zero at H ⊢, rw ← frobenius_sub at H, exact pow_eq_zero H }

namespace char_p

section
variables [ring R]

lemma char_p_to_char_zero [char_p R 0] : char_zero R :=
char_zero_of_inj_zero $
  λ n h0, eq_zero_of_zero_dvd ((cast_eq_zero_iff R 0 n).mp h0)

lemma cast_eq_mod (p : ℕ) [char_p R p] (k : ℕ) : (k : R) = (k % p : ℕ) :=
calc (k : R) = ↑(k % p + p * (k / p)) : by rw [nat.mod_add_div]
         ... = ↑(k % p)               : by simp[cast_eq_zero]

theorem char_ne_zero_of_fintype (p : ℕ) [hc : char_p R p] [fintype R] : p ≠ 0 :=
assume h : p = 0,
have char_zero R := @char_p_to_char_zero R _ (h ▸ hc),
absurd (@nat.cast_injective R _ _ this) (not_injective_infinite_fintype coe)

end

section semiring
open nat

variables [non_assoc_semiring R]

theorem char_ne_one [nontrivial R] (p : ℕ) [hc : char_p R p] : p ≠ 1 :=
assume hp : p = 1,
have ( 1 : R) = 0, by simpa using (cast_eq_zero_iff R p 1).mpr (hp ▸ dvd_refl p),
absurd this one_ne_zero

section no_zero_divisors

variable [no_zero_divisors R]

theorem char_is_prime_of_two_le (p : ℕ) [hc : char_p R p] (hp : 2 ≤ p) : nat.prime p :=
suffices ∀d ∣ p, d = 1 ∨ d = p, from ⟨hp, this⟩,
assume (d : ℕ) (hdvd : ∃ e, p = d * e),
let ⟨e, hmul⟩ := hdvd in
have (p : R) = 0, from (cast_eq_zero_iff R p p).mpr (dvd_refl p),
have (d : R) * e = 0, from (@cast_mul R _ d e) ▸ (hmul ▸ this),
or.elim (eq_zero_or_eq_zero_of_mul_eq_zero this)
  (assume hd : (d : R) = 0,
  have p ∣ d, from (cast_eq_zero_iff R p d).mp hd,
  show d = 1 ∨ d = p, from or.inr (dvd_antisymm ⟨e, hmul⟩ this))
  (assume he : (e : R) = 0,
  have p ∣ e, from (cast_eq_zero_iff R p e).mp he,
  have e ∣ p, from dvd_of_mul_left_eq d (eq.symm hmul),
  have e = p, from dvd_antisymm ‹e ∣ p› ‹p ∣ e›,
  have h₀ : p > 0, from gt_of_ge_of_gt hp (nat.zero_lt_succ 1),
  have d * p = 1 * p, by rw ‹e = p› at hmul; rw [one_mul]; exact eq.symm hmul,
  show d = 1 ∨ d = p, from or.inl (eq_of_mul_eq_mul_right h₀ this))

section nontrivial

variables [nontrivial R]

theorem char_is_prime_or_zero (p : ℕ) [hc : char_p R p] : nat.prime p ∨ p = 0 :=
match p, hc with
| 0,     _  := or.inr rfl
| 1,     hc := absurd (eq.refl (1 : ℕ)) (@char_ne_one R _ _ (1 : ℕ) hc)
| (m+2), hc := or.inl (@char_is_prime_of_two_le R _ _ (m+2) hc (nat.le_add_left 2 m))
end

lemma char_is_prime_of_pos (p : ℕ) [h : fact (0 < p)] [char_p R p] : fact p.prime :=
⟨(char_p.char_is_prime_or_zero R _).resolve_right (pos_iff_ne_zero.1 h.1)⟩

end nontrivial

end no_zero_divisors

end semiring

section ring

variables (R) [ring R] [no_zero_divisors R] [nontrivial R] [fintype R]

theorem char_is_prime (p : ℕ) [char_p R p] :
  p.prime :=
or.resolve_right (char_is_prime_or_zero R p) (char_ne_zero_of_fintype R p)

end ring

section char_one

variables {R} [non_assoc_semiring R]

@[priority 100]  -- see Note [lower instance priority]
instance [char_p R 1] : subsingleton R :=
subsingleton.intro $
suffices ∀ (r : R), r = 0,
  from assume a b, show a = b, by rw [this a, this b],
assume r,
calc r = 1 * r       : by rw one_mul
   ... = (1 : ℕ) * r : by rw nat.cast_one
   ... = 0 * r       : by rw char_p.cast_eq_zero
   ... = 0           : by rw zero_mul

lemma false_of_nontrivial_of_char_one [nontrivial R] [char_p R 1] : false :=
false_of_nontrivial_of_subsingleton R

lemma ring_char_ne_one [nontrivial R] : ring_char R ≠ 1 :=
by { intros h, apply @zero_ne_one R, symmetry, rw [←nat.cast_one, ring_char.spec, h], }

lemma nontrivial_of_char_ne_one {v : ℕ} (hv : v ≠ 1) [hr : char_p R v] :
  nontrivial R :=
⟨⟨(1 : ℕ), 0, λ h, hv $ by rwa [char_p.cast_eq_zero_iff _ v, nat.dvd_one] at h; assumption ⟩⟩

end char_one

end char_p

section

variables (R) [comm_ring R] [fintype R] (n : ℕ)

lemma char_p_of_ne_zero (hn : fintype.card R = n) (hR : ∀ i < n, (i : R) = 0 → i = 0) :
  char_p R n :=
{ cast_eq_zero_iff :=
  begin
    have H : (n : R) = 0, by { rw [← hn, char_p.cast_card_eq_zero] },
    intro k,
    split,
    { intro h,
      rw [← nat.mod_add_div k n, nat.cast_add, nat.cast_mul, H, zero_mul, add_zero] at h,
      rw nat.dvd_iff_mod_eq_zero,
      apply hR _ (nat.mod_lt _ _) h,
      rw [← hn, fintype.card_pos_iff],
      exact ⟨0⟩, },
    { rintro ⟨k, rfl⟩, rw [nat.cast_mul, H, zero_mul] }
  end }

lemma char_p_of_prime_pow_injective (p : ℕ) [hp : fact p.prime] (n : ℕ)
  (hn : fintype.card R = p ^ n) (hR : ∀ i ≤ n, (p ^ i : R) = 0 → i = n) :
  char_p R (p ^ n) :=
begin
  obtain ⟨c, hc⟩ := char_p.exists R, resetI,
  have hcpn : c ∣ p ^ n,
  { rw [← char_p.cast_eq_zero_iff R c, ← hn, char_p.cast_card_eq_zero], },
  obtain ⟨i, hi, hc⟩ : ∃ i ≤ n, c = p ^ i, by rwa nat.dvd_prime_pow hp.1 at hcpn,
  obtain rfl : i = n,
  { apply hR i hi, rw [← nat.cast_pow, ← hc, char_p.cast_eq_zero] },
  rwa ← hc
end

end

section prod

variables (S : Type v) [semiring R] [semiring S] (p q : ℕ) [char_p R p]

/-- The characteristic of the product of rings is the least common multiple of the
characteristics of the two rings. -/
instance [char_p S q] : char_p (R × S) (nat.lcm p q) :=
{ cast_eq_zero_iff :=
    by simp [prod.ext_iff, char_p.cast_eq_zero_iff R p,
      char_p.cast_eq_zero_iff S q, nat.lcm_dvd_iff] }

/-- The characteristic of the product of two rings of the same characteristic
  is the same as the characteristic of the rings -/
instance prod.char_p [char_p S p] : char_p (R × S) p :=
by convert nat.lcm.char_p R S p p; simp

end prod


/-
Copyright (c) 2021 Rémy Degenne. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Rémy Degenne
-/
import analysis.inner_product_space.basic
import measure_theory.integral.set_integral

/-! # `L^2` space

If `E` is an inner product space over `𝕜` (`ℝ` or `ℂ`), then `Lp E 2 μ` (defined in `lp_space.lean`)
is also an inner product space, with inner product defined as `inner f g = ∫ a, ⟪f a, g a⟫ ∂μ`.

### Main results

* `mem_L1_inner` : for `f` and `g` in `Lp E 2 μ`, the pointwise inner product `λ x, ⟪f x, g x⟫`
  belongs to `Lp 𝕜 1 μ`.
* `integrable_inner` : for `f` and `g` in `Lp E 2 μ`, the pointwise inner product `λ x, ⟪f x, g x⟫`
  is integrable.
* `L2.inner_product_space` : `Lp E 2 μ` is an inner product space.

-/

noncomputable theory
open topological_space measure_theory measure_theory.Lp
open_locale nnreal ennreal measure_theory

namespace measure_theory
namespace L2

variables {α E F 𝕜 : Type*} [is_R_or_C 𝕜] [measurable_space α] {μ : measure α}
  [measurable_space E] [inner_product_space 𝕜 E] [borel_space E] [second_countable_topology E]
  [normed_group F] [measurable_space F] [borel_space F] [second_countable_topology F]

local notation `⟪`x`, `y`⟫` := @inner 𝕜 _ _ x y

lemma snorm_rpow_two_norm_lt_top (f : Lp F 2 μ) : snorm (λ x, ∥f x∥ ^ (2 : ℝ)) 1 μ < ∞ :=
begin
  have h_two : ennreal.of_real (2 : ℝ) = 2, by simp [zero_le_one],
  rw [snorm_norm_rpow f zero_lt_two, one_mul, h_two],
  exact ennreal.rpow_lt_top_of_nonneg zero_le_two (Lp.snorm_ne_top f),
end

lemma snorm_inner_lt_top (f g : α →₂[μ] E) : snorm (λ (x : α), ⟪f x, g x⟫) 1 μ < ∞ :=
begin
  have h : ∀ x, is_R_or_C.abs ⟪f x, g x⟫ ≤ ∥f x∥ * ∥g x∥, from λ x, abs_inner_le_norm _ _,
  have h' : ∀ x, is_R_or_C.abs ⟪f x, g x⟫ ≤ is_R_or_C.abs (∥f x∥^2 + ∥g x∥^2),
  { refine λ x, le_trans (h x) _,
    rw [is_R_or_C.abs_to_real, abs_eq_self.mpr],
    swap, { exact add_nonneg (by simp) (by simp), },
    refine le_trans _ (half_le_self (add_nonneg (sq_nonneg _) (sq_nonneg _))),
    refine (le_div_iff (@zero_lt_two ℝ _ _)).mpr ((le_of_eq _).trans (two_mul_le_add_sq _ _)),
    ring, },
  simp_rw [← is_R_or_C.norm_eq_abs, ← real.rpow_nat_cast] at h',
  refine (snorm_mono_ae (ae_of_all _ h')).trans_lt ((snorm_add_le _ _ le_rfl).trans_lt _),
  { exact (Lp.ae_measurable f).norm.pow_const _ },
  { exact (Lp.ae_measurable g).norm.pow_const _ },
  simp only [nat.cast_bit0, ennreal.add_lt_top, nat.cast_one],
  exact ⟨snorm_rpow_two_norm_lt_top f, snorm_rpow_two_norm_lt_top g⟩,
end

section inner_product_space
open_locale complex_conjugate

include 𝕜

instance : has_inner 𝕜 (α →₂[μ] E) := ⟨λ f g, ∫ a, ⟪f a, g a⟫ ∂μ⟩

lemma inner_def (f g : α →₂[μ] E) : ⟪f, g⟫ = ∫ a : α, ⟪f a, g a⟫ ∂μ := rfl

lemma integral_inner_eq_sq_snorm (f : α →₂[μ] E) :
  ∫ a, ⟪f a, f a⟫ ∂μ = ennreal.to_real ∫⁻ a, (nnnorm (f a) : ℝ≥0∞) ^ (2:ℝ) ∂μ :=
begin
  simp_rw inner_self_eq_norm_sq_to_K,
  norm_cast,
  rw integral_eq_lintegral_of_nonneg_ae,
  swap, { exact filter.eventually_of_forall (λ x, sq_nonneg _), },
  swap, { exact (Lp.ae_measurable f).norm.pow_const _ },
  congr,
  ext1 x,
  have h_two : (2 : ℝ) = ((2 : ℕ) : ℝ), by simp,
  rw [← real.rpow_nat_cast _ 2, ← h_two,
    ← ennreal.of_real_rpow_of_nonneg (norm_nonneg _) zero_le_two, of_real_norm_eq_coe_nnnorm],
  norm_cast,
end

private lemma norm_sq_eq_inner' (f : α →₂[μ] E) : ∥f∥ ^ 2 = is_R_or_C.re ⟪f, f⟫ :=
begin
  have h_two : (2 : ℝ≥0∞).to_real = 2 := by simp,
  rw [inner_def, integral_inner_eq_sq_snorm, norm_def, ← ennreal.to_real_pow, is_R_or_C.of_real_re,
    ennreal.to_real_eq_to_real (ennreal.pow_ne_top (Lp.snorm_ne_top f)) _],
  { rw [←ennreal.rpow_nat_cast, snorm_eq_snorm' ennreal.two_ne_zero ennreal.two_ne_top, snorm',
      ← ennreal.rpow_mul, one_div, h_two],
    simp, },
  { refine (lintegral_rpow_nnnorm_lt_top_of_snorm'_lt_top zero_lt_two _).ne,
    rw [← h_two, ← snorm_eq_snorm' ennreal.two_ne_zero ennreal.two_ne_top],
    exact Lp.snorm_lt_top f, },
end

lemma mem_L1_inner (f g : α →₂[μ] E) :
  ae_eq_fun.mk (λ x, ⟪f x, g x⟫) ((Lp.ae_measurable f).inner (Lp.ae_measurable g)) ∈ Lp 𝕜 1 μ :=
by { simp_rw [mem_Lp_iff_snorm_lt_top, snorm_ae_eq_fun], exact snorm_inner_lt_top f g, }

lemma integrable_inner (f g : α →₂[μ] E) : integrable (λ x : α, ⟪f x, g x⟫) μ :=
(integrable_congr (ae_eq_fun.coe_fn_mk (λ x, ⟪f x, g x⟫)
    ((Lp.ae_measurable f).inner (Lp.ae_measurable g)))).mp
  (ae_eq_fun.integrable_iff_mem_L1.mpr (mem_L1_inner f g))

private lemma add_left' (f f' g : α →₂[μ] E) : ⟪f + f', g⟫ = inner f g + inner f' g :=
begin
  simp_rw [inner_def, ← integral_add (integrable_inner f g) (integrable_inner f' g),
    ←inner_add_left],
  refine integral_congr_ae ((coe_fn_add f f').mono (λ x hx, _)),
  congr,
  rwa pi.add_apply at hx,
end

private

instance inner_product_space : inner_product_space 𝕜 (α →₂[μ] E) :=
{ norm_sq_eq_inner := norm_sq_eq_inner',
  conj_sym := λ _ _, by simp_rw [inner_def, ← integral_conj, inner_conj_sym],
  add_left := add_left',
  smul_left := smul_left', }

end inner_product_space

section indicator_const_Lp

variables (𝕜) {s : set α}

/-- The inner product in `L2` of the indicator of a set `indicator_const_Lp 2 hs hμs c` and `f` is
equal to the integral of the inner product over `s`: `∫ x in s, ⟪c, f x⟫ ∂μ`. -/
lemma inner_indicator_const_Lp_eq_set_integral_inner (f : Lp E 2 μ) (hs : measurable_set s) (c : E)
  (hμs : μ s ≠ ∞) :
  (⟪indicator_const_Lp 2 hs hμs c, f⟫ : 𝕜) = ∫ x in s, ⟪c, f x⟫ ∂μ :=
begin
  rw [inner_def, ← integral_add_compl hs (L2.integrable_inner _ f)],
  have h_left : ∫ x in s, ⟪(indicator_const_Lp 2 hs hμs c) x, f x⟫ ∂μ = ∫ x in s, ⟪c, f x⟫ ∂μ,
  { suffices h_ae_eq : ∀ᵐ x ∂μ, x ∈ s → ⟪indicator_const_Lp 2 hs hμs c x, f x⟫ = ⟪c, f x⟫,
      from set_integral_congr_ae hs h_ae_eq,
    have h_indicator : ∀ᵐ (x : α) ∂μ, x ∈ s → (indicator_const_Lp 2 hs hμs c x) = c,
      from indicator_const_Lp_coe_fn_mem,
    refine h_indicator.mono (λ x hx hxs, _),
    congr,
    exact hx hxs, },
  have h_right : ∫ x in sᶜ, ⟪(indicator_const_Lp 2 hs hμs c) x, f x⟫ ∂μ = 0,
  { suffices h_ae_eq : ∀ᵐ x ∂μ, x ∉ s → ⟪indicator_const_Lp 2 hs hμs c x, f x⟫ = 0,
    { simp_rw ← set.mem_compl_iff at h_ae_eq,
      suffices h_int_zero : ∫ x in sᶜ, inner (indicator_const_Lp 2 hs hμs c x) (f x) ∂μ
        = ∫ x in sᶜ, (0 : 𝕜) ∂μ,
      { rw h_int_zero,
        simp, },
      exact set_integral_congr_ae hs.compl h_ae_eq, },
    have h_indicator : ∀ᵐ (x : α) ∂μ, x ∉ s → (indicator_const_Lp 2 hs hμs c x) = 0,
      from indicator_const_Lp_coe_fn_nmem,
    refine h_indicator.mono (λ x hx hxs, _),
    rw hx hxs,
    exact inner_zero_left, },
  rw [h_left, h_right, add_zero],
end

/-- The inner product in `L2` of the indicator of a set `indicator_const_Lp 2 hs hμs c` and `f` is
equal to the inner product of the constant `c` and the integral of `f` over `s`. -/
lemma inner_indicator_const_Lp_eq_inner_set_integral [complete_space E] [normed_space ℝ E]
  (hs : measurable_set s) (hμs : μ s ≠ ∞) (c : E) (f : Lp E 2 μ) :
  (⟪indicator_const_Lp 2 hs hμs c, f⟫ : 𝕜) = ⟪c, ∫ x in s, f x ∂μ⟫ :=
by rw [← integral_inner (integrable_on_Lp_of_measure_ne_top f fact_one_le_two_ennreal.elim hμs),
    L2.inner_indicator_const_Lp_eq_set_integral_inner]

variables {𝕜}

/-- The inner product in `L2` of the indicator of a set `indicator_const_Lp 2 hs hμs (1 : 𝕜)` and
a real or complex function `f` is equal to the integral of `f` over `s`. -/
lemma inner_indicator_const_Lp_one (hs : measurable_set s) (hμs : μ s ≠ ∞) (f : Lp 𝕜 2 μ) :
  ⟪indicator_const_Lp 2 hs hμs (1 : 𝕜), f⟫ = ∫ x in s, f x ∂μ :=
by { rw L2.inner_indicator_const_Lp_eq_inner_set_integral 𝕜 hs hμs (1 : 𝕜) f, simp, }

end indicator_const_Lp

end L2

section inner_continuous

variables {α : Type*} [topological_space α] [measure_space α] [borel_space α] {𝕜 : Type*}
  [is_R_or_C 𝕜]
variables (μ : measure α) [is_finite_measure μ]

open_locale bounded_continuous_function complex_conjugate

local notation `⟪`x`, `y`⟫` := @inner 𝕜 (α →₂[μ] 𝕜) _ x y

/-- For bounded continuous functions `f`, `g` on a finite-measure topological space `α`, the L^2
inner product is the integral of their pointwise inner product. -/
lemma bounded_continuous_function.inner_to_Lp (f g : α →ᵇ 𝕜) :
  ⟪bounded_continuous_function.to_Lp 2 μ 𝕜 f, bounded_continuous_function.to_Lp 2 μ 𝕜 g⟫
  = ∫ x, conj (f x) * g x ∂μ :=
begin
  apply integral_congr_ae,
  have hf_ae := f.coe_fn_to_Lp μ,
  have hg_ae := g.coe_fn_to_Lp μ,
  filter_upwards [hf_ae, hg_ae] with _ hf hg,
  rw [hf, hg],
  simp
end

variables [compact_space α]

/-- For continuous functions `f`, `g` on a compact, finite-measure topological space `α`, the L^2
inner product is the integral of their pointwise inner product. -/
lemma continuous_map.inner_to_Lp (f g : C(α, 𝕜)) :
  ⟪continuous_map.to_Lp 2 μ 𝕜 f, continuous_map.to_Lp 2 μ 𝕜 g⟫
  = ∫ x, conj (f x) * g x ∂μ :=
begin
  apply integral_congr_ae,
  have hf_ae := f.coe_fn_to_Lp μ,
  have hg_ae := g.coe_fn_to_Lp μ,
  filter_upwards [hf_ae, hg_ae] with _ hf hg,
  rw [hf, hg],
  simp
end

end inner_continuous

end measure_theory


namespace fol_15_16

-- Show that reflexivity is sufficient to derive the rules for symmetry and transitivity.

theorem foo {A : Type} {a b c : A} : a = b → c = b → a = c :=
assume h1: a = b,
assume h2: c = b,
show a = c, from
calc
a     = b : by rw h1
  ... = c : by rw ← h2

section
  variable A : Type
  variables a b c : A

  example (h1 : a = b) (h2 : c = b) : a = c :=
  foo h1 h2
end

section

  variable {A : Type}
  variables {a b c : A}

  -- Proof using foo and rfl, without using eq.symm.
  theorem fol_15 (h : b = a) : a = b :=
  show a = b, by rw h

  -- Using foo and fol_15 to prove transitivity.
  theorem fol_16 (h1 : a = b) (h2 : b = c) : a = c :=
  show a = c, from
  calc
  a     = b : by rw h1
    ... = c : by rw h2

end

end fol_15_16


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Patrick Massot

! This file was ported from Lean 3 source module topology.uniform_space.separation
! leanprover-community/mathlib commit 0c1f285a9f6e608ae2bdffa3f993eafb01eba829
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Tactic.ApplyFun
import Mathlib.Topology.UniformSpace.Basic
import Mathlib.Topology.Separation

/-!
# Hausdorff properties of uniform spaces. Separation quotient.

This file studies uniform spaces whose underlying topological spaces are separated
(also known as Hausdorff or T₂).
This turns out to be equivalent to asking that the intersection of all entourages
is the diagonal only. This condition actually implies the stronger separation property
that the space is T₃, hence those conditions are equivalent for topologies coming from
a uniform structure.

More generally, the intersection `𝓢 X` of all entourages of `X`, which has type `Set (X × X)` is an
equivalence relation on `X`. Points which are equivalent under the relation are basically
undistinguishable from the point of view of the uniform structure. For instance any uniformly
continuous function will send equivalent points to the same value.

The quotient `SeparationQuotient X` of `X` by `𝓢 X` has a natural uniform structure which is
separated, and satisfies a universal property: every uniformly continuous function
from `X` to a separated uniform space uniquely factors through `SeparationQuotient X`.
As usual, this allows to turn `SeparationQuotient` into a functor (but we don't use the
category theory library in this file).

These notions admit relative versions, one can ask that `s : Set X` is separated, this
is equivalent to asking that the uniform structure induced on `s` is separated.

## Main definitions

* `separationRel X : Set (X × X)`: the separation relation
* `SeparatedSpace X`: a predicate class asserting that `X` is separated
* `SeparationQuotient X`: the maximal separated quotient of `X`.
* `SeparationQuotient.lift f`: factors a map `f : X → Y` through the separation quotient of `X`.
* `separation_quotient.map f`: turns a map `f : X → Y` into a map between the separation quotients
  of `X` and `Y`.

## Main results

* `separated_iff_t2`: the equivalence between being separated and being Hausdorff for uniform
  spaces.
* `separation_quotient.uniform_continuous_lift`: factoring a uniformly continuous map through the
  separation quotient gives a uniformly continuous map.
* `separation_quotient.uniform_continuous_map`: maps induced between separation quotients are
  uniformly continuous.

## Notations

Localized in `uniformity`, we have the notation `𝓢 X` for the separation relation
on a uniform space `X`,

## Implementation notes

The separation setoid `separation_setoid` is not declared as a global instance.
It is made a local instance while building the theory of `SeparationQuotient`.
The factored map `SeparationQuotient.lift f` is defined without imposing any condition on
`f`, but returns junk if `f` is not uniformly continuous (constant junk hence it is always
uniformly continuous).

-/

open Filter Set Function Topology Uniformity UniformSpace
open scoped Classical

noncomputable section

universe u v w

variable {α : Type u} {β : Type v} {γ : Type w}
variable [UniformSpace α] [UniformSpace β] [UniformSpace γ]

/-!
### Separated uniform spaces
-/

instance (priority := 100) UniformSpace.to_regularSpace : RegularSpace α :=
  RegularSpace.ofBasis
    (fun a => by
      rw [nhds_eq_comap_uniformity]
      exact uniformity_hasBasis_closed.comap _)
    fun a V hV => by exact hV.2.preimage <| continuous_const.prod_mk continuous_id
#align uniform_space.to_regular_space UniformSpace.to_regularSpace

-- porting note: todo: use `Inseparable`
/-- The separation relation is the intersection of all entourages.
  Two points which are related by the separation relation are "indistinguishable"
  according to the uniform structure. -/
def separationRel (α : Type u) [UniformSpace α] := ⋂₀ (𝓤 α).sets
#align separation_rel separationRel

@[inherit_doc]
scoped[Uniformity] notation "𝓢" => separationRel

theorem separated_equiv : Equivalence fun x y => (x, y) ∈ 𝓢 α :=
  ⟨fun _ _ => refl_mem_uniformity, fun h _s hs => h _ (symm_le_uniformity hs),
    fun {x y z} (hxy : (x, y) ∈ 𝓢 α) (hyz : (y, z) ∈ 𝓢 α) s (hs : s ∈ 𝓤 α) =>
    let ⟨t, ht, (h_ts : compRel t t ⊆ s)⟩ := comp_mem_uniformity_sets hs
    h_ts <| show (x, z) ∈ compRel t t from ⟨y, hxy t ht, hyz t ht⟩⟩
#align separated_equiv separated_equiv

theorem Filter.HasBasis.mem_separationRel {ι : Sort _} {p : ι → Prop} {s : ι → Set (α × α)}
    (h : (𝓤 α).HasBasis p s) {a : α × α} : a ∈ 𝓢 α ↔ ∀ i, p i → a ∈ s i :=
  h.forall_mem_mem
#align filter.has_basis.mem_separation_rel Filter.HasBasis.mem_separationRel

theorem separationRel_iff_specializes {a b : α} : (a, b) ∈ 𝓢 α ↔ a ⤳ b := by
  simp only [(𝓤 α).basis_sets.mem_separationRel, id, mem_setOf_eq,
    (nhds_basis_uniformity (𝓤 α).basis_sets).specializes_iff]
#align separation_rel_iff_specializes separationRel_iff_specializes

theorem separationRel_iff_inseparable {a b : α} : (a, b) ∈ 𝓢 α ↔ Inseparable a b :=
  separationRel_iff_specializes.trans specializes_iff_inseparable
#align separation_rel_iff_inseparable separationRel_iff_inseparable

/-- A uniform space is separated if its separation relation is trivial (each point
is related only to itself). -/
class SeparatedSpace (α : Type u) [UniformSpace α] : Prop where
  /-- The separation relation is equal to the diagonal `idRel`. -/
  out : 𝓢 α = idRel
#align separated_space SeparatedSpace

theorem separatedSpace_iff {α : Type u} [UniformSpace α] : SeparatedSpace α ↔ 𝓢 α = idRel :=
  ⟨fun h => h.1, fun h => ⟨h⟩⟩
#align separated_space_iff separatedSpace_iff

theorem separated_def {α : Type u} [UniformSpace α] :
    SeparatedSpace α ↔ ∀ x y, (∀ r ∈ 𝓤 α, (x, y) ∈ r) → x = y := by
  simp only [separatedSpace_iff, Set.ext_iff, Prod.forall, mem_idRel, separationRel, mem_interₛ]
  exact forall₂_congr fun _ _ => ⟨Iff.mp, fun h => ⟨h, fun H U hU => H ▸ refl_mem_uniformity hU⟩⟩
#align separated_def separated_def

theorem separated_def' {α : Type u} [UniformSpace α] :
    SeparatedSpace α ↔ ∀ x y, x ≠ y → ∃ r ∈ 𝓤 α, (x, y) ∉ r :=
  separated_def.trans <| forall₂_congr fun x y => by rw [← not_imp_not]; simp [not_forall]
#align separated_def' separated_def'

theorem eq_of_uniformity {α : Type _} [UniformSpace α] [SeparatedSpace α] {x y : α}
    (h : ∀ {V}, V ∈ 𝓤 α → (x, y) ∈ V) : x = y :=
  separated_def.mp ‹SeparatedSpace α› x y fun _ => h
#align eq_of_uniformity eq_of_uniformity

theorem eq_of_uniformity_basis {α : Type _} [UniformSpace α] [SeparatedSpace α] {ι : Type _}
    {p : ι → Prop} {s : ι → Set (α × α)} (hs : (𝓤 α).HasBasis p s) {x y : α}
    (h : ∀ {i}, p i → (x, y) ∈ s i) : x = y :=
  eq_of_uniformity fun V_in => let ⟨_, hi, H⟩ := hs.mem_iff.mp V_in; H (h hi)
#align eq_of_uniformity_basis eq_of_uniformity_basis

theorem eq_of_forall_symmetric {α : Type _} [UniformSpace α] [SeparatedSpace α] {x y : α}
    (h : ∀ {V}, V ∈ 𝓤 α → SymmetricRel V → (x, y) ∈ V) : x = y :=
  eq_of_uniformity_basis hasBasis_symmetric (by simpa [and_imp])
#align eq_of_forall_symmetric eq_of_forall_symmetric

theorem eq_of_clusterPt_uniformity [SeparatedSpace α] {x y : α} (h : ClusterPt (x, y) (𝓤 α)) :
    x = y :=
  eq_of_uniformity_basis uniformity_hasBasis_closed fun ⟨hV, hVc⟩ =>
    isClosed_iff_clusterPt.1 hVc _ <| h.mono <| le_principal_iff.2 hV
#align eq_of_cluster_pt_uniformity eq_of_clusterPt_uniformity

theorem idRel_sub_separationRel (α : Type _) [UniformSpace α] : idRel ⊆ 𝓢 α := by
  unfold separationRel
  rw [idRel_subset]
  intro x
  suffices ∀ t ∈ 𝓤 α, (x, x) ∈ t by simpa only [refl_mem_uniformity]
  exact fun t => refl_mem_uniformity
#align id_rel_sub_separation_relation idRel_sub_separationRel

theorem separationRel_comap {f : α → β}
    (h : ‹UniformSpace α› = UniformSpace.comap f ‹UniformSpace β›) :
    𝓢 α = Prod.map f f ⁻¹' 𝓢 β := by
  subst h
  dsimp [separationRel]
  simp_rw [uniformity_comap, (Filter.comap_hasBasis (Prod.map f f) (𝓤 β)).interₛ_sets, ←
    preimage_interᵢ, interₛ_eq_binterᵢ]
  rfl
#align separation_rel_comap separationRel_comap

protected theorem Filter.HasBasis.separationRel {ι : Sort _} {p : ι → Prop} {s : ι → Set (α × α)}
    (h : HasBasis (𝓤 α) p s) : 𝓢 α = ⋂ (i) (_hi : p i), s i := by
  unfold separationRel
  rw [h.interₛ_sets]
#align filter.has_basis.separation_rel Filter.HasBasis.separationRel

theorem separationRel_eq_inter_closure : 𝓢 α = ⋂₀ (closure '' (𝓤 α).sets) := by
  simp [uniformity_hasBasis_closure.separationRel]
#align separation_rel_eq_inter_closure separationRel_eq_inter_closure

theorem isClosed_separationRel : IsClosed (𝓢 α) := by
  rw [separationRel_eq_inter_closure]
  apply isClosed_interₛ
  rintro _ ⟨t, -, rfl⟩
  exact isClosed_closure
#align is_closed_separation_rel isClosed_separationRel

theorem separated_iff_t2 : SeparatedSpace α ↔ T2Space α := by
  constructor <;> intro h
  · rw [t2_iff_isClosed_diagonal, ← show 𝓢 α = diagonal α from h.1]
    exact isClosed_separationRel
  · rw [separated_def']
    intro x y hxy
    rcases t2_separation hxy with ⟨u, v, uo, -, hx, hy, h⟩
    rcases isOpen_iff_ball_subset.1 uo x hx with ⟨r, hrU, hr⟩
    exact ⟨r, hrU, fun H => h.le_bot ⟨hr H, hy⟩⟩
#align separated_iff_t2 separated_iff_t2

-- see Note [lower instance priority]
instance (priority := 100) separated_t3 [SeparatedSpace α] : T3Space α :=
  haveI := separated_iff_t2.mp ‹_›
  ⟨⟩
#align separated_t3 separated_t3

instance Subtype.separatedSpace [SeparatedSpace α] (s : Set α) : SeparatedSpace s :=
  separated_iff_t2.mpr inferInstance
#align subtype.separated_space Subtype.separatedSpace

theorem isClosed_of_spaced_out [SeparatedSpace α] {V₀ : Set (α × α)} (V₀_in : V₀ ∈ 𝓤 α) {s : Set α}
    (hs : s.Pairwise fun x y => (x, y) ∉ V₀) : IsClosed s := by
  rcases comp_symm_mem_uniformity_sets V₀_in with ⟨V₁, V₁_in, V₁_symm, h_comp⟩
  apply isClosed_of_closure_subset
  intro x hx
  rw [mem_closure_iff_ball] at hx
  rcases hx V₁_in with ⟨y, hy, hy'⟩
  suffices x = y by rwa [this]
  apply eq_of_forall_symmetric
  intro V V_in _
  rcases hx (inter_mem V₁_in V_in) with ⟨z, hz, hz'⟩
  obtain rfl : z = y := by
    by_contra hzy
    exact hs hz' hy' hzy (h_comp <| mem_comp_of_mem_ball V₁_symm (ball_inter_left x _ _ hz) hy)
  exact ball_inter_right x _ _ hz
#align is_closed_of_spaced_out isClosed_of_spaced_out

theorem isClosed_range_of_spaced_out {ι} [SeparatedSpace α] {V₀ : Set (α × α)} (V₀_in : V₀ ∈ 𝓤 α)
    {f : ι → α} (hf : Pairwise fun x y => (f x, f y) ∉ V₀) : IsClosed (range f) :=
  isClosed_of_spaced_out V₀_in <| by
    rintro _ ⟨x, rfl⟩ _ ⟨y, rfl⟩ h
    exact hf (ne_of_apply_ne f h)
#align is_closed_range_of_spaced_out isClosed_range_of_spaced_out

/-!
### Separation quotient
-/

namespace UniformSpace

/-- The separation relation of a uniform space seen as a setoid. -/
def separationSetoid (α : Type u) [UniformSpace α] : Setoid α :=
  ⟨fun x y => (x, y) ∈ 𝓢 α, separated_equiv⟩
#align uniform_space.separation_setoid UniformSpace.separationSetoid

attribute [local instance] separationSetoid

instance separationSetoid.uniformSpace {α : Type u} [UniformSpace α] :
    UniformSpace (Quotient (separationSetoid α)) where
  toTopologicalSpace := instTopologicalSpaceQuotient
  uniformity := map (fun p : α × α => (⟦p.1⟧, ⟦p.2⟧)) (𝓤 α)
  refl := le_trans (by simp [Quotient.exists_rep]) (Filter.map_mono refl_le_uniformity)
  symm := tendsto_map' <| tendsto_map.comp tendsto_swap_uniformity
  comp := fun s hs => by
    rcases comp_open_symm_mem_uniformity_sets hs with ⟨U, hU, hUo, -, hUs⟩
    refine' mem_of_superset (mem_lift' <| image_mem_map hU) ?_
    simp only [subset_def, Prod.forall, mem_compRel, mem_image, Prod.ext_iff]
    rintro _ _ ⟨_, ⟨⟨x, y⟩, hxyU, rfl, rfl⟩, ⟨⟨y', z⟩, hyzU, hy, rfl⟩⟩
    have : y' ⤳ y := separationRel_iff_specializes.1 (Quotient.exact hy)
    exact @hUs (x, z) ⟨y', this.mem_open (UniformSpace.isOpen_ball _ hUo) hxyU, hyzU⟩
  isOpen_uniformity s := isOpen_coinduced.trans <| by
    simp only [_root_.isOpen_uniformity, forall_quotient_iff, mem_map', mem_setOf_eq]
    refine forall₂_congr fun x _ => ⟨fun h => ?_, fun h => mem_of_superset h ?_⟩
    · rcases comp_mem_uniformity_sets h with ⟨t, ht, hts⟩
      refine mem_of_superset ht fun (y, z) hyz hyx => @hts (x, z) ⟨y, ?_, hyz⟩ rfl
      exact Quotient.exact hyx.symm _ ht
    · exact fun y hy hyx => hy <| congr_arg _ hyx
#align uniform_space.separation_setoid.uniform_space UniformSpace.separationSetoid.uniformSpace

theorem uniformity_quotient :
    𝓤 (Quotient (separationSetoid α)) = (𝓤 α).map fun p : α × α => (⟦p.1⟧, ⟦p.2⟧) :=
  rfl
#align uniform_space.uniformity_quotient UniformSpace.uniformity_quotient

theorem uniformContinuous_quotient_mk' :
    UniformContinuous (Quotient.mk' : α → Quotient (separationSetoid α)) :=
  le_rfl
#align uniform_space.uniform_continuous_quotient_mk UniformSpace.uniformContinuous_quotient_mk'

theorem uniformContinuous_quotient_mk : UniformContinuous (Quotient.mk (separationSetoid α)) :=
  le_rfl

theorem uniformContinuous_quotient {f : Quotient (separationSetoid α) → β}
    (hf : UniformContinuous fun x => f ⟦x⟧) : UniformContinuous f :=
  hf
#align uniform_space.uniform_continuous_quotient UniformSpace.uniformContinuous_quotient

theorem uniformContinuous_quotient_lift {f : α → β} {h : ∀ a b, (a, b) ∈ 𝓢 α → f a = f b}
    (hf : UniformContinuous f) : UniformContinuous fun a => Quotient.lift f h a :=
  uniformContinuous_quotient hf
#align uniform_space.uniform_continuous_quotient_lift UniformSpace.uniformContinuous_quotient_lift

theorem uniformContinuous_quotient_lift₂ {f : α → β → γ}
    {h : ∀ a c b d, (a, b) ∈ 𝓢 α → (c, d) ∈ 𝓢 β → f a c = f b d}
    (hf : UniformContinuous fun p : α × β => f p.1 p.2) :
    UniformContinuous fun p : _ × _ => Quotient.lift₂ f h p.1 p.2 := by
  rw [UniformContinuous, uniformity_prod_eq_prod, uniformity_quotient, uniformity_quotient,
    Filter.prod_map_map_eq, Filter.tendsto_map'_iff, Filter.tendsto_map'_iff]
  rwa [UniformContinuous, uniformity_prod_eq_prod, Filter.tendsto_map'_iff] at hf
#align uniform_space.uniform_continuous_quotient_lift₂ UniformSpace.uniformContinuous_quotient_lift₂

theorem comap_quotient_le_uniformity :
    ((𝓤 <| Quotient <| separationSetoid α).comap fun p : α × α => (⟦p.fst⟧, ⟦p.snd⟧)) ≤ 𝓤 α :=
  ((((𝓤 α).basis_sets.map _).comap _).le_basis_iff uniformity_hasBasis_open).2 fun U hU =>
    ⟨U, hU.1, fun ⟨x, y⟩ ⟨⟨x', y'⟩, hx', h⟩ => by
      simp only [Prod.ext_iff, Quotient.eq] at h
      exact (((separationRel_iff_inseparable.1 h.1).prod
        (separationRel_iff_inseparable.1 h.2)).mem_open_iff hU.2).1 hx'⟩
#align uniform_space.comap_quotient_le_uniformity UniformSpace.comap_quotient_le_uniformity

theorem comap_quotient_eq_uniformity :
    ((𝓤 <| Quotient <| separationSetoid α).comap fun p : α × α => (⟦p.fst⟧, ⟦p.snd⟧)) = 𝓤 α :=
  le_antisymm comap_quotient_le_uniformity le_comap_map
#align uniform_space.comap_quotient_eq_uniformity UniformSpace.comap_quotient_eq_uniformity

instance separated_separation : SeparatedSpace (Quotient (separationSetoid α)) :=
  ⟨Set.ext fun ⟨a, b⟩ =>
      Quotient.inductionOn₂ a b fun a b =>
        ⟨fun h =>
          have : a ≈ b := fun s hs =>
            have :
              s ∈ (𝓤 <| Quotient <| separationSetoid α).comap fun p : α × α => (⟦p.1⟧, ⟦p.2⟧) :=
              comap_quotient_le_uniformity hs
            let ⟨t, ht, hts⟩ := this
            hts (by dsimp [preimage]; exact h t ht)
          show ⟦a⟧ = ⟦b⟧ from Quotient.sound this,
          fun heq : ⟦a⟧ = ⟦b⟧ => fun h hs => heq ▸ refl_mem_uniformity hs⟩⟩
#align uniform_space.separated_separation UniformSpace.separated_separation

theorem separated_of_uniformContinuous {f : α → β} {x y : α} (H : UniformContinuous f) (h : x ≈ y) :
    f x ≈ f y := fun _ h' => h _ (H h')
#align uniform_space.separated_of_uniform_continuous UniformSpace.separated_of_uniformContinuous

theorem eq_of_separated_of_uniformContinuous [SeparatedSpace β] {f : α → β} {x y : α}
    (H : UniformContinuous f) (h : x ≈ y) : f x = f y :=
  separated_def.1 (by infer_instance) _ _ <| separated_of_uniformContinuous H h
#align uniform_space.eq_of_separated_of_uniform_continuous UniformSpace.eq_of_separated_of_uniformContinuous

/-- The maximal separated quotient of a uniform space `α`. -/
def SeparationQuotient (α : Type _) [UniformSpace α] :=
  Quotient (separationSetoid α)
#align uniform_space.separation_quotient UniformSpace.SeparationQuotient

namespace SeparationQuotient

instance : UniformSpace (SeparationQuotient α) :=
  separationSetoid.uniformSpace

instance : SeparatedSpace (SeparationQuotient α) :=
  UniformSpace.separated_separation

instance [Inhabited α] : Inhabited (SeparationQuotient α) :=
  inferInstanceAs (Inhabited (Quotient (separationSetoid α)))

lemma mk_eq_mk {x y : α} : (⟦x⟧ : SeparationQuotient α) = ⟦y⟧ ↔ Inseparable x y :=
Quotient.eq'.trans separationRel_iff_inseparable
#align uniform_space.separation_quotient.mk_eq_mk UniformSpace.SeparationQuotient.mk_eq_mk

/-- Factoring functions to a separated space through the separation quotient. -/
def lift [SeparatedSpace β] (f : α → β) : SeparationQuotient α → β :=
  if h : UniformContinuous f then Quotient.lift f fun _ _ => eq_of_separated_of_uniformContinuous h
  else fun x => f (Nonempty.some ⟨x.out⟩)
#align uniform_space.separation_quotient.lift UniformSpace.SeparationQuotient.lift

theorem lift_mk [SeparatedSpace β] {f : α → β} (h : UniformContinuous f) (a : α) :
    lift f ⟦a⟧ = f a := by rw [lift, dif_pos h]; rfl
#align uniform_space.separation_quotient.lift_mk UniformSpace.SeparationQuotient.lift_mk

theorem uniformContinuous_lift [SeparatedSpace β] (f : α → β) : UniformContinuous (lift f) := by
  by_cases hf : UniformContinuous f
  · rw [lift, dif_pos hf]
    exact uniformContinuous_quotient_lift hf
  · rw [lift, dif_neg hf]
    exact uniformContinuous_of_const fun a _ => rfl
#align uniform_space.separation_quotient.uniform_continuous_lift UniformSpace.SeparationQuotient.uniformContinuous_lift

/-- The separation quotient functor acting on functions. -/
def map (f : α → β) : SeparationQuotient α → SeparationQuotient β :=
  lift (Quotient.mk' ∘ f)
#align uniform_space.separation_quotient.map UniformSpace.SeparationQuotient.map

theorem map_mk {f : α → β} (h : UniformContinuous f) (a : α) : map f ⟦a⟧ = ⟦f a⟧ := by
  rw [map, lift_mk (uniformContinuous_quotient_mk'.comp h)]; rfl
#align uniform_space.separation_quotient.map_mk UniformSpace.SeparationQuotient.map_mk

theorem uniformContinuous_map (f : α → β) : UniformContinuous (map f) :=
  uniformContinuous_lift (Quotient.mk' ∘ f)
#align uniform_space.separation_quotient.uniform_continuous_map UniformSpace.SeparationQuotient.uniformContinuous_map

theorem map_id : map (@id α) = id :=
  map_unique uniformContinuous_id rfl
#align uniform_space.separation_quotient.map_id UniformSpace.SeparationQuotient.map_id

theorem map_comp {f : α → β} {g : β → γ} (hf : UniformContinuous f) (hg : UniformContinuous g) :
    map g ∘ map f = map (g ∘ f) :=
  (map_unique (hg.comp hf) <| by simp only [Function.comp, map_mk, hf, hg]).symm
#align uniform_space.separation_quotient.map_comp UniformSpace.SeparationQuotient.map_comp

end SeparationQuotient

theorem separation_prod {a₁ a₂ : α} {b₁ b₂ : β} : (a₁, b₁) ≈ (a₂, b₂) ↔ a₁ ≈ a₂ ∧ b₁ ≈ b₂ := by
  constructor
  · intro h
    exact
      ⟨separated_of_uniformContinuous uniformContinuous_fst h,
        separated_of_uniformContinuous uniformContinuous_snd h⟩
  · rintro ⟨eqv_α, eqv_β⟩ r r_in
    rw [uniformity_prod] at r_in
    rcases r_in with ⟨t_α, ⟨r_α, r_α_in, h_α⟩, t_β, ⟨r_β, r_β_in, h_β⟩, rfl⟩
    let p_α := fun p : (α × β) × α × β => (p.1.1, p.2.1)
    let p_β := fun p : (α × β) × α × β => (p.1.2, p.2.2)
    have key_α : p_α ((a₁, b₁), (a₂, b₂)) ∈ r_α := by simp [eqv_α r_α r_α_in]
    have key_β : p_β ((a₁, b₁), (a₂, b₂)) ∈ r_β := by simp [eqv_β r_β r_β_in]
    exact ⟨h_α key_α, h_β key_β⟩
#align uniform_space.separation_prod UniformSpace.separation_prod

instance Separated.prod [SeparatedSpace α] [SeparatedSpace β] : SeparatedSpace (α × β) :=
  separated_def.2 fun _ _ H =>
    Prod.ext (eq_of_separated_of_uniformContinuous uniformContinuous_fst H)
      (eq_of_separated_of_uniformContinuous uniformContinuous_snd H)
#align uniform_space.separated.prod UniformSpace.Separated.prod

end UniformSpace


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

! This file was ported from Lean 3 source module ring_theory.ring_hom.integral
! leanprover-community/mathlib commit b5aecf07a179c60b6b37c1ac9da952f3b565c785
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.RingTheory.RingHomProperties

/-!

# The meta properties of integral ring homomorphisms.

-/

namespace RingHom

open TensorProduct

open TensorProduct Algebra.TensorProduct

theorem isIntegral_stableUnderComposition : StableUnderComposition fun R S _ _ f => f.is_integral :=
  by
  introv R hf hg
  exact RingHom.isIntegral_trans _ _ hf hg
#align ring_hom.is_integral_stable_under_composition RingHom.isIntegral_stableUnderComposition

theorem isIntegral_respectsIso : RespectsIso fun R S _ _ f => f.is_integral :=
  by
  apply is_integral_stable_under_composition.respects_iso
  introv x
  skip
  rw [← e.apply_symm_apply x]
  apply RingHom.is_integral_map
#align ring_hom.is_integral_respects_iso RingHom.isIntegral_respectsIso

theorem isIntegral_stableUnderBaseChange : StableUnderBaseChange fun R S _ _ f => f.is_integral :=
  by
  refine' stable_under_base_change.mk _ is_integral_respects_iso _
  introv h x
  skip
  apply TensorProduct.induction_on x
  · apply isIntegral_zero
  · intro x y
    exact IsIntegral.tmul x (h y)
  · intro x y hx hy
    exact isIntegral_add _ hx hy
#align ring_hom.is_integral_stable_under_base_change RingHom.isIntegral_stableUnderBaseChange

end RingHom


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import linear_algebra.finsupp
import algebra.monoid_algebra.basic
import algebra.direct_sum.internal
import ring_theory.graded_algebra.basic

/-!
# Internal grading of an `add_monoid_algebra`

In this file, we show that an `add_monoid_algebra` has an internal direct sum structure.

## Main results

* `add_monoid_algebra.grade_by R f i`: the `i`th grade of an `add_monoid_algebra R M` given by the
  degree function `f`.
* `add_monoid_algebra.grade R i`: the `i`th grade of an `add_monoid_algebra R M` when the degree
  function is the identity.
* `add_monoid_algebra.grade_by.graded_algebra`: `add_monoid_algebra` is an algebra graded by
  `add_monoid_algebra.grade_by`.
* `add_monoid_algebra.grade.graded_algebra`: `add_monoid_algebra` is an algebra graded by
  `add_monoid_algebra.grade`.
* `add_monoid_algebra.grade_by.is_internal`: propositionally, the statement that
  `add_monoid_algebra.grade_by` defines an internal graded structure.
* `add_monoid_algebra.grade.is_internal`: propositionally, the statement that
  `add_monoid_algebra.grade` defines an internal graded structure when the degree function
  is the identity.
-/

noncomputable theory

namespace add_monoid_algebra
variables {M : Type*} {ι : Type*} {R : Type*} [decidable_eq M]

section
variables (R) [comm_semiring R]

/-- The submodule corresponding to each grade given by the degree function `f`. -/
abbreviation grade_by (f : M → ι) (i : ι) : submodule R (add_monoid_algebra R M) :=
{ carrier := {a | ∀ m, m ∈ a.support → f m = i },
  zero_mem' := set.empty_subset _,
  add_mem' := λ a b ha hb m h,
    or.rec_on (finset.mem_union.mp (finsupp.support_add h)) (ha m) (hb m),
  smul_mem' := λ a m h, set.subset.trans finsupp.support_smul h }

/-- The submodule corresponding to each grade. -/
abbreviation grade (m : M) : submodule R (add_monoid_algebra R M) := grade_by R id m

lemma grade_by_id : grade_by R (id : M → M) = grade R := by refl

lemma mem_grade_iff (m : M) (a : add_monoid_algebra R M) : a ∈ grade R m ↔ a.support ⊆ {m} :=
begin
  rw [← finset.coe_subset, finset.coe_singleton],
  refl
end

lemma mem_grade_iff' (m : M) (a : add_monoid_algebra R M) :
  a ∈ grade R m ↔
    a ∈ ((finsupp.lsingle m).range : submodule R (add_monoid_algebra R M)) :=
begin
  rw [mem_grade_iff, finsupp.support_subset_singleton'],
  apply exists_congr,
  intros r,
  split; exact eq.symm
end

lemma grade_eq_lsingle_range (m : M) : grade R m = (finsupp.lsingle m).range :=
submodule.ext (mem_grade_iff' R m)

lemma single_mem_grade_by {R} [comm_semiring R] (f : M → ι) (m : M) (r : R) :
  finsupp.single m r ∈ grade_by R f (f m) :=
begin
  intros x hx,
  rw finset.mem_singleton.mp (finsupp.support_single_subset hx),
end

lemma single_mem_grade {R} [comm_semiring R] (i : M) (r : R) : finsupp.single i r ∈ grade R i :=
single_mem_grade_by _ _ _

end

open_locale direct_sum

instance grade_by.graded_monoid [add_monoid M] [add_monoid ι] [comm_semiring R] (f : M →+ ι) :
  set_like.graded_monoid (grade_by R f : ι → submodule R (add_monoid_algebra R M)) :=
{ one_mem := λ m h, begin
    rw one_def at h,
    by_cases H : (1 : R) = (0 : R),
    { rw [H , finsupp.single_zero] at h,
      exfalso,
      exact h },
    { rw [finsupp.support_single_ne_zero _ H, finset.mem_singleton] at h,
      rw [h, add_monoid_hom.map_zero] }
  end,
  mul_mem := λ i j a b ha hb c hc, begin
    set h := support_mul a b hc,
    simp only [finset.mem_bUnion] at h,
    rcases h with ⟨ma, ⟨hma, ⟨mb, ⟨hmb, hmc⟩⟩⟩⟩,
    rw [← ha ma hma, ← hb mb hmb, finset.mem_singleton.mp hmc],
    apply add_monoid_hom.map_add
  end }

instance grade.graded_monoid [add_monoid M] [comm_semiring R] :
  set_like.graded_monoid (grade R : M → submodule R (add_monoid_algebra R M)) :=
by apply grade_by.graded_monoid (add_monoid_hom.id _)

variables {R} [add_monoid M] [decidable_eq ι] [add_monoid ι] [comm_semiring R] (f : M →+ ι)

/-- Auxiliary definition; the canonical grade decomposition, used to provide
`direct_sum.decompose`. -/
def decompose_aux : add_monoid_algebra R M →ₐ[R] ⨁ i : ι, grade_by R f i :=
add_monoid_algebra.lift R M _
{ to_fun := λ m, direct_sum.of (λ i : ι, grade_by R f i) (f m.to_add)
    ⟨finsupp.single m.to_add 1, single_mem_grade_by _ _ _⟩,
  map_one' := direct_sum.of_eq_of_graded_monoid_eq (by congr' 2; try {ext};
    simp only [submodule.mem_to_add_submonoid, to_add_one, add_monoid_hom.map_zero]),
  map_mul' := λ i j, begin
    symmetry,
    convert direct_sum.of_mul_of _ _,
    apply direct_sum.of_eq_of_graded_monoid_eq,
    congr' 2,
    { rw [to_add_mul, add_monoid_hom.map_add] },
    { ext,
      simp only [submodule.mem_to_add_submonoid, add_monoid_hom.map_add, to_add_mul] },
    { exact eq.trans (by rw [one_mul, to_add_mul]) single_mul_single.symm }
  end }

lemma decompose_aux_single (m : M) (r : R) :
  decompose_aux f (finsupp.single m r) =
    direct_sum.of (λ i : ι, grade_by R f i) (f m)
      ⟨finsupp.single m r, single_mem_grade_by _ _ _⟩ :=
begin
  refine (lift_single _ _ _).trans _,
  refine (direct_sum.of_smul _ _ _ _).symm.trans _,
  apply direct_sum.of_eq_of_graded_monoid_eq,
  refine sigma.subtype_ext rfl _,
  refine (finsupp.smul_single' _ _ _).trans _,
  rw mul_one,
  refl,
end

lemma decompose_aux_coe {i : ι} (x : grade_by R f i) :
  decompose_aux f ↑x = direct_sum.of (λ i, grade_by R f i) i x :=
begin
  obtain ⟨x, hx⟩ := x,
  revert hx,
  refine finsupp.induction x _ _,
  { intros hx,
    symmetry,
    exact add_monoid_hom.map_zero _ },
  { intros m b y hmy hb ih hmby,
    have : disjoint (finsupp.single m b).support y.support,
    { simpa only [finsupp.support_single_ne_zero _ hb, finset.disjoint_singleton_left] },
    rw [mem_grade_by_iff, finsupp.support_add_eq this, finset.coe_union,
      set.union_subset_iff] at hmby,
    cases hmby with h1 h2,
    have : f m = i,
    { rwa [finsupp.support_single_ne_zero _ hb, finset.coe_singleton,
        set.singleton_subset_iff] at h1 },
    subst this,
    simp only [alg_hom.map_add, submodule.coe_mk, decompose_aux_single f m],
    let ih' := ih h2,
    dsimp at ih',
    rw [ih', ← add_monoid_hom.map_add],
    apply direct_sum.of_eq_of_graded_monoid_eq,
    congr' 2 }
end

instance grade_by.graded_algebra : graded_algebra (grade_by R f) :=
graded_algebra.of_alg_hom _
  (decompose_aux f)
  (begin
    ext : 2,
    dsimp,
    rw [decompose_aux_single, direct_sum.coe_alg_hom_of, subtype.coe_mk],
  end)
  (λ i x, by convert (decompose_aux_coe f x : _))

-- Lean can't find this later without us repeating it
instance grade_by.decomposition : direct_sum.decomposition (grade_by R f) :=
by apply_instance

@[simp] lemma decompose_aux_eq_decompose :
  ⇑(decompose_aux f : add_monoid_algebra R M →ₐ[R] ⨁ i : ι, grade_by R f i) =
    (direct_sum.decompose (grade_by R f)) := rfl

@[simp] lemma grades_by.decompose_single (m : M) (r : R) :
  direct_sum.decompose (grade_by R f) (finsupp.single m r) =
    direct_sum.of (λ i : ι, grade_by R f i) (f m)
      ⟨finsupp.single m r, single_mem_grade_by _ _ _⟩ :=
decompose_aux_single _ _ _

instance grade.graded_algebra : graded_algebra (grade R : ι → submodule _ _) :=
add_monoid_algebra.grade_by.graded_algebra (add_monoid_hom.id _)

-- Lean can't find this later without us repeating it
instance grade.decomposition : direct_sum.decomposition (grade R : ι → submodule _ _) :=
by apply_instance

@[simp]
lemma grade.decompose_single (i : ι) (r : R) :
  direct_sum.decompose (grade R : ι → submodule _ _) (finsupp.single i r) =
    direct_sum.of (λ i : ι, grade R i) i ⟨finsupp.single i r, single_mem_grade _ _⟩ :=
decompose_aux_single _ _ _

/-- `add_monoid_algebra.gradesby` describe an internally graded algebra -/
lemma grade_by.is_internal : direct_sum.is_internal (grade_by R f) :=
direct_sum.decomposition.is_internal _

/-- `add_monoid_algebra.grades` describe an internally graded algebra -/
lemma grade.is_internal : direct_sum.is_internal (grade R : ι → submodule R _) :=
direct_sum.decomposition.is_internal _

end add_monoid_algebra