/-
Copyright (c) 2020 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Anne Baanen
-/

import algebra.algebra.subalgebra.basic
import algebra.algebra.tower

/-!
# Subalgebras in towers of algebras

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

In this file we prove facts about subalgebras in towers of algebra.

An algebra tower A/S/R is expressed by having instances of `algebra A S`,
`algebra R S`, `algebra R A` and `is_scalar_tower R S A`, the later asserting the
compatibility condition `(r • s) • a = r • (s • a)`.

## Main results

 * `is_scalar_tower.subalgebra`: if `A/S/R` is a tower and `S₀` is a subalgebra
   between `S` and `R`, then `A/S/S₀` is a tower
 * `is_scalar_tower.subalgebra'`: if `A/S/R` is a tower and `S₀` is a subalgebra
   between `S` and `R`, then `A/S₀/R` is a tower
 * `subalgebra.restrict_scalars`: turn an `S`-subalgebra of `A` into an `R`-subalgebra of `A`,
   given that `A/S/R` is a tower

-/

open_locale pointwise
universes u v w u₁ v₁

variables (R : Type u) (S : Type v) (A : Type w) (B : Type u₁) (M : Type v₁)

namespace algebra

variables [comm_semiring R] [semiring A] [algebra R A]
variables [add_comm_monoid M] [module R M] [module A M] [is_scalar_tower R A M]

variables {A}

lemma lmul_algebra_map (x : R) :
  algebra.lmul R A (algebra_map R A x) = algebra.lsmul R A x :=
eq.symm $ linear_map.ext $ smul_def x

end algebra

namespace is_scalar_tower

section semiring
variables [comm_semiring R] [comm_semiring S] [semiring A]
variables [algebra R S] [algebra S A]

variables (R S A)

instance subalgebra (S₀ : subalgebra R S) : is_scalar_tower S₀ S A :=
of_algebra_map_eq $ λ x, rfl

variables [algebra R A] [is_scalar_tower R S A]

instance subalgebra' (S₀ : subalgebra R S) : is_scalar_tower R S₀ A :=
@is_scalar_tower.of_algebra_map_eq R S₀ A _ _ _ _ _ _ $ λ _,
(is_scalar_tower.algebra_map_apply R S A _ : _)

end semiring

end is_scalar_tower

namespace subalgebra

open is_scalar_tower

section semiring

variables (R) {S A B} [comm_semiring R] [comm_semiring S] [semiring A] [semiring B]
variables [algebra R S] [algebra S A] [algebra R A] [algebra S B] [algebra R B]
variables [is_scalar_tower R S A] [is_scalar_tower R S B]

/-- Given a tower `A / ↥U / S / R` of algebras, where `U` is an `S`-subalgebra of `A`, reinterpret
`U` as an `R`-subalgebra of `A`. -/
def restrict_scalars (U : subalgebra S A) : subalgebra R A :=
{ algebra_map_mem' := λ x, by { rw algebra_map_apply R S A, exact U.algebra_map_mem _ },
  .. U }

@[simp] lemma coe_restrict_scalars {U : subalgebra S A} :
  (restrict_scalars R U : set A) = (U : set A) := rfl

@[simp] lemma restrict_scalars_top : restrict_scalars R (⊤ : subalgebra S A) = ⊤ :=
set_like.coe_injective rfl

@[simp] lemma restrict_scalars_to_submodule {U : subalgebra S A} :
  (U.restrict_scalars R).to_submodule = U.to_submodule.restrict_scalars R :=
set_like.coe_injective rfl

@[simp] lemma mem_restrict_scalars {U : subalgebra S A} {x : A} :
  x ∈ restrict_scalars R U ↔ x ∈ U := iff.rfl

lemma restrict_scalars_injective :
  function.injective (restrict_scalars R : subalgebra S A → subalgebra R A) :=
λ U V H, ext $ λ x, by rw [← mem_restrict_scalars R, H, mem_restrict_scalars]

/-- Produces an `R`-algebra map from `U.restrict_scalars R` given an `S`-algebra map from `U`.

This is a special case of `alg_hom.restrict_scalars` that can be helpful in elaboration. -/
@[simp]
def of_restrict_scalars (U : subalgebra S A) (f : U →ₐ[S] B) : U.restrict_scalars R →ₐ[R] B :=
f.restrict_scalars R

end semiring

end subalgebra

namespace is_scalar_tower

open subalgebra

variables [comm_semiring R] [comm_semiring S] [comm_semiring A]
variables [algebra R S] [algebra S A] [algebra R A] [is_scalar_tower R S A]

theorem adjoin_range_to_alg_hom (t : set A) :
  (algebra.adjoin (to_alg_hom R S A).range t).restrict_scalars R =
    (algebra.adjoin S t).restrict_scalars R :=
subalgebra.ext $ λ z,
show z ∈ subsemiring.closure (set.range (algebra_map (to_alg_hom R S A).range A) ∪ t : set A) ↔
  z ∈ subsemiring.closure (set.range (algebra_map S A) ∪ t : set A),
from suffices set.range (algebra_map (to_alg_hom R S A).range A) = set.range (algebra_map S A),
  by rw this,
by { ext z, exact ⟨λ ⟨⟨x, y, h1⟩, h2⟩, ⟨y, h2 ▸ h1⟩, λ ⟨y, hy⟩, ⟨⟨z, y, hy⟩, rfl⟩⟩ }

end is_scalar_tower


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

import group_theory.group_action.group
import data.equiv.ring
import deprecated.subring

/-!
# Group action on rings

This file defines the typeclass of monoid acting on semirings `mul_semiring_action M R`,
and the corresponding typeclass of invariant subrings.

Note that `algebra` does not satisfy the axioms of `mul_semiring_action`.

## Implementation notes

There is no separate typeclass for group acting on rings, group acting on fields, etc.
They are all grouped under `mul_semiring_action`.

## Tags

group action, invariant subring

-/

universes u v
open_locale big_operators

/-- Typeclass for multiplicative actions by monoids on semirings. -/
class mul_semiring_action (M : Type u) [monoid M] (R : Type v) [semiring R]
  extends distrib_mul_action M R :=
(smul_one : ∀ (g : M), (g • 1 : R) = 1)
(smul_mul : ∀ (g : M) (x y : R), g • (x * y) = (g • x) * (g • y))

export mul_semiring_action (smul_one)

/-- Typeclass for faithful multiplicative actions by monoids on semirings. -/
class faithful_mul_semiring_action (M : Type u) [monoid M] (R : Type v) [semiring R]
  extends mul_semiring_action M R :=
(eq_of_smul_eq_smul' : ∀ {m₁ m₂ : M}, (∀ r : R, m₁ • r = m₂ • r) → m₁ = m₂)

section semiring

variables (M G : Type u) [monoid M] [group G]
variables (A R S F : Type v) [add_monoid A] [semiring R] [comm_semiring S] [field F]

variables {M R}
lemma smul_mul' [mul_semiring_action M R] (g : M) (x y : R) :
  g • (x * y) = (g • x) * (g • y) :=
mul_semiring_action.smul_mul g x y

variables {M} (R)
theorem eq_of_smul_eq_smul [faithful_mul_semiring_action M R] {m₁ m₂ : M} :
  (∀ r : R, m₁ • r = m₂ • r) → m₁ = m₂ :=
faithful_mul_semiring_action.eq_of_smul_eq_smul'

variables (M R)

/-- Each element of the monoid defines a additive monoid homomorphism. -/
def distrib_mul_action.to_add_monoid_hom [distrib_mul_action M A] (x : M) : A →+ A :=
{ to_fun   := (•) x,
  map_zero' := smul_zero x,
  map_add' := smul_add x }

/-- Each element of the group defines an additive monoid isomorphism. -/
def distrib_mul_action.to_add_equiv [distrib_mul_action G A] (x : G) : A ≃+ A :=
{ .. distrib_mul_action.to_add_monoid_hom G A x,
  .. mul_action.to_perm G A x }

/-- Each element of the group defines an additive monoid homomorphism. -/
def distrib_mul_action.hom_add_monoid_hom [distrib_mul_action M A] : M →* add_monoid.End A :=
{ to_fun := distrib_mul_action.to_add_monoid_hom M A,
  map_one' := add_monoid_hom.ext $ λ x, one_smul M x,
  map_mul' := λ x y, add_monoid_hom.ext $ λ z, mul_smul x y z }

/-- Each element of the monoid defines a semiring homomorphism. -/
def mul_semiring_action.to_semiring_hom [mul_semiring_action M R] (x : M) : R →+* R :=
{ map_one' := smul_one x,
  map_mul' := smul_mul' x,
  .. distrib_mul_action.to_add_monoid_hom M R x }

theorem to_semiring_hom_injective [faithful_mul_semiring_action M R] :
  function.injective (mul_semiring_action.to_semiring_hom M R) :=
λ m₁ m₂ h, eq_of_smul_eq_smul R $ λ r, ring_hom.ext_iff.1 h r

/-- Each element of the group defines a semiring isomorphism. -/
def mul_semiring_action.to_semiring_equiv [mul_semiring_action G R] (x : G) : R ≃+* R :=
{ .. distrib_mul_action.to_add_equiv G R x,
  .. mul_semiring_action.to_semiring_hom G R x }

section prod
variables [mul_semiring_action M R] [mul_semiring_action M S]

lemma list.smul_prod (g : M) (L : list R) : g • L.prod = (L.map $ (•) g).prod :=
monoid_hom.map_list_prod (mul_semiring_action.to_semiring_hom M R g : R →* R) L

lemma multiset.smul_prod (g : M) (m : multiset S) : g • m.prod = (m.map $ (•) g).prod :=
monoid_hom.map_multiset_prod (mul_semiring_action.to_semiring_hom M S g : S →* S) m

lemma smul_prod (g : M) {ι : Type*} (f : ι → S) (s : finset ι) :
  g • ∏ i in s, f i = ∏ i in s, g • f i :=
monoid_hom.map_prod (mul_semiring_action.to_semiring_hom M S g : S →* S) f s

end prod

section simp_lemmas

variables {M G A R}

attribute [simp] smul_one smul_mul' smul_zero smul_add

@[simp] lemma smul_inv [mul_semiring_action M F] (x : M) (m : F) : x • m⁻¹ = (x • m)⁻¹ :=
(mul_semiring_action.to_semiring_hom M F x).map_inv _

@[simp] lemma smul_pow [mul_semiring_action M R] (x : M) (m : R) (n : ℕ) :
  x • m ^ n = (x • m) ^ n :=
begin
  induction n with n ih,
  { rw [pow_zero, pow_zero], exact smul_one x },
  { rw [pow_succ, pow_succ], exact (smul_mul' x m (m ^ n)).trans (congr_arg _ ih) }
end

end simp_lemmas

end semiring

section ring

variables (M : Type u) [monoid M] {R : Type v} [ring R] [mul_semiring_action M R]
variables (S : set R) [is_subring S]
open mul_action

set_option old_structure_cmd false

/-- A subring invariant under the action. -/
class is_invariant_subring : Prop :=
(smul_mem : ∀ (m : M) {x : R}, x ∈ S → m • x ∈ S)

variables [is_invariant_subring M S]

local attribute [instance] subset.ring
instance is_invariant_subring.to_mul_semiring_action : mul_semiring_action M S :=
{ smul := λ m x, ⟨m • x, is_invariant_subring.smul_mem m x.2⟩,
  one_smul := λ s, subtype.eq $ one_smul M s,
  mul_smul := λ m₁ m₂ s, subtype.eq $ mul_smul m₁ m₂ s,
  smul_add := λ m s₁ s₂, subtype.eq $ smul_add m s₁ s₂,
  smul_zero := λ m, subtype.eq $ smul_zero m,
  smul_one := λ m, subtype.eq $ smul_one m,
  smul_mul := λ m s₁ s₂, subtype.eq $ smul_mul' m s₁ s₂ }

end ring


/-
Copyright (c) 2018 Alexander Bentkamp. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Alexander Bentkamp
-/
import algebra.module.pi
import algebra.big_operators.basic

/-!
# Basic properties of holors

Holors are indexed collections of tensor coefficients. Confusingly,
they are often called tensors in physics and in the neural network
community.

A holor is simply a multidimensional array of values. The size of a
holor is specified by a `list ℕ`, whose length is called the dimension
of the holor.

The tensor product of `x₁ : holor α ds₁` and `x₂ : holor α ds₂` is the
holor given by `(x₁ ⊗ x₂) (i₁ ++ i₂) = x₁ i₁ * x₂ i₂`. A holor is "of
rank at most 1" if it is a tensor product of one-dimensional holors.
The CP rank of a holor `x` is the smallest N such that `x` is the sum
of N holors of rank at most 1.

Based on the tensor library found in <https://www.isa-afp.org/entries/Deep_Learning.html>

## References

* <https://en.wikipedia.org/wiki/Tensor_rank_decomposition>
-/

universes u

open list

open_locale big_operators

/-- `holor_index ds` is the type of valid index tuples used to identify an entry of a holor
of dimensions `ds`. -/
def holor_index (ds : list ℕ) : Type := {is : list ℕ // forall₂ (<) is ds}

namespace holor_index
variables {ds₁ ds₂ ds₃ : list ℕ}

def take : Π {ds₁ : list ℕ}, holor_index (ds₁ ++ ds₂) → holor_index ds₁
| ds is := ⟨ list.take (length ds) is.1, forall₂_take_append is.1 ds ds₂ is.2 ⟩

def drop : Π {ds₁ : list ℕ}, holor_index (ds₁ ++ ds₂) → holor_index ds₂
| ds is := ⟨ list.drop (length ds) is.1, forall₂_drop_append is.1 ds ds₂ is.2 ⟩

lemma cast_type (is : list ℕ) (eq : ds₁ = ds₂) (h : forall₂ (<) is ds₁) :
  (cast (congr_arg holor_index eq) ⟨is, h⟩).val = is :=
by subst eq; refl

def assoc_right :
  holor_index (ds₁ ++ ds₂ ++ ds₃) → holor_index (ds₁ ++ (ds₂ ++ ds₃)) :=
cast (congr_arg holor_index (append_assoc ds₁ ds₂ ds₃))

def assoc_left :
  holor_index (ds₁ ++ (ds₂ ++ ds₃)) → holor_index (ds₁ ++ ds₂ ++ ds₃) :=
cast (congr_arg holor_index (append_assoc ds₁ ds₂ ds₃).symm)

lemma take_take :
  ∀ t : holor_index (ds₁ ++ ds₂ ++ ds₃),
  t.assoc_right.take = t.take.take
| ⟨ is , h ⟩ := subtype.eq $ by simp [assoc_right,take, cast_type, list.take_take,
                                     nat.le_add_right, min_eq_left]

lemma drop_take :
  ∀ t : holor_index (ds₁ ++ ds₂ ++ ds₃),
  t.assoc_right.drop.take = t.take.drop
| ⟨ is , h ⟩ := subtype.eq (by simp [assoc_right, take, drop, cast_type, list.drop_take])

lemma drop_drop :
  ∀ t : holor_index (ds₁ ++ ds₂ ++ ds₃),
  t.assoc_right.drop.drop = t.drop
| ⟨ is , h ⟩ := subtype.eq (by simp [add_comm, assoc_right, drop, cast_type, list.drop_drop])

end holor_index

/-- Holor (indexed collections of tensor coefficients) -/
def holor (α : Type u) (ds : list ℕ) := holor_index ds → α

namespace holor

variables {α : Type} {d : ℕ} {ds : list ℕ} {ds₁ : list ℕ} {ds₂ : list ℕ} {ds₃ : list ℕ}

instance [inhabited α] : inhabited (holor α ds) := ⟨λ t, default⟩
instance [has_zero α] : has_zero (holor α ds) := ⟨λ t, 0⟩
instance [has_add α] : has_add (holor α ds) := ⟨λ x y t, x t + y t⟩
instance [has_neg α] : has_neg (holor α ds) :=  ⟨λ a t, - a t⟩

instance [add_semigroup α] : add_semigroup (holor α ds) :=
by refine_struct { add := (+), .. }; tactic.pi_instance_derive_field

instance [add_comm_semigroup α] : add_comm_semigroup (holor α ds) :=
by refine_struct { add := (+), .. }; tactic.pi_instance_derive_field

instance [add_monoid α] : add_monoid (holor α ds) :=
by refine_struct { zero := (0 : holor α ds), add := (+), nsmul := λ n x i, n • (x i) };
tactic.pi_instance_derive_field

instance [add_comm_monoid α] : add_comm_monoid (holor α ds) :=
by refine_struct { zero := (0 : holor α ds), add := (+), nsmul := add_monoid.nsmul };
tactic.pi_instance_derive_field

instance [add_group α] : add_group (holor α ds) :=
by refine_struct { zero := (0 : holor α ds), add := (+), nsmul := add_monoid.nsmul,
  zsmul := λ n x i, n • (x i) };
tactic.pi_instance_derive_field

instance [add_comm_group α] : add_comm_group (holor α ds) :=
by refine_struct { zero := (0 : holor α ds), add := (+), nsmul := add_monoid.nsmul,
  zsmul := sub_neg_monoid.zsmul };
tactic.pi_instance_derive_field

/- scalar product -/

instance [has_mul α] : has_scalar α (holor α ds) :=
  ⟨λ a x, λ t, a * x t⟩

instance [semiring α] : module α (holor α ds) := pi.module _ _ _

/-- The tensor product of two holors. -/
def mul [s : has_mul α] (x : holor α ds₁) (y : holor α ds₂) : holor α (ds₁ ++ ds₂) :=
  λ t, x (t.take) * y (t.drop)

local infix ` ⊗ ` : 70 := mul

lemma cast_type (eq : ds₁ = ds₂) (a : holor α ds₁) :
  cast (congr_arg (holor α) eq) a = (λ t, a (cast (congr_arg holor_index eq.symm) t)) :=
by subst eq; refl

def assoc_right :
  holor α (ds₁ ++ ds₂ ++ ds₃) → holor α (ds₁ ++ (ds₂ ++ ds₃)) :=
cast (congr_arg (holor α) (append_assoc ds₁ ds₂ ds₃))

def assoc_left :
  holor α (ds₁ ++ (ds₂ ++ ds₃)) → holor α (ds₁ ++ ds₂ ++ ds₃) :=
cast (congr_arg (holor α) (append_assoc ds₁ ds₂ ds₃).symm)

lemma mul_assoc0 [semigroup α] (x : holor α ds₁) (y : holor α ds₂) (z : holor α ds₃) :
  x ⊗ y ⊗ z = (x ⊗ (y ⊗ z)).assoc_left :=
funext (assume t : holor_index (ds₁ ++ ds₂ ++ ds₃),
begin
  rw assoc_left,
  unfold mul,
  rw mul_assoc,
  rw [←holor_index.take_take, ←holor_index.drop_take, ←holor_index.drop_drop],
  rw cast_type,
  refl,
  rw append_assoc
end)

lemma mul_assoc [semigroup α] (x : holor α ds₁) (y : holor α ds₂) (z : holor α ds₃) :
  mul (mul x y) z == (mul x (mul y z)) :=
by simp [cast_heq, mul_assoc0, assoc_left].

lemma mul_left_distrib [distrib α] (x : holor α ds₁) (y : holor α ds₂) (z : holor α ds₂) :
  x ⊗ (y + z) = x ⊗ y + x ⊗ z :=
funext (λt, left_distrib (x (holor_index.take t)) (y (holor_index.drop t)) (z (holor_index.drop t)))

lemma mul_right_distrib [distrib α] (x : holor α ds₁) (y : holor α ds₁) (z : holor α ds₂) :
  (x + y) ⊗ z = x ⊗ z + y ⊗ z :=
funext $ λt, add_mul (x (holor_index.take t)) (y (holor_index.take t)) (z (holor_index.drop t))

@[simp] lemma zero_mul {α : Type} [ring α] (x : holor α ds₂) :
  (0 : holor α ds₁) ⊗ x = 0 :=
funext (λ t, zero_mul (x (holor_index.drop t)))

@[simp] lemma mul_zero {α : Type} [ring α] (x : holor α ds₁) :
  x ⊗ (0 :holor α ds₂) = 0 :=
funext (λ t, mul_zero (x (holor_index.take t)))

lemma mul_scalar_mul [monoid α] (x : holor α []) (y : holor α ds) :
  x ⊗ y = x ⟨[], forall₂.nil⟩ • y :=
by simp [mul, has_scalar.smul, holor_index.take, holor_index.drop]

/- holor slices -/

/-- A slice is a subholor consisting of all entries with initial index i. -/
def slice (x : holor α (d :: ds)) (i : ℕ) (h : i < d) : holor α ds :=
  (λ is : holor_index ds, x ⟨ i :: is.1, forall₂.cons h is.2⟩)

/-- The 1-dimensional "unit" holor with 1 in the `j`th position. -/
def unit_vec [monoid α] [add_monoid α] (d : ℕ) (j : ℕ) : holor α [d] :=
  λ ti, if ti.1 = [j] then 1 else 0

lemma holor_index_cons_decomp (p: holor_index (d :: ds) → Prop) :
  Π (t : holor_index (d :: ds)),
    (∀ i is, Π h : t.1 = i :: is, p ⟨ i :: is, begin rw [←h], exact t.2 end ⟩ ) → p t
| ⟨[], hforall₂⟩        hp := absurd (forall₂_nil_left_iff.1 hforall₂) (cons_ne_nil d ds)
| ⟨(i :: is), hforall₂⟩ hp := hp i is rfl

/-- Two holors are equal if all their slices are equal. -/
lemma slice_eq (x : holor α (d :: ds)) (y : holor α (d :: ds))
  (h : slice x = slice y) : x = y :=
funext $ λ t : holor_index (d :: ds), holor_index_cons_decomp (λ t, x t = y t) t $ λ i is hiis,
have hiisdds: forall₂ (<) (i :: is) (d :: ds), begin rw [←hiis], exact t.2 end,
have hid:     i<d,                             from (forall₂_cons.1 hiisdds).1,
have hisds:   forall₂ (<) is ds,               from (forall₂_cons.1 hiisdds).2,
calc
  x ⟨i :: is, _⟩ = slice x i hid ⟨is, hisds⟩  : congr_arg (λ t, x t) (subtype.eq rfl)
              ... = slice y i hid ⟨is, hisds⟩  : by rw h
              ... = y ⟨i :: is, _⟩             : congr_arg (λ t, y t) (subtype.eq rfl)

lemma slice_unit_vec_mul [ring α] {i : ℕ} {j : ℕ}
  (hid : i < d) (x : holor α ds) :
  slice (unit_vec d j ⊗ x) i hid = if i=j then x else 0 :=
funext $ λ t : holor_index ds, if h : i = j
  then by simp [slice, mul, holor_index.take, unit_vec, holor_index.drop, h]
  else by simp [slice, mul, holor_index.take, unit_vec, holor_index.drop, h]; refl

lemma slice_add [has_add α] (i : ℕ) (hid : i < d)  (x : holor α (d :: ds)) (y : holor α (d :: ds)) :
  slice x i hid + slice y i hid = slice (x + y) i hid := funext (λ t, by simp [slice,(+)])

lemma slice_zero [has_zero α] (i : ℕ) (hid : i < d)  :
  slice (0 : holor α (d :: ds)) i hid = 0 := rfl

lemma slice_sum [add_comm_monoid α] {β : Type}
  (i : ℕ) (hid : i < d) (s : finset β) (f : β → holor α (d :: ds)) :
  ∑ x in s, slice (f x) i hid = slice (∑ x in s, f x) i hid :=
begin
  letI := classical.dec_eq β,
  refine finset.induction_on s _ _,
  { simp [slice_zero] },
  { intros _ _ h_not_in ih,
    rw [finset.sum_insert h_not_in, ih, slice_add, finset.sum_insert h_not_in] }
end

/-- The original holor can be recovered from its slices by multiplying with unit vectors and
summing up. -/
@[simp] lemma sum_unit_vec_mul_slice [ring α] (x : holor α (d :: ds)) :
  ∑ i in (finset.range d).attach,
    unit_vec d i ⊗ slice x i (nat.succ_le_of_lt (finset.mem_range.1 i.prop)) = x :=
begin
  apply slice_eq _ _ _,
  ext i hid,
  rw [←slice_sum],
  simp only [slice_unit_vec_mul hid],
  rw finset.sum_eq_single (subtype.mk i $ finset.mem_range.2 hid),
  { simp },
  { assume (b : {x // x ∈ finset.range d}) (hb : b ∈ (finset.range d).attach) (hbi : b ≠ ⟨i, _⟩),
    have hbi' : i ≠ b,
    { simpa only [ne.def, subtype.ext_iff, subtype.coe_mk] using hbi.symm },
    simp [hbi'] },
  { assume hid' : subtype.mk i _ ∉ finset.attach (finset.range d),
    exfalso,
    exact absurd (finset.mem_attach _ _) hid' }
end

/- CP rank -/

/-- `cprank_max1 x` means `x` has CP rank at most 1, that is,
  it is the tensor product of 1-dimensional holors. -/
inductive cprank_max1 [has_mul α]: Π {ds}, holor α ds → Prop
| nil (x : holor α []) :
    cprank_max1 x
| cons {d} {ds} (x : holor α [d]) (y : holor α ds) :
    cprank_max1 y → cprank_max1 (x ⊗ y)

/-- `cprank_max N x` means `x` has CP rank at most `N`, that is,
  it can be written as the sum of N holors of rank at most 1. -/
inductive cprank_max [has_mul α] [add_monoid α] : ℕ → Π {ds}, holor α ds → Prop
| zero {ds} :
    cprank_max 0 (0 : holor α ds)
| succ n {ds} (x : holor α ds) (y : holor α ds) :
    cprank_max1 x → cprank_max n y →  cprank_max (n+1) (x + y)

lemma cprank_max_nil [monoid α] [add_monoid α] (x : holor α nil) : cprank_max 1 x :=
  have h : _, from cprank_max.succ 0 x 0 (cprank_max1.nil x) (cprank_max.zero),
  by rwa [add_zero x, zero_add] at h

lemma cprank_max_1 [monoid α] [add_monoid α] {x : holor α ds}
  (h : cprank_max1 x) : cprank_max 1 x :=
have h' : _, from cprank_max.succ 0 x 0 h cprank_max.zero,
by rwa [zero_add, add_zero] at h'

lemma cprank_max_add [monoid α] [add_monoid α]:
  ∀ {m : ℕ} {n : ℕ} {x : holor α ds} {y : holor α ds},
  cprank_max m x → cprank_max n y → cprank_max (m + n) (x + y)
| 0     n x y (cprank_max.zero) hy := by simp [hy]
| (m+1) n _ y (cprank_max.succ k x₁ x₂ hx₁ hx₂) hy :=
begin
  simp only [add_comm, add_assoc],
  apply cprank_max.succ,
  { assumption },
  { exact cprank_max_add hx₂ hy }
end

lemma cprank_max_mul [ring α] :
  ∀ (n : ℕ) (x : holor α [d]) (y : holor α ds), cprank_max n y → cprank_max n (x ⊗ y)
| 0 x _ (cprank_max.zero) := by simp [mul_zero x, cprank_max.zero]
| (n+1) x _ (cprank_max.succ k y₁ y₂ hy₁ hy₂) :=
begin
  rw mul_left_distrib,
  rw nat.add_comm,
  apply cprank_max_add,
  { exact cprank_max_1 (cprank_max1.cons _ _ hy₁) },
  { exact cprank_max_mul k x y₂ hy₂ }
end

lemma cprank_max_sum [ring α] {β} {n : ℕ} (s : finset β) (f : β → holor α ds) :
  (∀ x ∈ s, cprank_max n (f x)) → cprank_max (s.card * n) (∑ x in s, f x) :=
by letI := classical.dec_eq β;
exact finset.induction_on s
  (by simp [cprank_max.zero])
  (begin
    assume x s (h_x_notin_s : x ∉ s) ih h_cprank,
    simp only [finset.sum_insert h_x_notin_s,finset.card_insert_of_not_mem h_x_notin_s],
    rw nat.right_distrib,
    simp only [nat.one_mul, nat.add_comm],
    have ih' : cprank_max (finset.card s * n) (∑ x in s, f x),
    { apply ih,
      assume (x : β) (h_x_in_s: x ∈ s),
      simp only [h_cprank, finset.mem_insert_of_mem, h_x_in_s] },
    exact (cprank_max_add (h_cprank x (finset.mem_insert_self x s)) ih')
  end)

lemma cprank_max_upper_bound [ring α] : Π {ds}, ∀ x : holor α ds, cprank_max ds.prod x
| [] x := cprank_max_nil x
| (d :: ds) x :=
have h_summands : Π (i : {x // x ∈ finset.range d}),
  cprank_max ds.prod (unit_vec d i.1 ⊗ slice x i.1 (mem_range.1 i.2)),
  from λ i, cprank_max_mul _ _ _ (cprank_max_upper_bound (slice x i.1 (mem_range.1 i.2))),
have h_dds_prod : (list.cons d ds).prod = finset.card (finset.range d) * prod ds,
  by simp [finset.card_range],
have cprank_max (finset.card (finset.attach (finset.range d)) * prod ds)
  (∑ i in finset.attach (finset.range d), unit_vec d (i.val)⊗slice x (i.val) (mem_range.1 i.2)),
  from cprank_max_sum (finset.range d).attach _ (λ i _, h_summands i),
have h_cprank_max_sum : cprank_max (finset.card (finset.range d) * prod ds)
  (∑ i in finset.attach (finset.range d), unit_vec d (i.val)⊗slice x (i.val) (mem_range.1 i.2)),
  by rwa [finset.card_attach] at this,
begin
  rw [←sum_unit_vec_mul_slice x],
  rw [h_dds_prod],
  exact h_cprank_max_sum,
end

/-- The CP rank of a holor `x`: the smallest N such that
  `x` can be written as the sum of N holors of rank at most 1. -/
noncomputable def cprank [ring α] (x : holor α ds) : nat :=
@nat.find (λ n, cprank_max n x) (classical.dec_pred _) ⟨ds.prod, cprank_max_upper_bound x⟩

lemma cprank_upper_bound [ring α] :
  Π {ds}, ∀ x : holor α ds, cprank x ≤ ds.prod :=
λ ds (x : holor α ds),
  by letI := classical.dec_pred (λ (n : ℕ), cprank_max n x);
  exact nat.find_min'
    ⟨ds.prod, show (λ n, cprank_max n x) ds.prod, from cprank_max_upper_bound x⟩
    (cprank_max_upper_bound x)

end holor


import group_theory.order_of_element .zmod_as_fin2 algebra.pi_instances group_theory.group_action
open equiv fintype finset is_group_action is_monoid_action
universes u v w
variables {G : Type u} {α : Type v} {β : Type w} [group G]
#check le_antisymm'
namespace finset

lemma filter_insert_of_pos [decidable_eq α] (s : finset α) {P : α → Prop}
  [decidable_pred P] (a : α) (h : P a) : (insert a s).filter P = insert a (s.filter P) :=
ext.2 (λ x, by rw [mem_filter, mem_insert, mem_insert, mem_filter, eq_comm];
  exact ⟨λ h₁, by cases h₁.1; simp * at *, λ h₁, by cases h₁; simp * at *⟩)

lemma filter_insert_of_neg [decidable_eq α] (s : finset α) {P : α → Prop}
  [decidable_pred P] (a : α) (h : ¬P a) : (insert a s).filter P = s.filter P :=
ext.2 (λ x, by rw [mem_filter, mem_insert, mem_filter, eq_comm];
  exact ⟨λ h₁, by cases h₁.1; simp * at *, by finish⟩)

end finset

lemma nat.sum_mod [decidable_eq α] (s : finset α) (f : α → ℕ) (n : ℕ) :
  s.sum f ≡ (s.filter (λ x, f x % n ≠ 0)).sum f [MOD n] :=
finset.induction_on s rfl begin
  assume a s has ih,
  by_cases ha : f a % n ≠ 0,
  { rw [finset.sum_insert has, finset.filter_insert_of_pos s a ha, finset.sum_insert],
    exact nat.modeq.modeq_add rfl ih,
    { finish [finset.mem_filter] } },
  { rw [finset.sum_insert has, finset.filter_insert_of_neg s a ha,
      ← zero_add (finset.sum (finset.filter _ _) _)],
    rw [ne.def, ← nat.zero_mod n] at ha,
    exact nat.modeq.modeq_add (not_not.1 ha) ih }
end

namespace set

lemma card_eq_of_eq {s t : set α} [fintype s] [fintype t] (h : s = t) :
  card s = card t :=
by congr; assumption

lemma card_image_of_inj_on {s : set α} [fintype s]
  {f : α → β} [fintype (f '' s)] (H : ∀x∈s, ∀y∈s, f x = f y → x = y) :
  fintype.card (f '' s) = fintype.card s :=
by haveI := classical.prop_decidable; exact
calc fintype.card (f '' s) = (s.to_finset.image f).card : card_fintype_of_finset' _ (by simp)
... = s.to_finset.card : card_image_of_inj_on
    (λ x hx y hy hxy, H x (mem_to_finset.1 hx) y (mem_to_finset.1 hy) hxy)
... = card s : (card_fintype_of_finset' _ (λ a, mem_to_finset)).symm

lemma card_image_of_injective (s : set α) [fintype s]
  {f : α → β} [fintype (f '' s)] (H : function.injective f) :
  fintype.card (f '' s) = fintype.card s :=
card_image_of_inj_on $ λ _ _ _ _ h, H h

lemma coe_to_finset [decidable_eq α] (s : set α) [fintype s] : (↑s.to_finset : set α) = s :=
set.ext (by simp)

lemma ssubset_iff_subset_not_subset {s t : set α} : s ⊂ t ↔ s ⊆ t ∧ ¬ t ⊆ s :=
by split; simp [set.ssubset_def, ne.def, set.subset.antisymm_iff] {contextual := tt}

lemma coe_ssubset [decidable_eq α] {s t : finset α} : (↑s : set α) ⊂ ↑t ↔ s ⊂ t :=
show (↑s : set α) ⊂ ↑t ↔ s ⊆ t ∧ ¬t ⊆ s,
  by simp [ssubset_iff_subset_not_subset] {contextual := tt}

#print coe_ssubset

lemma card_lt_card {s t : set α} [fintype s] [fintype t] (h : s ⊂ t) : card s < card t :=
begin
  haveI := classical.prop_decidable,
  rw [card_fintype_of_finset' _ (λ x, mem_to_finset), card_fintype_of_finset' _ (λ x, mem_to_finset)],
  rw [← coe_to_finset s, ← coe_to_finset t, coe_ssubset] at h,
  exact finset.card_lt_card h,
end

def equiv_univ (α : Type u) : α ≃ (set.univ : set α) :=
{ to_fun := λ a, ⟨a, mem_univ _⟩,
  inv_fun := λ a, a.1,
  left_inv := λ a, rfl,
  right_inv := λ ⟨a, ha⟩, rfl }

@[simp] lemma card_univ (α : Type u) [fintype α] [fintype.{u} (set.univ : set α)] :
  fintype.card (set.univ : set α) = fintype.card α :=
eq.symm (card_congr (equiv_univ α))

lemma eq_of_card_eq_of_subset {s t : set α} [fintype s] [fintype t]
  (hcard : card s = card t) (hsub : s ⊆ t) : s = t :=
classical.by_contradiction (λ h, lt_irrefl (card t)
  (have card s < card t := set.card_lt_card ⟨hsub, h⟩,
    by rwa hcard at this))

end set

local attribute [instance, priority 0]
  subtype.fintype set_fintype classical.prop_decidable

section should_be_in_group_theory

noncomputable instance [fintype G] (H : set G) [is_subgroup H] :
fintype (left_cosets H) := quotient.fintype (left_rel H)

lemma card_eq_card_cosets_mul_card_subgroup [fintype G] (H : set G) [is_subgroup H] :
  card G = card (left_cosets H) * card H :=
by rw ← card_prod;
  exact card_congr (is_subgroup.group_equiv_left_cosets_times_subgroup _)

lemma order_of_dvd_of_pow_eq_one [fintype G] {a : G} {n : ℕ} (h : a ^ n = 1) :
  order_of a ∣ n :=
by_contradiction
(λ h₁, nat.find_min _ (show n % order_of a < order_of a,
  from nat.mod_lt _ (nat.pos_of_ne_zero (order_of_ne_zero _)))
    ⟨mt nat.dvd_of_mod_eq_zero h₁, by rwa ← pow_eq_mod_order_of⟩)

lemma eq_one_of_order_of_eq_one [fintype G] {a : G} (h : order_of a = 1) : a = 1 :=
by conv { to_lhs, rw [← pow_one a, ← h, pow_order_of_eq_one] }

lemma order_eq_card_gpowers [fintype G] {a : G} : order_of a = card (gpowers a) :=
begin
  refine (finset.card_eq_of_bijective _ _ _ _).symm,
  { exact λn hn, ⟨gpow a n, ⟨n, rfl⟩⟩ },
  { exact assume ⟨_, i, rfl⟩ _,
    have pos: (0:int) < order_of a,
      from int.coe_nat_lt.mpr $ nat.pos_iff_ne_zero.mpr $ order_of_ne_zero a,
    have 0 ≤ i % (order_of a),
      from int.mod_nonneg _ $ ne_of_gt pos,
    ⟨int.to_nat (i % order_of a),
      by rw [← int.coe_nat_lt, int.to_nat_of_nonneg this];
        exact ⟨int.mod_lt_of_pos _ pos, subtype.eq gpow_eq_mod_order_of.symm⟩⟩ },
  { intros, exact finset.mem_univ _ },
  { exact assume i j hi hj eq, pow_injective_of_lt_order_of a hi hj $ by simpa using eq }
end

@[simp] lemma card_trivial [fintype (is_subgroup.trivial G)] :
  fintype.card (is_subgroup.trivial G) = 1 := fintype.card_eq_one_iff.2
  ⟨⟨(1 : G), by simp⟩, λ ⟨y, hy⟩, subtype.eq $ is_subgroup.mem_trivial.1 hy⟩

local attribute [instance] left_rel normal_subgroup.to_is_subgroup

instance quotient.mk.is_group_hom (H : set G) [normal_subgroup H] : @is_group_hom G (left_cosets H) _ _
  quotient.mk :=
⟨λ _ _, rfl⟩

instance subtype.val.is_group_hom (H : set G) [is_subgroup H] : is_group_hom (subtype.val : H → G) :=
⟨λ _ _, rfl⟩

def normalizer (H : set G) : set G :=
{ g : G | ∀ n, n ∈ H ↔ g * n * g⁻¹ ∈ H }

instance (H : set G) [is_subgroup H] : is_subgroup (normalizer H) :=
{ one_mem := by simp [normalizer],
  mul_mem := λ a b (ha : ∀ n, n ∈ H ↔ a * n * a⁻¹ ∈ H)
    (hb : ∀ n, n ∈ H ↔ b * n * b⁻¹ ∈ H) n,
    by rw [mul_inv_rev, ← mul_assoc, mul_assoc a, mul_assoc a, ← ha, ← hb],
  inv_mem := λ a (ha : ∀ n, n ∈ H ↔ a * n * a⁻¹ ∈ H) n,
    by rw [ha (a⁻¹ * n * a⁻¹⁻¹)];
    simp [mul_assoc] }

lemma subset_normalizer (H : set G) [is_subgroup H] : H ⊆ normalizer H :=
λ g hg n, by rw [is_subgroup.mul_mem_cancel_left _ ((is_subgroup.inv_mem_iff _).2 hg),
  is_subgroup.mul_mem_cancel_right _ hg]

instance (H : set G) [is_subgroup H] : normal_subgroup { x : normalizer H | ↑x ∈ H } :=
{ one_mem := show (1 : G) ∈ H, from is_submonoid.one_mem _,
  mul_mem := λ a b ha hb, show (a * b : G) ∈ H, from is_submonoid.mul_mem ha hb,
  inv_mem := λ a ha, show (a⁻¹ : G) ∈ H, from is_subgroup.inv_mem ha,
  normal := λ a ha ⟨m, hm⟩, (hm a).1 ha }

lemma conj_inj_left {x : G} : function.injective (λ (n : G), x * n * x⁻¹) :=
λ a b h, (mul_left_inj x).1 $ (mul_right_inj (x⁻¹)).1 h

lemma mem_normalizer_fintype {H : set G} [fintype H] {x : G} :
  (∀ n, n ∈ H → x * n * x⁻¹ ∈ H) → x ∈ normalizer H :=
λ h n, ⟨h n, λ h₁,
have heq : (λ n, x * n * x⁻¹) '' H = H := set.eq_of_card_eq_of_subset
  (set.card_image_of_injective _ conj_inj_left) (λ n ⟨y, hy⟩, hy.2 ▸ h y hy.1),
have x * n * x⁻¹ ∈ (λ n, x * n * x⁻¹) '' H := heq.symm ▸ h₁,
let ⟨y, hy⟩ := this in conj_inj_left hy.2 ▸ hy.1⟩

noncomputable lemma preimage_quotient_mk_equiv_subgroup_times_set (H : set G) [is_subgroup H]
  (s : set (left_cosets H)) : quotient.mk ⁻¹' s ≃ (H × s) :=
have h : ∀ {x : left_cosets H} {a : G}, x ∈ s → a ∈ H →
  ⟦quotient.out x * a⟧ = ⟦quotient.out x⟧ := λ x a hx ha,
      quotient.sound (show (quotient.out x * a)⁻¹ * quotient.out x ∈ H,
      from (is_subgroup.inv_mem_iff _).1 $
        by rwa [mul_inv_rev, inv_inv, ← mul_assoc, inv_mul_self, one_mul]),
{ to_fun := λ ⟨a, ha⟩, ⟨⟨(quotient.out ⟦a⟧)⁻¹ * a,
    @quotient.exact _ (left_rel H) _ _ $ by simp⟩, ⟨⟦a⟧, ha⟩⟩,
  inv_fun := λ ⟨⟨a, ha⟩, ⟨x, hx⟩⟩, ⟨(quotient.out x) * a,
    show _ ∈ s, by simpa [h hx ha]⟩,
  left_inv := λ ⟨a, ha⟩, by simp,
  right_inv := λ ⟨⟨a, ha⟩, ⟨x, hx⟩⟩, by simp [h hx ha] }

end should_be_in_group_theory

section group_action
variables (f : G → α → α) [is_group_action f]

lemma card_orbit_of_mem_fixed_points {f : G → α → α} [is_group_action f]  {a : α} [fintype (orbit f a)] :
  a ∈ fixed_points f ↔ card (orbit f a) = 1 :=
begin
  rw [fintype.card_eq_one_iff, mem_fixed_points],
  split,
  { exact λ h, ⟨⟨a, mem_orbit_self _ _⟩, λ ⟨b, ⟨x, hx⟩⟩, subtype.eq $ by simp [h x, hx.symm]⟩ },
  { assume h x,
    rcases h with ⟨⟨z, hz⟩, hz₁⟩,
    exact calc f x a = z : subtype.mk.inj (hz₁ ⟨f x a, mem_orbit _ _ _⟩)
      ... = a : (subtype.mk.inj (hz₁ ⟨a, mem_orbit_self _ _⟩)).symm }
end

lemma card_modeq_card_fixed_points [fintype α] [fintype G] [fintype (fixed_points f)]
  {p n : ℕ} (hp : nat.prime p) (h : card G = p ^ n) : card α ≡ card (fixed_points f) [MOD p] :=
have hcard : ∀ s : set α, card ↥{x : α | orbit f x = s} % p ≠ 0
    ↔ card ↥{x : α | orbit f x = s} = 1 :=
  λ s, ⟨λ hs, begin
    have h : ∃ y, orbit f y = s := by_contradiction (λ h, begin
      rw not_exists at h,
      have : {x | orbit f x = s} = ∅ := set.eq_empty_iff_forall_not_mem.2 h,
      rw [set.card_eq_of_eq this, set.empty_card', nat.zero_mod] at hs,
      contradiction
    end),
    cases h with y hy,
    have hseq : {x | orbit f x = s} = orbit f y := set.ext (λ z,
      ⟨λ h : orbit f z = s, hy.symm ▸ h ▸ mem_orbit_self _ _,
      λ h, show orbit f z = s, by rwa orbit_eq_iff.2 h⟩),
    rw [card_eq_card_cosets_mul_card_subgroup (stabilizer f y),
      ← card_congr (orbit_equiv_left_cosets f y)] at h,
    have : ∃ k ≤ n, card (orbit f y) = p ^ k := (nat.dvd_prime_pow hp).1
      (h ▸ dvd_mul_right _ _),
    rcases this with ⟨k, hk₁, hk₂⟩,
    rw [set.card_eq_of_eq hseq, hk₂] at hs ⊢,
    have : ¬p ∣ p ^ k := mt nat.mod_eq_zero_of_dvd hs,
    cases k,
    { refl },
    { simpa [nat.pow_succ] using this }
  end,
  λ hs, hs.symm ▸ (nat.mod_eq_of_lt hp.gt_one).symm ▸ λ h, nat.no_confusion h⟩,
have h : (finset.univ.filter (λ a, card {x | orbit f x = a} % p ≠ 0)).sum
  (λ a : set α, card {x | orbit f x = a}) = card (fixed_points f),
  from calc _ = (finset.univ.filter (λ a, card {x | orbit f x = a} % p ≠ 0)).sum
    (λ a : set α, 1) : finset.sum_congr rfl (λ s hs, (hcard s).1 (finset.mem_filter.1 hs).2)
  ... = card {a : set α | card ↥{x : α | orbit f x = a} % p ≠ 0} :
  begin
    rw [finset.sum_const, nat.smul_eq_mul, mul_one],
    refine eq.symm (set.card_fintype_of_finset' _ _),
    simp [finset.mem_filter],
  end
  ... = card (fixed_points f) : fintype.card_congr
    (@equiv.of_bijective _ _
      (show fixed_points f → {a : set α // card ↥{x : α | orbit f x = a} % p ≠ 0},
      from λ x, ⟨orbit f x.1, begin
        rw [hcard, fintype.card_eq_one_iff],
        exact ⟨⟨x, rfl⟩, λ ⟨y, hy⟩,
          have hy : y ∈ orbit f x := (show orbit f y = orbit f x, from hy) ▸ mem_orbit_self _ _,
          subtype.eq (mem_fixed_points'.1 x.2 _ hy)⟩
      end⟩)
      ⟨λ x y hxy,
        have hxy : orbit f x.1 = orbit f y.1 := subtype.mk.inj hxy,
        have hxo : x.1 ∈ orbit f y.1 := hxy ▸ mem_orbit_self _ _,
        subtype.eq (mem_fixed_points'.1 y.2 _ hxo),
      λ ⟨s, hs⟩, begin
        rw [hcard, fintype.card_eq_one_iff] at hs,
        rcases hs with ⟨⟨x, hx₁⟩, hx₂⟩,
        exact ⟨⟨x, mem_fixed_points'.2 (λ y hy,
          subtype.mk.inj (hx₂ ⟨y, by have := orbit_eq_iff.2 hy; simpa [this, hx₁] using hx₁⟩))⟩,
            by simpa using hx₁⟩
      end⟩).symm,
calc card α % p = finset.sum finset.univ (λ a : set α, card {x // orbit f x = a}) % p :
  by rw [card_congr (equiv_fib (orbit f)), fintype.card_sigma]
... = _ : nat.sum_mod _ _ _
... = fintype.card ↥(fixed_points f) % p : by rw ← h; congr

end group_action

namespace sylow
open is_group_action

def mk_vector_prod_eq_one (n : ℕ) [pos_nat n] (v : Zmod n → G) : Zmod (n+1) → G :=
λ m, if h : m.1 < n then v m.1 else ((list.range n).map (λ m : ℕ, v (m : Zmod n))).prod⁻¹

lemma mk_vector_prod_eq_one_injective {p : ℕ} [h0 : pos_nat p] :
  function.injective (@mk_vector_prod_eq_one G _ p _) :=
λ x y hxy, funext (λ ⟨a, ha⟩, begin
  have : dite _ _ _ = dite _ _ _ := congr_fun hxy a,
  rw [Zmod.cast_val_nat, nat.mod_eq_of_lt (nat.lt_succ_of_lt ha),
    dif_pos ha, dif_pos ha] at this,
  rwa Zmod.mk_eq_cast
end)

/-- set of elements of G^n such that the product of the
  list of elements of the vector is one -/
def vectors_prod_eq_one (G : Type*) [group G] (n : ℕ) [pos_nat n] : set (Zmod n → G) :=
{v | ((list.range n).map (λ m : ℕ, v (↑m : Zmod n))).prod = 1 }

lemma mem_vectors_prod_eq_one_iff {n : ℕ} [pos_nat n] (v : Zmod (n + 1) → G) :
  v ∈ vectors_prod_eq_one G (n + 1) ↔ v ∈ mk_vector_prod_eq_one n '' (set.univ : set (Zmod n → G)) :=
have prod_lemma : ((list.range (n + 1)).map (λ m : ℕ, v (m : Zmod (n + 1)))).prod =
  list.prod (list.map (λ (m : ℕ), v ↑m) (list.range n)) * v ↑n :=
by rw [list.range_concat, list.map_append, list.prod_append,
  list.map_singleton, list.prod_cons, list.prod_nil, mul_one],
⟨λ h : list.prod (list.map (λ (m : ℕ), v ↑m) (list.range (n + 1))) = 1,
  have h₁ : list.map (λ (m : ℕ), v ((m : Zmod n).val : Zmod (n+1))) (list.range n)
    = list.map (λ (m : ℕ), v m) (list.range n) := list.map_congr (λ m hm,
  have hm' : m < n := list.mem_range.1 hm,
    by simp [Zmod.cast_val_nat, nat.mod_eq_of_lt hm']),
  ⟨λ m, v m.val, set.mem_univ _, funext (λ i, show dite _ _ _ = _, begin
    split_ifs,
    { refine congr_arg _ (fin.eq_of_veq _),
      simp [Zmod.cast_val_nat, nat.mod_eq_of_lt h_1, nat.mod_eq_of_lt (nat.lt_succ_of_lt h_1)] },
    { have hi : i = n := fin.eq_of_veq begin
        rw [Zmod.cast_val_nat, nat.mod_eq_of_lt (nat.lt_succ_self _)],
        exact le_antisymm (nat.le_of_lt_succ i.2) (le_of_not_gt h_1),
      end,
      rw [h₁, hi, inv_eq_iff_mul_eq_one, ← prod_lemma, h] }
  end)⟩,
λ ⟨w, hw⟩,
  have h : list.map (λ m : ℕ, w m) (list.range n) = list.map (λ m : ℕ, v m) (list.range n) :=
  list.map_congr (λ k hk,
    have hk' : k < n := list.mem_range.1 hk,
    hw.2 ▸ (show _ = dite _ _ _,
      by rw [Zmod.cast_val_nat, nat.mod_eq_of_lt (nat.lt_succ_of_lt hk'), dif_pos hk'])),
  begin
    show list.prod (list.map (λ (m : ℕ), v ↑m) (list.range (n + 1))) = 1,
    rw [prod_lemma, ← h, ← hw.2],
    show _ * dite _ _ _ = (1 : G),
    rw [Zmod.cast_val_nat, nat.mod_eq_of_lt (nat.lt_succ_self _), dif_neg (lt_irrefl _),
      mul_inv_self],
  end⟩

def rotate (α : Type v) (n : ℕ) (i : multiplicative (Zmod n)) (v : multiplicative (Zmod n) → α)
  (m : multiplicative (Zmod n)) := v (m * i)

instance rotate.is_group_action (n : ℕ) [pos_nat n] :
  is_group_action (rotate α n) :=
{ mul := λ x y v, funext (λ i, show v (i * (x * y)) = v (i * x * y), by rw mul_assoc),
  one := λ v, funext (λ i, show v (i * 1) = v i, by rw mul_one) }

lemma fixed_points_rotate_eq_const {n : ℕ} [h0 : pos_nat n] {v : multiplicative (Zmod n) → G}
  (h : v ∈ fixed_points (rotate G n)) (i j : multiplicative (Zmod n)) : v i = v j :=
calc v i = v (j * i) : mul_comm i j ▸ (congr_fun ((mem_fixed_points'.1 h _) (mem_orbit (rotate G n) v j)) i).symm
... = v j : congr_fun ((mem_fixed_points'.1 h _) (mem_orbit (rotate G n) v i)) j

lemma map_succ_range : ∀ n : ℕ, list.range (nat.succ n) = 0 :: (list.range n).map nat.succ
| 0 := rfl
| (n+1) := by rw [list.range_concat, list.range_concat, list.map_append,
  ← list.cons_append, ← map_succ_range, list.range_concat, list.map_singleton]

open nat

lemma list.prod_const [monoid α] : ∀ {l : list α} {a : α}, (∀ b ∈ l, b = a) → l.prod = a ^ l.length
| [] := λ _ _, rfl
| (b::l) := λ a ha,
have h : ∀ b ∈ l, b = a := λ b hb, ha b (list.mem_cons_of_mem _ hb),
have hb : b = a := ha b (list.mem_cons_self _ _),
by simp [_root_.pow_add, list.prod_const h, hb]

lemma rotate_on_vectors_prod_eq_one {n : ℕ} [h0 : pos_nat n] {v : Zmod n → G}
  (hv : v ∈ vectors_prod_eq_one G n) (i : Zmod n) :
  (rotate G n) (i : Zmod n) v ∈ vectors_prod_eq_one G n :=
begin
  cases i with i hi,
  rw Zmod.mk_eq_cast,
  clear hi,
  induction i with i ih,
  { show list.prod (list.map (λ (m : ℕ), v (m + 0)) (list.range n)) = 1,
    simpa },
  { show list.prod (list.map (λ (m : ℕ), v (m + (i + 1))) (list.range n)) = 1,
    replace ih : list.prod (list.map (λ (m : ℕ), v (m + i)) (list.range n)) = 1 := ih,
    resetI,
    cases n,
    { simp [list.range, list.range_core] },
    { rw [list.range_concat, list.map_append, list.prod_append, list.map_singleton,
        list.prod_cons, list.prod_nil, mul_one] at ⊢ ih,
      have h : list.map (λ m : ℕ, v (↑m + (i + 1))) (list.range n) =
        list.map (λ m : ℕ, v (m + i)) (list.map (λ m : ℕ, m + 1) (list.range n)),
      { simp [list.map_map, function.comp] },
      resetI,
      cases n,
      { rw ← ih, congr },
      { have h : list.map (λ m : ℕ, v (↑m + (i + 1))) (list.range n) =
          list.map (λ m : ℕ, v (m + i)) (list.map succ (list.range n)),
        { simp [list.map_map, function.comp] },
        have h₁ : (succ n : Zmod (succ (succ n))) + (↑i + 1) = i,
        { rw [add_left_comm, ← nat.cast_one, ← nat.cast_add, Zmod.cast_self_eq_zero, add_zero] },
        have h₂ : (n : Zmod (succ (succ n))) + i + 1 = succ n + i := by simp [succ_eq_add_one],
        rw [map_succ_range, list.map_cons, list.prod_cons, ← h, nat.cast_zero, zero_add] at ih,
        have := eq_inv_mul_of_mul_eq ih,
        rw [list.range_concat, list.map_append, list.map_singleton, list.prod_append,
          list.prod_cons, list.prod_nil, mul_one, ← add_assoc, h₁, h₂, this],
        simp } } }
end

def rotate_vectors_prod_eq_one (G : Type u) [group G] (n : ℕ) [pos_nat n] (i : multiplicative (Zmod n))
  (v : vectors_prod_eq_one G n) : vectors_prod_eq_one G n := ⟨rotate _ n i v.1, rotate_on_vectors_prod_eq_one v.2 _⟩

instance (n : ℕ) [pos_nat n] : is_group_action (rotate_vectors_prod_eq_one G n) :=
{ one := λ ⟨a, ha⟩, subtype.eq (is_monoid_action.one (rotate G n) _),
  mul := λ x y ⟨a, ha⟩, subtype.eq (is_monoid_action.mul (rotate G n) _ _ _) }

lemma mem_fixed_points_rotate_vectors_prod_eq_one {n : ℕ} [pos_nat n]
  : ∀ {v : vectors_prod_eq_one G n}, v ∈ fixed_points (rotate_vectors_prod_eq_one G n) ↔ (v : Zmod n → G) ∈ fixed_points (rotate G n) :=
λ ⟨v, hv⟩, ⟨λ h x, subtype.mk.inj (h x), λ h x, subtype.eq (h x)⟩

lemma fixed_points_rotate_pow_n [fintype G] {n : ℕ} (hn : nat.prime (succ n))
  [h0 : pos_nat n] : ∀ {v : vectors_prod_eq_one G (succ n)}
  (hv : v ∈ fixed_points (rotate_vectors_prod_eq_one G (succ n))), (v : Zmod (succ n) → G) 0 ^ (n + 1) = 1 :=
λ ⟨v, hv₁⟩ hv,
let ⟨w, hw⟩ := (mem_vectors_prod_eq_one_iff _).1 hv₁ in
have hv' : (v : Zmod (succ n) → G) ∈ fixed_points (rotate G (succ n)) :=
  λ i, subtype.mk.inj (mem_stabilizer_iff.1 (hv i)),
begin
  have h₁ : dite _ _ _ = (v : Zmod (succ n) → G) _ := congr_fun hw.2 ⟨n, nat.lt_succ_self n⟩,
  rw dif_neg (lt_irrefl _) at h₁,
  have h₂ : ∀ b, b < n → w b = (v : Zmod (succ n) → G) b := λ b hb, begin
    have : dite _ _ _ = _ := congr_fun hw.2 b,
    rwa [Zmod.cast_val_of_lt (lt_succ_of_lt hb), dif_pos hb] at this,
  end,
  have hb : ∀ (b : G), b ∈ list.map (λ (m : ℕ), w ↑m) (list.range n) → b = w 0 := λ b hb,
    let ⟨i, hi⟩ := list.mem_map.1 hb in
    by rw [← hi.2, h₂ _ (list.mem_range.1 hi.1), fixed_points_rotate_eq_const hv' _ 1];
      exact (h₂ 0 h0.pos).symm,
  refine (@mul_left_inj _ _ (w 0 ^ (-n : ℤ)) _ _).1 _,
  rw [@list.prod_const _ _ _ (w 0) hb, list.length_map, list.length_range, ← gpow_coe_nat, ← gpow_neg] at h₁,
  conv { to_rhs, rw [h₁, fixed_points_rotate_eq_const hv' _ 1] },
  rw [← nat.cast_zero, h₂ 0 h0.pos, nat.cast_zero, subtype.coe_mk, ← gpow_coe_nat, ← _root_.gpow_add, int.coe_nat_add],
  simp, refl,
end

lemma one_mem_fixed_points_rotate [fintype G] {n : ℕ} [h0 : pos_nat n] :
  (1 : Zmod n → G) ∈ fixed_points (rotate G n) :=
mem_fixed_points'.2 (λ y hy, funext (λ j,
  let ⟨i, hi⟩ := mem_orbit_iff.1 hy in
  have hj : (1 : G) = y j := congr_fun hi j,
    hj ▸ rfl))

lemma one_mem_vectors_prod_eq_one (n : ℕ) [pos_nat n] : (1 : Zmod n → G) ∈ vectors_prod_eq_one G n :=
show list.prod (list.map (λ (m : ℕ), (1 : G)) (list.range n)) = 1,
from have h : ∀ b : G, b ∈ list.map (λ (m : ℕ), (1 : G)) (list.range n) → b = 1 :=
λ b hb, let ⟨_, h⟩ := list.mem_map.1 hb in h.2.symm,
by simp [list.prod_const h]

attribute [trans] dvd.trans

lemma exists_prime_order_of_dvd_card [fintype G] {p : ℕ} (hp : nat.prime p)
  (hdvd : p ∣ card G) : ∃ x : G, order_of x = p :=
let n := p - 1 in
have hn : p = n + 1 := nat.succ_sub hp.pos,
have hnp : nat.prime (n + 1) := hn ▸ hp,
have hn0 : pos_nat n := ⟨nat.lt_of_succ_lt_succ hnp.gt_one⟩,
have hlt : ¬(n : Zmod (n + 1)).val < n :=
  not_lt_of_ge (by rw [Zmod.cast_val_nat, nat.mod_eq_of_lt (nat.lt_succ_self _)];
    exact le_refl _),
have hcard1 : card (vectors_prod_eq_one G (n + 1)) = card (Zmod n → G) :=
  by rw [← set.card_univ (Zmod n → G), set.ext (@mem_vectors_prod_eq_one_iff _ _ _ hn0),
    set.card_image_of_injective _ mk_vector_prod_eq_one_injective],
have hcard : card (vectors_prod_eq_one G (n + 1)) = card G ^ n :=
  by conv { rw hcard1, to_rhs, rw ← card_fin n };
    exact fintype.card_fun,
have fintype (multiplicative (Zmod (succ n))) := fin.fintype _,
have pos_nat (succ n) := ⟨succ_pos _⟩,
have hZmod : @fintype.card (multiplicative (Zmod (succ n))) (fin.fintype _) =
  (n+1) ^ 1 := (nat.pow_one (n + 1)).symm ▸ card_fin _,
by exactI
have hmodeq : _ = _ := @card_modeq_card_fixed_points _ _ _ (rotate_vectors_prod_eq_one G (succ n)) _ _ _ _ _ 1 hnp hZmod,
have hdvdcard : (n + 1) ∣ card (vectors_prod_eq_one G (n + 1)) :=
  calc (n + 1) = p : hn.symm
  ... ∣ card G ^ 1 : by rwa nat.pow_one
  ... ∣ card G ^ n : nat.pow_dvd_pow _ hn0.pos
  ... = card (vectors_prod_eq_one G (n + 1)) : hcard.symm,
have hdvdcard₂ : (n + 1) ∣ card (fixed_points (rotate_vectors_prod_eq_one G (succ n))) :=
  nat.dvd_of_mod_eq_zero (hmodeq ▸ (nat.mod_eq_zero_of_dvd hdvdcard)),
have hcard_pos : 0 < card (fixed_points (rotate_vectors_prod_eq_one G (succ n))) :=
  fintype.card_pos_iff.2 ⟨⟨⟨(1 : Zmod (succ n) → G), one_mem_vectors_prod_eq_one _⟩,
    λ x, subtype.eq (one_mem_fixed_points_rotate x)⟩⟩,
have hle : 1 < card (fixed_points (rotate_vectors_prod_eq_one G (succ n))) :=
  calc 1 < n + 1 : hnp.gt_one
  ... ≤ _ : nat.le_of_dvd hcard_pos hdvdcard₂,
let ⟨⟨x, hx₁⟩, hx₂⟩ := classical.not_forall.1 (mt fintype.card_le_one_iff.2 (not_le_of_gt hle)) in
let ⟨⟨y, hy₁⟩, hy₂⟩ := classical.not_forall.1 hx₂ in
have hxy : (x : Zmod (succ n) → G) 0 ≠ 1 ∨ (y : Zmod (succ n) → G) 0 ≠ 1 :=
  or_iff_not_imp_left.2
  (λ hx1 hy1, hy₂ $ subtype.eq $ subtype.eq $ funext $ λ i,
  show (x : Zmod (succ n) → G) i = (y : Zmod (succ n) → G) i,
  by rw [fixed_points_rotate_eq_const ((mem_fixed_points_rotate_vectors_prod_eq_one).1 hx₁) _ (0 : Zmod (succ n)),
    fixed_points_rotate_eq_const ((mem_fixed_points_rotate_vectors_prod_eq_one).1 hy₁) _ (0 : Zmod (succ n)),
    not_not.1 hx1, hy1]),
have hxp : (x : Zmod (succ n) → G) 0 ^ (n + 1) = 1 := @fixed_points_rotate_pow_n _ _ _ _ hnp hn0 _ hx₁,
have hyp : (y : Zmod (succ n) → G) 0 ^ (n + 1) = 1 := @fixed_points_rotate_pow_n _ _ _ _ hnp hn0 _ hy₁,
begin
  rw hn,
  cases hxy with hx hy,
  { existsi (x : Zmod (succ n) → G) 0,
    exact or.resolve_left (hnp.2 _ (order_of_dvd_of_pow_eq_one hxp))
      (λ h, hx (eq_one_of_order_of_eq_one h)) },
  { existsi (y : Zmod (succ n) → G) 0,
    exact or.resolve_left (hnp.2 _ (order_of_dvd_of_pow_eq_one hyp))
      (λ h, hy (eq_one_of_order_of_eq_one h)) }
end

local attribute [instance] left_rel set_fintype
open is_subgroup is_submonoid is_group_hom

def mul_left_cosets (L₁ L₂ : set G) [is_subgroup L₂] [is_subgroup L₁]
  (x : L₂) (y : left_cosets L₁) : left_cosets L₁ :=
quotient.lift_on y (λ y, ⟦(x : G) * y⟧)
  (λ a b (hab : _ ∈ L₁), quotient.sound
    (show _ ∈ L₁, by rwa [mul_inv_rev, ← mul_assoc, mul_assoc (a⁻¹), inv_mul_self, mul_one]))

instance mul_left_cosets.is_group_action (L₁ L₂ : set G) [is_subgroup L₂] [is_subgroup L₁] :
  is_group_action (mul_left_cosets L₁ L₂) :=
{ one := λ a, quotient.induction_on a (λ a, quotient.sound (show (1 : G) * a ≈ a, by simp)),
  mul := λ x y a, quotient.induction_on a (λ a, quotient.sound (by rw ← mul_assoc; refl)) }

lemma mem_fixed_points_mul_left_cosets_iff_mem_normalizer {H : set G} [is_subgroup H] [fintype H]
  {x : G} : ⟦x⟧ ∈ fixed_points (mul_left_cosets H H) ↔ x ∈ normalizer H :=
⟨λ hx, have ha : ∀ {y : left_cosets H}, y ∈ orbit (mul_left_cosets H H) ⟦x⟧ → y = ⟦x⟧ := λ _,
    (mem_fixed_points'.1 hx _),
  (inv_mem_iff _).1 (mem_normalizer_fintype (λ n hn,
    have (n⁻¹ * x)⁻¹ * x ∈ H := quotient.exact (ha (mem_orbit (mul_left_cosets H H) _
      ⟨n⁻¹, inv_mem hn⟩)),
    by simpa only [mul_inv_rev, inv_inv] using this)),
λ (hx : ∀ (n : G), n ∈ H ↔ x * n * x⁻¹ ∈ H),
mem_fixed_points'.2 $ λ y, quotient.induction_on y $ λ y hy, quotient.sound
  (let ⟨⟨b, hb₁⟩, hb₂⟩ := hy in
  have hb₂ : (b * x)⁻¹ * y ∈ H := quotient.exact hb₂,
  (inv_mem_iff H).1 $ (hx _).2 $ (mul_mem_cancel_right H (inv_mem hb₁)).1
  $ by rw hx at hb₂;
    simpa [mul_inv_rev, mul_assoc] using hb₂)⟩

lemma fixed_points_mul_left_cosets_equiv_cosets (H : set G) [is_subgroup H] [fintype H] :
  fixed_points (mul_left_cosets H H) ≃ left_cosets {x : normalizer H | ↑x ∈ H} :=
{ to_fun := λ a, quotient.hrec_on a.1 (λ a ha, @quotient.mk _
  (left_rel {x : normalizer H | ↑x ∈ H}) ⟨a, mem_fixed_points_mul_left_cosets_iff_mem_normalizer.1 ha⟩)
    (λ x y hxy, function.hfunext (by rw quotient.sound hxy)
      (λ hx hy _, heq_of_eq (@quotient.sound _ (left_rel {x : normalizer H | ↑x ∈ H})
        _ _ (by exact hxy)))) a.2,
  inv_fun := λ x, ⟨@quotient.lift_on _ _ (left_rel {x : normalizer H | ↑x ∈ H}) x
     (λ x, show (↥(fixed_points (mul_left_cosets H H)) : Type u),
       from ⟨⟦x⟧, mem_fixed_points_mul_left_cosets_iff_mem_normalizer.2 x.2⟩)
     (λ ⟨x, hx⟩ ⟨y, hy⟩ (hxy : x⁻¹ * y ∈ H), subtype.eq (quotient.sound hxy)),
     (@quotient.induction_on _  (left_rel {x : normalizer H | ↑x ∈ H}) _ x
       (by intro x; cases x with x hx;
         exact mem_fixed_points_mul_left_cosets_iff_mem_normalizer.2 hx))⟩,
  left_inv := λ ⟨x, hx⟩, by revert hx;
    exact quotient.induction_on x (by intros; refl),
  right_inv := λ x, @quotient.induction_on _
    (left_rel {x : normalizer H | ↑x ∈ H}) _ x
      (by intro x; cases x; refl) }

lemma exists_subgroup_card_pow_prime [fintype G] {p : ℕ} : ∀ {n : ℕ} (hp : nat.prime p)
  (hdvd : p ^ n ∣ card G), ∃ H : set G, is_subgroup H ∧ card H = p ^ n
| 0 := λ _ _, ⟨trivial G, by apply_instance, by simp [-set.set_coe_eq_subtype]⟩
| (n+1) := λ hp hdvd,
let ⟨H, ⟨hH1, hH2⟩⟩ := exists_subgroup_card_pow_prime hp (dvd.trans (pow_dvd_pow _ (le_succ _)) hdvd) in
let ⟨s, hs⟩ := exists_eq_mul_left_of_dvd hdvd in
by exactI
have hcard : card (left_cosets H) = s * p :=
  (nat.mul_right_inj (show card H > 0, from fintype.card_pos_iff.2 ⟨⟨1, is_submonoid.one_mem H⟩⟩)).1
    (by rwa [← card_eq_card_cosets_mul_card_subgroup, hH2, hs, nat.pow_succ, mul_assoc, mul_comm p]),
have hm : s * p % p = card (left_cosets {x : normalizer H | ↑x ∈ H}) % p :=
  card_congr (fixed_points_mul_left_cosets_equiv_cosets H) ▸ hcard ▸
    card_modeq_card_fixed_points _ hp hH2,
have hm' : p ∣ card (left_cosets {x : normalizer H | ↑x ∈ H}) :=
  nat.dvd_of_mod_eq_zero
    (by rwa [nat.mod_eq_zero_of_dvd (dvd_mul_left _ _), eq_comm] at hm),
let ⟨x, hx⟩ := exists_prime_order_of_dvd_card hp hm' in
have hxcard : card (gpowers x) = p := by rwa ← order_eq_card_gpowers,
let S : set ↥(normalizer H) := set.preimage (@quotient.mk _
    (left_rel {x : ↥(normalizer H) | ↑x ∈ H}))
      (@gpowers (left_cosets {x : ↥(normalizer H) | ↑x ∈ H}) _ x) in
have is_subgroup S := @is_group_hom.preimage _
  (left_cosets {x : ↥(normalizer H) | ↑x ∈ H}) _ _ _ _ _ _,
have fS : fintype S := by apply_instance,
let hequiv : {x : ↥(normalizer H) | ↑x ∈ H} ≃ H :=
  { to_fun := λ ⟨x, hx⟩, ⟨x, hx⟩,
    inv_fun := λ ⟨x, hx⟩, ⟨⟨x, subset_normalizer _ hx⟩, hx⟩,
    left_inv := λ ⟨⟨_, _⟩, _⟩, rfl,
    right_inv := λ ⟨_, _⟩, rfl } in
⟨subtype.val '' S, by apply_instance,
by dsimp only [S];
  rw [set.card_image_of_injective _ subtype.val_injective, nat.pow_succ,
    @card_congr _ _ fS _ (preimage_quotient_mk_equiv_subgroup_times_set _ _),
    card_prod, hxcard, ← hH2, card_congr hequiv]⟩

def conjugate_set (x : G) (H : set G) : set G :=
(λ n, x⁻¹ * n * x) ⁻¹' H

lemma conjugate_set_eq_image (H : set G) (x : G) :
  conjugate_set x H = (λ n, x * n * x⁻¹) '' H :=
eq.symm (congr_fun (set.image_eq_preimage_of_inverse
  (λ _, by simp [mul_assoc]) (λ _, by simp [mul_assoc])) _)

lemma conjugate_set_eq_preimage (H : set G) (x : G) :
  conjugate_set x H = (λ n, x⁻¹ * n * x) ⁻¹' H := rfl

instance conjugate_set.is_group_action : is_group_action (@conjugate_set G _) :=
{ one := λ H, by simp [conjugate_set_eq_image, set.image],
  mul := λ x y H, by simp [mul_inv_rev, mul_assoc, function.comp, conjugate_set_eq_preimage,
    set.preimage] }

@[simp] lemma conjugate_set_normal_subgroup (H : set G) [normal_subgroup H] (x : G) :
  conjugate_set x H = H :=
set.ext (λ n, ⟨λ h : _ ∈ H, by have := normal_subgroup.normal _ h x; simpa [mul_assoc] using this,
λ h, show _ ∈ H, by have := normal_subgroup.normal _ h (x⁻¹); by simpa using this⟩)

instance is_group_action.subgroup (H : set G) [is_subgroup H] (f : G → α → α) [is_group_action f] :
  is_group_action (λ x : H, f x) :=
{ one := λ a, is_monoid_action.one f a,
  mul := λ ⟨x, hx⟩ ⟨y, hy⟩ a, is_monoid_action.mul f x y a }

instance is_group_hom_conj (x : G) : is_group_hom (λ (n : G), x * n * x⁻¹) :=
⟨by simp [mul_assoc]⟩

instance is_subgroup_conj (x : G) (H : set G) [is_subgroup H] :
  is_subgroup (conjugate_set x H) :=
by rw conjugate_set_eq_image; apply_instance

/-- `dlogn p a` gives the maximum value of `n` such that `p ^ n ∣ a` -/
def dlogn (p : ℕ) : ℕ → ℕ
| 0     := 0
| (a+1) := if h : p > 1 then
  have (a + 1) / p < a + 1, from div_lt_self dec_trivial h,
    if p ∣ (a + 1) then dlogn ((a + 1) / p) + 1 else 0
  else 0

lemma dlogn_dvd {p : ℕ} : ∀ a, p > 1 → p ^ dlogn p a ∣ a
| 0     := λ _, dvd_zero _
| (a+1) := λ h,
have (a + 1) / p < a + 1, from div_lt_self dec_trivial h,
begin
  rw [dlogn, if_pos h],
  split_ifs with hd,
  { rw nat.pow_succ,
    conv { to_rhs, rw ← nat.div_mul_cancel hd },
    exact mul_dvd_mul (dlogn_dvd _ h) (dvd_refl _) },
  { simp }
end

lemma not_dvd_of_gt_dlogn {p : ℕ} : ∀ {a m}, a > 0 → p > 1 → m > dlogn p a → ¬p ^ m ∣ a
| 0     := λ m h, (lt_irrefl _ h).elim
| (a+1) := λ m h hp hm ,
have (a + 1) / p < a + 1, from div_lt_self dec_trivial hp,
begin
  rw [dlogn, if_pos hp] at hm,
  split_ifs at hm with hd,
  { have hmsub : succ (m - 1) = m :=
      succ_sub (show 1 ≤ m, from (lt_of_le_of_lt (nat.zero_le _) hm)) ▸
      (succ_sub_one m).symm,
    have := @not_dvd_of_gt_dlogn ((a + 1) / p) (m - 1)
      (pos_of_mul_pos_left (by rw nat.mul_div_cancel' hd; exact nat.succ_pos _) (nat.zero_le p))
      hp (lt_of_succ_lt_succ (hmsub.symm ▸ hm)),
    rwa [← nat.mul_dvd_mul_iff_right (lt_trans dec_trivial hp), nat.div_mul_cancel hd,
      ← nat.pow_succ, hmsub] at this },
  { assume h,
    exact hd (calc p = p ^ 1 : (nat.pow_one _).symm
      ... ∣ p ^ m : nat.pow_dvd_pow p hm
      ... ∣ a + 1 : h) }
end

lemma pow_dvd_of_dvd_mul {p : ℕ} : ∀ {m n k : ℕ} (hp : prime p) (hd : p ^ m ∣ n * k) (hk : ¬p ∣ k),
  p ^ m ∣ n
| 0     := by simp
| (m+1) := λ n k hp hd hk,
have hpnk : p ∣ n * k := calc p = p ^ 1 : by rw nat.pow_one
  ... ∣ p ^ (m + 1) : nat.pow_dvd_pow _ (succ_pos _)
  ... ∣ n * k : by assumption,
have hpn : p ∣ n := or.resolve_right (hp.dvd_mul.1 hpnk) hk,
have p ^ m ∣ (n / p) * k := dvd_of_mul_dvd_mul_right hp.pos $
  by rwa [mul_right_comm, nat.div_mul_cancel hpn, ← nat.pow_succ],
by rw [nat.pow_succ, ← nat.div_mul_cancel hpn];
  exact mul_dvd_mul_right (pow_dvd_of_dvd_mul hp this hk) _

lemma eq_dlogn_of_dvd_of_succ_not_dvd {a p n : ℕ} (hp : 1 < p) (h₁ : p ^ n ∣ a) (h₂ : ¬p ^ succ n ∣ a) :
  n = dlogn p a :=
have ha : 0 < a := nat.pos_of_ne_zero (λ h, by simpa [h] using h₂),
le_antisymm (le_of_not_gt $ λ h, not_dvd_of_gt_dlogn ha hp h h₁)
  (le_of_not_gt $ λ h, h₂ $ calc p ^ succ n ∣ p ^ dlogn p a : nat.pow_dvd_pow _ h
    ... ∣ _ : dlogn_dvd _ hp)

lemma dlogn_eq_of_not_dvd {a b p  : ℕ} (hp : prime p) (hpb : ¬p ∣ b) : dlogn p a = dlogn p (a * b) :=
if ha : a = 0 then by simp [ha, dlogn] else
eq_dlogn_of_dvd_of_succ_not_dvd hp.gt_one (dvd.trans (dlogn_dvd _ hp.gt_one) (dvd_mul_right _ _))
  (λ h, not_dvd_of_gt_dlogn (nat.pos_of_ne_zero ha)
  hp.gt_one (lt_succ_self _) (pow_dvd_of_dvd_mul hp h hpb))

lemma not_dvd_div_dlogn {p a : ℕ} (ha : a > 0) (hp : p > 1) : ¬p ∣ a / (p ^ dlogn p a) :=
by rw [← nat.mul_dvd_mul_iff_left (nat.pos_pow_of_pos (dlogn p a) (lt_trans dec_trivial hp)),
    nat.mul_div_cancel' (dlogn_dvd _ hp), ← nat.pow_succ];
  exact not_dvd_of_gt_dlogn ha hp (lt_succ_self _)

class is_sylow [fintype G] (H : set G) {p : ℕ} (hp : prime p) extends is_subgroup H : Prop :=
(card_eq : card H = p ^ dlogn p (card G))

instance is_subgroup_in_subgroup (H K : set G) [is_subgroup H] [is_subgroup K] :
  is_subgroup {x : K | (x : G) ∈ H} :=
{ one_mem := show _ ∈ H, from one_mem _,
  mul_mem := λ x y hx hy, show x.1 * y.1 ∈ H, from mul_mem hx hy,
  inv_mem := λ x hx, show x.1⁻¹ ∈ H, from inv_mem hx }

lemma exists_sylow_subgroup (G : Type u) [group G] [fintype G] {p : ℕ} (hp : prime p) :
  ∃ H : set G, is_sylow H hp :=
let ⟨H, ⟨hH₁, hH₂⟩⟩ := exists_subgroup_card_pow_prime hp (dlogn_dvd (card G) hp.gt_one) in
by exactI ⟨H, by split; assumption⟩

lemma card_sylow [fintype G] (H : set G) [f : fintype H] {p : ℕ} (hp : prime p) [is_sylow H hp] :
  card H = p ^ dlogn p (card G) :=
by rw ← is_sylow.card_eq H hp; congr

lemma is_sylow_in_subgroup [fintype G] (H K : set G) {p : ℕ} (hp : prime p) [is_sylow H hp] (hsub : H ⊆ K)
  [is_subgroup K] : is_sylow {x : K | (x : G) ∈ H} hp :=
{ card_eq :=
  have h₁ : H = subtype.val '' {x : K | (x : G) ∈ H},
    from set.ext $ λ x, ⟨λ h, ⟨⟨x, hsub h⟩, ⟨h, rfl⟩⟩, λ ⟨y, hy⟩, hy.2 ▸ hy.1⟩,
  have h₂ : card K * (card G / card K) = card G := nat.mul_div_cancel'
    ((card_eq_card_cosets_mul_card_subgroup K).symm ▸ dvd_mul_left _ _),
  have h₃ : ∀ {f : fintype {x : K | (x : G) ∈ H}}, @fintype.card {x : K | (x : G) ∈ H} f
    = card H := λ f, by exactI
    calc @fintype.card {x : K | (x : G) ∈ H} f = card (subtype.val '' {x : K | (x : G) ∈ H}) :
      by exact (set.card_image_of_injective _ subtype.val_injective).symm
    ... = card H : set.card_eq_of_eq h₁.symm,
  calc _ = _ : h₃
  ... = p ^ dlogn p (card G) : card_sylow H hp
  ... = p ^ dlogn p (card K) : congr_arg _ (h₂ ▸ eq.symm begin
    refine dlogn_eq_of_not_dvd hp (λ h, _),
    have h₄ := mul_dvd_mul_left (card K) h,
    rw [h₂, card_eq_card_cosets_mul_card_subgroup {x : K | (x : G) ∈ H}, h₃, card_sylow H hp,
      mul_assoc, ← nat.pow_succ] at h₄,
    exact not_dvd_of_gt_dlogn (fintype.card_pos_iff.2 ⟨(1 : G)⟩) hp.gt_one (lt_succ_self _)
      (dvd_of_mul_left_dvd h₄),
  end),
  ..sylow.is_subgroup_in_subgroup H K }

lemma sylow_conjugate [fintype G] {p : ℕ} (hp : prime p)
  (H K : set G) [is_sylow H hp] [is_sylow K hp] :
  ∃ g : G, H = conjugate_set g K :=
have hs : card (left_cosets K) = card G / (p ^ dlogn p (card G)) :=
  (nat.mul_right_inj (pos_pow_of_pos (dlogn p (card G)) hp.pos)).1
  $ by rw [← card_sylow K hp, ← card_eq_card_cosets_mul_card_subgroup, card_sylow K hp,
    nat.div_mul_cancel (dlogn_dvd _ hp.gt_one)],
have hmodeq : card G / (p ^ dlogn p (card G)) ≡ card (fixed_points (mul_left_cosets K H)) [MOD p] :=
  hs ▸ card_modeq_card_fixed_points (mul_left_cosets K H) hp (card_sylow H hp),
have hfixed : 0 < card (fixed_points (mul_left_cosets K H)) := nat.pos_of_ne_zero
  (λ h, (not_dvd_div_dlogn (fintype.card_pos_iff.2 ⟨(1 : G)⟩) hp.gt_one)
    $ by rwa [h, nat.modeq.modeq_zero_iff] at hmodeq),
let ⟨⟨x, hx⟩⟩ := fintype.card_pos_iff.1 hfixed in
begin
  haveI : is_subgroup K := by apply_instance,
  revert hx,
  refine quotient.induction_on x
    (λ x hx, ⟨x, set.eq_of_card_eq_of_subset _ _⟩),
  { rw [conjugate_set_eq_image, set.card_image_of_injective _ conj_inj_left,
    card_sylow K hp, card_sylow H hp] },
  { assume y hy,
    have : (y⁻¹ * x)⁻¹ * x ∈ K := quotient.exact
      (mem_fixed_points'.1 hx ⟦y⁻¹ * x⟧ ⟨⟨y⁻¹, inv_mem hy⟩, rfl⟩),
    simp [conjugate_set_eq_preimage, set.preimage, mul_inv_rev, *, mul_assoc] at * }
end

def conj_on_sylow [fintype G] {p : ℕ} (hp : nat.prime p)
  : Π (x : G) (H : {H : set G // is_sylow H hp}), {H : set G // is_sylow H hp} :=
λ x ⟨H, hH⟩, ⟨conjugate_set x H, by exactI
have h : is_subgroup (conjugate_set x H) := @sylow.is_subgroup_conj _ _ _ _ _,
{ card_eq := by exactI by
  rw [← card_sylow H hp, conjugate_set_eq_image, set.card_image_of_injective _ conj_inj_left],
  ..h }⟩

instance conj_on_sylow.is_group_action [fintype G] {p : ℕ} (hp : prime p) :
  is_group_action (@conj_on_sylow G _ _ _ hp) :=
{ one := λ ⟨H, hH⟩, by simp [conj_on_sylow, conjugate_set_eq_preimage, set.preimage],
  mul := λ x y ⟨H, hH⟩, by simp! [mul_inv_rev, mul_assoc, function.comp,
      conjugate_set_eq_image, (set.image_comp _ _ _).symm, conj_on_sylow] }

lemma card_sylow_dvd [fintype G] {p : ℕ} (hp : prime p) :
  card {H : set G // is_sylow H hp} ∣ card G :=
let ⟨H, hH⟩ := exists_sylow_subgroup G hp in
have h : orbit (conj_on_sylow hp) ⟨H, hH⟩ = set.univ :=
  set.eq_univ_iff_forall.2 (λ S, mem_orbit_iff.2 $
  let ⟨x, (hx : S.val = _)⟩ := @sylow_conjugate _ _ _ _ hp S.1 H S.2 hH in
  ⟨x, subtype.eq (hx.symm ▸ rfl)⟩),
have is_subgroup (stabilizer (conj_on_sylow hp) ⟨H, hH⟩) := by apply_instance,
by exactI
have orbit_equiv : card (orbit (conj_on_sylow hp) ⟨H, hH⟩) =
  fintype.card (left_cosets (stabilizer (conj_on_sylow hp) ⟨H, hH⟩)) :=
   card_congr (orbit_equiv_left_cosets (conj_on_sylow hp) (⟨H, hH⟩ : {H : set G // is_sylow H hp})),
by exactI begin
  rw [h, ← card_congr (set.equiv_univ _)] at orbit_equiv,
  rw [orbit_equiv, card_congr (@group_equiv_left_cosets_times_subgroup _ _
    (stabilizer (conj_on_sylow hp) ⟨H, hH⟩) (by apply_instance)), card_prod],
  exact dvd_mul_right _ _
end

lemma card_sylow_modeq_one [fintype G] {p : ℕ} (hp : prime p) :
  card {H : set G // is_sylow H hp} ≡ 1 [MOD p] :=
let ⟨H, hH⟩ := exists_sylow_subgroup G hp in
by exactI
eq.trans
(card_modeq_card_fixed_points (λ x : H, conj_on_sylow hp (x : G)) hp (card_sylow H hp))
begin
  refine congr_fun (show (%) _ = (%) 1,
    from congr_arg _ (fintype.card_eq_one_iff.2 _)) p,
  refine ⟨(⟨(⟨H, hH⟩ :  {H // is_sylow H hp}), λ ⟨x, hx⟩, subtype.eq $
    set.ext (λ i, by simp [conj_on_sylow, conjugate_set_eq_preimage, mul_mem_cancel_left _ hx,
      mul_mem_cancel_right _ (inv_mem hx)])⟩ :
        subtype (fixed_points (λ (x : ↥H), conj_on_sylow hp ↑x))), _⟩,
  refine λ L, subtype.eq (subtype.eq _),
  rcases L with ⟨⟨L, hL₁⟩, hL₂⟩,
  have Hsub : H ⊆ normalizer L,
  { assume x hx n,
    conv {to_rhs, rw ← subtype.mk.inj (hL₂ ⟨x, hx⟩)},
    simp [conjugate_set, mul_assoc] },
  suffices : ∀ x, x ∈ {x : normalizer L | (x : G) ∈ L} ↔ x ∈ {x : normalizer L | (x : G) ∈ H},
  { exact set.ext (λ x, ⟨λ h, (this ⟨x, subset_normalizer _ h⟩).1 h, λ h, (this ⟨x, Hsub h⟩).2 h⟩) },
  assume x,
  haveI := is_sylow_in_subgroup L (normalizer L) hp (subset_normalizer L),
  haveI := is_sylow_in_subgroup H (normalizer L) hp Hsub,
  cases sylow_conjugate hp {x : normalizer L | (x : G) ∈ H} {x | (x : G) ∈ L} with x hx,
  simp [hx]
end

end sylow


import analysis.topology.continuity
import analysis.topology.topological_space
import analysis.topology.infinite_sum
import analysis.topology.topological_structures
import analysis.topology.uniform_space

universe u

open set filter lattice classical

#print definition set

#check empty
def empty_topology : topological_space empty :=
{
is_open := λ (a : set empty),
true, is_open_univ := begin trivial, end,
is_open_inter := begin intros h1 h2 h3 h4, trivial end,
is_open_sUnion := begin intros h1 h2, trivial end
}
#print univ
#check empty_topology.is_open

--Exercise 4. Let X be a non-empty set and let T1 and T2 be topologies on X. 1. Must T1 ∩ T2 be a topology on X? 2. Must T1 ∪ T2 be a topology on X?

#print set

definition is_open_sets {α : Type u} (is_open : set α → Prop) :=
  is_open univ ∧ (∀s t, is_open s → is_open t → is_open (s ∩ t)) ∧ (∀s, (∀t∈s, is_open t) → is_open (⋃₀ s))

definition is_to_top {α : Type u} (is_open : set α → Prop) (H : is_open_sets (is_open)) : topological_space α :=
{ is_open := is_open,
  is_open_univ := H.left,
  is_open_inter := H.right.left,
  is_open_sUnion := H.right.right
}

definition top_to_is {α : Type u} (T : topological_space α) : is_open_sets (T.is_open) :=
⟨T.is_open_univ,T.is_open_inter,T.is_open_sUnion⟩

theorem exercisefoura {α : Type u} {T1_sets T2_sets : set α → Prop} : is_open_sets T1_sets → is_open_sets T2_sets → is_open_sets (λ (a : set α), and (T1_sets a) (T2_sets a)) :=
begin
intros H1 H2,
unfold is_open_sets,
split,
exact ⟨H1.left, H2.left⟩,
split,
intros s t H3 H4,
exact ⟨H1.right.left s t H3.left H4.left, H2.right.left s t H3.right H4.right⟩,
intros I H3,
split,
have H4 : ∀ (t : set α), t ∈ I → T1_sets t,
intros A H5,
exact (H3 A H5).left,
exact H1.right.right I H4,
have H4 :  ∀ (t : set α), t ∈ I → T2_sets t,
intros A H5,
exact (H3 A H5).right,
exact H2.right.right I H4,
end

inductive zeroonetwo : Type  -- use Type to work instead of Type u
| zero : zeroonetwo
| one : zeroonetwo
| two : zeroonetwo

open zeroonetwo
#print univ

def collection_one : set zeroonetwo  → Prop := λ s, s = ∅ ∨ s = {one, two} ∨ s = {zero, one, two}
def collection_two : set zeroonetwo → Prop := λ s, s = ∅ ∨ s = {zero, one} ∨ s = {zero, one, two}

def T1 : topological_space zeroonetwo := {
is_open := collection_one,
is_open_univ := begin have : (univ : set zeroonetwo) = {zero, one, two}, apply set.ext, assume x, cases x; simp, rewrite this, unfold collection_one, have obv : {zero, one, two} = {zero, one, two}, trivial, exact or.inr (or.inr obv) end,
is_open_inter := begin intros s t H1 H2, unfold collection_one at H1 H2, cases H1, cases H2, simp *,
 unfold collection_one, cc, cases H2, simp *, unfold collection_one, cc, simp *,
  unfold collection_one, cc, cases H1, cases H2, simp *, unfold collection_one, cc,
   cases H2, simp [*, collection_one], cc, simp [*, collection_one],
    have obv2 : insert two {one} ∩ insert two (insert one {zero}) = insert two {one}, unfold insert, rw inter_eq_self_of_subset_left, assume x : zeroonetwo, finish, exact or.inr (or.inl obv2),
    cases H2, simp [*, collection_one], finish, cases H2, simp[*, collection_one], have obv3 : insert two (insert one {zero}) ∩ insert two {one} = insert two {one}, unfold insert, rw inter_eq_self_of_subset_right, assume x : zeroonetwo, finish, exact or.inr (or.inl obv3),
    simp [*, collection_one], finish, end,
is_open_sUnion := by admit
 }

def T2 : topological_space zeroonetwo := {
    is_open := collection_two,
    is_open_univ := by admit,
    is_open_inter := by admit,
    is_open_sUnion := by admit
}

example : zero ∈ ({zero, one} : set zeroonetwo) := by simp

theorem exercisefourb : ¬ ∀ {α : Type } {T1_sets T2_sets : set α → Prop}, (is_open_sets T1_sets → is_open_sets T2_sets → is_open_sets (λ (a : set α), or (T1_sets a) (T2_sets a)) :=
begin
intro H1,
have is_topology : is_open_sets (λ (a : set zeroonetwo), collection_one a ∨ collection_two a),
exact H1 (top_to_is T1) (top_to_is T2),
unfold is_open_sets at is_topology,
have S : collection_one {one, two},
unfold collection_one, cc,
have T : collection_two {zero, one},
unfold collection_two, cc,
have M : collection_one ({one, two} ∩ {zero, one}) ∨ collection_two ({one, two} ∩ {zero, one}),
exact is_topology.right.left {one,two} {zero, one} (or.inl S) (or.inr T),
have obvious : {one, two} ∩ {zero, one} = {one},
apply set.ext, assume x : zeroonetwo, cases x, finish, split, rw mem_inter_eq one {one,two} {zero, one}, simp, exact mem_singleton _,
simp, finish,
rw obvious at M,
cases M,
admit,
end


import data.real.basic
import data.nat.basic
variables (x : ℝ)
variable (n: nat)

example (h:x>0) : (1+x)^n ≥ 1 + x*n :=
begin

end


import data.fintype.basic

open_locale classical

lemma exists_le_finset {α : Type*} [inhabited α] [semilattice_inf α]
  (G : finset α) : ∃ j : α, ∀ g ∈ G, j ≤ g :=
begin
  by_cases h : G.nonempty,
  { exact ⟨finset.inf' G h id, λ g, finset.inf'_le _⟩ },
  { exact ⟨default, λ g hg, false.elim $ h ⟨_, hg⟩⟩ }
end

lemma Inter_eq {α β : Type*} [inhabited α] [fintype β] [semilattice_inf α]
  (i : α) (f : Π (a : α) (ha : a ≤ i), set β)
  (hf : ∀ (a b : α) (ha : a ≤ i) (hb : b ≤ i) (h : a ≤ b), f a ha ≤ f b hb) :
  (∃ (j : α) (hj : j ≤ i), (⋂ (k : α) (hk : k ≤ i), f k hk) = f j hj) :=
begin
  suffices :
    (∃ (j : α) (hj : j ≤ i), ∀ (k : α) (hk : k ≤ i), f j hj ≤ f k hk),
  { rcases this with ⟨j,hj,h⟩,
    use j,
    use hj,
    refine le_antisymm _ _,
    { refine set.sInter_subset_of_mem ⟨j, _⟩,
      tidy },
    { rintros x hx _ ⟨k,rfl⟩,
      rintro _ ⟨hk,rfl⟩,
      apply h _ _ hx } },
  let BB := {S : set β | ∃ (e : α) (he : e ≤ i), S = f e he },
  let FF : BB → α := λ ee, classical.some ee.2,
  have hFF : ∀ S : BB, FF S ≤ i := λ S, (classical.some_spec S.2).some,
  have hFF' : ∀ S : BB, (S : set β) = f (FF S) (hFF S) := λ S, (classical.some_spec S.2).some_spec,
  haveI : fintype BB := fintype.of_injective (λ S : BB, S.1) (by tidy),
  let GG := (finset.univ : finset BB).image FF,
  obtain ⟨j0,hj0⟩ := exists_le_finset GG,
  use [j0 ⊓ i, inf_le_right],
  intros k hk,
  have : ∃ (e : α) (he : e ≤ i) (heFF : e ∈ GG), f k hk = f e he,
  { let T : BB := ⟨f k hk, k, hk, rfl⟩,
    use [FF T, hFF _],
    split,
    { erw finset.mem_image,
      use T,
      simp },
    { rw ← hFF', refl, } },
  obtain ⟨e,he,heFF,hhe⟩ := this,
  rw hhe,
  exact hf _ _ _ _ (le_trans inf_le_left (hj0 _ heFF)),
end

lemma eventually_constant {α β : Type*} [inhabited α] [fintype β] [semilattice_inf α]
  (i : α) (f : Π (a : α) (ha : a ≤ i), set β)
  (hf : ∀ (a b : α) (ha : a ≤ i) (hb : b ≤ i) (h : a ≤ b), f a ha ≤ f b hb) :
  (∃ (j : α) (hj : j ≤ i), ∀ (k : α) (hk : k ≤ j), f k (le_trans hk hj) = f j hj) :=
begin
  let S := ⋂ (k : α) (hk : k ≤ i), f k hk,
  obtain ⟨j0,hj0,h⟩ := Inter_eq i f hf,
  use [j0, hj0],
  intros e he,
  refine le_antisymm (hf _ _ _ _ he) _,
  rw ← h,
  rintros x hx,
  refine hx _ ⟨e, _⟩,
  tidy
end


/-
Copyright (c) 2020 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson
-/
import ring_theory.int.basic
import ring_theory.localization

/-!
# Gauss's Lemma

Gauss's Lemma is one of a few results pertaining to irreducibility of primitive polynomials.

## Main Results
 - `polynomial.is_primitive.irreducible_iff_irreducible_map_fraction_map`:
  A primitive polynomial is irreducible iff it is irreducible in a fraction field.
 - `polynomial.is_primitive.int.irreducible_iff_irreducible_map_cast`:
  A primitive polynomial over `ℤ` is irreducible iff it is irreducible over `ℚ`.
 - `polynomial.is_primitive.dvd_iff_fraction_map_dvd_fraction_map`:
  Two primitive polynomials divide each other iff they do in a fraction field.
 - `polynomial.is_primitive.int.dvd_iff_map_cast_dvd_map_cast`:
  Two primitive polynomials over `ℤ` divide each other if they do in `ℚ`.

-/

open_locale non_zero_divisors

variables {R : Type*} [comm_ring R] [is_domain R]

namespace polynomial
section normalized_gcd_monoid
variable [normalized_gcd_monoid R]

section
variables {S : Type*} [comm_ring S] [is_domain S] {φ : R →+* S} (hinj : function.injective φ)
variables {f : polynomial R} (hf : f.is_primitive)
include hinj hf

lemma is_primitive.is_unit_iff_is_unit_map_of_injective :
  is_unit f ↔ is_unit (map φ f) :=
begin
  refine ⟨(map_ring_hom φ).is_unit_map, λ h, _⟩,
  rcases is_unit_iff.1 h with ⟨_, ⟨u, rfl⟩, hu⟩,
  have hdeg := degree_C u.ne_zero,
  rw [hu, degree_map_eq_of_injective hinj] at hdeg,
  rw [eq_C_of_degree_eq_zero hdeg, is_primitive_iff_content_eq_one,
      content_C, normalize_eq_one] at hf,
  rwa [eq_C_of_degree_eq_zero hdeg, is_unit_C],
end

lemma is_primitive.irreducible_of_irreducible_map_of_injective (h_irr : irreducible (map φ f)) :
  irreducible f :=
begin
  refine ⟨λ h, h_irr.not_unit (is_unit.map ((map_ring_hom φ).to_monoid_hom) h), _⟩,
  intros a b h,
  rcases h_irr.is_unit_or_is_unit (by rw [h, map_mul]) with hu | hu,
  { left,
    rwa (hf.is_primitive_of_dvd (dvd.intro _ h.symm)).is_unit_iff_is_unit_map_of_injective hinj },
  right,
  rwa (hf.is_primitive_of_dvd (dvd.intro_left _ h.symm)).is_unit_iff_is_unit_map_of_injective hinj
end

end

section fraction_map
variables {K : Type*} [field K] [algebra R K] [is_fraction_ring R K]

lemma is_primitive.is_unit_iff_is_unit_map {p : polynomial R} (hp : p.is_primitive) :
  is_unit p ↔ is_unit (p.map (algebra_map R K)) :=
hp.is_unit_iff_is_unit_map_of_injective (is_fraction_ring.injective _ _)

open is_localization

lemma is_unit_or_eq_zero_of_is_unit_integer_normalization_prim_part
  {p : polynomial K} (h0 : p ≠ 0) (h : is_unit (integer_normalization R⁰ p).prim_part) :
  is_unit p :=
begin
  rcases is_unit_iff.1 h with ⟨_, ⟨u, rfl⟩, hu⟩,
  obtain ⟨⟨c, c0⟩, hc⟩ := integer_normalization_map_to_map R⁰ p,
  rw [subtype.coe_mk, algebra.smul_def, algebra_map_apply] at hc,
  apply is_unit_of_mul_is_unit_right,
  rw [← hc, (integer_normalization R⁰ p).eq_C_content_mul_prim_part, ← hu,
    ← ring_hom.map_mul, is_unit_iff],
  refine ⟨algebra_map R K ((integer_normalization R⁰ p).content * ↑u),
    is_unit_iff_ne_zero.2 (λ con, _), by simp⟩,
  replace con := (algebra_map R K).injective_iff.1 (is_fraction_ring.injective _ _) _ con,
  rw [mul_eq_zero, content_eq_zero_iff, is_fraction_ring.integer_normalization_eq_zero_iff] at con,
  rcases con with con | con,
  { apply h0 con },
  { apply units.ne_zero _ con },
end

/-- **Gauss's Lemma** states that a primitive polynomial is irreducible iff it is irreducible in the
  fraction field. -/
theorem is_primitive.irreducible_iff_irreducible_map_fraction_map
  {p : polynomial R} (hp : p.is_primitive) :
  irreducible p ↔ irreducible (p.map (algebra_map R K)) :=
begin
  refine ⟨λ hi, ⟨λ h, hi.not_unit (hp.is_unit_iff_is_unit_map.2 h), λ a b hab, _⟩,
    hp.irreducible_of_irreducible_map_of_injective (is_fraction_ring.injective _ _)⟩,
  obtain ⟨⟨c, c0⟩, hc⟩ := integer_normalization_map_to_map R⁰ a,
  obtain ⟨⟨d, d0⟩, hd⟩ := integer_normalization_map_to_map R⁰ b,
  rw [algebra.smul_def, algebra_map_apply, subtype.coe_mk] at hc hd,
  rw mem_non_zero_divisors_iff_ne_zero at c0 d0,
  have hcd0 : c * d ≠ 0 := mul_ne_zero c0 d0,
  rw [ne.def, ← C_eq_zero] at hcd0,
  have h1 : C c * C d * p = integer_normalization R⁰ a * integer_normalization R⁰ b,
  { apply map_injective (algebra_map R K) (is_fraction_ring.injective _ _) _,
    rw [map_mul, map_mul, map_mul, hc, hd, map_C, map_C, hab],
    ring },
  obtain ⟨u, hu⟩ : associated (c * d) (content (integer_normalization R⁰ a) *
            content (integer_normalization R⁰ b)),
  { rw [← dvd_dvd_iff_associated, ← normalize_eq_normalize_iff, normalize.map_mul,
        normalize.map_mul, normalize_content, normalize_content,
        ← mul_one (normalize c * normalize d), ← hp.content_eq_one, ← content_C, ← content_C,
        ← content_mul, ← content_mul, ← content_mul, h1] },
  rw [← ring_hom.map_mul, eq_comm,
    (integer_normalization R⁰ a).eq_C_content_mul_prim_part,
    (integer_normalization R⁰ b).eq_C_content_mul_prim_part, mul_assoc,
    mul_comm _ (C _ * _), ← mul_assoc, ← mul_assoc, ← ring_hom.map_mul, ← hu, ring_hom.map_mul,
    mul_assoc, mul_assoc, ← mul_assoc (C ↑u)] at h1,
  have h0 : (a ≠ 0) ∧ (b ≠ 0),
  { classical,
    rw [ne.def, ne.def, ← decidable.not_or_iff_and_not, ← mul_eq_zero, ← hab],
    intro con,
    apply hp.ne_zero (map_injective (algebra_map R K) (is_fraction_ring.injective _ _) _),
    simp [con] },
  rcases hi.is_unit_or_is_unit (mul_left_cancel₀ hcd0 h1).symm with h | h,
  { right,
    apply is_unit_or_eq_zero_of_is_unit_integer_normalization_prim_part h0.2
      (is_unit_of_mul_is_unit_right h) },
  { left,
    apply is_unit_or_eq_zero_of_is_unit_integer_normalization_prim_part h0.1 h },
end

lemma is_primitive.dvd_of_fraction_map_dvd_fraction_map {p q : polynomial R}
  (hp : p.is_primitive) (hq : q.is_primitive)
  (h_dvd : p.map (algebra_map R K) ∣ q.map (algebra_map R K)) : p ∣ q :=
begin
  rcases h_dvd with ⟨r, hr⟩,
  obtain ⟨⟨s, s0⟩, hs⟩ := integer_normalization_map_to_map R⁰ r,
  rw [subtype.coe_mk, algebra.smul_def, algebra_map_apply] at hs,
  have h : p ∣ q * C s,
  { use (integer_normalization R⁰ r),
    apply map_injective (algebra_map R K) (is_fraction_ring.injective _ _),
    rw [map_mul, map_mul, hs, hr, mul_assoc, mul_comm r],
    simp },
  rw [← hp.dvd_prim_part_iff_dvd, prim_part_mul, hq.prim_part_eq,
      associated.dvd_iff_dvd_right] at h,
  { exact h },
  { symmetry,
    rcases is_unit_prim_part_C s with ⟨u, hu⟩,
    use u,
    rw hu },
  iterate 2 { apply mul_ne_zero hq.ne_zero,
    rw [ne.def, C_eq_zero],
    contrapose! s0,
    simp [s0, mem_non_zero_divisors_iff_ne_zero] }
end

variables (K)

lemma is_primitive.dvd_iff_fraction_map_dvd_fraction_map {p q : polynomial R}
  (hp : p.is_primitive) (hq : q.is_primitive) :
  (p ∣ q) ↔ (p.map (algebra_map R K) ∣ q.map (algebra_map R K)) :=
⟨λ ⟨a,b⟩, ⟨a.map (algebra_map R K), b.symm ▸ map_mul (algebra_map R K)⟩,
  λ h, hp.dvd_of_fraction_map_dvd_fraction_map hq h⟩

end fraction_map

/-- **Gauss's Lemma** for `ℤ` states that a primitive integer polynomial is irreducible iff it is
  irreducible over `ℚ`. -/
theorem is_primitive.int.irreducible_iff_irreducible_map_cast
  {p : polynomial ℤ} (hp : p.is_primitive) :
  irreducible p ↔ irreducible (p.map (int.cast_ring_hom ℚ)) :=
hp.irreducible_iff_irreducible_map_fraction_map

lemma is_primitive.int.dvd_iff_map_cast_dvd_map_cast (p q : polynomial ℤ)
  (hp : p.is_primitive) (hq : q.is_primitive) :
  (p ∣ q) ↔ (p.map (int.cast_ring_hom ℚ) ∣ q.map (int.cast_ring_hom ℚ)) :=
hp.dvd_iff_fraction_map_dvd_fraction_map ℚ hq

end normalized_gcd_monoid
end polynomial