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

import group_theory.group_action.quotient
import group_theory.order_of_element

/-!
# Complements

In this file we define the complement of a subgroup.

## Main definitions

- `is_complement S T` where `S` and `T` are subsets of `G` states that every `g : G` can be
  written uniquely as a product `s * t` for `s ∈ S`, `t ∈ T`.
- `left_transversals T` where `T` is a subset of `G` is the set of all left-complements of `T`,
  i.e. the set of all `S : set G` that contain exactly one element of each left coset of `T`.
- `right_transversals S` where `S` is a subset of `G` is the set of all right-complements of `S`,
  i.e. the set of all `T : set G` that contain exactly one element of each right coset of `S`.

## Main results

- `is_complement_of_coprime` : Subgroups of coprime order are complements.
-/

open_locale big_operators

namespace subgroup

variables {G : Type*} [group G] (H K : subgroup G) (S T : set G)

/-- `S` and `T` are complements if `(*) : S × T → G` is a bijection.
  This notion generalizes left transversals, right transversals, and complementary subgroups. -/
@[to_additive "`S` and `T` are complements if `(*) : S × T → G` is a bijection"]
def is_complement : Prop := function.bijective (λ x : S × T, x.1.1 * x.2.1)

/-- `H` and `K` are complements if `(*) : H × K → G` is a bijection -/
@[to_additive "`H` and `K` are complements if `(*) : H × K → G` is a bijection"]
abbreviation is_complement' := is_complement (H : set G) (K : set G)

/-- The set of left-complements of `T : set G` -/
@[to_additive "The set of left-complements of `T : set G`"]
def left_transversals : set (set G) := {S : set G | is_complement S T}

/-- The set of right-complements of `S : set G` -/
@[to_additive "The set of right-complements of `S : set G`"]
def right_transversals : set (set G) := {T : set G | is_complement S T}

variables {H K S T}

@[to_additive] lemma is_complement'_def :
  is_complement' H K ↔ is_complement (H : set G) (K : set G) := iff.rfl

@[to_additive] lemma is_complement_iff_exists_unique :
  is_complement S T ↔ ∀ g : G, ∃! x : S × T, x.1.1 * x.2.1 = g :=
function.bijective_iff_exists_unique _

@[to_additive] lemma is_complement.exists_unique (h : is_complement S T) (g : G) :
  ∃! x : S × T, x.1.1 * x.2.1 = g :=
is_complement_iff_exists_unique.mp h g

@[to_additive] lemma is_complement'.symm (h : is_complement' H K) : is_complement' K H :=
begin
  let ϕ : H × K ≃ K × H := equiv.mk (λ x, ⟨x.2⁻¹, x.1⁻¹⟩) (λ x, ⟨x.2⁻¹, x.1⁻¹⟩)
    (λ x, prod.ext (inv_inv _) (inv_inv _)) (λ x, prod.ext (inv_inv _) (inv_inv _)),
  let ψ : G ≃ G := equiv.mk (λ g : G, g⁻¹) (λ g : G, g⁻¹) inv_inv inv_inv,
  suffices : ψ ∘ (λ x : H × K, x.1.1 * x.2.1) = (λ x : K × H, x.1.1 * x.2.1) ∘ ϕ,
  { rwa [is_complement'_def, is_complement, ←equiv.bijective_comp, ←this, equiv.comp_bijective] },
  exact funext (λ x, mul_inv_rev _ _),
end

@[to_additive] lemma is_complement'_comm : is_complement' H K ↔ is_complement' K H :=
⟨is_complement'.symm, is_complement'.symm⟩

@[to_additive] lemma is_complement_top_singleton {g : G} : is_complement (⊤ : set G) {g} :=
⟨λ ⟨x, _, rfl⟩ ⟨y, _, rfl⟩ h, prod.ext (subtype.ext (mul_right_cancel h)) rfl,
  λ x, ⟨⟨⟨x * g⁻¹, ⟨⟩⟩, g, rfl⟩, inv_mul_cancel_right x g⟩⟩

@[to_additive] lemma is_complement_singleton_top {g : G} : is_complement ({g} : set G) ⊤ :=
⟨λ ⟨⟨_, rfl⟩, x⟩ ⟨⟨_, rfl⟩, y⟩ h, prod.ext rfl (subtype.ext (mul_left_cancel h)),
  λ x, ⟨⟨⟨g, rfl⟩, g⁻¹ * x, ⟨⟩⟩, mul_inv_cancel_left g x⟩⟩

@[to_additive] lemma is_complement_singleton_left {g : G} : is_complement {g} S ↔ S = ⊤ :=
begin
  refine ⟨λ h, top_le_iff.mp (λ x hx, _), λ h, (congr_arg _ h).mpr is_complement_singleton_top⟩,
  obtain ⟨⟨⟨z, rfl : z = g⟩, y, _⟩, hy⟩ := h.2 (g * x),
  rwa ← mul_left_cancel hy,
end

@[to_additive] lemma is_complement_singleton_right {g : G} : is_complement S {g} ↔ S = ⊤ :=
begin
  refine ⟨λ h, top_le_iff.mp (λ x hx, _), λ h, (congr_arg _ h).mpr is_complement_top_singleton⟩,
  obtain ⟨y, hy⟩ := h.2 (x * g),
  conv_rhs at hy { rw ← (show y.2.1 = g, from y.2.2) },
  rw ← mul_right_cancel hy,
  exact y.1.2,
end

@[to_additive] lemma is_complement_top_left : is_complement ⊤ S ↔ ∃ g : G, S = {g} :=
begin
  refine ⟨λ h, set.exists_eq_singleton_iff_nonempty_subsingleton.mpr ⟨_, λ a ha b hb, _⟩, _⟩,
  { obtain ⟨a, ha⟩ := h.2 1,
    exact ⟨a.2.1, a.2.2⟩ },
  { have : (⟨⟨_, mem_top a⁻¹⟩, ⟨a, ha⟩⟩ : (⊤ : set G) × S) = ⟨⟨_, mem_top b⁻¹⟩, ⟨b, hb⟩⟩ :=
    h.1 ((inv_mul_self a).trans (inv_mul_self b).symm),
    exact subtype.ext_iff.mp ((prod.ext_iff.mp this).2) },
  { rintro ⟨g, rfl⟩,
    exact is_complement_top_singleton },
end

@[to_additive] lemma is_complement_top_right : is_complement S ⊤ ↔ ∃ g : G, S = {g} :=
begin
  refine ⟨λ h, set.exists_eq_singleton_iff_nonempty_subsingleton.mpr ⟨_, λ a ha b hb, _⟩, _⟩,
  { obtain ⟨a, ha⟩ := h.2 1,
    exact ⟨a.1.1, a.1.2⟩ },
  { have : (⟨⟨a, ha⟩, ⟨_, mem_top a⁻¹⟩⟩ : S × (⊤ : set G)) = ⟨⟨b, hb⟩, ⟨_, mem_top b⁻¹⟩⟩ :=
    h.1 ((mul_inv_self a).trans (mul_inv_self b).symm),
    exact subtype.ext_iff.mp ((prod.ext_iff.mp this).1) },
  { rintro ⟨g, rfl⟩,
    exact is_complement_singleton_top },
end

@[to_additive] lemma is_complement'_top_bot : is_complement' (⊤ : subgroup G) ⊥ :=
is_complement_top_singleton

@[to_additive] lemma is_complement'_bot_top : is_complement' (⊥ : subgroup G) ⊤ :=
is_complement_singleton_top

@[simp, to_additive] lemma is_complement'_bot_left : is_complement' ⊥ H ↔ H = ⊤ :=
is_complement_singleton_left.trans coe_eq_univ

@[simp, to_additive] lemma is_complement'_bot_right : is_complement' H ⊥ ↔ H = ⊤ :=
is_complement_singleton_right.trans coe_eq_univ

@[simp, to_additive] lemma is_complement'_top_left : is_complement' ⊤ H ↔ H = ⊥ :=
is_complement_top_left.trans coe_eq_singleton

@[simp, to_additive] lemma is_complement'_top_right : is_complement' H ⊤ ↔ H = ⊥ :=
is_complement_top_right.trans coe_eq_singleton

@[to_additive] lemma mem_left_transversals_iff_exists_unique_inv_mul_mem :
  S ∈ left_transversals T ↔ ∀ g : G, ∃! s : S, (s : G)⁻¹ * g ∈ T :=
begin
  rw [left_transversals, set.mem_set_of_eq, is_complement_iff_exists_unique],
  refine ⟨λ h g, _, λ h g, _⟩,
  { obtain ⟨x, h1, h2⟩ := h g,
    exact ⟨x.1, (congr_arg (∈ T) (eq_inv_mul_of_mul_eq h1)).mp x.2.2, λ y hy,
      (prod.ext_iff.mp (h2 ⟨y, y⁻¹ * g, hy⟩ (mul_inv_cancel_left y g))).1⟩ },
  { obtain ⟨x, h1, h2⟩ := h g,
    refine ⟨⟨x, x⁻¹ * g, h1⟩, mul_inv_cancel_left x g, λ y hy, _⟩,
    have := h2 y.1 ((congr_arg (∈ T) (eq_inv_mul_of_mul_eq hy)).mp y.2.2),
    exact prod.ext this (subtype.ext (eq_inv_mul_of_mul_eq ((congr_arg _ this).mp hy))) },
end

@[to_additive] lemma mem_right_transversals_iff_exists_unique_mul_inv_mem :
  S ∈ right_transversals T ↔ ∀ g : G, ∃! s : S, g * (s : G)⁻¹ ∈ T :=
begin
  rw [right_transversals, set.mem_set_of_eq, is_complement_iff_exists_unique],
  refine ⟨λ h g, _, λ h g, _⟩,
  { obtain ⟨x, h1, h2⟩ := h g,
    exact ⟨x.2, (congr_arg (∈ T) (eq_mul_inv_of_mul_eq h1)).mp x.1.2, λ y hy,
      (prod.ext_iff.mp (h2 ⟨⟨g * y⁻¹, hy⟩, y⟩ (inv_mul_cancel_right g y))).2⟩ },
  { obtain ⟨x, h1, h2⟩ := h g,
    refine ⟨⟨⟨g * x⁻¹, h1⟩, x⟩, inv_mul_cancel_right g x, λ y hy, _⟩,
    have := h2 y.2 ((congr_arg (∈ T) (eq_mul_inv_of_mul_eq hy)).mp y.1.2),
    exact prod.ext (subtype.ext (eq_mul_inv_of_mul_eq ((congr_arg _ this).mp hy))) this },
end

@[to_additive] lemma mem_left_transversals_iff_exists_unique_quotient_mk'_eq :
  S ∈ left_transversals (H : set G) ↔
  ∀ q : quotient (quotient_group.left_rel H), ∃! s : S, quotient.mk' s.1 = q :=
begin
  simp_rw [mem_left_transversals_iff_exists_unique_inv_mul_mem, set_like.mem_coe,
    ← quotient_group.eq'],
  exact ⟨λ h q, quotient.induction_on' q h, λ h g, h (quotient.mk' g)⟩,
end

@[to_additive] lemma mem_right_transversals_iff_exists_unique_quotient_mk'_eq :
  S ∈ right_transversals (H : set G) ↔
  ∀ q : quotient (quotient_group.right_rel H), ∃! s : S, quotient.mk' s.1 = q :=
begin
  simp_rw [mem_right_transversals_iff_exists_unique_mul_inv_mem, set_like.mem_coe,
    ← quotient_group.right_rel_apply, ← quotient.eq'],
  exact ⟨λ h q, quotient.induction_on' q h, λ h g, h (quotient.mk' g)⟩,
end

@[to_additive] lemma mem_left_transversals_iff_bijective : S ∈ left_transversals (H : set G) ↔
  function.bijective (S.restrict (quotient.mk' : G → quotient (quotient_group.left_rel H))) :=
mem_left_transversals_iff_exists_unique_quotient_mk'_eq.trans
  (function.bijective_iff_exists_unique (S.restrict quotient.mk')).symm

@[to_additive] lemma mem_right_transversals_iff_bijective : S ∈ right_transversals (H : set G) ↔
  function.bijective (S.restrict (quotient.mk' : G → quotient (quotient_group.right_rel H))) :=
mem_right_transversals_iff_exists_unique_quotient_mk'_eq.trans
  (function.bijective_iff_exists_unique (S.restrict quotient.mk')).symm

@[to_additive] lemma range_mem_left_transversals {f : G ⧸ H → G} (hf : ∀ q, ↑(f q) = q) :
  set.range f ∈ left_transversals (H : set G) :=
mem_left_transversals_iff_bijective.mpr ⟨by rintros ⟨-, q₁, rfl⟩ ⟨-, q₂, rfl⟩ h;
  exact congr_arg _ (((hf q₁).symm.trans h).trans (hf q₂)), λ q, ⟨⟨f q, q, rfl⟩, hf q⟩⟩

@[to_additive] lemma range_mem_right_transversals {f : quotient (quotient_group.right_rel H) → G}
  (hf : ∀ q, quotient.mk' (f q) = q) : set.range f ∈ right_transversals (H : set G) :=
mem_right_transversals_iff_bijective.mpr ⟨by rintros ⟨-, q₁, rfl⟩ ⟨-, q₂, rfl⟩ h;
  exact congr_arg _ (((hf q₁).symm.trans h).trans (hf q₂)), λ q, ⟨⟨f q, q, rfl⟩, hf q⟩⟩

@[to_additive] lemma exists_left_transversal (g : G) :
  ∃ S ∈ left_transversals (H : set G), g ∈ S :=
begin
  classical,
  refine ⟨set.range (function.update quotient.out' ↑g g), range_mem_left_transversals (λ q, _),
    g, function.update_same g g quotient.out'⟩,
  by_cases hq : q = g,
  { exact hq.symm ▸ congr_arg _ (function.update_same g g quotient.out') },
  { exact eq.trans (congr_arg _ (function.update_noteq hq g quotient.out')) q.out_eq' },
end

@[to_additive] lemma exists_right_transversal (g : G) :
  ∃ S ∈ right_transversals (H : set G), g ∈ S :=
begin
  classical,
  refine ⟨set.range (function.update quotient.out' _ g), range_mem_right_transversals (λ q, _),
    quotient.mk' g, function.update_same (quotient.mk' g) g quotient.out'⟩,
  by_cases hq : q = quotient.mk' g,
  { exact hq.symm ▸ congr_arg _ (function.update_same (quotient.mk' g) g quotient.out') },
  { exact eq.trans (congr_arg _ (function.update_noteq hq g quotient.out')) q.out_eq' },
end

namespace mem_left_transversals

/-- A left transversal is in bijection with left cosets. -/
@[to_additive "A left transversal is in bijection with left cosets."]
noncomputable def to_equiv (hS : S ∈ subgroup.left_transversals (H : set G)) : G ⧸ H ≃ S :=
(equiv.of_bijective _ (subgroup.mem_left_transversals_iff_bijective.mp hS)).symm

@[to_additive] lemma mk'_to_equiv (hS : S ∈ subgroup.left_transversals (H : set G)) (q : G ⧸ H) :
  quotient.mk' (to_equiv hS q : G) = q :=
(to_equiv hS).symm_apply_apply q

@[to_additive] lemma to_equiv_apply {f : G ⧸ H → G} (hf : ∀ q, (f q : G ⧸ H) = q) (q : G ⧸ H) :
  (to_equiv (range_mem_left_transversals hf) q : G) = f q :=
begin
  refine (subtype.ext_iff.mp _).trans (subtype.coe_mk (f q) ⟨q, rfl⟩),
  exact (to_equiv (range_mem_left_transversals hf)).apply_eq_iff_eq_symm_apply.mpr (hf q).symm,
end

/-- A left transversal can be viewed as a function mapping each element of the group
  to the chosen representative from that left coset. -/
@[to_additive "A left transversal can be viewed as a function mapping each element of the group
  to the chosen representative from that left coset."]
noncomputable def to_fun (hS : S ∈ subgroup.left_transversals (H : set G)) : G → S :=
to_equiv hS ∘ quotient.mk'

@[to_additive] lemma inv_to_fun_mul_mem (hS : S ∈ subgroup.left_transversals (H : set G))
  (g : G) : (to_fun hS g : G)⁻¹ * g ∈ H :=
quotient_group.left_rel_apply.mp $ quotient.exact' $ mk'_to_equiv _ _

@[to_additive] lemma inv_mul_to_fun_mem (hS : S ∈ subgroup.left_transversals (H : set G))
  (g : G) : g⁻¹ * to_fun hS g ∈ H :=
(congr_arg (∈ H) (by rw [mul_inv_rev, inv_inv])).mp (H.inv_mem (inv_to_fun_mul_mem hS g))

end mem_left_transversals

namespace mem_right_transversals

/-- A right transversal is in bijection with right cosets. -/
@[to_additive "A right transversal is in bijection with right cosets."]
noncomputable def to_equiv (hS : S ∈ subgroup.right_transversals (H : set G)) :
  quotient (quotient_group.right_rel H) ≃ S :=
(equiv.of_bijective _ (subgroup.mem_right_transversals_iff_bijective.mp hS)).symm

@[to_additive] lemma mk'_to_equiv (hS : S ∈ subgroup.right_transversals (H : set G))
  (q : quotient (quotient_group.right_rel H)) : quotient.mk' (to_equiv hS q : G) = q :=
(to_equiv hS).symm_apply_apply q

@[to_additive] lemma to_equiv_apply {f : quotient (quotient_group.right_rel H) → G}
  (hf : ∀ q, quotient.mk' (f q) = q) (q : quotient (quotient_group.right_rel H)) :
  (to_equiv (range_mem_right_transversals hf) q : G) = f q :=
begin
  refine (subtype.ext_iff.mp _).trans (subtype.coe_mk (f q) ⟨q, rfl⟩),
  exact (to_equiv (range_mem_right_transversals hf)).apply_eq_iff_eq_symm_apply.mpr (hf q).symm,
end

/-- A right transversal can be viewed as a function mapping each element of the group
  to the chosen representative from that right coset. -/
@[to_additive "A right transversal can be viewed as a function mapping each element of the group
  to the chosen representative from that right coset."]
noncomputable def to_fun (hS : S ∈ subgroup.right_transversals (H : set G)) : G → S :=
to_equiv hS ∘ quotient.mk'

@[to_additive] lemma mul_inv_to_fun_mem (hS : S ∈ subgroup.right_transversals (H : set G))
  (g : G) : g * (to_fun hS g : G)⁻¹ ∈ H :=
quotient_group.right_rel_apply.mp $ quotient.exact' $ mk'_to_equiv _ _

@[to_additive] lemma to_fun_mul_inv_mem (hS : S ∈ subgroup.right_transversals (H : set G))
  (g : G) : (to_fun hS g : G) * g⁻¹ ∈ H :=
(congr_arg (∈ H) (by rw [mul_inv_rev, inv_inv])).mp (H.inv_mem (mul_inv_to_fun_mem hS g))

end mem_right_transversals

section action

open_locale pointwise

open mul_action mem_left_transversals

variables {F : Type*} [group F] [mul_action F G] [quotient_action F H]

@[to_additive] instance : mul_action F (left_transversals (H : set G)) :=
{ smul := λ f T, ⟨f • T, by
  { refine mem_left_transversals_iff_exists_unique_inv_mul_mem.mpr (λ g, _),
    obtain ⟨t, ht1, ht2⟩ := mem_left_transversals_iff_exists_unique_inv_mul_mem.mp T.2 (f⁻¹ • g),
    refine ⟨⟨f • t, set.smul_mem_smul_set t.2⟩, _, _⟩,
    { exact (congr_arg _ (smul_inv_smul f g)).mp (quotient_action.inv_mul_mem f ht1) },
    { rintros ⟨-, t', ht', rfl⟩ h,
      replace h := quotient_action.inv_mul_mem f⁻¹ h,
      simp only [subtype.ext_iff, subtype.coe_mk, smul_left_cancel_iff, inv_smul_smul] at h ⊢,
      exact subtype.ext_iff.mp (ht2 ⟨t', ht'⟩ h) } }⟩,
  one_smul := λ T, subtype.ext (one_smul F T),
  mul_smul := λ f₁ f₂ T, subtype.ext (mul_smul f₁ f₂ T) }

@[to_additive] lemma smul_to_fun (f : F) (T : left_transversals (H : set G)) (g : G) :
  (f • to_fun T.2 g : G) = to_fun (f • T).2 (f • g) :=
subtype.ext_iff.mp $ @unique_of_exists_unique ↥(f • T) (λ s, (↑s)⁻¹ * f • g ∈ H)
  (mem_left_transversals_iff_exists_unique_inv_mul_mem.mp (f • T).2 (f • g))
  ⟨f • to_fun T.2 g, set.smul_mem_smul_set (subtype.coe_prop _)⟩ (to_fun (f • T).2 (f • g))
  (quotient_action.inv_mul_mem f (inv_to_fun_mul_mem T.2 g)) (inv_to_fun_mul_mem (f • T).2 (f • g))

@[to_additive] lemma smul_to_equiv (f : F) (T : left_transversals (H : set G)) (q : G ⧸ H) :
  f • (to_equiv T.2 q : G) = to_equiv (f • T).2 (f • q) :=
quotient.induction_on' q (λ g, smul_to_fun f T g)

@[to_additive] lemma smul_apply_eq_smul_apply_inv_smul (f : F) (T : left_transversals (H : set G))
  (q : G ⧸ H) : (to_equiv (f • T).2 q : G) = f • (to_equiv T.2 (f⁻¹ • q) : G) :=
by rw [smul_to_equiv, smul_inv_smul]

end action

@[to_additive] instance : inhabited (left_transversals (H : set G)) :=
⟨⟨set.range quotient.out', range_mem_left_transversals quotient.out_eq'⟩⟩

@[to_additive] instance : inhabited (right_transversals (H : set G)) :=
⟨⟨set.range quotient.out', range_mem_right_transversals quotient.out_eq'⟩⟩

lemma is_complement'.is_compl (h : is_complement' H K) : is_compl H K :=
begin
  refine ⟨λ g ⟨p, q⟩, let x : H × K := ⟨⟨g, p⟩, 1⟩, y : H × K := ⟨1, g, q⟩ in subtype.ext_iff.mp
    (prod.ext_iff.mp (show x = y, from h.1 ((mul_one g).trans (one_mul g).symm))).1, λ g _, _⟩,
  obtain ⟨⟨h, k⟩, rfl⟩ := h.2 g,
  exact subgroup.mul_mem_sup h.2 k.2,
end

lemma is_complement'.sup_eq_top (h : subgroup.is_complement' H K) : H ⊔ K = ⊤ :=
h.is_compl.sup_eq_top

lemma is_complement'.disjoint (h : is_complement' H K) : disjoint H K :=
h.is_compl.disjoint

lemma is_complement.card_mul [fintype G] [fintype S] [fintype T] (h : is_complement S T) :
  fintype.card S * fintype.card T = fintype.card G :=
(fintype.card_prod _ _).symm.trans (fintype.card_of_bijective h)

lemma is_complement'.card_mul [fintype G] [fintype H] [fintype K] (h : is_complement' H K) :
  fintype.card H * fintype.card K = fintype.card G :=
h.card_mul

lemma is_complement'_of_card_mul_and_disjoint [fintype G] [fintype H] [fintype K]
  (h1 : fintype.card H * fintype.card K = fintype.card G) (h2 : disjoint H K) :
  is_complement' H K :=
begin
  refine (fintype.bijective_iff_injective_and_card _).mpr
    ⟨λ x y h, _, (fintype.card_prod H K).trans h1⟩,
  rw [←eq_inv_mul_iff_mul_eq, ←mul_assoc, ←mul_inv_eq_iff_eq_mul] at h,
  change ↑(x.2 * y.2⁻¹) = ↑(x.1⁻¹ * y.1) at h,
  rw [prod.ext_iff, ←@inv_mul_eq_one H _ x.1 y.1, ←@mul_inv_eq_one K _ x.2 y.2, subtype.ext_iff,
      subtype.ext_iff, coe_one, coe_one, h, and_self, ←mem_bot, ←h2.eq_bot, mem_inf],
  exact ⟨subtype.mem ((x.1)⁻¹ * (y.1)), (congr_arg (∈ K) h).mp (subtype.mem (x.2 * (y.2)⁻¹))⟩,
end

lemma is_complement'_iff_card_mul_and_disjoint [fintype G] [fintype H] [fintype K] :
  is_complement' H K ↔
    fintype.card H * fintype.card K = fintype.card G ∧ disjoint H K :=
⟨λ h, ⟨h.card_mul, h.disjoint⟩, λ h, is_complement'_of_card_mul_and_disjoint h.1 h.2⟩

lemma is_complement'_of_coprime [fintype G] [fintype H] [fintype K]
  (h1 : fintype.card H * fintype.card K = fintype.card G)
  (h2 : nat.coprime (fintype.card H) (fintype.card K)) :
  is_complement' H K :=
is_complement'_of_card_mul_and_disjoint h1 (disjoint_iff.mpr (inf_eq_bot_of_coprime h2))

lemma is_complement'_stabilizer {α : Type*} [mul_action G α] (a : α)
  (h1 : ∀ (h : H), h • a = a → h = 1) (h2 : ∀ g : G, ∃ h : H, h • (g • a) = a) :
  is_complement' H (mul_action.stabilizer G a) :=
begin
  refine is_complement_iff_exists_unique.mpr (λ g, _),
  obtain ⟨h, hh⟩ := h2 g,
  have hh' : (↑h * g) • a = a := by rwa [mul_smul],
  refine ⟨⟨h⁻¹, h * g, hh'⟩, inv_mul_cancel_left h g, _⟩,
  rintros ⟨h', g, hg : g • a = a⟩ rfl,
  specialize h1 (h * h') (by rwa [mul_smul, smul_def h', ←hg, ←mul_smul, hg]),
  refine prod.ext (eq_inv_of_mul_eq_one_right h1) (subtype.ext _),
  rwa [subtype.ext_iff, coe_one, coe_mul, ←self_eq_mul_left, mul_assoc ↑h ↑h' g] at h1,
end

end subgroup


/-
taken from a comment by Junyan Xu on
https://leanprover-community.github.io/archive/stream/113489-new-members/topic/Generalization.20of.20map_diff.html
-/
import data.multiset.basic
open multiset
variables {α β : Type*} [decidable_eq α] [decidable_eq β] (f : α → β)

lemma multiset.map_diff_subset (s₁ : multiset α) (s₂ : multiset α) :
  s₁.map f - s₂.map f ≤ (s₁ - s₂).map f :=
begin
  rw [tsub_le_iff_right, le_iff_count],
  intro, simp only [count_add, count_map, ← card_add, ← filter_add],
  exact card_le_of_le (filter_le_filter _ $ tsub_le_iff_right.1 le_rfl),
end

lemma list.map_diff_subset (l₁ : list α) (l₂ : list α) :
  (l₁.map f).diff (l₂.map f) ⊆ (l₁.diff l₂).map f :=
begin
  simp only [← coe_subset, ← coe_sub, ← coe_map],
  exact subset_of_le (multiset.map_diff_subset f _ _),
end


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

import algebra.monoid_algebra.division
import ring_theory.ideal.basic

/-!
# Lemmas about ideals of `monoid_algebra` and `add_monoid_algebra`
-/

variables {k A G : Type*}

/-- If `x` belongs to the ideal generated by generators in `s`, then every element of the support of
`x` factors through an element of `s`.

We could spell `∃ d, m = d * m` as `mul_opposite.op m' ∣ mul_opposite.op m` but this would be worse.
-/
lemma monoid_algebra.mem_ideal_span_of_image
  [monoid G] [semiring k] {s : set G} {x : monoid_algebra k G} :
  x ∈ ideal.span (monoid_algebra.of k G '' s) ↔ ∀ m ∈ x.support, ∃ m' ∈ s, ∃ d, m = d * m' :=
begin
  let RHS : ideal (monoid_algebra k G) :=
  { carrier := {p | ∀ (m : G), m ∈ p.support → ∃ m' ∈ s, ∃ d, m = d * m'},
    add_mem' := λ x y hx hy m hm, by classical;
      exact (finset.mem_union.1 $ finsupp.support_add hm).elim (hx m) (hy m),
    zero_mem' := λ m hm, by cases hm,
    smul_mem' := λ x y hy m hm, begin
      replace hm := finset.mem_bUnion.mp (finsupp.support_sum hm),
      obtain ⟨xm, hxm, hm⟩ := hm,
      replace hm := finset.mem_bUnion.mp (finsupp.support_sum hm),
      obtain ⟨ym, hym, hm⟩ := hm,
      replace hm := finset.mem_singleton.mp (finsupp.support_single_subset hm),
      obtain rfl := hm,
      refine (hy _ hym).imp (λ sm, Exists.imp $ λ hsm, _),
      rintros ⟨d, rfl⟩,
      exact ⟨xm * d, (mul_assoc _ _ _).symm⟩,
    end },
  change _ ↔ x ∈ RHS,
  split,
  { revert x,
    refine ideal.span_le.2 _,
    rintro _ ⟨i, hi, rfl⟩ m hm,
    refine ⟨_, hi, 1, _⟩,
    obtain rfl := finset.mem_singleton.mp (finsupp.support_single_subset hm),
    exact (one_mul _).symm },
  { intros hx,
    rw ←finsupp.sum_single x,
    apply ideal.sum_mem _ (λ i hi, _),
    obtain ⟨d, hd, d2, rfl⟩ := hx _ hi,
    convert ideal.mul_mem_left _ (id $ finsupp.single d2 $ (x (d2 * d)) : monoid_algebra k G) _,
    swap 3,
    refine ideal.subset_span ⟨_, hd, rfl⟩,
    rw [id.def, monoid_algebra.of_apply, monoid_algebra.single_mul_single, mul_one] },
end

/-- If `x` belongs to the ideal generated by generators in `s`, then every element of the support of
`x` factors additively through an element of `s`.
-/
lemma add_monoid_algebra.mem_ideal_span_of'_image
  [add_monoid A] [semiring k] {s : set A} {x : add_monoid_algebra k A} :
  x ∈ ideal.span (add_monoid_algebra.of' k A '' s) ↔ ∀ m ∈ x.support, ∃ m' ∈ s, ∃ d, m = d + m' :=
@monoid_algebra.mem_ideal_span_of_image k (multiplicative A) _ _ _ _


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

! This file was ported from Lean 3 source module algebra.order.field.pi
! leanprover-community/mathlib commit 509de852e1de55e1efa8eacfa11df0823f26f226
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Order.Field.Basic
import Mathlib.Data.Fintype.Lattice

/-!
# Lemmas about (finite domain) functions into fields.

We split this from `Algebra.Order.Field.Basic` to avoid importing the finiteness hierarchy there.
-/

variable {α ι : Type _} [LinearOrderedSemifield α]

theorem Pi.exists_forall_pos_add_lt [ExistsAddOfLE α] [Finite ι] {x y : ι → α}
    (h : ∀ i, x i < y i) : ∃ ε, 0 < ε ∧ ∀ i, x i + ε < y i := by
  cases nonempty_fintype ι
  cases isEmpty_or_nonempty ι
  · exact ⟨1, zero_lt_one, isEmptyElim⟩
  choose ε hε hxε using fun i => exists_pos_add_of_lt' (h i)
  obtain rfl : x + ε = y := funext hxε
  have hε : 0 < Finset.univ.inf' Finset.univ_nonempty ε := (Finset.lt_inf'_iff _).2 fun i _ => hε _
  exact
    ⟨_, half_pos hε, fun i =>
      add_lt_add_left ((half_lt_self hε).trans_le <| Finset.inf'_le _ <| Finset.mem_univ _) _⟩
#align pi.exists_forall_pos_add_lt Pi.exists_forall_pos_add_lt


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

! This file was ported from Lean 3 source module data.real.pi.leibniz
! leanprover-community/mathlib commit f2ce6086713c78a7f880485f7917ea547a215982
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.SpecialFunctions.Trigonometric.ArctanDeriv

/-! ### Leibniz's Series for Pi -/

namespace Real

open Filter Set

open Classical BigOperators Topology Real

-- mathport name: abs
local notation "|" x "|" => abs x

/-- This theorem establishes **Leibniz's series for `π`**: The alternating sum of the reciprocals
  of the odd numbers is `π/4`. Note that this is a conditionally rather than absolutely convergent
  series. The main tool that this proof uses is the Mean Value Theorem (specifically avoiding the
  Fundamental Theorem of Calculus).

  Intuitively, the theorem holds because Leibniz's series is the Taylor series of `arctan x`
  centered about `0` and evaluated at the value `x = 1`. Therefore, much of this proof consists of
  reasoning about a function
    `f := arctan x - ∑ i in finset.range k, (-(1:ℝ))^i * x^(2*i+1) / (2*i+1)`,
  the difference between `arctan` and the `k`-th partial sum of its Taylor series. Some ingenuity is
  required due to the fact that the Taylor series is not absolutely convergent at `x = 1`.

  This proof requires a bound on `f 1`, the key idea being that `f 1` can be split as the sum of
  `f 1 - f u` and `f u`, where `u` is a sequence of values in [0,1], carefully chosen such that
  each of these two terms can be controlled (in different ways).

  We begin the proof by (1) introducing that sequence `u` and then proving that another sequence
  constructed from `u` tends to `0` at `+∞`. After (2) converting the limit in our goal to an
  inequality, we (3) introduce the auxiliary function `f` defined above. Next, we (4) compute the
  derivative of `f`, denoted by `f'`, first generally and then on each of two subintervals of [0,1].
  We then (5) prove a bound for `f'`, again both generally as well as on each of the two
  subintervals. Finally, we (6) apply the Mean Value Theorem twice, obtaining bounds on `f 1 - f u`
  and `f u - f 0` from the bounds on `f'` (note that `f 0 = 0`). -/
theorem tendsto_sum_pi_div_four :
    Tendsto (fun k => ∑ i in Finset.range k, (-(1 : ℝ)) ^ i / (2 * i + 1)) atTop (𝓝 (π / 4)) :=
  by
  rw [tendsto_iff_norm_tendsto_zero, ← tendsto_zero_iff_norm_tendsto_zero]
  -- (1) We introduce a useful sequence `u` of values in [0,1], then prove that another sequence
  --     constructed from `u` tends to `0` at `+∞`
  let u := fun k : ℕ => (k : NNReal) ^ (-1 / (2 * (k : ℝ) + 1))
  have H : tendsto (fun k : ℕ => (1 : ℝ) - u k + u k ^ (2 * (k : ℝ) + 1)) at_top (𝓝 0) :=
    by
    convert(((tendsto_rpow_div_mul_add (-1) 2 1 two_ne_zero.symm).neg.const_add 1).add
            tendsto_inv_atTop_zero).comp
        tendsto_nat_cast_atTop_atTop
    · ext k
      simp only [NNReal.coe_nat_cast, Function.comp_apply, NNReal.coe_rpow]
      rw [← rpow_mul (Nat.cast_nonneg k) (-1 / (2 * (k : ℝ) + 1)) (2 * (k : ℝ) + 1),
        @div_mul_cancel _ _ (2 * (k : ℝ) + 1) _
          (by
            norm_cast
            simp only [Nat.succ_ne_zero, not_false_iff]),
        rpow_neg_one k, sub_eq_add_neg]
    · simp only [add_zero, add_right_neg]
  -- (2) We convert the limit in our goal to an inequality
  refine' squeeze_zero_norm _ H
  intro k
  -- Since `k` is now fixed, we henceforth denote `u k` as `U`
  let U := u k
  -- (3) We introduce an auxiliary function `f`
  let b (i : ℕ) x := (-(1 : ℝ)) ^ i * x ^ (2 * i + 1) / (2 * i + 1)
  let f x := arctan x - ∑ i in Finset.range k, b i x
  suffices f_bound : |f 1 - f 0| ≤ (1 : ℝ) - U + U ^ (2 * (k : ℝ) + 1)
  · rw [← norm_neg]
    convert f_bound
    simp only [f]
    simp [b]
  -- We show that `U` is indeed in [0,1]
  have hU1 : (U : ℝ) ≤ 1 := by
    by_cases hk : k = 0
    · simp [u, U, hk]
    ·
      exact
        rpow_le_one_of_one_le_of_nonpos
          (by
            norm_cast
            exact nat.succ_le_iff.mpr (Nat.pos_of_ne_zero hk))
          (le_of_lt
            (@div_neg_of_neg_of_pos _ _ (-(1 : ℝ)) (2 * k + 1) (neg_neg_iff_pos.mpr zero_lt_one)
              (by
                norm_cast
                exact Nat.succ_pos')))
  have hU2 := NNReal.coe_nonneg U
  -- (4) We compute the derivative of `f`, denoted by `f'`
  let f' := fun x : ℝ => (-x ^ 2) ^ k / (1 + x ^ 2)
  have has_deriv_at_f : ∀ x, HasDerivAt f (f' x) x :=
    by
    intro x
    have has_deriv_at_b : ∀ i ∈ Finset.range k, HasDerivAt (b i) ((-x ^ 2) ^ i) x :=
      by
      intro i hi
      convert HasDerivAt.const_mul ((-1 : ℝ) ^ i / (2 * i + 1))
          (@HasDerivAt.pow _ _ _ _ _ (2 * i + 1) (hasDerivAt_id x))
      · ext y
        simp only [b, id.def]
        ring
      · simp only [Nat.add_succ_sub_one, add_zero, mul_one, id.def, Nat.cast_bit0, Nat.cast_add,
          Nat.cast_one, Nat.cast_mul]
        rw [← mul_assoc,
          @div_mul_cancel _ _ (2 * (i : ℝ) + 1) _
            (by
              norm_cast
              linarith),
          pow_mul x 2 i, ← mul_pow (-1) (x ^ 2) i]
        ring_nf
    convert(has_deriv_at_arctan x).sub (HasDerivAt.sum has_deriv_at_b)
    have g_sum :=
      @geom_sum_eq _ _ (-x ^ 2) ((neg_nonpos.mpr (sq_nonneg x)).trans_lt zero_lt_one).Ne k
    simp only [f'] at g_sum⊢
    rw [g_sum, ← neg_add' (x ^ 2) 1, add_comm (x ^ 2) 1, sub_eq_add_neg, neg_div', neg_div_neg_eq]
    ring
  have hderiv1 : ∀ x ∈ Icc (U : ℝ) 1, HasDerivWithinAt f (f' x) (Icc (U : ℝ) 1) x := fun x hx =>
    (has_deriv_at_f x).HasDerivWithinAt
  have hderiv2 : ∀ x ∈ Icc 0 (U : ℝ), HasDerivWithinAt f (f' x) (Icc 0 (U : ℝ)) x := fun x hx =>
    (has_deriv_at_f x).HasDerivWithinAt
  -- (5) We prove a general bound for `f'` and then more precise bounds on each of two subintervals
  have f'_bound : ∀ x ∈ Icc (-1 : ℝ) 1, |f' x| ≤ |x| ^ (2 * k) :=
    by
    intro x hx
    rw [abs_div, IsAbsoluteValue.abv_pow abs (-x ^ 2) k, abs_neg, IsAbsoluteValue.abv_pow abs x 2, ←
      pow_mul]
    refine' div_le_of_nonneg_of_le_mul (abs_nonneg _) (pow_nonneg (abs_nonneg _) _) _
    refine' le_mul_of_one_le_right (pow_nonneg (abs_nonneg _) _) _
    rw [abs_of_nonneg (add_nonneg zero_le_one (sq_nonneg x) : (0 : ℝ) ≤ _)]
    exact (le_add_of_nonneg_right (sq_nonneg x) : (1 : ℝ) ≤ _)
  have hbound1 : ∀ x ∈ Ico (U : ℝ) 1, |f' x| ≤ 1 :=
    by
    rintro x ⟨hx_left, hx_right⟩
    have hincr := pow_le_pow_of_le_left (le_trans hU2 hx_left) (le_of_lt hx_right) (2 * k)
    rw [one_pow (2 * k), ← abs_of_nonneg (le_trans hU2 hx_left)] at hincr
    rw [← abs_of_nonneg (le_trans hU2 hx_left)] at hx_right
    linarith [f'_bound x (mem_Icc.mpr (abs_le.mp (le_of_lt hx_right)))]
  have hbound2 : ∀ x ∈ Ico 0 (U : ℝ), |f' x| ≤ U ^ (2 * k) :=
    by
    rintro x ⟨hx_left, hx_right⟩
    have hincr := pow_le_pow_of_le_left hx_left (le_of_lt hx_right) (2 * k)
    rw [← abs_of_nonneg hx_left] at hincr hx_right
    rw [← abs_of_nonneg hU2] at hU1 hx_right
    linarith [f'_bound x (mem_Icc.mpr (abs_le.mp (le_trans (le_of_lt hx_right) hU1)))]
  -- (6) We twice apply the Mean Value Theorem to obtain bounds on `f` from the bounds on `f'`
  have mvt1 := norm_image_sub_le_of_norm_deriv_le_segment' hderiv1 hbound1 _ (right_mem_Icc.mpr hU1)
  have mvt2 := norm_image_sub_le_of_norm_deriv_le_segment' hderiv2 hbound2 _ (right_mem_Icc.mpr hU2)
  -- The following algebra is enough to complete the proof
  calc
    |f 1 - f 0| = |f 1 - f U + (f U - f 0)| := by ring_nf
    _ ≤ 1 * (1 - U) + U ^ (2 * k) * (U - 0) :=
      (le_trans (abs_add (f 1 - f U) (f U - f 0)) (add_le_add mvt1 mvt2))
    _ = 1 - U + U ^ (2 * k) * U := by ring
    _ = 1 - u k + u k ^ (2 * (k : ℝ) + 1) :=
      by
      rw [← pow_succ' (U : ℝ) (2 * k)]
      norm_cast

#align real.tendsto_sum_pi_div_four Real.tendsto_sum_pi_div_four

end Real


-- Si a es un punto de acumulación de la sucesión de Cauchy u, entonces a es el límite de u
-- ========================================================================================

import data.real.basic

variable  {u : ℕ → ℝ}
variables {a : ℝ}
variable  {φ : ℕ → ℕ}

-- ----------------------------------------------------
-- Nota. Usaremos los siguientes conceptos estudiados
-- anteriormente.
-- ----------------------------------------------------

notation `|`x`|` := abs x

def limite : (ℕ → ℝ) → ℝ → Prop :=
λ u c, ∀ ε > 0, ∃ N, ∀ n ≥ N, |u n - c| ≤ ε

def extraccion : (ℕ → ℕ) → Prop
| φ := ∀ n m, n < m → φ n < φ m

lemma id_mne_extraccion
  (h : extraccion φ)
  : ∀ n, n ≤ φ n :=
begin
  intros n,
  induction n with m HI,
  { linarith },
  { exact nat.succ_le_of_lt (by linarith [h m (m+1) (by linarith)]) },
end

lemma extraccion_mye
  (h : extraccion φ)
  : ∀ N N', ∃ n ≥ N', φ n ≥ N :=
λ N N',
  ⟨max N N', le_max_right N N',
             le_trans (le_max_left N N')
             (id_mne_extraccion h (max N N'))⟩

def punto_acumulacion : (ℕ → ℝ) → ℝ → Prop
| u a := ∃ φ, extraccion φ ∧ limite (u ∘ φ) a

lemma cerca_acumulacion
  (h : punto_acumulacion u a)
  : ∀ ε > 0, ∀ N, ∃ n ≥ N, |u n - a| ≤ ε :=
begin
  intros ε hε N,
  rcases h with ⟨φ, hφ1, hφ2⟩,
  cases hφ2 ε hε with N' hN',
  rcases extraccion_mye hφ1 N N' with ⟨m, hm, hm'⟩,
  exact ⟨φ m, hm', hN' _ hm⟩,
end

def sucesion_de_Cauchy : (ℕ → ℝ) → Prop
| u := ∀ ε > 0, ∃ N, ∀ p q, p ≥ N → q ≥ N → |u p - u q| ≤ ε

-- ----------------------------------------------------
-- Ejercicio. Demostrar que si u es una sucesión de
-- Cauchy y a es un punto de acumulación de u, entonces
-- a es el límite de u.
-- ----------------------------------------------------

-- 1ª demostración
example
  (hu : sucesion_de_Cauchy u)
  (ha : punto_acumulacion u a)
  : limite u a :=
begin
  -- unfold limite,
  intros ε hε,
  -- unfold sucesion_de_Cauchy at hu,
  cases hu (ε/2) (half_pos hε) with N hN,
  use N,
  have ha' : ∃ N' ≥ N, |u N' - a| ≤ ε/2,
    apply cerca_acumulacion ha (ε/2) (half_pos hε),
  cases ha' with N' h,
  cases h with hNN' hN',
  intros n hn,
  calc   |u n - a|
       = |(u n - u N') + (u N' - a)| : by ring
   ... ≤ |u n - u N'| + |u N' - a|   : abs_add (u n - u N') (u N' - a)
   ... ≤ ε/2 + |u N' - a|            : add_le_add_right (hN n N' hn hNN') _
   ... ≤ ε/2 + ε/2                   : add_le_add_left hN' (ε / 2)
   ... = ε                           : add_halves ε
end

-- 2ª demostración
example
  (hu : sucesion_de_Cauchy u)
  (ha : punto_acumulacion u a)
  : limite u a :=
begin
  intros ε hε,
  cases hu (ε/2) (by linarith) with N hN,
  use N,
  have ha' : ∃ N' ≥ N, |u N' - a| ≤ ε/2,
    apply cerca_acumulacion ha (ε/2) (by linarith),
  rcases ha' with ⟨N', hNN', hN'⟩,
  intros n hn,
  calc  |u n - a|
      = |(u n - u N') + (u N' - a)| : by ring
  ... ≤ |u n - u N'| + |u N' - a|   : by simp [abs_add]
  ... ≤ ε                           : by linarith [hN n N' hn hNN'],
end


import game.order.level08
open real

namespace xena -- hide

/-
# Chapter 2 : Order

## Level 9

This level invites you to work out a property of the absolute value.
In Lean the absolute value of $x$ is denoted by `abs x`.
For ease of use, a notation can be used around that definition as below.
Feel free to use the triangle inequality on the real numbers,

`abs_add : ∀ (a b : ?M_1), |a + b| ≤ |a| + |b|`

together with the `linarith` and `norm_num` tactics.
-/

notation `|` x `|` := abs x

-- begin hide
-- this to go in the side bar
lemma eq_sqr_to_eq (a b : ℝ) (ha : 0 ≤ a) (hb : 0 ≤ b) : a^2 = b^2 → a = b :=
begin
    intro H,
    have A : sqrt (a ^ 2) = sqrt (a ^ 2), refl,
    rw H at A {occs := occurrences.pos [2]},
    have G := sqrt_sqr ha, rw G at A,
    have F := sqrt_sqr hb, rw F at A,
    exact A, done
end
-- end hide

/- Lemma
For any two real numbers $a$ and $b$, we have that
$$|a + b| = |a| + |b|$$ if and only if $ab \ge 0$ .
-/
theorem abs_sub_eq_sum_abs (a b : ℝ) : |a + b| = |a| + |b| ↔ a * b ≥ 0 :=
begin
    have H0 : (a+b)^2 = |a+b|^2,
        have h01 := abs_mul_abs_self (a+b),
        rw pow_two _, rw pow_two _, symmetry, exact h01,
    have H1 : 0 ≤ (a + b) ^ 2, exact pow_two_nonneg (a+b),
    have H2 : (a+b) ^ 2 = a ^2 + 2 * a * b + b^2, ring,
    have H3 : ( |a| + |b| )^2 = |a|^2 + 2*|a|*|b| + |b|^2, ring,
    rw H0 at H2,
    have Ha : a^2 = |a|^2,
        have h01 := abs_mul_abs_self a,
        rw pow_two _, rw pow_two _, symmetry, exact h01,
    have Hb : b^2 = |b|^2,
        have h01 := abs_mul_abs_self b,
        rw pow_two _, rw pow_two _, symmetry, exact h01,
    rw [Ha, Hb] at H2,
    split,
    intro h,
    rw h at H2, rw H3 at H2, simp at H2,
    rw mul_assoc at H2, rw mul_assoc at H2,
    have g1 : ( |a| * |b| ) = (a * b), linarith,
    have g2 : |a * b| = ( |a| * |b| ), exact abs_mul _ _,
    rw ← g2 at g1,
    by_contradiction hn, push_neg at hn,
    have g3 : | a * b | = - (a *b), exact abs_of_neg hn,
    rw g1 at g3, linarith,
    -- the right-left direction
    intro h,
    have g1 : |a * b| = a * b, exact abs_of_nonneg h,
    have g2 : |a * b| = ( |a| * |b| ), exact abs_mul _ _,
    rw g2 at g1, rw mul_assoc 2 a b at H2,
    rw ← g1 at H2,
    have g3 : |a| ^ 2 + 2 * ( |a| * |b| ) + |b| ^ 2 = ( |a| + |b| )^2, ring,
    rw g3 at H2,
    have g4 : sqrt ( |a + b| ^ 2 ) = sqrt ( |a + b| ^ 2), refl,
    rw H2 at g4 {occs := occurrences.pos [2]},
    have hab : 0 ≤ |a + b|,  exact is_absolute_value.abv_nonneg abs (a+b),
    have ha : 0 ≤ |a|,  exact is_absolute_value.abv_nonneg abs a,
    have hb : 0 ≤ |b|,  exact is_absolute_value.abv_nonneg abs b,
    have hc : 0 ≤ |a| + |b|, linarith,
    have G := eq_sqr_to_eq ( |a + b| ) ( |a| + |b| ) hab hc H2, exact G, done
end

end xena -- hide


import set_theory.cardinal.basic
import set_theory.cardinal.finite
import set_theory.cardinal.ordinal

universe u

namespace cardinal
lemma eq_one_iff_exists_unique {α : Type*}:
  cardinal.mk α = 1 ↔ ∃! (a: α), true :=
begin
  rw [eq_one_iff_unique],
  exact ⟨
      λ h, h.right.elim (λ a, ⟨a, trivial, λ _ _, @subsingleton.elim _ h.left _ _ ⟩) ,
      λ h, exists_unique.elim h (λ a _ ha, and.intro
        (subsingleton.intro (λ x y, trans (ha x trivial) (ha y trivial).symm))
        (nonempty.intro a)) ⟩,
end

theorem lt_aleph_0' {c : cardinal} (hc: c < aleph_0): ∃ n : ℕ, (n: cardinal) = c :=
  exists.elim (cardinal.lt_aleph_0.mp hc) (λ n hn, ⟨n, hn.symm⟩)

lemma le_mk_diff_add_mk_of_lt_aleph_0 {α: Type*} {c: cardinal} {s t: set α} (ht: cardinal.mk t < cardinal.aleph_0): c + cardinal.mk t ≤ cardinal.mk s → c ≤ cardinal.mk (s \ t : set α) :=
λ h, (cardinal.add_le_add_iff_of_lt_aleph_0 ht).mp (trans h (le_mk_diff_add_mk _ _))

lemma to_nat_inj {a b: cardinal} (ha: a < aleph_0) (hb: b < aleph_0) (h: a.to_nat = b.to_nat):
   a = b := le_antisymm
      ((cardinal.to_nat_le_iff_le_of_lt_aleph_0 ha hb).mp (le_of_eq h))
      ((cardinal.to_nat_le_iff_le_of_lt_aleph_0 hb ha).mp (ge_of_eq h))

lemma to_nat_inj_iff {a b: cardinal} (ha: a < aleph_0) (hb: b < aleph_0):
  a.to_nat = b.to_nat ↔ a = b :=
    ⟨ λ h, to_nat_inj ha hb h, congr_arg _ ⟩

lemma nat_cast_add (n m: ℕ): ((n + m:ℕ): cardinal) = n + m :=
  to_nat_inj (nat_lt_aleph_0 _) (add_lt_aleph_0 (nat_lt_aleph_0 _) (nat_lt_aleph_0 _)) (by simp)

theorem to_nat_even_iff (c: cardinal): even c ↔ even c.to_nat :=
begin
  split;
  intro h;
  cases h with x h,
  { rw [h],
    use to_nat x,
    rw [← two_mul, ← two_mul, to_nat_mul, ← nat.cast_two, to_nat_cast] },
  cases lt_or_ge c aleph_0 with hfin hinf,
  { cases cardinal.lt_aleph_0' hfin with n hn,
    induction hn,
    rw [to_nat_cast] at h,
    exact ⟨ x, by rw [h, nat_cast_add] ⟩ },
  { exact ⟨c, (add_eq_left hinf (le_refl _)).symm⟩ },
end

theorem nat_mul_lt_aleph_0 (c: cardinal) {n: ℕ}: c < aleph_0 → (n:cardinal)*c < aleph_0 :=
begin
  simp only [lt_aleph_0, forall_exists_index],
  exact λ m hm, ⟨n * m, hm.symm ▸ (nat.cast_mul _ _).symm⟩
end

theorem nat_mul_ge_aleph_0 (c: cardinal) {n: ℕ}: aleph_0 ≤ c → n ≠ 0 → (n:cardinal)*c = c :=
begin
  intros hc hn,
  rwa [mul_eq_max_of_aleph_0_le_right _ hc, max_eq_right_iff.mpr _],
  exact trans (le_of_lt (nat_lt_aleph_0 _)) hc,
  rwa nat.cast_ne_zero,
end

theorem nat_cast_left_mul_le_mul (c d: cardinal) {n: ℕ} (hn: 0 < n): (n:cardinal) * c ≤ n * d → c ≤ d :=
begin
  by_cases hc: c < aleph_0;
  by_cases hd: d < aleph_0,
  { cases lt_aleph_0' hc with nc hc,
    cases lt_aleph_0' hd with nd hd,
    induction hc,
    induction hd,
    simpa only [← nat.cast_mul, nat.cast_le, mul_le_mul_left hn] using id },
  { exact λ _,  trans (le_of_lt hc) (le_of_not_gt hd) },
  { intro h,
    exfalso,
    apply not_lt_of_ge h,
    apply lt_of_lt_of_le (nat_mul_lt_aleph_0 _ hd),
    rw [nat_mul_ge_aleph_0],
    repeat { exact le_of_not_gt hc },
    apply ne_of_gt hn },
  { rw [nat_mul_ge_aleph_0, nat_mul_ge_aleph_0],
    exact id,
    any_goals { exact ne_of_gt hn },
    { exact le_of_not_gt hd },
    { exact le_of_not_gt hc },
  },
end
end cardinal

lemma set.cardinal_embedding {α: Type u} {s: set α} {c: cardinal.{u}}:
  c ≤ cardinal.mk s → ∃ t: set α, cardinal.mk t = c ∧ t ⊆ s :=
begin
  intro hlt,
  rw [← cardinal.mk_out c, cardinal.le_def] at hlt,
  cases hlt,
  use { v | ∃ (hv : v ∈ s) c, hlt.to_fun c = ⟨v, hv⟩ },
  refine ⟨_, λ hp, by simpa using λ hp _ _, hp ⟩,
  conv_rhs { rw [← cardinal.mk_out c] },
  apply eq.symm,
  rw [cardinal.eq],
  fconstructor,
  refine equiv.of_bijective _ ⟨_, _⟩,
  { exact (λ x, ⟨ (hlt.to_fun x).val, by simp ⟩) },
  { intros c₁ c₂, simp [subtype.coe_inj] },
  intros ha,
  rcases ha with ⟨a, ha, c', hc⟩,
  use c',
  revert hc,
  simpa using congr_arg coe,
end

lemma set.cardinal_union_ge {α: Type*} (s t: set α):
  cardinal.mk s ≤ cardinal.mk (s ∪ t: set α) :=
 ⟨ ⟨  λ a, ⟨ a.val, or.inl a.property ⟩, λ a b, by simp [subtype.coe_inj] ⟩ ⟩

lemma set.cardinal_union_of_aleph_0_le {α: Type*} (s t: set α):
  cardinal.mk t ≤ cardinal.mk s → cardinal.aleph_0 ≤ cardinal.mk s → cardinal.mk (s ∪ t: set α) = cardinal.mk s :=
  λ h₁ h₂, le_antisymm
    (trans (cardinal.mk_union_le _ _) (cardinal.add_le_of_le h₂ (le_refl _) h₁))
    (cardinal.mk_le_mk_of_subset (set.subset_union_left _ _))


import tactic

#check mul_add
#check dvd_mul_right

variables {a b c : ℕ}

-- BEGIN
example (divab : a ∣ b) (divac : a ∣ c) : a ∣ (b + c) :=
begin
  cases divab with d beq,
  cases divac with e ceq,
  rw [beq, ceq],
  rw ← mul_add,
  exact dvd_mul_right a (d + e),
end

example (divab : a ∣ b) (divac : a ∣ c) : a ∣ (b + c) :=
begin
  cases divab with d beq,
  cases divac with e ceq,
  rw [beq, ceq],
  rw ← mul_add,
  use (d + e),
end
-- END


/- Homework 3.1: Program Semantics — Operational Semantics -/

attribute [pattern] or.intro_left or.intro_right

/- Question 1: Semantics of regular expressions

Regular expression are a very popular tool for software development. Often, when textual input needs
to be analyzed it is matched against a regular expression. In this homework, we define the syntax of
regular expressions and what it means that a regular expression matches a string.

We define `regex` to represent the following grammar:

    R ::= c       — `char`: accepts one character `c`
        | ∅       — `nothing`: accepts nothing
        | ε       — `empty`: accepts the empty string
        | R ⬝ R    — `concat`: accepts the concatenation of two regexes
        | R + R   — `alt`: accepts either of two regexes
        | R*      — `star`: accept arbitrary many repetitions of a regex

Notice the rough correspondence with a WHILE language:

  `char`    ~ assignment
 (`nothing` ~ failing assertion)
  `empty`   ~ `skip`
  `concat`  ~ sequential composition
  `alt`     ~ conditional statement
  `star`    ~ while loop -/

@[derive decidable_eq]
inductive regex : Type
| char    : char → regex
| nothing : regex
| empty   : regex
| concat  : regex → regex → regex
| alt     : regex → regex → regex
| star    : regex → regex

/- `accept r s`: the regular expression `r` accepts the string `s` -/

inductive accept : regex → list char → Prop
/- accept one character -/
| char (c : char) :
  accept (regex.char c) [c]
/- accept the empty string -/
| empty :
  accept regex.empty []
/- accept two concatenated regexes -/
| concat {r₁ r₂ : regex} (s₁ s₂ : list char) (h₁ : accept r₁ s₁) (h₂ : accept r₂ s₂) :
  accept (regex.concat r₁ r₂) (s₁ ++ s₂)
/- accept the left alternative -/
| alt_left {r₁ r₂ : regex} (s : list char) (h : accept r₁ s) :
  accept (regex.alt r₁ r₂) s
/- accept the right alternative -/
| alt_right {r₁ r₂ : regex} (s : list char) (h : accept r₂ s) :
  accept (regex.alt r₁ r₂) s
/- accepts the empty string; this is the base case of `R*` -/
| star_base {r : regex} : accept (regex.star r) []
/- accepts `R` followed again by `R*`; this is the induction step of `R*` -/
| star_step {r : regex} (s s' : list char) (h₁ : accept r s) (h₂ : accept (regex.star r) s') :
  accept (regex.star r) (s ++ s')

/- 1.1. Explain why there is no rule for `nothing`. -/

/- Answer: There is no input nor output. So it would be weird to have a rule for nothing, as there is nothing.. -/

/- 1.2. Prove the following inversion rules.

These proofs are very similar to the inversion rules in the lecture and in Question 2.1 of the
exercise. -/

variables {s s₁ s₂ : list char} {r r₁ r₂  : regex} {c : char}

@[simp] lemma accept_char : accept (regex.char c) s ↔ s = [c] :=
begin
  apply iff.intro,
  intro h,
  cases h,
  trivial,
  intro s,
  cases s,
  exact accept.char c
end

@[simp] lemma accept_nothing : ¬ accept regex.nothing s:=
begin
  intro s,
  cases s
end

@[simp] lemma accept_empty : accept regex.empty s ↔ s = [] :=
begin
  apply iff.intro,
  intro h,
  cases h,
  trivial,
  intro h,
  cases h,
  exact accept.empty
end

@[simp] lemma accept_concat :
  accept (regex.concat r₁ r₂) s ↔ (∃s₁ s₂, accept r₁ s₁ ∧ accept r₂ s₂ ∧ s = s₁ ++ s₂) :=
  begin
    apply iff.intro,
    intro h,
    cases h,
    apply exists.intro h_s₁,
    apply exists.intro h_s₂,
    apply and.intro,
    assumption,
    apply and.intro,
    assumption,

  end

@[simp] lemma accept_alt :
  accept (regex.alt r₁ r₂) s ↔ (accept r₁ s ∨ accept r₂ s) :=
begin
  apply iff.intro,
  intro a,
  cases a,
  cases a_h,
  apply or.inl,
  assumption,
  apply or.inl,
  assumption,
  apply or.inl,
  assumption,
  apply or.inl,
  assumption,
  apply or.inl,
  assumption,
  apply or.inl,
  assumption,
  apply or.inl,
  assumption,
  apply or.inr,
  assumption,
  intro b,
  cases b,
  exact accept.alt_left s b ,
  exact accept.alt_right s b
end

lemma accept_star :
  accept (regex.star r) s ↔
  (s = [] ∨ (∃s₁ s₂, accept r s₁ ∧ accept (regex.star r) s₂ ∧ s = s₁ ++ s₂)) :=
begin
apply iff.intro,
intro acc,
cases s,
simp,
repeat{simp[accept.star_base, accept.star_step]},
repeat {apply exists.intro s_tl},
apply and.intro,
cases s_tl,
cases r,
exact accept.empty, /-Does not work?-/

end

/- 1.3 **optional**. Prove a more sophisticated version of `accept_star`.

The previous rule `accept_star` has the problem that in the induction step, the accepted string for
`r` could be empty. Now we want to **enforce** that the it is not empty, _without loss of
generality_.

*Hint*: In contrast to the other inversion rules, you now need to perform an induction. But the
arguments in our induction hypothesis `accept (regex.star r) (c :: s)` are not variables. So you
will need to generalize them. You can use `cases` to cope with the parts where the regex you handle
is not of the form `regex.star r`. In the `accept.star_step` case, you might need to split on the
string first, and then use `cases` on the second generalized equality. -/

lemma accept_star_cons :
  accept (regex.star r) (c :: s) →
  ∃s₁ s₂ : list char, accept r (c :: s₁) ∧ accept (regex.star r) s₂ ∧ s = s₁ ++ s₂ :=
sorry

/- Question 2 **optional**: Equivalence and matching of regular expressions -/

/- We can prove equivalence between regular expressions, just like between programs. Two
regular expressions are equivalent if they accept the same set of strings. -/

def regex_equiv (r₁ r₂ : regex) : Prop :=
∀s, accept r₁ s ↔ accept r₂ s

local infix ` ≈ ` := regex_equiv

/- Program equivalence is a equivalence relation, i.e. it is reflexive, symmetric, and
transitive. -/

@[refl] lemma regex_equiv.refl :
  r ≈ r :=
assume s, by refl

@[symm] lemma regex_equiv.symm :
  r₁ ≈ r₂ → r₂ ≈ r₁ :=
assume h s, (h s).symm

@[trans] lemma regex_equiv.trans {r₃} (h₁₂ : r₁ ≈ r₂) (h₂₃ : r₂ ≈ r₃) :
  r₁ ≈ r₃ :=
assume s, iff.trans (h₁₂ s) (h₂₃ s)

/- 2.1 **optional**. Prove the following regular expression equivalences. -/

lemma concat_empty_left : regex.concat regex.empty r ≈ r :=
sorry

/- **Hint**: Below, you need to rewrite at some point `x ++ [] = x` (either
using `rw` or `simp`). Depending on your approach you may be required to
introduce an intermediate goal. Remember `simp [...] at h` or `rw [...] at h`
allows you to rewrite a hypothesis. -/

lemma concat_empty_right : regex.concat r regex.empty ≈ r :=
sorry

lemma alt_idem : regex.alt r r ≈ r :=
sorry

lemma star_unfold : regex.star r ≈ regex.alt regex.empty (regex.concat r (regex.star r)) :=
sorry

/- **Hint**: For the next proof, you will probably need induction. -/

lemma star_congr_aux (hr : r₁ ≈ r₂) : accept (regex.star r₁) s → accept (regex.star r₂) s :=
sorry

/- **Hint**: For the next proof, you will probably need `star_congr_aux` and `regex.symm`. -/

lemma star_congr (hr : r₁ ≈ r₂) : regex.star r₁ ≈ regex.star r₂ :=
sorry

/- The `match_regex` function below matches a regular expression using Brzozowski derivatives. See
https://en.wikipedia.org/wiki/Brzozowski_derivative for details. -/

@[simp] def accepts_empty : regex → bool
| (regex.char c)       := ff
| regex.nothing        := ff
| regex.empty          := tt
| (regex.concat r₁ r₂) := accepts_empty r₁ && accepts_empty r₂
| (regex.alt r₁ r₂)    := accepts_empty r₁ || accepts_empty r₂
| (regex.star r)       := tt

lemma accepts_empty_iff : ∀r : regex, accepts_empty r = tt ↔ accept r []
| (regex.char c)       := by simp
| regex.nothing        := by simp
| regex.empty          := by simp
| (regex.concat r₁ r₂) :=
  begin
    simp [accepts_empty_iff r₁, accepts_empty_iff r₂],
    exact iff.intro
      (assume ⟨h₁, h₂⟩, ⟨[], [], h₁, h₂, rfl⟩)
      (assume h, match h with ⟨[], [], h₁, h₂, rfl⟩ := ⟨h₁, h₂⟩ end)
  end
| (regex.alt r₁ r₂)    := by simp [accepts_empty_iff r₁, accepts_empty_iff r₂]
| (regex.star r)       := by simp; constructor

@[simp] def deriv : regex → char → regex
| (regex.char c')      c := if c = c' then regex.empty else regex.nothing
| regex.nothing        _ := regex.nothing
| regex.empty          _ := regex.nothing
| (regex.concat r₁ r₂) c :=
  if accepts_empty r₁ = tt
  then regex.alt (regex.concat (deriv r₁ c) r₂) (deriv r₂ c)
  else regex.concat (deriv r₁ c) r₂
| (regex.alt r₁ r₂)    c := regex.alt (deriv r₁ c) (deriv r₂ c)
| (regex.star r)       c := regex.concat (deriv r c) (regex.star r)

def match_regex : regex → list char → bool
| r []       := accepts_empty r
| r (c :: s) := match_regex (deriv r c) s

/- 2.2 **optional**. Fill in the `sorry` placeholders below. -/

lemma accept_deriv : ∀r : regex, ∀c s, accept (deriv r c) s ↔ accept r (c :: s)
| (regex.char c')      c s :=
  sorry
| regex.nothing        c s :=
  sorry
| regex.empty          c s :=
  sorry
| (regex.concat r₁ r₂) c s :=
  begin
    by_cases h₁ : accepts_empty r₁ = tt;
      simp [h₁, accept_deriv r₂, accept_deriv r₁];
      simp [accepts_empty_iff] at h₁,
    sorry,  -- in one direction, you will need to make a case distinction on the string
    sorry
  end
| (regex.alt r₁ r₂)    c s := by simp [accept_deriv r₂, accept_deriv r₁]
| (regex.star r)       c s :=
  begin
    rw [accept_star],
    sorry  -- for one direction, you will probably need `accept_star_cons`
  end


-- Si_ff_es_biyectiva_entonces_f_es_biyectiva.lean
-- Si f·f es biyectiva entonces f es biyectiva.
-- José A. Alonso Jiménez <https://jaalonso.github.io>
-- Sevilla, 28-junio-2022
-- ---------------------------------------------------------------------

-- ---------------------------------------------------------------------
-- Demostrar que si f·f es biyectiva, entonces f es biyectiva.
-- ---------------------------------------------------------------------

import tactic
open function

variables {X Y Z : Type}
variable  {f : X → Y}
variable  {g : Y → Z}

-- 1ª demostración
-- ===============

lemma iny_comp_iny_primera
  (Hgf : injective (g ∘ f))
  : injective f :=
begin
  intros x x' f_xx',
  apply Hgf,
  finish,
end

lemma supr_comp_supr_segunda
  (Hgf : surjective (g ∘ f))
  : surjective g :=
begin
  intros z,
  rcases Hgf z with ⟨x, hx⟩,
  use f x,
  calc g (f x) = (g ∘ f) x : rfl
           ... = z         : hx,
end

example
  (f : X → X)
  (Hff : bijective (f ∘ f))
  : bijective f :=
begin
  split,
  { have h1 : injective (f ∘ f) := bijective.injective Hff,
    exact iny_comp_iny_primera h1, },
  { have h2 : surjective (f ∘ f) := bijective.surjective Hff,
    exact supr_comp_supr_segunda h2, },
end


/-
Copyright (c) 2020 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson, Jalex Stark
-/
import data.polynomial.monic
import data.polynomial.ring_division
import tactic.linarith
/-!
# Lemmas for the interaction between polynomials and `∑` and `∏`.

Recall that `∑` and `∏` are notation for `finset.sum` and `finset.prod` respectively.

## Main results

- `polynomial.nat_degree_prod_of_monic` : the degree of a product of monic polynomials is the
  product of degrees. We prove this only for `[comm_semiring R]`,
  but it ought to be true for `[semiring R]` and `list.prod`.
- `polynomial.nat_degree_prod` : for polynomials over an integral domain,
  the degree of the product is the sum of degrees.
- `polynomial.leading_coeff_prod` : for polynomials over an integral domain,
  the leading coefficient is the product of leading coefficients.
- `polynomial.prod_X_sub_C_coeff_card_pred` carries most of the content for computing
  the second coefficient of the characteristic polynomial.
-/

open finset
open multiset

open_locale big_operators

universes u w

variables {R : Type u} {ι : Type w}

namespace polynomial

variables (s : finset ι)

section comm_semiring
variables [comm_semiring R] (f : ι → polynomial R) (t : multiset (polynomial R))

lemma nat_degree_multiset_prod_le :
  t.prod.nat_degree ≤ (t.map (λ f, nat_degree f)).sum :=
begin
  refine multiset.induction_on t _ (λ a t ih, _), { simp },
  rw [prod_cons, map_cons, sum_cons],
  transitivity a.nat_degree + t.prod.nat_degree,
  { apply polynomial.nat_degree_mul_le },
  { exact add_le_add (le_refl _) ih }
end

lemma nat_degree_prod_le : (∏ i in s, f i).nat_degree ≤ ∑ i in s, (f i).nat_degree :=
by simpa using nat_degree_multiset_prod_le (s.1.map f)

/--
The leading coefficient of a product of polynomials is equal to
the product of the leading coefficients, provided that this product is nonzero.

See `polynomial.leading_coeff_multiset_prod` (without the `'`) for a version for integral domains,
where this condition is automatically satisfied.
-/
lemma leading_coeff_multiset_prod' (h : (t.map (λ f, leading_coeff f)).prod ≠ 0) :
  t.prod.leading_coeff = (t.map (λ f, leading_coeff f)).prod :=
begin
  revert h,
  refine multiset.induction_on t _ (λ a t ih ht, _), { simp },
  rw [map_cons, prod_cons] at ht,
  simp only [map_cons, prod_cons],
  rw polynomial.leading_coeff_mul'; { rwa ih, apply right_ne_zero_of_mul ht }
end

/--
The leading coefficient of a product of polynomials is equal to
the product of the leading coefficients, provided that this product is nonzero.

See `polynomial.leading_coeff_prod` (without the `'`) for a version for integral domains,
where this condition is automatically satisfied.
-/
lemma leading_coeff_prod' (h : ∏ i in s, (f i).leading_coeff ≠ 0) :
  (∏ i in s, f i).leading_coeff = ∏ i in s, (f i).leading_coeff :=
by simpa using leading_coeff_multiset_prod' (s.1.map f) (by simpa using h)

/--
The degree of a product of polynomials is equal to
the sum of the degrees, provided that the product of leading coefficients is nonzero.

See `polynomial.nat_degree_multiset_prod` (without the `'`) for a version for integral domains,
where this condition is automatically satisfied.
-/
lemma nat_degree_multiset_prod' (h : (t.map (λ f, leading_coeff f)).prod ≠ 0) :
  t.prod.nat_degree = (t.map (λ f, nat_degree f)).sum :=
begin
  revert h,
  refine multiset.induction_on t _ (λ a t ih ht, _), { simp },
  rw [map_cons, prod_cons] at ht ⊢,
  rw [sum_cons, polynomial.nat_degree_mul', ih],
  { apply right_ne_zero_of_mul ht },
  { rwa polynomial.leading_coeff_multiset_prod', apply right_ne_zero_of_mul ht },
end

/--
The degree of a product of polynomials is equal to
the sum of the degrees, provided that the product of leading coefficients is nonzero.

See `polynomial.nat_degree_prod` (without the `'`) for a version for integral domains,
where this condition is automatically satisfied.
-/
lemma nat_degree_prod' (h : ∏ i in s, (f i).leading_coeff ≠ 0) :
  (∏ i in s, f i).nat_degree = ∑ i in s, (f i).nat_degree :=
by simpa using nat_degree_multiset_prod' (s.1.map f) (by simpa using h)

lemma nat_degree_multiset_prod_of_monic [nontrivial R] (h : ∀ f ∈ t, monic f) :
  t.prod.nat_degree = (t.map (λ f, nat_degree f)).sum :=
begin
  apply nat_degree_multiset_prod',
  suffices : (t.map (λ f, leading_coeff f)).prod = 1, { rw this, simp },
  convert prod_repeat (1 : R) t.card,
  { simp only [eq_repeat, multiset.card_map, eq_self_iff_true, true_and],
    rintros i hi,
    obtain ⟨i, hi, rfl⟩ := multiset.mem_map.mp hi,
    apply h, assumption },
  { simp }
end

lemma nat_degree_prod_of_monic [nontrivial R] (h : ∀ i ∈ s, (f i).monic) :
  (∏ i in s, f i).nat_degree = ∑ i in s, (f i).nat_degree :=
by simpa using nat_degree_multiset_prod_of_monic (s.1.map f) (by simpa using h)

lemma coeff_zero_multiset_prod :
  t.prod.coeff 0 = (t.map (λ f, coeff f 0)).prod :=
begin
  refine multiset.induction_on t _ (λ a t ht, _), { simp },
  rw [prod_cons, map_cons, prod_cons, polynomial.mul_coeff_zero, ht]
end

lemma coeff_zero_prod :
  (∏ i in s, f i).coeff 0 = ∏ i in s, (f i).coeff 0 :=
by simpa using coeff_zero_multiset_prod (s.1.map f)

end comm_semiring

section comm_ring
variables [comm_ring R]

open monic
-- Eventually this can be generalized with Vieta's formulas
-- plus the connection between roots and factorization.
lemma multiset_prod_X_sub_C_next_coeff [nontrivial R] (t : multiset R) :
  next_coeff (t.map (λ x, X - C x)).prod = -t.sum :=
begin
  rw next_coeff_multiset_prod,
  { simp only [next_coeff_X_sub_C],
    refine t.sum_hom ⟨has_neg.neg, _, _⟩; simp [add_comm] },
  { intros, apply monic_X_sub_C }
end

lemma prod_X_sub_C_next_coeff [nontrivial R] {s : finset ι} (f : ι → R) :
  next_coeff ∏ i in s, (X - C (f i)) = -∑ i in s, f i :=
by simpa using multiset_prod_X_sub_C_next_coeff (s.1.map f)

lemma multiset_prod_X_sub_C_coeff_card_pred [nontrivial R] (t : multiset R) (ht : 0 < t.card) :
  (t.map (λ x, (X - C x))).prod.coeff (t.card - 1) = -t.sum :=
begin
  convert multiset_prod_X_sub_C_next_coeff (by assumption),
  rw next_coeff, split_ifs,
  { rw nat_degree_multiset_prod_of_monic at h; simp only [multiset.mem_map] at *,
    swap, { rintros _ ⟨_, _, rfl⟩, apply monic_X_sub_C },
    simp_rw [multiset.sum_eq_zero_iff, multiset.mem_map] at h,
    contrapose! h,
    obtain ⟨x, hx⟩ := card_pos_iff_exists_mem.mp ht,
    exact ⟨_, ⟨_, ⟨x, hx, rfl⟩, nat_degree_X_sub_C _⟩, one_ne_zero⟩ },
  congr, rw nat_degree_multiset_prod_of_monic; { simp [nat_degree_X_sub_C, monic_X_sub_C] },
end

lemma prod_X_sub_C_coeff_card_pred [nontrivial R] (s : finset ι) (f : ι → R) (hs : 0 < s.card) :
  (∏ i in s, (X - C (f i))).coeff (s.card - 1) = - ∑ i in s, f i :=
by simpa using multiset_prod_X_sub_C_coeff_card_pred (s.1.map f) (by simpa using hs)

end comm_ring

section no_zero_divisors
variables [comm_ring R] [no_zero_divisors R] (f : ι → polynomial R) (t : multiset (polynomial R))

/--
The degree of a product of polynomials is equal to
the sum of the degrees.

See `polynomial.nat_degree_prod'` (with a `'`) for a version for commutative semirings,
where additionally, the product of the leading coefficients must be nonzero.
-/
lemma nat_degree_prod [nontrivial R] (h : ∀ i ∈ s, f i ≠ 0) :
  (∏ i in s, f i).nat_degree = ∑ i in s, (f i).nat_degree :=
begin
  apply nat_degree_prod',
  rw prod_ne_zero_iff,
  intros x hx, simp [h x hx]
end

lemma nat_degree_multiset_prod [nontrivial R] (s : multiset (polynomial R))
  (h : (0 : polynomial R) ∉ s) :
  nat_degree s.prod = (s.map nat_degree).sum :=
begin
  rw nat_degree_multiset_prod',
  simp_rw [ne.def, multiset.prod_eq_zero_iff, multiset.mem_map, leading_coeff_eq_zero],
  rintro ⟨_, h, rfl⟩,
  contradiction
end

/--
The degree of a product of polynomials is equal to
the sum of the degrees, where the degree of the zero polynomial is ⊥.
-/
lemma degree_multiset_prod [nontrivial R] :
  t.prod.degree = (t.map (λ f, degree f)).sum :=
begin
  refine multiset.induction_on t _ (λ a t ht, _), { simp },
  { rw [prod_cons, degree_mul, ht, map_cons, sum_cons] }
end

/--
The degree of a product of polynomials is equal to
the sum of the degrees, where the degree of the zero polynomial is ⊥.
-/
lemma degree_prod [nontrivial R] : (∏ i in s, f i).degree = ∑ i in s, (f i).degree :=
by simpa using degree_multiset_prod (s.1.map f)

/--
The leading coefficient of a product of polynomials is equal to
the product of the leading coefficients.

See `polynomial.leading_coeff_multiset_prod'` (with a `'`) for a version for commutative semirings,
where additionally, the product of the leading coefficients must be nonzero.
-/
lemma leading_coeff_multiset_prod :
  t.prod.leading_coeff = (t.map (λ f, leading_coeff f)).prod :=
by { rw [← leading_coeff_hom_apply, monoid_hom.map_multiset_prod], refl }

/--
The leading coefficient of a product of polynomials is equal to
the product of the leading coefficients.

See `polynomial.leading_coeff_prod'` (with a `'`) for a version for commutative semirings,
where additionally, the product of the leading coefficients must be nonzero.
-/
lemma leading_coeff_prod :
  (∏ i in s, f i).leading_coeff = ∏ i in s, (f i).leading_coeff :=
by simpa using leading_coeff_multiset_prod (s.1.map f)

end no_zero_divisors
end polynomial


/-
Copyright (c) 2022 Junyan Xu. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Junyan Xu
-/
import data.finsupp.lex
import data.finsupp.multiset
import order.game_add

/-!
# Termination of a hydra game

This file deals with the following version of the hydra game: each head of the hydra is
labelled by an element in a type `α`, and when you cut off one head with label `a`, it
grows back an arbitrary but finite number of heads, all labelled by elements smaller than
`a` with respect to a well-founded relation `r` on `α`. We show that no matter how (in
what order) you choose cut off the heads, the game always terminates, i.e. all heads will
eventually be cut off (but of course it can last arbitrarily long, i.e. takes an
arbitrary finite number of steps).

This result is stated as the well-foundedness of the `cut_expand` relation defined in
this file: we model the heads of the hydra as a multiset of elements of `α`, and the
valid "moves" of the game are modelled by the relation `cut_expand r` on `multiset α`:
`cut_expand r s' s` is true iff `s'` is obtained by removing one head `a ∈ s` and
adding back an arbitrary multiset `t` of heads such that all `a' ∈ t` satisfy `r a' a`.

We follow the proof by Peter LeFanu Lumsdaine at https://mathoverflow.net/a/229084/3332.

TODO: formalize the relations corresponding to more powerful (e.g. Kirby–Paris and Buchholz)
hydras, and prove their well-foundedness.
-/

namespace relation

open multiset prod

variables {α : Type*}

/-- The relation that specifies valid moves in our hydra game. `cut_expand r s' s`
  means that `s'` is obtained by removing one head `a ∈ s` and adding back an arbitrary
  multiset `t` of heads such that all `a' ∈ t` satisfy `r a' a`.

  This is most directly translated into `s' = s.erase a + t`, but `multiset.erase` requires
  `decidable_eq α`, so we use the equivalent condition `s' + {a} = s + t` instead, which
  is also easier to verify for explicit multisets `s'`, `s` and `t`.

  We also don't include the condition `a ∈ s` because `s' + {a} = s + t` already
  guarantees `a ∈ s + t`, and if `r` is irreflexive then `a ∉ t`, which is the
  case when `r` is well-founded, the case we are primarily interested in.

  The lemma `relation.cut_expand_iff` below converts between this convenient definition
  and the direct translation when `r` is irreflexive. -/
def cut_expand (r : α → α → Prop) (s' s : multiset α) : Prop :=
∃ (t : multiset α) (a : α), (∀ a' ∈ t, r a' a) ∧ s' + {a} = s + t

variable {r : α → α → Prop}

lemma cut_expand_le_inv_image_lex [hi : is_irrefl α r] :
  cut_expand r ≤ inv_image (finsupp.lex (rᶜ ⊓ (≠)) (<)) to_finsupp :=
λ s t ⟨u, a, hr, he⟩, begin
  classical, refine ⟨a, λ b h, _, _⟩; simp_rw to_finsupp_apply,
  { apply_fun count b at he, simp_rw count_add at he,
    convert he; convert (add_zero _).symm; rw count_eq_zero; intro hb,
    exacts [h.2 (mem_singleton.1 hb), h.1 (hr b hb)] },
  { apply_fun count a at he, simp_rw [count_add, count_singleton_self] at he,
    apply nat.lt_of_succ_le, convert he.le, convert (add_zero _).symm,
    exact count_eq_zero.2 (λ ha, hi.irrefl a $ hr a ha) },
end

theorem cut_expand_singleton {s x} (h : ∀ x' ∈ s, r x' x) : cut_expand r s {x} :=
⟨s, x, h, add_comm s _⟩

theorem cut_expand_singleton_singleton {x' x} (h : r x' x) : cut_expand r {x'} {x} :=
cut_expand_singleton (λ a h, by rwa mem_singleton.1 h)

theorem cut_expand_add_left {t u} (s) : cut_expand r (s + t) (s + u) ↔ cut_expand r t u :=
exists₂_congr $ λ _ _, and_congr iff.rfl $ by rw [add_assoc, add_assoc, add_left_cancel_iff]

lemma cut_expand_iff [decidable_eq α] [is_irrefl α r] {s' s : multiset α} :
  cut_expand r s' s ↔ ∃ (t : multiset α) a, (∀ a' ∈ t, r a' a) ∧ a ∈ s ∧ s' = s.erase a + t :=
begin
  simp_rw [cut_expand, add_singleton_eq_iff],
  refine exists₂_congr (λ t a, ⟨_, _⟩),
  { rintro ⟨ht, ha, rfl⟩,
    obtain h|h := mem_add.1 ha,
    exacts [⟨ht, h, t.erase_add_left_pos h⟩, (@irrefl α r _ a (ht a h)).elim] },
  { rintro ⟨ht, h, rfl⟩,
    exact ⟨ht, mem_add.2 (or.inl h), (t.erase_add_left_pos h).symm⟩ },
end

theorem not_cut_expand_zero [is_irrefl α r] (s) : ¬ cut_expand r s 0 :=
by { classical, rw cut_expand_iff, rintro ⟨_, _, _, ⟨⟩, _⟩ }

/-- For any relation `r` on `α`, multiset addition `multiset α × multiset α → multiset α` is a
  fibration between the game sum of `cut_expand r` with itself and `cut_expand r` itself. -/
lemma cut_expand_fibration (r : α → α → Prop) :
  fibration (game_add (cut_expand r) (cut_expand r)) (cut_expand r) (λ s, s.1 + s.2) :=
begin
  rintro ⟨s₁, s₂⟩ s ⟨t, a, hr, he⟩, dsimp at he ⊢,
  classical, obtain ⟨ha, rfl⟩ := add_singleton_eq_iff.1 he,
  rw [add_assoc, mem_add] at ha, obtain (h|h) := ha,
  { refine ⟨(s₁.erase a + t, s₂), game_add.fst ⟨t, a, hr, _⟩, _⟩,
    { rw [add_comm, ← add_assoc, singleton_add, cons_erase h] },
    { rw [add_assoc s₁, erase_add_left_pos _ h, add_right_comm, add_assoc] } },
  { refine ⟨(s₁, (s₂ + t).erase a), game_add.snd ⟨t, a, hr, _⟩, _⟩,
    { rw [add_comm, singleton_add, cons_erase h] },
    { rw [add_assoc, erase_add_right_pos _ h] } },
end

/-- A multiset is accessible under `cut_expand` if all its singleton subsets are,
  assuming `r` is irreflexive. -/
lemma acc_of_singleton [is_irrefl α r] {s : multiset α} :
  (∀ a ∈ s, acc (cut_expand r) {a}) → acc (cut_expand r) s :=
begin
  refine multiset.induction _ _ s,
  { exact λ _, acc.intro 0 $ λ s h, (not_cut_expand_zero s h).elim },
  { intros a s ih hacc, rw ← s.singleton_add a,
    exact ((hacc a $ s.mem_cons_self a).prod_game_add $ ih $ λ a ha,
      hacc a $ mem_cons_of_mem ha).of_fibration _ (cut_expand_fibration r) },
end

/-- A singleton `{a}` is accessible under `cut_expand r` if `a` is accessible under `r`,
  assuming `r` is irreflexive. -/
lemma _root_.acc.cut_expand [is_irrefl α r] {a : α} (hacc : acc r a) : acc (cut_expand r) {a} :=
begin
  induction hacc with a h ih,
  refine acc.intro _ (λ s, _),
  classical, rw cut_expand_iff,
  rintro ⟨t, a, hr, rfl|⟨⟨⟩⟩, rfl⟩,
  refine acc_of_singleton (λ a', _),
  rw [erase_singleton, zero_add],
  exact ih a' ∘ hr a',
end

/-- `cut_expand r` is well-founded when `r` is. -/
theorem _root_.well_founded.cut_expand (hr : well_founded r) : well_founded (cut_expand r) :=
⟨by { letI h := hr.is_irrefl, exact λ s, acc_of_singleton $ λ a _, (hr.apply a).cut_expand }⟩

end relation


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import tactic.abel
import data.polynomial.eval

/-!
# The Pochhammer polynomials

We define and prove some basic relations about
`pochhammer S n : S[X] := X * (X + 1) * ... * (X + n - 1)`
which is also known as the rising factorial. A version of this definition
that is focused on `nat` can be found in `data.nat.factorial` as `nat.asc_factorial`.

## Implementation

As with many other families of polynomials, even though the coefficients are always in `ℕ`,
we define the polynomial with coefficients in any `[semiring S]`.

## TODO

There is lots more in this direction:
* q-factorials, q-binomials, q-Pochhammer.
-/

universes u v

open polynomial
open_locale polynomial

section semiring
variables (S : Type u) [semiring S]

/--
`pochhammer S n` is the polynomial `X * (X+1) * ... * (X + n - 1)`,
with coefficients in the semiring `S`.
-/
noncomputable def pochhammer : ℕ → S[X]
| 0 := 1
| (n+1) := X * (pochhammer n).comp (X + 1)

@[simp] lemma pochhammer_zero : pochhammer S 0 = 1 := rfl
@[simp] lemma pochhammer_one : pochhammer S 1 = X := by simp [pochhammer]

lemma pochhammer_succ_left (n : ℕ) : pochhammer S (n+1) = X * (pochhammer S n).comp (X+1) :=
by rw pochhammer

section
variables {S} {T : Type v} [semiring T]
@[simp] lemma pochhammer_map (f : S →+* T) (n : ℕ) : (pochhammer S n).map f = pochhammer T n :=
begin
  induction n with n ih,
  { simp, },
  { simp [ih, pochhammer_succ_left, map_comp], },
end

end

@[simp, norm_cast] lemma pochhammer_eval_cast (n k : ℕ) :
  ((pochhammer ℕ n).eval k : S) = (pochhammer S n).eval k :=
begin
  rw [←pochhammer_map (algebra_map ℕ S), eval_map, ←eq_nat_cast (algebra_map ℕ S),
    eval₂_at_nat_cast, nat.cast_id, eq_nat_cast],
end

lemma pochhammer_eval_zero {n : ℕ} : (pochhammer S n).eval 0 = if n = 0 then 1 else 0 :=
begin
  cases n,
  { simp, },
  { simp [X_mul, nat.succ_ne_zero, pochhammer_succ_left], }
end

lemma pochhammer_zero_eval_zero : (pochhammer S 0).eval 0 = 1 :=
by simp

@[simp] lemma pochhammer_ne_zero_eval_zero {n : ℕ} (h : n ≠ 0) : (pochhammer S n).eval 0 = 0 :=
by simp [pochhammer_eval_zero, h]

lemma pochhammer_succ_right (n : ℕ) : pochhammer S (n+1) = pochhammer S n * (X + n) :=
begin
  suffices h : pochhammer ℕ (n+1) = pochhammer ℕ n * (X + n),
  { apply_fun polynomial.map (algebra_map ℕ S) at h,
    simpa only [pochhammer_map, polynomial.map_mul, polynomial.map_add,
                map_X, polynomial.map_nat_cast] using h },
  induction n with n ih,
  { simp, },
  { conv_lhs
  { rw [pochhammer_succ_left, ih, mul_comp, ←mul_assoc, ←pochhammer_succ_left, add_comp, X_comp,
      nat_cast_comp, add_assoc, add_comm (1 : ℕ[X])], },
    refl, },
end

lemma pochhammer_succ_eval {S : Type*} [semiring S] (n : ℕ) (k : S) :
  (pochhammer S (n + 1)).eval k = (pochhammer S n).eval k * (k + n) :=
by rw [pochhammer_succ_right, mul_add, eval_add, eval_mul_X, ← nat.cast_comm, ← C_eq_nat_cast,
    eval_C_mul, nat.cast_comm, ← mul_add]

lemma pochhammer_succ_comp_X_add_one (n : ℕ) :
  (pochhammer S (n + 1)).comp (X + 1) =
    pochhammer S (n + 1) + (n + 1) • (pochhammer S n).comp (X + 1) :=
begin
  suffices : (pochhammer ℕ (n + 1)).comp (X + 1) =
              pochhammer ℕ (n + 1) + (n + 1) * (pochhammer ℕ n).comp (X + 1),
  { simpa [map_comp] using congr_arg (polynomial.map (nat.cast_ring_hom S)) this },
  cases n,
  { simp },
  { nth_rewrite 1 pochhammer_succ_left,
    rw [← add_mul, pochhammer_succ_right ℕ (n + 1), mul_comp, mul_comm, add_comp, X_comp,
      nat_cast_comp, add_comm ↑(n + 1), ← add_assoc] }
end

lemma polynomial.mul_X_add_nat_cast_comp {p q : S[X]} {n : ℕ} :
  (p * (X + n)).comp q = (p.comp q) * (q + n) :=
by rw [mul_add, add_comp, mul_X_comp, ←nat.cast_comm, nat_cast_mul_comp, nat.cast_comm, mul_add]

lemma pochhammer_mul (n m : ℕ) :
  pochhammer S n * (pochhammer S m).comp (X + n) = pochhammer S (n + m) :=
begin
  induction m with m ih,
  { simp, },
  { rw [pochhammer_succ_right, polynomial.mul_X_add_nat_cast_comp, ←mul_assoc, ih,
      nat.succ_eq_add_one, ←add_assoc, pochhammer_succ_right, nat.cast_add, add_assoc], }
end

lemma pochhammer_nat_eq_asc_factorial (n : ℕ) :
  ∀ k, (pochhammer ℕ k).eval (n + 1) = n.asc_factorial k
| 0 := by erw [eval_one]; refl
| (t + 1) := begin
  rw [pochhammer_succ_right, eval_mul, pochhammer_nat_eq_asc_factorial t],
  suffices : n.asc_factorial t * (n + 1 + t) = n.asc_factorial (t + 1), by simpa,
  rw [nat.asc_factorial_succ, add_right_comm, mul_comm]
end

lemma pochhammer_nat_eq_desc_factorial (a b : ℕ) :
  (pochhammer ℕ b).eval a = (a + b - 1).desc_factorial b :=
begin
  cases b,
  { rw [nat.desc_factorial_zero, pochhammer_zero, polynomial.eval_one] },
  rw [nat.add_succ, nat.succ_sub_succ, tsub_zero],
  cases a,
  { rw [pochhammer_ne_zero_eval_zero _ b.succ_ne_zero, zero_add,
    nat.desc_factorial_of_lt b.lt_succ_self] },
  { rw [nat.succ_add, ←nat.add_succ, nat.add_desc_factorial_eq_asc_factorial,
      pochhammer_nat_eq_asc_factorial] }
end

end semiring

section ordered_semiring
variables {S : Type*} [ordered_semiring S] [nontrivial S]

lemma pochhammer_pos (n : ℕ) (s : S) (h : 0 < s) : 0 < (pochhammer S n).eval s :=
begin
  induction n with n ih,
  { simp only [nat.nat_zero_eq_zero, pochhammer_zero, eval_one], exact zero_lt_one, },
  { rw [pochhammer_succ_right, mul_add, eval_add, ←nat.cast_comm, eval_nat_cast_mul, eval_mul_X,
      nat.cast_comm, ←mul_add],
    exact mul_pos ih
      (lt_of_lt_of_le h ((le_add_iff_nonneg_right _).mpr (nat.cast_nonneg n))), }
end

end ordered_semiring

section factorial

open_locale nat

variables (S : Type*) [semiring S] (r n : ℕ)

@[simp]
lemma pochhammer_eval_one (S : Type*) [semiring S] (n : ℕ) :
  (pochhammer S n).eval (1 : S) = (n! : S) :=
by rw_mod_cast [pochhammer_nat_eq_asc_factorial, nat.zero_asc_factorial]

lemma factorial_mul_pochhammer (S : Type*) [semiring S] (r n : ℕ) :
  (r! : S) * (pochhammer S n).eval (r + 1) = (r + n)! :=
by rw_mod_cast [pochhammer_nat_eq_asc_factorial, nat.factorial_mul_asc_factorial]

lemma pochhammer_nat_eval_succ (r : ℕ) :
  ∀ n : ℕ, n * (pochhammer ℕ r).eval (n + 1) = (n + r) * (pochhammer ℕ r).eval n
| 0 := begin
  by_cases h : r = 0,
  { simp only [h, zero_mul, zero_add], },
  { simp only [pochhammer_eval_zero, zero_mul, if_neg h, mul_zero], }
end
| (k + 1) := by simp only [pochhammer_nat_eq_asc_factorial, nat.succ_asc_factorial, add_right_comm]

lemma pochhammer_eval_succ (r n : ℕ) :
  (n : S) * (pochhammer S r).eval (n + 1 : S) = (n + r) * (pochhammer S r).eval n :=
by exact_mod_cast congr_arg nat.cast (pochhammer_nat_eval_succ r n)

end factorial


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

We provide two versions of the quoptient construction. They use the same names and notation:
one lives in the namespace 'quotient_group' and the other lives in the namespace
'quotient_group_general'.

The first takes a group, A, and a normal subgroup, H. We have

  quotient H       := the quotient of A by H
  qproj H a        := the projection, with notation a' * G
  qproj H ' s      := the image of s, with notation s / G
  extend H respf   := given f : A → B respecting the equivalence relation, we get a function
                      f : quotient G → B
  bar f            := the above, G = ker f)

The definition is constructive, using quotient types. We prove all the characteristic properties.

As in the SSReflect library, we also provide a construction to quotient by an *arbitrary subgroup*.
Now we have

  quotient H       := the quotient of normalizer H by H
  qproj H a        := still denoted a '* H, the projection when a is in normalizer H,
                      arbitrary otherwise
  qproj H G        := still denoted G / H, the image of the above
  extend H G respf := given a homomorphism on G with ker_in G f ⊆ H, extends to a
                      homomorphism G / H
  bar G f          := the above, with H = ker_in f G

This quotient H is defined by composing the first one with the construction which turns
normalizer H into a group.
-/
import .subgroup_to_group theories.move
open set function subtype classical quot

namespace group_theory
open coset_notation

variables {A B C : Type}

/- the quotient group -/

namespace quotient_group

variables [group A] (H : set A) [is_normal H]

definition lcoset_setoid [instance] : setoid A :=
setoid.mk (lcoset_equiv H) (equivalence_lcoset_equiv H)

definition quotient := quot (lcoset_setoid H)

private definition qone : quotient H := ⟦ 1 ⟧

private definition qmul : quotient H → quotient H → quotient H :=
quot.lift₂
  (λ a b, ⟦a * b⟧)
  (λ a₁ a₂ b₁ b₂ e₁ e₂, quot.sound (lcoset_equiv_mul H e₁ e₂))

private definition qinv : quotient H → quotient H :=
quot.lift
  (λ a, ⟦a⁻¹⟧)
  (λ a₁ a₂ e, quot.sound (lcoset_equiv_inv H e))

private proposition qmul_assoc (a b c : quotient H) :
  qmul H (qmul H a b) c = qmul H a (qmul H b c) :=
quot.induction_on₂ a b (λ a b, quot.induction_on c (λ c,
  have H :  ⟦a * b * c⟧ = ⟦a * (b * c)⟧, by rewrite mul.assoc,
  H))

private proposition qmul_qone (a : quotient H) : qmul H a (qone H) = a :=
quot.induction_on a (λ a', show ⟦a' * 1⟧ = ⟦a'⟧, by rewrite mul_one)

private proposition qone_qmul (a : quotient H) : qmul H (qone H) a = a :=
quot.induction_on a (λ a', show ⟦1 * a'⟧ = ⟦a'⟧, by rewrite one_mul)

private proposition qmul_left_inv (a : quotient H) : qmul H (qinv H a) a = qone H :=
quot.induction_on a (λ a', show ⟦a'⁻¹ * a'⟧ = ⟦1⟧, by rewrite mul.left_inv)

protected definition group [instance] : group (quotient H) :=
⦃ group,
  mul          := qmul H,
  inv          := qinv H,
  one          := qone H,
  mul_assoc    := qmul_assoc H,
  mul_one      := qmul_qone H,
  one_mul      := qone_qmul H,
  mul_left_inv := qmul_left_inv H
⦄

-- these theorems characterize the quotient group

definition qproj (a : A) : quotient H := ⟦a⟧

infix ` '* `:65  := λ {A' : Type} [group A'] a H' [is_normal H'], qproj H' a
infix ` / `      := λ {A' : Type} [group A'] G H' [is_normal H'], qproj H' ' G

proposition is_hom_qproj [instance] : is_hom (qproj H) :=
is_mul_hom.mk (λ a b, rfl)

variable {H}

proposition qproj_eq_qproj {a b : A} (h : a * H = b * H) : a '* H = b '* H :=
quot.sound h

proposition lcoset_eq_lcoset_of_qproj_eq_qproj {a b : A} (h : a '* H = b '* H) :  a * H = b * H :=
quot.exact h

variable (H)

proposition qproj_eq_qproj_iff (a b : A) : a '* H = b '* H ↔ a * H = b * H :=
iff.intro lcoset_eq_lcoset_of_qproj_eq_qproj qproj_eq_qproj

proposition ker_qproj [is_subgroup H] : ker (qproj H) = H :=
ext (take a,
  begin
    rewrite [↑ker, mem_set_of_iff, -hom_one (qproj H), qproj_eq_qproj_iff,
      one_lcoset],
    show a * H = H ↔ a ∈ H, from iff.intro mem_of_lcoset_eq_self lcoset_eq_self_of_mem
  end)

proposition qproj_eq_one_iff [is_subgroup H] (a : A) : a '* H = 1 ↔ a ∈ H :=
have H : qproj H a = 1 ↔ a ∈ ker (qproj H), from iff.rfl,
by rewrite [H, ker_qproj]

variable {H}

proposition qproj_eq_one_of_mem [is_subgroup H] {a : A} (aH : a ∈ H) : a '* H = 1 :=
iff.mpr (qproj_eq_one_iff H a) aH

proposition mem_of_qproj_eq_one [is_subgroup H] {a : A} (h : a '* H = 1) : a ∈ H :=
iff.mp (qproj_eq_one_iff H a) h

variable (H)

proposition surjective_qproj : surjective (qproj H) :=
take y, quot.induction_on y (λ a, exists.intro a rfl)

variable {H}

proposition quotient_induction {P : quotient H → Prop} (h : ∀ a, P (a '* H)) : ∀ a, P a :=
quot.ind h

proposition quotient_induction₂ {P : quotient H → quotient H → Prop}
    (h : ∀ a₁ a₂, P (a₁ '* H) (a₂ '* H)) :
  ∀ a₁ a₂, P a₁ a₂ :=
quot.ind₂ h

variable (H)

proposition image_qproj_self [is_subgroup H] : H / H = '{1} :=
eq_of_subset_of_subset
  (image_subset_of_maps_to
    (take x, suppose x ∈ H,
      show x '* H ∈ '{1},
        from mem_singleton_of_eq (qproj_eq_one_of_mem `x ∈ H`)))
  (take x, suppose x ∈ '{1},
    have x = 1, from eq_of_mem_singleton this,
    show x ∈ H / H, by rewrite this; apply mem_image_of_mem _ one_mem)

-- extending a function A → B to a function A / H → B

section respf

variable {H}
variables {f : A → B} (respf : ∀ a₁ a₂, a₁ * H = a₂ * H → f a₁ = f a₂)

definition extend : quotient H → B := quot.lift f respf

proposition extend_qproj (a : A) : extend respf (a '* H) = f a := rfl

proposition extend_comp_qproj : extend respf ∘ (qproj H) = f := rfl

proposition image_extend (G : set A) : (extend respf) ' (G / H) = f ' G :=
by rewrite [-image_comp]

variable [group B]

proposition is_hom_extend [instance] [is_hom f] : is_hom (extend respf) :=
is_mul_hom.mk (take a b,
  show (extend respf (a * b)) = (extend respf a) * (extend respf b), from
    quot.induction_on₂ a b (take a b, hom_mul f a b))

proposition ker_extend : ker (extend respf) = ker f / H :=
eq_of_subset_of_subset
  (quotient_induction
    (take a, assume Ha : qproj H a ∈ ker (extend respf),
      have f a = 1, from Ha,
      show a '* H ∈ ker f / H,
        from mem_image_of_mem _ this))
  (image_subset_of_maps_to
    (take a, assume h : a ∈ ker f,
      show extend respf (a '* H) = 1, from h))

end respf

end quotient_group

/- the first homomorphism theorem for the quotient group -/

namespace quotient_group
  variables [group A] [group B] (f : A → B) [is_hom f]

  lemma eq_of_lcoset_equiv_ker ⦃a b : A⦄ (h : lcoset_equiv (ker f) a b) : f a = f b :=
  have b⁻¹ * a ∈ ker f, from inv_mul_mem_of_lcoset_eq_lcoset h,
  eq.symm (eq_of_inv_mul_mem_ker this)

  definition bar : quotient (ker f) → B := extend (eq_of_lcoset_equiv_ker f)

  proposition bar_qproj (a : A) : bar f (a '* ker f) = f a := rfl

  proposition is_hom_bar [instance] : is_hom (bar f) := is_hom_extend _

  proposition image_bar (G : set A) : bar f ' (G / ker f) = f ' G :=
  by rewrite [↑bar, image_extend]

  proposition image_bar_univ : bar f ' univ = f ' univ :=
  by rewrite [↑bar, -image_eq_univ_of_surjective (surjective_qproj (ker f)),
       image_extend]

  proposition surj_on_bar : surj_on (bar f) univ (f ' univ) :=
  by rewrite [↑surj_on, image_bar_univ]; apply subset.refl

  proposition ker_bar_eq : ker (bar f) = '{1} :=
  by rewrite [↑bar, ker_extend, image_qproj_self]

  proposition injective_bar : injective (bar f) :=
  injective_of_ker_eq_singleton_one (ker_bar_eq f)
end quotient_group

/- a generic morphism extension property -/

section
  variables [group A] [group B] [group C]
  variables (G : set A) [is_subgroup G]
  variables (g : A → C) (f : A → B)

  noncomputable definition gen_extend : C → B := λ c, f (inv_fun g G 1 c)

  variables {G g f}

  proposition eq_of_ker_in_subset {a₁ a₂ : A} (a₁G : a₁ ∈ G) (a₂G : a₂ ∈ G)
      [is_hom_on g G] [is_hom_on f G] (Hker : ker_in g G ⊆ ker f) (H' : g a₁ = g a₂) :
    f a₁ = f a₂ :=
  have memG : a₁⁻¹ * a₂ ∈ G, from mul_mem (inv_mem a₁G) a₂G,
  have a₁⁻¹ * a₂ ∈ ker_in g G, from inv_mul_mem_ker_in_of_eq a₁G a₂G H',
  have a₁⁻¹ * a₂ ∈ ker_in f G, from and.intro (Hker this) memG,
  show f a₁ = f a₂, from eq_of_inv_mul_mem_ker_in a₁G a₂G this

  proposition gen_extend_spec [is_hom_on g G] [is_hom_on f G] (Hker : ker_in g G ⊆ ker f)
    {a : A} (aG : a ∈ G) : gen_extend G g f (g a) = f a :=
  eq_of_ker_in_subset (inv_fun_spec' aG) aG Hker (inv_fun_spec aG)

  proposition is_hom_on_gen_extend [is_hom_on g G] [is_hom_on f G] (Hker : ker_in g G ⊆ ker f) :
    is_hom_on (gen_extend G g f) (g ' G) :=
  have is_subgroup (g ' G), from is_subgroup_image g G,
  take c₁, assume c₁gG : c₁ ∈ g ' G,
  take c₂, assume c₂gG : c₂ ∈ g ' G,
  let ginv := inv_fun g G 1 in
  have Hginv : maps_to ginv (g ' G) G, from maps_to_inv_fun one_mem,
  have ginvc₁ : ginv c₁ ∈ G, from Hginv c₁gG,
  have ginvc₂ : ginv c₂ ∈ G, from Hginv c₂gG,
  have ginvc₁c₂ : ginv (c₁ * c₂) ∈ G, from Hginv (mul_mem c₁gG c₂gG),
  have HH : ∀₀ c ∈ g ' G, g (ginv c) = c,
    from λ a aG, right_inv_on_inv_fun_of_surj_on _ (surj_on_image g G) aG,
  have eq₁ : g (ginv c₁) = c₁, from HH c₁gG,
  have eq₂ : g (ginv c₂) = c₂, from HH c₂gG,
  have eq₃ : g (ginv (c₁ * c₂)) = c₁ * c₂, from HH (mul_mem c₁gG c₂gG),
  have g (ginv (c₁ * c₂)) = g ((ginv c₁) * (ginv c₂)),
    by rewrite [eq₃, hom_on_mul g ginvc₁ ginvc₂, eq₁, eq₂],
  have f (ginv (c₁ * c₂)) = f (ginv c₁ * ginv c₂),
    from eq_of_ker_in_subset (ginvc₁c₂) (mul_mem ginvc₁ ginvc₂) Hker this,
  show f (ginv (c₁ * c₂)) = f (ginv c₁) * f (ginv c₂),
    by rewrite [this, hom_on_mul f ginvc₁ ginvc₂]
end

/- quotient by an arbitrary group, not necessarily normal -/

namespace quotient_group_general

variables [group A] (H : set A) [is_subgroup H]

lemma is_normal_to_group_of_normalizer [instance] :
  is_normal (to_group_of (normalizer H) ' H) :=
have H1 : is_normal_in (to_group_of (normalizer H) ' H)
                       (to_group_of (normalizer H) ' (normalizer H)),
  from is_normal_in_image_image (subset_normalizer_self H) (to_group_of (normalizer H)),
have H2 : to_group_of (normalizer H) ' (normalizer H) = univ,
  from image_to_group_of_eq_univ (normalizer H),
is_normal_of_is_normal_in_univ (by rewrite -H2; exact H1)

section quotient_group
open quotient_group

noncomputable definition quotient : Type := quotient (to_group_of (normalizer H) ' H)

noncomputable definition group_quotient  [instance] : group (quotient H) :=
quotient_group.group (to_group_of (normalizer H) ' H)

noncomputable definition qproj : A → quotient H :=
qproj (to_group_of (normalizer H) ' H) ∘ (to_group_of (normalizer H))

infix ` '* `:65  := λ {A' : Type} [group A'] a H' [is_subgroup H'], qproj H' a
infix ` / `      := λ {A' : Type} [group A'] G H' [is_subgroup H'], qproj H' ' G

proposition is_hom_on_qproj [instance] : is_hom_on (qproj H) (normalizer H) :=
have H₀ : is_hom_on (to_group_of (normalizer H)) (normalizer H),
  from is_hom_on_to_group_of (normalizer H),
have H₁ : is_hom_on (quotient_group.qproj (to_group_of (normalizer H) ' H)) univ,
  from iff.mpr (is_hom_on_univ_iff (quotient_group.qproj (to_group_of (normalizer H) ' H)))
         (is_hom_qproj (to_group_of (normalizer H) ' H)),
is_hom_on_comp H₀ H₁ (maps_to_univ (to_group_of (normalizer H)) (normalizer H))

proposition is_hom_on_qproj' [instance] (G : set A) [is_normal_in H G] :
  is_hom_on (qproj H) G :=
is_hom_on_of_subset (qproj H) (subset_normalizer G H)

proposition ker_in_qproj : ker_in (qproj H) (normalizer H) = H :=
let tg := to_group_of (normalizer H) in
begin
  rewrite [↑ker_in, ker_eq_preimage_one, ↑qproj, preimage_comp, -ker_eq_preimage_one],
  have is_hom_on tg H, from is_hom_on_of_subset _ (subset_normalizer_self H),
  have is_subgroup (tg ' H), from is_subgroup_image tg H,
  krewrite [ker_qproj, to_group_of_preimage_to_group_of_image (subset_normalizer_self H)]
end

end quotient_group

variable {H}

proposition qproj_eq_qproj_iff {a b : A} (Ha : a ∈ normalizer H) (Hb : b ∈ normalizer H) :
   a '* H = b '* H ↔ a * H = b * H :=
by rewrite [lcoset_eq_lcoset_iff, eq_iff_inv_mul_mem_ker_in Ha Hb, ker_in_qproj,
            -inv_mem_iff, mul_inv, inv_inv]

proposition qproj_eq_qproj {a b : A} (Ha : a ∈ normalizer H) (Hb : b ∈ normalizer H)
    (h : a * H = b * H) :
  a '* H = b '* H :=
iff.mpr (qproj_eq_qproj_iff Ha Hb) h

proposition lcoset_eq_lcoset_of_qproj_eq_qproj {a b : A}
    (Ha : a ∈ normalizer H) (Hb : b ∈ normalizer H) (h : a '* H = b '* H) :
  a * H = b * H :=
iff.mp (qproj_eq_qproj_iff Ha Hb) h

variable (H)

proposition qproj_mem {a : A} {G : set A} (aG : a ∈ G) : a '* H ∈ G / H :=
mem_image_of_mem _ aG

proposition qproj_one : 1 '* H = 1 := hom_on_one (qproj H) (normalizer H)

variable {H}

proposition mem_of_qproj_mem {a : A} (anH : a ∈ normalizer H)
    {G : set A} (HsubG : H ⊆ G) [is_subgroup G] [is_normal_in H G]
  (aHGH : a '* H ∈ G / H): a ∈ G :=
have GH : G ⊆ normalizer H, from subset_normalizer G H,
obtain b [bG (bHeq : b '* H = a '* H)], from aHGH,
have b * H = a * H, from lcoset_eq_lcoset_of_qproj_eq_qproj (GH bG) anH bHeq,
have a ∈ b * H, by rewrite this; apply mem_lcoset_self,
have a ∈ b * G, from lcoset_subset_lcoset b HsubG this,
show a ∈ G, by rewrite [lcoset_eq_self_of_mem bG at this]; apply this

proposition qproj_eq_one_iff {a : A} (Ha : a ∈ normalizer H) : a '* H = 1 ↔ a ∈ H :=
by rewrite [-hom_on_one (qproj H) (normalizer H), qproj_eq_qproj_iff Ha one_mem, one_lcoset,
        lcoset_eq_self_iff]

proposition qproj_eq_one_of_mem {a : A} (aH : a ∈ H) : a '* H = 1 :=
iff.mpr (qproj_eq_one_iff (subset_normalizer_self H aH)) aH

proposition mem_of_qproj_eq_one {a : A} (Ha : a ∈ normalizer H) (h : a '* H = 1) : a ∈ H :=
iff.mp (qproj_eq_one_iff Ha) h

variable (H)

section
open quotient_group
proposition surj_on_qproj_normalizer : surj_on (qproj H) (normalizer H) univ :=
have H₀ : surj_on (to_group_of (normalizer H)) (normalizer H) univ,
  from surj_on_to_group_of_univ (normalizer H),
have H₁ : surj_on (quotient_group.qproj (to_group_of (normalizer H) ' H)) univ univ,
  from surj_on_univ_of_surjective univ (surjective_qproj _),
surj_on_comp H₁ H₀
end

variable {H}

proposition quotient_induction {P : quotient H → Prop} (hyp : ∀₀ a ∈ normalizer H, P (a '* H)) :
  ∀ a, P a :=
surj_on_univ_induction (surj_on_qproj_normalizer H) hyp

proposition quotient_induction₂ {P : quotient H → quotient H → Prop}
    (hyp : ∀₀ a₁ ∈ normalizer H, ∀₀ a₂ ∈ normalizer H, P (a₁ '* H) (a₂ '* H)) :
  ∀ a₁ a₂, P a₁ a₂ :=
surj_on_univ_induction₂ (surj_on_qproj_normalizer H) hyp

variable (H)

proposition image_qproj_self : H / H = '{1} :=
eq_of_subset_of_subset
  (image_subset_of_maps_to
    (take x, suppose x ∈ H,
      show x '* H ∈ '{1},
        from mem_singleton_of_eq (qproj_eq_one_of_mem `x ∈ H`)))
  (take x, suppose x ∈ '{1},
    have x = 1, from eq_of_mem_singleton this,
    show x ∈ H / H,
      by rewrite [this, -qproj_one H]; apply mem_image_of_mem _ one_mem)

section respf

variable (H)
variables [group B] (G : set A) [is_subgroup G] (f : A → B)

noncomputable definition extend : quotient H → B := gen_extend G (qproj H) f

variables [is_hom_on f G] [is_normal_in H G]

private proposition aux : is_hom_on (qproj H) G :=
is_hom_on_of_subset (qproj H) (subset_normalizer G H)

local attribute [instance] aux

variables {H f}

private proposition aux' (respf : H ⊆ ker f) : ker_in (qproj H) G ⊆ ker f :=
subset.trans
  (show ker_in (qproj H) G ⊆ ker_in (qproj H) (normalizer H),
    from inter_subset_inter_left _ (subset_normalizer G H))
  (by rewrite [ker_in_qproj]; apply respf)

variable {G}

proposition extend_qproj (respf : H ⊆ ker f) {a : A} (aG : a ∈ G) :
  extend H G f (a '* H) = f a :=
gen_extend_spec (aux' G respf) aG

proposition image_extend (respf : H ⊆ ker f) {s : set A} (ssubG : s ⊆ G) :
  extend H G f ' (s / H) = f ' s :=
begin
  rewrite [-image_comp],
  apply image_eq_image_of_eq_on,
  intro a amems,
  apply extend_qproj respf (ssubG amems)
end

variable (G)

proposition is_hom_on_extend [instance] (respf : H ⊆ ker f) : is_hom_on (extend H G f) (G / H) :=
by unfold extend; apply is_hom_on_gen_extend (aux' G respf)

variable {G}

proposition ker_in_extend [is_subgroup G] (respf : H ⊆ ker f) (HsubG : H ⊆ G) :
  ker_in (extend H G f) (G / H) = (ker_in f G) / H :=
begin
  apply ext,
  intro aH,
  cases surj_on_qproj_normalizer H (show aH ∈ univ, from trivial) with a atemp,
  cases atemp with anH aHeq,
  rewrite -aHeq,
  apply iff.intro,
  { intro akerin,
    cases akerin with aker ain,
    have a '* H ∈ G / H, from ain,
    have a ∈ G, from mem_of_qproj_mem anH HsubG this,
    have a '* H ∈ ker (extend H G f), from aker,
    have extend H G f (a '* H) = 1, from this,
    have f a = extend H G f (a '* H), from eq.symm (extend_qproj respf `a ∈ G`),
    have f a = 1, by rewrite this; assumption,
    have a ∈ ker_in f G, from and.intro this `a ∈ G`,
    show a '* H ∈ (ker_in f G) / H, from qproj_mem H this},
  intro aHker,
  have aker : a ∈ ker_in f G,
    begin
      have Hsub : H ⊆ ker_in f G, from subset_inter respf HsubG,
      have is_normal_in H (ker_in f G),
        from subset.trans (inter_subset_right (ker f) G) (subset_normalizer G H),
      apply (mem_of_qproj_mem anH Hsub aHker)
    end,
  have a ∈ G, from and.right aker,
  have f a = 1, from and.left aker,
  have extend H G f (a '* H) = 1,
    from eq.trans (extend_qproj respf `a ∈ G`) this,
  show a '* H ∈ ker_in (extend H G f) (G / H),
    from and.intro this (qproj_mem H `a ∈ G`)
end

/- (comment from Jeremy)
This version kills the elaborator. I don't know why.
Tracing class instances doesn't show a problem. My best guess is that it is
the backgracking from the "obtain".

proposition ker_in_extend [is_subgroup G] (respf : H ⊆ ker f) (HsubG : H ⊆ G) :
  ker_in (extend H G f) (qproj H ' G) = qproj H ' (ker_in f G) :=
ext (take aH,
  obtain a [(anH : a ∈ normalizer H) (aHeq : a '* H = aH)],
    from surj_on_qproj_normalizer H (show aH ∈ univ, from trivial),
  begin
    rewrite -aHeq, apply iff.intro, unfold ker_in,
    exact
      (assume aker : a '* H ∈ ker (extend H G f) ∩ (qproj H ' G),
        have a '* H ∈ qproj H ' G, from and.right aker,
        have a ∈ G, from mem_of_qproj_mem anH HsubG this,
        -- Uncommenting the next line of code slows things down dramatically.
        -- Uncommenting the one after kills the system.
        -- have a '* H ∈ ker (extend H G f), from and.left aker,
        -- have extend H G f (a '* H) = 1, from this,
        -- have f a = extend H G f (a '* H), from eq.symm (extend_qproj respf `a ∈ G`),
        -- have f a = 1, by rewrite [-this, extend_qproj respf aG],
        -- have a ∈ ker_in f G, from and.intro this `a ∈ G`,
        show a '* H ∈ qproj H ' (ker_in f G), from sorry),
    exact
      (assume hyp : a '* H ∈ qproj H ' (ker_in f G),
        show a '* H ∈ ker_in (extend H G f) (qproj H ' G), from sorry)
  end)
-/

end respf

attribute quotient [irreducible]

end quotient_group_general

/- the first homomorphism theorem for general quotient groups -/

namespace quotient_group_general

variables [group A] [group B] (G : set A) [is_subgroup G]
variables (f : A → B) [is_hom_on f G]

noncomputable definition bar : quotient (ker_in f G) → B :=
extend (ker_in f G) G f

proposition bar_qproj {a : A} (aG : a ∈ G) : bar G f (a '* ker_in f G) = f a :=
extend_qproj (inter_subset_left _ _) aG

proposition is_hom_on_bar [instance] : is_hom_on (bar G f) (G / ker_in f G) :=
have is_subgroup (ker f ∩ G), from is_subgroup_ker_in f G,
have is_normal_in (ker f ∩ G) G, from is_normal_in_ker_in f G,
is_hom_on_extend G (inter_subset_left _ _)

proposition image_bar {s : set A} (ssubG : s ⊆ G) : bar G f ' (s / ker_in f G) = f ' s :=
have is_subgroup (ker f ∩ G), from is_subgroup_ker_in f G,
have is_normal_in (ker f ∩ G) G, from is_normal_in_ker_in f G,
image_extend (inter_subset_left _ _) ssubG

proposition surj_on_bar : surj_on (bar G f) (G / ker_in f G) (f ' G) :=
by rewrite [↑surj_on, image_bar G f (@subset.refl _ G)]; apply subset.refl

proposition ker_in_bar : ker_in (bar G f) (G / ker_in f G) = '{1} :=
have H₀ : ker_in f G ⊆ ker f, from inter_subset_left _ _,
have H₁ : ker_in f G ⊆ G, from inter_subset_right _ _,
by rewrite [↑bar, ker_in_extend H₀ H₁, image_qproj_self]

proposition inj_on_bar : inj_on (bar G f) (G / ker_in f G) :=
inj_on_of_ker_in_eq_singleton_one (ker_in_bar G f)

end quotient_group_general

end group_theory


/-
Copyright (c) 2021 Bolton Bailey. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bolton Bailey
-/
import algebra.periodic
import data.nat.count
import data.nat.interval

/-!
# Periodic Functions on ℕ

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

This file identifies a few functions on `ℕ` which are periodic, and also proves a lemma about
periodic predicates which helps determine their cardinality when filtering intervals over them.
-/

namespace nat

open nat function

lemma periodic_gcd (a : ℕ) : periodic (gcd a) a :=
by simp only [forall_const, gcd_add_self_right, eq_self_iff_true, periodic]

lemma periodic_coprime (a : ℕ) : periodic (coprime a) a :=
by simp only [coprime_add_self_right, forall_const, iff_self, eq_iff_iff, periodic]

lemma periodic_mod (a : ℕ) : periodic (λ n, n % a) a :=
by simp only [forall_const, eq_self_iff_true, add_mod_right, periodic]

lemma _root_.function.periodic.map_mod_nat {α : Type*} {f : ℕ → α} {a : ℕ} (hf : periodic f a) :
  ∀ n, f (n % a) = f n :=
λ n, by conv_rhs { rw [← nat.mod_add_div n a, mul_comm, ← nat.nsmul_eq_mul, hf.nsmul] }

section multiset
open multiset

/-- An interval of length `a` filtered over a periodic predicate of period `a` has cardinality
equal to the number naturals below `a` for which `p a` is true. -/
lemma filter_multiset_Ico_card_eq_of_periodic (n a : ℕ) (p : ℕ → Prop) [decidable_pred p]
  (pp : periodic p a) :
  (filter p (Ico n (n+a))).card = a.count p :=
begin
  rw [count_eq_card_filter_range, finset.card, finset.filter_val, finset.range_val,
    ←multiset_Ico_map_mod n, ←map_count_true_eq_filter_card, ←map_count_true_eq_filter_card,
    map_map, function.comp],
  simp only [pp.map_mod_nat],
end

end multiset

section finset
open finset

/-- An interval of length `a` filtered over a periodic predicate of period `a` has cardinality
equal to the number naturals below `a` for which `p a` is true. -/
lemma filter_Ico_card_eq_of_periodic (n a : ℕ) (p : ℕ → Prop) [decidable_pred p]
  (pp : periodic p a) :
  ((Ico n (n + a)).filter p).card = a.count p :=
filter_multiset_Ico_card_eq_of_periodic n a p pp

end finset

end nat