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

import data.nat.parity
import data.polynomial.ring_division
import group_theory.specific_groups.cyclic
import ring_theory.integral_domain
import number_theory.divisors
import data.zmod.basic
import tactic.zify
import field_theory.separable
import field_theory.finite.basic

/-!
# Roots of unity and primitive roots of unity

We define roots of unity in the context of an arbitrary commutative monoid,
as a subgroup of the group of units. We also define a predicate `is_primitive_root` on commutative
monoids, expressing that an element is a primitive root of unity.

## Main definitions

* `roots_of_unity n M`, for `n : ℕ+` is the subgroup of the units of a commutative monoid `M`
  consisting of elements `x` that satisfy `x ^ n = 1`.
* `is_primitive_root ζ k`: an element `ζ` is a primitive `k`-th root of unity if `ζ ^ k = 1`,
  and if `l` satisfies `ζ ^ l = 1` then `k ∣ l`.
* `primitive_roots k R`: the finset of primitive `k`-th roots of unity in an integral domain `R`.

## Main results

* `roots_of_unity.is_cyclic`: the roots of unity in an integral domain form a cyclic group.
* `is_primitive_root.zmod_equiv_gpowers`: `zmod k` is equivalent to
  the subgroup generated by a primitive `k`-th root of unity.
* `is_primitive_root.gpowers_eq`: in an integral domain, the subgroup generated by
  a primitive `k`-th root of unity is equal to the `k`-th roots of unity.
* `is_primitive_root.card_primitive_roots`: if an integral domain
   has a primitive `k`-th root of unity, then it has `φ k` of them.

## Implementation details

It is desirable that `roots_of_unity` is a subgroup,
and it will mainly be applied to rings (e.g. the ring of integers in a number field) and fields.
We therefore implement it as a subgroup of the units of a commutative monoid.

We have chosen to define `roots_of_unity n` for `n : ℕ+`, instead of `n : ℕ`,
because almost all lemmas need the positivity assumption,
and in particular the type class instances for `fintype` and `is_cyclic`.

On the other hand, for primitive roots of unity, it is desirable to have a predicate
not just on units, but directly on elements of the ring/field.
For example, we want to say that `exp (2 * pi * I / n)` is a primitive `n`-th root of unity
in the complex numbers, without having to turn that number into a unit first.

This creates a little bit of friction, but lemmas like `is_primitive_root.is_unit` and
`is_primitive_root.coe_units_iff` should provide the necessary glue.

-/

open_locale classical big_operators
noncomputable theory

open polynomial
open finset

variables {M N G G₀ R S : Type*}
variables [comm_monoid M] [comm_monoid N] [comm_group G] [comm_group_with_zero G₀]
variables [integral_domain R] [integral_domain S]

section roots_of_unity

variables {k l : ℕ+}

/-- `roots_of_unity k M` is the subgroup of elements `m : units M` that satisfy `m ^ k = 1` -/
def roots_of_unity (k : ℕ+) (M : Type*) [comm_monoid M] : subgroup (units M) :=
{ carrier := { ζ | ζ ^ (k : ℕ) = 1 },
  one_mem' := one_pow _,
  mul_mem' := λ ζ ξ hζ hξ, by simp only [*, set.mem_set_of_eq, mul_pow, one_mul] at *,
  inv_mem' := λ ζ hζ, by simp only [*, set.mem_set_of_eq, inv_pow, one_inv] at * }

@[simp] lemma mem_roots_of_unity (k : ℕ+) (ζ : units M) :
  ζ ∈ roots_of_unity k M ↔ ζ ^ (k : ℕ) = 1 := iff.rfl

lemma roots_of_unity_le_of_dvd (h : k ∣ l) : roots_of_unity k M ≤ roots_of_unity l M :=
begin
  obtain ⟨d, rfl⟩ := h,
  intros ζ h,
  simp only [mem_roots_of_unity, pnat.mul_coe, pow_mul, one_pow, *] at *,
end

lemma map_roots_of_unity (f : units M →* units N) (k : ℕ+) :
  (roots_of_unity k M).map f ≤ roots_of_unity k N :=
begin
  rintros _ ⟨ζ, h, rfl⟩,
  simp only [←monoid_hom.map_pow, *, mem_roots_of_unity, set_like.mem_coe, monoid_hom.map_one] at *
end

lemma mem_roots_of_unity_iff_mem_nth_roots {ζ : units R} :
  ζ ∈ roots_of_unity k R ↔ (ζ : R) ∈ nth_roots k (1 : R) :=
by simp only [mem_roots_of_unity, mem_nth_roots k.pos, units.ext_iff, units.coe_one, units.coe_pow]

variables (k R)

/-- Equivalence between the `k`-th roots of unity in `R` and the `k`-th roots of `1`.

This is implemented as equivalence of subtypes,
because `roots_of_unity` is a subgroup of the group of units,
whereas `nth_roots` is a multiset. -/
def roots_of_unity_equiv_nth_roots :
  roots_of_unity k R ≃ {x // x ∈ nth_roots k (1 : R)} :=
begin
  refine
  { to_fun := λ x, ⟨x, mem_roots_of_unity_iff_mem_nth_roots.mp x.2⟩,
    inv_fun := λ x, ⟨⟨x, x ^ (k - 1 : ℕ), _, _⟩, _⟩,
    left_inv := _,
    right_inv := _ },
  swap 4, { rintro ⟨x, hx⟩, ext, refl },
  swap 4, { rintro ⟨x, hx⟩, ext, refl },
  all_goals
  { rcases x with ⟨x, hx⟩, rw [mem_nth_roots k.pos] at hx,
    simp only [subtype.coe_mk, ← pow_succ, ← pow_succ', hx,
      nat.sub_add_cancel (show 1 ≤ (k : ℕ), from k.one_le)] },
  { show (_ : units R) ^ (k : ℕ) = 1,
    simp only [units.ext_iff, hx, units.coe_mk, units.coe_one, subtype.coe_mk, units.coe_pow] }
end

variables {k R}

@[simp] lemma roots_of_unity_equiv_nth_roots_apply (x : roots_of_unity k R) :
  (roots_of_unity_equiv_nth_roots R k x : R) = x :=
rfl

@[simp] lemma roots_of_unity_equiv_nth_roots_symm_apply (x : {x // x ∈ nth_roots k (1 : R)}) :
  ((roots_of_unity_equiv_nth_roots R k).symm x : R) = x :=
rfl

variables (k R)

instance roots_of_unity.fintype : fintype (roots_of_unity k R) :=
fintype.of_equiv {x // x ∈ nth_roots k (1 : R)} $ (roots_of_unity_equiv_nth_roots R k).symm

instance roots_of_unity.is_cyclic : is_cyclic (roots_of_unity k R) :=
is_cyclic_of_subgroup_integral_domain ((units.coe_hom R).comp (roots_of_unity k R).subtype)
  (units.ext.comp subtype.val_injective)

lemma card_roots_of_unity : fintype.card (roots_of_unity k R) ≤ k :=
calc  fintype.card (roots_of_unity k R)
    = fintype.card {x // x ∈ nth_roots k (1 : R)} :
          fintype.card_congr (roots_of_unity_equiv_nth_roots R k)
... ≤ (nth_roots k (1 : R)).attach.card           : multiset.card_le_of_le (multiset.erase_dup_le _)
... = (nth_roots k (1 : R)).card                  : multiset.card_attach
... ≤ k                                           : card_nth_roots k 1

variables {k R}

@[norm_cast]
lemma roots_of_unity.coe_pow (ζ : roots_of_unity k R) (m : ℕ) : ↑(ζ ^ m) = (ζ ^ m : R) :=
begin
  change ↑(↑(ζ ^ m) : units R) = ↑(ζ : units R) ^ m,
  rw [subgroup.coe_pow, units.coe_pow],
end

/-- Restrict a ring homomorphism between integral domains to the nth roots of unity -/
def ring_hom.restrict_roots_of_unity (σ : R →+* S) (n : ℕ+) :
  roots_of_unity n R →* roots_of_unity n S :=
let h : ∀ ξ : roots_of_unity n R, (σ ξ) ^ (n : ℕ) = 1 := λ ξ, by
{ change (σ (ξ : units R)) ^ (n : ℕ) = 1,
  rw [←σ.map_pow, ←units.coe_pow, show ((ξ : units R) ^ (n : ℕ) = 1), from ξ.2,
      units.coe_one, σ.map_one] } in
{ to_fun := λ ξ, ⟨@unit_of_invertible _ _ _ (invertible_of_pow_eq_one _ _ (h ξ) n.2),
    by { ext, rw units.coe_pow, exact h ξ }⟩,
  map_one' := by { ext, exact σ.map_one },
  map_mul' := λ ξ₁ ξ₂, by { ext, rw [subgroup.coe_mul, units.coe_mul], exact σ.map_mul _ _ } }

@[simp] lemma ring_hom.restrict_roots_of_unity_coe_apply (σ : R →+* S) (ζ : roots_of_unity k R) :
  ↑(σ.restrict_roots_of_unity k ζ) = σ ↑ζ :=
rfl

/-- Restrict a ring isomorphism between integral domains to the nth roots of unity -/
def ring_equiv.restrict_roots_of_unity (σ : R ≃+* S) (n : ℕ+) :
  roots_of_unity n R ≃* roots_of_unity n S :=
{ to_fun := σ.to_ring_hom.restrict_roots_of_unity n,
  inv_fun := σ.symm.to_ring_hom.restrict_roots_of_unity n,
  left_inv := λ ξ, by { ext, exact σ.symm_apply_apply ξ },
  right_inv := λ ξ, by { ext, exact σ.apply_symm_apply ξ },
  map_mul' := (σ.to_ring_hom.restrict_roots_of_unity n).map_mul }

@[simp] lemma ring_equiv.restrict_roots_of_unity_coe_apply (σ : R ≃+* S) (ζ : roots_of_unity k R) :
  ↑(σ.restrict_roots_of_unity k ζ) = σ ↑ζ :=
rfl

@[simp] lemma ring_equiv.restrict_roots_of_unity_symm (σ : R ≃+* S) :
  (σ.restrict_roots_of_unity k).symm = σ.symm.restrict_roots_of_unity k :=
rfl

lemma ring_hom.map_root_of_unity_eq_pow_self (σ : R →+* R) (ζ : roots_of_unity k R) :
  ∃ m : ℕ, σ ζ = ζ ^ m :=
begin
  obtain ⟨m, hm⟩ := (σ.restrict_roots_of_unity k).map_cyclic,
  rw [←σ.restrict_roots_of_unity_coe_apply, hm, gpow_eq_mod_order_of, ←int.to_nat_of_nonneg
      (m.mod_nonneg (int.coe_nat_ne_zero.mpr (pos_iff_ne_zero.mp (order_of_pos ζ)))),
      gpow_coe_nat, roots_of_unity.coe_pow],
  exact ⟨(m % (order_of ζ)).to_nat, rfl⟩,
end

end roots_of_unity

/-- An element `ζ` is a primitive `k`-th root of unity if `ζ ^ k = 1`,
and if `l` satisfies `ζ ^ l = 1` then `k ∣ l`. -/
structure is_primitive_root (ζ : M) (k : ℕ) : Prop :=
(pow_eq_one : ζ ^ (k : ℕ) = 1)
(dvd_of_pow_eq_one : ∀ l : ℕ, ζ ^ l = 1 → k ∣ l)

section primitive_roots
variables {k : ℕ}

/-- `primitive_roots k R` is the finset of primitive `k`-th roots of unity
in the integral domain `R`. -/
def primitive_roots (k : ℕ) (R : Type*) [integral_domain R] : finset R :=
(nth_roots k (1 : R)).to_finset.filter (λ ζ, is_primitive_root ζ k)

@[simp] lemma mem_primitive_roots {ζ : R} (h0 : 0 < k) :
  ζ ∈ primitive_roots k R ↔ is_primitive_root ζ k :=
begin
  rw [primitive_roots, mem_filter, multiset.mem_to_finset, mem_nth_roots h0, and_iff_right_iff_imp],
  exact is_primitive_root.pow_eq_one
end

end primitive_roots

namespace is_primitive_root

variables {k l : ℕ}

lemma iff_def (ζ : M) (k : ℕ) :
  is_primitive_root ζ k ↔ (ζ ^ k = 1) ∧ (∀ l : ℕ, ζ ^ l = 1 → k ∣ l) :=
⟨λ ⟨h1, h2⟩, ⟨h1, h2⟩, λ ⟨h1, h2⟩, ⟨h1, h2⟩⟩

lemma mk_of_lt (ζ : M) (hk : 0 < k) (h1 : ζ ^ k = 1) (h : ∀ l : ℕ, 0 < l →  l < k → ζ ^ l ≠ 1) :
  is_primitive_root ζ k :=
begin
  refine ⟨h1, _⟩,
  intros l hl,
  apply dvd_trans _ (k.gcd_dvd_right l),
  suffices : k.gcd l = k, { rw this },
  rw eq_iff_le_not_lt,
  refine ⟨nat.le_of_dvd hk (k.gcd_dvd_left l), _⟩,
  intro h', apply h _ (nat.gcd_pos_of_pos_left _ hk) h',
  exact pow_gcd_eq_one _ h1 hl
end

section comm_monoid

variables {ζ : M} (h : is_primitive_root ζ k)

lemma pow_eq_one_iff_dvd (l : ℕ) : ζ ^ l = 1 ↔ k ∣ l :=
⟨h.dvd_of_pow_eq_one l,
by { rintro ⟨i, rfl⟩, simp only [pow_mul, h.pow_eq_one, one_pow, pnat.mul_coe] }⟩

lemma is_unit (h : is_primitive_root ζ k) (h0 : 0 < k) : is_unit ζ :=
begin
  apply is_unit_of_mul_eq_one ζ (ζ ^ (k - 1)),
  rw [← pow_succ, nat.sub_add_cancel h0, h.pow_eq_one]
end

lemma pow_ne_one_of_pos_of_lt (h0 : 0 < l) (hl : l < k) : ζ ^ l ≠ 1 :=
mt (nat.le_of_dvd h0 ∘ h.dvd_of_pow_eq_one _) $ not_le_of_lt hl

lemma pow_inj (h : is_primitive_root ζ k) ⦃i j : ℕ⦄ (hi : i < k) (hj : j < k) (H : ζ ^ i = ζ ^ j) :
  i = j :=
begin
  wlog hij : i ≤ j,
  apply le_antisymm hij,
  rw ← nat.sub_eq_zero_iff_le,
  apply nat.eq_zero_of_dvd_of_lt _ (lt_of_le_of_lt (nat.sub_le_self _ _) hj),
  apply h.dvd_of_pow_eq_one,
  rw [← ((h.is_unit (lt_of_le_of_lt (nat.zero_le _) hi)).pow i).mul_left_inj,
      ← pow_add, nat.sub_add_cancel hij, H, one_mul]
end

lemma one : is_primitive_root (1 : M) 1 :=
{ pow_eq_one := pow_one _,
  dvd_of_pow_eq_one := λ l hl, one_dvd _ }

@[simp] lemma one_right_iff : is_primitive_root ζ 1 ↔ ζ = 1 :=
begin
  split,
  { intro h, rw [← pow_one ζ, h.pow_eq_one] },
  { rintro rfl, exact one }
end

@[simp] lemma coe_units_iff {ζ : units M} :
  is_primitive_root (ζ : M) k ↔ is_primitive_root ζ k :=
by simp only [iff_def, units.ext_iff, units.coe_pow, units.coe_one]

lemma pow_of_coprime (h : is_primitive_root ζ k) (i : ℕ) (hi : i.coprime k) :
  is_primitive_root (ζ ^ i) k :=
begin
  by_cases h0 : k = 0,
  { subst k, simp only [*, pow_one, nat.coprime_zero_right] at * },
  rcases h.is_unit (nat.pos_of_ne_zero h0) with ⟨ζ, rfl⟩,
  rw [← units.coe_pow],
  rw coe_units_iff at h ⊢,
  refine
  { pow_eq_one := by rw [← pow_mul', pow_mul, h.pow_eq_one, one_pow],
    dvd_of_pow_eq_one := _ },
  intros l hl,
  apply h.dvd_of_pow_eq_one,
  rw [← pow_one ζ, ← gpow_coe_nat ζ, ← hi.gcd_eq_one, nat.gcd_eq_gcd_ab, gpow_add,
      mul_pow, ← gpow_coe_nat, ← gpow_mul, mul_right_comm],
  simp only [gpow_mul, hl, h.pow_eq_one, one_gpow, one_pow, one_mul, gpow_coe_nat]
end

lemma pow_of_prime (h : is_primitive_root ζ k) {p : ℕ} (hprime : nat.prime p) (hdiv : ¬ p ∣ k) :
  is_primitive_root (ζ ^ p) k :=
h.pow_of_coprime p (hprime.coprime_iff_not_dvd.2 hdiv)

lemma pow_iff_coprime (h : is_primitive_root ζ k) (h0 : 0 < k) (i : ℕ) :
  is_primitive_root (ζ ^ i) k ↔ i.coprime k :=
begin
  refine ⟨_, h.pow_of_coprime i⟩,
  intro hi,
  obtain ⟨a, ha⟩ := i.gcd_dvd_left k,
  obtain ⟨b, hb⟩ := i.gcd_dvd_right k,
  suffices : b = k,
  { rwa [this, ← one_mul k, nat.mul_left_inj h0, eq_comm] at hb { occs := occurrences.pos [1] } },
  rw [ha] at hi,
  rw [mul_comm] at hb,
  apply nat.dvd_antisymm ⟨i.gcd k, hb⟩ (hi.dvd_of_pow_eq_one b _),
  rw [← pow_mul', ← mul_assoc, ← hb, pow_mul, h.pow_eq_one, one_pow]
end

end comm_monoid

section comm_group

variables {ζ : G}

lemma gpow_eq_one (h : is_primitive_root ζ k) : ζ ^ (k : ℤ) = 1 :=
by { rw gpow_coe_nat, exact h.pow_eq_one }

lemma gpow_eq_one_iff_dvd (h : is_primitive_root ζ k) (l : ℤ) :
  ζ ^ l = 1 ↔ (k : ℤ) ∣ l :=
begin
  by_cases h0 : 0 ≤ l,
  { lift l to ℕ using h0, rw [gpow_coe_nat], norm_cast, exact h.pow_eq_one_iff_dvd l },
  { have : 0 ≤ -l, { simp only [not_le, neg_nonneg] at h0 ⊢, exact le_of_lt h0 },
    lift -l to ℕ using this with l' hl',
    rw [← dvd_neg, ← hl'],
    norm_cast,
    rw [← h.pow_eq_one_iff_dvd, ← inv_inj, ← gpow_neg, ← hl', gpow_coe_nat, one_inv] }
end

lemma inv (h : is_primitive_root ζ k) : is_primitive_root ζ⁻¹ k :=
{ pow_eq_one := by simp only [h.pow_eq_one, one_inv, eq_self_iff_true, inv_pow],
  dvd_of_pow_eq_one :=
  begin
    intros l hl,
    apply h.dvd_of_pow_eq_one l,
    rw [← inv_inj, ← inv_pow, hl, one_inv]
  end }

@[simp] lemma inv_iff : is_primitive_root ζ⁻¹ k ↔ is_primitive_root ζ k :=
by { refine ⟨_, λ h, inv h⟩, intro h, rw [← inv_inv ζ], exact inv h }

lemma gpow_of_gcd_eq_one (h : is_primitive_root ζ k) (i : ℤ) (hi : i.gcd k = 1) :
  is_primitive_root (ζ ^ i) k :=
begin
  by_cases h0 : 0 ≤ i,
  { lift i to ℕ using h0,
    rw gpow_coe_nat,
    exact h.pow_of_coprime i hi },
  have : 0 ≤ -i, { simp only [not_le, neg_nonneg] at h0 ⊢, exact le_of_lt h0 },
  lift -i to ℕ using this with i' hi',
  rw [← inv_iff, ← gpow_neg, ← hi', gpow_coe_nat],
  apply h.pow_of_coprime,
  rw [int.gcd, ← int.nat_abs_neg, ← hi'] at hi,
  exact hi
end

@[simp] lemma coe_subgroup_iff (H : subgroup G) {ζ : H} :
  is_primitive_root (ζ : G) k ↔ is_primitive_root ζ k :=
by simp only [iff_def, ← subgroup.coe_pow, ← H.coe_one, ← subtype.ext_iff]

end comm_group

section comm_group_with_zero

variables {ζ : G₀}

lemma fpow_eq_one (h : is_primitive_root ζ k) : ζ ^ (k : ℤ) = 1 :=
by { rw gpow_coe_nat, exact h.pow_eq_one }

lemma fpow_eq_one_iff_dvd (h : is_primitive_root ζ k) (l : ℤ) :
  ζ ^ l = 1 ↔ (k : ℤ) ∣ l :=
begin
  by_cases h0 : 0 ≤ l,
  { lift l to ℕ using h0, rw [gpow_coe_nat], norm_cast, exact h.pow_eq_one_iff_dvd l },
  { have : 0 ≤ -l, { simp only [not_le, neg_nonneg] at h0 ⊢, exact le_of_lt h0 },
    lift -l to ℕ using this with l' hl',
    rw [← dvd_neg, ← hl'],
    norm_cast,
    rw [← h.pow_eq_one_iff_dvd, ← inv_inj', ← fpow_neg, ← hl', gpow_coe_nat, inv_one] }
end

lemma inv' (h : is_primitive_root ζ k) : is_primitive_root ζ⁻¹ k :=
{ pow_eq_one := by simp only [h.pow_eq_one, inv_one, eq_self_iff_true, inv_pow'],
  dvd_of_pow_eq_one :=
  begin
    intros l hl,
    apply h.dvd_of_pow_eq_one l,
    rw [← inv_inj', ← inv_pow', hl, inv_one]
  end }

@[simp] lemma inv_iff' : is_primitive_root ζ⁻¹ k ↔ is_primitive_root ζ k :=
by { refine ⟨_, λ h, inv' h⟩, intro h, rw [← inv_inv' ζ], exact inv' h }

lemma fpow_of_gcd_eq_one (h : is_primitive_root ζ k) (i : ℤ) (hi : i.gcd k = 1) :
  is_primitive_root (ζ ^ i) k :=
begin
  by_cases h0 : 0 ≤ i,
  { lift i to ℕ using h0,
    rw gpow_coe_nat,
    exact h.pow_of_coprime i hi },
  have : 0 ≤ -i, { simp only [not_le, neg_nonneg] at h0 ⊢, exact le_of_lt h0 },
  lift -i to ℕ using this with i' hi',
  rw [← inv_iff', ← fpow_neg, ← hi', gpow_coe_nat],
  apply h.pow_of_coprime,
  rw [int.gcd, ← int.nat_abs_neg, ← hi'] at hi,
  exact hi
end

end comm_group_with_zero

section integral_domain

variables {ζ : R}

@[simp] lemma primitive_roots_zero : primitive_roots 0 R = ∅ :=
begin
  rw [← finset.val_eq_zero, ← multiset.subset_zero, ← nth_roots_zero (1 : R), primitive_roots],
    simp only [finset.not_mem_empty, forall_const, forall_prop_of_false, multiset.to_finset_zero,
    finset.filter_true_of_mem, finset.empty_val, not_false_iff,
    multiset.zero_subset, nth_roots_zero]
end

@[simp] lemma primitive_roots_one : primitive_roots 1 R = {(1 : R)} :=
begin
  apply finset.eq_singleton_iff_unique_mem.2,
  split,
  { simp only [is_primitive_root.one_right_iff, mem_primitive_roots zero_lt_one] },
  { intros x hx,
    rw [mem_primitive_roots zero_lt_one, is_primitive_root.one_right_iff] at hx,
    exact hx }
end

lemma neg_one (p : ℕ) [char_p R p] (hp : p ≠ 2) : is_primitive_root (-1 : R) 2 :=
mk_of_lt (-1 : R) dec_trivial (by simp only [one_pow, neg_sq]) $
begin
  intros l hl0 hl2,
  obtain rfl : l = 1,
  { unfreezingI { clear_dependent R p }, dec_trivial! },
  simp only [pow_one, ne.def],
  intro h,
  suffices h2 : p ∣ 2,
  { have := char_p.char_ne_one R p,
    unfreezingI { clear_dependent R },
    have aux := nat.le_of_dvd dec_trivial h2,
    revert this hp h2, revert p, dec_trivial },
  simp only [← char_p.cast_eq_zero_iff R p, nat.cast_bit0, nat.cast_one],
  rw [bit0, ← h, neg_add_self] { occs := occurrences.pos [1] }
end

lemma eq_neg_one_of_two_right (h : is_primitive_root ζ 2) : ζ = -1 :=
begin
  apply (eq_or_eq_neg_of_sq_eq_sq ζ 1 _).resolve_left,
  { rw [← pow_one ζ], apply h.pow_ne_one_of_pos_of_lt; dec_trivial },
  { simp only [h.pow_eq_one, one_pow] }
end

end integral_domain

section integral_domain

variables {ζ : units R} (h : is_primitive_root ζ k)

protected
lemma mem_roots_of_unity {n : ℕ+} (h : is_primitive_root ζ n) : ζ ∈ roots_of_unity n R :=
h.pow_eq_one

/-- The (additive) monoid equivalence between `zmod k`
and the powers of a primitive root of unity `ζ`. -/
def zmod_equiv_gpowers (h : is_primitive_root ζ k) : zmod k ≃+ additive (subgroup.gpowers ζ) :=
add_equiv.of_bijective
  (add_monoid_hom.lift_of_right_inverse (int.cast_add_hom $ zmod k) _ zmod.int_cast_right_inverse
    ⟨{ to_fun := λ i, additive.of_mul (⟨_, i, rfl⟩ : subgroup.gpowers ζ),
      map_zero' := by { simp only [gpow_zero], refl },
      map_add' := by { intros i j, simp only [gpow_add], refl } },
    (λ i hi,
    begin
      simp only [add_monoid_hom.mem_ker, char_p.int_cast_eq_zero_iff (zmod k) k,
        add_monoid_hom.coe_mk, int.coe_cast_add_hom] at hi ⊢,
      obtain ⟨i, rfl⟩ := hi,
      simp only [gpow_mul, h.pow_eq_one, one_gpow, gpow_coe_nat],
      refl
    end)⟩)
  begin
    split,
    { rw add_monoid_hom.injective_iff,
      intros i hi,
      rw subtype.ext_iff at hi,
      have := (h.gpow_eq_one_iff_dvd _).mp hi,
      rw [← (char_p.int_cast_eq_zero_iff (zmod k) k _).mpr this, eq_comm],
      exact zmod.int_cast_right_inverse i },
    { rintro ⟨ξ, i, rfl⟩,
      refine ⟨int.cast_add_hom _ i, _⟩,
      rw [add_monoid_hom.lift_of_right_inverse_comp_apply],
      refl }
  end

@[simp] lemma zmod_equiv_gpowers_apply_coe_int (i : ℤ) :
  h.zmod_equiv_gpowers i = additive.of_mul (⟨ζ ^ i, i, rfl⟩ : subgroup.gpowers ζ) :=
add_monoid_hom.lift_of_right_inverse_comp_apply _ _ zmod.int_cast_right_inverse _ _

@[simp] lemma zmod_equiv_gpowers_apply_coe_nat (i : ℕ) :
  h.zmod_equiv_gpowers i = additive.of_mul (⟨ζ ^ i, i, rfl⟩ : subgroup.gpowers ζ) :=
begin
  have : (i : zmod k) = (i : ℤ), by norm_cast,
  simp only [this, zmod_equiv_gpowers_apply_coe_int, gpow_coe_nat],
  refl
end

@[simp] lemma zmod_equiv_gpowers_symm_apply_gpow (i : ℤ) :
  h.zmod_equiv_gpowers.symm (additive.of_mul (⟨ζ ^ i, i, rfl⟩ : subgroup.gpowers ζ)) = i :=
by rw [← h.zmod_equiv_gpowers.symm_apply_apply i, zmod_equiv_gpowers_apply_coe_int]

@[simp] lemma zmod_equiv_gpowers_symm_apply_gpow' (i : ℤ) :
  h.zmod_equiv_gpowers.symm ⟨ζ ^ i, i, rfl⟩ = i :=
h.zmod_equiv_gpowers_symm_apply_gpow i

@[simp] lemma zmod_equiv_gpowers_symm_apply_pow (i : ℕ) :
  h.zmod_equiv_gpowers.symm (additive.of_mul (⟨ζ ^ i, i, rfl⟩ : subgroup.gpowers ζ)) = i :=
by rw [← h.zmod_equiv_gpowers.symm_apply_apply i, zmod_equiv_gpowers_apply_coe_nat]

@[simp] lemma zmod_equiv_gpowers_symm_apply_pow' (i : ℕ) :
  h.zmod_equiv_gpowers.symm ⟨ζ ^ i, i, rfl⟩ = i :=
h.zmod_equiv_gpowers_symm_apply_pow i

lemma gpowers_eq {k : ℕ+} {ζ : units R} (h : is_primitive_root ζ k) :
  subgroup.gpowers ζ = roots_of_unity k R :=
begin
  apply set_like.coe_injective,
  haveI : fact (0 < (k : ℕ)) := ⟨k.pos⟩,
  haveI F : fintype (subgroup.gpowers ζ) := fintype.of_equiv _ (h.zmod_equiv_gpowers).to_equiv,
  refine @set.eq_of_subset_of_card_le (units R) (subgroup.gpowers ζ) (roots_of_unity k R)
    F (roots_of_unity.fintype R k)
    (subgroup.gpowers_subset $ show ζ ∈ roots_of_unity k R, from h.pow_eq_one) _,
  calc fintype.card (roots_of_unity k R)
      ≤ k                                 : card_roots_of_unity R k
  ... = fintype.card (zmod k)             : (zmod.card k).symm
  ... = fintype.card (subgroup.gpowers ζ) : fintype.card_congr (h.zmod_equiv_gpowers).to_equiv
end

lemma eq_pow_of_mem_roots_of_unity {k : ℕ+} {ζ ξ : units R}
  (h : is_primitive_root ζ k) (hξ : ξ ∈ roots_of_unity k R) :
  ∃ (i : ℕ) (hi : i < k), ζ ^ i = ξ :=
begin
  obtain ⟨n, rfl⟩ : ∃ n : ℤ, ζ ^ n = ξ, by rwa [← h.gpowers_eq] at hξ,
  have hk0 : (0 : ℤ) < k := by exact_mod_cast k.pos,
  let i := n % k,
  have hi0 : 0 ≤ i := int.mod_nonneg _ (ne_of_gt hk0),
  lift i to ℕ using hi0 with i₀ hi₀,
  refine ⟨i₀, _, _⟩,
  { zify, rw [hi₀], exact int.mod_lt_of_pos _ hk0 },
  { have aux := h.gpow_eq_one, rw [← coe_coe] at aux,
    rw [← gpow_coe_nat, hi₀, ← int.mod_add_div n k, gpow_add, gpow_mul,
        aux, one_gpow, mul_one] }
end

lemma eq_pow_of_pow_eq_one {k : ℕ} {ζ ξ : R}
  (h : is_primitive_root ζ k) (hξ : ξ ^ k = 1) (h0 : 0 < k) :
  ∃ i < k, ζ ^ i = ξ :=
begin
  obtain ⟨ζ, rfl⟩ := h.is_unit h0,
  obtain ⟨ξ, rfl⟩ := is_unit_of_pow_eq_one ξ k hξ h0,
  obtain ⟨k, rfl⟩ : ∃ k' : ℕ+, k = k' := ⟨⟨k, h0⟩, rfl⟩,
  simp only [← units.coe_pow, ← units.ext_iff],
  rw coe_units_iff at h,
  apply h.eq_pow_of_mem_roots_of_unity,
  rw [mem_roots_of_unity, units.ext_iff, units.coe_pow, hξ, units.coe_one]
end

lemma is_primitive_root_iff' {k : ℕ+} {ζ ξ : units R} (h : is_primitive_root ζ k) :
  is_primitive_root ξ k ↔ ∃ (i < (k : ℕ)) (hi : i.coprime k), ζ ^ i = ξ :=
begin
  split,
  { intro hξ,
    obtain ⟨i, hik, rfl⟩ := h.eq_pow_of_mem_roots_of_unity hξ.pow_eq_one,
    rw h.pow_iff_coprime k.pos at hξ,
    exact ⟨i, hik, hξ, rfl⟩ },
  { rintro ⟨i, -, hi, rfl⟩, exact h.pow_of_coprime i hi }
end

lemma is_primitive_root_iff {k : ℕ} {ζ ξ : R} (h : is_primitive_root ζ k) (h0 : 0 < k) :
  is_primitive_root ξ k ↔ ∃ (i < k) (hi : i.coprime k), ζ ^ i = ξ :=
begin
  split,
  { intro hξ,
    obtain ⟨i, hik, rfl⟩ := h.eq_pow_of_pow_eq_one hξ.pow_eq_one h0,
    rw h.pow_iff_coprime h0 at hξ,
    exact ⟨i, hik, hξ, rfl⟩ },
  { rintro ⟨i, -, hi, rfl⟩, exact h.pow_of_coprime i hi }
end

lemma card_roots_of_unity' {n : ℕ+} (h : is_primitive_root ζ n) :
  fintype.card (roots_of_unity n R) = n :=
begin
  haveI : fact (0 < ↑n) := ⟨n.pos⟩,
  let e := h.zmod_equiv_gpowers,
  haveI F : fintype (subgroup.gpowers ζ) := fintype.of_equiv _ e.to_equiv,
  calc fintype.card (roots_of_unity n R)
      = fintype.card (subgroup.gpowers ζ) : fintype.card_congr $ by rw h.gpowers_eq
  ... = fintype.card (zmod n)             : fintype.card_congr e.to_equiv.symm
  ... = n                                 : zmod.card n
end

lemma card_roots_of_unity {ζ : R} {n : ℕ+} (h : is_primitive_root ζ n) :
  fintype.card (roots_of_unity n R) = n :=
begin
  obtain ⟨ζ, hζ⟩ := h.is_unit n.pos,
  rw [← hζ, is_primitive_root.coe_units_iff] at h,
  exact h.card_roots_of_unity'
end

/-- The cardinality of the multiset `nth_roots ↑n (1 : R)` is `n`
if there is a primitive root of unity in `R`. -/
lemma card_nth_roots {ζ : R} {n : ℕ} (h : is_primitive_root ζ n) :
  (nth_roots n (1 : R)).card = n :=
begin
  cases nat.eq_zero_or_pos n with hzero hpos,
  { simp only [hzero, multiset.card_zero, nth_roots_zero] },
  rw eq_iff_le_not_lt,
  use card_nth_roots n 1,
  { rw [not_lt],
    have hcard : fintype.card {x // x ∈ nth_roots n (1 : R)}
      ≤ (nth_roots n (1 : R)).attach.card := multiset.card_le_of_le (multiset.erase_dup_le _),
    rw multiset.card_attach at hcard,
    rw ← pnat.to_pnat'_coe hpos at hcard h ⊢,
    set m := nat.to_pnat' n,
    rw [← fintype.card_congr (roots_of_unity_equiv_nth_roots R m), card_roots_of_unity h] at hcard,
    exact hcard }
end

/-- The multiset `nth_roots ↑n (1 : R)` has no repeated elements
if there is a primitive root of unity in `R`. -/
lemma nth_roots_nodup {ζ : R} {n : ℕ} (h : is_primitive_root ζ n) : (nth_roots n (1 : R)).nodup :=
begin
  cases nat.eq_zero_or_pos n with hzero hpos,
  { simp only [hzero, multiset.nodup_zero, nth_roots_zero] },
  apply (@multiset.erase_dup_eq_self R _ _).1,
  rw eq_iff_le_not_lt,
  split,
  { exact multiset.erase_dup_le (nth_roots n (1 : R)) },
  { by_contra ha,
    replace ha := multiset.card_lt_of_lt ha,
    rw card_nth_roots h at ha,
    have hrw : (nth_roots n (1 : R)).erase_dup.card =
      fintype.card {x // x ∈ (nth_roots n (1 : R))},
    { set fs := (⟨(nth_roots n (1 : R)).erase_dup, multiset.nodup_erase_dup _⟩ : finset R),
      rw [← finset.card_mk, ← fintype.card_of_subtype fs _],
      intro x,
      simp only [multiset.mem_erase_dup, finset.mem_mk] },
    rw ← pnat.to_pnat'_coe hpos at h hrw ha,
    set m := nat.to_pnat' n,
    rw [hrw, ← fintype.card_congr (roots_of_unity_equiv_nth_roots R m),
        card_roots_of_unity h] at ha,
    exact nat.lt_asymm ha ha }
end

@[simp] lemma card_nth_roots_finset {ζ : R} {n : ℕ} (h : is_primitive_root ζ n) :
  (nth_roots_finset n R).card = n :=
by rw [nth_roots_finset, ← multiset.to_finset_eq (nth_roots_nodup h), card_mk, h.card_nth_roots]

open_locale nat

/-- If an integral domain has a primitive `k`-th root of unity, then it has `φ k` of them. -/
lemma card_primitive_roots {ζ : R} {k : ℕ} (h : is_primitive_root ζ k) (h0 : 0 < k) :
  (primitive_roots k R).card = φ k :=
begin
  symmetry,
  refine finset.card_congr (λ i _, ζ ^ i) _ _ _,
  { simp only [true_and, and_imp, mem_filter, mem_range, mem_univ],
    rintro i - hi,
    rw mem_primitive_roots h0,
    exact h.pow_of_coprime i hi.symm },
  { simp only [true_and, and_imp, mem_filter, mem_range, mem_univ],
    rintro i j hi - hj - H,
    exact h.pow_inj hi hj H },
  { simp only [exists_prop, true_and, mem_filter, mem_range, mem_univ],
    intros ξ hξ,
    rw [mem_primitive_roots h0, h.is_primitive_root_iff h0] at hξ,
    rcases hξ with ⟨i, hin, hi, H⟩,
    exact ⟨i, ⟨hin, hi.symm⟩, H⟩ }
end

/-- The sets `primitive_roots k R` are pairwise disjoint. -/
lemma disjoint {k l : ℕ} (hk : 0 < k) (hl : 0 < l) (h : k ≠ l) :
  disjoint (primitive_roots k R) (primitive_roots l R) :=
begin
  intro z,
  simp only [finset.inf_eq_inter, finset.mem_inter, mem_primitive_roots, hk, hl, iff_def],
  rintro ⟨⟨hzk, Hzk⟩, ⟨hzl, Hzl⟩⟩,
  apply_rules [h, nat.dvd_antisymm, Hzk, Hzl, hzk, hzl]
end

/-- If there is a `n`-th primitive root of unity in `R` and `b` divides `n`,
then there is a `b`-th primitive root of unity in `R`. -/
lemma pow {ζ : R} {n : ℕ} {a b : ℕ}
  (hn : 0 < n) (h : is_primitive_root ζ n) (hprod : n = a * b) :
  is_primitive_root (ζ ^ a) b :=
begin
  subst n,
  simp only [iff_def, ← pow_mul, h.pow_eq_one, eq_self_iff_true, true_and],
  intros l hl,
  have ha0 : a ≠ 0, { rintro rfl, simpa only [nat.not_lt_zero, zero_mul] using hn },
  rwa ← mul_dvd_mul_iff_left ha0,
  exact h.dvd_of_pow_eq_one _ hl
end

/-- `nth_roots n` as a `finset` is equal to the union of `primitive_roots i R` for `i ∣ n`
if there is a primitive root of unity in `R`. -/
lemma nth_roots_one_eq_bUnion_primitive_roots' {ζ : R} {n : ℕ+} (h : is_primitive_root ζ n) :
  nth_roots_finset n R = (nat.divisors ↑n).bUnion (λ i, (primitive_roots i R)) :=
begin
  symmetry,
  apply finset.eq_of_subset_of_card_le,
  { intros x,
    simp only [nth_roots_finset, ← multiset.to_finset_eq (nth_roots_nodup h),
      exists_prop, finset.mem_bUnion, finset.mem_filter, finset.mem_range, mem_nth_roots,
      finset.mem_mk, nat.mem_divisors, and_true, ne.def, pnat.ne_zero, pnat.pos, not_false_iff],
    rintro ⟨a, ⟨d, hd⟩, ha⟩,
    have hazero : 0 < a,
    { contrapose! hd with ha0,
      simp only [nonpos_iff_eq_zero, zero_mul, *] at *,
      exact n.ne_zero },
    rw mem_primitive_roots hazero at ha,
    rw [hd, pow_mul, ha.pow_eq_one, one_pow] },
  { apply le_of_eq,
    rw [h.card_nth_roots_finset, finset.card_bUnion],
    { rw [← nat.sum_totient n, nat.filter_dvd_eq_divisors (pnat.ne_zero n), sum_congr rfl]
        { occs := occurrences.pos [1] },
      simp only [finset.mem_filter, finset.mem_range, nat.mem_divisors],
      rintro k ⟨H, hk⟩,
      have hdvd := H,
      rcases H with ⟨d, hd⟩,
      rw mul_comm at hd,
      rw (h.pow n.pos hd).card_primitive_roots (pnat.pos_of_div_pos hdvd) },
    { intros i hi j hj hdiff,
      simp only [nat.mem_divisors, and_true, ne.def, pnat.ne_zero, not_false_iff] at hi hj,
      exact disjoint (pnat.pos_of_div_pos hi) (pnat.pos_of_div_pos hj) hdiff } }
end

/-- `nth_roots n` as a `finset` is equal to the union of `primitive_roots i R` for `i ∣ n`
if there is a primitive root of unity in `R`. -/
lemma nth_roots_one_eq_bUnion_primitive_roots {ζ : R} {n : ℕ} (hpos : 0 < n)
  (h : is_primitive_root ζ n) :
  nth_roots_finset n R = (nat.divisors n).bUnion (λ i, (primitive_roots i R)) :=
@nth_roots_one_eq_bUnion_primitive_roots' _ _ _ ⟨n, hpos⟩ h

end integral_domain

section minpoly

open minpoly

variables {n : ℕ} {K : Type*} [field K] {μ : K} (h : is_primitive_root μ n) (hpos : 0 < n)

include n μ h hpos

/--`μ` is integral over `ℤ`. -/
lemma is_integral : is_integral ℤ μ :=
begin
  use (X ^ n - 1),
  split,
  { exact (monic_X_pow_sub_C 1 (ne_of_lt hpos).symm) },
  { simp only [((is_primitive_root.iff_def μ n).mp h).left, eval₂_one, eval₂_X_pow, eval₂_sub,
      sub_self] }
end

variables [char_zero K]

/--The minimal polynomial of a root of unity `μ` divides `X ^ n - 1`. -/
lemma minpoly_dvd_X_pow_sub_one : minpoly ℤ μ ∣ X ^ n - 1 :=
begin
  apply integer_dvd (is_integral h hpos) (polynomial.monic.is_primitive
  (monic_X_pow_sub_C 1 (ne_of_lt hpos).symm)),
  simp only [((is_primitive_root.iff_def μ n).mp h).left, aeval_X_pow, ring_hom.eq_int_cast,
  int.cast_one, aeval_one, alg_hom.map_sub, sub_self]
end

/-- The reduction modulo `p` of the minimal polynomial of a root of unity `μ` is separable. -/
lemma separable_minpoly_mod {p : ℕ} [fact p.prime] (hdiv : ¬p ∣ n) :
  separable (map (int.cast_ring_hom (zmod p)) (minpoly ℤ μ)) :=
begin
  have hdvd : (map (int.cast_ring_hom (zmod p))
    (minpoly ℤ μ)) ∣ X ^ n - 1,
  { simpa [map_pow, map_X, map_one, ring_hom.coe_of, map_sub] using
      ring_hom.map_dvd (ring_hom.of (map (int.cast_ring_hom (zmod p))))
        (minpoly_dvd_X_pow_sub_one h hpos) },
  refine separable.of_dvd (separable_X_pow_sub_C 1 _ one_ne_zero) hdvd,
  by_contra hzero,
  exact hdiv ((zmod.nat_coe_zmod_eq_zero_iff_dvd n p).1 (not_not.1 hzero))
end

/-- The reduction modulo `p` of the minimal polynomial of a root of unity `μ` is squarefree. -/
lemma squarefree_minpoly_mod {p : ℕ} [fact p.prime] (hdiv : ¬ p ∣ n) :
  squarefree (map (int.cast_ring_hom (zmod p)) (minpoly ℤ μ)) :=
(separable_minpoly_mod h hpos hdiv).squarefree

/- Let `P` be the minimal polynomial of a root of unity `μ` and `Q` be the minimal polynomial of
`μ ^ p`, where `p` is a prime that does not divide `n`. Then `P` divides `expand ℤ p Q`. -/
lemma minpoly_dvd_expand {p : ℕ} (hprime : nat.prime p) (hdiv : ¬ p ∣ n) :
  minpoly ℤ μ ∣
  expand ℤ p (minpoly ℤ (μ ^ p)) :=
begin
  apply minpoly.integer_dvd (h.is_integral hpos),
  { apply monic.is_primitive,
    rw [polynomial.monic, leading_coeff, nat_degree_expand, mul_comm, coeff_expand_mul'
        (nat.prime.pos hprime), ← leading_coeff, ← polynomial.monic],
    exact minpoly.monic (is_integral (pow_of_prime h hprime hdiv) hpos) },
  { rw [aeval_def, coe_expand, ← comp, eval₂_eq_eval_map, map_comp, map_pow, map_X, eval_comp,
      eval_pow, eval_X, ← eval₂_eq_eval_map, ← aeval_def],
    exact minpoly.aeval _ _ }
end

/- Let `P` be the minimal polynomial of a root of unity `μ` and `Q` be the minimal polynomial of
`μ ^ p`, where `p` is a prime that does not divide `n`. Then `P` divides `Q ^ p` modulo `p`. -/
lemma minpoly_dvd_pow_mod {p : ℕ} [hprime : fact p.prime] (hdiv : ¬ p ∣ n) :
  map (int.cast_ring_hom (zmod p)) (minpoly ℤ μ) ∣
  map (int.cast_ring_hom (zmod p)) (minpoly ℤ (μ ^ p)) ^ p :=
begin
  set Q := minpoly ℤ (μ ^ p),
  have hfrob : map (int.cast_ring_hom (zmod p)) Q ^ p =
    map (int.cast_ring_hom (zmod p)) (expand ℤ p Q),
  by rw [← zmod.expand_card, map_expand hprime.1.pos],
  rw [hfrob],
  apply ring_hom.map_dvd (ring_hom.of (map (int.cast_ring_hom (zmod p)))),
  exact minpoly_dvd_expand h hpos hprime.1 hdiv
end

/- Let `P` be the minimal polynomial of a root of unity `μ` and `Q` be the minimal polynomial of
`μ ^ p`, where `p` is a prime that does not divide `n`. Then `P` divides `Q` modulo `p`. -/
lemma minpoly_dvd_mod_p {p : ℕ} [hprime : fact p.prime] (hdiv : ¬ p ∣ n) :
  map (int.cast_ring_hom (zmod p)) (minpoly ℤ μ) ∣
  map (int.cast_ring_hom (zmod p)) (minpoly ℤ (μ ^ p)) :=
(unique_factorization_monoid.dvd_pow_iff_dvd_of_squarefree (squarefree_minpoly_mod h
  hpos hdiv) hprime.1.ne_zero).1 (minpoly_dvd_pow_mod h hpos hdiv)

/-- If `p` is a prime that does not divide `n`,
then the minimal polynomials of a primitive `n`-th root of unity `μ`
and of `μ ^ p` are the same. -/
lemma minpoly_eq_pow {p : ℕ} [hprime : fact p.prime] (hdiv : ¬ p ∣ n) :
  minpoly ℤ μ = minpoly ℤ (μ ^ p) :=
begin
  by_contra hdiff,
  set P := minpoly ℤ μ,
  set Q := minpoly ℤ (μ ^ p),
  have Pmonic : P.monic := minpoly.monic (h.is_integral hpos),
  have Qmonic : Q.monic := minpoly.monic ((h.pow_of_prime hprime.1 hdiv).is_integral hpos),
  have Pirr : irreducible P := minpoly.irreducible (h.is_integral hpos),
  have Qirr : irreducible Q :=
    minpoly.irreducible ((h.pow_of_prime hprime.1 hdiv).is_integral hpos),
  have PQprim : is_primitive (P * Q) := Pmonic.is_primitive.mul Qmonic.is_primitive,
  have prod : P * Q ∣ X ^ n - 1,
  { rw [(is_primitive.int.dvd_iff_map_cast_dvd_map_cast (P * Q) (X ^ n - 1) PQprim
      (monic_X_pow_sub_C (1 : ℤ) (ne_of_gt hpos)).is_primitive), map_mul],
    refine is_coprime.mul_dvd _ _ _,
    { have aux := is_primitive.int.irreducible_iff_irreducible_map_cast Pmonic.is_primitive,
      refine (dvd_or_coprime _ _ (aux.1 Pirr)).resolve_left _,
      rw map_dvd_map (int.cast_ring_hom ℚ) int.cast_injective Pmonic,
      intro hdiv,
      refine hdiff (eq_of_monic_of_associated Pmonic Qmonic _),
      exact associated_of_dvd_dvd hdiv (dvd_symm_of_irreducible Pirr Qirr hdiv) },
    { apply (map_dvd_map (int.cast_ring_hom ℚ) int.cast_injective Pmonic).2,
      exact minpoly_dvd_X_pow_sub_one h hpos },
    { apply (map_dvd_map (int.cast_ring_hom ℚ) int.cast_injective Qmonic).2,
      exact minpoly_dvd_X_pow_sub_one (pow_of_prime h hprime.1 hdiv) hpos } },
  replace prod := ring_hom.map_dvd (ring_hom.of (map (int.cast_ring_hom (zmod p)))) prod,
  rw [ring_hom.coe_of, map_mul, map_sub, map_one, map_pow, map_X] at prod,
  obtain ⟨R, hR⟩ := minpoly_dvd_mod_p h hpos hdiv,
  rw [hR, ← mul_assoc, ← map_mul, ← sq, map_pow] at prod,
  have habs : map (int.cast_ring_hom (zmod p)) P ^ 2 ∣ map (int.cast_ring_hom (zmod p)) P ^ 2 * R,
  { use R },
  replace habs := lt_of_lt_of_le (enat.coe_lt_coe.2 one_lt_two)
    (multiplicity.le_multiplicity_of_pow_dvd (dvd_trans habs prod)),
  have hfree : squarefree (X ^ n - 1 : polynomial (zmod p)),
  { refine squarefree_X_pow_sub_C 1 _ one_ne_zero,
    by_contra hzero,
    exact hdiv ((zmod.nat_coe_zmod_eq_zero_iff_dvd n p).1 (not_not.1 hzero)) },
  cases (multiplicity.squarefree_iff_multiplicity_le_one (X ^ n - 1)).1 hfree
    (map (int.cast_ring_hom (zmod p)) P) with hle hunit,
  { exact not_lt_of_le hle habs },
  { replace hunit := degree_eq_zero_of_is_unit hunit,
    rw degree_map_eq_of_leading_coeff_ne_zero _ _ at hunit,
    { exact (ne_of_lt (minpoly.degree_pos (is_integral h hpos))).symm hunit },
    simp only [Pmonic, ring_hom.eq_int_cast, monic.leading_coeff, int.cast_one, ne.def,
      not_false_iff, one_ne_zero] },
end

/-- If `m : ℕ` is coprime with `n`,
then the minimal polynomials of a primitive `n`-th root of unity `μ`
and of `μ ^ m` are the same. -/
lemma minpoly_eq_pow_coprime {m : ℕ} (hcop : nat.coprime m n) :
  minpoly ℤ μ = minpoly ℤ (μ ^ m) :=
begin
  revert n hcop,
  refine unique_factorization_monoid.induction_on_prime m _ _ _,
  { intros n hn h hpos,
    congr,
    simpa [(nat.coprime_zero_left n).mp hn] using h },
  { intros u hunit n hcop h hpos,
    congr,
    simp [nat.is_unit_iff.mp hunit] },
  { intros a p ha hprime hind n hcop h hpos,
    rw hind (nat.coprime.coprime_mul_left hcop) h hpos, clear hind,
    replace hprime := nat.prime_iff_prime.2 hprime,
    have hdiv := (nat.prime.coprime_iff_not_dvd hprime).1 (nat.coprime.coprime_mul_right hcop),
    haveI := fact.mk hprime,
    rw [minpoly_eq_pow
      (h.pow_of_coprime a (nat.coprime.coprime_mul_left hcop)) hpos hdiv],
    congr' 1,
    ring_exp }
end

/-- If `m : ℕ` is coprime with `n`,
then the minimal polynomial of a primitive `n`-th root of unity `μ`
has `μ ^ m` as root. -/
lemma pow_is_root_minpoly {m : ℕ} (hcop : nat.coprime m n) :
  is_root (map (int.cast_ring_hom K) (minpoly ℤ μ)) (μ ^ m) :=
by simpa [minpoly_eq_pow_coprime h hpos hcop, eval_map, aeval_def (μ ^ m) _]
  using minpoly.aeval ℤ (μ ^ m)

/-- `primitive_roots n K` is a subset of the roots of the minimal polynomial of a primitive
`n`-th root of unity `μ`. -/
lemma is_roots_of_minpoly : primitive_roots n K ⊆ (map (int.cast_ring_hom K)
  (minpoly ℤ μ)).roots.to_finset :=
begin
  intros x hx,
  obtain ⟨m, hle, hcop, rfl⟩ := (is_primitive_root_iff h hpos).1 ((mem_primitive_roots hpos).1 hx),
  simpa [multiset.mem_to_finset,
    mem_roots (map_monic_ne_zero $ minpoly.monic $ is_integral h hpos)]
    using pow_is_root_minpoly h hpos hcop
end

/-- The degree of the minimal polynomial of `μ` is at least `totient n`. -/
lemma totient_le_degree_minpoly : nat.totient n ≤ (minpoly ℤ μ).nat_degree :=
let P : polynomial ℤ := minpoly ℤ μ,-- minimal polynomial of `μ`
    P_K : polynomial K := map (int.cast_ring_hom K) P -- minimal polynomial of `μ` sent to `K[X]`
in calc
n.totient = (primitive_roots n K).card : (h.card_primitive_roots hpos).symm
... ≤ P_K.roots.to_finset.card : finset.card_le_of_subset (is_roots_of_minpoly h hpos)
... ≤ P_K.roots.card : multiset.to_finset_card_le _
... ≤ P_K.nat_degree : (card_roots' $ map_monic_ne_zero
        (minpoly.monic $ is_integral h hpos))
... ≤ P.nat_degree : nat_degree_map_le _

end minpoly

end is_primitive_root


-- Pruebas de la transitividad de la igualdad
-- ==========================================

import tactic

variable  (U : Type)
variables (x y z : U)

-- ----------------------------------------------------
-- Ej. 1. Demostrar que
--    x = y, y = z ⊢ x = z
-- ----------------------------------------------------

-- 1ª demostración
example
  (h1 : x = y)
  (h2 : y = z)
  : x = z :=
eq.subst h2 h1

-- 2ª demostración
example
  (h1 : x = y)
  (h2 : y = z)
  : x = z :=
h2 ▸ h1

-- 3ª demostración
example
  (h1 : x = y)
  (h2 : y = z)
  : x = z :=
eq.substr h1 h2

-- 4ª demostración
example
  (h1 : x = y)
  (h2 : y = z)
  : x = z :=
eq.trans h1 h2

-- 5ª demostración
example
  (h1 : x = y)
  (h2 : y = z)
  : x = z :=
begin
  rw h1,
  exact h2,
end

-- 6ª demostración
example
  (h1 : x = y)
  (h2 : y = z)
  : x = z :=
begin
  rw h1,
  assumption,
end

-- 7ª demostración
example
  (h1 : x = y)
  (h2 : y = z)
  : x = z :=
begin
  rwa h1,
end

-- 8ª demostración
example
  (h1 : x = y)
  (h2 : y = z)
  : x = z :=
by rwa h1

-- 9ª demostración
example
  (h1 : x = y)
  (h2 : y = z)
  : x = z :=
begin
  rwa ←h2,
end

-- 10ª demostración
example
  (h1 : x = y)
  (h2 : y = z)
  : x = z :=
begin
  rwa h2 at h1,
end

-- 11ª demostración
example
  (h1 : x = y)
  (h2 : y = z)
  : x = z :=
by simp *

-- 12ª demostración
example
  (h1 : x = y)
  (h2 : y = z)
  : x = z :=
-- by hint
by finish


/-
Copyright (c) 2020 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import topology.basic
import order.omega_complete_partial_order

/-!
# Scott Topological Spaces

A type of topological spaces whose notion
of continuity is equivalent to continuity in ωCPOs.

## Reference

 * https://ncatlab.org/nlab/show/Scott+topology

-/

open set omega_complete_partial_order
open_locale classical

universes u
namespace Scott

/-- `x` is an `ω`-Sup of a chain `c` if it is the least upper bound of the range of `c`. -/
def is_ωSup {α : Type u} [preorder α] (c : chain α) (x : α) : Prop :=
(∀ i, c i ≤ x) ∧ (∀ y, (∀ i, c i ≤ y) → x ≤ y)

lemma is_ωSup_iff_is_lub {α : Type u} [preorder α] {c : chain α} {x : α} :
  is_ωSup c x ↔ is_lub (range c) x :=
by simp [is_ωSup, is_lub, is_least, upper_bounds, lower_bounds]

variables (α : Type u) [omega_complete_partial_order α]
local attribute [irreducible] set

/-- The characteristic function of open sets is monotone and preserves
the limits of chains. -/
def is_open (s : set α) : Prop :=
continuous' (λ x, x ∈ s)

theorem is_open_univ : is_open α univ :=
⟨λ x y h hx, mem_univ _,
  by { convert @complete_lattice.top_continuous α Prop _ _, exact rfl }⟩

theorem is_open.inter (s t : set α) : is_open α s → is_open α t → is_open α (s ∩ t) :=
complete_lattice.inf_continuous'

theorem is_open_sUnion (s : set (set α)) (hs : ∀t∈s, is_open α t) : is_open α (⋃₀ s) :=
begin
  simp only [is_open] at hs ⊢,
  convert complete_lattice.Sup_continuous' (set_of ⁻¹' s) _,
  { ext1 x,
    simp only [Sup_apply, set_of_bijective.surjective.exists, exists_prop, mem_preimage,
      set_coe.exists, supr_Prop_eq, mem_set_of_eq, subtype.coe_mk, mem_sUnion] },
  { intros p hp,
    convert hs (set_of p) (mem_preimage.1 hp),
    simp only [mem_set_of_eq] },
end

end Scott

/-- A Scott topological space is defined on preorders
such that their open sets, seen as a function `α → Prop`,
preserves the joins of ω-chains  -/
@[reducible]
def Scott (α : Type u) := α

instance Scott.topological_space (α : Type u) [omega_complete_partial_order α] :
  topological_space (Scott α) :=
{ is_open := Scott.is_open α,
  is_open_univ := Scott.is_open_univ α,
  is_open_inter := Scott.is_open.inter α,
  is_open_sUnion := Scott.is_open_sUnion α }

section not_below
variables {α : Type*} [omega_complete_partial_order α] (y : Scott α)

/-- `not_below` is an open set in `Scott α` used
to prove the monotonicity of continuous functions -/
def not_below := { x | ¬ x ≤ y }

lemma not_below_is_open : is_open (not_below y) :=
begin
  have h : monotone (not_below y),
  { intros x y' h,
    simp only [not_below, set_of, le_Prop_eq],
    intros h₀ h₁, apply h₀ (le_trans h h₁) },
  existsi h, rintros c,
  apply eq_of_forall_ge_iff, intro z,
  rw ωSup_le_iff,
  simp only [ωSup_le_iff, not_below, mem_set_of_eq, le_Prop_eq, order_hom.coe_fun_mk,
             chain.map_coe, function.comp_app, exists_imp_distrib, not_forall],
end

end not_below

open Scott (hiding is_open)
open omega_complete_partial_order

lemma is_ωSup_ωSup {α} [omega_complete_partial_order α] (c : chain α) :
  is_ωSup c (ωSup c) :=
begin
  split,
  { apply le_ωSup, },
  { apply ωSup_le, },
end

lemma Scott_continuous_of_continuous {α β}
  [omega_complete_partial_order α]
  [omega_complete_partial_order β]
  (f : Scott α → Scott β) (hf : continuous f) :
  omega_complete_partial_order.continuous' f :=
begin
  simp only [continuous_def, (⁻¹')] at hf,
  have h : monotone f,
  { intros x y h,
    cases (hf {x | ¬ x ≤ f y} (not_below_is_open _)) with hf hf', clear hf',
    specialize hf h, simp only [preimage, mem_set_of_eq, le_Prop_eq] at hf,
    by_contradiction H, apply hf H le_rfl },
  existsi h, intro c,
  apply eq_of_forall_ge_iff, intro z,
  specialize (hf _ (not_below_is_open z)),
  cases hf, specialize hf_h c,
  simp only [not_below, order_hom.coe_fun_mk, eq_iff_iff, mem_set_of_eq] at hf_h,
  rw [← not_iff_not],
  simp only [ωSup_le_iff, hf_h, ωSup, supr, Sup, complete_lattice.Sup, complete_semilattice_Sup.Sup,
    exists_prop, mem_range, order_hom.coe_fun_mk, chain.map_coe, function.comp_app,
    eq_iff_iff, not_forall],
  tauto,
end

lemma continuous_of_Scott_continuous {α β}
  [omega_complete_partial_order α]
  [omega_complete_partial_order β]
  (f : Scott α → Scott β) (hf : omega_complete_partial_order.continuous' f) :
  continuous f :=
begin
  rw continuous_def,
  intros s hs,
  change continuous' (s ∘ f),
  cases hs with hs hs',
  cases hf with hf hf',
  apply continuous.of_bundled,
  apply continuous_comp _ _ hf' hs',
end


import .Preloaded

theorem exercise_1p3 (x y : ℕ → ℝ) (l : ℝ)
  (h₁ : ∀ n, abs (x n - l) ≤ y n) (h₂ : lim_to_inf y 0) :
  lim_to_inf x l :=
begin
  unfold lim_to_inf at *,
  intros ε hep,
  specialize h₂ ε hep, simp at h₂,
  cases h₂ with N H,
  use N,
  intros n hn,
  specialize H n hn,
  apply lt_of_le_of_lt,
    exact h₁ n,
  apply lt_of_le_of_lt,
    exact le_abs_self (y n),
  exact H,
end


import data.nat.basic
import data.nat.parity
import data.int.basic
import data.equiv.denumerable
import data.int.modeq
import tactic

-- Determine all possible colorings of the integers that satisfy these rules.

structure coloring :=
-- Each integer on the number line is colored with exactly one of three possible colors—red, green or blue
(red blue : set ℤ)
(disjoint : ∀ n, ¬(red n ∧ blue n) )
--according to the following two rules:
-- the negative of a red number must be colored blue,
(neg_red : ∀ n, red n → blue (-n))
--and the sum of two blue numbers (not necessarily distinct) must be colored red.
(add_blue : ∀ n m ∈ blue, n + m ∈ red)

example (n m : ℤ) : n ≡ 2 [ZMOD 3] → m ≡ 2 [ZMOD 3] → (n+m) ≡ 1 [ZMOD 3]:=
begin
exact int.modeq.modeq_add,
end

-- a nontrivial example of a coloring
def mod_3_coloring : coloring :=
begin
  refine {red := {x | x ≡ 1 [ZMOD 3]},
  blue := {x | x ≡ 2 [ZMOD 3]},
  disjoint := by {intros n hn, cases hn with h1 h2,
    have key : 1 ≡ 2 [ZMOD 3], transitivity n, symmetry, assumption',
    revert key,
    exact of_to_bool_ff rfl},
  neg_red := by {intro n, exact int.modeq.modeq_neg},
  add_blue := by {intros n m, exact int.modeq.modeq_add}},
end

-- Show that the negative of a blue number must be colored red

lemma neg_blue {x : coloring} {n : ℤ} (hn : x.blue n) : x.red (-n) := begin
-- intros n hn,
have calc1 := x.add_blue _ _ hn hn,
have calc2 := x.neg_red _ calc1,
have calc3 := x.add_blue _ _ hn calc2,
have calc4 : n + -(n + n) = (-n), ring,
rw calc4 at calc3, exact calc3,
end

-- and the sum of two red numbers must be colored blue.

lemma add_red {x : coloring} {n m : ℤ} (hn : x.red n) (hm : x.red m) : n + m ∈ x.blue :=
begin
-- intros n m hn hm,
have calc1 := x.neg_red _ hn,
have calc2 := x.neg_red _ hm,
have calc3 := x.add_blue _ _ calc1 calc2,
have calc4 := x.neg_red _ calc3,
simp only [neg_add_rev, neg_neg] at calc4,
rw add_comm, exact calc4,
end

-- Determine all possible colorings of the integers that satisfy these rules.

-- if x is blue, then 2^n * x is blue when n is even and red when n is odd
-- so coloring behavior is determined by behavior on 2 and odd numbers
-- if 2 is blue and 1 is red, then all numbers 1 mod 4 are red and 3 mod 4 are blue

lemma zero_green (x : coloring) : ¬ x.red 0 ∧ ¬ x.blue 0 :=
begin
split; intro,
  have calc1 := x.neg_red _ a,
  swap, have calc1 := neg_blue x _ a,
all_goals {simp only [neg_zero] at calc1, apply x.disjoint 0, finish},
end

lemma reachable_from_one (x : coloring) (h1 : x.red 1) : false :=
begin
  have h2 := add_red x 1 1 h1 h1, norm_num at h2,
  -- get powers of two by induction
end

lemma powers_of_two {x : coloring} {n : ℤ} (hn : x.red n) (k : ℕ) :
2^(2 * k) * n ∈ x.red ∧ 2 ^ (2 * k + 1) * n ∈ x.blue :=
begin
  induction k with k hk,
    {simp only [one_mul, pow_one, mul_zero, pow_zero],
    split, assumption,
    have key := add_red x _ _ hn hn, ring at key, exact key},
  suffices key : 2 ^ (2 * k.succ) * n ∈ x.red,
    {split, assumption,
    have calc1 := add_red x _ _ key key,
    ring_exp at calc1, ring_exp, exact calc1},
  cases hk with _ hk,
    have calc1 := x.add_blue _ _ hk hk,
    rw ← nat.add_one, ring_exp, norm_num, ring_exp,
    ring_exp at calc1, exact calc1,
end

lemma red_sub_blue {x : coloring} {n m : ℤ} (hn : x.red n) (hm : x.blue m) :
x.blue (n - m) :=
begin
  have calc1 := neg_blue hm,
  have calc2 := add_red hn calc1,
  ring at calc2, exact calc2,
end

lemma blue_mul_3_not_red (x : coloring) (n : ℤ) (hn : x.blue n) (h3n : x.red (3*n)) : false :=
begin
  have key1 := red_sub_blue h3n hn, ring at key1,
  have key2 := x.add_blue _ _ hn hn, ring at key2,
  apply x.disjoint (2 * n), finish,
end

lemma red_mul_3_not_red (x : coloring) (n : ℤ) (hn : x.red n) (h3n : x.red (3*n)) : false :=
begin
  have h16n := (powers_of_two hn 2).left, norm_num at h16n,
  suffices h13n : x.red (13 * n),
    {have calc2 := add_red h13n h3n, ring at calc2,
    apply x.disjoint (16 * n), finish},
  have calc1 := powers_of_two hn 1, cases calc1 with h4n h8n, norm_num at h4n h8n,
  have h5n := add_red hn h4n, ring at h5n,
  have h13n := x.add_blue _ _ h5n h8n, ring at h13n, exact h13n,
end

lemma mul_3_not_red {x : coloring} {n : ℤ} (hn : n ≡ 0 [ZMOD 3]) (n_red : x.red n) : false :=
begin
  have calc1 : 3 ∣ n := int.dvd_of_mod_eq_zero hn,
  cases calc1 with k hk,
--   have calc1 : ∃ k, n = 3 * k,
end

lemma one_mod_3_red_of_one_red {x : coloring} (h1 : x.red 1) (n : ℕ):
x.red (3 * n + 1) ∧ x.blue (3 * n + 2) :=
begin
  have h2 := add_red h1 h1, ring at h2,
  induction n with k hk,
  { norm_num, split; assumption },
  suffices key : x.red (3 * ↑(k.succ) + 1),
    { split, assumption,
      have := add_red key h1, ring at this, exact this },
  have := x.add_blue _ _ hk.right h2, ring at this,
  rw ← nat.add_one, norm_cast, ring, exact this,
end

-- p blue, q blue
-- 2q > p
-- p + q red
-- 2q red

-- a red number minus a blue number is a blue number

-- this reduces the problem to coloring the odd numbers

-- n is blue
-- 2n is red
-- 4n is blue
-- 5n is red
-- 8n is red
-- 7n is blue
-- 11n is red
-- 13n is blue

-- 3*n is red, n is blue,
-- implies 2n is blue; contradiction

-- n is red, 4*n is red, 16*n is red,
-- 5*n is blue
-- 20*n is blue
-- -20*n is red
-- -4*n is blue


variable a : ℕ

#check lt_irrefl

-- BEGIN
example (h : 0 < 0) : a > 37 :=
begin
  exfalso,
  apply lt_irrefl 0 h
end

example (h : 0 < 0) : a > 37 :=
absurd h (lt_irrefl 0)

example (h : 0 < 0) : a > 37 :=
begin
  have h' : ¬ 0 < 0,
    from lt_irrefl 0,
  contradiction
end
-- END


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import data.finsupp.order

/-!
# Equivalence between `multiset` and `ℕ`-valued finitely supported functions

This defines `finsupp.to_multiset` the equivalence between `α →₀ ℕ` and `multiset α`, along
with `multiset.to_finsupp` the reverse equivalence and `finsupp.order_iso_multiset` the equivalence
promoted to an order isomorphism.
-/

open finset
open_locale big_operators classical
noncomputable theory

variables {α β ι  : Type*}

namespace finsupp

/-- Given `f : α →₀ ℕ`, `f.to_multiset` is the multiset with multiplicities given by the values of
`f` on the elements of `α`. We define this function as an `add_equiv`. -/
def to_multiset : (α →₀ ℕ) ≃+ multiset α :=
{ to_fun := λ f, f.sum (λa n, n • {a}),
  inv_fun := λ s, ⟨s.to_finset, λ a, s.count a, λ a, by simp⟩,
  left_inv := λ f, ext $ λ a, by
    { simp only [sum, multiset.count_sum', multiset.count_singleton, mul_boole, coe_mk,
        mem_support_iff, multiset.count_nsmul, finset.sum_ite_eq, ite_not, ite_eq_right_iff],
      exact eq.symm },
  right_inv := λ s, by simp only [sum, coe_mk, multiset.to_finset_sum_count_nsmul_eq],
  map_add' := λ f g, sum_add_index' (λ a, zero_nsmul _) (λ a, add_nsmul _) }

lemma to_multiset_zero : (0 : α →₀ ℕ).to_multiset = 0 := rfl

lemma to_multiset_add (m n : α →₀ ℕ) : (m + n).to_multiset = m.to_multiset + n.to_multiset :=
to_multiset.map_add m n

lemma to_multiset_apply (f : α →₀ ℕ) : f.to_multiset = f.sum (λ a n, n • {a}) := rfl

@[simp]
lemma to_multiset_symm_apply [decidable_eq α] (s : multiset α) (x : α) :
  finsupp.to_multiset.symm s x = s.count x :=
by convert rfl

@[simp] lemma to_multiset_single (a : α) (n : ℕ) : to_multiset (single a n) = n • {a} :=
by rw [to_multiset_apply, sum_single_index]; apply zero_nsmul

lemma to_multiset_sum {f : ι → α →₀ ℕ} (s : finset ι) :
  finsupp.to_multiset (∑ i in s, f i) = ∑ i in s, finsupp.to_multiset (f i) :=
add_equiv.map_sum _ _ _

lemma to_multiset_sum_single (s : finset ι) (n : ℕ) :
  finsupp.to_multiset (∑ i in s, single i n) = n • s.val :=
by simp_rw [to_multiset_sum, finsupp.to_multiset_single, sum_nsmul, sum_multiset_singleton]

lemma card_to_multiset (f : α →₀ ℕ) : f.to_multiset.card = f.sum (λ a, id) :=
by simp [to_multiset_apply, add_monoid_hom.map_finsupp_sum, function.id_def]

lemma to_multiset_map (f : α →₀ ℕ) (g : α → β) :
  f.to_multiset.map g = (f.map_domain g).to_multiset :=
begin
  refine f.induction _ _,
  { rw [to_multiset_zero, multiset.map_zero, map_domain_zero, to_multiset_zero] },
  { assume a n f _ _ ih,
    rw [to_multiset_add, multiset.map_add, ih, map_domain_add, map_domain_single,
        to_multiset_single, to_multiset_add, to_multiset_single,
        ← multiset.coe_map_add_monoid_hom, (multiset.map_add_monoid_hom g).map_nsmul],
    refl }
end

@[simp] lemma prod_to_multiset [comm_monoid α] (f : α →₀ ℕ) :
  f.to_multiset.prod = f.prod (λ a n, a ^ n) :=
begin
  refine f.induction _ _,
  { rw [to_multiset_zero, multiset.prod_zero, finsupp.prod_zero_index] },
  { assume a n f _ _ ih,
    rw [to_multiset_add, multiset.prod_add, ih, to_multiset_single, multiset.prod_nsmul,
      finsupp.prod_add_index' pow_zero pow_add, finsupp.prod_single_index, multiset.prod_singleton],
    { exact pow_zero a } }
end

@[simp] lemma to_finset_to_multiset [decidable_eq α] (f : α →₀ ℕ) :
  f.to_multiset.to_finset = f.support :=
begin
  refine f.induction _ _,
  { rw [to_multiset_zero, multiset.to_finset_zero, support_zero] },
  { assume a n f ha hn ih,
    rw [to_multiset_add, multiset.to_finset_add, ih, to_multiset_single, support_add_eq,
      support_single_ne_zero hn, multiset.to_finset_nsmul _ _ hn, multiset.to_finset_singleton],
    refine disjoint.mono_left support_single_subset _,
    rwa [finset.disjoint_singleton_left] }
end

@[simp] lemma count_to_multiset [decidable_eq α] (f : α →₀ ℕ) (a : α) :
  f.to_multiset.count a = f a :=
calc f.to_multiset.count a = f.sum (λx n, (n • {x} : multiset α).count a) :
  (multiset.count_add_monoid_hom a).map_sum _ f.support
  ... = f.sum (λx n, n * ({x} : multiset α).count a) : by simp only [multiset.count_nsmul]
  ... = f a * ({a} : multiset α).count a : sum_eq_single _
    (λ a' _ H, by simp only [multiset.count_singleton, if_false, H.symm, mul_zero])
    (λ H, by simp only [not_mem_support_iff.1 H, zero_mul])
  ... = f a : by rw [multiset.count_singleton_self, mul_one]

@[simp] lemma mem_to_multiset (f : α →₀ ℕ) (i : α) : i ∈ f.to_multiset ↔ i ∈ f.support :=
by rw [←multiset.count_ne_zero, finsupp.count_to_multiset, finsupp.mem_support_iff]

end finsupp

namespace multiset

/-- Given a multiset `s`, `s.to_finsupp` returns the finitely supported function on `ℕ` given by
the multiplicities of the elements of `s`. -/
def to_finsupp : multiset α ≃+ (α →₀ ℕ) := finsupp.to_multiset.symm

@[simp] lemma to_finsupp_support [decidable_eq α] (s : multiset α) :
  s.to_finsupp.support = s.to_finset :=
by convert rfl

@[simp] lemma to_finsupp_apply [decidable_eq α] (s : multiset α) (a : α) :
  to_finsupp s a = s.count a :=
by convert rfl

lemma to_finsupp_zero : to_finsupp (0 : multiset α) = 0 := add_equiv.map_zero _

lemma to_finsupp_add (s t : multiset α) : to_finsupp (s + t) = to_finsupp s + to_finsupp t :=
to_finsupp.map_add s t

@[simp] lemma to_finsupp_singleton (a : α) : to_finsupp ({a} : multiset α) = finsupp.single a 1 :=
finsupp.to_multiset.symm_apply_eq.2 $ by simp

@[simp] lemma to_finsupp_to_multiset (s : multiset α) : s.to_finsupp.to_multiset = s :=
finsupp.to_multiset.apply_symm_apply s

lemma to_finsupp_eq_iff {s : multiset α} {f : α →₀ ℕ} : s.to_finsupp = f ↔ s = f.to_multiset :=
finsupp.to_multiset.symm_apply_eq

end multiset

@[simp] lemma finsupp.to_multiset_to_finsupp (f : α →₀ ℕ) : f.to_multiset.to_finsupp = f :=
finsupp.to_multiset.symm_apply_apply f

/-! ### As an order isomorphism -/

namespace finsupp

/-- `finsupp.to_multiset` as an order isomorphism. -/
def order_iso_multiset : (ι →₀ ℕ) ≃o multiset ι :=
{ to_equiv := to_multiset.to_equiv,
  map_rel_iff' := λ f g, by simp [multiset.le_iff_count, le_def] }

@[simp] lemma coe_order_iso_multiset : ⇑(@order_iso_multiset ι) = to_multiset := rfl

@[simp] lemma coe_order_iso_multiset_symm : ⇑(@order_iso_multiset ι).symm = multiset.to_finsupp :=
rfl

lemma to_multiset_strict_mono : strict_mono (@to_multiset ι) := (@order_iso_multiset ι).strict_mono

lemma sum_id_lt_of_lt (m n : ι →₀ ℕ) (h : m < n) : m.sum (λ _, id) < n.sum (λ _, id) :=
begin
  rw [←card_to_multiset, ←card_to_multiset],
  apply multiset.card_lt_of_lt,
  exact to_multiset_strict_mono h
end

variable (ι)

/-- The order on `ι →₀ ℕ` is well-founded. -/
lemma lt_wf : well_founded (@has_lt.lt (ι →₀ ℕ) _) :=
subrelation.wf (sum_id_lt_of_lt) $ inv_image.wf _ nat.lt_wf

end finsupp

lemma multiset.to_finsupp_strict_mono : strict_mono (@multiset.to_finsupp ι) :=
(@finsupp.order_iso_multiset ι).symm.strict_mono


/-
Copyright (c) 2014 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Jeremy Avigad, Andrew Zipperer, Haitao Zhang

Functions between subsets of finite types.
-/
import .basic
open function eq.ops

namespace set

variables {X Y Z : Type}

/- preimages -/

definition preimage {A B:Type} (f : A → B) (Y : set B) : set A := { x | f x ∈ Y }

notation f ` '- ` s := preimage f s

theorem mem_preimage_iff (f : X → Y) (a : set Y) (x : X) :
  f x ∈ a ↔ x ∈ f '- a :=
!iff.refl

theorem mem_preimage {f : X → Y} {a : set Y} {x : X} (H : f x ∈ a) :
  x ∈ f '- a := H

theorem mem_of_mem_preimage {f : X → Y} {a : set Y} {x : X} (H : x ∈ f '- a) :
  f x ∈ a :=
proof H qed

theorem preimage_comp (f : Y → Z) (g : X → Y) (a : set Z) :
  (f ∘ g) '- a = g '- (f '- a) :=
ext (take x, !iff.refl)

lemma image_subset_iff {A B : Type} {f : A → B} {X : set A} {Y : set B} :
  f ' X ⊆ Y ↔ X ⊆ f '- Y :=
@bounded_forall_image_iff A B f X Y

theorem preimage_subset {a b : set Y} (f : X → Y) (H : a ⊆ b) :
  f '- a ⊆ f '- b :=
λ x H', proof @H (f x) H' qed

theorem preimage_id (s : set Y) : (λx, x) '- s = s :=
ext (take x, !iff.refl)

theorem preimage_union (f : X → Y) (s t : set Y) :
  f '- (s ∪ t) = f '- s ∪ f '- t :=
ext (take x, !iff.refl)

theorem preimage_inter (f : X → Y) (s t : set Y) :
  f '- (s ∩ t) = f '- s ∩ f '- t :=
ext (take x, !iff.refl)

theorem preimage_compl (f : X → Y) (s : set Y) :
  f '- (-s) = -(f '- s) :=
ext (take x, !iff.refl)

theorem preimage_diff (f : X → Y) (s t : set Y) :
  f '- (s \ t) = f '- s \ f '- t :=
ext (take x, !iff.refl)

theorem image_preimage_subset (f : X → Y) (s : set Y) :
  f ' (f '- s) ⊆ s :=
take y, suppose y ∈ f ' (f '- s),
  obtain x [xfis fxeqy], from this,
  show y ∈ s, by rewrite -fxeqy; exact xfis

theorem subset_preimage_image (s : set X) (f : X → Y) :
  s ⊆ f '- (f ' s) :=
take x, suppose x ∈ s,
show f x ∈ f ' s, from mem_image_of_mem f this

theorem inter_preimage_subset (s : set X) (t : set Y) (f : X → Y) :
  s ∩ f '- t ⊆ f '- (f ' s ∩ t) :=
take x, assume H : x ∈ s ∩ f '- t,
mem_preimage (show f x ∈ f ' s ∩ t,
  from and.intro (mem_image_of_mem f (and.left H)) (mem_of_mem_preimage (and.right H)))

theorem union_preimage_subset (s : set X) (t : set Y) (f : X → Y) :
  s ∪ f '- t ⊆ f '- (f ' s ∪ t) :=
take x, assume H : x ∈ s ∪ f '- t,
mem_preimage (show f x ∈ f ' s ∪ t,
  from or.elim H
    (suppose x ∈ s, or.inl (mem_image_of_mem f this))
    (suppose x ∈ f '- t, or.inr (mem_of_mem_preimage this)))

theorem image_inter (f : X → Y) (s : set X) (t : set Y) :
  f ' s ∩ t = f ' (s ∩ f '- t) :=
ext (take y, iff.intro
  (suppose y ∈ f ' s ∩ t,
    obtain [x [xs fxeqy]] yt, from this,
    have x ∈ s ∩ f '- t,
      from and.intro xs (mem_preimage (show f x ∈ t, by rewrite fxeqy; exact yt)),
    mem_image this fxeqy)
  (suppose y ∈ f ' (s ∩ f '- t),
    obtain x [[xs xfit] fxeqy], from this,
    and.intro (mem_image xs fxeqy)
      (show y ∈ t, by rewrite -fxeqy; exact mem_of_mem_preimage xfit)))

theorem image_union_supset (f : X → Y) (s : set X) (t : set Y) :
  f ' s ∪ t ⊇ f ' (s ∪ f '- t) :=
take y, assume H,
obtain x [xmem fxeqy], from H,
or.elim xmem
  (suppose x ∈ s, or.inl (mem_image this fxeqy))
  (suppose x ∈ f '- t, or.inr (show y ∈ t, by rewrite -fxeqy; exact mem_of_mem_preimage this))

/- maps to -/

definition maps_to [reducible] (f : X → Y) (a : set X) (b : set Y) : Prop := ∀⦃x⦄, x ∈ a → f x ∈ b

theorem maps_to_of_eq_on {f1 f2 : X → Y} {a : set X} {b : set Y} (eq_on_a : eq_on f1 f2 a)
    (maps_to_f1 : maps_to f1 a b) :
  maps_to f2 a b :=
take x,
assume xa : x ∈ a,
have H : f1 x ∈ b, from maps_to_f1 xa,
show f2 x ∈ b, from eq_on_a xa ▸ H

theorem maps_to_comp {g : Y → Z} {f : X → Y} {a : set X} {b : set Y} {c : set Z}
   (H1 : maps_to g b c) (H2 : maps_to f a b) : maps_to (g ∘ f) a c :=
take x, assume H : x ∈ a, H1 (H2 H)

theorem maps_to_univ_univ (f : X → Y) : maps_to f univ univ :=
take x, assume H, trivial

theorem image_subset_of_maps_to_of_subset {f : X → Y} {a : set X} {b : set Y} (mfab : maps_to f a b)
    {c : set X} (csuba : c ⊆ a) :
  f ' c ⊆ b :=
take y,
suppose y ∈ f ' c,
obtain x [(xc : x ∈ c) (yeq : f x = y)], from this,
have x ∈ a, from csuba `x ∈ c`,
have f x ∈ b, from mfab this,
show y ∈ b, from yeq ▸ this

theorem image_subset_of_maps_to {f : X → Y} {a : set X} {b : set Y} (mfab : maps_to f a b) :
  f ' a ⊆ b :=
image_subset_of_maps_to_of_subset mfab (subset.refl a)

/- injectivity -/

definition inj_on [reducible] (f : X → Y) (a : set X) : Prop :=
∀⦃x1 x2 : X⦄, x1 ∈ a → x2 ∈ a → f x1 = f x2 → x1 = x2

theorem inj_on_empty (f : X → Y) : inj_on f ∅ :=
  take x₁ x₂, assume H₁ H₂ H₃, false.elim H₁

theorem inj_on_of_eq_on {f1 f2 : X → Y} {a : set X} (eq_f1_f2 : eq_on f1 f2 a)
    (inj_f1 : inj_on f1 a) :
  inj_on f2 a :=
take x1 x2 : X,
assume ax1 : x1 ∈ a,
assume ax2 : x2 ∈ a,
assume H : f2 x1 = f2 x2,
have H' : f1 x1 = f1 x2, from eq_f1_f2 ax1 ⬝ H ⬝ (eq_f1_f2 ax2)⁻¹,
show x1 = x2, from inj_f1 ax1 ax2 H'

theorem inj_on_comp {g : Y → Z} {f : X → Y} {a : set X} {b : set Y}
    (fab : maps_to f a b) (Hg : inj_on g b) (Hf: inj_on f a) :
  inj_on (g ∘ f) a :=
take x1 x2 : X,
assume x1a : x1 ∈ a,
assume x2a : x2 ∈ a,
have  fx1b : f x1 ∈ b, from fab x1a,
have  fx2b : f x2 ∈ b, from fab x2a,
assume  H1 : g (f x1) = g (f x2),
have    H2 : f x1 = f x2, from Hg fx1b fx2b H1,
show x1 = x2, from Hf x1a x2a H2

theorem inj_on_of_inj_on_of_subset {f : X → Y} {a b : set X} (H1 : inj_on f b) (H2 : a ⊆ b) :
  inj_on f a :=
take x1 x2 : X, assume (x1a : x1 ∈ a) (x2a : x2 ∈ a),
assume H : f x1 = f x2,
show x1 = x2, from H1 (H2 x1a) (H2 x2a) H

lemma injective_iff_inj_on_univ {f : X → Y} : injective f ↔ inj_on f univ :=
iff.intro
  (assume H, take x₁ x₂, assume ax₁ ax₂, H x₁ x₂)
  (assume H : inj_on f univ,
     take x₁ x₂ Heq,
     show x₁ = x₂, from H trivial trivial Heq)

/- surjectivity -/

definition surj_on [reducible] (f : X → Y) (a : set X) (b : set Y) : Prop := b ⊆ f ' a

theorem surj_on_of_eq_on {f1 f2 : X → Y} {a : set X} {b : set Y} (eq_f1_f2 : eq_on f1 f2 a)
    (surj_f1 : surj_on f1 a b) :
  surj_on f2 a b :=
take y, assume H : y ∈ b,
obtain x (H1 : x ∈ a ∧ f1 x = y), from surj_f1 H,
have H2 : x ∈ a, from and.left H1,
have H3 : f2 x = y, from (eq_f1_f2 H2)⁻¹ ⬝ and.right H1,
exists.intro x (and.intro H2 H3)

theorem surj_on_comp {g : Y → Z} {f : X → Y} {a : set X} {b : set Y} {c : set Z}
  (Hg : surj_on g b c) (Hf: surj_on f a b) :
  surj_on (g ∘ f) a c :=
take z,
assume zc : z ∈ c,
obtain y (H1 : y ∈ b ∧ g y = z), from Hg zc,
obtain x (H2 : x ∈ a ∧ f x = y), from Hf (and.left H1),
show ∃x, x ∈ a ∧ g (f x) = z, from
  exists.intro x
    (and.intro
      (and.left H2)
      (calc
        g (f x) = g y : {and.right H2}
            ... = z   : and.right H1))

lemma surjective_iff_surj_on_univ {f : X → Y} : surjective f ↔ surj_on f univ univ :=
iff.intro
  (assume H, take y, assume Hy,
    obtain x Hx, from H y,
    mem_image trivial Hx)
  (assume H, take y,
    obtain x H1x H2x, from H y trivial,
    exists.intro x H2x)

lemma image_eq_of_maps_to_of_surj_on {f : X → Y} {a : set X} {b : set Y}
    (H1 : maps_to f a b) (H2 : surj_on f a b) :
  f ' a = b :=
eq_of_subset_of_subset (image_subset_of_maps_to H1) H2

/- bijectivity -/

definition bij_on [reducible] (f : X → Y) (a : set X) (b : set Y) : Prop :=
maps_to f a b ∧ inj_on f a ∧ surj_on f a b

lemma maps_to_of_bij_on {f : X → Y} {a : set X} {b : set Y} (H : bij_on f a b) :
      maps_to f a b :=
and.left H

lemma inj_on_of_bij_on {f : X → Y} {a : set X} {b : set Y} (H : bij_on f a b) :
      inj_on f a :=
and.left (and.right H)

lemma surj_on_of_bij_on {f : X → Y} {a : set X} {b : set Y} (H : bij_on f a b) :
      surj_on f a b :=
and.right (and.right H)

lemma bij_on.mk {f : X → Y} {a : set X} {b : set Y}
                (H₁ : maps_to f a b) (H₂ : inj_on f a) (H₃ : surj_on f a b) :
      bij_on f a b :=
and.intro H₁ (and.intro H₂ H₃)

theorem bij_on_of_eq_on {f1 f2 : X → Y} {a : set X} {b : set Y} (eqf : eq_on f1 f2 a)
     (H : bij_on f1 a b) : bij_on f2 a b :=
match H with and.intro Hmap (and.intro Hinj Hsurj) :=
  and.intro
    (maps_to_of_eq_on eqf Hmap)
    (and.intro
      (inj_on_of_eq_on eqf Hinj)
      (surj_on_of_eq_on eqf Hsurj))
end

lemma image_eq_of_bij_on {f : X → Y} {a : set X} {b : set Y} (bfab : bij_on f a b) :
  f ' a = b :=
image_eq_of_maps_to_of_surj_on (and.left bfab) (and.right (and.right bfab))

theorem bij_on_comp {g : Y → Z} {f : X → Y} {a : set X} {b : set Y} {c : set Z}
  (Hg : bij_on g b c) (Hf: bij_on f a b) :
  bij_on (g ∘ f) a c :=
match Hg with and.intro Hgmap (and.intro Hginj Hgsurj) :=
  match Hf with and.intro Hfmap (and.intro Hfinj Hfsurj) :=
    and.intro
      (maps_to_comp Hgmap Hfmap)
      (and.intro
        (inj_on_comp Hfmap Hginj Hfinj)
        (surj_on_comp Hgsurj Hfsurj))
  end
end

lemma bijective_iff_bij_on_univ {f : X → Y} : bijective f ↔ bij_on f univ univ :=
iff.intro
  (assume H,
    obtain Hinj Hsurj, from H,
    and.intro (maps_to_univ_univ f)
      (and.intro
        (iff.mp !injective_iff_inj_on_univ Hinj)
        (iff.mp !surjective_iff_surj_on_univ Hsurj)))
 (assume H,
    obtain Hmaps Hinj Hsurj, from H,
      (and.intro
        (iff.mpr !injective_iff_inj_on_univ Hinj)
        (iff.mpr !surjective_iff_surj_on_univ Hsurj)))

/- left inverse -/

-- g is a left inverse to f on a
definition left_inv_on [reducible] (g : Y → X) (f : X → Y) (a : set X) : Prop :=
∀₀ x ∈ a, g (f x) = x

theorem left_inv_on_of_eq_on_left {g1 g2 : Y → X} {f : X → Y} {a : set X} {b : set Y}
  (fab : maps_to f a b) (eqg : eq_on g1 g2 b) (H : left_inv_on g1 f a) : left_inv_on g2 f a :=
take x,
assume xa : x ∈ a,
calc
  g2 (f x) = g1 (f x) : (eqg (fab xa))⁻¹
       ... = x        : H xa

theorem left_inv_on_of_eq_on_right {g : Y → X} {f1 f2 : X → Y} {a : set X}
  (eqf : eq_on f1 f2 a) (H : left_inv_on g f1 a) : left_inv_on g f2 a :=
take x,
assume xa : x ∈ a,
calc
  g (f2 x) = g (f1 x) : {(eqf xa)⁻¹}
       ... = x        : H xa

theorem inj_on_of_left_inv_on {g : Y → X} {f : X → Y} {a : set X} (H : left_inv_on g f a) :
  inj_on f a :=
take x1 x2,
assume x1a : x1 ∈ a,
assume x2a : x2 ∈ a,
assume H1 : f x1 = f x2,
calc
  x1     = g (f x1) : H x1a
     ... = g (f x2) : H1
     ... = x2       : H x2a

theorem left_inv_on_comp {f' : Y → X} {g' : Z → Y} {g : Y → Z} {f : X → Y}
   {a : set X} {b : set Y} (fab : maps_to f a b)
    (Hf : left_inv_on f' f a) (Hg : left_inv_on g' g b) : left_inv_on (f' ∘ g') (g ∘ f) a :=
take x : X,
assume xa : x ∈ a,
have fxb : f x ∈ b, from fab xa,
calc
  f' (g' (g (f x))) = f' (f x) : Hg fxb
                ... = x        : Hf xa

/- right inverse -/

-- g is a right inverse to f on a
definition right_inv_on [reducible] (g : Y → X) (f : X → Y) (b : set Y) : Prop :=
left_inv_on f g b

theorem right_inv_on_of_eq_on_left {g1 g2 : Y → X} {f : X → Y} {a : set X} {b : set Y}
  (eqg : eq_on g1 g2 b) (H : right_inv_on g1 f b) : right_inv_on g2 f b :=
left_inv_on_of_eq_on_right eqg H

theorem right_inv_on_of_eq_on_right {g : Y → X} {f1 f2 : X → Y} {a : set X} {b : set Y}
  (gba : maps_to g b a) (eqf : eq_on f1 f2 a) (H : right_inv_on g f1 b) : right_inv_on g f2 b :=
left_inv_on_of_eq_on_left gba eqf H

theorem surj_on_of_right_inv_on {g : Y → X} {f : X → Y} {a : set X} {b : set Y}
    (gba : maps_to g b a) (H : right_inv_on g f b) :
  surj_on f a b :=
take y,
assume yb : y ∈ b,
have gya : g y ∈ a, from gba yb,
have H1 : f (g y) = y, from H yb,
exists.intro (g y) (and.intro gya H1)

theorem right_inv_on_comp {f' : Y → X} {g' : Z → Y} {g : Y → Z} {f : X → Y}
   {c : set Z} {b : set Y} (g'cb : maps_to g' c b)
    (Hf : right_inv_on f' f b) (Hg : right_inv_on g' g c) : right_inv_on (f' ∘ g') (g ∘ f) c :=
left_inv_on_comp g'cb Hg Hf

theorem right_inv_on_of_inj_on_of_left_inv_on {f : X → Y} {g : Y → X} {a : set X} {b : set Y}
    (fab : maps_to f a b) (gba : maps_to g b a) (injf : inj_on f a) (lfg : left_inv_on f g b) :
  right_inv_on f g a :=
take x, assume xa : x ∈ a,
have H : f (g (f x)) = f x, from lfg (fab xa),
injf (gba (fab xa)) xa H

theorem eq_on_of_left_inv_of_right_inv {g1 g2 : Y → X} {f : X → Y} {a : set X} {b : set Y}
  (g2ba : maps_to g2 b a) (Hg1 : left_inv_on g1 f a) (Hg2 : right_inv_on g2 f b) : eq_on g1 g2 b :=
take y,
assume yb : y ∈ b,
calc
  g1 y = g1 (f (g2 y)) : {(Hg2 yb)⁻¹}
   ... = g2 y          : Hg1 (g2ba yb)

theorem left_inv_on_of_surj_on_right_inv_on {f : X → Y} {g : Y → X} {a : set X} {b : set Y}
    (surjf : surj_on f a b) (rfg : right_inv_on f g a) :
  left_inv_on f g b :=
take y, assume yb : y ∈ b,
obtain x (xa : x ∈ a) (Hx : f x = y), from surjf yb,
calc
  f (g y) = f (g (f x)) : Hx
      ... = f x         : rfg xa
      ... = y           : Hx

/- inverses -/

-- g is an inverse to f viewed as a map from a to b
definition inv_on [reducible] (g : Y → X) (f : X → Y) (a : set X) (b : set Y) : Prop :=
left_inv_on g f a ∧ right_inv_on g f b

theorem bij_on_of_inv_on {g : Y → X} {f : X → Y} {a : set X} {b : set Y} (fab : maps_to f a b)
  (gba : maps_to g b a) (H : inv_on g f a b) : bij_on f a b :=
and.intro fab
  (and.intro
    (inj_on_of_left_inv_on (and.left H))
    (surj_on_of_right_inv_on gba (and.right H)))

end set


/-
Copyright (c) 2021 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel

! This file was ported from Lean 3 source module analysis.calculus.fderiv_symmetric
! leanprover-community/mathlib commit f2ce6086713c78a7f880485f7917ea547a215982
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.Calculus.Deriv
import Mathbin.Analysis.Calculus.MeanValue
import Mathbin.Analysis.Convex.Topology

/-!
# Symmetry of the second derivative

We show that, over the reals, the second derivative is symmetric.

The most precise result is `convex.second_derivative_within_at_symmetric`. It asserts that,
if a function is differentiable inside a convex set `s` with nonempty interior, and has a second
derivative within `s` at a point `x`, then this second derivative at `x` is symmetric. Note that
this result does not require continuity of the first derivative.

The following particular cases of this statement are especially relevant:

`second_derivative_symmetric_of_eventually` asserts that, if a function is differentiable on a
neighborhood of `x`, and has a second derivative at `x`, then this second derivative is symmetric.

`second_derivative_symmetric` asserts that, if a function is differentiable, and has a second
derivative at `x`, then this second derivative is symmetric.

## Implementation note

For the proof, we obtain an asymptotic expansion to order two of `f (x + v + w) - f (x + v)`, by
using the mean value inequality applied to a suitable function along the
segment `[x + v, x + v + w]`. This expansion involves `f'' ⬝ w` as we move along a segment directed
by `w` (see `convex.taylor_approx_two_segment`).

Consider the alternate sum `f (x + v + w) + f x - f (x + v) - f (x + w)`, corresponding to the
values of `f` along a rectangle based at `x` with sides `v` and `w`. One can write it using the two
sides directed by `w`, as `(f (x + v + w) - f (x + v)) - (f (x + w) - f x)`. Together with the
previous asymptotic expansion, one deduces that it equals `f'' v w + o(1)` when `v, w` tends to `0`.
Exchanging the roles of `v` and `w`, one instead gets an asymptotic expansion `f'' w v`, from which
the equality `f'' v w = f'' w v` follows.

In our most general statement, we only assume that `f` is differentiable inside a convex set `s`, so
a few modifications have to be made. Since we don't assume continuity of `f` at `x`, we consider
instead the rectangle based at `x + v + w` with sides `v` and `w`,
in `convex.is_o_alternate_sum_square`, but the argument is essentially the same. It only works
when `v` and `w` both point towards the interior of `s`, to make sure that all the sides of the
rectangle are contained in `s` by convexity. The general case follows by linearity, though.
-/

open Asymptotics Set

open Topology

variable {E F : Type _} [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F]
  [NormedSpace ℝ F] {s : Set E} (s_conv : Convex ℝ s) {f : E → F} {f' : E → E →L[ℝ] F}
  {f'' : E →L[ℝ] E →L[ℝ] F} (hf : ∀ x ∈ interior s, HasFderivAt f (f' x) x) {x : E} (xs : x ∈ s)
  (hx : HasFderivWithinAt f' f'' (interior s) x)

include s_conv xs hx hf

/-- Assume that `f` is differentiable inside a convex set `s`, and that its derivative `f'` is
differentiable at a point `x`. Then, given two vectors `v` and `w` pointing inside `s`, one can
Taylor-expand to order two the function `f` on the segment `[x + h v, x + h (v + w)]`, giving a
bilinear estimate for `f (x + hv + hw) - f (x + hv)` in terms of `f' w` and of `f'' ⬝ w`, up to
`o(h^2)`.

This is a technical statement used to show that the second derivative is symmetric.
-/
theorem Convex.taylor_approx_two_segment {v w : E} (hv : x + v ∈ interior s)
    (hw : x + v + w ∈ interior s) :
    (fun h : ℝ =>
        f (x + h • v + h • w) - f (x + h • v) - h • f' x w - h ^ 2 • f'' v w -
          (h ^ 2 / 2) • f'' w w) =o[𝓝[>] 0]
      fun h => h ^ 2 :=
  by
  -- it suffices to check that the expression is bounded by `ε * ((‖v‖ + ‖w‖) * ‖w‖) * h^2` for
  -- small enough `h`, for any positive `ε`.
  apply is_o.trans_is_O (is_o_iff.2 fun ε εpos => _) (is_O_const_mul_self ((‖v‖ + ‖w‖) * ‖w‖) _ _)
  -- consider a ball of radius `δ` around `x` in which the Taylor approximation for `f''` is
  -- good up to `δ`.
  rw [HasFderivWithinAt, HasFderivAtFilter, is_o_iff] at hx
  rcases Metric.mem_nhdsWithin_iff.1 (hx εpos) with ⟨δ, δpos, sδ⟩
  have E1 : ∀ᶠ h in 𝓝[>] (0 : ℝ), h * (‖v‖ + ‖w‖) < δ :=
    by
    have : Filter.Tendsto (fun h => h * (‖v‖ + ‖w‖)) (𝓝[>] (0 : ℝ)) (𝓝 (0 * (‖v‖ + ‖w‖))) :=
      (continuous_id.mul continuous_const).ContinuousWithinAt
    apply (tendsto_order.1 this).2 δ
    simpa only [MulZeroClass.zero_mul] using δpos
  have E2 : ∀ᶠ h in 𝓝[>] (0 : ℝ), (h : ℝ) < 1 :=
    mem_nhdsWithin_Ioi_iff_exists_Ioo_subset.2
      ⟨(1 : ℝ), by simp only [mem_Ioi, zero_lt_one], fun x hx => hx.2⟩
  filter_upwards [E1, E2, self_mem_nhdsWithin]with h hδ h_lt_1 hpos
  -- we consider `h` small enough that all points under consideration belong to this ball,
  -- and also with `0 < h < 1`.
  replace hpos : 0 < h := hpos
  have xt_mem : ∀ t ∈ Icc (0 : ℝ) 1, x + h • v + (t * h) • w ∈ interior s :=
    by
    intro t ht
    have : x + h • v ∈ interior s := s_conv.add_smul_mem_interior xs hv ⟨hpos, h_lt_1.le⟩
    rw [← smul_smul]
    apply s_conv.interior.add_smul_mem this _ ht
    rw [add_assoc] at hw
    rw [add_assoc, ← smul_add]
    exact s_conv.add_smul_mem_interior xs hw ⟨hpos, h_lt_1.le⟩
  -- define a function `g` on `[0,1]` (identified with `[v, v + w]`) such that `g 1 - g 0` is the
  -- quantity to be estimated. We will check that its derivative is given by an explicit
  -- expression `g'`, that we can bound. Then the desired bound for `g 1 - g 0` follows from the
  -- mean value inequality.
  let g t :=
    f (x + h • v + (t * h) • w) - (t * h) • f' x w - (t * h ^ 2) • f'' v w -
      ((t * h) ^ 2 / 2) • f'' w w
  set g' := fun t =>
    f' (x + h • v + (t * h) • w) (h • w) - h • f' x w - h ^ 2 • f'' v w - (t * h ^ 2) • f'' w w with
    hg'
  -- check that `g'` is the derivative of `g`, by a straightforward computation
  have g_deriv : ∀ t ∈ Icc (0 : ℝ) 1, HasDerivWithinAt g (g' t) (Icc 0 1) t :=
    by
    intro t ht
    apply_rules [HasDerivWithinAt.sub, HasDerivWithinAt.add]
    · refine' (hf _ _).comp_hasDerivWithinAt _ _
      · exact xt_mem t ht
      apply_rules [HasDerivAt.hasDerivWithinAt, HasDerivAt.const_add, HasDerivAt.smul_const,
        hasDerivAt_mul_const]
    · apply_rules [HasDerivAt.hasDerivWithinAt, HasDerivAt.smul_const, hasDerivAt_mul_const]
    · apply_rules [HasDerivAt.hasDerivWithinAt, HasDerivAt.smul_const, hasDerivAt_mul_const]
    · suffices H :
        HasDerivWithinAt (fun u => ((u * h) ^ 2 / 2) • f'' w w)
          ((((2 : ℕ) : ℝ) * (t * h) ^ (2 - 1) * (1 * h) / 2) • f'' w w) (Icc 0 1) t
      · convert H using 2
        simp only [one_mul, Nat.cast_bit0, pow_one, Nat.cast_one]
        ring
      apply_rules [HasDerivAt.hasDerivWithinAt, HasDerivAt.smul_const, hasDerivAt_id',
        HasDerivAt.pow, HasDerivAt.mul_const]
  -- check that `g'` is uniformly bounded, with a suitable bound `ε * ((‖v‖ + ‖w‖) * ‖w‖) * h^2`.
  have g'_bound : ∀ t ∈ Ico (0 : ℝ) 1, ‖g' t‖ ≤ ε * ((‖v‖ + ‖w‖) * ‖w‖) * h ^ 2 :=
    by
    intro t ht
    have I : ‖h • v + (t * h) • w‖ ≤ h * (‖v‖ + ‖w‖) :=
      calc
        ‖h • v + (t * h) • w‖ ≤ ‖h • v‖ + ‖(t * h) • w‖ := norm_add_le _ _
        _ = h * ‖v‖ + t * (h * ‖w‖) := by
          simp only [norm_smul, Real.norm_eq_abs, hpos.le, abs_of_nonneg, abs_mul, ht.left,
            mul_assoc]
        _ ≤ h * ‖v‖ + 1 * (h * ‖w‖) :=
          (add_le_add le_rfl
            (mul_le_mul_of_nonneg_right ht.2.le (mul_nonneg hpos.le (norm_nonneg _))))
        _ = h * (‖v‖ + ‖w‖) := by ring

    calc
      ‖g' t‖ = ‖(f' (x + h • v + (t * h) • w) - f' x - f'' (h • v + (t * h) • w)) (h • w)‖ :=
        by
        rw [hg']
        have : h * (t * h) = t * (h * h) := by ring
        simp only [ContinuousLinearMap.coe_sub', ContinuousLinearMap.map_add, pow_two,
          ContinuousLinearMap.add_apply, Pi.smul_apply, smul_sub, smul_add, smul_smul, ← sub_sub,
          ContinuousLinearMap.coe_smul', Pi.sub_apply, ContinuousLinearMap.map_smul, this]
      _ ≤ ‖f' (x + h • v + (t * h) • w) - f' x - f'' (h • v + (t * h) • w)‖ * ‖h • w‖ :=
        (ContinuousLinearMap.le_op_norm _ _)
      _ ≤ ε * ‖h • v + (t * h) • w‖ * ‖h • w‖ :=
        by
        apply mul_le_mul_of_nonneg_right _ (norm_nonneg _)
        have H : x + h • v + (t * h) • w ∈ Metric.ball x δ ∩ interior s :=
          by
          refine' ⟨_, xt_mem t ⟨ht.1, ht.2.le⟩⟩
          rw [add_assoc, add_mem_ball_iff_norm]
          exact I.trans_lt hδ
        simpa only [mem_set_of_eq, add_assoc x, add_sub_cancel'] using sδ H
      _ ≤ ε * (‖h • v‖ + ‖h • w‖) * ‖h • w‖ :=
        by
        apply mul_le_mul_of_nonneg_right _ (norm_nonneg _)
        apply mul_le_mul_of_nonneg_left _ εpos.le
        apply (norm_add_le _ _).trans
        refine' add_le_add le_rfl _
        simp only [norm_smul, Real.norm_eq_abs, abs_mul, abs_of_nonneg, ht.1, hpos.le, mul_assoc]
        exact mul_le_of_le_one_left (mul_nonneg hpos.le (norm_nonneg _)) ht.2.le
      _ = ε * ((‖v‖ + ‖w‖) * ‖w‖) * h ^ 2 :=
        by
        simp only [norm_smul, Real.norm_eq_abs, abs_mul, abs_of_nonneg, hpos.le]
        ring

  -- conclude using the mean value inequality
  have I : ‖g 1 - g 0‖ ≤ ε * ((‖v‖ + ‖w‖) * ‖w‖) * h ^ 2 := by
    simpa only [mul_one, sub_zero] using
      norm_image_sub_le_of_norm_deriv_le_segment' g_deriv g'_bound 1 (right_mem_Icc.2 zero_le_one)
  convert I using 1
  · congr 1
    dsimp only [g]
    simp only [Nat.one_ne_zero, add_zero, one_mul, zero_div, MulZeroClass.zero_mul, sub_zero,
      zero_smul, Ne.def, not_false_iff, bit0_eq_zero, zero_pow']
    abel
  ·
    simp only [Real.norm_eq_abs, abs_mul, add_nonneg (norm_nonneg v) (norm_nonneg w), abs_of_nonneg,
      mul_assoc, pow_bit0_abs, norm_nonneg, abs_pow]
#align convex.taylor_approx_two_segment Convex.taylor_approx_two_segment

/-- One can get `f'' v w` as the limit of `h ^ (-2)` times the alternate sum of the values of `f`
along the vertices of a quadrilateral with sides `h v` and `h w` based at `x`.
In a setting where `f` is not guaranteed to be continuous at `f`, we can still
get this if we use a quadrilateral based at `h v + h w`. -/
theorem Convex.isOCat_alternate_sum_square {v w : E} (h4v : x + (4 : ℝ) • v ∈ interior s)
    (h4w : x + (4 : ℝ) • w ∈ interior s) :
    (fun h : ℝ =>
        f (x + h • (2 • v + 2 • w)) + f (x + h • (v + w)) - f (x + h • (2 • v + w)) -
            f (x + h • (v + 2 • w)) -
          h ^ 2 • f'' v w) =o[𝓝[>] 0]
      fun h => h ^ 2 :=
  by
  have A : (1 : ℝ) / 2 ∈ Ioc (0 : ℝ) 1 := ⟨by norm_num, by norm_num⟩
  have B : (1 : ℝ) / 2 ∈ Icc (0 : ℝ) 1 := ⟨by norm_num, by norm_num⟩
  have C : ∀ w : E, (2 : ℝ) • w = 2 • w := fun w => by simp only [two_smul]
  have h2v2w : x + (2 : ℝ) • v + (2 : ℝ) • w ∈ interior s :=
    by
    convert s_conv.interior.add_smul_sub_mem h4v h4w B using 1
    simp only [smul_sub, smul_smul, one_div, add_sub_add_left_eq_sub, mul_add, add_smul]
    norm_num
    simp only [show (4 : ℝ) = (2 : ℝ) + (2 : ℝ) by norm_num, add_smul]
    abel
  have h2vww : x + (2 • v + w) + w ∈ interior s :=
    by
    convert h2v2w using 1
    simp only [two_smul]
    abel
  have h2v : x + (2 : ℝ) • v ∈ interior s :=
    by
    convert s_conv.add_smul_sub_mem_interior xs h4v A using 1
    simp only [smul_smul, one_div, add_sub_cancel', add_right_inj]
    norm_num
  have h2w : x + (2 : ℝ) • w ∈ interior s :=
    by
    convert s_conv.add_smul_sub_mem_interior xs h4w A using 1
    simp only [smul_smul, one_div, add_sub_cancel', add_right_inj]
    norm_num
  have hvw : x + (v + w) ∈ interior s :=
    by
    convert s_conv.add_smul_sub_mem_interior xs h2v2w A using 1
    simp only [smul_smul, one_div, add_sub_cancel', add_right_inj, smul_add, smul_sub]
    norm_num
    abel
  have h2vw : x + (2 • v + w) ∈ interior s :=
    by
    convert s_conv.interior.add_smul_sub_mem h2v h2v2w B using 1
    simp only [smul_add, smul_sub, smul_smul, ← C]
    norm_num
    abel
  have hvww : x + (v + w) + w ∈ interior s :=
    by
    convert s_conv.interior.add_smul_sub_mem h2w h2v2w B using 1
    simp only [one_div, add_sub_cancel', inv_smul_smul₀, add_sub_add_right_eq_sub, Ne.def,
      not_false_iff, bit0_eq_zero, one_ne_zero]
    rw [two_smul]
    abel
  have TA1 := s_conv.taylor_approx_two_segment hf xs hx h2vw h2vww
  have TA2 := s_conv.taylor_approx_two_segment hf xs hx hvw hvww
  convert TA1.sub TA2
  ext h
  simp only [two_smul, smul_add, ← add_assoc, ContinuousLinearMap.map_add,
    ContinuousLinearMap.add_apply, Pi.smul_apply, ContinuousLinearMap.coe_smul',
    ContinuousLinearMap.map_smul]
  abel
#align convex.is_o_alternate_sum_square Convex.isOCat_alternate_sum_square

/-- Assume that `f` is differentiable inside a convex set `s`, and that its derivative `f'` is
differentiable at a point `x`. Then, given two vectors `v` and `w` pointing inside `s`, one
has `f'' v w = f'' w v`. Superseded by `convex.second_derivative_within_at_symmetric`, which
removes the assumption that `v` and `w` point inside `s`.
-/
theorem Convex.second_derivative_within_at_symmetric_of_mem_interior {v w : E}
    (h4v : x + (4 : ℝ) • v ∈ interior s) (h4w : x + (4 : ℝ) • w ∈ interior s) : f'' w v = f'' v w :=
  by
  have A : (fun h : ℝ => h ^ 2 • (f'' w v - f'' v w)) =o[𝓝[>] 0] fun h => h ^ 2 :=
    by
    convert(s_conv.is_o_alternate_sum_square hf xs hx h4v h4w).sub
        (s_conv.is_o_alternate_sum_square hf xs hx h4w h4v)
    ext h
    simp only [add_comm, smul_add, smul_sub]
    abel
  have B : (fun h : ℝ => f'' w v - f'' v w) =o[𝓝[>] 0] fun h => (1 : ℝ) :=
    by
    have : (fun h : ℝ => 1 / h ^ 2) =O[𝓝[>] 0] fun h => 1 / h ^ 2 := is_O_refl _ _
    have C := this.smul_is_o A
    apply C.congr' _ _
    · filter_upwards [self_mem_nhdsWithin]
      intro h hpos
      rw [← one_smul ℝ (f'' w v - f'' v w), smul_smul, smul_smul]
      congr 1
      field_simp [LT.lt.ne' hpos]
    · filter_upwards [self_mem_nhdsWithin]with _ hpos
      field_simp [LT.lt.ne' hpos, SMul.smul]
  simpa only [sub_eq_zero] using is_o_const_const_iff.1 B
#align convex.second_derivative_within_at_symmetric_of_mem_interior Convex.second_derivative_within_at_symmetric_of_mem_interior

omit s_conv xs hx hf

/-- If a function is differentiable inside a convex set with nonempty interior, and has a second
derivative at a point of this convex set, then this second derivative is symmetric. -/
theorem Convex.second_derivative_within_at_symmetric {s : Set E} (s_conv : Convex ℝ s)
    (hne : (interior s).Nonempty) {f : E → F} {f' : E → E →L[ℝ] F} {f'' : E →L[ℝ] E →L[ℝ] F}
    (hf : ∀ x ∈ interior s, HasFderivAt f (f' x) x) {x : E} (xs : x ∈ s)
    (hx : HasFderivWithinAt f' f'' (interior s) x) (v w : E) : f'' v w = f'' w v :=
  by
  /- we work around a point `x + 4 z` in the interior of `s`. For any vector `m`,
    then `x + 4 (z + t m)` also belongs to the interior of `s` for small enough `t`. This means that
    we will be able to apply `second_derivative_within_at_symmetric_of_mem_interior` to show
    that `f''` is symmetric, after cancelling all the contributions due to `z`. -/
  rcases hne with ⟨y, hy⟩
  obtain ⟨z, hz⟩ : ∃ z, z = ((1 : ℝ) / 4) • (y - x) := ⟨((1 : ℝ) / 4) • (y - x), rfl⟩
  have A : ∀ m : E, Filter.Tendsto (fun t : ℝ => x + (4 : ℝ) • (z + t • m)) (𝓝 0) (𝓝 y) :=
    by
    intro m
    have : x + (4 : ℝ) • (z + (0 : ℝ) • m) = y := by simp [hz]
    rw [← this]
    refine' tendsto_const_nhds.add _
    refine' tendsto_const_nhds.smul _
    refine' tendsto_const_nhds.add _
    exact continuous_at_id.smul continuousAt_const
  have B : ∀ m : E, ∀ᶠ t in 𝓝[>] (0 : ℝ), x + (4 : ℝ) • (z + t • m) ∈ interior s :=
    by
    intro m
    apply nhdsWithin_le_nhds
    apply A m
    rw [mem_interior_iff_mem_nhds] at hy
    exact interior_mem_nhds.2 hy
  -- we choose `t m > 0` such that `x + 4 (z + (t m) m)` belongs to the interior of `s`, for any
  -- vector `m`.
  choose t ts tpos using fun m => ((B m).And self_mem_nhdsWithin).exists
  -- applying `second_derivative_within_at_symmetric_of_mem_interior` to the vectors `z`
  -- and `z + (t m) m`, we deduce that `f'' m z = f'' z m` for all `m`.
  have C : ∀ m : E, f'' m z = f'' z m := by
    intro m
    have : f'' (z + t m • m) (z + t 0 • 0) = f'' (z + t 0 • 0) (z + t m • m) :=
      s_conv.second_derivative_within_at_symmetric_of_mem_interior hf xs hx (ts 0) (ts m)
    simp only [ContinuousLinearMap.map_add, ContinuousLinearMap.map_smul, add_right_inj,
      ContinuousLinearMap.add_apply, Pi.smul_apply, ContinuousLinearMap.coe_smul', add_zero,
      ContinuousLinearMap.zero_apply, smul_zero, ContinuousLinearMap.map_zero] at this
    exact smul_right_injective F (tpos m).ne' this
  -- applying `second_derivative_within_at_symmetric_of_mem_interior` to the vectors `z + (t v) v`
  -- and `z + (t w) w`, we deduce that `f'' v w = f'' w v`. Cross terms involving `z` can be
  -- eliminated thanks to the fact proved above that `f'' m z = f'' z m`.
  have : f'' (z + t v • v) (z + t w • w) = f'' (z + t w • w) (z + t v • v) :=
    s_conv.second_derivative_within_at_symmetric_of_mem_interior hf xs hx (ts w) (ts v)
  simp only [ContinuousLinearMap.map_add, ContinuousLinearMap.map_smul, smul_add, smul_smul,
    ContinuousLinearMap.add_apply, Pi.smul_apply, ContinuousLinearMap.coe_smul', C] at this
  rw [← sub_eq_zero] at this
  abel  at this
  simp only [one_zsmul, neg_smul, sub_eq_zero, mul_comm, ← sub_eq_add_neg] at this
  apply smul_right_injective F _ this
  simp [(tpos v).ne', (tpos w).ne']
#align convex.second_derivative_within_at_symmetric Convex.second_derivative_within_at_symmetric

/-- If a function is differentiable around `x`, and has two derivatives at `x`, then the second
derivative is symmetric. -/
theorem second_derivative_symmetric_of_eventually {f : E → F} {f' : E → E →L[ℝ] F}
    {f'' : E →L[ℝ] E →L[ℝ] F} (hf : ∀ᶠ y in 𝓝 x, HasFderivAt f (f' y) y) (hx : HasFderivAt f' f'' x)
    (v w : E) : f'' v w = f'' w v :=
  by
  rcases Metric.mem_nhds_iff.1 hf with ⟨ε, εpos, hε⟩
  have A : (interior (Metric.ball x ε)).Nonempty := by
    rwa [metric.is_open_ball.interior_eq, Metric.nonempty_ball]
  exact
    Convex.second_derivative_within_at_symmetric (convex_ball x ε) A
      (fun y hy => hε (interior_subset hy)) (Metric.mem_ball_self εpos) hx.has_fderiv_within_at v w
#align second_derivative_symmetric_of_eventually second_derivative_symmetric_of_eventually

/-- If a function is differentiable, and has two derivatives at `x`, then the second
derivative is symmetric. -/
theorem second_derivative_symmetric {f : E → F} {f' : E → E →L[ℝ] F} {f'' : E →L[ℝ] E →L[ℝ] F}
    (hf : ∀ y, HasFderivAt f (f' y) y) (hx : HasFderivAt f' f'' x) (v w : E) : f'' v w = f'' w v :=
  second_derivative_symmetric_of_eventually (Filter.eventually_of_forall hf) hx v w
#align second_derivative_symmetric second_derivative_symmetric