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

! This file was ported from Lean 3 source module algebraic_topology.simplex_category
! leanprover-community/mathlib commit e8ac6315bcfcbaf2d19a046719c3b553206dac75
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Tactic.Linarith.Default
import Mathbin.CategoryTheory.Skeletal
import Mathbin.Data.Fintype.Sort
import Mathbin.Order.Category.NonemptyFinLinOrd
import Mathbin.CategoryTheory.Functor.ReflectsIsomorphisms

/-! # The simplex category

We construct a skeletal model of the simplex category, with objects `ℕ` and the
morphism `n ⟶ m` being the monotone maps from `fin (n+1)` to `fin (m+1)`.

We show that this category is equivalent to `NonemptyFinLinOrd`.

## Remarks

The definitions `simplex_category` and `simplex_category.hom` are marked as irreducible.

We provide the following functions to work with these objects:
1. `simplex_category.mk` creates an object of `simplex_category` out of a natural number.
  Use the notation `[n]` in the `simplicial` locale.
2. `simplex_category.len` gives the "length" of an object of `simplex_category`, as a natural.
3. `simplex_category.hom.mk` makes a morphism out of a monotone map between `fin`'s.
4. `simplex_category.hom.to_order_hom` gives the underlying monotone map associated to a
  term of `simplex_category.hom`.

-/

universe v

open CategoryTheory CategoryTheory.Limits

/- ./././Mathport/Syntax/Translate/Command.lean:318:31: unsupported: @[derive, irreducible] def -/
/-- The simplex category:
* objects are natural numbers `n : ℕ`
* morphisms from `n` to `m` are monotone functions `fin (n+1) → fin (m+1)`
-/
irreducible_def SimplexCategory :=
  ℕ
#align simplex_category SimplexCategory

namespace SimplexCategory

section

attribute [local semireducible] SimplexCategory

-- TODO: Make `mk` irreducible.
/-- Interpet a natural number as an object of the simplex category. -/
def mk (n : ℕ) : SimplexCategory :=
  n
#align simplex_category.mk SimplexCategory.mk

-- mathport name: simplex_category.mk
scoped[Simplicial] notation "[" n "]" => SimplexCategory.mk n

-- TODO: Make `len` irreducible.
/-- The length of an object of `simplex_category`. -/
def len (n : SimplexCategory) : ℕ :=
  n
#align simplex_category.len SimplexCategory.len

@[ext]
theorem ext (a b : SimplexCategory) : a.len = b.len → a = b :=
  id
#align simplex_category.ext SimplexCategory.ext

@[simp]
theorem len_mk (n : ℕ) : [n].len = n :=
  rfl
#align simplex_category.len_mk SimplexCategory.len_mk

@[simp]
theorem mk_len (n : SimplexCategory) : [n.len] = n :=
  rfl
#align simplex_category.mk_len SimplexCategory.mk_len

/-- A recursor for `simplex_category`. Use it as `induction Δ using simplex_category.rec`. -/
protected def rec {F : ∀ Δ : SimplexCategory, Sort _} (h : ∀ n : ℕ, F [n]) : ∀ X, F X := fun n =>
  h n.len
#align simplex_category.rec SimplexCategory.rec

/-- Morphisms in the simplex_category. -/
@[nolint has_nonempty_instance]
protected irreducible_def Hom (a b : SimplexCategory) :=
  Fin (a.len + 1) →o Fin (b.len + 1)
#align simplex_category.hom SimplexCategory.Hom

namespace Hom

attribute [local semireducible] SimplexCategory.Hom

/-- Make a moprhism in `simplex_category` from a monotone map of fin's. -/
def mk {a b : SimplexCategory} (f : Fin (a.len + 1) →o Fin (b.len + 1)) : SimplexCategory.Hom a b :=
  f
#align simplex_category.hom.mk SimplexCategory.Hom.mk

/-- Recover the monotone map from a morphism in the simplex category. -/
def toOrderHom {a b : SimplexCategory} (f : SimplexCategory.Hom a b) :
    Fin (a.len + 1) →o Fin (b.len + 1) :=
  f
#align simplex_category.hom.to_order_hom SimplexCategory.Hom.toOrderHom

@[ext]
theorem ext {a b : SimplexCategory} (f g : SimplexCategory.Hom a b) :
    f.toOrderHom = g.toOrderHom → f = g :=
  id
#align simplex_category.hom.ext SimplexCategory.Hom.ext

@[simp]
theorem mk_toOrderHom {a b : SimplexCategory} (f : SimplexCategory.Hom a b) : mk f.toOrderHom = f :=
  rfl
#align simplex_category.hom.mk_to_order_hom SimplexCategory.Hom.mk_toOrderHom

@[simp]
theorem toOrderHom_mk {a b : SimplexCategory} (f : Fin (a.len + 1) →o Fin (b.len + 1)) :
    (mk f).toOrderHom = f :=
  rfl
#align simplex_category.hom.to_order_hom_mk SimplexCategory.Hom.toOrderHom_mk

theorem mk_toOrderHom_apply {a b : SimplexCategory} (f : Fin (a.len + 1) →o Fin (b.len + 1))
    (i : Fin (a.len + 1)) : (mk f).toOrderHom i = f i :=
  rfl
#align simplex_category.hom.mk_to_order_hom_apply SimplexCategory.Hom.mk_toOrderHom_apply

/-- Identity morphisms of `simplex_category`. -/
@[simp]
def id (a : SimplexCategory) : SimplexCategory.Hom a a :=
  mk OrderHom.id
#align simplex_category.hom.id SimplexCategory.Hom.id

/-- Composition of morphisms of `simplex_category`. -/
@[simp]
def comp {a b c : SimplexCategory} (f : SimplexCategory.Hom b c) (g : SimplexCategory.Hom a b) :
    SimplexCategory.Hom a c :=
  mk <| f.toOrderHom.comp g.toOrderHom
#align simplex_category.hom.comp SimplexCategory.Hom.comp

end Hom

@[simps]
instance smallCategory : SmallCategory.{0} SimplexCategory
    where
  Hom n m := SimplexCategory.Hom n m
  id m := SimplexCategory.Hom.id _
  comp _ _ _ f g := SimplexCategory.Hom.comp g f
#align simplex_category.small_category SimplexCategory.smallCategory

/-- The constant morphism from [0]. -/
def const (x : SimplexCategory) (i : Fin (x.len + 1)) : [0] ⟶ x :=
  Hom.mk <| ⟨fun _ => i, by tauto⟩
#align simplex_category.const SimplexCategory.const

@[simp]
theorem const_comp (x y : SimplexCategory) (i : Fin (x.len + 1)) (f : x ⟶ y) :
    const x i ≫ f = const y (f.toOrderHom i) :=
  rfl
#align simplex_category.const_comp SimplexCategory.const_comp

/-- Make a morphism `[n] ⟶ [m]` from a monotone map between fin's.
This is useful for constructing morphisms beetween `[n]` directly
without identifying `n` with `[n].len`.
-/
@[simp]
def mkHom {n m : ℕ} (f : Fin (n + 1) →o Fin (m + 1)) : [n] ⟶ [m] :=
  SimplexCategory.Hom.mk f
#align simplex_category.mk_hom SimplexCategory.mkHom

theorem hom_zero_zero (f : [0] ⟶ [0]) : f = 𝟙 _ :=
  by
  ext : 2
  dsimp
  apply Subsingleton.elim
#align simplex_category.hom_zero_zero SimplexCategory.hom_zero_zero

end

open Simplicial

section Generators

/-!
## Generating maps for the simplex category

TODO: prove that the simplex category is equivalent to
one given by the following generators and relations.
-/

/-- The `i`-th face map from `[n]` to `[n+1]` -/
def δ {n} (i : Fin (n + 2)) : [n] ⟶ [n + 1] :=
  mkHom (Fin.succAbove i).toOrderHom
#align simplex_category.δ SimplexCategory.δ

/-- The `i`-th degeneracy map from `[n+1]` to `[n]` -/
def σ {n} (i : Fin (n + 1)) : [n + 1] ⟶ [n] :=
  mkHom
    { toFun := Fin.predAbove i
      monotone' := Fin.predAbove_right_monotone i }
#align simplex_category.σ SimplexCategory.σ

/-- The generic case of the first simplicial identity -/
theorem δ_comp_δ {n} {i j : Fin (n + 2)} (H : i ≤ j) : δ i ≫ δ j.succ = δ j ≫ δ i.cast_succ :=
  by
  ext k
  dsimp [δ, Fin.succAbove]
  simp only [OrderEmbedding.toOrderHom_coe, OrderEmbedding.coe_ofStrictMono, Function.comp_apply,
    SimplexCategory.Hom.toOrderHom_mk, OrderHom.comp_coe]
  rcases i with ⟨i, _⟩
  rcases j with ⟨j, _⟩
  rcases k with ⟨k, _⟩
  split_ifs <;> · simp at * <;> linarith
#align simplex_category.δ_comp_δ SimplexCategory.δ_comp_δ

theorem δ_comp_δ' {n} {i : Fin (n + 2)} {j : Fin (n + 3)} (H : i.cast_succ < j) :
    δ i ≫ δ j = δ (j.pred fun hj => by simpa only [hj, Fin.not_lt_zero] using H) ≫ δ i.cast_succ :=
  by
  rw [← δ_comp_δ]
  · rw [Fin.succ_pred]
  ·
    simpa only [Fin.le_iff_val_le_val, ← Nat.lt_succ_iff, Nat.succ_eq_add_one, ← Fin.val_succ,
      j.succ_pred, Fin.lt_iff_val_lt_val] using H
#align simplex_category.δ_comp_δ' SimplexCategory.δ_comp_δ'

theorem δ_comp_δ'' {n} {i : Fin (n + 3)} {j : Fin (n + 2)} (H : i ≤ j.cast_succ) :
    δ (i.cast_lt (Nat.lt_of_le_of_lt (Fin.le_iff_val_le_val.mp H) j.is_lt)) ≫ δ j.succ =
      δ j ≫ δ i :=
  by
  rw [δ_comp_δ]
  · rfl
  · exact H
#align simplex_category.δ_comp_δ'' SimplexCategory.δ_comp_δ''

/-- The special case of the first simplicial identity -/
@[reassoc.1]
theorem δ_comp_δ_self {n} {i : Fin (n + 2)} : δ i ≫ δ i.cast_succ = δ i ≫ δ i.succ :=
  (δ_comp_δ (le_refl i)).symm
#align simplex_category.δ_comp_δ_self SimplexCategory.δ_comp_δ_self

@[reassoc.1]
theorem δ_comp_δ_self' {n} {i : Fin (n + 2)} {j : Fin (n + 3)} (H : j = i.cast_succ) :
    δ i ≫ δ j = δ i ≫ δ i.succ := by
  subst H
  rw [δ_comp_δ_self]
#align simplex_category.δ_comp_δ_self' SimplexCategory.δ_comp_δ_self'

/-- The second simplicial identity -/
@[reassoc.1]
theorem δ_comp_σ_of_le {n} {i : Fin (n + 2)} {j : Fin (n + 1)} (H : i ≤ j.cast_succ) :
    δ i.cast_succ ≫ σ j.succ = σ j ≫ δ i := by
  ext k
  suffices
    ite (j.succ.cast_succ < ite (k < i) k.cast_succ k.succ) (ite (k < i) (k : ℕ) (k + 1) - 1)
        (ite (k < i) k (k + 1)) =
      ite
        ((if h : (j : ℕ) < k then
              k.pred
                (by
                  rintro rfl
                  exact Nat.not_lt_zero _ h)
            else
              k.cast_lt
                (by
                  cases j
                  cases k
                  simp only [len_mk]
                  linarith)).cast_succ <
          i)
        (ite (j.cast_succ < k) (k - 1) k) (ite (j.cast_succ < k) (k - 1) k + 1)
    by
    dsimp [δ, σ, Fin.succAbove, Fin.predAbove]
    simp [Fin.predAbove, push_cast]
    convert rfl
  rcases i with ⟨i, _⟩
  rcases j with ⟨j, _⟩
  rcases k with ⟨k, _⟩
  simp only [Fin.mk_le_mk, Fin.castSucc_mk] at H
  dsimp
  split_ifs
  -- Most of the goals can now be handled by `linarith`,
  -- but we have to deal with two of them by hand.
  pick_goal 8
  · exact (Nat.succ_pred_eq_of_pos (lt_of_le_of_lt (zero_le _) ‹_›)).symm
  pick_goal 7
  · have : k ≤ i := Nat.le_of_pred_lt ‹_›
    linarith
  -- Hope for the best from `linarith`:
  all_goals try first |rfl|simp at * <;> linarith
#align simplex_category.δ_comp_σ_of_le SimplexCategory.δ_comp_σ_of_le

/-- The first part of the third simplicial identity -/
@[reassoc.1]
theorem δ_comp_σ_self {n} {i : Fin (n + 1)} : δ i.cast_succ ≫ σ i = 𝟙 [n] :=
  by
  ext j
  suffices
    ite (Fin.castSucc i < ite (j < i) (Fin.castSucc j) j.succ) (ite (j < i) (j : ℕ) (j + 1) - 1)
        (ite (j < i) j (j + 1)) =
      j
    by
    dsimp [δ, σ, Fin.succAbove, Fin.predAbove]
    simpa [Fin.predAbove, push_cast]
  rcases i with ⟨i, _⟩
  rcases j with ⟨j, _⟩
  dsimp
  split_ifs <;> · simp at * <;> linarith
#align simplex_category.δ_comp_σ_self SimplexCategory.δ_comp_σ_self

@[reassoc.1]
theorem δ_comp_σ_self' {n} {j : Fin (n + 2)} {i : Fin (n + 1)} (H : j = i.cast_succ) :
    δ j ≫ σ i = 𝟙 [n] := by
  subst H
  rw [δ_comp_σ_self]
#align simplex_category.δ_comp_σ_self' SimplexCategory.δ_comp_σ_self'

/-- The second part of the third simplicial identity -/
@[reassoc.1]
theorem δ_comp_σ_succ {n} {i : Fin (n + 1)} : δ i.succ ≫ σ i = 𝟙 [n] :=
  by
  ext j
  rcases i with ⟨i, _⟩
  rcases j with ⟨j, _⟩
  dsimp [δ, σ, Fin.succAbove, Fin.predAbove]
  simp [Fin.predAbove, push_cast]
  split_ifs <;> · simp at * <;> linarith
#align simplex_category.δ_comp_σ_succ SimplexCategory.δ_comp_σ_succ

@[reassoc.1]
theorem δ_comp_σ_succ' {n} (j : Fin (n + 2)) (i : Fin (n + 1)) (H : j = i.succ) :
    δ j ≫ σ i = 𝟙 [n] := by
  subst H
  rw [δ_comp_σ_succ]
#align simplex_category.δ_comp_σ_succ' SimplexCategory.δ_comp_σ_succ'

/-- The fourth simplicial identity -/
@[reassoc.1]
theorem δ_comp_σ_of_gt {n} {i : Fin (n + 2)} {j : Fin (n + 1)} (H : j.cast_succ < i) :
    δ i.succ ≫ σ j.cast_succ = σ j ≫ δ i := by
  ext k
  dsimp [δ, σ, Fin.succAbove, Fin.predAbove]
  rcases i with ⟨i, _⟩
  rcases j with ⟨j, _⟩
  rcases k with ⟨k, _⟩
  simp only [Fin.mk_lt_mk, Fin.castSucc_mk] at H
  suffices
    ite (_ < ite (k < i + 1) _ _) _ _ = ite _ (ite (j < k) (k - 1) k) (ite (j < k) (k - 1) k + 1) by
    simpa [apply_dite Fin.castSucc, Fin.predAbove, push_cast]
  split_ifs
  -- Most of the goals can now be handled by `linarith`,
  -- but we have to deal with three of them by hand.
  swap
  · simp only [Fin.mk_lt_mk] at h_1
    simp only [not_lt] at h_2
    simp only [self_eq_add_right, one_ne_zero]
    exact
      lt_irrefl (k - 1)
        (lt_of_lt_of_le (Nat.pred_lt (ne_of_lt (lt_of_le_of_lt (zero_le _) h_1)).symm)
          (le_trans (Nat.le_of_lt_succ h) h_2))
  pick_goal 4
  · simp only [Fin.mk_lt_mk] at h_1
    simp only [not_lt] at h
    simp only [Nat.add_succ_sub_one, add_zero]
    exfalso
    exact lt_irrefl _ (lt_of_le_of_lt (Nat.le_pred_of_lt (Nat.lt_of_succ_le h)) h_3)
  pick_goal 4
  · simp only [Fin.mk_lt_mk] at h_1
    simp only [not_lt] at h_3
    simp only [Nat.add_succ_sub_one, add_zero]
    exact (Nat.succ_pred_eq_of_pos (lt_of_le_of_lt (zero_le _) h_2)).symm
  -- Hope for the best from `linarith`:
  all_goals simp at h_1 h_2⊢ <;> linarith
#align simplex_category.δ_comp_σ_of_gt SimplexCategory.δ_comp_σ_of_gt

@[reassoc.1]
theorem δ_comp_σ_of_gt' {n} {i : Fin (n + 3)} {j : Fin (n + 2)} (H : j.succ < i) :
    δ i ≫ σ j =
      σ
          (j.cast_lt
            ((add_lt_add_iff_right 1).mp
              (lt_of_lt_of_le
                (by simpa only [[anonymous], ← Fin.val_succ] using fin.lt_iff_coe_lt_coe.mp H)
                i.is_le))) ≫
        δ (i.pred fun hi => by simpa only [Fin.not_lt_zero, hi] using H) :=
  by
  rw [← δ_comp_σ_of_gt]
  · simpa only [Fin.succ_pred]
  · rw [Fin.castSucc_cast_lt, ← Fin.succ_lt_succ_iff, Fin.succ_pred]
    exact H
#align simplex_category.δ_comp_σ_of_gt' SimplexCategory.δ_comp_σ_of_gt'

attribute [local simp] Fin.pred_mk

/-- The fifth simplicial identity -/
@[reassoc.1]
theorem σ_comp_σ {n} {i j : Fin (n + 1)} (H : i ≤ j) : σ i.cast_succ ≫ σ j = σ j.succ ≫ σ i :=
  by
  ext k
  dsimp [σ, Fin.predAbove]
  rcases i with ⟨i, _⟩
  rcases j with ⟨j, _⟩
  rcases k with ⟨k, _⟩
  simp only [Fin.mk_le_mk] at H
  -- At this point `simp with push_cast` makes good progress, but neither `simp?` nor `squeeze_simp`
  -- return usable sets of lemmas.
  -- To avoid using a non-terminal simp, we make a `suffices` statement indicating the shape
  -- of the goal we're looking for, and then use `simpa with push_cast`.
  -- I'm not sure this is actually much more robust that a non-terminal simp.
  suffices ite (_ < dite (i < k) _ _) _ _ = ite (_ < dite (j + 1 < k) _ _) _ _ by
    simpa [Fin.predAbove, push_cast]
  split_ifs
  -- `split_ifs` created 12 goals.
  -- Most of them are dealt with `by simp at *; linarith`,
  -- but we pull out two harder ones to do by hand.
  pick_goal 3
  · simp only [not_lt] at h_2
    exact
      False.elim
        (lt_irrefl (k - 1)
          (lt_of_lt_of_le (Nat.pred_lt (id (ne_of_lt (lt_of_le_of_lt (zero_le i) h)).symm))
            (le_trans h_2 (Nat.succ_le_of_lt h_1))))
  pick_goal 3
  · simp only [Subtype.mk_lt_mk, not_lt] at h_1
    exact False.elim (lt_irrefl j (lt_of_lt_of_le (Nat.pred_lt_pred (Nat.succ_ne_zero j) h_2) h_1))
  -- Deal with the rest automatically.
  all_goals simp at * <;> linarith
#align simplex_category.σ_comp_σ SimplexCategory.σ_comp_σ

end Generators

section Skeleton

/-- The functor that exhibits `simplex_category` as skeleton
of `NonemptyFinLinOrd` -/
@[simps obj map]
def skeletalFunctor : SimplexCategory ⥤ NonemptyFinLinOrdCat.{v}
    where
  obj a := NonemptyFinLinOrdCat.of <| ULift (Fin (a.len + 1))
  map a b f := ⟨fun i => ULift.up (f.toOrderHom i.down), fun i j h => f.toOrderHom.Monotone h⟩
  map_id' a := by
    ext
    simp
  map_comp' a b c f g := by
    ext
    simp
#align simplex_category.skeletal_functor SimplexCategory.skeletalFunctor

theorem skeletalFunctor.coe_map {Δ₁ Δ₂ : SimplexCategory} (f : Δ₁ ⟶ Δ₂) :
    coeFn (skeletalFunctor.{v}.map f) = ULift.up ∘ f.toOrderHom ∘ ULift.down :=
  rfl
#align simplex_category.skeletal_functor.coe_map SimplexCategory.skeletalFunctor.coe_map

theorem skeletal : Skeletal SimplexCategory := fun X Y ⟨I⟩ =>
  by
  suffices Fintype.card (Fin (X.len + 1)) = Fintype.card (Fin (Y.len + 1))
    by
    ext
    simpa
  · apply Fintype.card_congr
    refine' equiv.ulift.symm.trans (((skeletal_functor ⋙ forget _).mapIso I).toEquiv.trans _)
    apply Equiv.ulift
#align simplex_category.skeletal SimplexCategory.skeletal

namespace SkeletalFunctor

instance : Full skeletalFunctor.{v}
    where
  Preimage a b f :=
    SimplexCategory.Hom.mk ⟨fun i => (f (ULift.up i)).down, fun i j h => f.Monotone h⟩
  witness' := by
    intro m n f
    dsimp at *
    ext1 ⟨i⟩
    ext1
    ext1
    cases x
    simp

instance : Faithful skeletalFunctor.{v}
    where map_injective' m n f g h := by
    ext1; ext1; ext1 i; apply ULift.up.inj
    change (skeletal_functor.map f) ⟨i⟩ = (skeletal_functor.map g) ⟨i⟩
    rw [h]

instance : EssSurj skeletalFunctor.{v}
    where mem_essImage X :=
    ⟨mk (Fintype.card X - 1 : ℕ),
      ⟨by
        have aux : Fintype.card X = Fintype.card X - 1 + 1 :=
          (Nat.succ_pred_eq_of_pos <| fintype.card_pos_iff.mpr ⟨⊥⟩).symm
        let f := monoEquivOfFin X aux
        have hf := (finset.univ.order_emb_of_fin aux).StrictMono
        refine'
          { Hom := ⟨fun i => f i.down, _⟩
            inv := ⟨fun i => ⟨f.symm i⟩, _⟩
            hom_inv_id' := _
            inv_hom_id' := _ }
        · rintro ⟨i⟩ ⟨j⟩ h
          show f i ≤ f j
          exact hf.monotone h
        · intro i j h
          show f.symm i ≤ f.symm j
          rw [← hf.le_iff_le]
          show f (f.symm i) ≤ f (f.symm j)
          simpa only [OrderIso.apply_symm_apply]
        · ext1
          ext1 ⟨i⟩
          ext1
          exact f.symm_apply_apply i
        · ext1
          ext1 i
          exact f.apply_symm_apply i⟩⟩

noncomputable instance isEquivalence : IsEquivalence skeletalFunctor.{v} :=
  Equivalence.ofFullyFaithfullyEssSurj skeletalFunctor
#align simplex_category.skeletal_functor.is_equivalence SimplexCategory.skeletalFunctor.isEquivalence

end SkeletalFunctor

/-- The equivalence that exhibits `simplex_category` as skeleton
of `NonemptyFinLinOrd` -/
noncomputable def skeletalEquivalence : SimplexCategory ≌ NonemptyFinLinOrdCat.{v} :=
  Functor.asEquivalence skeletalFunctor
#align simplex_category.skeletal_equivalence SimplexCategory.skeletalEquivalence

end Skeleton

/-- `simplex_category` is a skeleton of `NonemptyFinLinOrd`.
-/
noncomputable def isSkeletonOf :
    IsSkeletonOf NonemptyFinLinOrdCat SimplexCategory skeletalFunctor.{v}
    where
  skel := skeletal
  eqv := skeletalFunctor.isEquivalence
#align simplex_category.is_skeleton_of SimplexCategory.isSkeletonOf

/-- The truncated simplex category. -/
def Truncated (n : ℕ) :=
  FullSubcategory fun a : SimplexCategory => a.len ≤ n deriving SmallCategory
#align simplex_category.truncated SimplexCategory.Truncated

namespace Truncated

instance {n} : Inhabited (Truncated n) :=
  ⟨⟨[0], by simp⟩⟩

/-- The fully faithful inclusion of the truncated simplex category into the usual
simplex category.
-/
def inclusion {n : ℕ} : SimplexCategory.Truncated n ⥤ SimplexCategory :=
  fullSubcategoryInclusion _ deriving Full, Faithful
#align simplex_category.truncated.inclusion SimplexCategory.Truncated.inclusion

end Truncated

section Concrete

instance : ConcreteCategory.{0} SimplexCategory
    where
  forget :=
    { obj := fun i => Fin (i.len + 1)
      map := fun i j f => f.toOrderHom }
  forget_faithful := { }

end Concrete

section EpiMono

/-- A morphism in `simplex_category` is a monomorphism precisely when it is an injective function
-/
theorem mono_iff_injective {n m : SimplexCategory} {f : n ⟶ m} :
    Mono f ↔ Function.Injective f.toOrderHom :=
  by
  rw [← functor.mono_map_iff_mono skeletal_equivalence.Functor]
  dsimp only [skeletal_equivalence, functor.as_equivalence_functor]
  rw [NonemptyFinLinOrdCat.mono_iff_injective, skeletal_functor.coe_map,
    Function.Injective.of_comp_iff ULift.up_injective,
    Function.Injective.of_comp_iff' _ ULift.down_bijective]
#align simplex_category.mono_iff_injective SimplexCategory.mono_iff_injective

/-- A morphism in `simplex_category` is an epimorphism if and only if it is a surjective function
-/
theorem epi_iff_surjective {n m : SimplexCategory} {f : n ⟶ m} :
    Epi f ↔ Function.Surjective f.toOrderHom :=
  by
  rw [← functor.epi_map_iff_epi skeletal_equivalence.Functor]
  dsimp only [skeletal_equivalence, functor.as_equivalence_functor]
  rw [NonemptyFinLinOrdCat.epi_iff_surjective, skeletal_functor.coe_map,
    Function.Surjective.of_comp_iff' ULift.up_bijective,
    Function.Surjective.of_comp_iff _ ULift.down_surjective]
#align simplex_category.epi_iff_surjective SimplexCategory.epi_iff_surjective

/-- A monomorphism in `simplex_category` must increase lengths-/
theorem len_le_of_mono {x y : SimplexCategory} {f : x ⟶ y} : Mono f → x.len ≤ y.len :=
  by
  intro hyp_f_mono
  have f_inj : Function.Injective f.to_order_hom.to_fun := mono_iff_injective.elim_left hyp_f_mono
  simpa using Fintype.card_le_of_injective f.to_order_hom.to_fun f_inj
#align simplex_category.len_le_of_mono SimplexCategory.len_le_of_mono

theorem le_of_mono {n m : ℕ} {f : [n] ⟶ [m]} : CategoryTheory.Mono f → n ≤ m :=
  len_le_of_mono
#align simplex_category.le_of_mono SimplexCategory.le_of_mono

/-- An epimorphism in `simplex_category` must decrease lengths-/
theorem len_le_of_epi {x y : SimplexCategory} {f : x ⟶ y} : Epi f → y.len ≤ x.len :=
  by
  intro hyp_f_epi
  have f_surj : Function.Surjective f.to_order_hom.to_fun := epi_iff_surjective.elim_left hyp_f_epi
  simpa using Fintype.card_le_of_surjective f.to_order_hom.to_fun f_surj
#align simplex_category.len_le_of_epi SimplexCategory.len_le_of_epi

theorem le_of_epi {n m : ℕ} {f : [n] ⟶ [m]} : Epi f → m ≤ n :=
  len_le_of_epi
#align simplex_category.le_of_epi SimplexCategory.le_of_epi

instance {n : ℕ} {i : Fin (n + 2)} : Mono (δ i) :=
  by
  rw [mono_iff_injective]
  exact Fin.succAbove_right_injective

instance {n : ℕ} {i : Fin (n + 1)} : Epi (σ i) :=
  by
  rw [epi_iff_surjective]
  intro b
  simp only [σ, mk_hom, hom.to_order_hom_mk, OrderHom.coe_fun_mk]
  by_cases b ≤ i
  · use b
    rw [Fin.predAbove_below i b (by simpa only [Fin.coe_eq_castSucc] using h)]
    simp only [Fin.coe_eq_castSucc, Fin.castPred_castSucc]
  · use b.succ
    rw [Fin.predAbove_above i b.succ _, Fin.pred_succ]
    rw [not_le] at h
    rw [Fin.lt_iff_val_lt_val] at h⊢
    simpa only [Fin.val_succ, Fin.coe_castSucc] using Nat.lt.step h

instance : ReflectsIsomorphisms (forget SimplexCategory) :=
  ⟨by
    intro x y f
    intro
    exact
      is_iso.of_iso
        { Hom := f
          inv :=
            hom.mk
              { toFun := inv ((forget SimplexCategory).map f)
                monotone' := fun y₁ y₂ h => by
                  by_cases h' : y₁ < y₂
                  · by_contra h''
                    have eq := fun i => congr_hom (iso.inv_hom_id (as_iso ((forget _).map f))) i
                    have ineq := f.to_order_hom.monotone' (le_of_not_ge h'')
                    dsimp at ineq
                    erw [Eq, Eq] at ineq
                    exact not_le.mpr h' ineq
                  · rw [eq_of_le_of_not_lt h h'] }
          hom_inv_id' := by
            ext1
            ext1
            exact iso.hom_inv_id (as_iso ((forget _).map f))
          inv_hom_id' := by
            ext1
            ext1
            exact iso.inv_hom_id (as_iso ((forget _).map f)) }⟩

theorem isIso_of_bijective {x y : SimplexCategory} {f : x ⟶ y}
    (hf : Function.Bijective f.toOrderHom.toFun) : IsIso f :=
  haveI : is_iso ((forget SimplexCategory).map f) := (is_iso_iff_bijective _).mpr hf
  is_iso_of_reflects_iso f (forget SimplexCategory)
#align simplex_category.is_iso_of_bijective SimplexCategory.isIso_of_bijective

/-- An isomorphism in `simplex_category` induces an `order_iso`. -/
@[simp]
def orderIsoOfIso {x y : SimplexCategory} (e : x ≅ y) : Fin (x.len + 1) ≃o Fin (y.len + 1) :=
  Equiv.toOrderIso
    { toFun := e.Hom.toOrderHom
      invFun := e.inv.toOrderHom
      left_inv := fun i => by
        simpa only using congr_arg (fun φ => (hom.to_order_hom φ) i) e.hom_inv_id'
      right_inv := fun i => by
        simpa only using congr_arg (fun φ => (hom.to_order_hom φ) i) e.inv_hom_id' }
    e.Hom.toOrderHom.Monotone e.inv.toOrderHom.Monotone
#align simplex_category.order_iso_of_iso SimplexCategory.orderIsoOfIso

theorem iso_eq_iso_refl {x : SimplexCategory} (e : x ≅ x) : e = Iso.refl x :=
  by
  have h : (Finset.univ : Finset (Fin (x.len + 1))).card = x.len + 1 := Finset.card_fin (x.len + 1)
  have eq₁ := Finset.orderEmbOfFin_unique' h fun i => Finset.mem_univ ((order_iso_of_iso e) i)
  have eq₂ :=
    Finset.orderEmbOfFin_unique' h fun i => Finset.mem_univ ((order_iso_of_iso (iso.refl x)) i)
  ext1; ext1
  convert congr_arg (fun φ => OrderEmbedding.toOrderHom φ) (eq₁.trans eq₂.symm)
  ext1; ext1 i
  rfl
#align simplex_category.iso_eq_iso_refl SimplexCategory.iso_eq_iso_refl

theorem eq_id_of_isIso {x : SimplexCategory} (f : x ⟶ x) [hf : IsIso f] : f = 𝟙 _ :=
  congr_arg (fun φ : _ ≅ _ => φ.Hom) (iso_eq_iso_refl (asIso f))
#align simplex_category.eq_id_of_is_iso SimplexCategory.eq_id_of_isIso

theorem eq_σ_comp_of_not_injective' {n : ℕ} {Δ' : SimplexCategory} (θ : mk (n + 1) ⟶ Δ')
    (i : Fin (n + 1)) (hi : θ.toOrderHom i.cast_succ = θ.toOrderHom i.succ) :
    ∃ θ' : mk n ⟶ Δ', θ = σ i ≫ θ' := by
  use δ i.succ ≫ θ
  ext1; ext1; ext1 x
  simp only [hom.to_order_hom_mk, Function.comp_apply, OrderHom.comp_coe, hom.comp,
    small_category_comp, σ, mk_hom, OrderHom.coe_fun_mk]
  by_cases h' : x ≤ i.cast_succ
  · rw [Fin.predAbove_below i x h']
    have eq := Fin.castSucc_castPred (gt_of_gt_of_ge (Fin.castSucc_lt_last i) h')
    erw [Fin.succAbove_below i.succ x.cast_pred _]
    swap
    · rwa [Eq, ← Fin.le_castSucc_iff]
    rw [Eq]
  · simp only [not_le] at h'
    let y :=
      x.pred
        (by
          intro h
          rw [h] at h'
          simpa only [Fin.lt_iff_val_lt_val, Nat.not_lt_zero, Fin.val_zero] using h')
    simp only [show x = y.succ by rw [Fin.succ_pred]] at h'⊢
    rw [Fin.predAbove_above i y.succ h', Fin.pred_succ]
    by_cases h'' : y = i
    · rw [h'']
      convert hi.symm
      erw [Fin.succAbove_below i.succ _]
      exact Fin.lt_succ
    · erw [Fin.succAbove_above i.succ _]
      simp only [Fin.lt_iff_val_lt_val, Fin.le_iff_val_le_val, Fin.val_succ, Fin.coe_castSucc,
        Nat.lt_succ_iff, Fin.ext_iff] at h' h''⊢
      cases' Nat.le.dest h' with c hc
      cases c
      · exfalso
        rw [add_zero] at hc
        rw [hc] at h''
        exact h'' rfl
      · rw [← hc]
        simp only [add_le_add_iff_left, Nat.succ_eq_add_one, le_add_iff_nonneg_left, zero_le]
#align simplex_category.eq_σ_comp_of_not_injective' SimplexCategory.eq_σ_comp_of_not_injective'

theorem eq_σ_comp_of_not_injective {n : ℕ} {Δ' : SimplexCategory} (θ : mk (n + 1) ⟶ Δ')
    (hθ : ¬Function.Injective θ.toOrderHom) : ∃ (i : Fin (n + 1))(θ' : mk n ⟶ Δ'), θ = σ i ≫ θ' :=
  by
  simp only [Function.Injective, exists_prop, not_forall] at hθ
  -- as θ is not injective, there exists `x<y` such that `θ x = θ y`
  -- and then, `θ x = θ (x+1)`
  have hθ₂ : ∃ x y : Fin (n + 2), (hom.to_order_hom θ) x = (hom.to_order_hom θ) y ∧ x < y :=
    by
    rcases hθ with ⟨x, y, ⟨h₁, h₂⟩⟩
    by_cases x < y
    · exact ⟨x, y, ⟨h₁, h⟩⟩
    · refine' ⟨y, x, ⟨h₁.symm, _⟩⟩
      cases' lt_or_eq_of_le (not_lt.mp h) with h' h'
      · exact h'
      · exfalso
        exact h₂ h'.symm
  rcases hθ₂ with ⟨x, y, ⟨h₁, h₂⟩⟩
  let z := x.cast_pred
  use z
  simp only [←
    show z.cast_succ = x from Fin.castSucc_castPred (lt_of_lt_of_le h₂ (Fin.le_last y))] at h₁ h₂
  apply eq_σ_comp_of_not_injective'
  rw [Fin.castSucc_lt_iff_succ_le] at h₂
  apply le_antisymm
  · exact θ.to_order_hom.monotone (le_of_lt (Fin.castSucc_lt_succ z))
  · rw [h₁]
    exact θ.to_order_hom.monotone h₂
#align simplex_category.eq_σ_comp_of_not_injective SimplexCategory.eq_σ_comp_of_not_injective

theorem eq_comp_δ_of_not_surjective' {n : ℕ} {Δ : SimplexCategory} (θ : Δ ⟶ mk (n + 1))
    (i : Fin (n + 2)) (hi : ∀ x, θ.toOrderHom x ≠ i) : ∃ θ' : Δ ⟶ mk n, θ = θ' ≫ δ i :=
  by
  by_cases i < Fin.last (n + 1)
  · use θ ≫ σ (Fin.castPred i)
    ext1
    ext1
    ext1 x
    simp only [hom.to_order_hom_mk, Function.comp_apply, OrderHom.comp_coe, hom.comp,
      small_category_comp]
    by_cases h' : θ.to_order_hom x ≤ i
    · simp only [σ, mk_hom, hom.to_order_hom_mk, OrderHom.coe_fun_mk]
      rw [Fin.predAbove_below (Fin.castPred i) (θ.to_order_hom x)
          (by simpa [Fin.castSucc_castPred h] using h')]
      erw [Fin.succAbove_below i]
      swap
      · simp only [Fin.lt_iff_val_lt_val, Fin.coe_castSucc]
        exact
          lt_of_le_of_lt (Fin.coe_castPred_le_self _)
            (fin.lt_iff_coe_lt_coe.mp ((Ne.le_iff_lt (hi x)).mp h'))
      rw [Fin.castSucc_castPred]
      apply lt_of_le_of_lt h' h
    · simp only [not_le] at h'
      simp only [σ, mk_hom, hom.to_order_hom_mk, OrderHom.coe_fun_mk,
        Fin.predAbove_above (Fin.castPred i) (θ.to_order_hom x)
          (by simpa only [Fin.castSucc_castPred h] using h')]
      erw [Fin.succAbove_above i _, Fin.succ_pred]
      simpa only [Fin.le_iff_val_le_val, Fin.coe_castSucc, Fin.coe_pred] using
        Nat.le_pred_of_lt (fin.lt_iff_coe_lt_coe.mp h')
  · obtain rfl := le_antisymm (Fin.le_last i) (not_lt.mp h)
    use θ ≫ σ (Fin.last _)
    ext1
    ext1
    ext1 x
    simp only [hom.to_order_hom_mk, Function.comp_apply, OrderHom.comp_coe, hom.comp,
      small_category_comp, σ, δ, mk_hom, OrderHom.coe_fun_mk, OrderEmbedding.toOrderHom_coe,
      Fin.predAbove_last, Fin.succAbove_last,
      Fin.castSucc_castPred ((Ne.le_iff_lt (hi x)).mp (Fin.le_last _))]
#align simplex_category.eq_comp_δ_of_not_surjective' SimplexCategory.eq_comp_δ_of_not_surjective'

theorem eq_comp_δ_of_not_surjective {n : ℕ} {Δ : SimplexCategory} (θ : Δ ⟶ mk (n + 1))
    (hθ : ¬Function.Surjective θ.toOrderHom) : ∃ (i : Fin (n + 2))(θ' : Δ ⟶ mk n), θ = θ' ≫ δ i :=
  by
  cases' not_forall.mp hθ with i hi
  use i
  exact eq_comp_δ_of_not_surjective' θ i (not_exists.mp hi)
#align simplex_category.eq_comp_δ_of_not_surjective SimplexCategory.eq_comp_δ_of_not_surjective

theorem eq_id_of_mono {x : SimplexCategory} (i : x ⟶ x) [Mono i] : i = 𝟙 _ :=
  by
  suffices is_iso i by
    haveI := this
    apply eq_id_of_is_iso
  apply is_iso_of_bijective
  dsimp
  rw [Fintype.bijective_iff_injective_and_card i.to_order_hom, ← mono_iff_injective,
    eq_self_iff_true, and_true_iff]
  infer_instance
#align simplex_category.eq_id_of_mono SimplexCategory.eq_id_of_mono

theorem eq_id_of_epi {x : SimplexCategory} (i : x ⟶ x) [Epi i] : i = 𝟙 _ :=
  by
  suffices is_iso i by
    haveI := this
    apply eq_id_of_is_iso
  apply is_iso_of_bijective
  dsimp
  rw [Fintype.bijective_iff_surjective_and_card i.to_order_hom, ← epi_iff_surjective,
    eq_self_iff_true, and_true_iff]
  infer_instance
#align simplex_category.eq_id_of_epi SimplexCategory.eq_id_of_epi

theorem eq_σ_of_epi {n : ℕ} (θ : mk (n + 1) ⟶ mk n) [Epi θ] : ∃ i : Fin (n + 1), θ = σ i :=
  by
  rcases eq_σ_comp_of_not_injective θ _ with ⟨i, θ', h⟩; swap
  · by_contra
    simpa only [Nat.one_ne_zero, add_le_iff_nonpos_right, nonpos_iff_eq_zero] using
      le_of_mono (mono_iff_injective.mpr h)
  use i
  haveI : epi (σ i ≫ θ') := by
    rw [← h]
    infer_instance
  haveI := CategoryTheory.epi_of_epi (σ i) θ'
  rw [h, eq_id_of_epi θ', category.comp_id]
#align simplex_category.eq_σ_of_epi SimplexCategory.eq_σ_of_epi

theorem eq_δ_of_mono {n : ℕ} (θ : mk n ⟶ mk (n + 1)) [Mono θ] : ∃ i : Fin (n + 2), θ = δ i :=
  by
  rcases eq_comp_δ_of_not_surjective θ _ with ⟨i, θ', h⟩; swap
  · by_contra
    simpa only [add_le_iff_nonpos_right, nonpos_iff_eq_zero] using
      le_of_epi (epi_iff_surjective.mpr h)
  use i
  haveI : mono (θ' ≫ δ i) := by
    rw [← h]
    infer_instance
  haveI := CategoryTheory.mono_of_mono θ' (δ i)
  rw [h, eq_id_of_mono θ', category.id_comp]
#align simplex_category.eq_δ_of_mono SimplexCategory.eq_δ_of_mono

theorem len_lt_of_mono {Δ' Δ : SimplexCategory} (i : Δ' ⟶ Δ) [hi : Mono i] (hi' : Δ ≠ Δ') :
    Δ'.len < Δ.len := by
  cases lt_or_eq_of_le (len_le_of_mono hi)
  · exact h
  · exfalso
    exact
      hi'
        (by
          ext
          exact h.symm)
#align simplex_category.len_lt_of_mono SimplexCategory.len_lt_of_mono

noncomputable instance : SplitEpiCategory SimplexCategory :=
  skeletalEquivalence.{0}.inverse.splitEpiCategoryImpOfIsEquivalence

instance : HasStrongEpiMonoFactorisations SimplexCategory :=
  Functor.hasStrongEpiMonoFactorisations_imp_of_isEquivalence
    SimplexCategory.skeletalEquivalence.{0}.inverse

instance : HasStrongEpiImages SimplexCategory :=
  Limits.hasStrongEpiImages_of_hasStrongEpiMonoFactorisations

instance (Δ Δ' : SimplexCategory) (θ : Δ ⟶ Δ') : Epi (factorThruImage θ) :=
  StrongEpi.epi

theorem image_eq {Δ Δ' Δ'' : SimplexCategory} {φ : Δ ⟶ Δ''} {e : Δ ⟶ Δ'} [Epi e] {i : Δ' ⟶ Δ''}
    [Mono i] (fac : e ≫ i = φ) : image φ = Δ' :=
  by
  haveI := strong_epi_of_epi e
  let e := image.iso_strong_epi_mono e i fac
  ext
  exact
    le_antisymm (len_le_of_epi (inferInstance : epi e.hom))
      (len_le_of_mono (inferInstance : mono e.hom))
#align simplex_category.image_eq SimplexCategory.image_eq

theorem image_ι_eq {Δ Δ'' : SimplexCategory} {φ : Δ ⟶ Δ''} {e : Δ ⟶ image φ} [Epi e]
    {i : image φ ⟶ Δ''} [Mono i] (fac : e ≫ i = φ) : image.ι φ = i :=
  by
  haveI := strong_epi_of_epi e
  rw [← image.iso_strong_epi_mono_hom_comp_ι e i fac,
    SimplexCategory.eq_id_of_isIso (image.iso_strong_epi_mono e i fac).Hom, category.id_comp]
#align simplex_category.image_ι_eq SimplexCategory.image_ι_eq

theorem factorThruImage_eq {Δ Δ'' : SimplexCategory} {φ : Δ ⟶ Δ''} {e : Δ ⟶ image φ} [Epi e]
    {i : image φ ⟶ Δ''} [Mono i] (fac : e ≫ i = φ) : factorThruImage φ = e := by
  rw [← cancel_mono i, fac, ← image_ι_eq fac, image.fac]
#align simplex_category.factor_thru_image_eq SimplexCategory.factorThruImage_eq

end EpiMono

/-- This functor `simplex_category ⥤ Cat` sends `[n]` (for `n : ℕ`)
to the category attached to the ordered set `{0, 1, ..., n}` -/
@[simps obj map]
def toCat : SimplexCategory ⥤ Cat.{0} :=
  SimplexCategory.skeletalFunctor ⋙
    forget₂ NonemptyFinLinOrdCat LinOrd ⋙
      forget₂ LinOrd Lat ⋙ forget₂ Lat PartOrd ⋙ forget₂ PartOrd Preord ⋙ preordToCat
#align simplex_category.to_Cat SimplexCategory.toCat

end SimplexCategory


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

import algebra.char_p.two
import algebra.ne_zero
import algebra.gcd_monoid.integrally_closed
import data.polynomial.ring_division
import field_theory.finite.basic
import field_theory.minpoly.is_integrally_closed
import field_theory.separable
import group_theory.specific_groups.cyclic
import number_theory.divisors
import ring_theory.integral_domain
import tactic.zify

/-!
# 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`.
* `is_primitive_root.aut_to_pow`: the monoid hom that takes an automorphism of a ring to the power
  it sends that specific primitive root, as a member of `(zmod n)ˣ`.

## Main results

* `roots_of_unity.is_cyclic`: the roots of unity in an integral domain form a cyclic group.
* `is_primitive_root.zmod_equiv_zpowers`: `zmod k` is equivalent to
  the subgroup generated by a primitive `k`-th root of unity.
* `is_primitive_root.zpowers_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 polynomial
noncomputable theory

open polynomial
open finset

variables {M N G R S F : Type*}
variables [comm_monoid M] [comm_monoid N] [division_comm_monoid G]

section roots_of_unity

variables {k l : ℕ+}

/-- `roots_of_unity k M` is the subgroup of elements `m : Mˣ` that satisfy `m ^ k = 1` -/
def roots_of_unity (k : ℕ+) (M : Type*) [comm_monoid M] : subgroup 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, inv_one] at * }

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

lemma mem_roots_of_unity' (k : ℕ+) (ζ : Mˣ) :
  ζ ∈ roots_of_unity k M ↔ (ζ : M) ^ (k : ℕ) = 1 :=
by { rw [mem_roots_of_unity], norm_cast }

lemma roots_of_unity.coe_injective {n : ℕ+} : function.injective (coe : (roots_of_unity n M) → M) :=
units.ext.comp (λ x y, subtype.ext)

/-- Make an element of `roots_of_unity` from a member of the base ring, and a proof that it has
a positive power equal to one. -/
@[simps coe_coe] def roots_of_unity.mk_of_pow_eq (ζ : M) {n : ℕ+} (h : ζ ^ (n : ℕ) = 1) :
  roots_of_unity n M :=
⟨units.of_pow_eq_one ζ n h n.ne_zero, units.pow_of_pow_eq_one _ _⟩

@[simp] lemma roots_of_unity.coe_mk_of_pow_eq {ζ : M} {n : ℕ+}
  (h : ζ ^ (n : ℕ) = 1) : (roots_of_unity.mk_of_pow_eq _ h : M) = ζ := 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 : Mˣ →* Nˣ) (k : ℕ+) :
  (roots_of_unity k M).map f ≤ roots_of_unity k N :=
begin
  rintros _ ⟨ζ, h, rfl⟩,
  simp only [←map_pow, *, mem_roots_of_unity, set_like.mem_coe, monoid_hom.map_one] at *
end

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

section comm_semiring

variables [comm_semiring R] [comm_semiring S]

/-- Restrict a ring homomorphism to the nth roots of unity -/
def restrict_roots_of_unity [ring_hom_class F R S] (σ : F) (n : ℕ+) :
  roots_of_unity n R →* roots_of_unity n S :=
let h : ∀ ξ : roots_of_unity n R, (σ ξ) ^ (n : ℕ) = 1 := λ ξ, by
{ change (σ (ξ : Rˣ)) ^ (n : ℕ) = 1,
  rw [←map_pow, ←units.coe_pow, show ((ξ : Rˣ) ^ (n : ℕ) = 1), from ξ.2,
      units.coe_one, map_one σ] } in
{ to_fun := λ ξ, ⟨@unit_of_invertible _ _ _ (invertible_of_pow_eq_one _ _ (h ξ) n.ne_zero),
    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 restrict_roots_of_unity_coe_apply [ring_hom_class F R S] (σ : F)
  (ζ : roots_of_unity k R) : ↑(restrict_roots_of_unity σ k ζ) = σ ↑ζ :=
rfl

/-- Restrict a ring isomorphism 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 := restrict_roots_of_unity σ.to_ring_hom n,
  inv_fun :=restrict_roots_of_unity σ.symm.to_ring_hom n,
  left_inv := λ ξ, by { ext, exact σ.symm_apply_apply ξ },
  right_inv := λ ξ, by { ext, exact σ.apply_symm_apply ξ },
  map_mul' := (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

end comm_semiring

section is_domain

variables [comm_ring R] [is_domain R]

lemma mem_roots_of_unity_iff_mem_nth_roots {ζ : 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,
      tsub_add_cancel_of_le (show 1 ≤ (k : ℕ), from k.one_le)] },
  { show (_ : 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_is_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.dedup_le _)
... = (nth_roots k (1 : R)).card                  : multiset.card_attach
... ≤ k                                           : card_nth_roots k 1

variables {k R}

lemma map_root_of_unity_eq_pow_self [ring_hom_class F R R] (σ : F) (ζ : roots_of_unity k R) :
  ∃ m : ℕ, σ ζ = ζ ^ m :=
begin
  obtain ⟨m, hm⟩ := monoid_hom.map_cyclic (restrict_roots_of_unity σ k),
  rw [←restrict_roots_of_unity_coe_apply, hm, zpow_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 ζ)))),
      zpow_coe_nat, roots_of_unity.coe_pow],
  exact ⟨(m % (order_of ζ)).to_nat, rfl⟩,
end

end is_domain

section reduced

variables (R) [comm_ring R] [is_reduced R]

@[simp] lemma mem_roots_of_unity_prime_pow_mul_iff (p k : ℕ) (m : ℕ+) [hp : fact p.prime]
  [char_p R p] {ζ : Rˣ} :
  ζ ∈ roots_of_unity (⟨p, hp.1.pos⟩ ^ k * m) R ↔ ζ ∈ roots_of_unity m R :=
by simp [mem_roots_of_unity']

end reduced

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)

/-- Turn a primitive root μ into a member of the `roots_of_unity` subgroup. -/
@[simps] def is_primitive_root.to_roots_of_unity {μ : M} {n : ℕ+} (h : is_primitive_root μ n) :
  roots_of_unity n M := roots_of_unity.mk_of_pow_eq μ h.pow_eq_one

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*) [comm_ring R] [is_domain R] : finset R :=
(nth_roots k (1 : R)).to_finset.filter (λ ζ, is_primitive_root ζ k)

variables [comm_ring R] [is_domain R]

@[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

@[simp] lemma primitive_roots_zero : primitive_roots 0 R = ∅ :=
by rw [primitive_roots, nth_roots_zero, multiset.to_finset_zero, finset.filter_empty]

lemma is_primitive_root_of_mem_primitive_roots {ζ : R} (h : ζ ∈ primitive_roots k R) :
  is_primitive_root ζ k :=
k.eq_zero_or_pos.elim (λ hk, false.elim $ by simpa [hk] using h)
  (λ hk, (mem_primitive_roots hk).1 h)

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, λ l hl, _⟩,
  suffices : k.gcd l = k, { exact this ▸ k.gcd_dvd_right l },
  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} {f : F} (h : is_primitive_root ζ k)

@[nontriviality] lemma of_subsingleton [subsingleton M] (x : M) : is_primitive_root x 1 :=
⟨subsingleton.elim _ _, λ _ _, one_dvd _⟩

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, tsub_add_cancel_of_le h0.nat_succ_le, 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 ne_one (hk : 1 < k) : ζ ≠ 1 :=
h.pow_ne_one_of_pos_of_lt zero_lt_one hk ∘ (pow_one ζ).trans

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 generalizing i j,
  { exact (this hj hi H.symm (le_of_not_le hij)).symm },
  apply le_antisymm hij,
  rw ← tsub_eq_zero_iff_le,
  apply nat.eq_zero_of_dvd_of_lt _ (lt_of_le_of_lt tsub_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, tsub_add_cancel_of_le 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_submonoid_class_iff {M B : Type*} [comm_monoid M] [set_like B M]
  [submonoid_class B M] {N : B} {ζ : N} : is_primitive_root (ζ : M) k ↔ is_primitive_root ζ k :=
by simp [iff_def, ← submonoid_class.coe_pow]

@[simp] lemma coe_units_iff {ζ : 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 ζ, ← zpow_coe_nat ζ, ← hi.gcd_eq_one, nat.gcd_eq_gcd_ab, zpow_add,
      mul_pow, ← zpow_coe_nat, ← zpow_mul, mul_right_comm],
  simp only [zpow_mul, hl, h.pow_eq_one, one_zpow, one_pow, one_mul, zpow_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, mul_left_inj' h0.ne', 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

protected lemma order_of (ζ : M) : is_primitive_root ζ (order_of ζ) :=
⟨pow_order_of_eq_one ζ, λ l, order_of_dvd_of_pow_eq_one⟩

lemma unique {ζ : M} (hk : is_primitive_root ζ k) (hl : is_primitive_root ζ l) : k = l :=
nat.dvd_antisymm (hk.2 _ hl.1) (hl.2 _ hk.1)

lemma eq_order_of : k = order_of ζ := h.unique (is_primitive_root.order_of ζ)

protected lemma iff (hk : 0 < k) :
  is_primitive_root ζ k ↔ ζ ^ k = 1 ∧ ∀ l : ℕ, 0 < l → l < k → ζ ^ l ≠ 1 :=
begin
  refine ⟨λ h, ⟨h.pow_eq_one, λ l hl' hl, _⟩, λ ⟨hζ, hl⟩, is_primitive_root.mk_of_lt ζ hk hζ hl⟩,
  rw h.eq_order_of at hl,
  exact pow_ne_one_of_lt_order_of' hl'.ne' hl,
end

protected lemma not_iff : ¬ is_primitive_root ζ k ↔ order_of ζ ≠ k :=
⟨λ h hk, h $ hk ▸ is_primitive_root.order_of ζ,
 λ h hk, h.symm $ hk.unique $ is_primitive_root.order_of ζ⟩

lemma pow_of_dvd (h : is_primitive_root ζ k) {p : ℕ} (hp : p ≠ 0) (hdiv : p ∣ k) :
  is_primitive_root (ζ ^ p) (k / p) :=
begin
  suffices : order_of (ζ ^ p) = k / p,
  { exact this ▸ is_primitive_root.order_of (ζ ^ p) },
  rw [order_of_pow' _ hp, ← eq_order_of h, nat.gcd_eq_right hdiv]
end

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

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

section maps

open function

lemma map_of_injective [monoid_hom_class F M N] (h : is_primitive_root ζ k) (hf : injective f) :
  is_primitive_root (f ζ) k :=
{ pow_eq_one := by rw [←map_pow, h.pow_eq_one, _root_.map_one],
  dvd_of_pow_eq_one := begin
    rw h.eq_order_of,
    intros l hl,
    rw [←map_pow, ←map_one f] at hl,
    exact order_of_dvd_of_pow_eq_one (hf hl)
  end }

lemma of_map_of_injective [monoid_hom_class F M N] (h : is_primitive_root (f ζ) k)
  (hf : injective f) : is_primitive_root ζ k :=
{ pow_eq_one := by { apply_fun f, rw [map_pow, _root_.map_one, h.pow_eq_one] },
  dvd_of_pow_eq_one := begin
    rw h.eq_order_of,
    intros l hl,
    apply_fun f at hl,
    rw [map_pow, _root_.map_one] at hl,
    exact order_of_dvd_of_pow_eq_one hl
  end }

lemma map_iff_of_injective [monoid_hom_class F M N] (hf : injective f) :
  is_primitive_root (f ζ) k ↔ is_primitive_root ζ k :=
⟨λ h, h.of_map_of_injective hf, λ h, h.map_of_injective hf⟩

end maps

end comm_monoid

section comm_monoid_with_zero

variables {M₀ : Type*} [comm_monoid_with_zero M₀]

lemma zero [nontrivial M₀] : is_primitive_root (0 : M₀) 0 :=
⟨pow_zero 0, λ l hl, by simpa [zero_pow_eq, show ∀ p, ¬p → false ↔ p, from @not_not] using hl⟩

protected lemma ne_zero [nontrivial M₀] {ζ : M₀} (h : is_primitive_root ζ k) : k ≠ 0 → ζ ≠ 0 :=
mt $ λ hn, h.unique (hn.symm ▸ is_primitive_root.zero)

end comm_monoid_with_zero

section division_comm_monoid

variables {ζ : G}

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

lemma zpow_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 [zpow_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, ← zpow_neg, ← hl', zpow_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 zpow_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 zpow_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, ← zpow_neg, ← hi', zpow_coe_nat],
  apply h.pow_of_coprime,
  rw [int.gcd, ← int.nat_abs_neg, ← hi'] at hi,
  exact hi
end

end division_comm_monoid

section is_domain

variables {ζ : R}
variables [comm_ring R] [is_domain R]

@[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 ne_zero' {n : ℕ+} (hζ : is_primitive_root ζ n) : ne_zero ((n : ℕ) : R) :=
begin
  let p := ring_char R,
  have hfin := (multiplicity.finite_nat_iff.2 ⟨char_p.char_ne_one R p, n.pos⟩),
  obtain ⟨m, hm⟩ := multiplicity.exists_eq_pow_mul_and_not_dvd hfin,
  by_cases hp : p ∣ n,
  { obtain ⟨k, hk⟩ := nat.exists_eq_succ_of_ne_zero (multiplicity.pos_of_dvd hfin hp).ne',
    haveI : ne_zero p := ne_zero.of_pos (nat.pos_of_dvd_of_pos hp n.pos),
    haveI hpri : fact p.prime := char_p.char_is_prime_of_pos R p,
    have := hζ.pow_eq_one,
    rw [hm.1, hk, pow_succ, mul_assoc, pow_mul', ← frobenius_def, ← frobenius_one p] at this,
    exfalso,
    have hpos : 0 < p ^ k * m,
    { refine (mul_pos (pow_pos hpri.1.pos _) (nat.pos_of_ne_zero (λ h, _))),
      have H := hm.1,
      rw [h] at H,
      simpa using H },
    refine hζ.pow_ne_one_of_pos_of_lt hpos _ (frobenius_inj R p this),
    { rw [hm.1, hk, pow_succ, mul_assoc, mul_comm p],
      exact lt_mul_of_one_lt_right hpos hpri.1.one_lt } },
  { exact ne_zero.of_not_dvd R hp }
end

lemma mem_nth_roots_finset (hζ : is_primitive_root ζ k) (hk : 0 < k) :
  ζ ∈ nth_roots_finset k R :=
(mem_nth_roots_finset hk).2 hζ.pow_eq_one

end is_domain

section is_domain

variables [comm_ring R]
variables {ζ : Rˣ} (h : is_primitive_root ζ k)

lemma eq_neg_one_of_two_right [no_zero_divisors R] {ζ : R} (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

lemma neg_one (p : ℕ) [nontrivial R] [h : char_p R p] (hp : p ≠ 2) : is_primitive_root (-1 : R) 2 :=
begin
  convert is_primitive_root.order_of (-1 : R),
  rw [order_of_neg_one, if_neg],
  rwa ring_char.eq_iff.mpr h
end

/-- If `1 < k` then `(∑ i in range k, ζ ^ i) = 0`. -/
lemma geom_sum_eq_zero [is_domain R] {ζ : R} (hζ : is_primitive_root ζ k) (hk : 1 < k) :
  (∑ i in range k, ζ ^ i) = 0 :=
begin
  refine eq_zero_of_ne_zero_of_mul_left_eq_zero (sub_ne_zero_of_ne (hζ.ne_one hk).symm) _,
  rw [mul_neg_geom_sum, hζ.pow_eq_one, sub_self]
end

/-- If `1 < k`, then `ζ ^ k.pred = -(∑ i in range k.pred, ζ ^ i)`. -/

/-- The (additive) monoid equivalence between `zmod k`
and the powers of a primitive root of unity `ζ`. -/
def zmod_equiv_zpowers (h : is_primitive_root ζ k) : zmod k ≃+ additive (subgroup.zpowers ζ) :=
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.zpowers ζ),
      map_zero' := by { simp only [zpow_zero], refl },
      map_add' := by { intros i j, simp only [zpow_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 [zpow_mul, h.pow_eq_one, one_zpow, zpow_coe_nat],
      refl
    end)⟩)
  begin
    split,
    { rw injective_iff_map_eq_zero,
      intros i hi,
      rw subtype.ext_iff at hi,
      have := (h.zpow_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_zpowers_apply_coe_int (i : ℤ) :
  h.zmod_equiv_zpowers i = additive.of_mul (⟨ζ ^ i, i, rfl⟩ : subgroup.zpowers ζ) :=
add_monoid_hom.lift_of_right_inverse_comp_apply _ _ zmod.int_cast_right_inverse _ _

@[simp] lemma zmod_equiv_zpowers_apply_coe_nat (i : ℕ) :
  h.zmod_equiv_zpowers i = additive.of_mul (⟨ζ ^ i, i, rfl⟩ : subgroup.zpowers ζ) :=
begin
  have : (i : zmod k) = (i : ℤ), by norm_cast,
  simp only [this, zmod_equiv_zpowers_apply_coe_int, zpow_coe_nat],
  refl
end

@[simp] lemma zmod_equiv_zpowers_symm_apply_zpow (i : ℤ) :
  h.zmod_equiv_zpowers.symm (additive.of_mul (⟨ζ ^ i, i, rfl⟩ : subgroup.zpowers ζ)) = i :=
by rw [← h.zmod_equiv_zpowers.symm_apply_apply i, zmod_equiv_zpowers_apply_coe_int]

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

@[simp] lemma zmod_equiv_zpowers_symm_apply_pow (i : ℕ) :
  h.zmod_equiv_zpowers.symm (additive.of_mul (⟨ζ ^ i, i, rfl⟩ : subgroup.zpowers ζ)) = i :=
by rw [← h.zmod_equiv_zpowers.symm_apply_apply i, zmod_equiv_zpowers_apply_coe_nat]

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

variables [is_domain R]

lemma zpowers_eq {k : ℕ+} {ζ : Rˣ} (h : is_primitive_root ζ k) :
  subgroup.zpowers ζ = roots_of_unity k R :=
begin
  apply set_like.coe_injective,
  haveI F : fintype (subgroup.zpowers ζ) := fintype.of_equiv _ (h.zmod_equiv_zpowers).to_equiv,
  refine @set.eq_of_subset_of_card_le Rˣ (subgroup.zpowers ζ) (roots_of_unity k R)
    F (roots_of_unity.fintype R k)
    (subgroup.zpowers_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.zpowers ζ) : fintype.card_congr (h.zmod_equiv_zpowers).to_equiv
end

lemma eq_pow_of_mem_roots_of_unity {k : ℕ+} {ζ ξ : 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.zpowers_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.zpow_eq_one, rw [← coe_coe] at aux,
    rw [← zpow_coe_nat, hi₀, ← int.mod_add_div n k, zpow_add, zpow_mul,
        aux, one_zpow, 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
  lift ζ to Rˣ using h.is_unit h0,
  lift ξ to Rˣ using is_unit_of_pow_eq_one hξ h0.ne',
  lift k to ℕ+ using h0,
  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 : ℕ+} {ζ ξ : 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
  let e := h.zmod_equiv_zpowers,
  haveI F : fintype (subgroup.zpowers ζ) := fintype.of_equiv _ e.to_equiv,
  calc fintype.card (roots_of_unity n R)
      = fintype.card (subgroup.zpowers ζ) : fintype.card_congr $ by rw h.zpowers_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.dedup_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.dedup_eq_self R _ _).1,
  rw eq_iff_le_not_lt,
  split,
  { exact multiset.dedup_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)).dedup.card =
      fintype.card {x // x ∈ (nth_roots n (1 : R))},
    { set fs := (⟨(nth_roots n (1 : R)).dedup, multiset.nodup_dedup _⟩ : finset R),
      rw [← finset.card_mk, ← fintype.card_of_subtype fs _],
      intro x,
      simp only [multiset.mem_dedup, 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) :
  (primitive_roots k R).card = φ k :=
begin
  by_cases h0 : k = 0,
  { simp [h0], },
  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 (nat.pos_of_ne_zero 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 (nat.pos_of_ne_zero h0),
      h.is_primitive_root_iff (nat.pos_of_ne_zero 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 : ℕ} (h : k ≠ l) :
  disjoint (primitive_roots k R) (primitive_roots l R) :=
finset.disjoint_left.2 $ λ z hk hl, h $ (is_primitive_root_of_mem_primitive_roots hk).unique $
  is_primitive_root_of_mem_primitive_roots hl

/-- `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`.
This holds for any `nat`, not just `pnat`, see `nth_roots_one_eq_bUnion_primitive_roots`. -/
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],
    { nth_rewrite_lhs 0 ← nat.sum_totient n,
      refine sum_congr rfl _,
      simp only [nat.mem_divisors],
      rintro k ⟨⟨d, hd⟩, -⟩,
      rw mul_comm at hd,
      rw (h.pow n.pos hd).card_primitive_roots },
    { intros i hi j hj hdiff,
      exact disjoint 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 : ℕ}
  (h : is_primitive_root ζ n) :
  nth_roots_finset n R = (nat.divisors n).bUnion (λ i, (primitive_roots i R)) :=
begin
  by_cases hn : n = 0,
  { simp [hn], },
  exact @nth_roots_one_eq_bUnion_primitive_roots' _ _ _ _ ⟨n, nat.pos_of_ne_zero hn⟩ h
end

end is_domain

section minpoly

open minpoly

section comm_ring
variables {n : ℕ} {K : Type*} [comm_ring 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

section is_domain

variables [is_domain K] [char_zero K]

omit hpos

/--The minimal polynomial of a root of unity `μ` divides `X ^ n - 1`. -/
lemma minpoly_dvd_X_pow_sub_one : minpoly ℤ μ ∣ X ^ n - 1 :=
begin
  rcases n.eq_zero_or_pos with rfl | hpos,
  { simp },
  letI : is_integrally_closed ℤ := gcd_monoid.to_is_integrally_closed,
  apply minpoly.is_integrally_closed_dvd (is_integral h hpos),
  simp only [((is_primitive_root.iff_def μ n).mp h).left, aeval_X_pow, 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 [polynomial.map_pow, map_X, polynomial.map_one, polynomial.map_sub] using
      ring_hom.map_dvd (map_ring_hom (int.cast_ring_hom (zmod p)))
        (minpoly_dvd_X_pow_sub_one h) },
  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 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 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 natural number that does not divide `n`. Then `P` divides `expand ℤ p Q`. -/
lemma minpoly_dvd_expand {p : ℕ} (hdiv : ¬ p ∣ n) : minpoly ℤ μ ∣ expand ℤ p (minpoly ℤ (μ ^ p)) :=
begin
  rcases n.eq_zero_or_pos with rfl | hpos,
  { simp * at *, },
  letI : is_integrally_closed ℤ := gcd_monoid.to_is_integrally_closed,
  refine minpoly.is_integrally_closed_dvd (h.is_integral hpos) _,
  { rw [aeval_def, coe_expand, ← comp, eval₂_eq_eval_map, map_comp, polynomial.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],
  rw [hfrob],
  apply ring_hom.map_dvd (map_ring_hom (int.cast_ring_hom (zmod p))),
  exact minpoly_dvd_expand h 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
  hdiv) hprime.1.ne_zero).1 (minpoly_dvd_pow_mod h 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_cases hn : n = 0, { simp * at *, },
  have hpos := nat.pos_of_ne_zero hn,
  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), polynomial.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 (Pirr.dvd_symm Qirr hdiv) },
    { apply (map_dvd_map (int.cast_ring_hom ℚ) int.cast_injective Pmonic).2,
      exact minpoly_dvd_X_pow_sub_one h },
    { 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) } },
  replace prod := ring_hom.map_dvd ((map_ring_hom (int.cast_ring_hom (zmod p)))) prod,
  rw [coe_map_ring_hom, polynomial.map_mul, polynomial.map_sub,
      polynomial.map_one, polynomial.map_pow, map_X] at prod,
  obtain ⟨R, hR⟩ := minpoly_dvd_mod_p h hdiv,
  rw [hR, ← mul_assoc, ← polynomial.map_mul, ← sq, polynomial.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 (part_enat.coe_lt_coe.2 one_lt_two)
    (multiplicity.le_multiplicity_of_pow_dvd (dvd_trans habs prod)),
  have hfree : squarefree (X ^ n - 1 : (zmod p)[X]),
  { exact (separable_X_pow_sub_C 1
          (λ h, hdiv $ (zmod.nat_coe_zmod_eq_zero_iff_dvd n p).1 h) one_ne_zero).squarefree },
  cases (multiplicity.squarefree_iff_multiplicity_le_one (X ^ n - 1)).1 hfree
    (map (int.cast_ring_hom (zmod p)) P) with hle hunit,
  { rw nat.cast_one at habs, exact hle.not_lt habs },
  { replace hunit := degree_eq_zero_of_is_unit hunit,
    rw degree_map_eq_of_leading_coeff_ne_zero (int.cast_ring_hom (zmod p)) _ at hunit,
    { exact (minpoly.degree_pos (is_integral h hpos)).ne' hunit },
    simp only [Pmonic, 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,
    congr,
    simpa [(nat.coprime_zero_left n).mp hn] using h },
  { intros u hunit n hcop h,
    congr,
    simp [nat.is_unit_iff.mp hunit] },
  { intros a p ha hprime hind n hcop h,
    rw hind (nat.coprime.coprime_mul_left hcop) h, clear hind,
    replace hprime := hprime.nat_prime,
    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)) 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 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
  by_cases hn : n = 0, { simp * at *, },
  have hpos := nat.pos_of_ne_zero hn,
  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 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 : ℤ[X] := minpoly ℤ μ,-- minimal polynomial of `μ`
    P_K : K[X] := 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.symm
... ≤ P_K.roots.to_finset.card : finset.card_le_of_subset (is_roots_of_minpoly h)
... ≤ P_K.roots.card : multiset.to_finset_card_le _
... ≤ P_K.nat_degree : card_roots' _
... ≤ P.nat_degree : nat_degree_map_le _ _

end is_domain

end comm_ring

end minpoly

section automorphisms

variables {S} [comm_ring S] [is_domain S] {μ : S} {n : ℕ+} (hμ : is_primitive_root μ n)
          (R) [comm_ring R] [algebra R S]

/-- The `monoid_hom` that takes an automorphism to the power of μ that μ gets mapped to under it. -/
noncomputable def aut_to_pow : (S ≃ₐ[R] S) →* (zmod n)ˣ :=
let μ' := hμ.to_roots_of_unity in
have ho : order_of μ' = n :=
  by rw [hμ.eq_order_of, ←hμ.coe_to_roots_of_unity_coe, order_of_units, order_of_subgroup],
monoid_hom.to_hom_units
{ to_fun := λ σ, (map_root_of_unity_eq_pow_self σ.to_alg_hom μ').some,
  map_one' := begin
    generalize_proofs h1,
    have h := h1.some_spec,
    dsimp only [alg_equiv.one_apply, alg_equiv.to_ring_equiv_eq_coe, ring_equiv.to_ring_hom_eq_coe,
                ring_equiv.coe_to_ring_hom, alg_equiv.coe_ring_equiv] at *,
    replace h : μ' = μ' ^ h1.some := roots_of_unity.coe_injective
                 (by simpa only [roots_of_unity.coe_pow] using h),
    rw ←pow_one μ' at h {occs := occurrences.pos [1]},
    rw [←@nat.cast_one $ zmod n, zmod.nat_coe_eq_nat_coe_iff, ←ho, ←pow_eq_pow_iff_modeq μ', h]
  end,
  map_mul' := begin
    generalize_proofs hxy' hx' hy',
    have hxy := hxy'.some_spec,
    have hx := hx'.some_spec,
    have hy := hy'.some_spec,
    dsimp only [alg_equiv.to_ring_equiv_eq_coe, ring_equiv.to_ring_hom_eq_coe,
                ring_equiv.coe_to_ring_hom, alg_equiv.coe_ring_equiv, alg_equiv.mul_apply] at *,
    replace hxy : x (↑μ' ^ hy'.some) = ↑μ' ^ hxy'.some := hy ▸ hxy,
    rw x.map_pow at hxy,
    replace hxy : ((μ' : S) ^ hx'.some) ^ hy'.some = μ' ^ hxy'.some := hx ▸ hxy,
    rw ←pow_mul at hxy,
    replace hxy : μ' ^ (hx'.some * hy'.some) = μ' ^ hxy'.some := roots_of_unity.coe_injective
                                           (by simpa only [roots_of_unity.coe_pow] using hxy),
    rw [←nat.cast_mul, zmod.nat_coe_eq_nat_coe_iff, ←ho, ←pow_eq_pow_iff_modeq μ', hxy]
  end }

-- We are not using @[simps] in aut_to_pow to avoid a timeout.
lemma coe_aut_to_pow_apply (f : S ≃ₐ[R] S) : (aut_to_pow R hμ f : zmod n) =
  ((map_root_of_unity_eq_pow_self f hμ.to_roots_of_unity).some : zmod n) := rfl

@[simp] lemma aut_to_pow_spec (f : S ≃ₐ[R] S) :
  μ ^ (hμ.aut_to_pow R f : zmod n).val = f μ :=
begin
  rw is_primitive_root.coe_aut_to_pow_apply,
  generalize_proofs h,
  have := h.some_spec,
  dsimp only [alg_equiv.to_alg_hom_eq_coe, alg_equiv.coe_alg_hom] at this,
  refine (_ : ↑hμ.to_roots_of_unity ^ _ = _).trans this.symm,
  rw [←roots_of_unity.coe_pow, ←roots_of_unity.coe_pow],
  congr' 1,
  rw [pow_eq_pow_iff_modeq, ←order_of_subgroup, ←order_of_units, hμ.coe_to_roots_of_unity_coe,
      ←hμ.eq_order_of, zmod.val_nat_cast],
  exact nat.mod_modeq _ _
end

end automorphisms

end is_primitive_root


import data.polynomial.basic
import topology.metric_space.basic
import data.polynomial.eval
import data.mv_polynomial.basic
import data.real.basic
import topology.basic
import data.polynomial.ring_division
import topology.instances.real
import data.set.prod
import mv_poly_partials

open_locale polynomial classical

lemma finset_has_min_dif (S : set ℝ) (hS : S.finite) : ∃ ε : ℝ, ε > 0 ∧ ∀ x y : ℝ, x ∈ S → y ∈ S → y ≠ x → |x - y| > ε :=
begin
  by_cases S.nonempty,
  let f : (ℝ × ℝ) → ℝ := λ xy, if xy.1 = xy.2 then 1 else |xy.1 - xy.2|,
  have hf : ∀ x y : ℝ, f (x, y) ≠ 0 :=
  begin
    intros x y,
    simp only [f],
    rw ne,
    rw ite_eq_iff,
    simp only [abs_eq_zero, false_or, not_and, one_ne_zero, and_false],
    intros h1 h2,
    rw sub_eq_zero at h2,
    exact h1 h2,
  end,

  have hf' : ∀ x y : ℝ, f(x, y) ≥ 0 :=
  begin
    simp only [f],
    intros x y,
    split_ifs,
    simp only [zero_le_one, ge_iff_le],
    exact abs_nonneg _,
  end,

  let diffs₂ := f '' (S ×ˢ S),
  have hdiffs₂ : diffs₂.finite := set.finite.image f (set.finite.prod hS hS),
  have : set.nonempty (S ×ˢ S):=
  begin
    rw set.prod_nonempty_iff,
    exact ⟨h, h⟩,
  end,
  have h'diffs₂ : hdiffs₂.to_finset.nonempty :=
  begin
    simp only [set.nonempty_image_iff, set.finite.to_finset.nonempty],
    exact this,
  end,

  have : (0 : ℝ) ∉ diffs₂ :=
  begin
    by_contra,
    rw set.mem_image at h,
    choose x hx using h,
    exact hf x.1 x.2 hx.2,
  end,

  have : ∀ x : ℝ, x ∈ diffs₂ → 0 < x :=
  begin
    intros x hx,
    rw set.mem_image at hx,
    choose a ha using hx,
    rw ← ha.2,
    apply lt_of_le_of_ne,
    exact hf' _ _,
    exact (hf _ _).symm,
  end,

  let δ := hdiffs₂.to_finset.min' h'diffs₂,
  have hδ : δ ∈ diffs₂ :=
  begin
    have : δ ∈ hdiffs₂.to_finset := finset.min'_mem hdiffs₂.to_finset _,
    rw set.finite.mem_to_finset at this,
    exact this,
  end,

  have hδ' : 0 < δ := this δ hδ,
  use δ / 2,
  split,
  linarith,
  intros x y hx hy hxy,
  have : | x - y | = f (x,y) :=
  begin
    simp only [f],
    split_ifs,
    by_contra,
    simp at h_1,
    exact hxy h_1.symm,
    simp only [eq_self_iff_true],
  end,
  rw this,
  have : f (x,y) ∈ diffs₂ :=
  begin
    simp only [set.mem_image, prod.exists],
    use x,
    use y,
    simp only [and_true, eq_self_iff_true, set.prod_mk_mem_set_prod_eq],
    exact ⟨hx, hy⟩,
  end,
  have : δ ≤ f(x ,y) :=
  begin
    apply finset.min'_le _ _ _,
    rw set.finite.mem_to_finset,
    exact this,
  end,
  linarith,
  use 1,
  simp only [true_and, gt_iff_lt, zero_lt_one],
  intros x y hx hy hxy,
  by_contra h',
  have : S = ∅ :=
  begin
    rw ← set.not_nonempty_iff_eq_empty,
    exact h,
  end,
  rw this at hx,
  rw set.mem_empty_eq at hx,
  exact hx,
end

lemma compl_finset_dense_in_R (S : finset ℝ) : dense (↑S : set ℝ)ᶜ :=
begin
  rw dense,
  intro x,
  rw real.mem_closure_iff,
  intros ε hε,
  by_cases hx : x ∈ S,
  have := finset_has_min_dif ↑S S.finite_to_set,
  choose δ hδ using this,
  by_cases δ < ε,
  use x + δ,
  split,
  simp only [set.mem_compl_eq, finset.mem_coe],
  intro hxδ,
  have foo : x + δ ≠ x :=
  begin
    simp only [add_right_eq_self, ne.def],
    exact ne_of_gt hδ.1,
  end,
  have := hδ.2 x (x + δ) hx hxδ foo,
  simp only [gt_iff_lt, sub_add_cancel', abs_neg] at this,
  rw abs_of_pos hδ.1 at this,
  linarith,
  simp only [add_tsub_cancel_left],
  rw abs_of_pos hδ.1,
  exact h,
  use x + ε / 2,
  split,
  rw not_lt at h,
  simp only [set.mem_compl_eq, finset.mem_coe],
  intro hxε,
  have foo : x + ε / 2 ≠ x :=
  begin
    linarith,
  end,
  have := hδ.2 x (x + ε/2) hx hxε foo,
  simp only [gt_iff_lt, sub_add_cancel', abs_neg] at this,
  have hε' : ε / 2 > 0 :=
  begin
    apply div_pos,
    exact hε,
    simp only [zero_lt_bit0, zero_lt_one],
  end,
  rw abs_of_pos hε' at this,
  linarith,
  simp only [add_tsub_cancel_left],
  have hε' : ε / 2 > 0 :=
  begin
    apply div_pos,
    exact hε,
    simp only [zero_lt_bit0, zero_lt_one],
  end,
  rw abs_of_pos hε',
  linarith,
  use x,
  simp only [abs_zero, set.mem_compl_eq, finset.mem_coe, sub_self],
  exact ⟨ hx, hε ⟩,
end

lemma poly_nonzero_dense {σ : Type*} {p : ℝ[X]} (hp : p ≠ 0) :
  dense {x : ℝ | polynomial.eval x p ≠ 0} :=
begin
  simp_rw ne,
  simp_rw ← polynomial.is_root.def,
  have fact₁ : ↑(polynomial.roots p).to_finset = {x : ℝ | p.is_root x} :=
  begin
    ext,
    simp only [multiset.mem_to_finset, set.mem_set_of_eq, finset.mem_coe],
    rw polynomial.mem_roots,
    exact hp,
  end,
  have fact₂ : {x : ℝ | ¬ p.is_root x} = {x : ℝ | p.is_root x}.compl :=
  begin
    ext,
    simp only [set.compl_eq_compl, iff_self, set.mem_set_of_eq, set.mem_compl_eq],
  end,
  rw fact₂,
  rw ← fact₁,
  -- simp [set.compl_eq_univ_diff],
  -- exact dense.diff_finset (dense_univ) _,
  exact compl_finset_dense_in_R _,
end

lemma poly_in_ball_eq_zero_eq_zero {σ : Type*} (r : ℝ)
  [fintype σ]
  {p : mv_polynomial σ ℝ}
  (hp : p ≠ 0)
  (H : r > 0)
  (h : ¬(metric.ball (0 : σ → ℝ) r ∩
            {y : σ → ℝ | (mv_polynomial.eval y) p ≠ 0}).nonempty) :
  p = 0 :=
begin
  rw ← mv_poly_along_line_eq_zero_iff_mv_poly_eq_zero p,
  by_contra h1,
  simp only [not_forall] at h1,
  choose y hy using h1,
  have dense_nonzero_y := @poly_nonzero_dense σ _ hy,
  by_cases hy' : y = 0,
  simp_rw [eval_along_line_eq_eval, hy', smul_zero] at dense_nonzero_y,
  rw [set.nonempty, not_exists] at h,
  specialize h y,
  rw hy' at h,
  simp only [norm_zero, set.mem_inter_eq, not_and, mem_ball_zero_iff, set.mem_set_of_eq] at h,
  specialize h H,
  rw not_ne_iff at h,
  rw [h] at dense_nonzero_y,
  simp [set.set_of_false] at dense_nonzero_y,
  rw [dense, closure_empty] at dense_nonzero_y,
  specialize dense_nonzero_y 0,
  rw set.mem_empty_eq at dense_nonzero_y,
  exact dense_nonzero_y,

  have : ∀ t : ℝ, |t| * ∥ y ∥ < r → (mv_poly_along_line p y).eval t = 0 :=
  begin
    intros t ht,
    rw eval_along_line_eq_eval,
    have : t • y ∈ metric.ball (0 : σ → ℝ) r :=
    begin
      rw mem_ball_zero_iff,
      rw norm_smul,
      rw real.norm_eq_abs,
      exact ht,
    end,
    rw set.nonempty at h,
    rw not_exists at h,
    specialize h (t • y),
    simp only [set.mem_inter_eq, not_and, set.mem_set_of_eq] at h,
    rw not_ne_iff at h,
    exact h this,
  end,
  rw dense at dense_nonzero_y,
  simp_rw real.mem_closure_iff at dense_nonzero_y,
  specialize dense_nonzero_y 0 (r / ∥ y ∥) (by {ring, apply mul_pos, simp only [norm_pos_iff, ne.def, inv_pos], exact hy', exact H}),
  choose t' ht' using dense_nonzero_y,
  simp only [sub_zero, set.mem_set_of_eq] at ht',
  specialize this t' (by {rw ← lt_div_iff, exact ht'.2, simp only [norm_pos_iff, ne.def, hy', not_false_iff],}), --ht'.2,
  exact ht'.1 this,
end

lemma mvpoly_nonzero_dense {σ : Type*} [fintype σ] {p : mv_polynomial σ ℝ} (hp : p ≠ 0) :
  dense {x : σ → ℝ | mv_polynomial.eval x p ≠ 0} :=
begin
  rw metric.dense_iff,
  intros,
  by_contra,
  have : ¬ (metric.ball (0 : σ → ℝ) r ∩ {y : σ → ℝ | (mv_polynomial.eval y) (p.recenter (-x)) ≠ (0 : ℝ)}).nonempty :=
  begin
    rw [set.nonempty, not_exists],
    rw [set.nonempty, not_exists] at h,
    intro y,
    simp only [set.mem_inter_eq, not_and, mem_ball_zero_iff, set.mem_set_of_eq],
    intro hy,
    rw mv_polynomial.recenter_eval,
    simp only [not_not, ne.def, sub_neg_eq_add],
    specialize h (y + x),
    simp only [metric.mem_ball, set.mem_inter_eq, not_and, set.mem_set_of_eq] at h,
    rw dist_eq_norm at h,

    simp only [not_not, ne.def] at h,
    apply h,
    simp only [add_sub_cancel],
    exact hy,
  end,
  have hp' := poly_in_ball_eq_zero_eq_zero r _ H this,
  rw mv_polynomial.eq_zero_iff_recenter_eq_zero at hp',
  exact hp hp',
  intro hp',
  rw mv_polynomial.eq_zero_iff_recenter_eq_zero at hp',
  exact hp hp',

end