/-
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.associated
import data.fintype.basic

/-!
# Some facts about finite rings
-/

open_locale classical

lemma card_units_lt (M₀ : Type*) [monoid_with_zero M₀] [nontrivial M₀] [fintype M₀] :
  fintype.card (units M₀) < fintype.card M₀ :=
fintype.card_lt_of_injective_of_not_mem (coe : units M₀ → M₀) units.ext not_is_unit_zero


import seminormed_rings
import ring_theory.adjoin.basic
--import field_theory.normal

open_locale nnreal

variables {R S : Type*} [comm_ring R] [comm_ring S] [algebra R S]

lemma is_pow_mult.restriction (A : subalgebra R S) {f : S → ℝ≥0} (hf_pm : is_pow_mult f) :
  is_pow_mult (λ x : A, (f x.val)) :=
λ x n hn, by simpa [subtype.val_eq_coe,subsemiring_class.coe_pow] using (hf_pm ↑x hn)

lemma is_algebra_norm.restriction (A : subalgebra R S) {g : R → ℝ≥0} (hg : is_norm g)
  {f : S → ℝ≥0} (hf_an : is_algebra_norm hg f) : is_algebra_norm hg (λ x : A, (f x.val)) :=
⟨⟨⟨hf_an.to_is_norm.to_is_seminorm.zero, λ x y, hf_an.to_is_norm.to_is_seminorm.add _ _,
    λ x y, hf_an.to_is_norm.to_is_seminorm.mul _ _⟩, λ x hx, (by {rw [ne.def,
      ← add_submonoid_class.coe_eq_zero] at hx, exact hf_an.to_is_norm.ne_zero _ hx})⟩,
     λ r x, hf_an.smul _ _⟩

-- Proposition 3.1.5/1
lemma eq_of_pow_mult_faithful {g : R → ℝ≥0} (hg : is_mul_norm g) {f₁ : S → ℝ≥0}
  (hf₁_pm : is_pow_mult f₁) (hf₁_an : is_algebra_norm (hg.to_is_norm) f₁) {f₂ : S → ℝ≥0}
  (hf₂_pm : is_pow_mult f₂) (hf₂_an : is_algebra_norm (hg.to_is_norm) f₂)
  (h_eq : ∀ (y : S), ∃ (C₁ C₂ : ℝ≥0) (hC₁ : 0 < C₁) (hC₂ : 0 < C₂), ∀ (x : (algebra.adjoin R {y})),
    f₁ x.val ≤ C₁ * (f₂ x.val) ∧ f₂ x.val ≤ C₂ * (f₁ x.val) ) :
  f₁ = f₂ :=
begin
  ext x,
  rw nnreal.coe_eq,
  set g₁ : algebra.adjoin R ({x} : set S) → ℝ≥0 := λ y, f₁ y.val with hg₁,
  set g₂ : algebra.adjoin R ({x} : set S) → ℝ≥0 := λ y, f₂ y.val with hg₂,
  have hg₁_s : is_seminorm g₁ :=
  (is_algebra_norm.restriction _ hg.to_is_norm hf₁_an).to_is_norm.to_is_seminorm,
  have hg₁_pm : is_pow_mult g₁ := is_pow_mult.restriction _ hf₁_pm,
  have hg₂_s : is_seminorm g₂ :=
  (is_algebra_norm.restriction _ hg.to_is_norm hf₂_an).to_is_norm.to_is_seminorm,
  have hg₂_pm : is_pow_mult g₂ := is_pow_mult.restriction _ hf₂_pm,
  let y : algebra.adjoin R ({x} : set S) := ⟨x, algebra.self_mem_adjoin_singleton R x⟩,
  have hy : x = y.val := rfl,
  have h1 : f₁ y.val = g₁ y := rfl,
  have h2 : f₂ y.val = g₂ y := rfl,
  obtain ⟨C₁, C₂, hC₁_pos, hC₂_pos, hC⟩ := h_eq x,
  obtain ⟨hC₁, hC₂⟩ := forall_and_distrib.mp hC,
  rw [hy, h1, h2, eq_seminorms hg₁_s hg₁_pm hg₂_s hg₂_pm ⟨C₁, hC₁_pos, hC₁⟩ ⟨C₂, hC₂_pos, hC₂⟩],
end


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

import ring_theory.polynomial.cyclotomic.basic
import number_theory.number_field
import algebra.char_p.algebra
import field_theory.galois

/-!
# Cyclotomic extensions

Let `A` and `B` be commutative rings with `algebra A B`. For `S : set ℕ+`, we define a class
`is_cyclotomic_extension S A B` expressing the fact that `B` is obtained from `A` by adding `n`-th
primitive roots of unity, for all `n ∈ S`.

## Main definitions

* `is_cyclotomic_extension S A B` : means that `B` is obtained from `A` by adding `n`-th primitive
  roots of unity, for all `n ∈ S`.
* `cyclotomic_field`: given `n : ℕ+` and a field `K`, we define `cyclotomic n K` as the splitting
  field of `cyclotomic n K`. If `n` is nonzero in `K`, it has the instance
  `is_cyclotomic_extension {n} K (cyclotomic_field n K)`.
* `cyclotomic_ring` : if `A` is a domain with fraction field `K` and `n : ℕ+`, we define
  `cyclotomic_ring n A K` as the `A`-subalgebra of `cyclotomic_field n K` generated by the roots of
  `X ^ n - 1`. If `n` is nonzero in `A`, it has the instance
  `is_cyclotomic_extension {n} A (cyclotomic_ring n A K)`.

## Main results

* `is_cyclotomic_extension.trans` : if `is_cyclotomic_extension S A B` and
  `is_cyclotomic_extension T B C`, then `is_cyclotomic_extension (S ∪ T) A C`.
* `is_cyclotomic_extension.union_right` : given `is_cyclotomic_extension (S ∪ T) A B`, then
  `is_cyclotomic_extension T (adjoin A { b : B | ∃ a : ℕ+, a ∈ S ∧ b ^ (a : ℕ) = 1 }) B`.
* `is_cyclotomic_extension.union_right` : given `is_cyclotomic_extension T A B` and `S ⊆ T`, then
  `is_cyclotomic_extension S A (adjoin A { b : B | ∃ a : ℕ+, a ∈ S ∧ b ^ (a : ℕ) = 1 })`.
* `is_cyclotomic_extension.finite` : if `S` is finite and `is_cyclotomic_extension S A B`, then
  `B` is a finite `A`-algebra.
* `is_cyclotomic_extension.number_field` : a finite cyclotomic extension of a number field is a
  number field.
* `is_cyclotomic_extension.splitting_field_X_pow_sub_one` : if `is_cyclotomic_extension {n} K L`
  and `ne_zero ((n : ℕ) : K)`, then `L` is the splitting field of `X ^ n - 1`.
* `is_cyclotomic_extension.splitting_field_cyclotomic` : if `is_cyclotomic_extension {n} K L`
  and `ne_zero ((n : ℕ) : K)`, then `L` is the splitting field of `cyclotomic n K`.

## Implementation details

Our definition of `is_cyclotomic_extension` is very general, to allow rings of any characteristic
and infinite extensions, but it will mainly be used in the case `S = {n}` with `(n : A) ≠ 0` (and
for integral domains).
All results are in the `is_cyclotomic_extension` namespace.
Note that some results, for example `is_cyclotomic_extension.trans`,
`is_cyclotomic_extension.finite`, `is_cyclotomic_extension.number_field`,
`is_cyclotomic_extension.finite_dimensional`, `is_cyclotomic_extension.is_galois` and
`cyclotomic_field.algebra_base` are lemmas, but they can be made local instances.

-/

open polynomial algebra finite_dimensional module set

open_locale big_operators

universes u v w z

variables (n : ℕ+) (S T : set ℕ+) (A : Type u) (B : Type v) (K : Type w) (L : Type z)
variables [comm_ring A] [comm_ring B] [algebra A B]
variables [field K] [field L] [algebra K L]

noncomputable theory

/-- Given an `A`-algebra `B` and `S : set ℕ+`, we define `is_cyclotomic_extension S A B` requiring
that `cyclotomic a A` has a root in `B` for all `a ∈ S` and that `B` is generated over `A` by the
roots of `X ^ n - 1`. -/
@[mk_iff] class is_cyclotomic_extension : Prop :=
(exists_root {a : ℕ+} (ha : a ∈ S) : ∃ r : B, aeval r (cyclotomic a A) = 0)
(adjoin_roots : ∀ (x : B), x ∈ adjoin A { b : B | ∃ a : ℕ+, a ∈ S ∧ b ^ (a : ℕ) = 1 })

namespace is_cyclotomic_extension

section basic

/-- A reformulation of `is_cyclotomic_extension` that uses `⊤`. -/
lemma iff_adjoin_eq_top : is_cyclotomic_extension S A B ↔
 (∀ (a : ℕ+), a ∈ S → ∃ r : B, aeval r (cyclotomic a A) = 0) ∧
 (adjoin A { b : B | ∃ a : ℕ+, a ∈ S ∧ b ^ (a : ℕ) = 1 } = ⊤) :=
⟨λ h, ⟨h.exists_root, algebra.eq_top_iff.2 h.adjoin_roots⟩, λ h, ⟨h.1, algebra.eq_top_iff.1 h.2⟩⟩

/-- A reformulation of `is_cyclotomic_extension` in the case `S` is a singleton. -/
lemma iff_singleton : is_cyclotomic_extension {n} A B ↔
 (∃ r : B, aeval r (cyclotomic n A) = 0) ∧
 (∀ x, x ∈ adjoin A { b : B | b ^ (n : ℕ) = 1 }) :=
by simp [is_cyclotomic_extension_iff]

/-- If `is_cyclotomic_extension ∅ A B`, then `A = B`. -/
lemma empty [h : is_cyclotomic_extension ∅ A B] : (⊥ : subalgebra A B) = ⊤ :=
by simpa [algebra.eq_top_iff, is_cyclotomic_extension_iff] using h

/-- Transitivity of cyclotomic extensions. -/
lemma trans (C : Type w) [comm_ring C] [algebra A C] [algebra B C]
  [is_scalar_tower A B C] [hS : is_cyclotomic_extension S A B]
  [hT : is_cyclotomic_extension T B C] : is_cyclotomic_extension (S ∪ T) A C :=
begin
  refine ⟨λ n hn, _, λ x, _⟩,
  { cases hn,
    { obtain ⟨b, hb⟩ := ((is_cyclotomic_extension_iff _ _ _).1 hS).1 hn,
      refine ⟨algebra_map B C b, _⟩,
      replace hb := congr_arg (algebra_map B C) hb,
      rw [aeval_def, eval₂_eq_eval_map, map_cyclotomic, ring_hom.map_zero, ← eval₂_at_apply,
        eval₂_eq_eval_map, map_cyclotomic] at hb,
      rwa [aeval_def, eval₂_eq_eval_map, map_cyclotomic] },
    { obtain ⟨c, hc⟩ := ((is_cyclotomic_extension_iff _ _ _).1 hT).1 hn,
      refine ⟨c, _⟩,
      rw [aeval_def, eval₂_eq_eval_map, map_cyclotomic] at hc,
      rwa [aeval_def, eval₂_eq_eval_map, map_cyclotomic] } },
  { refine adjoin_induction (((is_cyclotomic_extension_iff _ _ _).1 hT).2 x) (λ c ⟨n, hn⟩,
      subset_adjoin ⟨n, or.inr hn.1, hn.2⟩) (λ b, _) (λ x y hx hy, subalgebra.add_mem _ hx hy)
      (λ x y hx hy, subalgebra.mul_mem _ hx hy),
    { let f := is_scalar_tower.to_alg_hom A B C,
      have hb : f b ∈ (adjoin A { b : B | ∃ (a : ℕ+), a ∈ S ∧ b ^ (a : ℕ) = 1 }).map f :=
        ⟨b, ((is_cyclotomic_extension_iff _ _ _).1 hS).2 b, rfl⟩,
      rw [is_scalar_tower.to_alg_hom_apply, ← adjoin_image] at hb,
      refine adjoin_mono (λ y hy, _) hb,
      obtain ⟨b₁, ⟨⟨n, hn⟩, h₁⟩⟩ := hy,
      exact ⟨n, ⟨mem_union_left T hn.1, by rw [← h₁, ← alg_hom.map_pow, hn.2, alg_hom.map_one]⟩⟩ } }
end

/-- If `B` is a cyclotomic extension of `A` given by roots of unity of order in `S ∪ T`, then `B`
is a cyclotomic extension of `adjoin A { b : B | ∃ a : ℕ+, a ∈ S ∧ b ^ (a : ℕ) = 1 } ` given by
roots of unity of order in `T`. -/
lemma union_right [h : is_cyclotomic_extension (S ∪ T) A B] :
  is_cyclotomic_extension T (adjoin A { b : B | ∃ a : ℕ+, a ∈ S ∧ b ^ (a : ℕ) = 1 }) B :=
begin
  have : { b : B | ∃ (n : ℕ+), n ∈ S ∪ T ∧ b ^ (n : ℕ) = 1 } =
    { b : B | ∃ (n : ℕ+), n ∈ S ∧ b ^ (n : ℕ) = 1 } ∪
    { b : B | ∃ (n : ℕ+), n ∈ T ∧ b ^ (n : ℕ) = 1 },
  { refine le_antisymm (λ x hx, _) (λ x hx, _),
    { rcases hx with ⟨n, hn₁ | hn₂, hnpow⟩,
      { left, exact ⟨n, hn₁, hnpow⟩ },
      { right, exact ⟨n, hn₂, hnpow⟩ } },
    { rcases hx with ⟨n, hn⟩ | ⟨n, hn⟩,
      { exact ⟨n, or.inl hn.1, hn.2⟩ },
      { exact ⟨n, or.inr hn.1, hn.2⟩ } } },

  refine ⟨λ n hn, _, λ b, _⟩,
  { obtain ⟨b, hb⟩ := ((is_cyclotomic_extension_iff _ _ _).1 h).1 (mem_union_right S hn),
    refine ⟨b, _⟩,
    rw [aeval_def, eval₂_eq_eval_map, map_cyclotomic] at hb,
    rwa [aeval_def, eval₂_eq_eval_map, map_cyclotomic] },
  { replace h := ((is_cyclotomic_extension_iff _ _ _).1 h).2 b,
    rwa [this, adjoin_union_eq_adjoin_adjoin,
      subalgebra.mem_restrict_scalars] at h }
end

/-- If `B` is a cyclotomic extension of `A` given by roots of unity of order in `T` and `S ⊆ T`,
then `adjoin A { b : B | ∃ a : ℕ+, a ∈ S ∧ b ^ (a : ℕ) = 1 }` is a cyclotomic extension of `B`
given by roots of unity of order in `S`. -/
lemma union_left [h : is_cyclotomic_extension T A B] (hS : S ⊆ T) :
  is_cyclotomic_extension S A (adjoin A { b : B | ∃ a : ℕ+, a ∈ S ∧ b ^ (a : ℕ) = 1 }) :=
begin
  refine ⟨λ n hn, _, λ b, _⟩,
  { obtain ⟨b, hb⟩ := ((is_cyclotomic_extension_iff _ _ _).1 h).1 (hS hn),
    refine ⟨⟨b, subset_adjoin ⟨n, hn, _⟩⟩, _⟩,
    { rw [aeval_def, eval₂_eq_eval_map, map_cyclotomic, ← is_root.def] at hb,
      suffices : (X ^ (n : ℕ) - 1).is_root b,
      { simpa [sub_eq_zero] using this },
      exact hb.dvd (cyclotomic.dvd_X_pow_sub_one _ _) },
      rwa [← subalgebra.coe_eq_zero, aeval_subalgebra_coe, subtype.coe_mk] },
  { convert mem_top,
    rw [← adjoin_adjoin_coe_preimage, preimage_set_of_eq],
    norm_cast, }
end

end basic

section fintype

lemma finite_of_singleton [is_domain B] [h : is_cyclotomic_extension {n} A B] : finite A B :=
begin
  classical,
  rw [module.finite_def, ← top_to_submodule, ← ((iff_adjoin_eq_top _ _ _).1 h).2],
  refine fg_adjoin_of_finite _ (λ b hb, _),
  { simp only [mem_singleton_iff, exists_eq_left],
    have : {b : B | b ^ (n : ℕ) = 1} = (nth_roots n (1 : B)).to_finset :=
      set.ext (λ x, ⟨λ h, by simpa using h, λ h, by simpa using h⟩),
    rw [this],
    exact (nth_roots ↑n 1).to_finset.finite_to_set },
  { simp only [mem_singleton_iff, exists_eq_left, mem_set_of_eq] at hb,
    refine ⟨X ^ (n : ℕ) - 1, ⟨monic_X_pow_sub_C _ n.pos.ne.symm, by simp [hb]⟩⟩ }
end

/-- If `S` is finite and `is_cyclotomic_extension S A B`, then `B` is a finite `A`-algebra. -/
lemma finite [is_domain B] [h₁ : fintype S] [h₂ : is_cyclotomic_extension S A B] : finite A B :=
begin
  unfreezingI {revert h₂ A B},
  refine set.finite.induction_on (set.finite.intro h₁) (λ A B, _) (λ n S hn hS H A B, _),
  { introsI _ _ _ _ _,
    refine module.finite_def.2 ⟨({1} : finset B), _⟩,
    simp [← top_to_submodule, ← empty, to_submodule_bot] },
  { introsI _ _ _ _ h,
    haveI : is_cyclotomic_extension S A (adjoin A { b : B | ∃ (n : ℕ+),
      n ∈ S ∧ b ^ (n : ℕ) = 1 }) := union_left _ (insert n S) _ _ (subset_insert n S),
    haveI := H A (adjoin A { b : B | ∃ (n : ℕ+), n ∈ S ∧ b ^ (n : ℕ) = 1 }),
    haveI : finite (adjoin A { b : B | ∃ (n : ℕ+), n ∈ S ∧ b ^ (n : ℕ) = 1 }) B,
    { rw [← union_singleton] at h,
      letI := @union_right S {n} A B _ _ _ h,
      exact finite_of_singleton n _ _ },
    exact finite.trans (adjoin A { b : B | ∃ (n : ℕ+), n ∈ S ∧ b ^ (n : ℕ) = 1 }) _ }
end

/-- A cyclotomic finite extension of a number field is a number field. -/
lemma number_field [h : number_field K] [fintype S] [is_cyclotomic_extension S K L] :
  number_field L :=
{ to_char_zero := char_zero_of_injective_algebra_map (algebra_map K L).injective,
  to_finite_dimensional := @finite.trans _ K L _ _ _ _
    (@algebra_rat L _ (char_zero_of_injective_algebra_map (algebra_map K L).injective)) _ _
    h.to_finite_dimensional (finite S K L) }

/-- A finite cyclotomic extension of an integral noetherian domain is integral -/
lemma integral [is_domain B] [is_noetherian_ring A] [fintype S] [is_cyclotomic_extension S A B] :
  algebra.is_integral A B :=
is_integral_of_noetherian $ is_noetherian_of_fg_of_noetherian' $ (finite S A B).out

/-- If `S` is finite and `is_cyclotomic_extension S K A`, then `finite_dimensional K A`. -/
lemma finite_dimensional (C : Type z) [fintype S] [comm_ring C] [algebra K C] [is_domain C]
  [is_cyclotomic_extension S K C] : finite_dimensional K C :=
finite S K C

end fintype

section

variables {A B}

lemma adjoin_roots_cyclotomic_eq_adjoin_nth_roots [decidable_eq B] [is_domain B] {ζ : B}
  (hζ : is_primitive_root ζ n) :
  adjoin A ↑((map (algebra_map A B) (cyclotomic n A)).roots.to_finset) =
  adjoin A {b : B | ∃ (a : ℕ+), a ∈ ({n} : set ℕ+) ∧ b ^ (a : ℕ) = 1} :=
begin
  simp only [mem_singleton_iff, exists_eq_left, map_cyclotomic],
  refine le_antisymm (adjoin_mono (λ x hx, _)) (adjoin_le (λ x hx, _)),
  { simp only [multiset.mem_to_finset, finset.mem_coe,
               map_cyclotomic, mem_roots (cyclotomic_ne_zero n B)] at hx,
    simp only [mem_singleton_iff, exists_eq_left, mem_set_of_eq],
    rw is_root_of_unity_iff n.pos,
    exact ⟨n, nat.mem_divisors_self n n.ne_zero, hx⟩ },
  { simp only [mem_singleton_iff, exists_eq_left, mem_set_of_eq] at hx,
    obtain ⟨i, hin, rfl⟩ := hζ.eq_pow_of_pow_eq_one hx n.pos,
    refine set_like.mem_coe.2 (subalgebra.pow_mem _ (subset_adjoin _) _),
    rwa [finset.mem_coe, multiset.mem_to_finset, mem_roots $ cyclotomic_ne_zero n B],
    exact is_root_cyclotomic n.pos hζ }
end

lemma adjoin_roots_cyclotomic_eq_adjoin_root_cyclotomic [decidable_eq B] [is_domain B]
  (ζ : B) (hζ : is_primitive_root ζ n) :
  adjoin A (((map (algebra_map A B) (cyclotomic n A)).roots.to_finset) : set B) = adjoin A ({ζ}) :=
begin
  refine le_antisymm (adjoin_le (λ x hx, _)) (adjoin_mono (λ x hx, _)),
  { suffices hx : x ^ ↑n = 1,
    obtain ⟨i, hin, rfl⟩ := hζ.eq_pow_of_pow_eq_one hx n.pos,
    exact set_like.mem_coe.2 (subalgebra.pow_mem _ (subset_adjoin $ mem_singleton ζ) _),
    rw is_root_of_unity_iff n.pos,
    refine ⟨n, nat.mem_divisors_self n n.ne_zero, _⟩,
    rwa [finset.mem_coe, multiset.mem_to_finset,
         map_cyclotomic, mem_roots $ cyclotomic_ne_zero n B] at hx },
  { simp only [mem_singleton_iff, exists_eq_left, mem_set_of_eq] at hx,
    simpa only [hx, multiset.mem_to_finset, finset.mem_coe, map_cyclotomic,
                mem_roots (cyclotomic_ne_zero n B)] using is_root_cyclotomic n.pos hζ }
end

lemma adjoin_primitive_root_eq_top [is_domain B] [h : is_cyclotomic_extension {n} A B]
  (ζ : B) (hζ : is_primitive_root ζ n) : adjoin A ({ζ} : set B) = ⊤ :=
begin
  classical,
  rw ←adjoin_roots_cyclotomic_eq_adjoin_root_cyclotomic n ζ hζ,
  rw adjoin_roots_cyclotomic_eq_adjoin_nth_roots n hζ,
  exact ((iff_adjoin_eq_top {n} A B).mp h).2,
end

end

section field

variable [ne_zero ((n : ℕ) : K)]

/-- A cyclotomic extension splits `X ^ n - 1` if `n ∈ S` and `ne_zero (n : K)`.-/
lemma splits_X_pow_sub_one [H : is_cyclotomic_extension S K L] (hS : n ∈ S) :
  splits (algebra_map K L) (X ^ (n : ℕ) - 1) :=
begin
  rw [← splits_id_iff_splits, polynomial.map_sub, polynomial.map_one,
      polynomial.map_pow, polynomial.map_X],
  obtain ⟨z, hz⟩ := ((is_cyclotomic_extension_iff _ _ _).1 H).1 hS,
  rw [aeval_def, eval₂_eq_eval_map, map_cyclotomic] at hz,
  haveI := ne_zero.of_no_zero_smul_divisors K L n,
  exact X_pow_sub_one_splits (is_root_cyclotomic_iff.1 hz),
end

/-- A cyclotomic extension splits `cyclotomic n K` if `n ∈ S` and `ne_zero (n : K)`.-/
lemma splits_cyclotomic [is_cyclotomic_extension S K L] (hS : n ∈ S) :
  splits (algebra_map K L) (cyclotomic n K) :=
begin
  refine splits_of_splits_of_dvd _ (X_pow_sub_C_ne_zero n.pos _)
    (splits_X_pow_sub_one n S K L hS) _,
  use (∏ (i : ℕ) in (n : ℕ).proper_divisors, polynomial.cyclotomic i K),
  rw [(eq_cyclotomic_iff n.pos _).1 rfl, ring_hom.map_one],
end

section singleton

variables [is_cyclotomic_extension {n} K L]

/-- If `is_cyclotomic_extension {n} K L` and `ne_zero ((n : ℕ) : K)`, then `L` is the splitting
field of `X ^ n - 1`. -/
lemma splitting_field_X_pow_sub_one : is_splitting_field K L (X ^ (n : ℕ) - 1) :=
{ splits := splits_X_pow_sub_one n {n} K L (mem_singleton n),
  adjoin_roots :=
  begin
    rw [← ((iff_adjoin_eq_top {n} K L).1 infer_instance).2],
    congr,
    refine set.ext (λ x, _),
    simp only [polynomial.map_pow, mem_singleton_iff, multiset.mem_to_finset, exists_eq_left,
      mem_set_of_eq, polynomial.map_X, polynomial.map_one, finset.mem_coe, polynomial.map_sub],
    rwa [← ring_hom.map_one C, mem_roots (@X_pow_sub_C_ne_zero _ (field.to_nontrivial L) _ _
      n.pos _), is_root.def, eval_sub, eval_pow, eval_C, eval_X, sub_eq_zero]
  end }

include n

lemma is_galois : is_galois K L :=
begin
  letI := splitting_field_X_pow_sub_one n K L,
  exact is_galois.of_separable_splitting_field (X_pow_sub_one_separable_iff.2
    (ne_zero.ne _ : ((n : ℕ) : K) ≠ 0)),
end

/-- If `is_cyclotomic_extension {n} K L` and `ne_zero ((n : ℕ) : K)`, then `L` is the splitting
field of `cyclotomic n K`. -/
lemma splitting_field_cyclotomic : is_splitting_field K L (cyclotomic n K) :=
{ splits := splits_cyclotomic n {n} K L (mem_singleton n),
  adjoin_roots :=
  begin
    rw [← ((iff_adjoin_eq_top {n} K L).1 infer_instance).2],
    letI := classical.dec_eq L,
    obtain ⟨ζ, hζ⟩ := @is_cyclotomic_extension.exists_root {n} K L _ _ _ _ _ (mem_singleton n),
    haveI : ne_zero ((n : ℕ) : L) := ne_zero.nat_of_injective (algebra_map K L).injective,
    rw [aeval_def, eval₂_eq_eval_map, map_cyclotomic, ← is_root.def, is_root_cyclotomic_iff] at hζ,
    refine adjoin_roots_cyclotomic_eq_adjoin_nth_roots n hζ
  end }

end singleton

end field

end is_cyclotomic_extension

section cyclotomic_field

/-- Given `n : ℕ+` and a field `K`, we define `cyclotomic_field n K` as the
splitting field of `cyclotomic n K`. If `n` is nonzero in `K`, it has
the instance `is_cyclotomic_extension {n} K (cyclotomic_field n K)`. -/
@[derive [field, algebra K, inhabited]]
def cyclotomic_field : Type w := (cyclotomic n K).splitting_field

namespace cyclotomic_field

instance is_cyclotomic_extension [ne_zero ((n : ℕ) : K)] :
  is_cyclotomic_extension {n} K (cyclotomic_field n K) :=
{ exists_root := λ a han,
  begin
    rw mem_singleton_iff at han,
    subst a,
    exact exists_root_of_splits _ (splitting_field.splits _) (degree_cyclotomic_pos n K (n.pos)).ne'
  end,
  adjoin_roots :=
  begin
    rw [←algebra.eq_top_iff, ←splitting_field.adjoin_roots, eq_comm],
    letI := classical.dec_eq (cyclotomic_field n K),
    obtain ⟨ζ, hζ⟩ := exists_root_of_splits _ (splitting_field.splits (cyclotomic n K))
      (degree_cyclotomic_pos n _ n.pos).ne',
    haveI : ne_zero ((n : ℕ) : (cyclotomic_field n K)) :=
      ne_zero.nat_of_injective (algebra_map K _).injective,
    rw [eval₂_eq_eval_map, map_cyclotomic, ← is_root.def, is_root_cyclotomic_iff] at hζ,
    exact is_cyclotomic_extension.adjoin_roots_cyclotomic_eq_adjoin_nth_roots n hζ,
  end }

end cyclotomic_field

end cyclotomic_field

section is_domain

variables [is_domain A] [algebra A K] [is_fraction_ring A K]

section cyclotomic_ring

/-- If `K` is the fraction field of `A`, the `A`-algebra structure on `cyclotomic_field n K`.
This is not an instance since it causes diamonds when `A = ℤ`. -/
@[nolint unused_arguments]
def cyclotomic_field.algebra_base : algebra A (cyclotomic_field n K) :=
((algebra_map K (cyclotomic_field n K)).comp (algebra_map A K)).to_algebra

local attribute [instance] cyclotomic_field.algebra_base

instance cyclotomic_field.no_zero_smul_divisors : no_zero_smul_divisors A (cyclotomic_field n K) :=
no_zero_smul_divisors.of_algebra_map_injective $ function.injective.comp
(no_zero_smul_divisors.algebra_map_injective _ _) $ is_fraction_ring.injective A K

/-- If `A` is a domain with fraction field `K` and `n : ℕ+`, we define `cyclotomic_ring n A K` as
the `A`-subalgebra of `cyclotomic_field n K` generated by the roots of `X ^ n - 1`. If `n`
is nonzero in `A`, it has the instance `is_cyclotomic_extension {n} A (cyclotomic_ring n A K)`. -/
@[derive [comm_ring, is_domain, inhabited]]
def cyclotomic_ring : Type w := adjoin A { b : (cyclotomic_field n K) | b ^ (n : ℕ) = 1 }

namespace cyclotomic_ring

/-- The `A`-algebra structure on `cyclotomic_ring n A K`.
This is not an instance since it causes diamonds when `A = ℤ`. -/
def algebra_base : algebra A (cyclotomic_ring n A K) := (adjoin A _).algebra

local attribute [instance] cyclotomic_ring.algebra_base

instance : no_zero_smul_divisors A (cyclotomic_ring n A K) := (adjoin A _).no_zero_smul_divisors_bot

lemma algebra_base_injective : function.injective $ algebra_map A (cyclotomic_ring n A K) :=
no_zero_smul_divisors.algebra_map_injective _ _

instance : algebra (cyclotomic_ring n A K) (cyclotomic_field n K) :=
(adjoin A _).to_algebra

lemma adjoin_algebra_injective :
  function.injective $ algebra_map (cyclotomic_ring n A K) (cyclotomic_field n K) :=
subtype.val_injective

instance : no_zero_smul_divisors (cyclotomic_ring n A K) (cyclotomic_field n K) :=
no_zero_smul_divisors.of_algebra_map_injective (adjoin_algebra_injective n A K)

instance : is_scalar_tower A (cyclotomic_ring n A K) (cyclotomic_field n K) :=
is_scalar_tower.subalgebra' _ _ _ _

instance is_cyclotomic_extension [ne_zero ((n : ℕ) : A)] :
  is_cyclotomic_extension {n} A (cyclotomic_ring n A K) :=
{ exists_root := λ a han,
  begin
    rw mem_singleton_iff at han,
    subst a,
    haveI := ne_zero.of_no_zero_smul_divisors A K n,
    haveI := ne_zero.of_no_zero_smul_divisors A (cyclotomic_ring n A K) n,
    haveI := ne_zero.of_no_zero_smul_divisors A (cyclotomic_field n K) n,
    obtain ⟨μ, hμ⟩ := let h := (cyclotomic_field.is_cyclotomic_extension n K).exists_root
                      in h $ mem_singleton n,
    refine ⟨⟨μ, subset_adjoin _⟩, _⟩,
    { apply (is_root_of_unity_iff n.pos (cyclotomic_field n K)).mpr,
      refine ⟨n, nat.mem_divisors_self _ n.ne_zero, _⟩,
      rwa [aeval_def, eval₂_eq_eval_map, map_cyclotomic] at hμ },
    simp_rw [aeval_def, eval₂_eq_eval_map,
      map_cyclotomic, ←is_root.def, is_root_cyclotomic_iff] at hμ ⊢,
    rwa ←is_primitive_root.map_iff_of_injective (adjoin_algebra_injective n A K)
  end,
  adjoin_roots := λ x,
  begin
    refine adjoin_induction' (λ y hy, _) (λ a, _) (λ y z hy hz, _) (λ y z hy hz, _) x,
    { refine subset_adjoin _,
      simp only [mem_singleton_iff, exists_eq_left, mem_set_of_eq],
      rwa [← subalgebra.coe_eq_one, subalgebra.coe_pow, subtype.coe_mk] },
    { exact subalgebra.algebra_map_mem _ a },
    { exact subalgebra.add_mem _ hy hz },
    { exact subalgebra.mul_mem _ hy hz },
  end }

instance [ne_zero ((n : ℕ) : A)] :
  is_fraction_ring (cyclotomic_ring n A K) (cyclotomic_field n K) :=
{ map_units := λ ⟨x, hx⟩, begin
    rw is_unit_iff_ne_zero,
    apply map_ne_zero_of_mem_non_zero_divisors,
    apply adjoin_algebra_injective,
    exact hx
  end,
  surj := λ x,
  begin
    letI : ne_zero ((n : ℕ) : K) := ne_zero.nat_of_injective (is_fraction_ring.injective A K),
    refine algebra.adjoin_induction (((is_cyclotomic_extension.iff_singleton n K _).1
      (cyclotomic_field.is_cyclotomic_extension n K)).2 x) (λ y hy, _) (λ k, _) _ _,
    { exact ⟨⟨⟨y, subset_adjoin hy⟩, 1⟩, by simpa⟩ },
    { have : is_localization (non_zero_divisors A) K := infer_instance,
      replace := this.surj,
      obtain ⟨⟨z, w⟩, hw⟩ := this k,
      refine ⟨⟨algebra_map A _ z, algebra_map A _ w, map_mem_non_zero_divisors _
        (algebra_base_injective n A K) w.2⟩, _⟩,
      letI : is_scalar_tower A K (cyclotomic_field n K) :=
        is_scalar_tower.of_algebra_map_eq (congr_fun rfl),
      rw [set_like.coe_mk, ← is_scalar_tower.algebra_map_apply,
        ← is_scalar_tower.algebra_map_apply, @is_scalar_tower.algebra_map_apply A K _ _ _ _ _
        (_root_.cyclotomic_field.algebra n K) _ _ w, ← ring_hom.map_mul, hw,
        ← is_scalar_tower.algebra_map_apply] },
    { rintro y z ⟨a, ha⟩ ⟨b, hb⟩,
      refine ⟨⟨a.1 * b.2 + b.1 * a.2, a.2 * b.2, mul_mem_non_zero_divisors.2 ⟨a.2.2, b.2.2⟩⟩, _⟩,
      rw [set_like.coe_mk, ring_hom.map_mul, add_mul, ← mul_assoc, ha,
        mul_comm ((algebra_map _ _) ↑a.2), ← mul_assoc, hb],
      simp },
    { rintro y z ⟨a, ha⟩ ⟨b, hb⟩,
      refine ⟨⟨a.1 * b.1, a.2 * b.2, mul_mem_non_zero_divisors.2 ⟨a.2.2, b.2.2⟩⟩, _⟩,
      rw [set_like.coe_mk, ring_hom.map_mul, mul_comm ((algebra_map _ _) ↑a.2), mul_assoc,
        ← mul_assoc z, hb, ← mul_comm ((algebra_map _ _) ↑a.2), ← mul_assoc, ha],
      simp }
  end,
  eq_iff_exists := λ x y, ⟨λ h, ⟨1, by rw adjoin_algebra_injective n A K h⟩,
    λ ⟨c, hc⟩, by rw mul_right_cancel₀ (non_zero_divisors.ne_zero c.prop) hc⟩ }

lemma eq_adjoin_primitive_root {μ : (cyclotomic_field n K)} (h : is_primitive_root μ n) :
  cyclotomic_ring n A K = adjoin A ({μ} : set ((cyclotomic_field n K))) :=
begin
  letI := classical.prop_decidable,
  rw [←is_cyclotomic_extension.adjoin_roots_cyclotomic_eq_adjoin_root_cyclotomic n μ h,
      is_cyclotomic_extension.adjoin_roots_cyclotomic_eq_adjoin_nth_roots n h],
  simp [cyclotomic_ring]
end

end cyclotomic_ring

end cyclotomic_ring

end is_domain


import ground_zero.HITs.interval

namespace ground_zero.types

universes u v t

namespace product
  variables {α : Sort u} {β : Sort v}

  def elim {γ : Sort t} (g : α → β → γ) (x : α × β) : γ :=
  g x.pr₁ x.pr₂

  def uniq : Π (x : α × β), (intro x.pr₁ x.pr₂) = x :> (α × β)
  | (intro a b) := eq.refl (intro a b)

  def construction (a b : α) (c d : β)
    (p : a = b :> α) (q : c = d :> β) :
    ⟨a, c⟩ = ⟨b, d⟩ :> α × β :=
  begin induction p, induction q, reflexivity end

  abbreviation prod {α : Type u} {β : Type v} {a b : α} {c d : β}
    (p : a = b :> α) (q : c = d :> β) :
    ⟨a, c⟩ = ⟨b, d⟩ :> α × β :=
  construction a b c d p q

  def ind {π : α × β → Type t} (g : Π (x : α) (y : β), π (intro x y)) :
    Π (x : α × β), π x
  | (intro a b) := g a b

  def univ {ν : Type t} : (ν → α × β) ≃ (ν → α) × (ν → β) := begin
    let e₁ : (ν → α × β) → (ν → α) × (ν → β) :=
    λ f, intro (pr₁ ∘ f) (pr₂ ∘ f),
    let e₂ : (ν → α) × (ν → β) → (ν → α × β) :=
    λ f x, intro (f.pr₁ x) (f.pr₂ x),
    existsi e₁, split; existsi e₂,
    { simp [equiv.homotopy], intro f, apply ground_zero.HITs.interval.funext,
      simp [e₁, e₂], intro x, simp, apply product.uniq },
    { simp [equiv.homotopy], intro x,
      cases x with f g, simp }
  end

  def bimap {γ δ : Sort v} (f : α → γ) (g : β → δ) :
    α × β → γ × δ
  | (intro a b) := intro (f a) (g b)

  def swap : α × β → β × α
  | (intro a b) := intro b a

  theorem comm : α × β ≃ β × α := begin
    existsi swap, split; existsi swap,
    repeat { intro x, induction x with a b, simp [swap] }
  end

  instance {α : Type u} {β : Type v}
    [has_one α] [has_one β] : has_one (α × β) :=
  ⟨intro 1 1⟩
end product

end ground_zero.types


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

! This file was ported from Lean 3 source module combinatorics.set_family.harris_kleitman
! leanprover-community/mathlib commit b363547b3113d350d053abdf2884e9850a56b205
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Combinatorics.SetFamily.Compression.Down
import Mathlib.Order.UpperLower.Basic
import Mathlib.Data.Fintype.BigOperators

/-!
# Harris-Kleitman inequality

This file proves the Harris-Kleitman inequality. This relates `𝒜.card * ℬ.card` and
`2 ^ card α * (𝒜 ∩ ℬ).card` where `𝒜` and `ℬ` are upward- or downcard-closed finite families of
finsets. This can be interpreted as saying that any two lower sets (resp. any two upper sets)
correlate in the uniform measure.

## Main declarations

* `IsLowerSet.le_card_inter_finset`: One form of the Harris-Kleitman inequality.

## References

* [D. J. Kleitman, *Families of non-disjoint subsets*][kleitman1966]
-/

open Finset

open BigOperators

variable {α : Type _} [DecidableEq α] {𝒜 ℬ : Finset (Finset α)} {s : Finset α} {a : α}

theorem IsLowerSet.nonMemberSubfamily (h : IsLowerSet (𝒜 : Set (Finset α))) :
    IsLowerSet (𝒜.nonMemberSubfamily a : Set (Finset α)) := fun s t hts => by
  simp_rw [mem_coe, mem_nonMemberSubfamily]
  exact And.imp (h hts) (mt <| @hts _)
#align is_lower_set.non_member_subfamily IsLowerSet.nonMemberSubfamily

theorem IsLowerSet.memberSubfamily (h : IsLowerSet (𝒜 : Set (Finset α))) :
    IsLowerSet (𝒜.memberSubfamily a : Set (Finset α)) := by
  rintro s t hts
  simp_rw [mem_coe, mem_memberSubfamily]
  exact And.imp (h <| insert_subset_insert _ hts) (mt <| @hts _)
#align is_lower_set.member_subfamily IsLowerSet.memberSubfamily

theorem IsLowerSet.memberSubfamily_subset_nonMemberSubfamily (h : IsLowerSet (𝒜 : Set (Finset α))) :
    𝒜.memberSubfamily a ⊆ 𝒜.nonMemberSubfamily a := fun s => by
  rw [mem_memberSubfamily, mem_nonMemberSubfamily]
  exact And.imp_left (h <| subset_insert _ _)
#align is_lower_set.member_subfamily_subset_non_member_subfamily
    IsLowerSet.memberSubfamily_subset_nonMemberSubfamily

/-- **Harris-Kleitman inequality**: Any two lower sets of finsets correlate. -/
theorem IsLowerSet.le_card_inter_finset' (h𝒜 : IsLowerSet (𝒜 : Set (Finset α)))
    (hℬ : IsLowerSet (ℬ : Set (Finset α))) (h𝒜s : ∀ t ∈ 𝒜, t ⊆ s) (hℬs : ∀ t ∈ ℬ, t ⊆ s) :
    𝒜.card * ℬ.card ≤ 2 ^ s.card * (𝒜 ∩ ℬ).card := by
  induction' s using Finset.induction with a s hs ih generalizing 𝒜 ℬ
  · simp_rw [subset_empty, ← subset_singleton_iff', subset_singleton_iff] at h𝒜s hℬs
    obtain rfl | rfl := h𝒜s
    · simp only [card_empty, empty_inter, mul_zero, zero_mul]
    obtain rfl | rfl := hℬs
    · simp only [card_empty, inter_empty, mul_zero, zero_mul]
    · simp only [card_empty, pow_zero, inter_singleton_of_mem, mem_singleton, card_singleton]
  rw [card_insert_of_not_mem hs, ← card_memberSubfamily_add_card_nonMemberSubfamily a 𝒜, ←
    card_memberSubfamily_add_card_nonMemberSubfamily a ℬ, add_mul, mul_add, mul_add,
    add_comm (_ * _), add_add_add_comm]
  refine'
    (add_le_add_right
          (mul_add_mul_le_mul_add_mul
              (card_le_of_subset h𝒜.memberSubfamily_subset_nonMemberSubfamily) <|
            card_le_of_subset hℬ.memberSubfamily_subset_nonMemberSubfamily)
          _).trans
      _
  rw [← two_mul, pow_succ, mul_assoc]
  have h₀ :
    ∀ 𝒞 : Finset (Finset α), (∀ t ∈ 𝒞, t ⊆ insert a s) → ∀ t ∈ 𝒞.nonMemberSubfamily a, t ⊆ s :=
    by
    rintro 𝒞 h𝒞 t ht
    rw [mem_nonMemberSubfamily] at ht
    exact (subset_insert_iff_of_not_mem ht.2).1 (h𝒞 _ ht.1)
  have h₁ : ∀ 𝒞 : Finset (Finset α), (∀ t ∈ 𝒞, t ⊆ insert a s) → ∀ t ∈ 𝒞.memberSubfamily a, t ⊆ s
    :=
    by
    rintro 𝒞 h𝒞 t ht
    rw [mem_memberSubfamily] at ht
    exact (subset_insert_iff_of_not_mem ht.2).1 ((subset_insert _ _).trans <| h𝒞 _ ht.1)
  refine' mul_le_mul_left' _ _
  refine'
    (add_le_add (ih h𝒜.memberSubfamily hℬ.memberSubfamily (h₁ _ h𝒜s) <| h₁ _ hℬs) <|
          ih h𝒜.nonMemberSubfamily hℬ.nonMemberSubfamily (h₀ _ h𝒜s) <| h₀ _ hℬs).trans_eq
      _
  rw [← mul_add, ← memberSubfamily_inter, ← nonMemberSubfamily_inter,
    card_memberSubfamily_add_card_nonMemberSubfamily]
#align is_lower_set.le_card_inter_finset' IsLowerSet.le_card_inter_finset'

variable [Fintype α]

/-- **Harris-Kleitman inequality**: Any two lower sets of finsets correlate. -/
theorem IsLowerSet.le_card_inter_finset (h𝒜 : IsLowerSet (𝒜 : Set (Finset α)))
    (hℬ : IsLowerSet (ℬ : Set (Finset α))) : 𝒜.card * ℬ.card ≤ 2 ^ Fintype.card α * (𝒜 ∩ ℬ).card
    := h𝒜.le_card_inter_finset' hℬ (fun _ _ => subset_univ _) fun _ _ => subset_univ _
#align is_lower_set.le_card_inter_finset IsLowerSet.le_card_inter_finset

/-- **Harris-Kleitman inequality**: Upper sets and lower sets of finsets anticorrelate. -/
theorem IsUpperSet.card_inter_le_finset (h𝒜 : IsUpperSet (𝒜 : Set (Finset α)))
    (hℬ : IsLowerSet (ℬ : Set (Finset α))) : 2 ^ Fintype.card α * (𝒜 ∩ ℬ).card ≤ 𝒜.card * ℬ.card
  :=
  by
  rw [← isLowerSet_compl, ← coe_compl] at h𝒜
  have := h𝒜.le_card_inter_finset hℬ
  rwa [card_compl, Fintype.card_finset, tsub_mul, tsub_le_iff_tsub_le, ← mul_tsub, ←
    card_sdiff (inter_subset_right _ _), sdiff_inter_self_right, sdiff_compl,
    _root_.inf_comm] at this
#align is_upper_set.card_inter_le_finset IsUpperSet.card_inter_le_finset

/-- **Harris-Kleitman inequality**: Lower sets and upper sets of finsets anticorrelate. -/
theorem IsLowerSet.card_inter_le_finset (h𝒜 : IsLowerSet (𝒜 : Set (Finset α)))
    (hℬ : IsUpperSet (ℬ : Set (Finset α))) : 2 ^ Fintype.card α * (𝒜 ∩ ℬ).card ≤ 𝒜.card * ℬ.card
  :=
  by
  rw [inter_comm, mul_comm 𝒜.card]
  exact hℬ.card_inter_le_finset h𝒜
#align is_lower_set.card_inter_le_finset IsLowerSet.card_inter_le_finset

/-- **Harris-Kleitman inequality**: Any two upper sets of finsets correlate. -/
theorem IsUpperSet.le_card_inter_finset (h𝒜 : IsUpperSet (𝒜 : Set (Finset α)))
    (hℬ : IsUpperSet (ℬ : Set (Finset α))) : 𝒜.card * ℬ.card ≤ 2 ^ Fintype.card α * (𝒜 ∩ ℬ).card
  :=
  by
  rw [← isLowerSet_compl, ← coe_compl] at h𝒜
  have := h𝒜.card_inter_le_finset hℬ
  rwa [card_compl, Fintype.card_finset, tsub_mul, le_tsub_iff_le_tsub, ← mul_tsub, ←
    card_sdiff (inter_subset_right _ _), sdiff_inter_self_right, sdiff_compl,
    _root_.inf_comm] at this
  · exact mul_le_mul_left' (card_le_of_subset <| inter_subset_right _ _) _
  · rw [← Fintype.card_finset]
    exact mul_le_mul_right' (card_le_univ _) _
#align is_upper_set.le_card_inter_finset IsUpperSet.le_card_inter_finset


/-
Copyright (c) 2023 David Loeffler. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: David Loeffler

! This file was ported from Lean 3 source module analysis.special_functions.trigonometric.euler_sine_prod
! leanprover-community/mathlib commit 980755c33b9168bc82f774f665eaa27878140fac
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Real.Pi.Wallis
import Mathbin.MeasureTheory.Integral.PeakFunction

/-! # Euler's infinite product for the sine function

This file proves the infinite product formula

$$ \sin \pi z = \pi z \prod_{n = 1}^\infty \left(1 - \frac{z ^ 2}{n ^ 2}\right) $$

for any real or complex `z`. Our proof closely follows the article
[Salwinski, *Euler's Sine Product Formula: An Elementary Proof*][salwinski2018]: the basic strategy
is to prove a recurrence relation for the integrals `∫ x in 0..π/2, cos 2 z x * cos x ^ (2 * n)`,
generalising the arguments used to prove Wallis' limit formula for `π`.
-/

open Real Topology BigOperators

open Real Set Filter intervalIntegral MeasureTheory.MeasureSpace

namespace EulerSine

section IntegralRecursion

/-! ## Recursion formula for the integral of `cos (2 * z * x) * cos x ^ n`

We evaluate the integral of `cos (2 * z * x) * cos x ^ n`, for any complex `z` and even integers
`n`, via repeated integration by parts. -/

variable {z : ℂ} {n : ℕ}

theorem antideriv_cos_comp_const_mul (hz : z ≠ 0) (x : ℝ) :
    HasDerivAt (fun y : ℝ => Complex.sin (2 * z * y) / (2 * z)) (Complex.cos (2 * z * x)) x :=
  by
  have a : HasDerivAt _ _ ↑x := hasDerivAt_mul_const _
  have b : HasDerivAt (fun y : ℂ => Complex.sin (y * (2 * z))) _ ↑x :=
    HasDerivAt.comp x (Complex.hasDerivAt_sin (x * (2 * z))) a
  convert b.comp_of_real.div_const (2 * z)
  · ext1 x
    rw [mul_comm _ (2 * z)]
  · field_simp
    rw [mul_comm _ (2 * z)]
#align euler_sine.antideriv_cos_comp_const_mul EulerSine.antideriv_cos_comp_const_mul

theorem antideriv_sin_comp_const_mul (hz : z ≠ 0) (x : ℝ) :
    HasDerivAt (fun y : ℝ => -Complex.cos (2 * z * y) / (2 * z)) (Complex.sin (2 * z * x)) x :=
  by
  have a : HasDerivAt _ _ ↑x := hasDerivAt_mul_const _
  have b : HasDerivAt (fun y : ℂ => Complex.cos (y * (2 * z))) _ ↑x :=
    HasDerivAt.comp x (Complex.hasDerivAt_cos (x * (2 * z))) a
  convert(b.comp_of_real.div_const (2 * z)).neg
  · ext1 x
    rw [mul_comm _ (2 * z)]
    field_simp
  · field_simp
    rw [mul_comm _ (2 * z)]
#align euler_sine.antideriv_sin_comp_const_mul EulerSine.antideriv_sin_comp_const_mul

theorem integral_cos_mul_cos_pow_aux (hn : 2 ≤ n) (hz : z ≠ 0) :
    (∫ x : ℝ in 0 ..π / 2, Complex.cos (2 * z * x) * cos x ^ n) =
      n / (2 * z) * ∫ x : ℝ in 0 ..π / 2, Complex.sin (2 * z * x) * sin x * cos x ^ (n - 1) :=
  by
  have der1 :
    ∀ x : ℝ,
      x ∈ uIcc 0 (π / 2) →
        HasDerivAt (fun y => ↑(cos y) ^ n : ℝ → ℂ) (-n * sin x * cos x ^ (n - 1)) x :=
    by
    intro x hx
    have b : HasDerivAt (fun y => ↑(cos y) : ℝ → ℂ) (-sin x) x := by
      simpa using (has_deriv_at_cos x).of_real_comp
    convert HasDerivAt.comp x (hasDerivAt_pow _ _) b using 1
    ring
  convert integral_mul_deriv_eq_deriv_mul der1 (fun x hx => antideriv_cos_comp_const_mul hz x) _ _
  · ext1 x
    rw [mul_comm]
  · rw [Complex.ofReal_zero, MulZeroClass.mul_zero, Complex.sin_zero, zero_div,
      MulZeroClass.mul_zero, sub_zero, cos_pi_div_two, Complex.ofReal_zero,
      zero_pow (by positivity : 0 < n), MulZeroClass.zero_mul, zero_sub, ← integral_neg, ←
      integral_const_mul]
    refine' integral_congr fun x hx => _
    field_simp
    ring
  · apply Continuous.intervalIntegrable
    exact
      (continuous_const.mul (complex.continuous_of_real.comp continuous_sin)).mul
        ((complex.continuous_of_real.comp continuous_cos).pow (n - 1))
  · apply Continuous.intervalIntegrable
    exact complex.continuous_cos.comp (continuous_const.mul Complex.continuous_of_real)
#align euler_sine.integral_cos_mul_cos_pow_aux EulerSine.integral_cos_mul_cos_pow_aux

theorem integral_sin_mul_sin_mul_cos_pow_eq (hn : 2 ≤ n) (hz : z ≠ 0) :
    (∫ x : ℝ in 0 ..π / 2, Complex.sin (2 * z * x) * sin x * cos x ^ (n - 1)) =
      (n / (2 * z) * ∫ x : ℝ in 0 ..π / 2, Complex.cos (2 * z * x) * cos x ^ n) -
        (n - 1) / (2 * z) * ∫ x : ℝ in 0 ..π / 2, Complex.cos (2 * z * x) * cos x ^ (n - 2) :=
  by
  have der1 :
    ∀ x : ℝ,
      x ∈ uIcc 0 (π / 2) →
        HasDerivAt (fun y => sin y * cos y ^ (n - 1) : ℝ → ℂ)
          (cos x ^ n - (n - 1) * sin x ^ 2 * cos x ^ (n - 2)) x :=
    by
    intro x hx
    have c := HasDerivAt.comp (x : ℂ) (hasDerivAt_pow (n - 1) _) (Complex.hasDerivAt_cos x)
    convert((Complex.hasDerivAt_sin x).mul c).comp_of_real using 1
    · ext1 y
      simp only [Complex.ofReal_sin, Complex.ofReal_cos]
    · simp only [Complex.ofReal_cos, Complex.ofReal_sin]
      rw [mul_neg, mul_neg, ← sub_eq_add_neg, Function.comp_apply]
      congr 1
      · rw [← pow_succ, Nat.sub_add_cancel (by linarith : 1 ≤ n)]
      · have : ((n - 1 : ℕ) : ℂ) = (n : ℂ) - 1 := by
          rw [Nat.cast_sub (one_le_two.trans hn), Nat.cast_one]
        rw [Nat.sub_sub, this]
        ring
  convert integral_mul_deriv_eq_deriv_mul der1 (fun x hx => antideriv_sin_comp_const_mul hz x) _
      _ using
    1
  · refine' integral_congr fun x hx => _
    ring_nf
  · -- now a tedious rearrangement of terms
    -- gather into a single integral, and deal with continuity subgoals:
    rw [sin_zero, cos_pi_div_two, Complex.ofReal_zero, zero_pow, MulZeroClass.zero_mul,
      MulZeroClass.mul_zero, MulZeroClass.zero_mul, MulZeroClass.zero_mul, sub_zero, zero_sub, ←
      integral_neg, ← integral_const_mul, ← integral_const_mul, ← integral_sub]
    rotate_left
    · apply Continuous.intervalIntegrable
      exact
        continuous_const.mul
          ((complex.continuous_cos.comp (continuous_const.mul Complex.continuous_of_real)).mul
            ((complex.continuous_of_real.comp continuous_cos).pow n))
    · apply Continuous.intervalIntegrable
      exact
        continuous_const.mul
          ((complex.continuous_cos.comp (continuous_const.mul Complex.continuous_of_real)).mul
            ((complex.continuous_of_real.comp continuous_cos).pow (n - 2)))
    · apply Nat.sub_pos_of_lt
      exact one_lt_two.trans_le hn
    refine' integral_congr fun x hx => _
    dsimp only
    -- get rid of real trig functions and divions by 2 * z:
    rw [Complex.ofReal_cos, Complex.ofReal_sin, Complex.sin_sq, ← mul_div_right_comm, ←
      mul_div_right_comm, ← sub_div, mul_div, ← neg_div]
    congr 1
    have : Complex.cos ↑x ^ n = Complex.cos ↑x ^ (n - 2) * Complex.cos ↑x ^ 2 := by
      conv_lhs => rw [← Nat.sub_add_cancel hn, pow_add]
    rw [this]
    ring
  · apply Continuous.intervalIntegrable
    exact
      ((complex.continuous_of_real.comp continuous_cos).pow n).sub
        ((continuous_const.mul ((complex.continuous_of_real.comp continuous_sin).pow 2)).mul
          ((complex.continuous_of_real.comp continuous_cos).pow (n - 2)))
  · apply Continuous.intervalIntegrable
    exact complex.continuous_sin.comp (continuous_const.mul Complex.continuous_of_real)
#align euler_sine.integral_sin_mul_sin_mul_cos_pow_eq EulerSine.integral_sin_mul_sin_mul_cos_pow_eq

/-- Note this also holds for `z = 0`, but we do not need this case for `sin_pi_mul_eq`.  -/
theorem integral_cos_mul_cos_pow (hn : 2 ≤ n) (hz : z ≠ 0) :
    ((1 - 4 * z ^ 2 / n ^ 2) * ∫ x : ℝ in 0 ..π / 2, Complex.cos (2 * z * x) * cos x ^ n) =
      (n - 1 : ℂ) / n * ∫ x : ℝ in 0 ..π / 2, Complex.cos (2 * z * x) * cos x ^ (n - 2) :=
  by
  have nne : (n : ℂ) ≠ 0 := by
    contrapose! hn
    rw [Nat.cast_eq_zero] at hn
    rw [hn]
    exact zero_lt_two
  have := integral_cos_mul_cos_pow_aux hn hz
  rw [integral_sin_mul_sin_mul_cos_pow_eq hn hz, sub_eq_neg_add, mul_add, ← sub_eq_iff_eq_add] at
    this
  convert congr_arg (fun u : ℂ => -u * (2 * z) ^ 2 / n ^ 2) this using 1 <;>
    · field_simp
      ring
#align euler_sine.integral_cos_mul_cos_pow EulerSine.integral_cos_mul_cos_pow

/-- Note this also holds for `z = 0`, but we do not need this case for `sin_pi_mul_eq`. -/
theorem integral_cos_mul_cos_pow_even (n : ℕ) (hz : z ≠ 0) :
    ((1 - z ^ 2 / (n + 1) ^ 2) *
        ∫ x : ℝ in 0 ..π / 2, Complex.cos (2 * z * x) * cos x ^ (2 * n + 2)) =
      (2 * n + 1 : ℂ) / (2 * n + 2) *
        ∫ x : ℝ in 0 ..π / 2, Complex.cos (2 * z * x) * cos x ^ (2 * n) :=
  by
  convert integral_cos_mul_cos_pow (by linarith : 2 ≤ 2 * n + 2) hz using 3
  · simp only [Nat.cast_add, Nat.cast_mul, Nat.cast_two]
    nth_rw_rhs 3 [← mul_one (2 : ℂ)]
    rw [← mul_add, mul_pow, ← div_div]
    ring
  · push_cast
    ring
  · push_cast
    ring
#align euler_sine.integral_cos_mul_cos_pow_even EulerSine.integral_cos_mul_cos_pow_even

/-- Relate the integral `cos x ^ n` over `[0, π/2]` to the integral of `sin x ^ n` over `[0, π]`,
which is studied in `data.real.pi.wallis` and other places. -/
theorem integral_cos_pow_eq (n : ℕ) :
    (∫ x : ℝ in 0 ..π / 2, cos x ^ n) = 1 / 2 * ∫ x : ℝ in 0 ..π, sin x ^ n :=
  by
  rw [mul_comm (1 / 2 : ℝ), ← div_eq_iff (one_div_ne_zero (two_ne_zero' ℝ)), ← div_mul, div_one,
    mul_two]
  have L : IntervalIntegrable _ volume 0 (π / 2) := (continuous_sin.pow n).IntervalIntegrable _ _
  have R : IntervalIntegrable _ volume (π / 2) π := (continuous_sin.pow n).IntervalIntegrable _ _
  rw [← integral_add_adjacent_intervals L R]
  congr 1
  · nth_rw 1 [(by ring : 0 = π / 2 - π / 2)]
    nth_rw 3 [(by ring : π / 2 = π / 2 - 0)]
    rw [← integral_comp_sub_left]
    refine' integral_congr fun x _ => _
    dsimp only
    rw [cos_pi_div_two_sub]
  · nth_rw 3 [(by ring : π = π / 2 + π / 2)]
    nth_rw 2 [(by ring : π / 2 = 0 + π / 2)]
    rw [← integral_comp_add_right]
    refine' integral_congr fun x _ => _
    dsimp only
    rw [sin_add_pi_div_two]
#align euler_sine.integral_cos_pow_eq EulerSine.integral_cos_pow_eq

theorem integral_cos_pow_pos (n : ℕ) : 0 < ∫ x : ℝ in 0 ..π / 2, cos x ^ n :=
  (integral_cos_pow_eq n).symm ▸ mul_pos one_half_pos (integral_sin_pow_pos _)
#align euler_sine.integral_cos_pow_pos EulerSine.integral_cos_pow_pos

/-- Finite form of Euler's sine product, with remainder term expressed as a ratio of cosine
integrals. -/
theorem sin_pi_mul_eq (z : ℂ) (n : ℕ) :
    Complex.sin (π * z) =
      ((π * z * ∏ j in Finset.range n, 1 - z ^ 2 / (j + 1) ^ 2) *
          ∫ x in 0 ..π / 2, Complex.cos (2 * z * x) * cos x ^ (2 * n)) /
        ↑(∫ x in 0 ..π / 2, cos x ^ (2 * n)) :=
  by
  rcases eq_or_ne z 0 with (rfl | hz)
  · simp
  induction' n with n hn
  · simp_rw [MulZeroClass.mul_zero, pow_zero, mul_one, Finset.prod_range_zero, mul_one,
      integral_one, sub_zero]
    rw [integral_cos_mul_complex (mul_ne_zero two_ne_zero hz), Complex.ofReal_zero,
      MulZeroClass.mul_zero, Complex.sin_zero, zero_div, sub_zero,
      (by
        push_cast
        field_simp
        ring : 2 * z * ↑(π / 2) = π * z)]
    field_simp [complex.of_real_ne_zero.mpr pi_pos.ne']
    ring
  · rw [hn, Finset.prod_range_succ]
    set A := ∏ j in Finset.range n, 1 - z ^ 2 / (j + 1) ^ 2
    set B := ∫ x : ℝ in 0 ..π / 2, Complex.cos (2 * z * x) * cos x ^ (2 * n)
    set C := ∫ x : ℝ in 0 ..π / 2, cos x ^ (2 * n)
    have aux' : 2 * n.succ = 2 * n + 2 := by rw [Nat.succ_eq_add_one, mul_add, mul_one]
    have : (∫ x : ℝ in 0 ..π / 2, cos x ^ (2 * n.succ)) = (2 * (n : ℝ) + 1) / (2 * n + 2) * C :=
      by
      rw [integral_cos_pow_eq]
      dsimp only [C]
      rw [integral_cos_pow_eq, aux', integral_sin_pow, sin_zero, sin_pi, pow_succ,
        MulZeroClass.zero_mul, MulZeroClass.zero_mul, MulZeroClass.zero_mul, sub_zero, zero_div,
        zero_add, ← mul_assoc, ← mul_assoc, mul_comm (1 / 2 : ℝ) _, Nat.cast_mul, Nat.cast_bit0,
        Nat.cast_one]
    rw [this]
    change
      ↑π * z * A * B / ↑C =
        (↑π * z * (A * (1 - z ^ 2 / (↑n + 1) ^ 2)) *
            ∫ x : ℝ in 0 ..π / 2, Complex.cos (2 * z * ↑x) * ↑(cos x) ^ (2 * n.succ)) /
          ↑((2 * ↑n + 1) / (2 * ↑n + 2) * C)
    have :
      (↑π * z * (A * (1 - z ^ 2 / (↑n + 1) ^ 2)) *
          ∫ x : ℝ in 0 ..π / 2, Complex.cos (2 * z * ↑x) * ↑(cos x) ^ (2 * n.succ)) =
        ↑π * z * A *
          ((1 - z ^ 2 / ↑n.succ ^ 2) *
            ∫ x : ℝ in 0 ..π / 2, Complex.cos (2 * z * ↑x) * ↑(cos x) ^ (2 * n.succ)) :=
      by
      nth_rw_rhs 1 [Nat.succ_eq_add_one]
      rw [Nat.cast_add_one]
      ring
    rw [this]
    suffices
      ((1 - z ^ 2 / ↑n.succ ^ 2) *
          ∫ x : ℝ in 0 ..π / 2, Complex.cos (2 * z * ↑x) * ↑(cos x) ^ (2 * n.succ)) =
        (2 * n + 1) / (2 * n + 2) * B
      by
      rw [this, Complex.ofReal_mul, Complex.ofReal_div]
      have : (C : ℂ) ≠ 0 := complex.of_real_ne_zero.mpr (integral_cos_pow_pos _).ne'
      have : 2 * (n : ℂ) + 1 ≠ 0 :=
        by
        convert(Nat.cast_add_one_ne_zero (2 * n) : (↑(2 * n) + 1 : ℂ) ≠ 0)
        simp
      have : 2 * (n : ℂ) + 2 ≠ 0 :=
        by
        convert(Nat.cast_add_one_ne_zero (2 * n + 1) : (↑(2 * n + 1) + 1 : ℂ) ≠ 0) using 1
        push_cast
        ring
      field_simp
      ring
    convert integral_cos_mul_cos_pow_even n hz
    rw [Nat.cast_succ]
#align euler_sine.sin_pi_mul_eq EulerSine.sin_pi_mul_eq

end IntegralRecursion

/-! ## Conclusion of the proof

The main theorem `complex.tendsto_euler_sin_prod`, and its real variant
`real.tendsto_euler_sin_prod`, now follow by combining `sin_pi_mul_eq` with a lemma
stating that the sequence of measures on `[0, π/2]` given by integration against `cos x ^ n`
(suitably normalised) tends to the Dirac measure at 0, as a special case of the general result
`tendsto_set_integral_pow_smul_of_unique_maximum_of_is_compact_of_continuous_on`. -/

theorem tendsto_integral_cos_pow_mul_div {f : ℝ → ℂ} (hf : ContinuousOn f (Icc 0 (π / 2))) :
    Tendsto
      (fun n : ℕ => (∫ x : ℝ in 0 ..π / 2, ↑(cos x) ^ n * f x) / ↑(∫ x : ℝ in 0 ..π / 2, cos x ^ n))
      atTop (𝓝 <| f 0) :=
  by
  simp_rw [div_eq_inv_mul _ (coe _), ← Complex.ofReal_inv, integral_of_le pi_div_two_pos.le, ←
    MeasureTheory.integral_Icc_eq_integral_Ioc, ← Complex.ofReal_pow, ← Complex.real_smul]
  have c_lt : ∀ y : ℝ, y ∈ Icc 0 (π / 2) → y ≠ 0 → cos y < cos 0 := fun y hy hy' =>
    cos_lt_cos_of_nonneg_of_le_pi_div_two (le_refl 0) hy.2 (lt_of_le_of_ne hy.1 hy'.symm)
  have c_nonneg : ∀ x : ℝ, x ∈ Icc 0 (π / 2) → 0 ≤ cos x := fun x hx =>
    cos_nonneg_of_mem_Icc ((Icc_subset_Icc_left (neg_nonpos_of_nonneg pi_div_two_pos.le)) hx)
  have c_zero_pos : 0 < cos 0 := by
    rw [cos_zero]
    exact zero_lt_one
  have zero_mem : (0 : ℝ) ∈ closure (interior (Icc 0 (π / 2))) :=
    by
    rw [interior_Icc, closure_Ioo pi_div_two_pos.ne, left_mem_Icc]
    exact pi_div_two_pos.le
  exact
    tendsto_set_integral_pow_smul_of_unique_maximum_of_isCompact_of_continuousOn is_compact_Icc
      continuous_on_cos c_lt c_nonneg c_zero_pos zero_mem hf
#align euler_sine.tendsto_integral_cos_pow_mul_div EulerSine.tendsto_integral_cos_pow_mul_div

/-- Euler's infinite product formula for the complex sine function. -/
theorem Complex.tendsto_euler_sin_prod (z : ℂ) :
    Tendsto (fun n : ℕ => ↑π * z * ∏ j in Finset.range n, 1 - z ^ 2 / (j + 1) ^ 2) atTop
      (𝓝 <| Complex.sin (π * z)) :=
  by
  have A :
    tendsto
      (fun n : ℕ =>
        ((↑π * z * ∏ j in Finset.range n, 1 - z ^ 2 / (j + 1) ^ 2) *
            ∫ x in 0 ..π / 2, Complex.cos (2 * z * x) * cos x ^ (2 * n)) /
          ↑(∫ x in 0 ..π / 2, cos x ^ (2 * n)))
      at_top (𝓝 <| _) :=
    tendsto.congr (fun n => sin_pi_mul_eq z n) tendsto_const_nhds
  have : 𝓝 (Complex.sin (π * z)) = 𝓝 (Complex.sin (π * z) * 1) := by rw [mul_one]
  simp_rw [this, mul_div_assoc] at A
  convert(tendsto_mul_iff_of_ne_zero _ one_ne_zero).mp A
  suffices :
    tendsto
      (fun n : ℕ =>
        (∫ x : ℝ in 0 ..π / 2, Complex.cos (2 * z * x) * cos x ^ n) /
          ↑(∫ x : ℝ in 0 ..π / 2, cos x ^ n))
      at_top (𝓝 1)
  exact this.comp (tendsto_id.const_mul_at_top' zero_lt_two)
  have : ContinuousOn (fun x : ℝ => Complex.cos (2 * z * x)) (Icc 0 (π / 2)) :=
    (complex.continuous_cos.comp (continuous_const.mul Complex.continuous_of_real)).ContinuousOn
  convert tendsto_integral_cos_pow_mul_div this
  · ext1 n
    congr 2 with x : 1
    rw [mul_comm]
  · rw [Complex.ofReal_zero, MulZeroClass.mul_zero, Complex.cos_zero]
#align complex.tendsto_euler_sin_prod Complex.tendsto_euler_sin_prod

/-- Euler's infinite product formula for the real sine function. -/
theorem Real.tendsto_euler_sin_prod (x : ℝ) :
    Tendsto (fun n : ℕ => π * x * ∏ j in Finset.range n, 1 - x ^ 2 / (j + 1) ^ 2) atTop
      (𝓝 <| sin (π * x)) :=
  by
  convert(complex.continuous_re.tendsto _).comp (Complex.tendsto_euler_sin_prod x)
  · ext1 n
    rw [Function.comp_apply, ← Complex.ofReal_mul, Complex.ofReal_mul_re]
    suffices
      (∏ j : ℕ in Finset.range n, 1 - (x : ℂ) ^ 2 / (↑j + 1) ^ 2) =
        ↑(∏ j : ℕ in Finset.range n, 1 - x ^ 2 / (↑j + 1) ^ 2)
      by rw [this, Complex.ofReal_re]
    rw [Complex.ofReal_prod]
    refine' Finset.prod_congr (by rfl) fun n hn => _
    norm_cast
  · rw [← Complex.ofReal_mul, ← Complex.ofReal_sin, Complex.ofReal_re]
#align real.tendsto_euler_sin_prod Real.tendsto_euler_sin_prod

end EulerSine


/-
Copyright (c) 2019 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro, Kevin Kappelmann
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.floor
import Mathlib.tactic.field_simp
import Mathlib.PostPort

namespace Mathlib

/-!
# Floor Function for Rational Numbers

## Summary

We define the `floor` function and the `floor_ring` instance on `ℚ`. Some technical lemmas relating
`floor` to integer division and modulo arithmetic are derived as well as some simple inequalities.

## Tags

rat, rationals, ℚ, floor
-/

namespace rat

/-- `floor q` is the largest integer `z` such that `z ≤ q` -/
protected def floor : ℚ → ℤ :=
  sorry

protected theorem le_floor {z : ℤ} {r : ℚ} : z ≤ rat.floor r ↔ ↑z ≤ r := sorry

protected instance floor_ring : floor_ring ℚ :=
  floor_ring.mk rat.floor rat.le_floor

protected theorem floor_def {q : ℚ} : floor q = num q / ↑(denom q) :=
  cases_on q
    fun (q_num : ℤ) (q_denom : ℕ) (q_pos : 0 < q_denom) (q_cop : nat.coprime (int.nat_abs q_num) q_denom) =>
      Eq.refl (floor (mk' q_num q_denom q_pos q_cop))

theorem floor_int_div_nat_eq_div {n : ℤ} {d : ℕ} : floor (↑n / ↑d) = n / ↑d := sorry

end rat

theorem int.mod_nat_eq_sub_mul_floor_rat_div {n : ℤ} {d : ℕ} : n % ↑d = n - ↑d * floor (↑n / ↑d) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (n % ↑d = n - ↑d * floor (↑n / ↑d))) (eq_sub_of_add_eq (int.mod_add_div n ↑d))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (n - ↑d * (n / ↑d) = n - ↑d * floor (↑n / ↑d))) rat.floor_int_div_nat_eq_div))
      (Eq.refl (n - ↑d * (n / ↑d))))

theorem nat.coprime_sub_mul_floor_rat_div_of_coprime {n : ℕ} {d : ℕ} (n_coprime_d : nat.coprime n d) : nat.coprime (int.nat_abs (↑n - ↑d * floor (↑n / ↑d))) d := sorry

namespace rat

theorem num_lt_succ_floor_mul_denom (q : ℚ) : num q < (floor q + 1) * ↑(denom q) := sorry

theorem fract_inv_num_lt_num_of_pos {q : ℚ} (q_pos : 0 < q) : num (fract (q⁻¹)) < num q := sorry


import tactic
import tactic.norm_cast
import data.rat
import data.fintype
import data.real.basic
import data.nat.parity

noncomputable theory
open_locale classical

/---  problem statement  ---/

def lamp_switch_seq (n k : ℕ) := array k (fin (n+n))
--local attribute [instance] classical.prop_decidable

instance (n k : ℕ) : has_mem (fin (n+n)) (lamp_switch_seq n k) := array.has_mem
instance (n k : ℕ) : fintype (lamp_switch_seq n k) :=
begin
  unfold lamp_switch_seq,
  apply_instance
end

def lamp_state (n : ℕ) := array (n+n) bool

def ini_state (n : ℕ) : (lamp_state n) := ⟨λ i : fin (n+n), ff⟩
def target_state (n : ℕ) : (lamp_state n) := ⟨λ i : fin (n+n), (i:ℕ) < n⟩
def switch_lamp {n : ℕ} (i : fin (n+n)) (s1 : lamp_state n) : lamp_state n
:= s1.write i (¬s1.read i)
-- := ⟨λ j : fin (n+n), xor (i = j) (s1.read j)⟩

def fin_state {n k : ℕ} (seq : lamp_switch_seq n k) : lamp_state n
  := seq.foldl (ini_state n) switch_lamp

def is_N_seq {n k : ℕ} (seq : lamp_switch_seq n k) : Prop
  := (fin_state seq = target_state n)
def is_M_seq {n k : ℕ} (seq : lamp_switch_seq n k) : Prop
  := is_N_seq seq ∧ ∀ l ∈ seq, (l : ℕ) < n

def N_seq (n k : ℕ) := @subtype (lamp_switch_seq n k) is_N_seq
def M_seq (n k : ℕ) := @subtype (lamp_switch_seq n k) is_M_seq

instance (n k : ℕ) : fintype (N_seq n k) := by apply subtype.fintype
instance (n k : ℕ) : fintype (M_seq n k) := by apply subtype.fintype

def N_num (n k : ℕ) := fintype.card (N_seq n k)
def M_num (n k : ℕ) := fintype.card (M_seq n k)

/- The statement of the theorem -/

def lamp_prop : Prop :=
  ∀ n k : ℕ, 0 < n → n ≤ k → nat.even (k-n) →
    (N_num n k : ℚ) / (M_num n k) = 2^(k-n)

/- Proof -/

def to_fin_2n_small {n : ℕ} (i : fin n) : fin (n+n)
  := ⟨i, nat.lt_add_left i.val n n i.is_lt⟩
def to_fin_2n_big {n : ℕ} (i : fin n) : fin (n+n)
  := ⟨i+n, add_lt_add_right i.is_lt n⟩

def is_D_seq {n k : ℕ} (seq : lamp_switch_seq n k) : Prop
  :=
  let fs := fin_state seq in
  ∀ i : fin n, xor (fs.read  (to_fin_2n_small i)) (fs.read (to_fin_2n_big i))
def D_seq (n k : ℕ) := @subtype (lamp_switch_seq n k) is_D_seq
instance (n k : ℕ) : fintype (D_seq n k) := by apply subtype.fintype
def D_num (n k : ℕ) := fintype.card (D_seq n k)

lemma N_num_by_D_num (n k : ℕ) : (N_num n k) * 2^n = (D_num n k)
:=
begin
  sorry
end

lemma M_num_by_D_num (n k : ℕ) : (M_num n k) * 2^k = (D_num n k)
:=
begin
  sorry
end

-- proving that M ≠ 0

def nontriv_val_small {n k : ℕ} {i : fin k} (c : i.val < n) : fin (n+n) :=
  ⟨i, nat.lt_add_left i.val n n c⟩
def nontriv_val_big {n k : ℕ} {i : fin k} (n_pos : 0 < n) (c : ¬i.val < n) : fin (n+n) :=
  ⟨0, nat.lt_add_left 0 n n n_pos⟩
def nontriv_seq (n k : ℕ) (n_pos : 0 < n) : lamp_switch_seq n k :=
  ⟨λ i : fin k,
    dite (i.val < n)
      nontriv_val_small
      (nontriv_val_big n_pos)
  ⟩

lemma nontriv_correct (n k : ℕ) (n_pos : 0 < n) (nk_lt : n ≤ k) (nk_parity : nat.even (k-n))
  : is_N_seq (nontriv_seq n k n_pos)
:=
begin
  sorry
end

lemma nontriv_all_small (n k : ℕ) (n_pos : 0 < n)
  : ∀ l ∈ (nontriv_seq n k n_pos), ↑l < n
:=
begin
  let seq := nontriv_seq n k n_pos,
  show ∀ l ∈ seq, ↑l < n,
  intros,
  obtain ⟨si, hs⟩ : ∃ si, seq.data si = l, from H,
  rw ←hs,
  cases classical.em (si.val < n) with si_small si_big,
  -- si_small
  have : seq.data si = nontriv_val_small si_small, from dif_pos si_small,
  rw this,
  show si.val < n, from si_small,
  -- si_big
  have : seq.data si = nontriv_val_big n_pos si_big, from dif_neg si_big,
  rw this,
  show 0 < n, from n_pos,
end

lemma fintype.card_pos (α : Type) [ft : fintype α] (x : α)
  : 0 < fintype.card α
:= begin
  apply finset.card_pos.2,
  apply exists.intro,
  show α, from x,
  show x ∈ finset.univ, from finset.mem_univ x
end

lemma M_num_nontriv {n k : ℕ} (n_pos : 0 < n) (nk_le : n ≤ k) (nk_parity : nat.even (k-n))
  : M_num n k > 0
:=
begin
  let seq : lamp_switch_seq n k := (nontriv_seq n k n_pos),
  have : is_M_seq seq, begin
    apply and.intro,
    show is_N_seq seq, begin
      apply nontriv_correct,
      show n ≤ k, from nk_le,
      show nat.even (k-n), from nk_parity,
    end,
    show ∀ l ∈ seq, ↑l < n, by apply nontriv_all_small,
  end,
  apply fintype.card_pos,
  show M_seq n k, from ⟨seq, this⟩
end

-- final arithmetics

lemma lamp_arith (M N D n k : ℕ) (h1 : N * 2^n = D) (h2 : M * 2^k = D)
  (non_triv : M > 0) (nk_le : n ≤ k) :
  (N / M : ℚ) = 2^(k-n) :=
begin
  rw div_eq_iff_mul_eq,
  rw ← domain.mul_left_inj (ne_of_gt $ pow_pos two_pos n : (2^n : ℚ) ≠ 0),
  rw [← mul_assoc, ← pow_add, nat.add_sub_cancel' nk_le],
  rw mul_comm at h1 h2,
  exact_mod_cast h2.trans h1.symm,
  exact_mod_cast ne_of_gt non_triv
end

/- Proof of the main theorem -/

theorem lamp_thm : lamp_prop
:= begin
  show ∀ n k : ℕ, 0 < n → n ≤ k → nat.even (k-n) →
    (N_num n k : ℚ) / (M_num n k) = 2^(k-n),
  intros n k n_pos nk_le nk_parity,
  apply lamp_arith,
    show N_num n k * 2^n = D_num n k, by apply N_num_by_D_num,
    show M_num n k * 2^k = D_num n k, by apply M_num_by_D_num,
    show M_num n k > 0, from M_num_nontriv n_pos nk_le nk_parity,
    show n ≤ k, from nk_le,
end