import analysis.special_functions.exp_deriv
import analysis.calculus.deriv
import analysis.calculus.mean_value

universe u_1

lemma fun_split
(f g : ℝ → ℝ)
:
(λ x, (f x) + (g x)) = ((λ x, f x) + (λ x, g x))
:=
begin
ring_nf,
end

theorem antideriv_const
(f : ℝ → ℝ) (k : ℝ)
(hf : ∀ x, has_deriv_at f k x):
(f = λ x, (k*x) + (f 0) ) :=
begin
   have h1: ∀(x y : ℝ), f x - (x*k) = f y - (y*k),
   {
    apply is_const_of_deriv_eq_zero,
    {
      rw differentiable,
      intro x,
      specialize hf x,
      apply has_deriv_at.differentiable_at,
      apply has_deriv_at.sub,
      {
        convert hf,
      },
      apply has_deriv_at_mul_const,
    },
    intro x,
    rw deriv_sub,
    rw sub_eq_zero,
    simp,
    rw has_deriv_at.deriv,
    specialize hf x,
    apply hf,
    apply has_deriv_at.differentiable_at,
    specialize hf x,
    apply hf,
    simp,
  },
  ext z,
  specialize h1 z 0,
  apply eq_add_of_sub_eq',
  simp at h1,
  rw mul_comm at h1,
  exact h1,
end

theorem antideriv_pow
(f : ℝ → ℝ)
(hf : ∀ x, ∀ (n : ℕ), has_deriv_at f (x^n) x) :
∀(n:ℕ), (f = λ x, (x^(n+1))/↑(n+1) + (f 0)) :=
begin
  have h1: ∀ (n:ℕ) (x y : ℝ), f x - (x^(n+1))/↑(n+1) = f y - (y^(n+1))/↑(n+1),
  {
    intro n,
    rw ← nat.succ_eq_add_one,
    apply is_const_of_deriv_eq_zero,
    {
      rw differentiable,
      intro x,
      specialize hf x,
      apply has_deriv_at.differentiable_at,
      apply has_deriv_at.sub,
      {
        specialize hf n,
        exact hf,
      },
      apply has_deriv_at.div_const,
      apply has_deriv_at_pow,
    },
    intro x,
    rw deriv_sub,
    rw sub_eq_zero,
    simp,
    rw has_deriv_at.deriv,
    specialize hf x,
    specialize hf n,
    rw ← nat.cast_add_one,
    rw mul_div_assoc,
    rw mul_div_left_comm,
    rw div_self,
    rw mul_one,
    exact hf,
    rw nat.cast_ne_zero,
    finish,
    apply has_deriv_at.differentiable_at,
    apply hf,
    exact n,
    apply differentiable_at.div_const,
    apply differentiable_at_pow,
  },
  intro n,
  ext z,
  specialize h1 n z 0,
  apply eq_add_of_sub_eq',
  simpa using h1,
end

theorem antideriv_zpow
(f : ℝ → ℝ)
(hf : ∀ x, x ≠ 0 ∧ ∀ z:ℤ,has_deriv_at f (x^z) x) :
∀(z:ℤ), (↑z + (1:ℝ) ≠ 0  → f = λ x, (x^(z+1))/↑(z+1) + (f 0)) :=
begin
  have h1: ∀ (z:ℤ), ↑z + (1:ℝ) ≠ 0  → ∀ (x y : ℝ), f x - (x^(z+1))/↑(z+1) = f y - (y^(z+1))/↑(z+1),
  {
    intro z,
    intro h,
    apply is_const_of_deriv_eq_zero,
    {
      rw differentiable,
      intro x,
      specialize hf x,
      cases hf with hx hf,
      apply has_deriv_at.differentiable_at,
      apply has_deriv_at.sub,
      {
        specialize hf z,
        exact hf,
      },
      apply has_deriv_at.div_const,
      apply has_deriv_at_zpow,
      left,
      exact hx,
    },
    intro x,
    specialize hf x,
    cases hf with hx hf,
    rw deriv_sub,
    rw sub_eq_zero,
    simp,
    rw has_deriv_at.deriv,
    rw mul_div_assoc,
    rw mul_div_left_comm,
    rw div_self,
    rw mul_one,
    exact hf z,
    exact h,
    apply has_deriv_at.differentiable_at,
    exact hf z,
    apply differentiable_at.div_const,
    rw differentiable_at_zpow,
    left,
    exact hx,
  },
  intro z,
  intro h,
  ext v,
  specialize h1 z h v 0,
  apply eq_add_of_sub_eq',
  rw zero_zpow at h1,
  simpa using h1,
  norm_cast at *,
end

theorem antideriv_first_order_poly
{k j: ℝ}
(f : ℝ → ℝ)
(hf : ∀ x, has_deriv_at f (j*x + k) x) :
(f = λ x, j*(x^2)/2 + k*x + (f 0)) :=
begin
  conv{
  find (k*_) {rw ← pow_one x,}
  },
  rw fun_split,
  have h1: ∀ (x y : ℝ), f x - (j*(x^2)/2 + k*x^1)= f y - (j*(y^2)/2 + k*y^1),
  {
    apply is_const_of_deriv_eq_zero,
    {
      rw differentiable,
      intro x,
      specialize hf x,
      apply has_deriv_at.differentiable_at,
      apply has_deriv_at.sub,
      {
        convert hf,
      },
      apply has_deriv_at.add,
      apply has_deriv_at.div_const,
      apply has_deriv_at.const_mul,
      apply has_deriv_at_pow,
      apply has_deriv_at.const_mul,
      apply has_deriv_at_pow,
    },
    intro x,
    rw deriv_sub,
    rw sub_eq_zero,
    simp,
    rw has_deriv_at.deriv,
    specialize hf x,
    ring_nf,
    rw mul_comm,
    exact hf,
    apply has_deriv_at.differentiable_at,
    apply hf,
    finish,
  },
  ext z,
  specialize h1 z 0,
  apply eq_add_of_sub_eq',
  simpa using h1,
end

theorem constant_of_has_deriv_right_zero' {E : Type u_1} [normed_add_comm_group E] [normed_space ℝ E]
  {f : ℝ → E} {a b : ℝ} (hderiv : ∀ (x : ℝ), x ∈ set.Icc a b → has_deriv_at f 0 x) (h : a ≤ b) :
  f b = f a :=
begin
  apply constant_of_has_deriv_right_zero,
  apply has_deriv_at.continuous_on hderiv,
  intros,
  apply has_deriv_at.has_deriv_within_at,
  apply hderiv x (set.mem_Icc_of_Ico H),
  finish,
end

section vector_function
universes u_2 u_3
variables {E : Type u_2}  {𝕜 : Type u_3} [is_R_or_C 𝕜] [normed_add_comm_group E]
[normed_space 𝕜 E]

theorem antideriv
{f F G: 𝕜 → E} (hf : ∀ t, has_deriv_at F (f t) t)
(hg : ∀ t, has_deriv_at G (f t) t)
(hg' : G 0 = 0)
: F = λ t, G t + F(0) :=
begin
have h1: ∀(x y : 𝕜), F x - G x = F y - G y,
   {
    apply is_const_of_deriv_eq_zero,
    {
      rw differentiable,
      intro x,
      apply has_deriv_at.differentiable_at,
      apply has_deriv_at.sub (hf x),
      apply (hg x),},
    intro x,
    rw [deriv_sub, sub_eq_zero],
    rw has_deriv_at.deriv,
    simp,
    rw has_deriv_at.deriv,
    apply hf,
    apply hg,
    apply has_deriv_at.differentiable_at (hf x),
    apply has_deriv_at.differentiable_at (hg x),
  },
  funext z,
  specialize h1 z 0,
  rw hg' at h1,
  simp at h1,
  apply eq_add_of_sub_eq' h1,
end
lemma has_deriv_at_linear_no_pow
:
∀ x : 𝕜, has_deriv_at (λ y : 𝕜, y) 1 x
:=
begin
  intro,
  rw [show (λ y : 𝕜, y) = (λ y : 𝕜, y^1), by finish, show 1 = ↑(1:ℕ)*x^(1-1), by finish],
  apply has_deriv_at_pow 1,
end

theorem antideriv_const'
(f : 𝕜 → E) {k : E}
(hf : ∀ x, has_deriv_at f k x):
(f = λ (x : 𝕜), x•k + f 0) :=
begin
  apply antideriv hf,
  simp,
  intro,
  rw show k = (1:𝕜)•k, by simp,
  conv{
    find (_•(1:𝕜)•k) {simp,},
  },
  rw show (λ t, t•k) = λ t, ((λ t : 𝕜, t) t) • k, by {funext, simp},
  apply has_deriv_at.smul_const (has_deriv_at_linear_no_pow t) k,
  simp,
end

theorem antideriv_first_order_poly'
{k j: E}
(f : 𝕜 → E)
(hf : ∀ x:𝕜, has_deriv_at f (x•j+k) x) :
(f = λ x,(x^2/2)•j + x•k + (f 0)) :=
begin
  conv{
  find (_•k) {rw ← pow_one x,}
  },
  have h1: ∀ (x y : 𝕜), f x - ((x^2/2)•j + x^1•k)= f y - ((y^2/2)•j + y^1•k),
  {
    apply is_const_of_deriv_eq_zero,
    {
      rw differentiable,
      intro x,
      specialize hf x,
      apply has_deriv_at.differentiable_at,
      apply has_deriv_at.sub,
      {
        convert hf,
      },
      apply has_deriv_at.add,
      apply has_deriv_at.smul_const,
      apply has_deriv_at.div_const,
      apply has_deriv_at_pow,
      apply has_deriv_at.smul_const,
      apply has_deriv_at_pow,
    },
    intro x,
    rw deriv_sub,
    rw sub_eq_zero,
    simp,
    iterate 2 {rw deriv_smul_const},
    simp,
    ring_nf,
    rw has_deriv_at.deriv,
    exact hf x,
    iterate 2 {finish},
    apply has_deriv_at.differentiable_at,
    exact hf x,
    finish,
  },
  ext z,
  specialize h1 z 0,
  apply eq_add_of_sub_eq',
  simpa using h1,

end
end vector_function

/-! ### Analytical ODE solutions-/

open set filter
open_locale topological_space

lemma mem_of_le_of_forall_exists_lt {α : Type u_1} [conditionally_complete_linear_order α] [topological_space α] [order_topology α]
{a b : α} {s : set α} (hs : is_closed (s ∩ Icc a b))
  (hb : b ∈ s) (hab : a ≤ b) (hgt : ∀ x ∈ s ∩ Ioc a b, (s ∩ Ico a x).nonempty) :
  a ∈ s :=
begin
  let S := s ∩ Icc a b,
  replace hb : b ∈ S, from ⟨hb, right_mem_Icc.2 hab⟩,
  have Sbd : bdd_below S, from ⟨a, λ z hz, hz.2.1⟩,
  let c := Inf (s ∩ Icc a b),
  have c_mem : c ∈ S, from hs.cInf_mem ⟨_, hb⟩ Sbd,
  have c_le : a ≤ c, from le_cInf ⟨_, hb⟩ (λ x hx, hx.2.1),
  cases eq_or_lt_of_le c_le with hc hc, from hc.symm ▸ c_mem.1,
  exfalso,
  rcases hgt c ⟨c_mem.1, hc, c_mem.2.2⟩ with ⟨x, xs, ax, xc⟩,
  exact not_lt_of_le (cInf_le Sbd ⟨xs, le_trans (cInf_le Sbd hb) (le_of_lt xc), ax⟩)
end

lemma lmem_of_ge_of_forall_exists_gt {α : Type u_1} [conditionally_complete_linear_order α] [topological_space α] [order_topology α]
{a b : α} {s : set α} (hs : is_closed (s ∩ Icc a b))
  (ha : a ∈ s) (hab : a ≤ b) (hgt : ∀ x ∈ s ∩ Ico a b, (s ∩ Ioc x b).nonempty) :
  b ∈ s :=
begin
  let S := s ∩ Icc a b,
  replace ha : a ∈ S, from ⟨ha, left_mem_Icc.2 hab⟩,
  have Sbd : bdd_above S, from ⟨b, λ z hz, hz.2.2⟩,
  let c := Sup (s ∩ Icc a b),
  have c_mem : c ∈ S, from hs.cSup_mem ⟨_, ha⟩ Sbd,
  have c_le : c ≤ b, from cSup_le ⟨_, ha⟩ (λ x hx, hx.2.2),
  cases eq_or_lt_of_le c_le with hc hc, from hc ▸ c_mem.1,
  exfalso,
  rcases hgt c ⟨c_mem.1, c_mem.2.1, hc⟩ with ⟨x, xs, cx, xb⟩,
  exact not_lt_of_le (le_cSup Sbd ⟨xs, le_trans (le_cSup Sbd ha) (le_of_lt cx), xb⟩) cx
end
lemma Icc_subset_of_forall_exists_lt {α : Type u_1} [conditionally_complete_linear_order α] [topological_space α] [order_topology α]
{a b : α} {s : set α} (hs : is_closed (s ∩ Icc a b))
  (hb : b ∈ s) (hgt : ∀ x ∈ s ∩ Ioc a b, ∀ y ∈ Iio x, (s ∩ Ico x y).nonempty) :
  Icc a b ⊆ s :=
begin
  assume y hy,
  have : is_closed (s ∩ Icc y b),
  { suffices : s ∩ Icc y b = s ∩ Icc a b ∩ Icc y b,
    { rw this, apply is_closed.inter hs is_closed_Icc },
    rw [inter_assoc],
    congr,
    rw inter_comm,
    apply (inter_eq_self_of_subset_left $ Icc_subset_Icc_left hy.1).symm, },
  exact is_closed.mem_of_ge_of_forall_exists_gt this hb hy.2
    (λ x hx, hgt x ⟨hx.1, Ico_subset_Ico_right hy.2 hx.2⟩ y hx.2.2)
end

lemma image_le_of_liminf_slope_left_lt_deriv_boundary' {f f' : ℝ → ℝ} {a b : ℝ}
  (hf : continuous_on f (Icc a b))
  -- `hf'` actually says `liminf (f z - f x) / (z - x) ≤ f' x`
  (hf' : ∀ x ∈ Ioc a b, ∀ r, f' x < r → ∃ᶠ z in 𝓝[>] x, slope f x z < r)
  {B B' : ℝ → ℝ} (hb : f b ≤ B b) (hB : continuous_on B (Icc a b))
  (hB' : ∀ x ∈ Ioc a b, has_deriv_within_at B (B' x) (Iic x) x)
  (bound : ∀ x ∈ Ioc a b, f x = B x → f' x < B' x) :
  ∀ ⦃x⦄, x ∈ Icc a b → f x ≤ B x :=
begin
  change Icc a b ⊆ {x | f x ≤ B x},
  set s := {x | f x ≤ B x} ∩ Icc a b,
  have A : continuous_on (λ x, (f x, B x)) (Icc a b), from hf.prod hB,
  have : is_closed s,
  { simp only [s, inter_comm],
    exact A.preimage_closed_of_closed is_closed_Icc order_closed_topology.is_closed_le' },
  apply this.Icc_subset_of_forall_exists_gt,
  rintros x ⟨hxB : f x ≤ B x, xab⟩ y hy,
  cases hxB.lt_or_eq with hxB hxB,
  { -- If `f x < B x`, then all we need is continuity of both sides
    refine nonempty_of_mem (inter_mem _ (Ioc_mem_nhds_within_Ioi ⟨le_rfl, hy⟩)),
    have : ∀ᶠ x in 𝓝[Icc a b] x, f x < B x,
      from A x (Ico_subset_Icc_self xab)
        (is_open.mem_nhds (is_open_lt continuous_fst continuous_snd) hxB),
    have : ∀ᶠ x in 𝓝[>] x, f x < B x,
      from nhds_within_le_of_mem (Icc_mem_nhds_within_Ioi xab) this,
    exact this.mono (λ y, le_of_lt) },
  { rcases exists_between (bound x xab hxB) with ⟨r, hfr, hrB⟩,
    specialize hf' x xab r hfr,
    have HB : ∀ᶠ z in 𝓝[>] x, r < slope B x z,
      from (has_deriv_within_at_iff_tendsto_slope' $ lt_irrefl x).1
        (hB' x xab).Ioi_of_Ici (Ioi_mem_nhds hrB),
    obtain ⟨z, hfz, hzB, hz⟩ :
      ∃ z, slope f x z < r ∧ r < slope B x z ∧ z ∈ Ioc x y,
      from (hf'.and_eventually (HB.and (Ioc_mem_nhds_within_Ioi ⟨le_rfl, hy⟩))).exists,
    refine ⟨z, _, hz⟩,
    have := (hfz.trans hzB).le,
    rwa [slope_def_field, slope_def_field, div_le_div_right (sub_pos.2 hz.1), hxB,
      sub_le_sub_iff_right] at this }
end

lemma image_le_of_liminf_slope_left_le_deriv_boundary {f : ℝ → ℝ} {a b : ℝ} (hf : continuous_on f (set.Icc a b))
{B B' : ℝ → ℝ} (ha : f b ≤ B b) (hB : continuous_on B (set.Icc a b))
(hB' : ∀ (x : ℝ), x ∈ set.Ioc a b → has_deriv_within_at B (B' x) (set.Iic x) x)
(bound : ∀ (x : ℝ), x ∈ set.Ioc a b → ∀ (r : ℝ), B' x < r → (∃ᶠ (z : ℝ) in nhds_within x (set.Iio x), slope f x z < r))
⦃x : ℝ⦄ :
x ∈ set.Icc a b → f x ≤ B x :=
begin
  have Hr : ∀ x ∈ Icc a b, ∀ r > 0, f x ≤ B x + r * (x - b),
  { intros x hx r hr,
    apply image_le_of_liminf_slope_right_lt_deriv_boundary' hf bound,
    { rwa [sub_self, mul_zero, add_zero] },
    { exact hB.add (continuous_on_const.mul
        (continuous_id.continuous_on.sub continuous_on_const)) },
    { assume x hx,
      exact (hB' x hx).add (((has_deriv_within_at_id x (Ici x)).sub_const a).const_mul r) },
    { assume x hx _,
      rw [mul_one],
      exact (lt_add_iff_pos_right _).2 hr },
    exact hx },
  assume x hx,
  have : continuous_within_at (λ r, B x + r * (x - a)) (Ioi 0) 0,
    from continuous_within_at_const.add (continuous_within_at_id.mul continuous_within_at_const),
  convert continuous_within_at_const.closure_le _ this (Hr x hx); simp
end

lemma image_norm_le_of_norm_deriv_left_le_deriv_boundary'
{E : Type u_1} [normed_add_comm_group E] [normed_space ℝ E]
{f : ℝ → E} {a b : ℝ} {f' : ℝ → E}
(hf : continuous_on f (Icc a b))
(hf' : ∀ x ∈ Ioc a b, has_deriv_within_at f (- f' x) (Iic x) x)
{B B' : ℝ → ℝ} (ha : ∥f a∥ ≤ B a) (hB : continuous_on B (Icc a b))
(hB' : ∀ x ∈ Ioc a b, has_deriv_within_at B (B' x) (Iic x) x)
(bound : ∀ x ∈ Ioc a b, ∥f' x∥ ≤ B' x) :
∀ ⦃x⦄, x ∈ Icc a b → ∥f x∥ ≤ B x :=
image_le_of_liminf_slope_right_le_deriv_boundary (continuous_norm.comp_continuous_on hf) ha hB hB' $
  (λ x hx r hr, (hf' x hx).liminf_right_slope_norm_le (lt_of_le_of_lt (bound x hx) hr))

theorem image_norm_le_of_norm_deriv_left_le_deriv_boundary
{E : Type u_1} [normed_add_comm_group E] [normed_space ℝ E]
{f : ℝ → E} {a b : ℝ}{f' : ℝ → E}
(hf : continuous_on f (Icc a b))
(hf' : ∀ x ∈ Ioc a b, has_deriv_within_at f (-f' x) (Iic x) x)
{B B' : ℝ → ℝ} (ha : ∥f a∥ ≤ B a) (hB : ∀ x, has_deriv_at B (B' x) x)
(bound : ∀ x ∈ Ioc a b, ∥f' x∥ ≤ B' x) :
∀ ⦃x⦄, x ∈ Icc a b → ∥f x∥ ≤ B x :=
image_norm_le_of_norm_deriv_right_le_deriv_boundary' hf hf' ha
  (λ x hx, (hB x).continuous_at.continuous_within_at)
  (λ x hx, (hB x).has_deriv_within_at) bound

theorem norm_image_sub_le_of_norm_deriv_left_le_segment
{E : Type u_1} [normed_add_comm_group E] [normed_space ℝ E]
{f : ℝ → E} {a b : ℝ} {f' : ℝ → E} {C : ℝ}
(hf : continuous_on f (set.Icc a b))
(hf' : ∀ x ∈ set.Ioc a b, has_deriv_within_at f (f' x) (set.Iic x) x)
(bound : ∀x ∈ set.Ioc a b, ∥f' x∥ ≤ C) :
∀ x ∈ set.Icc a b, ∥f b - f x∥ ≤ C * (b - x) :=
begin
  let g := λ x, f b - f x,
  have hg : continuous_on g (set.Icc a b),
  { assume x hx,
    simp [g],
    apply continuous_on.sub (continuous_on_const) hf x hx,},
  have hg' : ∀ x ∈ set.Ioc a b, has_deriv_within_at g (- f' x) (set.Iic x) x,
  { assume x hx,
    simp [g, ← zero_sub],
    apply has_deriv_within_at.sub (has_deriv_within_at_const _ _ _) (hf' x hx),},
  let B := λ x, C * (b - x),
  have hB : ∀ x, has_deriv_at B (- C) x,
  { assume x,
    simpa using (has_deriv_at_const x C).mul ((has_deriv_at_const x b).sub (has_deriv_at_id x))
     },
  convert image_norm_le_of_norm_deriv_right_le_deriv_boundary hg hg' _ hB bound,
  simp only [g, B], rw [sub_self, norm_zero, sub_self, mul_zero]
end
theorem constant_of_has_deriv_left_zero
{E : Type u_1} [normed_add_comm_group E] [normed_space ℝ E]
{f : ℝ → E} {a b : ℝ} (hcont : continuous_on f (set.Icc a b))
(hderiv : ∀ x ∈ set.Ioc a b, has_deriv_within_at f 0 (set.Iic x) x) :
∀ x ∈ set.Icc a b, f x = f b :=
-- by simpa only [zero_mul, norm_le_zero_iff, sub_eq_zero] using
--   λ x hx, norm_image_sub_le_of_norm_deriv_left_le_segment
--     hcont hderiv (λ y hy, by rw norm_le_zero_iff) x hx
begin
  assume x hx,
  simpa only [← zero_mul, norm_le_zero_iff, sub_eq_zero] using
  norm_image_sub_le_of_norm_deriv_left_le_segment hcont hderiv (λ y hy, by rw norm_le_zero_iff) x hx
end
theorem antideriv_self
{k: ℝ}
(f : ℝ → ℝ)
(hf : ∀ x, has_deriv_at f (k*(f x)) x) :
(f = λ x, (f 0)*real.exp(k*x)) :=
begin
  have : ∀ x, has_deriv_at (λ x, real.exp (- k * x) * f x) 0 x,
  { intros x,
    convert (has_deriv_at_mul_const k).neg.exp.mul (hf x),
    { ext x,
      ring_nf },
    { ring_nf } },
  ext x,
  have hx : x ≤ 0 ∨ 0 ≤ x := by exact le_total x 0,
  cases hx with hx hx',
  swap,
  have : real.exp (-k * x) * f x = f 0,
  { convert @constant_of_has_deriv_right_zero _ _ _ _ 0 x _ (λ y hy, (this y).has_deriv_within_at) x _,
    { simp },
    { intros x hx,
      exact (this x).continuous_at.continuous_within_at },
    { rw set.right_mem_Icc,
      exact hx' } },
  convert congr_arg ((*) (real.exp (k * x))) this using 1,
  { rw [← mul_assoc, ← real.exp_add],
    ring_nf,
    simp, },
  { ring, },
  have : real.exp (-k * x) * f x = f 0,
  { convert @constant_of_has_deriv_right_zero' _ _ _ _ x 0 _ (λ y hy, (this y).has_deriv_within_at) x _,
    { simp },
    { intros x hx,
      exact (this x).continuous_at.continuous_within_at },
    { rw set.right_mem_Icc,
      exact hx' } },

end


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.shapes.zero
import Mathlib.PostPort

universes v u l

namespace Mathlib

/-!
# Shift

A `shift` on a category is nothing more than an automorphism of the category. An example to
keep in mind might be the category of complexes ⋯ → C_{n-1} → C_n → C_{n+1} → ⋯ with the shift
operator re-indexing the terms, so the degree `n` term of `shift C` would be the degree `n+1`
term of `C`.

-/

namespace category_theory

/-- A category has a shift, or translation, if it is equipped with an automorphism. -/
class has_shift (C : Type u) [category C] where
  shift : C ≌ C

/-- The shift autoequivalence, moving objects and morphisms 'up'. -/
def shift (C : Type u) [category C] [has_shift C] : C ≌ C := has_shift.shift

-- Any better notational suggestions?

@[simp] theorem shift_zero_eq_zero (C : Type u) [category C] [has_shift C]
    [limits.has_zero_morphisms C] (X : C) (Y : C) (n : ℤ) :
    functor.map (equivalence.functor (shift C ^ n)) 0 = 0 :=
  limits.equivalence_preserves_zero_morphisms C (shift C ^ n) X Y

end Mathlib


/-
Copyright (c) 2020 Joseph Myers. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joseph Myers
-/
import geometry.euclidean.sphere.basic
import linear_algebra.affine_space.finite_dimensional
import tactic.derive_fintype

/-!
# Circumcenter and circumradius

This file proves some lemmas on points equidistant from a set of
points, and defines the circumradius and circumcenter of a simplex.
There are also some definitions for use in calculations where it is
convenient to work with affine combinations of vertices together with
the circumcenter.

## Main definitions

* `circumcenter` and `circumradius` are the circumcenter and
  circumradius of a simplex.

## References

* https://en.wikipedia.org/wiki/Circumscribed_circle

-/

noncomputable theory
open_locale big_operators
open_locale classical
open_locale real_inner_product_space

namespace euclidean_geometry

variables {V : Type*} {P : Type*}
  [normed_add_comm_group V] [inner_product_space ℝ V] [metric_space P] [normed_add_torsor V P]
include V

open affine_subspace

/-- `p` is equidistant from two points in `s` if and only if its
`orthogonal_projection` is. -/
lemma dist_eq_iff_dist_orthogonal_projection_eq {s : affine_subspace ℝ P} [nonempty s]
  [complete_space s.direction] {p1 p2 : P} (p3 : P) (hp1 : p1 ∈ s) (hp2 : p2 ∈ s) :
  dist p1 p3 = dist p2 p3 ↔
    dist p1 (orthogonal_projection s p3) = dist p2 (orthogonal_projection s p3) :=
begin
  rw [←mul_self_inj_of_nonneg dist_nonneg dist_nonneg,
      ←mul_self_inj_of_nonneg dist_nonneg dist_nonneg,
      dist_sq_eq_dist_orthogonal_projection_sq_add_dist_orthogonal_projection_sq
        p3 hp1,
      dist_sq_eq_dist_orthogonal_projection_sq_add_dist_orthogonal_projection_sq
        p3 hp2],
  simp
end

/-- `p` is equidistant from a set of points in `s` if and only if its
`orthogonal_projection` is. -/
lemma dist_set_eq_iff_dist_orthogonal_projection_eq {s : affine_subspace ℝ P} [nonempty s]
  [complete_space s.direction] {ps : set P} (hps : ps ⊆ s) (p : P) :
  set.pairwise ps (λ p1 p2, dist p1 p = dist p2 p) ↔
    (set.pairwise ps (λ p1 p2, dist p1 (orthogonal_projection s p) =
      dist p2 (orthogonal_projection s p))) :=
⟨λ h p1 hp1 p2 hp2 hne,
  (dist_eq_iff_dist_orthogonal_projection_eq p (hps hp1) (hps hp2)).1 (h hp1 hp2 hne),
λ h p1 hp1 p2 hp2 hne,
  (dist_eq_iff_dist_orthogonal_projection_eq p (hps hp1) (hps hp2)).2 (h hp1 hp2 hne)⟩

/-- There exists `r` such that `p` has distance `r` from all the
points of a set of points in `s` if and only if there exists (possibly
different) `r` such that its `orthogonal_projection` has that distance
from all the points in that set. -/
lemma exists_dist_eq_iff_exists_dist_orthogonal_projection_eq {s : affine_subspace ℝ P} [nonempty s]
  [complete_space s.direction] {ps : set P} (hps : ps ⊆ s) (p : P) :
  (∃ r, ∀ p1 ∈ ps, dist p1 p = r) ↔
    ∃ r, ∀ p1 ∈ ps, dist p1 ↑(orthogonal_projection s p) = r :=
begin
  have h := dist_set_eq_iff_dist_orthogonal_projection_eq hps p,
  simp_rw set.pairwise_eq_iff_exists_eq at h,
  exact h
end

/-- The induction step for the existence and uniqueness of the
circumcenter.  Given a nonempty set of points in a nonempty affine
subspace whose direction is complete, such that there is a unique
(circumcenter, circumradius) pair for those points in that subspace,
and a point `p` not in that subspace, there is a unique (circumcenter,
circumradius) pair for the set with `p` added, in the span of the
subspace with `p` added. -/
lemma exists_unique_dist_eq_of_insert {s : affine_subspace ℝ P}
  [complete_space s.direction] {ps : set P} (hnps : ps.nonempty) {p : P}
  (hps : ps ⊆ s) (hp : p ∉ s)
  (hu : ∃! cs : sphere P, cs.center ∈ s ∧ ps ⊆ (cs : set P)) :
  ∃! cs₂ : sphere P, cs₂.center ∈ affine_span ℝ (insert p (s : set P)) ∧
    (insert p ps) ⊆ (cs₂ : set P) :=
begin
  haveI : nonempty s := set.nonempty.to_subtype (hnps.mono hps),
  rcases hu with ⟨⟨cc, cr⟩, ⟨hcc, hcr⟩, hcccru⟩,
  simp only at hcc hcr hcccru,
  let x := dist cc (orthogonal_projection s p),
  let y := dist p (orthogonal_projection s p),
  have hy0 : y ≠ 0 := dist_orthogonal_projection_ne_zero_of_not_mem hp,
  let ycc₂ := (x * x + y * y - cr * cr) / (2 * y),
  let cc₂ := (ycc₂ / y) • (p -ᵥ orthogonal_projection s p : V) +ᵥ cc,
  let cr₂ := real.sqrt (cr * cr + ycc₂ * ycc₂),
  use ⟨cc₂, cr₂⟩,
  simp only,
  have hpo : p = (1 : ℝ) • (p -ᵥ orthogonal_projection s p : V) +ᵥ orthogonal_projection s p,
  { simp },
  split,
  { split,
    { refine vadd_mem_of_mem_direction _ (mem_affine_span ℝ (set.mem_insert_of_mem _ hcc)),
      rw direction_affine_span,
      exact submodule.smul_mem _ _
        (vsub_mem_vector_span ℝ (set.mem_insert _ _)
                                (set.mem_insert_of_mem _ (orthogonal_projection_mem _))) },
    { intros p1 hp1,
      rw [sphere.mem_coe, mem_sphere, ←mul_self_inj_of_nonneg dist_nonneg (real.sqrt_nonneg _),
          real.mul_self_sqrt (add_nonneg (mul_self_nonneg _) (mul_self_nonneg _))],
      cases hp1,
      { rw hp1,
        rw [hpo,
            dist_sq_smul_orthogonal_vadd_smul_orthogonal_vadd
              (orthogonal_projection_mem p) hcc _ _
              (vsub_orthogonal_projection_mem_direction_orthogonal s p),
            ←dist_eq_norm_vsub V p, dist_comm _ cc],
        field_simp [hy0],
        ring },
      { rw [dist_sq_eq_dist_orthogonal_projection_sq_add_dist_orthogonal_projection_sq
               _ (hps hp1),
            orthogonal_projection_vadd_smul_vsub_orthogonal_projection _ _ hcc, subtype.coe_mk,
            dist_of_mem_subset_mk_sphere hp1 hcr,
            dist_eq_norm_vsub V cc₂ cc, vadd_vsub, norm_smul, ←dist_eq_norm_vsub V,
            real.norm_eq_abs, abs_div, abs_of_nonneg dist_nonneg, div_mul_cancel _ hy0,
            abs_mul_abs_self] } } },
  { rintros ⟨cc₃, cr₃⟩ ⟨hcc₃, hcr₃⟩,
    simp only at hcc₃ hcr₃,
    obtain ⟨t₃, cc₃', hcc₃', hcc₃''⟩ :
      ∃ (r : ℝ) (p0 : P) (hp0 : p0 ∈ s), cc₃ = r • (p -ᵥ ↑((orthogonal_projection s) p)) +ᵥ p0,
    { rwa mem_affine_span_insert_iff (orthogonal_projection_mem p) at hcc₃ },
    have hcr₃' : ∃ r, ∀ p1 ∈ ps, dist p1 cc₃ = r :=
      ⟨cr₃, λ p1 hp1, dist_of_mem_subset_mk_sphere (set.mem_insert_of_mem _ hp1) hcr₃⟩,
    rw [exists_dist_eq_iff_exists_dist_orthogonal_projection_eq hps cc₃, hcc₃'',
      orthogonal_projection_vadd_smul_vsub_orthogonal_projection _ _ hcc₃'] at hcr₃',
    cases hcr₃' with cr₃' hcr₃',
    have hu := hcccru ⟨cc₃', cr₃'⟩,
    simp only at hu,
    replace hu := hu ⟨hcc₃', hcr₃'⟩,
    cases hu with hucc hucr,
    substs hucc hucr,
    have hcr₃val : cr₃ = real.sqrt (cr₃' * cr₃' + (t₃ * y) * (t₃ * y)),
    { cases hnps with p0 hp0,
      have h' : ↑(⟨cc₃', hcc₃'⟩ : s) = cc₃' := rfl,
      rw [←dist_of_mem_subset_mk_sphere (set.mem_insert_of_mem _ hp0) hcr₃, hcc₃'',
          ←mul_self_inj_of_nonneg dist_nonneg (real.sqrt_nonneg _),
          real.mul_self_sqrt (add_nonneg (mul_self_nonneg _) (mul_self_nonneg _)),
          dist_sq_eq_dist_orthogonal_projection_sq_add_dist_orthogonal_projection_sq
            _ (hps hp0),
          orthogonal_projection_vadd_smul_vsub_orthogonal_projection _ _ hcc₃', h',
          dist_of_mem_subset_mk_sphere hp0 hcr,
          dist_eq_norm_vsub V _ cc₃', vadd_vsub, norm_smul, ←dist_eq_norm_vsub V p,
          real.norm_eq_abs, ←mul_assoc, mul_comm _ (|t₃|), ←mul_assoc, abs_mul_abs_self],
      ring },
    replace hcr₃ := dist_of_mem_subset_mk_sphere (set.mem_insert _ _) hcr₃,
    rw [hpo, hcc₃'', hcr₃val, ←mul_self_inj_of_nonneg dist_nonneg (real.sqrt_nonneg _),
        dist_sq_smul_orthogonal_vadd_smul_orthogonal_vadd
          (orthogonal_projection_mem p) hcc₃' _ _
          (vsub_orthogonal_projection_mem_direction_orthogonal s p),
        dist_comm, ←dist_eq_norm_vsub V p,
        real.mul_self_sqrt (add_nonneg (mul_self_nonneg _) (mul_self_nonneg _))] at hcr₃,
    change x * x + _ * (y * y) = _ at hcr₃,
    rw [(show x * x + (1 - t₃) * (1 - t₃) * (y * y) =
           x * x + y * y - 2 * y * (t₃ * y) + t₃ * y * (t₃ * y), by ring), add_left_inj] at hcr₃,
    have ht₃ : t₃ = ycc₂ / y,
    { field_simp [←hcr₃, hy0],
      ring },
    subst ht₃,
    change cc₃ = cc₂ at hcc₃'',
    congr',
    rw hcr₃val,
    congr' 2,
    field_simp [hy0],
    ring }
end

/-- Given a finite nonempty affinely independent family of points,
there is a unique (circumcenter, circumradius) pair for those points
in the affine subspace they span. -/
lemma _root_.affine_independent.exists_unique_dist_eq {ι : Type*} [hne : nonempty ι] [finite ι]
    {p : ι → P} (ha : affine_independent ℝ p) :
  ∃! cs : sphere P, cs.center ∈ affine_span ℝ (set.range p) ∧ set.range p ⊆ (cs : set P) :=
begin
  casesI nonempty_fintype ι,
  unfreezingI { induction hn : fintype.card ι with m hm generalizing ι },
  { exfalso,
    have h := fintype.card_pos_iff.2 hne,
    rw hn at h,
    exact lt_irrefl 0 h },
  { cases m,
    { rw fintype.card_eq_one_iff at hn,
      cases hn with i hi,
      haveI : unique ι := ⟨⟨i⟩, hi⟩,
      use ⟨p i, 0⟩,
      simp only [set.range_unique, affine_subspace.mem_affine_span_singleton],
      split,
      { simp_rw [hi default, set.singleton_subset_iff, sphere.mem_coe, mem_sphere, dist_self],
        exact ⟨rfl, rfl⟩ },
      { rintros ⟨cc, cr⟩,
        simp only,
        rintros ⟨rfl, hdist⟩,
        simp_rw [set.singleton_subset_iff, sphere.mem_coe, mem_sphere, dist_self] at hdist,
        rw [hi default, hdist],
        exact ⟨rfl, rfl⟩ } },
    { have i := hne.some,
      let ι2 := {x // x ≠ i},
      have hc : fintype.card ι2 = m + 1,
      { rw fintype.card_of_subtype (finset.univ.filter (λ x, x ≠ i)),
        { rw finset.filter_not,
          simp_rw eq_comm,
          rw [finset.filter_eq, if_pos (finset.mem_univ _),
              finset.card_sdiff (finset.subset_univ _), finset.card_singleton, finset.card_univ,
              hn],
          simp },
        { simp } },
      haveI : nonempty ι2 := fintype.card_pos_iff.1 (hc.symm ▸ nat.zero_lt_succ _),
      have ha2 : affine_independent ℝ (λ i2 : ι2, p i2) := ha.subtype _,
      replace hm := hm ha2 _ hc,
      have hr : set.range p = insert (p i) (set.range (λ i2 : ι2, p i2)),
      { change _ = insert _ (set.range (λ i2 : {x | x ≠ i}, p i2)),
        rw [←set.image_eq_range, ←set.image_univ, ←set.image_insert_eq],
        congr' with j,
        simp [classical.em] },
      rw [hr, ←affine_span_insert_affine_span],
      refine exists_unique_dist_eq_of_insert
        (set.range_nonempty _)
        (subset_span_points ℝ _)
        _
        hm,
      convert ha.not_mem_affine_span_diff i set.univ,
      change set.range (λ i2 : {x | x ≠ i}, p i2) = _,
      rw ←set.image_eq_range,
      congr' with j, simp, refl } }
end

end euclidean_geometry

namespace affine

namespace simplex

open finset affine_subspace euclidean_geometry

variables {V : Type*} {P : Type*}
  [normed_add_comm_group V] [inner_product_space ℝ V] [metric_space P] [normed_add_torsor V P]
include V

/-- The circumsphere of a simplex. -/
def circumsphere {n : ℕ} (s : simplex ℝ P n) : sphere P :=
s.independent.exists_unique_dist_eq.some

/-- The property satisfied by the circumsphere. -/
lemma circumsphere_unique_dist_eq {n : ℕ} (s : simplex ℝ P n) :
  (s.circumsphere.center ∈ affine_span ℝ (set.range s.points) ∧
    set.range s.points ⊆ s.circumsphere) ∧
  (∀ cs : sphere P, (cs.center ∈ affine_span ℝ (set.range s.points) ∧
    set.range s.points ⊆ cs → cs = s.circumsphere)) :=
s.independent.exists_unique_dist_eq.some_spec

/-- The circumcenter of a simplex. -/
def circumcenter {n : ℕ} (s : simplex ℝ P n) : P :=
s.circumsphere.center

/-- The circumradius of a simplex. -/
def circumradius {n : ℕ} (s : simplex ℝ P n) : ℝ :=
s.circumsphere.radius

/-- The center of the circumsphere is the circumcenter. -/
@[simp] lemma circumsphere_center {n : ℕ} (s : simplex ℝ P n) :
  s.circumsphere.center = s.circumcenter :=
rfl

/-- The radius of the circumsphere is the circumradius. -/
@[simp] lemma circumsphere_radius {n : ℕ} (s : simplex ℝ P n) :
  s.circumsphere.radius = s.circumradius :=
rfl

/-- The circumcenter lies in the affine span. -/
lemma circumcenter_mem_affine_span {n : ℕ} (s : simplex ℝ P n) :
  s.circumcenter ∈ affine_span ℝ (set.range s.points) :=
s.circumsphere_unique_dist_eq.1.1

/-- All points have distance from the circumcenter equal to the
circumradius. -/
@[simp] lemma dist_circumcenter_eq_circumradius {n : ℕ} (s : simplex ℝ P n) (i : fin (n + 1)) :
  dist (s.points i) s.circumcenter = s.circumradius :=
dist_of_mem_subset_sphere (set.mem_range_self _) s.circumsphere_unique_dist_eq.1.2

/-- All points lie in the circumsphere. -/
lemma mem_circumsphere {n : ℕ} (s : simplex ℝ P n) (i : fin (n + 1)) :
  s.points i ∈ s.circumsphere :=
s.dist_circumcenter_eq_circumradius i

/-- All points have distance to the circumcenter equal to the
circumradius. -/
@[simp] lemma dist_circumcenter_eq_circumradius' {n : ℕ} (s : simplex ℝ P n) :
  ∀ i, dist s.circumcenter (s.points i) = s.circumradius :=
begin
  intro i,
  rw dist_comm,
  exact dist_circumcenter_eq_circumradius _ _
end

/-- Given a point in the affine span from which all the points are
equidistant, that point is the circumcenter. -/
lemma eq_circumcenter_of_dist_eq {n : ℕ} (s : simplex ℝ P n) {p : P}
    (hp : p ∈ affine_span ℝ (set.range s.points)) {r : ℝ} (hr : ∀ i, dist (s.points i) p = r) :
  p = s.circumcenter :=
begin
  have h := s.circumsphere_unique_dist_eq.2 ⟨p, r⟩,
  simp only [hp, hr, forall_const, eq_self_iff_true, subset_sphere, sphere.ext_iff,
             set.forall_range_iff, mem_sphere, true_and] at h,
  exact h.1
end

/-- Given a point in the affine span from which all the points are
equidistant, that distance is the circumradius. -/
lemma eq_circumradius_of_dist_eq {n : ℕ} (s : simplex ℝ P n) {p : P}
    (hp : p ∈ affine_span ℝ (set.range s.points)) {r : ℝ} (hr : ∀ i, dist (s.points i) p = r) :
  r = s.circumradius :=
begin
  have h := s.circumsphere_unique_dist_eq.2 ⟨p, r⟩,
  simp only [hp, hr, forall_const, eq_self_iff_true, subset_sphere, sphere.ext_iff,
             set.forall_range_iff, mem_sphere, true_and] at h,
  exact h.2
end

/-- The circumradius is non-negative. -/
lemma circumradius_nonneg {n : ℕ} (s : simplex ℝ P n) : 0 ≤ s.circumradius :=
s.dist_circumcenter_eq_circumradius 0 ▸ dist_nonneg

/-- The circumradius of a simplex with at least two points is
positive. -/
lemma circumradius_pos {n : ℕ} (s : simplex ℝ P (n + 1)) : 0 < s.circumradius :=
begin
  refine lt_of_le_of_ne s.circumradius_nonneg _,
  intro h,
  have hr := s.dist_circumcenter_eq_circumradius,
  simp_rw [←h, dist_eq_zero] at hr,
  have h01 := s.independent.injective.ne (dec_trivial : (0 : fin (n + 2)) ≠ 1),
  simpa [hr] using h01
end

/-- The circumcenter of a 0-simplex equals its unique point. -/
lemma circumcenter_eq_point (s : simplex ℝ P 0) (i : fin 1) :
  s.circumcenter = s.points i :=
begin
  have h := s.circumcenter_mem_affine_span,
  rw [set.range_unique, mem_affine_span_singleton] at h,
  rw h,
  congr
end

/-- The circumcenter of a 1-simplex equals its centroid. -/
lemma circumcenter_eq_centroid (s : simplex ℝ P 1) :
  s.circumcenter = finset.univ.centroid ℝ s.points :=
begin
  have hr : set.pairwise set.univ
    (λ i j : fin 2, dist (s.points i) (finset.univ.centroid ℝ s.points) =
                    dist (s.points j) (finset.univ.centroid ℝ s.points)),
  { intros i hi j hj hij,
    rw [finset.centroid_pair_fin, dist_eq_norm_vsub V (s.points i),
        dist_eq_norm_vsub V (s.points j), vsub_vadd_eq_vsub_sub, vsub_vadd_eq_vsub_sub,
        ←one_smul ℝ (s.points i -ᵥ s.points 0), ←one_smul ℝ (s.points j -ᵥ s.points 0)],
    fin_cases i; fin_cases j; simp [-one_smul, ←sub_smul]; norm_num },
  rw set.pairwise_eq_iff_exists_eq at hr,
  cases hr with r hr,
  exact (s.eq_circumcenter_of_dist_eq
          (centroid_mem_affine_span_of_card_eq_add_one ℝ _ (finset.card_fin 2))
          (λ i, hr i (set.mem_univ _))).symm
end

/-- Reindexing a simplex along an `equiv` of index types does not change the circumsphere. -/
@[simp] lemma circumsphere_reindex {m n : ℕ} (s : simplex ℝ P m) (e : fin (m + 1) ≃ fin (n + 1)) :
  (s.reindex e).circumsphere = s.circumsphere :=
begin
  refine s.circumsphere_unique_dist_eq.2 _ ⟨_, _⟩; rw ←s.reindex_range_points e,
  { exact (s.reindex e).circumsphere_unique_dist_eq.1.1 },
  { exact (s.reindex e).circumsphere_unique_dist_eq.1.2 }
end

/-- Reindexing a simplex along an `equiv` of index types does not change the circumcenter. -/
@[simp] lemma circumcenter_reindex {m n : ℕ} (s : simplex ℝ P m) (e : fin (m + 1) ≃ fin (n + 1)) :
  (s.reindex e).circumcenter = s.circumcenter :=
by simp_rw [←circumcenter, circumsphere_reindex]

/-- Reindexing a simplex along an `equiv` of index types does not change the circumradius. -/
@[simp] lemma circumradius_reindex {m n : ℕ} (s : simplex ℝ P m) (e : fin (m + 1) ≃ fin (n + 1)) :
  (s.reindex e).circumradius = s.circumradius :=
by simp_rw [←circumradius, circumsphere_reindex]

local attribute [instance] affine_subspace.to_add_torsor

/-- The orthogonal projection of a point `p` onto the hyperplane spanned by the simplex's points. -/
def orthogonal_projection_span {n : ℕ} (s : simplex ℝ P n) :
  P →ᵃ[ℝ] affine_span ℝ (set.range s.points) :=
orthogonal_projection (affine_span ℝ (set.range s.points))

/-- Adding a vector to a point in the given subspace, then taking the
orthogonal projection, produces the original point if the vector is a
multiple of the result of subtracting a point's orthogonal projection
from that point. -/
lemma orthogonal_projection_vadd_smul_vsub_orthogonal_projection
  {n : ℕ} (s : simplex ℝ P n) {p1 : P} (p2 : P) (r : ℝ)
  (hp : p1 ∈ affine_span ℝ (set.range s.points)) :
  s.orthogonal_projection_span (r • (p2 -ᵥ s.orthogonal_projection_span p2 : V) +ᵥ p1) =
    ⟨p1, hp⟩ :=
orthogonal_projection_vadd_smul_vsub_orthogonal_projection _ _ _

lemma coe_orthogonal_projection_vadd_smul_vsub_orthogonal_projection {n : ℕ} {r₁ : ℝ}
  (s : simplex ℝ P n) {p p₁o : P} (hp₁o : p₁o ∈ affine_span ℝ (set.range s.points)) :
  ↑(s.orthogonal_projection_span (r₁ • (p -ᵥ ↑(s.orthogonal_projection_span p)) +ᵥ p₁o)) = p₁o :=
congr_arg coe (orthogonal_projection_vadd_smul_vsub_orthogonal_projection _ _ _ hp₁o)

lemma dist_sq_eq_dist_orthogonal_projection_sq_add_dist_orthogonal_projection_sq {n : ℕ}
  (s : simplex ℝ P n) {p1 : P}
  (p2 : P) (hp1 : p1 ∈ affine_span ℝ (set.range s.points)) :
  dist p1 p2 * dist p1 p2 =
    dist p1 (s.orthogonal_projection_span p2) * dist p1 (s.orthogonal_projection_span p2) +
    dist p2 (s.orthogonal_projection_span p2) * dist p2 (s.orthogonal_projection_span p2) :=
begin
  rw [pseudo_metric_space.dist_comm p2 _, dist_eq_norm_vsub V p1 _, dist_eq_norm_vsub V p1 _,
    dist_eq_norm_vsub V _ p2, ← vsub_add_vsub_cancel p1 (s.orthogonal_projection_span p2) p2,
    norm_add_sq_eq_norm_sq_add_norm_sq_iff_real_inner_eq_zero],
  exact submodule.inner_right_of_mem_orthogonal
    (vsub_orthogonal_projection_mem_direction p2 hp1)
    (orthogonal_projection_vsub_mem_direction_orthogonal _ p2),
end

lemma dist_circumcenter_sq_eq_sq_sub_circumradius {n : ℕ} {r : ℝ} (s : simplex ℝ P n)
  {p₁ : P}
  (h₁ : ∀ (i : fin (n + 1)), dist (s.points i) p₁ = r)
  (h₁' : ↑((s.orthogonal_projection_span) p₁) = s.circumcenter)
  (h : s.points 0 ∈ affine_span ℝ (set.range s.points)) :
  dist p₁ s.circumcenter * dist p₁ s.circumcenter = r * r - s.circumradius * s.circumradius :=
begin
  rw [dist_comm, ←h₁ 0,
    s.dist_sq_eq_dist_orthogonal_projection_sq_add_dist_orthogonal_projection_sq p₁ h],
  simp only [h₁', dist_comm p₁, add_sub_cancel', simplex.dist_circumcenter_eq_circumradius],
end

/-- If there exists a distance that a point has from all vertices of a
simplex, the orthogonal projection of that point onto the subspace
spanned by that simplex is its circumcenter.  -/
lemma orthogonal_projection_eq_circumcenter_of_exists_dist_eq {n : ℕ} (s : simplex ℝ P n)
  {p : P} (hr : ∃ r, ∀ i, dist (s.points i) p = r) :
  ↑(s.orthogonal_projection_span p) = s.circumcenter :=
begin
  change ∃ r : ℝ, ∀ i, (λ x, dist x p = r) (s.points i) at hr,
  conv at hr { congr, funext, rw ←set.forall_range_iff },
  rw exists_dist_eq_iff_exists_dist_orthogonal_projection_eq (subset_affine_span ℝ _) p at hr,
  cases hr with r hr,
  exact s.eq_circumcenter_of_dist_eq
    (orthogonal_projection_mem p) (λ i, hr _ (set.mem_range_self i)),
end

/-- If a point has the same distance from all vertices of a simplex,
the orthogonal projection of that point onto the subspace spanned by
that simplex is its circumcenter.  -/
lemma orthogonal_projection_eq_circumcenter_of_dist_eq {n : ℕ} (s : simplex ℝ P n) {p : P}
  {r : ℝ} (hr : ∀ i, dist (s.points i) p = r) :
  ↑(s.orthogonal_projection_span p) = s.circumcenter :=
s.orthogonal_projection_eq_circumcenter_of_exists_dist_eq ⟨r, hr⟩

/-- The orthogonal projection of the circumcenter onto a face is the
circumcenter of that face. -/
lemma orthogonal_projection_circumcenter {n : ℕ} (s : simplex ℝ P n) {fs : finset (fin (n + 1))}
  {m : ℕ} (h : fs.card = m + 1) :
  ↑((s.face h).orthogonal_projection_span s.circumcenter) = (s.face h).circumcenter :=
begin
  have hr : ∃ r, ∀ i, dist ((s.face h).points i) s.circumcenter = r,
  { use s.circumradius,
    simp [face_points] },
  exact orthogonal_projection_eq_circumcenter_of_exists_dist_eq _ hr
end

/-- Two simplices with the same points have the same circumcenter. -/
lemma circumcenter_eq_of_range_eq {n : ℕ} {s₁ s₂ : simplex ℝ P n}
  (h : set.range s₁.points = set.range s₂.points) : s₁.circumcenter = s₂.circumcenter :=
begin
  have hs : s₁.circumcenter ∈ affine_span ℝ (set.range s₂.points) :=
    h ▸ s₁.circumcenter_mem_affine_span,
  have hr : ∀ i, dist (s₂.points i) s₁.circumcenter = s₁.circumradius,
  { intro i,
    have hi : s₂.points i ∈ set.range s₂.points := set.mem_range_self _,
    rw [←h, set.mem_range] at hi,
    rcases hi with ⟨j, hj⟩,
    rw [←hj, s₁.dist_circumcenter_eq_circumradius j] },
  exact s₂.eq_circumcenter_of_dist_eq hs hr
end

omit V

/-- An index type for the vertices of a simplex plus its circumcenter.
This is for use in calculations where it is convenient to work with
affine combinations of vertices together with the circumcenter.  (An
equivalent form sometimes used in the literature is placing the
circumcenter at the origin and working with vectors for the vertices.) -/
@[derive fintype]
inductive points_with_circumcenter_index (n : ℕ)
| point_index : fin (n + 1) → points_with_circumcenter_index
| circumcenter_index : points_with_circumcenter_index

open points_with_circumcenter_index

instance points_with_circumcenter_index_inhabited (n : ℕ) :
  inhabited (points_with_circumcenter_index n) :=
⟨circumcenter_index⟩

/-- `point_index` as an embedding. -/
def point_index_embedding (n : ℕ) : fin (n + 1) ↪ points_with_circumcenter_index n :=
⟨λ i, point_index i, λ _ _ h, by injection h⟩

/-- The sum of a function over `points_with_circumcenter_index`. -/
lemma sum_points_with_circumcenter {α : Type*} [add_comm_monoid α] {n : ℕ}
  (f : points_with_circumcenter_index n → α) :
  ∑ i, f i = (∑ (i : fin (n + 1)), f (point_index i)) + f circumcenter_index :=
begin
  have h : univ = insert circumcenter_index (univ.map (point_index_embedding n)),
  { ext x,
    refine ⟨λ h, _, λ _, mem_univ _⟩,
    cases x with i,
    { exact mem_insert_of_mem (mem_map_of_mem _ (mem_univ i)) },
    { exact mem_insert_self _ _ } },
  change _ = ∑ i, f (point_index_embedding n i) + _,
  rw [add_comm, h, ←sum_map, sum_insert],
  simp_rw [finset.mem_map, not_exists],
  intros x hx h,
  injection h
end

include V

/-- The vertices of a simplex plus its circumcenter. -/
def points_with_circumcenter {n : ℕ} (s : simplex ℝ P n) : points_with_circumcenter_index n → P
| (point_index i) := s.points i
| circumcenter_index := s.circumcenter

/-- `points_with_circumcenter`, applied to a `point_index` value,
equals `points` applied to that value. -/
@[simp] lemma points_with_circumcenter_point {n : ℕ} (s : simplex ℝ P n) (i : fin (n + 1)) :
  s.points_with_circumcenter (point_index i) = s.points i :=
rfl

/-- `points_with_circumcenter`, applied to `circumcenter_index`, equals the
circumcenter. -/
@[simp] lemma points_with_circumcenter_eq_circumcenter {n : ℕ} (s : simplex ℝ P n) :
  s.points_with_circumcenter circumcenter_index = s.circumcenter :=
rfl

omit V

/-- The weights for a single vertex of a simplex, in terms of
`points_with_circumcenter`. -/
def point_weights_with_circumcenter {n : ℕ} (i : fin (n + 1)) : points_with_circumcenter_index n → ℝ
| (point_index j) := if j = i then 1 else 0
| circumcenter_index := 0

/-- `point_weights_with_circumcenter` sums to 1. -/
@[simp] lemma sum_point_weights_with_circumcenter {n : ℕ} (i : fin (n + 1)) :
  ∑ j, point_weights_with_circumcenter i j = 1 :=
begin
  convert sum_ite_eq' univ (point_index i) (function.const _ (1 : ℝ)),
  { ext j,
    cases j ; simp [point_weights_with_circumcenter] },
  { simp }
end

include V

/-- A single vertex, in terms of `points_with_circumcenter`. -/
lemma point_eq_affine_combination_of_points_with_circumcenter {n : ℕ} (s : simplex ℝ P n)
  (i : fin (n + 1)) :
  s.points i =
    (univ : finset (points_with_circumcenter_index n)).affine_combination ℝ
      s.points_with_circumcenter (point_weights_with_circumcenter i) :=
begin
  rw ←points_with_circumcenter_point,
  symmetry,
  refine affine_combination_of_eq_one_of_eq_zero _ _ _
    (mem_univ _)
    (by simp [point_weights_with_circumcenter])
    _,
  intros i hi hn,
  cases i,
  { have h : i_1 ≠ i := λ h, hn (h ▸ rfl),
    simp [point_weights_with_circumcenter, h] },
  { refl }
end

omit V

/-- The weights for the centroid of some vertices of a simplex, in
terms of `points_with_circumcenter`. -/
def centroid_weights_with_circumcenter {n : ℕ} (fs : finset (fin (n + 1)))
  : points_with_circumcenter_index n → ℝ
| (point_index i) := if i ∈ fs then ((card fs : ℝ) ⁻¹) else 0
| circumcenter_index := 0

/-- `centroid_weights_with_circumcenter` sums to 1, if the `finset` is
nonempty. -/
@[simp] lemma sum_centroid_weights_with_circumcenter {n : ℕ} {fs : finset (fin (n + 1))}
  (h : fs.nonempty) :
  ∑ i, centroid_weights_with_circumcenter fs i = 1 :=
begin
  simp_rw [sum_points_with_circumcenter, centroid_weights_with_circumcenter, add_zero,
           ←fs.sum_centroid_weights_eq_one_of_nonempty ℝ h,
           set.sum_indicator_subset _ fs.subset_univ],
  rcongr
end

include V

/-- The centroid of some vertices of a simplex, in terms of
`points_with_circumcenter`. -/
lemma centroid_eq_affine_combination_of_points_with_circumcenter {n : ℕ} (s : simplex ℝ P n)
  (fs : finset (fin (n + 1))) :
  fs.centroid ℝ s.points =
    (univ : finset (points_with_circumcenter_index n)).affine_combination ℝ
      s.points_with_circumcenter (centroid_weights_with_circumcenter fs) :=
begin
  simp_rw [centroid_def, affine_combination_apply,
           weighted_vsub_of_point_apply, sum_points_with_circumcenter,
           centroid_weights_with_circumcenter, points_with_circumcenter_point, zero_smul,
           add_zero, centroid_weights,
           set.sum_indicator_subset_of_eq_zero
             (function.const (fin (n + 1)) ((card fs : ℝ)⁻¹))
             (λ i wi, wi • (s.points i -ᵥ classical.choice add_torsor.nonempty))
             fs.subset_univ
             (λ i, zero_smul ℝ _),
           set.indicator_apply],
  congr,
end

omit V

/-- The weights for the circumcenter of a simplex, in terms of
`points_with_circumcenter`. -/
def circumcenter_weights_with_circumcenter (n : ℕ) : points_with_circumcenter_index n → ℝ
| (point_index i) := 0
| circumcenter_index := 1

/-- `circumcenter_weights_with_circumcenter` sums to 1. -/
@[simp] lemma sum_circumcenter_weights_with_circumcenter (n : ℕ) :
  ∑ i, circumcenter_weights_with_circumcenter n i = 1 :=
begin
  convert sum_ite_eq' univ circumcenter_index (function.const _ (1 : ℝ)),
  { ext ⟨j⟩ ; simp [circumcenter_weights_with_circumcenter] },
  { simp }
end

include V

/-- The circumcenter of a simplex, in terms of
`points_with_circumcenter`. -/
lemma circumcenter_eq_affine_combination_of_points_with_circumcenter {n : ℕ}
  (s : simplex ℝ P n) :
  s.circumcenter = (univ : finset (points_with_circumcenter_index n)).affine_combination ℝ
    s.points_with_circumcenter (circumcenter_weights_with_circumcenter n) :=
begin
  rw ←points_with_circumcenter_eq_circumcenter,
  symmetry,
  refine affine_combination_of_eq_one_of_eq_zero _ _ _ (mem_univ _) rfl _,
  rintros ⟨i⟩ hi hn ; tauto
end

omit V

/-- The weights for the reflection of the circumcenter in an edge of a
simplex.  This definition is only valid with `i₁ ≠ i₂`. -/
def reflection_circumcenter_weights_with_circumcenter {n : ℕ} (i₁ i₂ : fin (n + 1)) :
  points_with_circumcenter_index n → ℝ
| (point_index i) := if i = i₁ ∨ i = i₂ then 1 else 0
| circumcenter_index := -1

/-- `reflection_circumcenter_weights_with_circumcenter` sums to 1. -/
@[simp]

include V

/-- The reflection of the circumcenter of a simplex in an edge, in
terms of `points_with_circumcenter`. -/
lemma reflection_circumcenter_eq_affine_combination_of_points_with_circumcenter {n : ℕ}
  (s : simplex ℝ P n) {i₁ i₂ : fin (n + 1)} (h : i₁ ≠ i₂) :
  reflection (affine_span ℝ (s.points '' {i₁, i₂})) s.circumcenter =
    (univ : finset (points_with_circumcenter_index n)).affine_combination ℝ
      s.points_with_circumcenter (reflection_circumcenter_weights_with_circumcenter i₁ i₂) :=
begin
  have hc : card ({i₁, i₂} : finset (fin (n + 1))) = 2,
  { simp [h] },
  -- Making the next line a separate definition helps the elaborator:
  set W : affine_subspace ℝ P := affine_span ℝ (s.points '' {i₁, i₂}) with W_def,
  have h_faces : ↑(orthogonal_projection W s.circumcenter)
    = ↑((s.face hc).orthogonal_projection_span s.circumcenter),
  { apply eq_orthogonal_projection_of_eq_subspace,
    simp },
  rw [euclidean_geometry.reflection_apply, h_faces, s.orthogonal_projection_circumcenter hc,
      circumcenter_eq_centroid, s.face_centroid_eq_centroid hc,
      centroid_eq_affine_combination_of_points_with_circumcenter,
      circumcenter_eq_affine_combination_of_points_with_circumcenter, ←@vsub_eq_zero_iff_eq V,
      affine_combination_vsub, weighted_vsub_vadd_affine_combination, affine_combination_vsub,
      weighted_vsub_apply, sum_points_with_circumcenter],
  simp_rw [pi.sub_apply, pi.add_apply, pi.sub_apply, sub_smul, add_smul, sub_smul,
           centroid_weights_with_circumcenter, circumcenter_weights_with_circumcenter,
           reflection_circumcenter_weights_with_circumcenter, ite_smul, zero_smul, sub_zero,
           apply_ite2 (+), add_zero, ←add_smul, hc, zero_sub, neg_smul, sub_self, add_zero],
  convert sum_const_zero,
  norm_num
end

end simplex

end affine

namespace euclidean_geometry

open affine affine_subspace finite_dimensional

variables {V : Type*} {P : Type*}
  [normed_add_comm_group V] [inner_product_space ℝ V] [metric_space P] [normed_add_torsor V P]
include V

/-- Given a nonempty affine subspace, whose direction is complete,
that contains a set of points, those points are cospherical if and
only if they are equidistant from some point in that subspace. -/
lemma cospherical_iff_exists_mem_of_complete {s : affine_subspace ℝ P} {ps : set P} (h : ps ⊆ s)
  [nonempty s] [complete_space s.direction] :
  cospherical ps ↔ ∃ (center ∈ s) (radius : ℝ), ∀ p ∈ ps, dist p center = radius :=
begin
  split,
  { rintro ⟨c, hcr⟩,
    rw exists_dist_eq_iff_exists_dist_orthogonal_projection_eq h c at hcr,
    exact ⟨orthogonal_projection s c, orthogonal_projection_mem _, hcr⟩ },
  { exact λ ⟨c, hc, hd⟩, ⟨c, hd⟩ }
end

/-- Given a nonempty affine subspace, whose direction is
finite-dimensional, that contains a set of points, those points are
cospherical if and only if they are equidistant from some point in
that subspace. -/
lemma cospherical_iff_exists_mem_of_finite_dimensional {s : affine_subspace ℝ P} {ps : set P}
  (h : ps ⊆ s) [nonempty s] [finite_dimensional ℝ s.direction] :
  cospherical ps ↔ ∃ (center ∈ s) (radius : ℝ), ∀ p ∈ ps, dist p center = radius :=
cospherical_iff_exists_mem_of_complete h

/-- All n-simplices among cospherical points in an n-dimensional
subspace have the same circumradius. -/
lemma exists_circumradius_eq_of_cospherical_subset {s : affine_subspace ℝ P} {ps : set P}
  (h : ps ⊆ s) [nonempty s] {n : ℕ} [finite_dimensional ℝ s.direction]
  (hd : finrank ℝ s.direction = n) (hc : cospherical ps) :
  ∃ r : ℝ, ∀ sx : simplex ℝ P n, set.range sx.points ⊆ ps → sx.circumradius = r :=
begin
  rw cospherical_iff_exists_mem_of_finite_dimensional h at hc,
  rcases hc with ⟨c, hc, r, hcr⟩,
  use r,
  intros sx hsxps,
  have hsx : affine_span ℝ (set.range sx.points) = s,
  { refine sx.independent.affine_span_eq_of_le_of_card_eq_finrank_add_one
      (span_points_subset_coe_of_subset_coe (hsxps.trans h)) _,
    simp [hd] },
  have hc : c ∈ affine_span ℝ (set.range sx.points) := hsx.symm ▸ hc,
  exact (sx.eq_circumradius_of_dist_eq
    hc
    (λ i, hcr (sx.points i) (hsxps (set.mem_range_self i)))).symm
end

/-- Two n-simplices among cospherical points in an n-dimensional
subspace have the same circumradius. -/
lemma circumradius_eq_of_cospherical_subset {s : affine_subspace ℝ P} {ps : set P}
  (h : ps ⊆ s) [nonempty s] {n : ℕ} [finite_dimensional ℝ s.direction]
  (hd : finrank ℝ s.direction = n) (hc : cospherical ps) {sx₁ sx₂ : simplex ℝ P n}
  (hsx₁ : set.range sx₁.points ⊆ ps) (hsx₂ : set.range sx₂.points ⊆ ps) :
  sx₁.circumradius = sx₂.circumradius :=
begin
  rcases exists_circumradius_eq_of_cospherical_subset h hd hc with ⟨r, hr⟩,
  rw [hr sx₁ hsx₁, hr sx₂ hsx₂]
end

/-- All n-simplices among cospherical points in n-space have the same
circumradius. -/
lemma exists_circumradius_eq_of_cospherical {ps : set P} {n : ℕ} [finite_dimensional ℝ V]
  (hd : finrank ℝ V = n) (hc : cospherical ps) :
  ∃ r : ℝ, ∀ sx : simplex ℝ P n, set.range sx.points ⊆ ps → sx.circumradius = r :=
begin
  haveI : nonempty (⊤ : affine_subspace ℝ P) := set.univ.nonempty,
  rw [←finrank_top, ←direction_top ℝ V P] at hd,
  refine exists_circumradius_eq_of_cospherical_subset _ hd hc,
  exact set.subset_univ _
end

/-- Two n-simplices among cospherical points in n-space have the same
circumradius. -/
lemma circumradius_eq_of_cospherical {ps : set P} {n : ℕ} [finite_dimensional ℝ V]
  (hd : finrank ℝ V = n) (hc : cospherical ps) {sx₁ sx₂ : simplex ℝ P n}
  (hsx₁ : set.range sx₁.points ⊆ ps) (hsx₂ : set.range sx₂.points ⊆ ps) :
  sx₁.circumradius = sx₂.circumradius :=
begin
  rcases exists_circumradius_eq_of_cospherical hd hc with ⟨r, hr⟩,
  rw [hr sx₁ hsx₁, hr sx₂ hsx₂]
end

/-- All n-simplices among cospherical points in an n-dimensional
subspace have the same circumcenter. -/
lemma exists_circumcenter_eq_of_cospherical_subset {s : affine_subspace ℝ P} {ps : set P}
  (h : ps ⊆ s) [nonempty s] {n : ℕ} [finite_dimensional ℝ s.direction]
  (hd : finrank ℝ s.direction = n) (hc : cospherical ps) :
  ∃ c : P, ∀ sx : simplex ℝ P n, set.range sx.points ⊆ ps → sx.circumcenter = c :=
begin
  rw cospherical_iff_exists_mem_of_finite_dimensional h at hc,
  rcases hc with ⟨c, hc, r, hcr⟩,
  use c,
  intros sx hsxps,
  have hsx : affine_span ℝ (set.range sx.points) = s,
  { refine sx.independent.affine_span_eq_of_le_of_card_eq_finrank_add_one
      (span_points_subset_coe_of_subset_coe (hsxps.trans h)) _,
    simp [hd] },
  have hc : c ∈ affine_span ℝ (set.range sx.points) := hsx.symm ▸ hc,
  exact (sx.eq_circumcenter_of_dist_eq
    hc
    (λ i, hcr (sx.points i) (hsxps (set.mem_range_self i)))).symm
end

/-- Two n-simplices among cospherical points in an n-dimensional
subspace have the same circumcenter. -/
lemma circumcenter_eq_of_cospherical_subset {s : affine_subspace ℝ P} {ps : set P}
  (h : ps ⊆ s) [nonempty s] {n : ℕ} [finite_dimensional ℝ s.direction]
  (hd : finrank ℝ s.direction = n) (hc : cospherical ps) {sx₁ sx₂ : simplex ℝ P n}
  (hsx₁ : set.range sx₁.points ⊆ ps) (hsx₂ : set.range sx₂.points ⊆ ps) :
  sx₁.circumcenter = sx₂.circumcenter :=
begin
  rcases exists_circumcenter_eq_of_cospherical_subset h hd hc with ⟨r, hr⟩,
  rw [hr sx₁ hsx₁, hr sx₂ hsx₂]
end

/-- All n-simplices among cospherical points in n-space have the same
circumcenter. -/
lemma exists_circumcenter_eq_of_cospherical {ps : set P} {n : ℕ} [finite_dimensional ℝ V]
  (hd : finrank ℝ V = n) (hc : cospherical ps) :
  ∃ c : P, ∀ sx : simplex ℝ P n, set.range sx.points ⊆ ps → sx.circumcenter = c :=
begin
  haveI : nonempty (⊤ : affine_subspace ℝ P) := set.univ.nonempty,
  rw [←finrank_top, ←direction_top ℝ V P] at hd,
  refine exists_circumcenter_eq_of_cospherical_subset _ hd hc,
  exact set.subset_univ _
end

/-- Two n-simplices among cospherical points in n-space have the same
circumcenter. -/
lemma circumcenter_eq_of_cospherical {ps : set P} {n : ℕ} [finite_dimensional ℝ V]
  (hd : finrank ℝ V = n) (hc : cospherical ps) {sx₁ sx₂ : simplex ℝ P n}
  (hsx₁ : set.range sx₁.points ⊆ ps) (hsx₂ : set.range sx₂.points ⊆ ps) :
  sx₁.circumcenter = sx₂.circumcenter :=
begin
  rcases exists_circumcenter_eq_of_cospherical hd hc with ⟨r, hr⟩,
  rw [hr sx₁ hsx₁, hr sx₂ hsx₂]
end

/-- All n-simplices among cospherical points in an n-dimensional
subspace have the same circumsphere. -/
lemma exists_circumsphere_eq_of_cospherical_subset {s : affine_subspace ℝ P} {ps : set P}
  (h : ps ⊆ s) [nonempty s] {n : ℕ} [finite_dimensional ℝ s.direction]
  (hd : finrank ℝ s.direction = n) (hc : cospherical ps) :
  ∃ c : sphere P, ∀ sx : simplex ℝ P n, set.range sx.points ⊆ ps → sx.circumsphere = c :=
begin
  obtain ⟨r, hr⟩ := exists_circumradius_eq_of_cospherical_subset h hd hc,
  obtain ⟨c, hc⟩ := exists_circumcenter_eq_of_cospherical_subset h hd hc,
  exact ⟨⟨c, r⟩, λ sx hsx, sphere.ext _ _ (hc sx hsx) (hr sx hsx)⟩
end

/-- Two n-simplices among cospherical points in an n-dimensional
subspace have the same circumsphere. -/
lemma circumsphere_eq_of_cospherical_subset {s : affine_subspace ℝ P} {ps : set P}
  (h : ps ⊆ s) [nonempty s] {n : ℕ} [finite_dimensional ℝ s.direction]
  (hd : finrank ℝ s.direction = n) (hc : cospherical ps) {sx₁ sx₂ : simplex ℝ P n}
  (hsx₁ : set.range sx₁.points ⊆ ps) (hsx₂ : set.range sx₂.points ⊆ ps) :
  sx₁.circumsphere = sx₂.circumsphere :=
begin
  rcases exists_circumsphere_eq_of_cospherical_subset h hd hc with ⟨r, hr⟩,
  rw [hr sx₁ hsx₁, hr sx₂ hsx₂]
end

/-- All n-simplices among cospherical points in n-space have the same
circumsphere. -/
lemma exists_circumsphere_eq_of_cospherical {ps : set P} {n : ℕ} [finite_dimensional ℝ V]
  (hd : finrank ℝ V = n) (hc : cospherical ps) :
  ∃ c : sphere P, ∀ sx : simplex ℝ P n, set.range sx.points ⊆ ps → sx.circumsphere = c :=
begin
  haveI : nonempty (⊤ : affine_subspace ℝ P) := set.univ.nonempty,
  rw [←finrank_top, ←direction_top ℝ V P] at hd,
  refine exists_circumsphere_eq_of_cospherical_subset _ hd hc,
  exact set.subset_univ _
end

/-- Two n-simplices among cospherical points in n-space have the same
circumsphere. -/
lemma circumsphere_eq_of_cospherical {ps : set P} {n : ℕ} [finite_dimensional ℝ V]
  (hd : finrank ℝ V = n) (hc : cospherical ps) {sx₁ sx₂ : simplex ℝ P n}
  (hsx₁ : set.range sx₁.points ⊆ ps) (hsx₂ : set.range sx₂.points ⊆ ps) :
  sx₁.circumsphere = sx₂.circumsphere :=
begin
  rcases exists_circumsphere_eq_of_cospherical hd hc with ⟨r, hr⟩,
  rw [hr sx₁ hsx₁, hr sx₂ hsx₂]
end

/-- Suppose all distances from `p₁` and `p₂` to the points of a
simplex are equal, and that `p₁` and `p₂` lie in the affine span of
`p` with the vertices of that simplex.  Then `p₁` and `p₂` are equal
or reflections of each other in the affine span of the vertices of the
simplex. -/
lemma eq_or_eq_reflection_of_dist_eq {n : ℕ} {s : simplex ℝ P n} {p p₁ p₂ : P} {r : ℝ}
    (hp₁ : p₁ ∈ affine_span ℝ (insert p (set.range s.points)))
    (hp₂ : p₂ ∈ affine_span ℝ (insert p (set.range s.points)))
    (h₁ : ∀ i, dist (s.points i) p₁ = r) (h₂ : ∀ i, dist (s.points i) p₂ = r) :
  p₁ = p₂ ∨ p₁ = reflection (affine_span ℝ (set.range s.points)) p₂ :=
begin
  let span_s := affine_span ℝ (set.range s.points),
  have h₁' := s.orthogonal_projection_eq_circumcenter_of_dist_eq h₁,
  have h₂' := s.orthogonal_projection_eq_circumcenter_of_dist_eq h₂,
  rw [←affine_span_insert_affine_span,
      mem_affine_span_insert_iff (orthogonal_projection_mem p)] at hp₁ hp₂,
  obtain ⟨r₁, p₁o, hp₁o, hp₁⟩ := hp₁,
  obtain ⟨r₂, p₂o, hp₂o, hp₂⟩ := hp₂,
  obtain rfl : ↑(s.orthogonal_projection_span p₁) = p₁o,
  { subst hp₁, exact s.coe_orthogonal_projection_vadd_smul_vsub_orthogonal_projection hp₁o },
  rw h₁' at hp₁,
  obtain rfl : ↑(s.orthogonal_projection_span p₂) = p₂o,
  { subst hp₂, exact s.coe_orthogonal_projection_vadd_smul_vsub_orthogonal_projection hp₂o },
  rw h₂' at hp₂,
  have h : s.points 0 ∈ span_s := mem_affine_span ℝ (set.mem_range_self _),
  have hd₁ : dist p₁ s.circumcenter * dist p₁ s.circumcenter =
      r * r - s.circumradius * s.circumradius :=
    s.dist_circumcenter_sq_eq_sq_sub_circumradius h₁ h₁' h,
  have hd₂ : dist p₂ s.circumcenter * dist p₂ s.circumcenter =
      r * r - s.circumradius * s.circumradius :=
    s.dist_circumcenter_sq_eq_sq_sub_circumradius h₂ h₂' h,
  rw [←hd₂, hp₁, hp₂, dist_eq_norm_vsub V _ s.circumcenter,
      dist_eq_norm_vsub V _ s.circumcenter, vadd_vsub, vadd_vsub, ←real_inner_self_eq_norm_mul_norm,
      ←real_inner_self_eq_norm_mul_norm, real_inner_smul_left, real_inner_smul_left,
      real_inner_smul_right, real_inner_smul_right, ←mul_assoc, ←mul_assoc] at hd₁,
  by_cases hp : p = s.orthogonal_projection_span p,
  { rw simplex.orthogonal_projection_span at hp,
    rw [hp₁, hp₂, ←hp],
    simp only [true_or, eq_self_iff_true, smul_zero, vsub_self] },
  { have hz : ⟪p -ᵥ orthogonal_projection span_s p, p -ᵥ orthogonal_projection span_s p⟫ ≠ 0,
      by simpa only [ne.def, vsub_eq_zero_iff_eq, inner_self_eq_zero] using hp,
    rw [mul_left_inj' hz, mul_self_eq_mul_self_iff] at hd₁,
    rw [hp₁, hp₂],
    cases hd₁,
    { left,
      rw hd₁ },
    { right,
      rw [hd₁,
          reflection_vadd_smul_vsub_orthogonal_projection p r₂ s.circumcenter_mem_affine_span,
          neg_smul] } }
end

end euclidean_geometry


/-
Copyright (c) 2021 Damiano Testa. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Damiano Testa
-/
import data.zmod.basic
import ring_theory.subsemiring.basic
import algebra.order.monoid.basic
/-!

A `canonically_ordered_comm_semiring` with two different elements `a` and `b` such that
`a ≠ b` and `2 * a = 2 * b`.  Thus, multiplication by a fixed non-zero element of a canonically
ordered semiring need not be injective.  In particular, multiplying by a strictly positive element
need not be strictly monotone.

Recall that a `canonically_ordered_comm_semiring` is a commutative semiring with a partial ordering
that is "canonical" in the sense that the inequality `a ≤ b` holds if and only if there is a `c`
such that `a + c = b`.  There are several compatibility conditions among addition/multiplication
and the order relation.  The point of the counterexample is to show that monotonicity of
multiplication cannot be strengthened to **strict** monotonicity.

Reference:
https://leanprover.zulipchat.com/#narrow/stream/113489-new-members/topic/canonically_ordered.20pathology
-/

namespace from_Bhavik

/--  Bhavik Mehta's example.  There are only the initial definitions, but no proofs.  The Type
`K` is a canonically ordered commutative semiring with the property that `2 * (1/2) ≤ 2 * 1`, even
though it is not true that `1/2 ≤ 1`, since `1/2` and `1` are not comparable. -/
@[derive [comm_semiring]]
def K : Type := subsemiring.closure ({1.5} : set ℚ)

instance : has_coe K ℚ := ⟨λ x, x.1⟩

instance inhabited_K : inhabited K := ⟨0⟩

instance : preorder K :=
{ le := λ x y, x = y ∨ (x : ℚ) + 1 ≤ (y : ℚ),
  le_refl := λ x, or.inl rfl,
  le_trans := λ x y z xy yz,
  begin
    rcases xy with (rfl | _), { apply yz },
    rcases yz with (rfl | _), { right, apply xy },
    right,
    exact xy.trans (le_trans ((le_add_iff_nonneg_right _).mpr zero_le_one) yz)
  end }

end from_Bhavik

lemma mem_zmod_2 (a : zmod 2) : a = 0 ∨ a = 1 :=
begin
  rcases a with ⟨_|_, _|_|_|_⟩,
  { exact or.inl rfl },
  { exact or.inr rfl },
end

lemma add_self_zmod_2 (a : zmod 2) : a + a = 0 :=
begin
  rcases mem_zmod_2 a with rfl | rfl;
  refl,
end

namespace Nxzmod_2

variables {a b : ℕ × zmod 2}

/-- The preorder relation on `ℕ × ℤ/2ℤ` where we only compare the first coordinate,
except that we leave incomparable each pair of elements with the same first component.
For instance, `∀ α, β ∈ ℤ/2ℤ`, the inequality `(1,α) ≤ (2,β)` holds,
whereas, `∀ n ∈ ℤ`, the elements `(n,0)` and `(n,1)` are incomparable. -/
instance preN2 : partial_order (ℕ × zmod 2) :=
{ le := λ x y, x = y ∨ x.1 < y.1,
  le_refl := λ a, or.inl rfl,
  le_trans := λ x y z xy yz,
  begin
    rcases xy with (rfl | _),
    { exact yz },
    { rcases yz with (rfl | _),
      { exact or.inr xy},
      { exact or.inr (xy.trans yz) } }
  end,
  le_antisymm := begin
    intros a b ab ba,
    cases ab with ab ab,
    { exact ab },
    { cases ba with ba ba,
      { exact ba.symm },
      { exact (nat.lt_asymm ab ba).elim } }
  end }

instance csrN2 : comm_semiring (ℕ × zmod 2) := by apply_instance

instance csrN2_1 : add_cancel_comm_monoid (ℕ × zmod 2) :=
{ add_left_cancel := λ a b c h, (add_right_inj a).mp h,
  ..Nxzmod_2.csrN2 }

/-- A strict inequality forces the first components to be different. -/
@[simp] lemma lt_def : a < b ↔ a.1 < b.1 :=
begin
  refine ⟨λ h, _, λ h, _⟩,
  { rcases h with ⟨(rfl | a1), h1⟩,
    { exact ((not_or_distrib.mp h1).1).elim rfl },
    { exact a1 } },
  refine ⟨or.inr h, not_or_distrib.mpr ⟨λ k, _, not_lt.mpr h.le⟩⟩,
  rw k at h,
  exact nat.lt_asymm h h
end

lemma add_left_cancel : ∀ (a b c : ℕ × zmod 2), a + b = a + c → b = c :=
λ a b c h, (add_right_inj a).mp h

lemma add_le_add_left : ∀ (a b : ℕ × zmod 2), a ≤ b → ∀ (c : ℕ × zmod 2), c + a ≤ c + b :=
begin
  rintros a b (rfl | ab) c,
  { refl },
  { exact or.inr (by simpa) }
end

lemma le_of_add_le_add_left : ∀ (a b c : ℕ × zmod 2), a + b ≤ a + c → b ≤ c :=
begin
  rintros a b c (bc | bc),
  { exact le_of_eq ((add_right_inj a).mp bc) },
  { exact or.inr (by simpa using bc) }
end

instance : zero_le_one_class (ℕ × zmod 2) := ⟨dec_trivial⟩

lemma mul_lt_mul_of_pos_left : ∀ (a b c : ℕ × zmod 2), a < b → 0 < c → c * a < c * b :=
λ a b c ab c0, lt_def.mpr ((mul_lt_mul_left (lt_def.mp c0)).mpr (lt_def.mp ab))

lemma mul_lt_mul_of_pos_right : ∀ (a b c : ℕ × zmod 2), a < b → 0 < c → a * c < b * c :=
λ a b c ab c0, lt_def.mpr ((mul_lt_mul_right (lt_def.mp c0)).mpr (lt_def.mp ab))

instance socsN2 : strict_ordered_comm_semiring (ℕ × zmod 2) :=
{ add_le_add_left := add_le_add_left,
  le_of_add_le_add_left := le_of_add_le_add_left,
  zero_le_one := zero_le_one,
  mul_lt_mul_of_pos_left := mul_lt_mul_of_pos_left,
  mul_lt_mul_of_pos_right := mul_lt_mul_of_pos_right,
  ..Nxzmod_2.csrN2_1,
  ..(infer_instance : partial_order (ℕ × zmod 2)),
  ..(infer_instance : comm_semiring (ℕ × zmod 2)),
  ..pullback_nonzero prod.fst prod.fst_zero prod.fst_one }

end Nxzmod_2

namespace ex_L

open Nxzmod_2 subtype

/-- Initially, `L` was defined as the subsemiring closure of `(1,0)`. -/
def L : Type := { l : (ℕ × zmod 2) // l ≠ (0, 1) }

lemma add_L {a b : ℕ × zmod 2} (ha : a ≠ (0, 1)) (hb : b ≠ (0, 1)) :
  a + b ≠ (0, 1) :=
begin
  rcases a with ⟨a, a2⟩,
  rcases b with ⟨b, b2⟩,
  cases b,
  { rcases mem_zmod_2 b2 with rfl | rfl,
    { simp [ha] },
    { simpa only } },
  { simp [(a + b).succ_ne_zero] }
end

lemma mul_L {a b : ℕ × zmod 2} (ha : a ≠ (0, 1)) (hb : b ≠ (0, 1)) :
  a * b ≠ (0, 1) :=
begin
  rcases a with ⟨a, a2⟩,
  rcases b with ⟨b, b2⟩,
  cases b,
  { rcases mem_zmod_2 b2 with rfl | rfl;
    rcases mem_zmod_2 a2 with rfl | rfl;
    -- while this looks like a non-terminal `simp`, it (almost) isn't: there is only one goal where
    -- it does not finish the proof and on that goal it asks to prove `false`
    simp,
    exact hb rfl },
  cases a,
  { rcases mem_zmod_2 b2 with rfl | rfl;
    rcases mem_zmod_2 a2 with rfl | rfl;
    -- while this looks like a non-terminal `simp`, it (almost) isn't: there is only one goal where
    -- it does not finish the proof and on that goal it asks to prove `false`
    simp,
    exact ha rfl },
  { simp [mul_ne_zero _ _, nat.succ_ne_zero _] }
end

/-- The subsemiring corresponding to the elements of `L`, used to transfer instances. -/
def L_subsemiring : subsemiring (ℕ × zmod 2) :=
{ carrier := { l | l ≠ (0, 1) },
  zero_mem' := dec_trivial,
  one_mem' := dec_trivial,
  add_mem' := λ _ _, add_L,
  mul_mem' := λ _ _, mul_L }

instance : ordered_comm_semiring L :=
L_subsemiring.to_ordered_comm_semiring

instance inhabited : inhabited L := ⟨1⟩

lemma bot_le : ∀ (a : L), 0 ≤ a :=
begin
  rintros ⟨⟨an, a2⟩, ha⟩,
  cases an,
  { rcases mem_zmod_2 a2 with (rfl | rfl),
    { refl, },
    { exact (ha rfl).elim } },
  { refine or.inr _,
    exact nat.succ_pos _ }
end

instance order_bot : order_bot L := ⟨0, bot_le⟩

lemma exists_add_of_le : ∀ a b : L, a ≤ b → ∃ c, b = a + c :=
begin
  rintro a ⟨b, _⟩ (⟨rfl, rfl⟩ | h),
  { exact ⟨0, (add_zero _).symm⟩ },
  { exact ⟨⟨b - a.1, λ H, (tsub_pos_of_lt h).ne' (prod.mk.inj_iff.1 H).1⟩,
      subtype.ext $ prod.ext (add_tsub_cancel_of_le h.le).symm (add_sub_cancel'_right _ _).symm⟩ }
end

lemma le_self_add : ∀ a b : L, a ≤ a + b :=
begin
  rintro a ⟨⟨bn, b2⟩, hb⟩,
  obtain rfl | h := nat.eq_zero_or_pos bn,
  { obtain rfl | rfl := mem_zmod_2 b2,
    { exact or.inl (prod.ext (add_zero _).symm (add_zero _).symm) },
    { exact (hb rfl).elim } },
  { exact or.inr ((lt_add_iff_pos_right _).mpr h) }
end

lemma eq_zero_or_eq_zero_of_mul_eq_zero : ∀ (a b : L), a * b = 0 → a = 0 ∨ b = 0 :=
begin
  rintros ⟨⟨a, a2⟩, ha⟩ ⟨⟨b, b2⟩, hb⟩ ab1,
  injection ab1 with ab,
  injection ab with abn ab2,
  rw mul_eq_zero at abn,
  rcases abn with ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩,
  { refine or.inl _,
    rcases mem_zmod_2 a2 with rfl | rfl,
    { refl },
    { exact (ha rfl).elim } },
  { refine or.inr _,
    rcases mem_zmod_2 b2 with rfl | rfl,
    { refl },
    { exact (hb rfl).elim } }
end

instance can : canonically_ordered_comm_semiring L :=
{ exists_add_of_le := exists_add_of_le,
  le_self_add := le_self_add,
  eq_zero_or_eq_zero_of_mul_eq_zero := eq_zero_or_eq_zero_of_mul_eq_zero,
  ..(infer_instance : order_bot L),
  ..(infer_instance : ordered_comm_semiring L) }

/--
The elements `(1,0)` and `(1,1)` of `L` are different, but their doubles coincide.
-/
example : ∃ a b : L, a ≠ b ∧ 2 * a = 2 * b :=
begin
  refine ⟨⟨(1,0), by simp⟩, 1, λ (h : (⟨(1, 0), _⟩ : L) = ⟨⟨1, 1⟩, _⟩), _, rfl⟩,
  obtain (F : (0 : zmod 2) = 1) := congr_arg (λ j : L, j.1.2) h,
  cases F,
end

end ex_L


import data.real.basic
open function

/-
# Chapter 6 : Functions

## Level 1

A classical result in composition of functions.
-/

/- Lemma
If $f : X \to Y$ and $g : Y \to Z$ are both injective functions, then
the function resulting from their composition is also injective.
-/
theorem both_injective
    (X Y Z : set ℝ) (f : X → Y) (g : Y → Z) : injective f ∧ injective g → injective (g ∘ f) :=
begin
    intros h a b ha,
    apply h.left,
    apply h.right,
    --either this: assumption, --or the line below
    exact ha, done
end


import algebra.ring

namespace my_ring

variables {R : Type*} [ring R]

#check add_zero
#check add_assoc
#check add_right_neg

-- BEGIN
theorem add_neg_cancel_right (a b : R) : (a + b) + -b = a :=
begin
  sorry,
end
-- END

end my_ring


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.monoid_algebra.basic
import algebra.char_p.invertible
import algebra.regular.basic
import linear_algebra.basis

/-!
# Maschke's theorem

We prove **Maschke's theorem** for finite groups,
in the formulation that every submodule of a `k[G]` module has a complement,
when `k` is a field with `invertible (fintype.card G : k)`.

We do the core computation in greater generality.
For any `[comm_ring k]` in which  `[invertible (fintype.card G : k)]`,
and a `k[G]`-linear map `i : V → W` which admits a `k`-linear retraction `π`,
we produce a `k[G]`-linear retraction by
taking the average over `G` of the conjugates of `π`.

## Implementation Notes
* These results assume `invertible (fintype.card G : k)` which is equivalent to the more
familiar `¬(ring_char k ∣ fintype.card G)`. It is possible to convert between them using
`invertible_of_ring_char_not_dvd` and `not_ring_char_dvd_of_invertible`.

## Future work
It's not so far to give the usual statement, that every finite dimensional representation
of a finite group is semisimple (i.e. a direct sum of irreducibles).
-/

universes u

noncomputable theory
open module
open monoid_algebra
open_locale big_operators

section

-- At first we work with any `[comm_ring k]`, and add the assumption that
-- `[invertible (fintype.card G : k)]` when it is required.
variables {k : Type u} [comm_ring k] {G : Type u} [group G]

variables {V : Type u} [add_comm_group V] [module k V] [module (monoid_algebra k G) V]
variables [is_scalar_tower k (monoid_algebra k G) V]
variables {W : Type u} [add_comm_group W] [module k W] [module (monoid_algebra k G) W]
variables [is_scalar_tower k (monoid_algebra k G) W]

/-!
We now do the key calculation in Maschke's theorem.

Given `V → W`, an inclusion of `k[G]` modules,,
assume we have some retraction `π` (i.e. `∀ v, π (i v) = v`),
just as a `k`-linear map.
(When `k` is a field, this will be available cheaply, by choosing a basis.)

We now construct a retraction of the inclusion as a `k[G]`-linear map,
by the formula
$$ \frac{1}{|G|} \sum_{g \in G} g⁻¹ • π(g • -). $$
-/

namespace linear_map

variables (π : W →ₗ[k] V)
include π

/--
We define the conjugate of `π` by `g`, as a `k`-linear map.
-/
def conjugate (g : G) : W →ₗ[k] V :=
((group_smul.linear_map k V g⁻¹).comp π).comp (group_smul.linear_map k W g)

variables (i : V →ₗ[monoid_algebra k G] W) (h : ∀ v : V, π (i v) = v)

section
include h

lemma conjugate_i (g : G) (v : V) : (conjugate π g) (i v) = v :=
begin
  dsimp [conjugate],
  simp only [←i.map_smul, h, ←mul_smul, single_mul_single, mul_one, mul_left_inv],
  change (1 : monoid_algebra k G) • v = v,
  simp,
end
end

variables (G) [fintype G]

/--
The sum of the conjugates of `π` by each element `g : G`, as a `k`-linear map.

(We postpone dividing by the size of the group as long as possible.)
-/
def sum_of_conjugates : W →ₗ[k] V :=
∑ g : G, π.conjugate g

/--
In fact, the sum over `g : G` of the conjugate of `π` by `g` is a `k[G]`-linear map.
-/
def sum_of_conjugates_equivariant : W →ₗ[monoid_algebra k G] V :=
monoid_algebra.equivariant_of_linear_of_comm (π.sum_of_conjugates G) (λ g v,
begin
  dsimp [sum_of_conjugates],
  simp only [linear_map.sum_apply, finset.smul_sum],
  dsimp [conjugate],
  conv_lhs
  { rw [←finset.univ_map_embedding (mul_right_embedding g⁻¹)],
    simp only [mul_right_embedding], },
  simp only [←mul_smul, single_mul_single, mul_inv_rev, mul_one, function.embedding.coe_fn_mk,
    finset.sum_map, inv_inv, inv_mul_cancel_right],
  recover,
end)

section
variables [inv : invertible (fintype.card G : k)]
include inv

/--
We construct our `k[G]`-linear retraction of `i` as
$$ \frac{1}{|G|} \sum_{g \in G} g⁻¹ • π(g • -). $$
-/
def equivariant_projection : W →ₗ[monoid_algebra k G] V :=
⅟(fintype.card G : k) • (π.sum_of_conjugates_equivariant G)

include h

lemma equivariant_projection_condition (v : V) : (π.equivariant_projection G) (i v) = v :=
begin
  rw [equivariant_projection, smul_apply, sum_of_conjugates_equivariant,
    equivariant_of_linear_of_comm_apply, sum_of_conjugates],
  rw [linear_map.sum_apply],
  simp only [conjugate_i π i h],
  rw [finset.sum_const, finset.card_univ, nsmul_eq_smul_cast k,
    ←mul_smul, invertible.inv_of_mul_self, one_smul],
end
end
end linear_map
end

namespace char_zero

variables {k : Type u} [field k] {G : Type u} [fintype G] [group G] [char_zero k]

instance : invertible (fintype.card G : k) :=
invertible_of_ring_char_not_dvd (by simp [fintype.card_eq_zero_iff])

end char_zero

namespace monoid_algebra

-- Now we work over a `[field k]`.
variables {k : Type u} [field k] {G : Type u} [fintype G] [invertible (fintype.card G : k)]
variables [group G]
variables {V : Type u} [add_comm_group V] [module k V] [module (monoid_algebra k G) V]
variables [is_scalar_tower k (monoid_algebra k G) V]
variables {W : Type u} [add_comm_group W] [module k W] [module (monoid_algebra k G) W]
variables [is_scalar_tower k (monoid_algebra k G) W]

lemma exists_left_inverse_of_injective
  (f : V →ₗ[monoid_algebra k G] W) (hf : f.ker = ⊥) :
  ∃ (g : W →ₗ[monoid_algebra k G] V), g.comp f = linear_map.id :=
begin
  obtain ⟨φ, hφ⟩ := (f.restrict_scalars k).exists_left_inverse_of_injective
    (by simp only [hf, submodule.restrict_scalars_bot, linear_map.ker_restrict_scalars]),
  refine ⟨φ.equivariant_projection G, _⟩,
  apply linear_map.ext,
  intro v,
  simp only [linear_map.id_coe, id.def, linear_map.comp_apply],
  apply linear_map.equivariant_projection_condition,
  intro v,
  have := congr_arg linear_map.to_fun hφ,
  exact congr_fun this v
end

namespace submodule

lemma exists_is_compl
  (p : submodule (monoid_algebra k G) V) :
  ∃ q : submodule (monoid_algebra k G) V, is_compl p q :=
let ⟨f, hf⟩ := monoid_algebra.exists_left_inverse_of_injective p.subtype p.ker_subtype in
⟨f.ker, linear_map.is_compl_of_proj $ linear_map.ext_iff.1 hf⟩

/-- This also implies an instance `is_semisimple_module (monoid_algebra k G) V`. -/
instance is_complemented : is_complemented (submodule (monoid_algebra k G) V) :=
⟨exists_is_compl⟩

end submodule
end monoid_algebra


/-
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 group_theory.group_action.big_operators
! leanprover-community/mathlib commit 008205aa645b3f194c1da47025c5f110c8406eab
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.BigOperators.Basic
import Mathlib.Data.Finset.Basic
import Mathlib.Data.Multiset.Basic
import Mathlib.GroupTheory.GroupAction.Defs

/-!
# Lemmas about group actions on big operators

Note that analogous lemmas for `Module`s like `Finset.sum_smul` appear in other files.
-/

variable {α β γ : Type _}

open BigOperators

section

variable [AddMonoid β] [DistribSMul α β]

theorem List.smul_sum {r : α} {l : List β} : r • l.sum = (l.map ((· • ·) r)).sum :=
  (DistribSMul.toAddMonoidHom β r).map_list_sum l
#align list.smul_sum List.smul_sum

end

section

variable [Monoid α] [Monoid β] [MulDistribMulAction α β]

theorem List.smul_prod {r : α} {l : List β} : r • l.prod = (l.map ((· • ·) r)).prod :=
  (MulDistribMulAction.toMonoidHom β r).map_list_prod l
#align list.smul_prod List.smul_prod

end

section

variable [AddCommMonoid β] [DistribSMul α β]

theorem Multiset.smul_sum {r : α} {s : Multiset β} : r • s.sum = (s.map ((· • ·) r)).sum :=
  (DistribSMul.toAddMonoidHom β r).map_multiset_sum s
#align multiset.smul_sum Multiset.smul_sum

theorem Finset.smul_sum {r : α} {f : γ → β} {s : Finset γ} :
    (r • ∑ x in s, f x) = ∑ x in s, r • f x :=
  (DistribSMul.toAddMonoidHom β r).map_sum f s
#align finset.smul_sum Finset.smul_sum

end

section

variable [Monoid α] [CommMonoid β] [MulDistribMulAction α β]

theorem Multiset.smul_prod {r : α} {s : Multiset β} : r • s.prod = (s.map ((· • ·) r)).prod :=
  (MulDistribMulAction.toMonoidHom β r).map_multiset_prod s
#align multiset.smul_prod Multiset.smul_prod

theorem Finset.smul_prod {r : α} {f : γ → β} {s : Finset γ} :
    (r • ∏ x in s, f x) = ∏ x in s, r • f x :=
  (MulDistribMulAction.toMonoidHom β r).map_prod f s
#align finset.smul_prod Finset.smul_prod

end


/-
Copyright (c) 2021 Thomas Browning. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Thomas Browning
-/
import field_theory.abel_ruffini
import analysis.calculus.local_extr
import ring_theory.eisenstein_criterion
/-!
Construction of an algebraic number that is not solvable by radicals.

The main ingredients are:
 * `solvable_by_rad.is_solvable'` in `field_theory/abel_ruffini` :
  an irreducible polynomial with an `is_solvable_by_rad` root has solvable Galois group
 * `gal_action_hom_bijective_of_prime_degree'` in `field_theory/polynomial_galois_group` :
  an irreducible polynomial of prime degree with 1-3 non-real roots has full Galois group
 * `equiv.perm.not_solvable` in `group_theory/solvable` : the symmetric group is not solvable

Then all that remains is the construction of a specific polynomial satisfying the conditions of
`gal_action_hom_bijective_of_prime_degree'`, which is done in this file.

-/

namespace abel_ruffini

open function polynomial polynomial.gal ideal
open_locale polynomial

local attribute [instance] splits_ℚ_ℂ

variables (R : Type*) [comm_ring R] (a b : ℕ)

/-- A quintic polynomial that we will show is irreducible -/
noncomputable def Φ : R[X] := X ^ 5 - C ↑a * X + C ↑b

variables {R}

@[simp] lemma map_Phi {S : Type*} [comm_ring S] (f : R →+* S) : (Φ R a b).map f = Φ S a b :=
by simp [Φ]

@[simp] lemma coeff_zero_Phi : (Φ R a b).coeff 0 = ↑b :=
by simp [Φ, coeff_X_pow]

@[simp] lemma coeff_five_Phi : (Φ R a b).coeff 5 = 1 :=
by simp [Φ, coeff_X, coeff_C, -C_eq_nat_cast, -map_nat_cast]

variables [nontrivial R]

lemma degree_Phi : (Φ R a b).degree = ↑5 :=
begin
  suffices : degree (X ^ 5 - C ↑a * X) = ↑5,
  { rwa [Φ, degree_add_eq_left_of_degree_lt],
    convert degree_C_le.trans_lt (with_bot.coe_lt_coe.mpr (nat.zero_lt_bit1 2)) },
  rw degree_sub_eq_left_of_degree_lt; rw degree_X_pow,
  exact (degree_C_mul_X_le _).trans_lt (with_bot.coe_lt_coe.mpr (nat.one_lt_bit1 two_ne_zero)),
end

lemma nat_degree_Phi : (Φ R a b).nat_degree = 5 :=
nat_degree_eq_of_degree_eq_some (degree_Phi a b)

lemma leading_coeff_Phi : (Φ R a b).leading_coeff = 1 :=
by rw [polynomial.leading_coeff, nat_degree_Phi, coeff_five_Phi]

lemma monic_Phi : (Φ R a b).monic :=
leading_coeff_Phi a b

lemma irreducible_Phi (p : ℕ) (hp : p.prime) (hpa : p ∣ a) (hpb : p ∣ b) (hp2b : ¬ p ^ 2 ∣ b) :
  irreducible (Φ ℚ a b) :=
begin
  rw [←map_Phi a b (int.cast_ring_hom ℚ), ←is_primitive.int.irreducible_iff_irreducible_map_cast],
  apply irreducible_of_eisenstein_criterion,
  { rwa [span_singleton_prime (int.coe_nat_ne_zero.mpr hp.ne_zero), int.prime_iff_nat_abs_prime] },
  { rw [leading_coeff_Phi, mem_span_singleton],
    exact_mod_cast mt nat.dvd_one.mp (hp.ne_one) },
  { intros n hn,
    rw mem_span_singleton,
    rw [degree_Phi, with_bot.coe_lt_coe] at hn,
    interval_cases n with hn;
    simp only [Φ, coeff_X_pow, coeff_C, int.coe_nat_dvd.mpr, hpb, if_true, coeff_C_mul, if_false,
      nat.zero_ne_bit1, eq_self_iff_true, coeff_X_zero, hpa, coeff_add, zero_add, mul_zero,
      int.nat_cast_eq_coe_nat, coeff_sub, sub_self, nat.one_ne_zero, add_zero, coeff_X_one, mul_one,
      zero_sub, dvd_neg, nat.one_eq_bit1, bit0_eq_zero, neg_zero, nat.bit0_ne_bit1,
      dvd_mul_of_dvd_left, nat.bit1_eq_bit1, nat.one_ne_bit0, nat.bit1_ne_zero], },
  { simp only [degree_Phi, ←with_bot.coe_zero, with_bot.coe_lt_coe, nat.succ_pos'] },
  { rw [coeff_zero_Phi, span_singleton_pow, mem_span_singleton, int.nat_cast_eq_coe_nat],
    exact mt int.coe_nat_dvd.mp hp2b },
  all_goals { exact monic.is_primitive (monic_Phi a b) },
end

lemma real_roots_Phi_le : fintype.card ((Φ ℚ a b).root_set ℝ) ≤ 3 :=
begin
  rw [←map_Phi a b (algebra_map ℤ ℚ), Φ, ←one_mul (X ^ 5), ←C_1],
  refine (card_root_set_le_derivative _).trans
    (nat.succ_le_succ ((card_root_set_le_derivative _).trans (nat.succ_le_succ _))),
  suffices : ((C ((algebra_map ℤ ℚ) 20) * X ^ 3).root_set ℝ).subsingleton,
  { norm_num [fintype.card_le_one_iff_subsingleton, ← mul_assoc, *] at * },
  rw root_set_C_mul_X_pow; norm_num,
end

lemma real_roots_Phi_ge_aux (hab : b < a) :
  ∃ x y : ℝ, x ≠ y ∧ aeval x (Φ ℚ a b) = 0 ∧ aeval y (Φ ℚ a b) = 0 :=
begin
  let f := λ x : ℝ, aeval x (Φ ℚ a b),
  have hf : f = λ x, x ^ 5 - a * x + b := by simp [f, Φ],
  have hc : ∀ s : set ℝ, continuous_on f s := λ s, (Φ ℚ a b).continuous_on_aeval,
  have ha : (1 : ℝ) ≤ a := nat.one_le_cast.mpr (nat.one_le_of_lt hab),
  have hle : (0 : ℝ) ≤ 1 := zero_le_one,
  have hf0 : 0 ≤ f 0 := by norm_num [hf],
  by_cases hb : (1 : ℝ) - a + b < 0,
  { have hf1 : f 1 < 0 := by norm_num [hf, hb],
    have hfa : 0 ≤ f a,
    { simp_rw [hf, ←sq],
      refine add_nonneg (sub_nonneg.mpr (pow_le_pow ha _)) _; norm_num },
    obtain ⟨x, ⟨-, hx1⟩, hx2⟩ := intermediate_value_Ico' hle (hc _) (set.mem_Ioc.mpr ⟨hf1, hf0⟩),
    obtain ⟨y, ⟨hy1, -⟩, hy2⟩ := intermediate_value_Ioc ha (hc _) (set.mem_Ioc.mpr ⟨hf1, hfa⟩),
    exact ⟨x, y, (hx1.trans hy1).ne, hx2, hy2⟩ },
  { replace hb : (b : ℝ) = a - 1 := by linarith [show (b : ℝ) + 1 ≤ a, by exact_mod_cast hab],
    have hf1 : f 1 = 0 := by norm_num [hf, hb],
    have hfa := calc f (-a) = a ^ 2 - a ^ 5 + b       : by norm_num [hf, ← sq]
                        ... ≤ a ^ 2 - a ^ 3 + (a - 1) : by refine add_le_add (sub_le_sub_left
                                                            (pow_le_pow ha _) _) _; linarith
                        ... = -(a - 1) ^ 2 * (a + 1)  : by ring
                        ... ≤ 0                       : by nlinarith,
    have ha' := neg_nonpos.mpr (hle.trans ha),
    obtain ⟨x, ⟨-, hx1⟩, hx2⟩ := intermediate_value_Icc ha' (hc _) (set.mem_Icc.mpr ⟨hfa, hf0⟩),
    exact ⟨x, 1, (hx1.trans_lt zero_lt_one).ne, hx2, hf1⟩ },
end

lemma real_roots_Phi_ge (hab : b < a) : 2 ≤ fintype.card ((Φ ℚ a b).root_set ℝ) :=
begin
  have q_ne_zero : Φ ℚ a b ≠ 0 := (monic_Phi a b).ne_zero,
  obtain ⟨x, y, hxy, hx, hy⟩ := real_roots_Phi_ge_aux a b hab,
  have key : ↑({x, y} : finset ℝ) ⊆ (Φ ℚ a b).root_set ℝ,
  { simp [set.insert_subset, mem_root_set q_ne_zero, hx, hy] },
  convert fintype.card_le_of_embedding (set.embedding_of_subset _ _ key),
  simp only [finset.coe_sort_coe, fintype.card_coe, finset.card_singleton,
             finset.card_insert_of_not_mem (mt finset.mem_singleton.mp hxy)]
end

lemma complex_roots_Phi (h : (Φ ℚ a b).separable) : fintype.card ((Φ ℚ a b).root_set ℂ) = 5 :=
(card_root_set_eq_nat_degree h (is_alg_closed.splits_codomain _)).trans (nat_degree_Phi a b)

lemma gal_Phi (hab : b < a) (h_irred : irreducible (Φ ℚ a b)) :
  bijective (gal_action_hom (Φ ℚ a b) ℂ) :=
begin
  apply gal_action_hom_bijective_of_prime_degree' h_irred,
  { norm_num [nat_degree_Phi] },
  { rw [complex_roots_Phi a b h_irred.separable, nat.succ_le_succ_iff],
    exact (real_roots_Phi_le a b).trans (nat.le_succ 3) },
  { simp_rw [complex_roots_Phi a b h_irred.separable, nat.succ_le_succ_iff],
    exact real_roots_Phi_ge a b hab },
end

theorem not_solvable_by_rad (p : ℕ) (x : ℂ) (hx : aeval x (Φ ℚ a b) = 0) (hab : b < a)
  (hp : p.prime) (hpa : p ∣ a) (hpb : p ∣ b) (hp2b : ¬ p ^ 2 ∣ b) :
  ¬ is_solvable_by_rad ℚ x :=
begin
  have h_irred := irreducible_Phi a b p hp hpa hpb hp2b,
  apply mt (solvable_by_rad.is_solvable' h_irred hx),
  introI h,
  refine equiv.perm.not_solvable _ (le_of_eq _)
    (solvable_of_surjective (gal_Phi a b hab h_irred).2),
  rw_mod_cast [cardinal.mk_fintype, complex_roots_Phi a b h_irred.separable],
end

theorem not_solvable_by_rad' (x : ℂ) (hx : aeval x (Φ ℚ 4 2) = 0) :
  ¬ is_solvable_by_rad ℚ x :=
by apply not_solvable_by_rad 4 2 2 x hx; norm_num

/-- **Abel-Ruffini Theorem** -/
theorem exists_not_solvable_by_rad : ∃ x : ℂ, is_algebraic ℚ x ∧ ¬ is_solvable_by_rad ℚ x :=
begin
  obtain ⟨x, hx⟩ := exists_root_of_splits (algebra_map ℚ ℂ)
    (is_alg_closed.splits_codomain (Φ ℚ 4 2))
    (ne_of_eq_of_ne (degree_Phi 4 2) (mt with_bot.coe_eq_coe.mp (nat.bit1_ne_zero 2))),
  exact ⟨x, ⟨Φ ℚ 4 2, (monic_Phi 4 2).ne_zero, hx⟩, not_solvable_by_rad' x hx⟩,
end

end abel_ruffini


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
Ported by: Anatole Dedecker

! This file was ported from Lean 3 source module logic.equiv.nat
! leanprover-community/mathlib commit 207cfac9fcd06138865b5d04f7091e46d9320432
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Nat.Pairing

/-!
# Equivalences involving `ℕ`

This file defines some additional constructive equivalences using `encodable` and the pairing
function on `ℕ`.
-/

open Nat Function

namespace Equiv

variable {α : Type _}

/-- An equivalence between `Bool × ℕ` and `ℕ`, by mapping `(true, x)` to `2 * x + 1` and
`(false, x)` to `2 * x`. -/
@[simps]
def boolProdNatEquivNat : Bool × ℕ ≃ ℕ where
  toFun := uncurry bit
  invFun := boddDiv2
  left_inv := fun ⟨b, n⟩ => by simp only [bodd_bit, div2_bit, uncurry_apply_pair, boddDiv2_eq]
  right_inv n := by simp only [bit_decomp, boddDiv2_eq, uncurry_apply_pair]
#align equiv.bool_prod_nat_equiv_nat Equiv.boolProdNatEquivNat
#align equiv.bool_prod_nat_equiv_nat_symm_apply Equiv.boolProdNatEquivNat_symm_apply
#align equiv.bool_prod_nat_equiv_nat_apply Equiv.boolProdNatEquivNat_apply

/-- An equivalence between `ℕ ⊕ ℕ` and `ℕ`, by mapping `(Sum.inl x)` to `2 * x` and `(Sum.inr x)` to
`2 * x + 1`.
-/
@[simps! symm_apply]
def natSumNatEquivNat : ℕ ⊕ ℕ ≃ ℕ :=
  (boolProdEquivSum ℕ).symm.trans boolProdNatEquivNat
#align equiv.nat_sum_nat_equiv_nat Equiv.natSumNatEquivNat
#align equiv.nat_sum_nat_equiv_nat_symm_apply Equiv.natSumNatEquivNat_symm_apply

set_option linter.deprecated false in
@[simp]
theorem natSumNatEquivNat_apply : ⇑natSumNatEquivNat = Sum.elim bit0 bit1 := by
  ext (x | x) <;> rfl
#align equiv.nat_sum_nat_equiv_nat_apply Equiv.natSumNatEquivNat_apply

/-- An equivalence between `ℤ` and `ℕ`, through `ℤ ≃ ℕ ⊕ ℕ` and `ℕ ⊕ ℕ ≃ ℕ`.
-/
def intEquivNat : ℤ ≃ ℕ :=
  intEquivNatSumNat.trans natSumNatEquivNat
#align equiv.int_equiv_nat Equiv.intEquivNat

/-- An equivalence between `α × α` and `α`, given that there is an equivalence between `α` and `ℕ`.
-/
def prodEquivOfEquivNat (e : α ≃ ℕ) : α × α ≃ α :=
  calc
    α × α ≃ ℕ × ℕ := prodCongr e e
    _ ≃ ℕ := pairEquiv
    _ ≃ α := e.symm
#align equiv.prod_equiv_of_equiv_nat Equiv.prodEquivOfEquivNat

end Equiv


import tactic
import data.nat.basic
import data.nat.prime
import data.real.sqrt

namespace lecture9

open nat

example {x : ℤ} : x^3 - 5 * x^2 + 3 * x ≠ 15 -> x ≠ 5 :=
begin
  contrapose,
  intro x_eq_5,
  simp at x_eq_5,
  simp,
  rw x_eq_5,
  linarith,
end

end lecture9


/-
 (c) 2022 Henrik Böving. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Henrik Böving
-/

namespace Cpdt
namespace Chapter3

inductive Formula where
  | eq : Nat → Nat → Formula
  | and : Formula → Formula → Formula
  | universal : (Nat → Formula) → Formula

namespace Formula

def denote : Formula → Prop
  | eq l r => l = r
  | and l r => (denote l) ∧ (denote r)
  | universal p => ∀ x, denote (p x)

@[simp] theorem denote_eq : denote (eq l r) = (l = r) := by rfl
@[simp] theorem denote_and : denote (and l r) = (denote l ∧ denote r) := by rfl
@[simp] theorem denote_universal : denote (universal p) = (∀ x, denote (p x)) := by rfl

def swapper : Formula → Formula
  | eq l r => eq r l
  | and l r => and r l
  | universal p => universal (fun x => swapper (p x))

@[simp] theorem swapper_eq : swapper (eq l r) = eq r l := by rfl
@[simp] theorem swapper_and : swapper (and l r) = and r l := by rfl
@[simp] theorem swapper_universal : swapper (universal p) = universal (fun x => swapper (p x)) := by rfl

theorem swapper_of_normal : ∀ f, (denote f) → denote (swapper f) := by
  intro f
  induction f <;> simp_all

end Formula

end Chapter3
end Cpdt


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import analysis.box_integral.partition.split
import analysis.normed_space.operator_norm

/-!
# Box additive functions

We say that a function `f : box ι → M` from boxes in `ℝⁿ` to a commutative additive monoid `M` is
*box additive* on subboxes of `I₀ : with_top (box ι)` if for any box `J`, `↑J ≤ I₀`, and a partition
`π` of `J`, `f J = ∑ J' in π.boxes, f J'`. We use `I₀ : with_top (box ι)` instead of `I₀ : box ι` to
use the same definition for functions box additive on subboxes of a box and for functions box
additive on all boxes.

Examples of box-additive functions include the measure of a box and the integral of a fixed
integrable function over a box.

In this file we define box-additive functions and prove that a function such that
`f J = f (J ∩ {x | x i < y}) + f (J ∩ {x | y ≤ x i})` is box-additive.

### Tags

rectangular box, additive function
-/

noncomputable theory
open_locale classical big_operators
open function set

namespace box_integral

variables {ι M : Type*} {n : ℕ}

/-- A function on `box ι` is called box additive if for every box `J` and a partition `π` of `J`
we have `f J = ∑ Ji in π.boxes, f Ji`. A function is called box additive on subboxes of `I : box ι`
if the same property holds for `J ≤ I`. We formalize these two notions in the same definition
using `I : with_bot (box ι)`: the value `I = ⊤` corresponds to functions box additive on the whole
space.  -/
structure box_additive_map (ι M : Type*) [add_comm_monoid M] (I : with_top (box ι)) :=
(to_fun : box ι → M)
(sum_partition_boxes' : ∀ J : box ι, ↑J ≤ I → ∀ π : prepartition J, π.is_partition →
  ∑ Ji in π.boxes, to_fun Ji = to_fun J)

localized "notation (name := box_integral.box_additive_map.top)
  ι ` →ᵇᵃ `:25 M := box_integral.box_additive_map ι M ⊤" in box_integral
localized "notation (name := box_integral.box_additive_map)
  ι ` →ᵇᵃ[`:25 I `] ` M := box_integral.box_additive_map ι M I" in box_integral

namespace box_additive_map

open box prepartition finset

variables {N : Type*} [add_comm_monoid M] [add_comm_monoid N] {I₀ : with_top (box ι)}
  {I J : box ι} {i : ι}

instance : has_coe_to_fun (ι →ᵇᵃ[I₀] M) (λ _, box ι → M) := ⟨to_fun⟩

initialize_simps_projections box_integral.box_additive_map (to_fun → apply)

@[simp] lemma to_fun_eq_coe (f : ι →ᵇᵃ[I₀] M) : f.to_fun = f := rfl

@[simp] lemma coe_mk (f h) : ⇑(mk f h : ι →ᵇᵃ[I₀] M) = f := rfl

lemma coe_injective : injective (λ (f : ι →ᵇᵃ[I₀] M) x, f x) :=
by { rintro ⟨f, hf⟩ ⟨g, hg⟩ (rfl : f = g), refl }

@[simp] lemma coe_inj {f g : ι →ᵇᵃ[I₀] M} : (f : box ι → M) = g ↔ f = g :=
coe_injective.eq_iff

lemma sum_partition_boxes (f : ι →ᵇᵃ[I₀] M) (hI : ↑I ≤ I₀) {π : prepartition I}
  (h : π.is_partition) :
  ∑ J in π.boxes, f J = f I :=
f.sum_partition_boxes' I hI π h

@[simps { fully_applied := ff }] instance : has_zero (ι →ᵇᵃ[I₀] M) :=
⟨⟨0, λ I hI π hπ, sum_const_zero⟩⟩

instance : inhabited (ι →ᵇᵃ[I₀] M) := ⟨0⟩

instance : has_add (ι →ᵇᵃ[I₀] M) :=
⟨λ f g, ⟨f + g, λ I hI π hπ,
  by simp only [pi.add_apply, sum_add_distrib, sum_partition_boxes _ hI hπ]⟩⟩

instance {R} [monoid R] [distrib_mul_action R M] : has_smul R (ι →ᵇᵃ[I₀] M) :=
⟨λ r f, ⟨r • f, λ I hI π hπ,
  by simp only [pi.smul_apply, ←smul_sum, sum_partition_boxes _ hI hπ]⟩⟩

instance : add_comm_monoid (ι →ᵇᵃ[I₀] M) :=
function.injective.add_comm_monoid _ coe_injective rfl (λ _ _, rfl) (λ _ _, rfl)

@[simp] lemma map_split_add (f : ι →ᵇᵃ[I₀] M) (hI : ↑I ≤ I₀) (i : ι) (x : ℝ) :
  (I.split_lower i x).elim 0 f + (I.split_upper i x).elim 0 f = f I :=
by rw [← f.sum_partition_boxes hI (is_partition_split I i x), sum_split_boxes]

/-- If `f` is box-additive on subboxes of `I₀`, then it is box-additive on subboxes of any
`I ≤ I₀`. -/
@[simps] def restrict (f : ι →ᵇᵃ[I₀] M) (I : with_top (box ι)) (hI : I ≤ I₀) : ι →ᵇᵃ[I] M :=
⟨f, λ J hJ, f.2 J (hJ.trans hI)⟩

/-- If `f : box ι → M` is box additive on partitions of the form `split I i x`, then it is box
additive. -/
def of_map_split_add [fintype ι] (f : box ι → M) (I₀ : with_top (box ι))
  (hf : ∀ I : box ι, ↑I ≤ I₀ → ∀ {i x}, x ∈ Ioo (I.lower i) (I.upper i) →
    (I.split_lower i x).elim 0 f + (I.split_upper i x).elim 0 f = f I) :
  ι →ᵇᵃ[I₀] M :=
begin
  refine ⟨f, _⟩,
  replace hf : ∀ I : box ι, ↑I ≤ I₀ → ∀ s, ∑ J in (split_many I s).boxes, f J = f I,
  { intros I hI s,
    induction s using finset.induction_on with a s ha ihs, { simp },
    rw [split_many_insert, inf_split, ← ihs, bUnion_boxes, sum_bUnion_boxes],
    refine finset.sum_congr rfl (λ J' hJ', _),
    by_cases h : a.2 ∈ Ioo (J'.lower a.1) (J'.upper a.1),
    { rw sum_split_boxes,
      exact hf _ ((with_top.coe_le_coe.2 $ le_of_mem _ hJ').trans hI) h },
    { rw [split_of_not_mem_Ioo h, top_boxes, finset.sum_singleton] } },
  intros I hI π hπ,
  have Hle : ∀ J ∈ π, ↑J ≤ I₀, from λ J hJ, (with_top.coe_le_coe.2 $ π.le_of_mem hJ).trans hI,
  rcases hπ.exists_split_many_le with ⟨s, hs⟩,
  rw [← hf _ hI, ← inf_of_le_right hs, inf_split_many, bUnion_boxes, sum_bUnion_boxes],
  exact finset.sum_congr rfl (λ J hJ, (hf _ (Hle _ hJ) _).symm)
end

/-- If `g : M → N` is an additive map and `f` is a box additive map, then `g ∘ f` is a box additive
map. -/
@[simps { fully_applied := ff }] def map (f : ι →ᵇᵃ[I₀] M) (g : M →+ N) :
  ι →ᵇᵃ[I₀] N :=
{ to_fun := g ∘ f,
  sum_partition_boxes' := λ I hI π hπ, by rw [← g.map_sum, f.sum_partition_boxes hI hπ] }

/-- If `f` is a box additive function on subboxes of `I` and `π₁`, `π₂` are two prepartitions of
`I` that cover the same part of `I`, then `∑ J in π₁.boxes, f J = ∑ J in π₂.boxes, f J`. -/
lemma sum_boxes_congr [finite ι] (f : ι →ᵇᵃ[I₀] M) (hI : ↑I ≤ I₀) {π₁ π₂ : prepartition I}
  (h : π₁.Union = π₂.Union) :
  ∑ J in π₁.boxes, f J = ∑ J in π₂.boxes, f J :=
begin
  rcases exists_split_many_inf_eq_filter_of_finite {π₁, π₂} ((finite_singleton _).insert _)
    with ⟨s, hs⟩, simp only [inf_split_many] at hs,
  rcases ⟨hs _ (or.inl rfl), hs _ (or.inr rfl)⟩ with ⟨h₁, h₂⟩, clear hs,
  rw h at h₁,
  calc ∑ J in π₁.boxes, f J = ∑ J in π₁.boxes, ∑ J' in (split_many J s).boxes, f J' :
    finset.sum_congr rfl (λ J hJ, (f.sum_partition_boxes _ (is_partition_split_many _ _)).symm)
  ... = ∑ J in (π₁.bUnion (λ J, split_many J s)).boxes, f J   : (sum_bUnion_boxes _ _ _).symm
  ... = ∑ J in (π₂.bUnion (λ J, split_many J s)).boxes, f J   : by rw [h₁, h₂]
  ... = ∑ J in π₂.boxes, ∑ J' in (split_many J s).boxes, f J' : sum_bUnion_boxes _ _ _
  ... = ∑ J in π₂.boxes, f J :
    finset.sum_congr rfl (λ J hJ, (f.sum_partition_boxes _ (is_partition_split_many _ _))),
  exacts [(with_top.coe_le_coe.2 $ π₁.le_of_mem hJ).trans hI,
    (with_top.coe_le_coe.2 $ π₂.le_of_mem hJ).trans hI]
end

section to_smul

variables {E : Type*} [normed_add_comm_group E] [normed_space ℝ E]

/-- If `f` is a box-additive map, then so is the map sending `I` to the scalar multiplication
by `f I` as a continuous linear map from `E` to itself. -/
def to_smul (f : ι →ᵇᵃ[I₀] ℝ) : ι →ᵇᵃ[I₀] (E →L[ℝ] E) :=
f.map (continuous_linear_map.lsmul ℝ ℝ).to_linear_map.to_add_monoid_hom

@[simp] lemma to_smul_apply (f : ι →ᵇᵃ[I₀] ℝ) (I : box ι) (x : E) : f.to_smul I x = f I • x := rfl

end to_smul

/-- Given a box `I₀` in `ℝⁿ⁺¹`, `f x : box (fin n) → G` is a family of functions indexed by a real
`x` and for `x ∈ [I₀.lower i, I₀.upper i]`, `f x` is box-additive on subboxes of the `i`-th face of
`I₀`, then `λ J, f (J.upper i) (J.face i) - f (J.lower i) (J.face i)` is box-additive on subboxes of
`I₀`. -/
@[simps] def {u} upper_sub_lower {G : Type u} [add_comm_group G]
  (I₀ : box (fin (n + 1))) (i : fin (n + 1)) (f : ℝ → box (fin n) → G)
  (fb : Icc (I₀.lower i) (I₀.upper i) → fin n →ᵇᵃ[I₀.face i] G)
  (hf : ∀ x (hx : x ∈ Icc (I₀.lower i) (I₀.upper i)) J, f x J = fb ⟨x, hx⟩ J) :
  fin (n + 1) →ᵇᵃ[I₀] G :=
of_map_split_add
  (λ J : box (fin (n + 1)), f (J.upper i) (J.face i) - f (J.lower i) (J.face i)) I₀
  begin
    intros J hJ j,
    rw with_top.coe_le_coe at hJ,
    refine i.succ_above_cases _ _ j,
    { intros x hx,
      simp only [box.split_lower_def hx, box.split_upper_def hx, update_same,
        ← with_bot.some_eq_coe, option.elim, box.face, (∘), update_noteq (fin.succ_above_ne _ _)],
      abel },
    { clear j, intros j x hx,
      have : (J.face i : with_top (box (fin n))) ≤ I₀.face i,
        from with_top.coe_le_coe.2 (face_mono hJ i),
      rw [le_iff_Icc, @box.Icc_eq_pi _ I₀] at hJ,
      rw [hf _ (hJ J.upper_mem_Icc _ trivial), hf _ (hJ J.lower_mem_Icc _ trivial),
        ← (fb _).map_split_add this j x, ← (fb _).map_split_add this j x],
      have hx' : x ∈ Ioo ((J.face i).lower j) ((J.face i).upper j) := hx,
      simp only [box.split_lower_def hx, box.split_upper_def hx,
        box.split_lower_def hx', box.split_upper_def hx',
        ← with_bot.some_eq_coe, option.elim, box.face_mk,
        update_noteq (fin.succ_above_ne _ _).symm, sub_add_sub_comm,
        update_comp_eq_of_injective _ i.succ_above.injective j x, ← hf],
      simp only [box.face] }
  end

end box_additive_map

end box_integral