/-
Copyright (c) Sidharth Hariharan. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kevin Buzzard, Sidharth Hariharan
-/
import data.polynomial.div
import data.zmod.basic
import logic.function.basic
import ring_theory.localization.fraction_ring
import tactic.field_simp
import tactic.linear_combination

/-!

# Partial fractions

These results were formalised by the Xena Project, at the suggestion
of Patrick Massot.

# The main theorem

* `div_eq_quo_add_sum_rem_div`: General partial fraction decomposition theorem for polynomials over
  an integral domain R :
  If f, g₁, g₂, ..., gₙ ∈ R[X] and the gᵢs are all monic and pairwise coprime, then ∃ q, r₁, ..., rₙ
  ∈ R[X] such that f / g₁g₂...gₙ = q + r₁/g₁ + ... + rₙ/gₙ and for all i, deg(rᵢ) < deg(gᵢ).

* The result is formalized here in slightly more generality, using finsets. That is, if ι is an
  arbitrary index type, g denotes a map from ι to R[X], and if s is an arbitrary finite subset of ι,
  with g i monic for all i ∈ s and for all i,j ∈ s, i ≠ j → g i is coprime to g j, then we have
  ∃ q ∈ R[X] , r : ι → R[X] such that ∀ i ∈ s, deg(r i) < deg(g i) and
  f / ∏ g i = q + ∑ (r i) / (g i), where the product and sum are over s.

* The proof is done by proving the two-denominator case and then performing finset induction for an
  arbitrary (finite) number of denominators.

## Scope for Expansion

* Proving uniqueness of the decomposition

-/

variables (R : Type) [comm_ring R] [is_domain R]

open_locale polynomial

open polynomial

variables (K : Type) [field K] [algebra R[X] K] [is_fraction_ring R[X] K]

section two_denominators

/--
Let R be an integral domain and f, g₁, g₂ ∈ R[X]. Let g₁ and g₂ be monic and coprime.
Then, ∃ q, r₁, r₂ ∈ R[X] such that f / g₁g₂ = q + r₁/g₁ + r₂/g₂ and deg(r₁) < deg(g₁) and
deg(r₂) < deg(g₂).
-/
lemma div_eq_quo_add_rem_div_add_rem_div (f : R[X]) {g₁ g₂ : R[X]}
  (hg₁ : g₁.monic) (hg₂ : g₂.monic) (hcoprime : is_coprime g₁ g₂) :
  ∃ q r₁ r₂ : R[X], r₁.degree < g₁.degree ∧ r₂.degree < g₂.degree ∧
  (↑f : K) / (↑g₁ * ↑g₂) = ↑q + ↑r₁ / ↑g₁ + ↑r₂ / ↑g₂ :=
begin
  rcases hcoprime with ⟨c, d, hcd⟩,
  refine ⟨(f * d) /ₘ g₁ + (f * c) /ₘ g₂, (f * d) %ₘ g₁, (f * c) %ₘ g₂,
    (degree_mod_by_monic_lt _ hg₁), (degree_mod_by_monic_lt _ hg₂), _⟩,
  have hg₁' : (↑g₁ : K) ≠ 0,
  { norm_cast, exact hg₁.ne_zero_of_ne zero_ne_one, },
  have hg₂' : (↑g₂ : K) ≠ 0,
  { norm_cast, exact hg₂.ne_zero_of_ne zero_ne_one, },
  have hfc := mod_by_monic_add_div (f * c) hg₂,
  have hfd := mod_by_monic_add_div (f * d) hg₁,
  field_simp,
  norm_cast,
  linear_combination (-1) * f * hcd + (-1) * g₁ * hfc + (-1) * g₂ * hfd,
end

end two_denominators

section n_denominators

open_locale big_operators classical

/--
Let R be an integral domain and f ∈ R[X]. Let s be a finite index set.
Then, a fraction of the form f / ∏ (g i) can be rewritten as q + ∑ (r i) / (g i), where
deg(r i) < deg(g i), provided that the g i are monic and pairwise coprime.
-/
lemma div_eq_quo_add_sum_rem_div (f : R[X]) {ι : Type*} {g : ι → R[X]} {s : finset ι}
  (hg : ∀ i ∈ s, (g i).monic)
  (hcop : set.pairwise ↑s (λ i j, is_coprime (g i) (g j))) :
  ∃ (q : R[X]) (r : ι → R[X]), (∀ i ∈ s, (r i).degree < (g i).degree) ∧
  (↑f : K) / ∏ i in s, ↑(g i) = ↑q + ∑ i in s, ↑(r i) / ↑(g i) :=
begin
  induction s using finset.induction_on with a b hab Hind f generalizing f,
  { refine ⟨f, (λ (i : ι), (0 : R[X])), λ i, _, by simp⟩,
    rintro ⟨⟩, },
  obtain ⟨q₀, r₁, r₂, hdeg₁, hdeg₂, (hf : (↑f : K) / _ = _)⟩ :=
    div_eq_quo_add_rem_div_add_rem_div R K f
    (_ : monic (g a))
    (_ : monic ∏ (i : ι) in b, (g i))
    _,
  { obtain ⟨q, r, hrdeg, IH⟩ := Hind (λ i hi, hg i (finset.mem_insert_of_mem hi))
      (set.pairwise.mono ( finset.coe_subset.2 $ λ i hi, finset.mem_insert_of_mem hi) hcop) r₂,
    refine ⟨q₀ + q, λ i, if i = a then r₁ else r i, _, _⟩,
    { intro i,
      split_ifs with h1,
      { cases h1,
        intro _,
        exact hdeg₁, },
      { intro hi,
        exact hrdeg i (finset.mem_of_mem_insert_of_ne hi h1), }, },
    norm_cast at ⊢ hf IH,
    rw [finset.prod_insert hab, hf, IH, finset.sum_insert hab, if_pos rfl],
    transitivity (↑(q₀ + q : R[X]) : K) + (↑r₁ / ↑(g a) + ∑ (i : ι) in b, ↑(r i) / ↑(g i)),
    { push_cast, ring, },
    congr' 2,
    refine finset.sum_congr rfl (λ x hxb, _),
    rw if_neg,
    rintro rfl,
    exact hab hxb },
  { exact hg a (b.mem_insert_self a), },
  { exact monic_prod_of_monic _ _ (λ i hi, hg i (finset.mem_insert_of_mem hi)), },
  { refine is_coprime.prod_right (λ i hi, hcop (finset.mem_coe.2 (b.mem_insert_self a))
     (finset.mem_coe.2 (finset.mem_insert_of_mem hi)) _),
    rintro rfl,
    exact hab hi, },
end

end n_denominators


example : Prop := ∀ n, (n:Nat) + n = n.succ
example : Prop := ∀ n, n.succ = (n:Nat) + n
example : Prop := ∀ n, (n:Nat) + n.succ = n
example : Prop := ∀ n, n.succ + (n:Nat) = n
example : Prop := ∀ n, (n.succ:Nat) + n = n
example : Prop := ∀ n, (n:Nat).succ + n = n

def fib: Nat → Nat
| 0 => 0
| 1 => 1
| n + 2 => fib n + fib (n + 1)

theorem fib50Eq : fib 50 = 12586269025 :=
  rfl

inductive type : Type
  | A : type
  | B  : type

inductive val : type → Type
  | cA : val type.A
  | cB : val type.B

inductive wrap : Type
  | val : ∀ {t : type}, (val t) → wrap

def f : wrap → Nat
  | wrap.val val.cA => 1
  | _ => 1

example (a : Nat) : True := by
  have : ∀ n, n ≥ 0 → a ≤ a := fun _ _ => Nat.le_refl ..
  exact True.intro

example (ᾰ : Nat) : True := by
  have : ∀ n, n ≥ 0 → ᾰ ≤ ᾰ := fun _ _ => Nat.le_refl ..
  exact True.intro

inductive Vec.{u} (α : Type u) : Nat → Type u
  | nil  : Vec α 0
  | cons : α → {n : Nat} → Vec α n → Vec α (Nat.succ n) -- TODO: investigate why +1 doesn't work here

opaque Vars : Type

structure Lang :=
  (funcs : Nat → Type)
  (consts : Type)

inductive Term (L : Lang) : Type
  | const_term : L.consts → Term L
  | var_term   : Vars → Term L
  | func_term  (n : Nat) (f : L.funcs n) (v : Vec (Term L) n) : Term L


import order.upper_lower
import topology.inseparable

/-! ### Upper/lower sets and fibrations -/

open order_dual set

variables {α β γ : Type*} {ι : Sort*} {κ : ι → Sort*}

namespace relation

variables {f : α → β} {s : set α}

lemma fibration.is_lower_set_image [has_le α] [has_le β] (hf : fibration (≤) (≤) f)
  {s : set α} (hs : is_lower_set s) : is_lower_set (f '' s) :=
by { rintros _ y' e ⟨x, hx, rfl⟩, obtain ⟨y, e', rfl⟩ := hf e, exact ⟨_, hs e' hx, rfl⟩ }

alias fibration.is_lower_set_image ← _root_.is_lower_set.image_fibration

lemma fibration_iff_is_lower_set_image_Iic [preorder α] [has_le β] :
  fibration (≤) (≤) f ↔ ∀ x, is_lower_set (f '' Iic x) :=
⟨λ h x, (is_lower_set_Iic x).image_fibration h, λ H x y' e, H x e ⟨x, le_rfl, rfl⟩⟩

lemma fibration_iff_is_lower_set_image [preorder α] [has_le β] :
  fibration (≤) (≤) f ↔ ∀ s, is_lower_set s → is_lower_set (f '' s) :=
⟨fibration.is_lower_set_image,
  λ H, fibration_iff_is_lower_set_image_Iic.mpr (λ x, H _ $ is_lower_set_Iic x)⟩

lemma fibration_iff_image_Iic [preorder α] [preorder β] (hf : monotone f) :
  fibration (≤) (≤) f ↔ ∀ x, f '' Iic x = Iic (f x) :=
⟨λ H x, le_antisymm (λ _ ⟨y, hy, e⟩, e ▸ hf hy)
  ((H.is_lower_set_image (is_lower_set_Iic x)).Iic_subset ⟨x, le_rfl, rfl⟩),
  λ H, fibration_iff_is_lower_set_image_Iic.mpr (λ x, (H x).symm ▸ is_lower_set_Iic (f x))⟩

lemma fibration.is_upper_set_image [has_le α] [has_le β] (hf : fibration (≥) (≥) f)
  {s : set α} (hs : is_upper_set s) : is_upper_set (f '' s) :=
@fibration.is_lower_set_image αᵒᵈ βᵒᵈ _ _ _ hf s hs

alias fibration.is_upper_set_image ← _root_.is_upper_set.image_fibration

lemma fibration_iff_is_upper_set_image_Ici [preorder α] [has_le β] :
  fibration (≥) (≥) f ↔ ∀ x, is_upper_set (f '' Ici x) :=
@fibration_iff_is_lower_set_image_Iic αᵒᵈ βᵒᵈ _ _ _

lemma fibration_iff_is_upper_set_image [preorder α] [has_le β] :
  fibration (≥) (≥) f ↔ ∀ s, is_upper_set s → is_upper_set (f '' s) :=
@fibration_iff_is_lower_set_image αᵒᵈ βᵒᵈ _ _ _

lemma fibration_iff_image_Ici [preorder α] [preorder β] (hf : monotone f) :
  fibration (≥) (≥) f ↔ ∀ x, f '' Ici x = Ici (f x) :=
fibration_iff_image_Iic hf.dual

end relation

section

variable [preorder α]
variables {f : α → β} {s : set α}

@[norm_cast] lemma coe_upper_closure' (s : set α) : ↑(upper_closure s) = ⋃ a ∈ s, set.Ici a :=
by { ext, simp }

@[norm_cast] lemma coe_lower_closure' (s : set α) : ↑(lower_closure s) = ⋃ a ∈ s, set.Iic a :=
by { ext, simp }

@[simp] lemma upper_closure_eq :
  ↑(upper_closure s) = s ↔ is_upper_set s :=
⟨λ h, h ▸ upper_set.upper _, is_upper_set.upper_closure⟩

@[simp] lemma lower_closure_eq :
  ↑(lower_closure s) = s ↔ is_lower_set s :=
@upper_closure_eq αᵒᵈ _ _

end

local attribute [instance] specialization_preorder

open set filter function
open_locale topological_space filter
variables {X Y Z : Type*} {π : ι → Type*} [topological_space X] [topological_space Y]
  [topological_space Z] [∀ i, topological_space (π i)] {x y z : X} {s : set X} {f : X → Y}

lemma closure_singleton_eq_Iic (x : X) : closure {x} = Iic x :=
ext $ λ _, specializes_iff_mem_closure.symm

/-- A subset `S` of a topological space is stable under specialization
if `x ∈ S → y ∈ S` for all `x ⤳ y`. -/
def stable_under_specialization (s : set X) : Prop :=
∀ ⦃x y⦄, x ⤳ y → x ∈ s → y ∈ s

/-- A subset `S` of a topological space is stable under specialization
if `x ∈ S → y ∈ S` for all `y ⤳ x`. -/
def stable_under_generalization (s : set X) : Prop :=
∀ ⦃x y⦄, y ⤳ x → x ∈ s → y ∈ s

example {s : set X} : stable_under_specialization s ↔ is_lower_set s := iff.rfl
example {s : set X} : stable_under_generalization s ↔ is_upper_set s := iff.rfl

lemma is_closed.stable_under_specialization {s : set X} (hs : is_closed s) :
  stable_under_specialization s :=
λ x y e, e.mem_closed hs

lemma is_open.stable_under_generalization {s : set X} (hs : is_open s) :
  stable_under_generalization s :=
λ x y e, e.mem_open hs

@[simp]
lemma stable_under_specialization_compl_iff {s : set X} :
  stable_under_specialization sᶜ ↔ stable_under_generalization s :=
is_lower_set_compl

@[simp]
lemma stable_under_generalization_compl_iff {s : set X} :
  stable_under_generalization sᶜ ↔ stable_under_specialization s :=
is_upper_set_compl

alias stable_under_specialization_compl_iff ↔ _ stable_under_generalization.compl
alias stable_under_generalization_compl_iff ↔ _ stable_under_specialization.compl

lemma stable_under_specialization_sUnion (S : set (set X))
  (H : ∀ s ∈ S, stable_under_specialization s) : stable_under_specialization (⋃₀ S) :=
is_lower_set_sUnion H

lemma stable_under_specialization_sInter (S : set (set X))
  (H : ∀ s ∈ S, stable_under_specialization s) : stable_under_specialization (⋂₀ S) :=
is_lower_set_sInter H

lemma stable_under_generalization_sUnion (S : set (set X))
  (H : ∀ s ∈ S, stable_under_generalization s) : stable_under_generalization (⋃₀ S) :=
is_upper_set_sUnion H

lemma stable_under_generalization_sInter (S : set (set X))
  (H : ∀ s ∈ S, stable_under_generalization s) : stable_under_generalization (⋂₀ S) :=
is_upper_set_sInter H

lemma stable_under_specialization_Union {ι : Sort*} (S : ι → set X)
  (H : ∀ i, stable_under_specialization (S i)) : stable_under_specialization (⋃ i, S i) :=
is_lower_set_Union H

lemma stable_under_specialization_Inter {ι : Sort*} (S : ι → set X)
  (H : ∀ i, stable_under_specialization (S i)) : stable_under_specialization (⋂ i, S i) :=
is_lower_set_Inter H

lemma stable_under_generalization_Union {ι : Sort*} (S : ι → set X)
  (H : ∀ i, stable_under_generalization (S i)) : stable_under_generalization (⋃ i, S i) :=
is_upper_set_Union H

lemma stable_under_generalization_Inter {ι : Sort*} (S : ι → set X)
  (H : ∀ i, stable_under_generalization (S i)) : stable_under_generalization (⋂ i, S i) :=
is_upper_set_Inter H

lemma Union_closure_singleton_eq_iff {s : set X} :
  (⋃ x ∈ s, closure {x}) = s ↔ stable_under_specialization s :=
show _ ↔ is_lower_set s,
  by simp only [closure_singleton_eq_Iic, ← lower_closure_eq, coe_lower_closure']

lemma stable_under_specialization_iff_eq_Union {s : set X} :
  stable_under_specialization s ↔ (⋃ x ∈ s, closure {x}) = s :=
Union_closure_singleton_eq_iff.symm

alias stable_under_specialization_iff_eq_Union ↔ stable_under_specialization.Union_eq _

/-- A set is stable under specialization iff it is a union of closed sets. -/
lemma stable_under_specialization_iff_exists_sUnion_eq {s : set X} :
  stable_under_specialization s ↔ ∃ (S : set (set X)), (∀ s ∈ S, is_closed s) ∧ ⋃₀ S = s :=
begin
  refine ⟨λ H, ⟨(λ x : X, closure {x}) '' s, _, _⟩, λ ⟨S, hS, e⟩, e ▸
    stable_under_specialization_sUnion S (λ x hx, (hS x hx).stable_under_specialization)⟩,
  { rintros _ ⟨_, _, rfl⟩, exact is_closed_closure },
  { conv_rhs { rw ← H.Union_eq }, simp }
end

/-- A set is stable under generalization iff it is an intersection of open sets. -/
lemma stable_under_generalization_iff_exists_sInter_eq {s : set X} :
  stable_under_generalization s ↔ ∃ (S : set (set X)), (∀ s ∈ S, is_open s) ∧ ⋂₀ S = s :=
begin
  refine ⟨_, λ ⟨S, hS, e⟩, e ▸
    stable_under_generalization_sInter S (λ x hx, (hS x hx).stable_under_generalization)⟩,
  rw [← stable_under_specialization_compl_iff, stable_under_specialization_iff_exists_sUnion_eq],
  exact λ ⟨S, h₁, h₂⟩, ⟨has_compl.compl '' S, λ s ⟨t, ht, e⟩, e ▸ (h₁ t ht).is_open_compl,
    compl_injective ((sUnion_eq_compl_sInter_compl S).symm.trans h₂)⟩
end

lemma stable_under_specialization.preimage {s : set Y}
  (hs : stable_under_specialization s) (hf : continuous f) :
  stable_under_specialization (f ⁻¹' s) :=
is_lower_set.preimage hs hf.specialization_monotone

lemma stable_under_generalization.preimage {s : set Y}
  (hs : stable_under_generalization s) (hf : continuous f) :
  stable_under_generalization (f ⁻¹' s) :=
is_upper_set.preimage hs hf.specialization_monotone

/-- A map `f` between topological spaces is specializing if specializations lifts along `f`,
i.e. for each `f x' ⤳ y` there is some `x` with `x' ⤳ x` whose image is `y`. -/
def specializing_map (f : X → Y) : Prop :=
relation.fibration (flip (⤳)) (flip (⤳)) f

/-- A map `f` between topological spaces is generalizing if generalizations lifts along `f`,
i.e. for each `y ⤳ f x'` there is some `x ⤳ x'` whose image is `y`. -/
def generalizing_map (f : X → Y) : Prop :=
relation.fibration (⤳) (⤳) f

lemma specializing_map_iff_closure_singleton_subset :
  specializing_map f ↔ ∀ x, closure {f x} ⊆ f '' closure {x} :=
by simpa only [specializing_map, relation.fibration, flip, specializes_iff_mem_closure]

alias specializing_map_iff_closure_singleton_subset ↔ specializing_map.closure_singleton_subset _

lemma specializing_map.stable_under_specialization_image (hf : specializing_map f)
  {s : set X} (hs : stable_under_specialization s) : stable_under_specialization (f '' s) :=
is_lower_set.image_fibration hf hs

alias specializing_map.stable_under_specialization_image ← stable_under_specialization.image

lemma specializing_map_iff_image_singleton_stable_under_specialization :
  specializing_map f ↔ ∀ x, stable_under_specialization (f '' closure {x}) :=
by simpa only [closure_singleton_eq_Iic] using relation.fibration_iff_is_lower_set_image_Iic

lemma specializing_map_iff_stable_under_specialization_image :
  specializing_map f ↔ ∀ s, stable_under_specialization s → stable_under_specialization (f '' s) :=
relation.fibration_iff_is_lower_set_image

lemma specializing_map_iff_closure_singleton (hf : continuous f) :
  specializing_map f ↔ ∀ x, f '' closure {x} = closure {f x} :=
by simpa only [closure_singleton_eq_Iic] using
  relation.fibration_iff_image_Iic hf.specialization_monotone

lemma specializing_map_iff_is_closed_image_closure_singleton (hf : continuous f) :
  specializing_map f ↔ ∀ x, is_closed (f '' closure {x}) :=
begin
  refine ⟨λ h x, _, λ h, specializing_map_iff_image_singleton_stable_under_specialization.mpr
    (λ x, (h x).stable_under_specialization)⟩,
  rw (specializing_map_iff_closure_singleton hf).mp h x,
  exact is_closed_closure
end

lemma is_closed_map.specializing_map (hf : is_closed_map f) : specializing_map f :=
specializing_map_iff_image_singleton_stable_under_specialization.mpr $
  λ x, (hf _ is_closed_closure).stable_under_specialization

lemma inducing.specializing_map (hf : inducing f) (h : stable_under_specialization (range f)) :
  specializing_map f :=
by { intros x y e, obtain ⟨y, rfl⟩ := h e ⟨x, rfl⟩, exact ⟨_, hf.specializes_iff.mp e, rfl⟩ }

lemma inducing.generalizing_map (hf : inducing f) (h : stable_under_generalization (range f)) :
  generalizing_map f :=
by { intros x y e, obtain ⟨y, rfl⟩ := h e ⟨x, rfl⟩, exact ⟨_, hf.specializes_iff.mp e, rfl⟩ }

lemma open_embedding.generalizing_map (hf : open_embedding f) : generalizing_map f :=
hf.to_inducing.generalizing_map hf.open_range.stable_under_generalization

lemma specializing_map.stable_under_specialization_range (h : specializing_map f) :
  stable_under_specialization (range f) :=
@image_univ _ _ f ▸ is_closed_univ.stable_under_specialization.image h

lemma generalizing_map.stable_under_generalization_image (hf : generalizing_map f) {s : set X}
  (hs : stable_under_generalization s) : stable_under_generalization (f '' s) :=
is_upper_set.image_fibration hf hs

lemma generalizing_map_iff_stable_under_generalization_image :
  generalizing_map f ↔ ∀ s, stable_under_generalization s → stable_under_generalization (f '' s) :=
relation.fibration_iff_is_upper_set_image

alias generalizing_map.stable_under_generalization_image ← stable_under_generalization.image

lemma generalizing_map.stable_under_generalization_range (h : generalizing_map f) :
  stable_under_generalization (range f) :=
@image_univ _ _ f ▸ is_open_univ.stable_under_generalization.image h


import data.list

namespace list

universes u v w

variables {α : Type u} {β : Type v} {γ : Type w}
variables x : α
variables xs ys : list α

def opt_head : list α → option α
 | [] := none
 | (x :: _) := some x

def front : list α → list α
  | [] := []
  | [x] := []
  | (x :: xs) := x :: front xs

lemma not_concat_eq_nil
: concat xs x ≠ [] :=
by { cases xs ; contradiction }

lemma front_concat
: front (concat xs x) = xs :=
begin
  induction xs with y ys IH,
  { refl },
  { unfold concat front,
    destruct (concat ys x),
    { intro h, cases not_concat_eq_nil _ _ h },
    { intros z zs Hconcat,
      rw Hconcat, unfold front,
      rw [← Hconcat,IH], }, }
end

variables {P : list α → Prop}

lemma ind_concat
  (Hnil : P nil)
  (Hcons : ∀ x xs, P xs → P (concat xs x))
: ∀ xs, P xs :=
begin
  let Q := P ∘ reverse,
  intro,
  rw ← reverse_reverse xs,
  generalize : (reverse xs) = ys, clear xs,
  change Q ys,
  induction ys with y ys IH,
  { apply Hnil },
  { change P _,
    have h := Hcons y (reverse ys) IH,
    rw [reverse_cons y ys,← concat_eq_append],
    apply h },
end

lemma rec_concat
  (Hnil : P nil)
  (Hcons : ∀ x xs, P (concat xs x))
: ∀ xs, P xs :=
begin
  apply ind_concat Hnil _,
  intros x xs IH,
  apply Hcons,
end

lemma ilast_concat {a : α} [inhabited α]
: ∀ (l : list α), ilast (concat l a) = a
  | [] := rfl
  | [x] := rfl
  | [x,y] := rfl
  | (x::y::z::l) := ilast_concat (z :: l)

lemma front_last_eq
  [inhabited α]
  (h₀ : xs ≠ []) (h₁ : ys ≠ [])
  (Hxs : front xs = front ys)
  (Hx : ilast xs = ilast ys)
: xs = ys :=
begin
  revert xs ys, intro,
  eapply   rec_concat _ _ xs,
  { intro, apply   rec_concat _ _ ys,
    contradiction,
    intros y ys h₀ h₁,
    contradiction, },
  { intros x xs ys,
    apply rec_concat _ _ ys,
    intro, contradiction,
    intros y ys h₀ h₁,
    rw [front_concat,front_concat,ilast_concat,ilast_concat],
    intros h₂ h₃,
    rw [h₂,h₃], }
end

section

variable {f : α → α → α}
variable [is_associative α f]
variable [is_commutative α f]
variable x₀ : α

lemma foldl_eq_foldr_of_ac
: foldl f x₀ xs = foldr f x₀ xs :=
begin
  induction xs,
  case nil
  { refl },
  case cons : x xs IH
  { unfold foldl foldr,
    rw ← IH, symmetry,
    rw [foldl_hom (f x) f f _ _ xs,is_commutative.comm f],
    { intros y z, rw is_associative.assoc f } },
end

end

lemma append_cons {α : Type u} (xs : list α) (x : α) (ys : list α)
: xs ++ x :: ys = (xs ++ [x]) ++ ys :=
by simp

instance {α : Type*} : monoid (list α) :=
{ mul := has_append.append
, one := []
, one_mul := nil_append
, mul_one := append_nil
, mul_assoc := append_assoc }

def mapp (f : α → β → γ) : list (α × β) → list γ
 | [ ] := [ ]
 | ((x,y) :: xs) := f x y :: mapp xs

end list


import set_theory.surreal
open pgame

theorem numeric_nat (n : ℕ) : numeric n :=
begin
  induction n with n hn,
  apply numeric_zero,
  apply numeric_add hn numeric_one,
end

theorem numeric_omega : numeric omega :=
⟨by rintros ⟨ ⟩ ⟨ ⟩, λ i, by simp [numeric_nat i.down] , by rintros ⟨ ⟩⟩

#check numeric_nat
#check numeric_omega


import tactic
import tactic.induction

def eq₁ {α : Sort*} (s : list α) : Prop := ∀ (x y ∈ s), x = y

def eq₂ {α : Sort*} : list α → Prop
| [] := true
| [x] := true
| [x, y] := x = y
| (x :: y :: z :: rest) :=
  list.foldr (∧) (eq₂ (y :: z :: rest)) (list.map ((=) x) (y :: z :: rest))

lemma eq_of_eq_cons {α : Sort*} {s : list α} {x : α}
  (h : eq₁ (x :: s)) : eq₁ s :=
λ a ha b hb, h a (by simp [ha]) b (by simp [hb])

lemma foldr_true {s : list Prop} :
  list.foldr and true s ↔ ∀ (P ∈ s), P :=
begin
  induction' s, { simp }, rw list.foldr, split; intro h,
  { rintro P h₁, cases h₁, { rw h₁, exact h.1 }, { apply ih.mp h.2 P h₁ } },
  { split, { apply h, simp }, { apply ih.mpr, rintro P h₁, apply h, simp [h₁] }},
end

lemma list_mem_cons_dup {α : Sort*} {s : list α} {x hd : α} :
  x ∈ (hd :: hd :: s) ↔ x ∈ (hd :: s) :=
by simp [list.mem_cons_iff]

lemma eq_cons_dup {α : Sort*} {s : list α} {hd : α} :
  eq₁ (hd :: hd :: s) ↔ eq₁ (hd :: s) :=
by simp [eq₁, list_mem_cons_dup]

lemma foldr_true_z {s : list Prop} {P : Prop}
  (h : list.foldr and P s) : P :=
by { induction' s, { exact h }, { exact ih h.2 }}

lemma eq_aux {α : Sort*} {s : list α} {x : α} :
  eq₁ (x :: s) ↔ list.foldr and (eq₁ s) (list.map (eq x) s) :=
begin
  induction' s, { simp [eq₁] },
  rw [list.map_cons, list.foldr_cons], split; intro h,
  { use h x (by simp) hd (by simp), have h₁ := eq_of_eq_cons h,
    have h₂ := eq_of_eq_cons h₁, have h₃ := ih.mp h₁,
    rw iff_of_true h₂ trivial at h₃, rw iff_of_true h₁ trivial,
    rw foldr_true at h₃ ⊢, rintro P hP, apply h₃,
    rw list.mem_map at hP ⊢, rcases hP with ⟨y, hy, rfl⟩,
    use [y, hy], ext, split; rintro rfl,
    { exact h x (by simp) hd (by simp) },
    { exact h hd (by simp) x (by simp) }},
  { rcases h with ⟨rfl, h⟩, rw eq_cons_dup, apply ih.mpr,
    have h₁ := foldr_true_z h, have h₂ := eq_of_eq_cons h₁,
    rw iff_of_true h₁ trivial at h, rwa iff_of_true h₂ trivial },
end

theorem eq₁_eq₂ {α : Sort*} {s : list α} : eq₁ s ↔ eq₂ s :=
begin
  induction' s, { simp [eq₁, eq₂] },
  cases' s with x s, { simp [eq₁, eq₂], },
  cases' s with y s, { simp [eq₁, eq₂], exact λ h, h.symm },
  rw [eq₂, ←ih, eq_aux],
end


/-
Copyright (c) 2019 Amelia Livingston. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Amelia Livingston
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.setoid.basic
import Mathlib.algebra.group.pi
import Mathlib.algebra.group.prod
import Mathlib.data.equiv.mul_add
import Mathlib.group_theory.submonoid.operations
import Mathlib.PostPort

universes u_1 l u_3 u_2

namespace Mathlib

/-!
# Congruence relations

This file defines congruence relations: equivalence relations that preserve a binary operation,
which in this case is multiplication or addition. The principal definition is a `structure`
extending a `setoid` (an equivalence relation), and the inductive definition of the smallest
congruence relation containing a binary relation is also given (see `con_gen`).

The file also proves basic properties of the quotient of a type by a congruence relation, and the
complete lattice of congruence relations on a type. We then establish an order-preserving bijection
between the set of congruence relations containing a congruence relation `c` and the set of
congruence relations on the quotient by `c`.

The second half of the file concerns congruence relations on monoids, in which case the
quotient by the congruence relation is also a monoid. There are results about the universal
property of quotients of monoids, and the isomorphism theorems for monoids.

## Implementation notes

The inductive definition of a congruence relation could be a nested inductive type, defined using
the equivalence closure of a binary relation `eqv_gen`, but the recursor generated does not work.
A nested inductive definition could conceivably shorten proofs, because they would allow invocation
of the corresponding lemmas about `eqv_gen`.

The lemmas `refl`, `symm` and `trans` are not tagged with `@[refl]`, `@[symm]`, and `@[trans]`
respectively as these tags do not work on a structure coerced to a binary relation.

There is a coercion from elements of a type to the element's equivalence class under a
congruence relation.

A congruence relation on a monoid `M` can be thought of as a submonoid of `M × M` for which
membership is an equivalence relation, but whilst this fact is established in the file, it is not
used, since this perspective adds more layers of definitional unfolding.

## Tags

congruence, congruence relation, quotient, quotient by congruence relation, monoid,
quotient monoid, isomorphism theorems
-/

/-- A congruence relation on a type with an addition is an equivalence relation which
    preserves addition. -/
structure add_con (M : Type u_1) [Add M] extends setoid M where
  add' : ∀ {w x y z : M}, r w x → r y z → r (w + y) (x + z)

/-- A congruence relation on a type with a multiplication is an equivalence relation which
    preserves multiplication. -/
structure con (M : Type u_1) [Mul M] extends setoid M where
  mul' : ∀ {w x y z : M}, r w x → r y z → r (w * y) (x * z)

/-- The equivalence relation underlying an additive congruence relation. -/
/-- The equivalence relation underlying a multiplicative congruence relation. -/
/-- The inductively defined smallest additive congruence relation containing a given binary
    relation. -/
inductive add_con_gen.rel {M : Type u_1} [Add M] (r : M → M → Prop) : M → M → Prop where
| of : ∀ (x y : M), r x y → add_con_gen.rel r x y
| refl : ∀ (x : M), add_con_gen.rel r x x
| symm : ∀ (x y : M), add_con_gen.rel r x y → add_con_gen.rel r y x
| trans : ∀ (x y z : M), add_con_gen.rel r x y → add_con_gen.rel r y z → add_con_gen.rel r x z
| add :
    ∀ (w x y z : M),
      add_con_gen.rel r w x → add_con_gen.rel r y z → add_con_gen.rel r (w + y) (x + z)

/-- The inductively defined smallest multiplicative congruence relation containing a given binary
    relation. -/
inductive con_gen.rel {M : Type u_1} [Mul M] (r : M → M → Prop) : M → M → Prop where
| of : ∀ (x y : M), r x y → con_gen.rel r x y
| refl : ∀ (x : M), con_gen.rel r x x
| symm : ∀ (x y : M), con_gen.rel r x y → con_gen.rel r y x
| trans : ∀ (x y z : M), con_gen.rel r x y → con_gen.rel r y z → con_gen.rel r x z
| mul : ∀ (w x y z : M), con_gen.rel r w x → con_gen.rel r y z → con_gen.rel r (w * y) (x * z)

/-- The inductively defined smallest multiplicative congruence relation containing a given binary
    relation. -/
def con_gen {M : Type u_1} [Mul M] (r : M → M → Prop) : con M := con.mk sorry sorry sorry

namespace con

protected instance Mathlib.add_con.inhabited {M : Type u_1} [Add M] : Inhabited (add_con M) :=
  { default := add_con_gen empty_relation }

/-- A coercion from a congruence relation to its underlying binary relation. -/
protected instance Mathlib.add_con.has_coe_to_fun {M : Type u_1} [Add M] :
    has_coe_to_fun (add_con M) :=
  has_coe_to_fun.mk (fun (c : add_con M) => M → M → Prop)
    fun (c : add_con M) (x y : M) => add_con.r c x y

@[simp] theorem Mathlib.add_con.rel_eq_coe {M : Type u_1} [Add M] (c : add_con M) :
    add_con.r c = ⇑c :=
  rfl

/-- Congruence relations are reflexive. -/
protected theorem Mathlib.add_con.refl {M : Type u_1} [Add M] (c : add_con M) (x : M) :
    coe_fn c x x :=
  and.left (add_con.iseqv c) x

/-- Congruence relations are symmetric. -/
protected theorem Mathlib.add_con.symm {M : Type u_1} [Add M] (c : add_con M) {x : M} {y : M} :
    coe_fn c x y → coe_fn c y x :=
  fun (h : coe_fn c _x✝ _x) => and.left (and.right (add_con.iseqv c)) _x✝ _x h

/-- Congruence relations are transitive. -/
protected theorem Mathlib.add_con.trans {M : Type u_1} [Add M] (c : add_con M) {x : M} {y : M}
    {z : M} : coe_fn c x y → coe_fn c y z → coe_fn c x z :=
  fun (h : coe_fn c _x✝¹ _x✝) => and.right (and.right (add_con.iseqv c)) _x✝¹ _x✝ _x h

/-- Multiplicative congruence relations preserve multiplication. -/
protected theorem Mathlib.add_con.add {M : Type u_1} [Add M] (c : add_con M) {w : M} {x : M} {y : M}
    {z : M} : coe_fn c w x → coe_fn c y z → coe_fn c (w + y) (x + z) :=
  fun (h1 : coe_fn c _x✝² _x✝¹) (h2 : coe_fn c _x✝ _x) => add_con.add' c h1 h2

/-- Given a type `M` with a multiplication, a congruence relation `c` on `M`, and elements of `M`
    `x, y`, `(x, y) ∈ M × M` iff `x` is related to `y` by `c`. -/
protected instance Mathlib.add_con.has_mem {M : Type u_1} [Add M] : has_mem (M × M) (add_con M) :=
  has_mem.mk fun (x : M × M) (c : add_con M) => coe_fn c (prod.fst x) (prod.snd x)

/-- The map sending a congruence relation to its underlying binary relation is injective. -/
theorem Mathlib.add_con.ext' {M : Type u_1} [Add M] {c : add_con M} {d : add_con M}
    (H : add_con.r c = add_con.r d) : c = d :=
  sorry

/-- Extensionality rule for congruence relations. -/
theorem Mathlib.add_con.ext {M : Type u_1} [Add M] {c : add_con M} {d : add_con M}
    (H : ∀ (x y : M), coe_fn c x y ↔ coe_fn d x y) : c = d :=
  add_con.ext' (funext fun (x : M) => funext fun (x_1 : M) => propext (H x x_1))

/-- The map sending a congruence relation to its underlying equivalence relation is injective. -/
theorem to_setoid_inj {M : Type u_1} [Mul M] {c : con M} {d : con M}
    (H : to_setoid c = to_setoid d) : c = d :=
  ext (iff.mp setoid.ext_iff H)

/-- Iff version of extensionality rule for congruence relations. -/
theorem Mathlib.add_con.ext_iff {M : Type u_1} [Add M] {c : add_con M} {d : add_con M} :
    (∀ (x y : M), coe_fn c x y ↔ coe_fn d x y) ↔ c = d :=
  { mp := add_con.ext, mpr := fun (h : c = d) (_x _x_1 : M) => h ▸ iff.rfl }

/-- Two congruence relations are equal iff their underlying binary relations are equal. -/
theorem ext'_iff {M : Type u_1} [Mul M] {c : con M} {d : con M} : r c = r d ↔ c = d :=
  { mp := ext', mpr := fun (h : c = d) => h ▸ rfl }

/-- The kernel of a multiplication-preserving function as a congruence relation. -/
def mul_ker {M : Type u_1} {P : Type u_3} [Mul M] [Mul P] (f : M → P)
    (h : ∀ (x y : M), f (x * y) = f x * f y) : con M :=
  mk (fun (x y : M) => f x = f y) sorry sorry

/-- Given types with multiplications `M, N`, the product of two congruence relations `c` on `M` and
    `d` on `N`: `(x₁, x₂), (y₁, y₂) ∈ M × N` are related by `c.prod d` iff `x₁` is related to `y₁`
    by `c` and `x₂` is related to `y₂` by `d`. -/
protected def Mathlib.add_con.prod {M : Type u_1} {N : Type u_2} [Add M] [Add N] (c : add_con M)
    (d : add_con N) : add_con (M × N) :=
  add_con.mk setoid.r sorry sorry

/-- The product of an indexed collection of congruence relations. -/
def Mathlib.add_con.pi {ι : Type u_1} {f : ι → Type u_2} [(i : ι) → Add (f i)]
    (C : (i : ι) → add_con (f i)) : add_con ((i : ι) → f i) :=
  add_con.mk setoid.r sorry sorry

@[simp] theorem Mathlib.add_con.coe_eq {M : Type u_1} [Add M] (c : add_con M) : setoid.r = ⇑c := rfl

-- Quotients

/-- Defining the quotient by a congruence relation of a type with a multiplication. -/
protected def Mathlib.add_con.quotient {M : Type u_1} [Add M] (c : add_con M) :=
  quotient (add_con.to_setoid c)

/-- Coercion from a type with a multiplication to its quotient by a congruence relation.

See Note [use has_coe_t]. -/
protected instance quotient.has_coe_t {M : Type u_1} [Mul M] (c : con M) :
    has_coe_t M (con.quotient c) :=
  has_coe_t.mk quotient.mk

/-- The quotient of a type with decidable equality by a congruence relation also has
    decidable equality. -/
protected instance quotient.decidable_eq {M : Type u_1} [Mul M] (c : con M)
    [d : (a b : M) → Decidable (coe_fn c a b)] : DecidableEq (con.quotient c) :=
  quotient.decidable_eq

/-- The function on the quotient by a congruence relation `c` induced by a function that is
    constant on `c`'s equivalence classes. -/
protected def Mathlib.add_con.lift_on {M : Type u_1} [Add M] {β : Sort u_2} {c : add_con M}
    (q : add_con.quotient c) (f : M → β) (h : ∀ (a b : M), coe_fn c a b → f a = f b) : β :=
  quotient.lift_on' q f h

/-- The binary function on the quotient by a congruence relation `c` induced by a binary function
    that is constant on `c`'s equivalence classes. -/
protected def Mathlib.add_con.lift_on₂ {M : Type u_1} [Add M] {β : Sort u_2} {c : add_con M}
    (q : add_con.quotient c) (r : add_con.quotient c) (f : M → M → β)
    (h : ∀ (a₁ a₂ b₁ b₂ : M), coe_fn c a₁ b₁ → coe_fn c a₂ b₂ → f a₁ a₂ = f b₁ b₂) : β :=
  quotient.lift_on₂' q r f h

/-- The inductive principle used to prove propositions about the elements of a quotient by a
    congruence relation. -/
protected theorem Mathlib.add_con.induction_on {M : Type u_1} [Add M] {c : add_con M}
    {C : add_con.quotient c → Prop} (q : add_con.quotient c) (H : ∀ (x : M), C ↑x) : C q :=
  quotient.induction_on' q H

/-- A version of `con.induction_on` for predicates which take two arguments. -/
protected theorem Mathlib.add_con.induction_on₂ {M : Type u_1} {N : Type u_2} [Add M] [Add N]
    {c : add_con M} {d : add_con N} {C : add_con.quotient c → add_con.quotient d → Prop}
    (p : add_con.quotient c) (q : add_con.quotient d) (H : ∀ (x : M) (y : N), C ↑x ↑y) : C p q :=
  quotient.induction_on₂' p q H

/-- Two elements are related by a congruence relation `c` iff they are represented by the same
    element of the quotient by `c`. -/
@[simp] protected theorem Mathlib.add_con.eq {M : Type u_1} [Add M] (c : add_con M) {a : M}
    {b : M} : ↑a = ↑b ↔ coe_fn c a b :=
  quotient.eq'

/-- The multiplication induced on the quotient by a congruence relation on a type with a
    multiplication. -/
protected instance has_mul {M : Type u_1} [Mul M] (c : con M) : Mul (con.quotient c) :=
  { mul := fun (x y : con.quotient c) => quotient.lift_on₂' x y (fun (w z : M) => ↑(w * z)) sorry }

/-- The kernel of the quotient map induced by a congruence relation `c` equals `c`. -/
@[simp] theorem mul_ker_mk_eq {M : Type u_1} [Mul M] (c : con M) :
    (mul_ker coe fun (x y : M) => rfl) = c :=
  ext fun (x y : M) => quotient.eq'

/-- The coercion to the quotient of a congruence relation commutes with multiplication (by
    definition). -/
@[simp] theorem Mathlib.add_con.coe_add {M : Type u_1} [Add M] {c : add_con M} (x : M) (y : M) :
    ↑(x + y) = ↑x + ↑y :=
  rfl

/-- Definition of the function on the quotient by a congruence relation `c` induced by a function
    that is constant on `c`'s equivalence classes. -/
@[simp] protected theorem lift_on_beta {M : Type u_1} [Mul M] {β : Sort u_2} (c : con M) (f : M → β)
    (h : ∀ (a b : M), coe_fn c a b → f a = f b) (x : M) : con.lift_on (↑x) f h = f x :=
  rfl

/-- Makes an isomorphism of quotients by two congruence relations, given that the relations are
    equal. -/
protected def Mathlib.add_con.congr {M : Type u_1} [Add M] {c : add_con M} {d : add_con M}
    (h : c = d) : add_con.quotient c ≃+ add_con.quotient d :=
  add_equiv.mk (equiv.to_fun (quotient.congr (equiv.refl M) sorry))
    (equiv.inv_fun (quotient.congr (equiv.refl M) sorry)) sorry sorry sorry

-- The complete lattice of congruence relations on a type

/-- For congruence relations `c, d` on a type `M` with a multiplication, `c ≤ d` iff `∀ x y ∈ M`,
    `x` is related to `y` by `d` if `x` is related to `y` by `c`. -/
protected instance Mathlib.add_con.has_le {M : Type u_1} [Add M] : HasLessEq (add_con M) :=
  { LessEq := fun (c d : add_con M) => ∀ {x y : M}, coe_fn c x y → coe_fn d x y }

/-- Definition of `≤` for congruence relations. -/
theorem Mathlib.add_con.le_def {M : Type u_1} [Add M] {c : add_con M} {d : add_con M} :
    c ≤ d ↔ ∀ {x y : M}, coe_fn c x y → coe_fn d x y :=
  iff.rfl

/-- The infimum of a set of congruence relations on a given type with a multiplication. -/
protected instance Mathlib.add_con.has_Inf {M : Type u_1} [Add M] : has_Inf (add_con M) :=
  has_Inf.mk
    fun (S : set (add_con M)) =>
      add_con.mk (fun (x y : M) => ∀ (c : add_con M), c ∈ S → coe_fn c x y) sorry sorry

/-- The infimum of a set of congruence relations is the same as the infimum of the set's image
    under the map to the underlying equivalence relation. -/
theorem Mathlib.add_con.Inf_to_setoid {M : Type u_1} [Add M] (S : set (add_con M)) :
    add_con.to_setoid (Inf S) = Inf (add_con.to_setoid '' S) :=
  sorry

/-- The infimum of a set of congruence relations is the same as the infimum of the set's image
    under the map to the underlying binary relation. -/
theorem Inf_def {M : Type u_1} [Mul M] (S : set (con M)) : r (Inf S) = Inf (r '' S) := sorry

protected instance Mathlib.add_con.partial_order {M : Type u_1} [Add M] :
    partial_order (add_con M) :=
  partial_order.mk LessEq (fun (c d : add_con M) => c ≤ d ∧ ¬d ≤ c) sorry sorry sorry

/-- The complete lattice of congruence relations on a given type with a multiplication. -/
protected instance complete_lattice {M : Type u_1} [Mul M] : complete_lattice (con M) :=
  complete_lattice.mk complete_lattice.sup complete_lattice.le complete_lattice.lt sorry sorry sorry
    sorry sorry sorry (fun (c d : con M) => mk setoid.r sorry sorry) sorry sorry sorry
    (mk setoid.r sorry sorry) sorry (mk setoid.r sorry sorry) sorry complete_lattice.Sup
    complete_lattice.Inf sorry sorry sorry sorry

/-- The infimum of two congruence relations equals the infimum of the underlying binary
    operations. -/
theorem Mathlib.add_con.inf_def {M : Type u_1} [Add M] {c : add_con M} {d : add_con M} :
    add_con.r (c ⊓ d) = add_con.r c ⊓ add_con.r d :=
  rfl

/-- Definition of the infimum of two congruence relations. -/
theorem Mathlib.add_con.inf_iff_and {M : Type u_1} [Add M] {c : add_con M} {d : add_con M} {x : M}
    {y : M} : coe_fn (c ⊓ d) x y ↔ coe_fn c x y ∧ coe_fn d x y :=
  iff.rfl

/-- The inductively defined smallest congruence relation containing a binary relation `r` equals
    the infimum of the set of congruence relations containing `r`. -/
theorem Mathlib.add_con.add_con_gen_eq {M : Type u_1} [Add M] (r : M → M → Prop) :
    add_con_gen r = Inf (set_of fun (s : add_con M) => ∀ (x y : M), r x y → coe_fn s x y) :=
  sorry

/-- The smallest congruence relation containing a binary relation `r` is contained in any
    congruence relation containing `r`. -/
theorem con_gen_le {M : Type u_1} [Mul M] {r : M → M → Prop} {c : con M}
    (h : ∀ (x y : M), r x y → r c x y) : con_gen r ≤ c :=
  eq.mpr (id (Eq._oldrec (Eq.refl (con_gen r ≤ c)) (con_gen_eq r))) (Inf_le h)

/-- Given binary relations `r, s` with `r` contained in `s`, the smallest congruence relation
    containing `s` contains the smallest congruence relation containing `r`. -/
theorem Mathlib.add_con.add_con_gen_mono {M : Type u_1} [Add M] {r : M → M → Prop}
    {s : M → M → Prop} (h : ∀ (x y : M), r x y → s x y) : add_con_gen r ≤ add_con_gen s :=
  add_con.add_con_gen_le fun (x y : M) (hr : r x y) => add_con_gen.rel.of x y (h x y hr)

/-- Congruence relations equal the smallest congruence relation in which they are contained. -/
@[simp] theorem con_gen_of_con {M : Type u_1} [Mul M] (c : con M) : con_gen ⇑c = c :=
  le_antisymm
    (eq.mpr (id (Eq._oldrec (Eq.refl (con_gen ⇑c ≤ c)) (con_gen_eq ⇑c)))
      (Inf_le fun (_x _x_1 : M) => id))
    con_gen.rel.of

/-- The map sending a binary relation to the smallest congruence relation in which it is
    contained is idempotent. -/
@[simp] theorem Mathlib.add_con.add_con_gen_idem {M : Type u_1} [Add M] (r : M → M → Prop) :
    add_con_gen ⇑(add_con_gen r) = add_con_gen r :=
  add_con.add_con_gen_of_add_con (add_con_gen r)

/-- The supremum of congruence relations `c, d` equals the smallest congruence relation containing
    the binary relation '`x` is related to `y` by `c` or `d`'. -/
theorem sup_eq_con_gen {M : Type u_1} [Mul M] (c : con M) (d : con M) :
    c ⊔ d = con_gen fun (x y : M) => coe_fn c x y ∨ coe_fn d x y :=
  sorry

/-- The supremum of two congruence relations equals the smallest congruence relation containing
    the supremum of the underlying binary operations. -/
theorem Mathlib.add_con.sup_def {M : Type u_1} [Add M] {c : add_con M} {d : add_con M} :
    c ⊔ d = add_con_gen (add_con.r c ⊔ add_con.r d) :=
  eq.mpr
    (id
      (Eq._oldrec (Eq.refl (c ⊔ d = add_con_gen (add_con.r c ⊔ add_con.r d)))
        (add_con.sup_eq_add_con_gen c d)))
    (Eq.refl (add_con_gen fun (x y : M) => coe_fn c x y ∨ coe_fn d x y))

/-- The supremum of a set of congruence relations `S` equals the smallest congruence relation
    containing the binary relation 'there exists `c ∈ S` such that `x` is related to `y` by
    `c`'. -/
theorem Mathlib.add_con.Sup_eq_add_con_gen {M : Type u_1} [Add M] (S : set (add_con M)) :
    Sup S = add_con_gen fun (x y : M) => ∃ (c : add_con M), c ∈ S ∧ coe_fn c x y :=
  sorry

/-- The supremum of a set of congruence relations is the same as the smallest congruence relation
    containing the supremum of the set's image under the map to the underlying binary relation. -/
theorem Mathlib.add_con.Sup_def {M : Type u_1} [Add M] {S : set (add_con M)} :
    Sup S = add_con_gen (Sup (add_con.r '' S)) :=
  sorry

/-- There is a Galois insertion of congruence relations on a type with a multiplication `M` into
    binary relations on `M`. -/
protected def gi (M : Type u_1) [Mul M] : galois_insertion con_gen r :=
  galois_insertion.mk (fun (r : M → M → Prop) (h : r (con_gen r) ≤ r) => con_gen r) sorry sorry
    sorry

/-- Given a function `f`, the smallest congruence relation containing the binary relation on `f`'s
    image defined by '`x ≈ y` iff the elements of `f⁻¹(x)` are related to the elements of `f⁻¹(y)`
    by a congruence relation `c`.' -/
def Mathlib.add_con.map_gen {M : Type u_1} {N : Type u_2} [Add M] [Add N] (c : add_con M)
    (f : M → N) : add_con N :=
  add_con_gen fun (x y : N) => ∃ (a : M), ∃ (b : M), f a = x ∧ f b = y ∧ coe_fn c a b

/-- Given a surjective multiplicative-preserving function `f` whose kernel is contained in a
    congruence relation `c`, the congruence relation on `f`'s codomain defined by '`x ≈ y` iff the
    elements of `f⁻¹(x)` are related to the elements of `f⁻¹(y)` by `c`.' -/
def Mathlib.add_con.map_of_surjective {M : Type u_1} {N : Type u_2} [Add M] [Add N] (c : add_con M)
    (f : M → N) (H : ∀ (x y : M), f (x + y) = f x + f y) (h : add_con.add_ker f H ≤ c)
    (hf : function.surjective f) : add_con N :=
  add_con.mk setoid.r sorry sorry

/-- A specialization of 'the smallest congruence relation containing a congruence relation `c`
    equals `c`'. -/
theorem Mathlib.add_con.map_of_surjective_eq_map_gen {M : Type u_1} {N : Type u_2} [Add M] [Add N]
    {c : add_con M} {f : M → N} (H : ∀ (x y : M), f (x + y) = f x + f y)
    (h : add_con.add_ker f H ≤ c) (hf : function.surjective f) :
    add_con.map_gen c f = add_con.map_of_surjective c f H h hf :=
  sorry

/-- Given types with multiplications `M, N` and a congruence relation `c` on `N`, a
    multiplication-preserving map `f : M → N` induces a congruence relation on `f`'s domain
    defined by '`x ≈ y` iff `f(x)` is related to `f(y)` by `c`.' -/
def Mathlib.add_con.comap {M : Type u_1} {N : Type u_2} [Add M] [Add N] (f : M → N)
    (H : ∀ (x y : M), f (x + y) = f x + f y) (c : add_con N) : add_con M :=
  add_con.mk setoid.r sorry sorry

/-- Given a congruence relation `c` on a type `M` with a multiplication, the order-preserving
    bijection between the set of congruence relations containing `c` and the congruence relations
    on the quotient of `M` by `c`. -/
def Mathlib.add_con.correspondence {M : Type u_1} [Add M] (c : add_con M) :
    (Subtype fun (d : add_con M) => c ≤ d) ≃o add_con (add_con.quotient c) :=
  rel_iso.mk
    (equiv.mk
      (fun (d : Subtype fun (d : add_con M) => c ≤ d) =>
        add_con.map_of_surjective (subtype.val d) coe sorry sorry sorry)
      (fun (d : add_con (add_con.quotient c)) =>
        { val := add_con.comap coe sorry d, property := sorry })
      sorry sorry)
    sorry

-- Monoids

/-- The quotient of a monoid by a congruence relation is a monoid. -/
protected instance monoid {M : Type u_1} [monoid M] (c : con M) : monoid (con.quotient c) :=
  monoid.mk Mul.mul sorry ↑1 sorry sorry

/-- The quotient of a `comm_monoid` by a congruence relation is a `comm_monoid`. -/
protected instance Mathlib.add_con.add_comm_monoid {α : Type u_1} [add_comm_monoid α]
    (c : add_con α) : add_comm_monoid (add_con.quotient c) :=
  add_comm_monoid.mk add_monoid.add sorry add_monoid.zero sorry sorry sorry

/-- The 1 of the quotient of a monoid by a congruence relation is the equivalence class of the
    monoid's 1. -/
@[simp] theorem coe_one {M : Type u_1} [monoid M] {c : con M} : ↑1 = 1 := rfl

/-- The submonoid of `M × M` defined by a congruence relation on a monoid `M`. -/
protected def Mathlib.add_con.add_submonoid (M : Type u_1) [add_monoid M] (c : add_con M) :
    add_submonoid (M × M) :=
  add_submonoid.mk (set_of fun (x : M × M) => coe_fn c (prod.fst x) (prod.snd x)) sorry sorry

/-- The congruence relation on a monoid `M` from a submonoid of `M × M` for which membership
    is an equivalence relation. -/
def Mathlib.add_con.of_add_submonoid {M : Type u_1} [add_monoid M] (N : add_submonoid (M × M))
    (H : equivalence fun (x y : M) => (x, y) ∈ N) : add_con M :=
  add_con.mk (fun (x y : M) => (x, y) ∈ N) H sorry

/-- Coercion from a congruence relation `c` on a monoid `M` to the submonoid of `M × M` whose
    elements are `(x, y)` such that `x` is related to `y` by `c`. -/
protected instance to_submonoid {M : Type u_1} [monoid M] : has_coe (con M) (submonoid (M × M)) :=
  has_coe.mk fun (c : con M) => con.submonoid M c

theorem Mathlib.add_con.mem_coe {M : Type u_1} [add_monoid M] {c : add_con M} {x : M} {y : M} :
    (x, y) ∈ ↑c ↔ (x, y) ∈ c :=
  iff.rfl

theorem to_submonoid_inj {M : Type u_1} [monoid M] (c : con M) (d : con M) (H : ↑c = ↑d) : c = d :=
  sorry

theorem Mathlib.add_con.le_iff {M : Type u_1} [add_monoid M] {c : add_con M} {d : add_con M} :
    c ≤ d ↔ ↑c ≤ ↑d :=
  { mp := fun (h : c ≤ d) (x : M × M) (H : x ∈ ↑c) => h H,
    mpr :=
      fun (h : ↑c ≤ ↑d) (x y : M) (hc : coe_fn c x y) => h ((fun (this : (x, y) ∈ c) => this) hc) }

/-- The kernel of a monoid homomorphism as a congruence relation. -/
def Mathlib.add_con.ker {M : Type u_1} {P : Type u_3} [add_monoid M] [add_monoid P] (f : M →+ P) :
    add_con M :=
  add_con.add_ker (⇑f) (add_monoid_hom.map_add' f)

/-- The definition of the congruence relation defined by a monoid homomorphism's kernel. -/
theorem ker_rel {M : Type u_1} {P : Type u_3} [monoid M] [monoid P] (f : M →* P) {x : M} {y : M} :
    coe_fn (ker f) x y ↔ coe_fn f x = coe_fn f y :=
  iff.rfl

/-- There exists an element of the quotient of a monoid by a congruence relation (namely 1). -/
protected instance quotient.inhabited {M : Type u_1} [monoid M] {c : con M} :
    Inhabited (con.quotient c) :=
  { default := ↑1 }

/-- The natural homomorphism from a monoid to its quotient by a congruence relation. -/
def Mathlib.add_con.mk' {M : Type u_1} [add_monoid M] (c : add_con M) : M →+ add_con.quotient c :=
  add_monoid_hom.mk coe sorry sorry

/-- The kernel of the natural homomorphism from a monoid to its quotient by a congruence
    relation `c` equals `c`. -/
@[simp] theorem Mathlib.add_con.mk'_ker {M : Type u_1} [add_monoid M] (c : add_con M) :
    add_con.ker (add_con.mk' c) = c :=
  add_con.ext fun (_x _x_1 : M) => add_con.eq c

/-- The natural homomorphism from a monoid to its quotient by a congruence relation is
    surjective. -/
theorem Mathlib.add_con.mk'_surjective {M : Type u_1} [add_monoid M] {c : add_con M} :
    function.surjective ⇑(add_con.mk' c) :=
  fun (x : add_con.quotient c) => quot.induction_on x fun (x : M) => Exists.intro x rfl

@[simp] theorem Mathlib.add_con.comp_mk'_apply {M : Type u_1} {P : Type u_3} [add_monoid M]
    [add_monoid P] {c : add_con M} (g : add_con.quotient c →+ P) {x : M} :
    coe_fn (add_monoid_hom.comp g (add_con.mk' c)) x = coe_fn g ↑x :=
  rfl

/-- The elements related to `x ∈ M`, `M` a monoid, by the kernel of a monoid homomorphism are
    those in the preimage of `f(x)` under `f`. -/
theorem Mathlib.add_con.ker_apply_eq_preimage {M : Type u_1} {P : Type u_3} [add_monoid M]
    [add_monoid P] {f : M →+ P} (x : M) :
    coe_fn (add_con.ker f) x = ⇑f ⁻¹' singleton (coe_fn f x) :=
  sorry

/-- Given a monoid homomorphism `f : N → M` and a congruence relation `c` on `M`, the congruence
    relation induced on `N` by `f` equals the kernel of `c`'s quotient homomorphism composed with
    `f`. -/
theorem Mathlib.add_con.comap_eq {M : Type u_1} {N : Type u_2} [add_monoid M] [add_monoid N]
    {c : add_con M} {f : N →+ M} :
    add_con.comap (⇑f) (add_monoid_hom.map_add f) c =
        add_con.ker (add_monoid_hom.comp (add_con.mk' c) f) :=
  sorry

/-- The homomorphism on the quotient of a monoid by a congruence relation `c` induced by a
    homomorphism constant on `c`'s equivalence classes. -/
def Mathlib.add_con.lift {M : Type u_1} {P : Type u_3} [add_monoid M] [add_monoid P] (c : add_con M)
    (f : M →+ P) (H : c ≤ add_con.ker f) : add_con.quotient c →+ P :=
  add_monoid_hom.mk (fun (x : add_con.quotient c) => add_con.lift_on x ⇑f sorry) sorry sorry

/-- The diagram describing the universal property for quotients of monoids commutes. -/
@[simp] theorem Mathlib.add_con.lift_mk' {M : Type u_1} {P : Type u_3} [add_monoid M] [add_monoid P]
    {c : add_con M} {f : M →+ P} (H : c ≤ add_con.ker f) (x : M) :
    coe_fn (add_con.lift c f H) (coe_fn (add_con.mk' c) x) = coe_fn f x :=
  rfl

/-- The diagram describing the universal property for quotients of monoids commutes. -/
@[simp] theorem Mathlib.add_con.lift_coe {M : Type u_1} {P : Type u_3} [add_monoid M] [add_monoid P]
    {c : add_con M} {f : M →+ P} (H : c ≤ add_con.ker f) (x : M) :
    coe_fn (add_con.lift c f H) ↑x = coe_fn f x :=
  rfl

/-- The diagram describing the universal property for quotients of monoids commutes. -/
@[simp] theorem Mathlib.add_con.lift_comp_mk' {M : Type u_1} {P : Type u_3} [add_monoid M]
    [add_monoid P] {c : add_con M} {f : M →+ P} (H : c ≤ add_con.ker f) :
    add_monoid_hom.comp (add_con.lift c f H) (add_con.mk' c) = f :=
  add_monoid_hom.ext
    fun (x : M) => Eq.refl (coe_fn (add_monoid_hom.comp (add_con.lift c f H) (add_con.mk' c)) x)

/-- Given a homomorphism `f` from the quotient of a monoid by a congruence relation, `f` equals the
    homomorphism on the quotient induced by `f` composed with the natural map from the monoid to
    the quotient. -/
@[simp] theorem Mathlib.add_con.lift_apply_mk' {M : Type u_1} {P : Type u_3} [add_monoid M]
    [add_monoid P] {c : add_con M} (f : add_con.quotient c →+ P) :
    (add_con.lift c (add_monoid_hom.comp f (add_con.mk' c))
          fun (x y : M) (h : coe_fn c x y) =>
            (fun (this : coe_fn f ↑x = coe_fn f ↑y) => this)
              (eq.mpr
                (id (Eq._oldrec (Eq.refl (coe_fn f ↑x = coe_fn f ↑y)) (iff.mpr (add_con.eq c) h)))
                (Eq.refl (coe_fn f ↑y)))) =
        f :=
  sorry

/-- Homomorphisms on the quotient of a monoid by a congruence relation are equal if they
    are equal on elements that are coercions from the monoid. -/
theorem Mathlib.add_con.lift_funext {M : Type u_1} {P : Type u_3} [add_monoid M] [add_monoid P]
    {c : add_con M} (f : add_con.quotient c →+ P) (g : add_con.quotient c →+ P)
    (h : ∀ (a : M), coe_fn f ↑a = coe_fn g ↑a) : f = g :=
  sorry

/-- The uniqueness part of the universal property for quotients of monoids. -/
theorem Mathlib.add_con.lift_unique {M : Type u_1} {P : Type u_3} [add_monoid M] [add_monoid P]
    {c : add_con M} {f : M →+ P} (H : c ≤ add_con.ker f) (g : add_con.quotient c →+ P)
    (Hg : add_monoid_hom.comp g (add_con.mk' c) = f) : g = add_con.lift c f H :=
  sorry

/-- Given a congruence relation `c` on a monoid and a homomorphism `f` constant on `c`'s
    equivalence classes, `f` has the same image as the homomorphism that `f` induces on the
    quotient. -/
theorem Mathlib.add_con.lift_range {M : Type u_1} {P : Type u_3} [add_monoid M] [add_monoid P]
    {c : add_con M} {f : M →+ P} (H : c ≤ add_con.ker f) :
    add_monoid_hom.mrange (add_con.lift c f H) = add_monoid_hom.mrange f :=
  sorry

/-- Surjective monoid homomorphisms constant on a congruence relation `c`'s equivalence classes
    induce a surjective homomorphism on `c`'s quotient. -/
theorem Mathlib.add_con.lift_surjective_of_surjective {M : Type u_1} {P : Type u_3} [add_monoid M]
    [add_monoid P] {c : add_con M} {f : M →+ P} (h : c ≤ add_con.ker f)
    (hf : function.surjective ⇑f) : function.surjective ⇑(add_con.lift c f h) :=
  fun (y : P) =>
    exists.elim (hf y)
      fun (w : M) (hw : coe_fn f w = y) => Exists.intro (↑w) (Eq.symm (add_con.lift_mk' h w) ▸ hw)

/-- Given a monoid homomorphism `f` from `M` to `P`, the kernel of `f` is the unique congruence
    relation on `M` whose induced map from the quotient of `M` to `P` is injective. -/
theorem Mathlib.add_con.ker_eq_lift_of_injective {M : Type u_1} {P : Type u_3} [add_monoid M]
    [add_monoid P] (c : add_con M) (f : M →+ P) (H : c ≤ add_con.ker f)
    (h : function.injective ⇑(add_con.lift c f H)) : add_con.ker f = c :=
  add_con.to_setoid_inj (setoid.ker_eq_lift_of_injective (⇑f) H h)

/-- The homomorphism induced on the quotient of a monoid by the kernel of a monoid homomorphism. -/
def Mathlib.add_con.ker_lift {M : Type u_1} {P : Type u_3} [add_monoid M] [add_monoid P]
    (f : M →+ P) : add_con.quotient (add_con.ker f) →+ P :=
  add_con.lift (add_con.ker f) f sorry

/-- The diagram described by the universal property for quotients of monoids, when the congruence
    relation is the kernel of the homomorphism, commutes. -/
@[simp] theorem ker_lift_mk {M : Type u_1} {P : Type u_3} [monoid M] [monoid P] {f : M →* P}
    (x : M) : coe_fn (ker_lift f) ↑x = coe_fn f x :=
  rfl

/-- Given a monoid homomorphism `f`, the induced homomorphism on the quotient by `f`'s kernel has
    the same image as `f`. -/
@[simp] theorem Mathlib.add_con.ker_lift_range_eq {M : Type u_1} {P : Type u_3} [add_monoid M]
    [add_monoid P] {f : M →+ P} :
    add_monoid_hom.mrange (add_con.ker_lift f) = add_monoid_hom.mrange f :=
  add_con.lift_range fun (_x _x_1 : M) => id

/-- A monoid homomorphism `f` induces an injective homomorphism on the quotient by `f`'s kernel. -/
theorem Mathlib.add_con.ker_lift_injective {M : Type u_1} {P : Type u_3} [add_monoid M]
    [add_monoid P] (f : M →+ P) : function.injective ⇑(add_con.ker_lift f) :=
  fun (x y : add_con.quotient (add_con.ker f)) =>
    quotient.induction_on₂' x y fun (_x _x_1 : M) => iff.mpr (add_con.eq (add_con.ker f))

/-- Given congruence relations `c, d` on a monoid such that `d` contains `c`, `d`'s quotient
    map induces a homomorphism from the quotient by `c` to the quotient by `d`. -/
def Mathlib.add_con.map {M : Type u_1} [add_monoid M] (c : add_con M) (d : add_con M) (h : c ≤ d) :
    add_con.quotient c →+ add_con.quotient d :=
  add_con.lift c (add_con.mk' d) sorry

/-- Given congruence relations `c, d` on a monoid such that `d` contains `c`, the definition of
    the homomorphism from the quotient by `c` to the quotient by `d` induced by `d`'s quotient
    map. -/
theorem Mathlib.add_con.map_apply {M : Type u_1} [add_monoid M] {c : add_con M} {d : add_con M}
    (h : c ≤ d) (x : add_con.quotient c) :
    coe_fn (add_con.map c d h) x =
        coe_fn
          (add_con.lift c (add_con.mk' d)
            fun (x y : M) (hc : coe_fn c x y) => iff.mpr (add_con.eq d) (h hc))
          x :=
  rfl

/-- The first isomorphism theorem for monoids. -/
def Mathlib.add_con.quotient_ker_equiv_range {M : Type u_1} {P : Type u_3} [add_monoid M]
    [add_monoid P] (f : M →+ P) : add_con.quotient (add_con.ker f) ≃+ ↥(add_monoid_hom.mrange f) :=
  add_equiv.mk
    (equiv.to_fun
      (equiv.of_bijective
        ⇑(add_monoid_hom.comp
            (add_equiv.to_add_monoid_hom (add_equiv.add_submonoid_congr add_con.ker_lift_range_eq))
            (add_monoid_hom.mrange_restrict (add_con.ker_lift f)))
        sorry))
    (equiv.inv_fun
      (equiv.of_bijective
        ⇑(add_monoid_hom.comp
            (add_equiv.to_add_monoid_hom (add_equiv.add_submonoid_congr add_con.ker_lift_range_eq))
            (add_monoid_hom.mrange_restrict (add_con.ker_lift f)))
        sorry))
    sorry sorry sorry

/-- The first isomorphism theorem for monoids in the case of a surjective homomorphism. -/
def Mathlib.add_con.quotient_ker_equiv_of_surjective {M : Type u_1} {P : Type u_3} [add_monoid M]
    [add_monoid P] (f : M →+ P) (hf : function.surjective ⇑f) :
    add_con.quotient (add_con.ker f) ≃+ P :=
  add_equiv.mk (equiv.to_fun (equiv.of_bijective ⇑(add_con.ker_lift f) sorry))
    (equiv.inv_fun (equiv.of_bijective ⇑(add_con.ker_lift f) sorry)) sorry sorry sorry

/-- The second isomorphism theorem for monoids. -/
def Mathlib.add_con.comap_quotient_equiv {M : Type u_1} {N : Type u_2} [add_monoid M] [add_monoid N]
    (c : add_con M) (f : N →+ M) :
    add_con.quotient (add_con.comap (⇑f) (add_monoid_hom.map_add f) c) ≃+
        ↥(add_monoid_hom.mrange (add_monoid_hom.comp (add_con.mk' c) f)) :=
  add_equiv.trans (add_con.congr add_con.comap_eq)
    (add_con.quotient_ker_equiv_range (add_monoid_hom.comp (add_con.mk' c) f))

/-- The third isomorphism theorem for monoids. -/
def quotient_quotient_equiv_quotient {M : Type u_1} [monoid M] (c : con M) (d : con M) (h : c ≤ d) :
    con.quotient (ker (map c d h)) ≃* con.quotient d :=
  mul_equiv.mk
    (equiv.to_fun (setoid.quotient_quotient_equiv_quotient (to_setoid c) (to_setoid d) h))
    (equiv.inv_fun (setoid.quotient_quotient_equiv_quotient (to_setoid c) (to_setoid d) h)) sorry
    sorry sorry

/-- Multiplicative congruence relations preserve inversion. -/
protected theorem Mathlib.add_con.neg {M : Type u_1} [add_group M] (c : add_con M) {w : M} {x : M} :
    coe_fn c w x → coe_fn c (-w) (-x) :=
  sorry

/-- The inversion induced on the quotient by a congruence relation on a type with a
    inversion. -/
protected instance has_inv {M : Type u_1} [group M] (c : con M) : has_inv (con.quotient c) :=
  has_inv.mk fun (x : con.quotient c) => quotient.lift_on' x (fun (w : M) => ↑(w⁻¹)) sorry

/-- The quotient of a group by a congruence relation is a group. -/
protected instance Mathlib.add_con.add_group {M : Type u_1} [add_group M] (c : add_con M) :
    add_group (add_con.quotient c) :=
  add_group.mk add_monoid.add sorry add_monoid.zero sorry sorry (fun (x : add_con.quotient c) => -x)
    (sub_neg_monoid.sub._default add_monoid.add sorry add_monoid.zero sorry sorry
      fun (x : add_con.quotient c) => -x)
    sorry

end Mathlib


import combinatorics.simple_graph.coloring

--OUTPUT 1
theorem bipartite_graph_two_colorable (G : Type*) [graph G] : two_colorable G ↔ bipartite G :=
begin
  split,
  {
    assume h1 : two_colorable G,
    have h2 : ∃ A B : set G, (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a, b) ∈ G.edges), from sorry,
    show bipartite G, from sorry,
  },
  {
    assume h1 : bipartite G,
    have h2 : ∃ A B : set G, (∀ a : G, a ∈ A ∨ a ∈ B) ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → (a, b) ∈ G.edges), from sorry,
    show two_colorable G, from sorry,
  }
end

/- FEW SHOT PROMPTS TO CODEX(START)
/--`theorem`
Power Set is Closed under Intersection
Let $S$ be a set.

Let $\powerset S$ be the power set of $S$.

Then:
:$\forall A, B \in \powerset S: A \cap B \in \powerset S$
`proof`
Let $A, B \in \powerset S$.

Then by the definition of power set, $A \subseteq S$ and $B \subseteq S$.

From Intersection is Subset we have that $A \cap B \subseteq A$.

It follows from Subset Relation is Transitive that $A \cap B \subseteq S$.

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from sorry,
  have h2 : (A ∩ B) ⊆ A, from sorry,
  have h3 : (A ∩ B) ⊆ S, from sorry,
  show (A ∩ B) ∈  𝒫 S, from sorry,
end

/--`theorem`
Square of Sum
 :$\forall x, y \in \R: \paren {x + y}^2 = x^2 + 2 x y + y^2$
`proof`
Follows from the distribution of multiplication over addition:

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2) :=
begin
  calc (x + y)^2 = (x+y)*(x+y) : by sorry
  ... = x*(x+y) + y*(x+y) : by sorry
  ... = x*x + x*y + y*x + y*y : by sorry
  ... = x^2 + 2*x*y + y^2 : by sorry,
end

/--`theorem`
Identity of Group is Unique
Let $\struct {G, \circ}$ be a group. Then there is a unique identity element $e \in G$.
`proof`
From Group has Latin Square Property, there exists a unique $x \in G$ such that:
:$a x = b$

and there exists a unique $y \in G$ such that:
:$y a = b$

Setting $b = a$, this becomes:

There exists a unique $x \in G$ such that:
:$a x = a$

and there exists a unique $y \in G$ such that:
:$y a = a$

These $x$ and $y$ are both $e$, by definition of identity element.
{{qed}}
-/
theorem group_identity_unique {G : Type*} [group G] : ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a :=
begin
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from sorry,
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from sorry,

  have h3 : ∀ a : G, ∃! x : G, a * x = a, from sorry,
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from sorry,

  have h5 : ∀ a : G, classical.some (h3 a) = (1 : G), from sorry,
  have h6 : ∀ a : G, classical.some (h4 a) = (1 : G), from sorry,

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by {
    use (1 : G),
    have h7 : ∀ e : G, (∀ a : G, e * a = a ∧ a * e = a) → e = 1, from by {
      assume (e : G) (h7 : ∀ a : G, e * a = a ∧ a * e = a),
      have h8 : ∀ a : G, e = classical.some (h3 a), from sorry,
      have h9 : ∀ a : G, e = classical.some (h4 a), from sorry,
      show e = (1 : G), from sorry,
    },
    sorry,
  }
end

/--`theorem`
Bipartite Graph is two colorable
Let $G$ be a graph. Then $G$ is 2-colorable if and only if $G$ is bipartite.
`proof`
Let $G$ be a 2-colorable graph, which means we can color every vertex either red or blue, and no edge will have both endpoints colored the same color. Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue. Since all vertices of $A$ are red, there are no edges within $A$, and similarly for $B$. This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.

Conversely, suppose $G$ is bipartite, that is, we can partition the vertices into two subsets $V_{1}, V_{2}$ every edge has one endpoint in $V_{1}$ and the other in $V_{2}$. Then coloring every vertex of $V_{1}$ red and every vertex of $V_{2}$ blue yields a valid coloring, so $G$ is 2-colorable.

QED

-/
theorem
FEW SHOT PROMPTS TO CODEX(END)-/


import ground_zero.types.coproduct ground_zero.HITs.colimit
open ground_zero.types

namespace ground_zero.types.nat

universes u v w

def encode : ℕ → ℕ + unit
| nat.zero := coproduct.inr unit.star
| (nat.succ n) := coproduct.inl n

def decode : ℕ + unit → ℕ
| (coproduct.inr _) := nat.zero
| (coproduct.inl n) := nat.succ n

theorem closed_nat : ℕ ≃ ℕ + unit := begin
  existsi encode, split; existsi decode,
  { intro n, induction n with n ih,
    { simp [decode, encode] },
    { simp at ih, simp, simp [encode, decode] } },
  { intro n, simp, induction n,
    { simp [decode, encode] },
    { induction n, simp [encode, decode] } }
end

theorem equiv_addition {α : Type u} {β : Type v} (γ : Type w)
  (e : α ≃ β) : α + γ ≃ β + γ := begin
  induction e with f H,
  have q := qinv.b2q f H,
  cases q with g inv, cases inv with α' β',

  simp [equiv.homotopy, function.comp] at α',
  simp [equiv.homotopy, function.comp] at β',

  let f : α + γ → β + γ := λ x, match x with
  | coproduct.inl a := coproduct.inl (f a)
  | coproduct.inr c := coproduct.inr c
  end,
  let g : β + γ → α + γ := λ x, match x with
  | coproduct.inl b := coproduct.inl (g b)
  | coproduct.inr c := coproduct.inr c
  end,

  existsi f, split; existsi g,
  { intro x, induction x,
    { simp [g, f],
      rw [ground_zero.support.truncation (β' x)],
      simp },
    { trivial } },
  { intro x, induction x,
    { simp [f, g],
      rw [ground_zero.support.truncation (α' x)],
      simp },
    { trivial } }
end

example : ℕ ≃ ℕ + unit + unit := begin
  transitivity, exact closed_nat,
  apply equiv_addition, exact closed_nat
end

def drop (α : Type) : ℕ → Type
| 0 := α
| (nat.succ n) := coproduct (drop n) unit

theorem nat_plus_unit (n : ℕ) : ℕ ≃ drop ℕ n := begin
  induction n with n ih,
  { reflexivity },
  { transitivity,
    exact closed_nat,
    apply equiv_addition unit ih }
end

abbreviation lift_unit (n : ℕ) : drop unit n → drop unit (n + 1) :=
coproduct.inl

def lift_to_top (x : unit) : Π (n : ℕ), drop unit n
| 0 := x
| (n + 1) := coproduct.inl (lift_to_top n)

def iterated := ground_zero.HITs.colimit (drop unit) lift_unit

def iterated.encode : ℕ → iterated
| 0 := ground_zero.HITs.colimit.inclusion 0 unit.star
| (n + 1) := ground_zero.HITs.colimit.inclusion (n + 1) (coproduct.inr unit.star)

end ground_zero.types.nat


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

import data.polynomial.ring_division
import group_theory.specific_groups.cyclic
import algebra.geom_sum

/-!
# Integral domains

Assorted theorems about integral domains.

## Main theorems

* `is_cyclic_of_subgroup_is_domain`: A finite subgroup of the units of an integral domain is cyclic.
* `fintype.field_of_domain`: A finite integral domain is a field.

## TODO

Prove Wedderburn's little theorem, which shows that all finite division rings are actually fields.

## Tags

integral domain, finite integral domain, finite field
-/

section

open finset polynomial function
open_locale big_operators nat

section cancel_monoid_with_zero
-- There doesn't seem to be a better home for these right now
variables {M : Type*} [cancel_monoid_with_zero M] [finite M]

lemma mul_right_bijective_of_finite₀ {a : M} (ha : a ≠ 0) : bijective (λ b, a * b) :=
finite.injective_iff_bijective.1 $ mul_right_injective₀ ha

lemma mul_left_bijective_of_finite₀ {a : M} (ha : a ≠ 0) : bijective (λ b, b * a) :=
finite.injective_iff_bijective.1 $ mul_left_injective₀ ha

/-- Every finite nontrivial cancel_monoid_with_zero is a group_with_zero. -/
def fintype.group_with_zero_of_cancel (M : Type*) [cancel_monoid_with_zero M] [decidable_eq M]
  [fintype M] [nontrivial M] : group_with_zero M :=
{ inv := λ a, if h : a = 0 then 0 else fintype.bij_inv (mul_right_bijective_of_finite₀ h) 1,
  mul_inv_cancel := λ a ha,
    by { simp [has_inv.inv, dif_neg ha], exact fintype.right_inverse_bij_inv _ _ },
  inv_zero := by { simp [has_inv.inv, dif_pos rfl] },
  ..‹nontrivial M›,
  ..‹cancel_monoid_with_zero M› }

lemma exists_eq_pow_of_mul_eq_pow_of_coprime {R : Type*} [comm_semiring R] [is_domain R]
  [gcd_monoid R] [unique Rˣ] {a b c : R} {n : ℕ} (cp : is_coprime a b) (h : a * b = c ^ n) :
  ∃ d : R, a = d ^ n :=
begin
  refine exists_eq_pow_of_mul_eq_pow (is_unit_of_dvd_one _ _) h,
  obtain ⟨x, y, hxy⟩ := cp,
  rw [← hxy],
  exact dvd_add (dvd_mul_of_dvd_right (gcd_dvd_left _ _) _)
    (dvd_mul_of_dvd_right (gcd_dvd_right _ _) _)
end

lemma finset.exists_eq_pow_of_mul_eq_pow_of_coprime {ι R : Type*} [comm_semiring R] [is_domain R]
  [gcd_monoid R] [unique Rˣ] {n : ℕ} {c : R} {s : finset ι} {f : ι → R}
  (h : ∀ i j ∈ s, i ≠ j → is_coprime (f i) (f j))
  (hprod : ∏ i in s, f i = c ^ n) : ∀ i ∈ s, ∃ d : R, f i = d ^ n :=
begin
  classical,
  intros i hi,
  rw [← insert_erase hi, prod_insert (not_mem_erase i s)] at hprod,
  refine exists_eq_pow_of_mul_eq_pow_of_coprime
    (is_coprime.prod_right (λ j hj, h i hi j (erase_subset i s hj) (λ hij, _))) hprod,
  rw [hij] at hj,
  exact (s.not_mem_erase _) hj
end

end cancel_monoid_with_zero

variables {R : Type*} {G : Type*}

section ring

variables [ring R] [is_domain R] [fintype R]

/-- Every finite domain is a division ring.

TODO: Prove Wedderburn's little theorem,
which shows a finite domain is in fact commutative, hence a field. -/
def fintype.division_ring_of_is_domain (R : Type*) [ring R] [is_domain R] [decidable_eq R]
  [fintype R] : division_ring R :=
{ ..show group_with_zero R, from fintype.group_with_zero_of_cancel R,
  ..‹ring R› }

/-- Every finite commutative domain is a field.

TODO: Prove Wedderburn's little theorem, which shows a finite domain is automatically commutative,
dropping one assumption from this theorem. -/
def fintype.field_of_domain (R) [comm_ring R] [is_domain R] [decidable_eq R] [fintype R] :
  field R :=
{ .. fintype.group_with_zero_of_cancel R,
  .. ‹comm_ring R› }

lemma finite.is_field_of_domain (R) [comm_ring R] [is_domain R] [finite R] : is_field R :=
by { casesI nonempty_fintype R,
  exact @field.to_is_field R (@@fintype.field_of_domain R _ _ (classical.dec_eq R) _) }

end ring

variables [comm_ring R] [is_domain R] [group G]

lemma card_nth_roots_subgroup_units [fintype G] (f : G →* R) (hf : injective f) {n : ℕ} (hn : 0 < n)
  (g₀ : G) :
  ({g ∈ univ | g ^ n = g₀} : finset G).card ≤ (nth_roots n (f g₀)).card :=
begin
  haveI : decidable_eq R := classical.dec_eq _,
  refine le_trans _ (nth_roots n (f g₀)).to_finset_card_le,
  apply card_le_card_of_inj_on f,
  { intros g hg,
    rw [sep_def, mem_filter] at hg,
    rw [multiset.mem_to_finset, mem_nth_roots hn, ← f.map_pow, hg.2] },
  { intros, apply hf, assumption }
end

/-- A finite subgroup of the unit group of an integral domain is cyclic. -/
lemma is_cyclic_of_subgroup_is_domain [finite G] (f : G →* R) (hf : injective f) : is_cyclic G :=
begin
  classical,
  casesI nonempty_fintype G,
  apply is_cyclic_of_card_pow_eq_one_le,
  intros n hn,
  convert (le_trans (card_nth_roots_subgroup_units f hf hn 1) (card_nth_roots n (f 1)))
end

/-- The unit group of a finite integral domain is cyclic.

To support `ℤˣ` and other infinite monoids with finite groups of units, this requires only
`finite Rˣ` rather than deducing it from `finite R`. -/
instance [finite Rˣ] : is_cyclic Rˣ :=
is_cyclic_of_subgroup_is_domain (units.coe_hom R) $ units.ext

section

variables (S : subgroup Rˣ) [finite S]

/-- A finite subgroup of the units of an integral domain is cyclic. -/
instance subgroup_units_cyclic : is_cyclic S :=
begin
  refine is_cyclic_of_subgroup_is_domain ⟨(coe : S → R), _, _⟩
    (units.ext.comp subtype.val_injective),
  { simp },
  { intros, simp },
end

end

section euclidean_division

namespace polynomial

open_locale polynomial

variables (K : Type) [field K] [algebra R[X] K] [is_fraction_ring R[X] K]

lemma div_eq_quo_add_rem_div (f : R[X]) {g : R[X]} (hg : g.monic) :
  ∃ q r : R[X], r.degree < g.degree ∧ (↑f : K) / ↑g = ↑q + ↑r / ↑g :=
begin
  refine ⟨f /ₘ g, f %ₘ g, _, _⟩,
  { exact degree_mod_by_monic_lt _ hg },
  { have hg' : (↑g : K) ≠ 0 := by exact_mod_cast (monic.ne_zero hg),
    field_simp [hg'],
    norm_cast,
    rw [add_comm, mul_comm, mod_by_monic_add_div f hg] },
end

end polynomial

end euclidean_division

variables [fintype G]

lemma card_fiber_eq_of_mem_range {H : Type*} [group H] [decidable_eq H]
  (f : G →* H) {x y : H} (hx : x ∈ set.range f) (hy : y ∈ set.range f) :
  (univ.filter $ λ g, f g = x).card = (univ.filter $ λ g, f g = y).card :=
begin
  rcases hx with ⟨x, rfl⟩,
  rcases hy with ⟨y, rfl⟩,
  refine card_congr (λ g _, g * x⁻¹ * y) _ _ (λ g hg, ⟨g * y⁻¹ * x, _⟩),
  { simp only [mem_filter, one_mul, monoid_hom.map_mul, mem_univ, mul_right_inv,
      eq_self_iff_true, monoid_hom.map_mul_inv, and_self, forall_true_iff] {contextual := tt} },
  { simp only [mul_left_inj, imp_self, forall_2_true_iff], },
  { simp only [true_and, mem_filter, mem_univ] at hg,
    simp only [hg, mem_filter, one_mul, monoid_hom.map_mul, mem_univ, mul_right_inv,
      eq_self_iff_true, exists_prop_of_true, monoid_hom.map_mul_inv, and_self,
      mul_inv_cancel_right, inv_mul_cancel_right], }
end

/-- In an integral domain, a sum indexed by a nontrivial homomorphism from a finite group is zero.
-/
lemma sum_hom_units_eq_zero (f : G →* R) (hf : f ≠ 1) : ∑ g : G, f g = 0 :=
begin
  classical,
  obtain ⟨x, hx⟩ : ∃ x : monoid_hom.range f.to_hom_units,
    ∀ y : monoid_hom.range f.to_hom_units, y ∈ submonoid.powers x,
    from is_cyclic.exists_monoid_generator,
  have hx1 : x ≠ 1,
  { rintro rfl,
    apply hf,
    ext g,
    rw [monoid_hom.one_apply],
    cases hx ⟨f.to_hom_units g, g, rfl⟩ with n hn,
    rwa [subtype.ext_iff, units.ext_iff, subtype.coe_mk, monoid_hom.coe_to_hom_units,
      one_pow, eq_comm] at hn, },
  replace hx1 : (x : R) - 1 ≠ 0,
    from λ h, hx1 (subtype.eq (units.ext (sub_eq_zero.1 h))),
  let c := (univ.filter (λ g, f.to_hom_units g = 1)).card,
  calc ∑ g : G, f g
      = ∑ g : G, f.to_hom_units g : rfl
  ... = ∑ u : Rˣ in univ.image f.to_hom_units,
    (univ.filter (λ g, f.to_hom_units g = u)).card • u : sum_comp (coe : Rˣ → R) f.to_hom_units
  ... = ∑ u : Rˣ in univ.image f.to_hom_units, c • u :
    sum_congr rfl (λ u hu, congr_arg2 _ _ rfl) -- remaining goal 1, proven below
  ... = ∑ b : monoid_hom.range f.to_hom_units, c • ↑b : finset.sum_subtype _
      (by simp ) _
  ... = c • ∑ b : monoid_hom.range f.to_hom_units, (b : R) : smul_sum.symm
  ... = c • 0 : congr_arg2 _ rfl _            -- remaining goal 2, proven below
  ... = 0 : smul_zero _,
  { -- remaining goal 1
    show (univ.filter (λ (g : G), f.to_hom_units g = u)).card = c,
    apply card_fiber_eq_of_mem_range f.to_hom_units,
    { simpa only [mem_image, mem_univ, exists_prop_of_true, set.mem_range] using hu, },
    { exact ⟨1, f.to_hom_units.map_one⟩ } },
  -- remaining goal 2
  show ∑ b : monoid_hom.range f.to_hom_units, (b : R) = 0,
  calc ∑ b : monoid_hom.range f.to_hom_units, (b : R)
      = ∑ n in range (order_of x), x ^ n :
    eq.symm $ sum_bij (λ n _, x ^ n)
      (by simp only [mem_univ, forall_true_iff])
      (by simp only [implies_true_iff, eq_self_iff_true, subgroup.coe_pow, units.coe_pow, coe_coe])
      (λ m n hm hn, pow_injective_of_lt_order_of _
        (by simpa only [mem_range] using hm)
        (by simpa only [mem_range] using hn))
      (λ b hb, let ⟨n, hn⟩ := hx b in ⟨n % order_of x, mem_range.2 (nat.mod_lt _ (order_of_pos _)),
        by rw [← pow_eq_mod_order_of, hn]⟩)
  ... = 0 : _,
  rw [← mul_left_inj' hx1, zero_mul, geom_sum_mul, coe_coe],
  norm_cast,
  simp [pow_order_of_eq_one],
end

/-- In an integral domain, a sum indexed by a homomorphism from a finite group is zero,
unless the homomorphism is trivial, in which case the sum is equal to the cardinality of the group.
-/
lemma sum_hom_units (f : G →* R) [decidable (f = 1)] :
  ∑ g : G, f g = if f = 1 then fintype.card G else 0 :=
begin
  split_ifs with h h,
  { simp [h, card_univ] },
  { exact sum_hom_units_eq_zero f h }
end

end


/-
Copyright (c) 2022 Yaël Dillies, Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Bhavik Mehta
-/
import analysis.special_functions.pow
import order.partition.equipartition

/-!
# Numerical bounds for Szemerédi Regularity Lemma

This file gathers the numerical facts required by the proof of Szemerédi's regularity lemma.

## Main declarations

* `szemeredi_regularity.step_bound`: During the inductive step, a partition of size `n` is blown to
  size at most `step_bound n`.
* `szemeredi_regularity.initial_bound`: The size of the partition we start the induction with.
* `szemeredi_regularity.bound`: The upper bound on the size of the partition produced by our version
  of Szemerédi's regularity lemma.
-/

open finset fintype function real

namespace szemeredi_regularity

/-- Auxiliary function for Szemerédi's regularity lemma. Blowing up a partition of size `n` during
the induction results in a partition of size at most `step_bound n`. -/
def step_bound (n : ℕ) : ℕ := n * 4 ^ n

lemma le_step_bound : id ≤ step_bound := λ n, nat.le_mul_of_pos_right $ pow_pos (by norm_num) n

lemma step_bound_mono : monotone step_bound :=
λ a b h, nat.mul_le_mul h $ nat.pow_le_pow_of_le_right (by norm_num) h

lemma step_bound_pos_iff {n : ℕ} : 0 < step_bound n ↔ 0 < n :=
zero_lt_mul_right $ pow_pos (by norm_num) _

alias step_bound_pos_iff ↔ _ step_bound_pos

variables {α : Type*} [decidable_eq α] [fintype α] {P : finpartition (univ : finset α)}
  {u : finset α} {ε : ℝ}

local notation `m` := (card α/step_bound P.parts.card : ℕ)
local notation `a` := (card α/P.parts.card - m * 4^P.parts.card : ℕ)

lemma m_pos [nonempty α] (hPα : P.parts.card * 16^P.parts.card ≤ card α) : 0 < m :=
nat.div_pos ((nat.mul_le_mul_left _ $ nat.pow_le_pow_of_le_left (by norm_num) _).trans hPα) $
  step_bound_pos (P.parts_nonempty $ univ_nonempty.ne_empty).card_pos

lemma m_coe_pos [nonempty α] (hPα : P.parts.card * 16^P.parts.card ≤ card α) : (0 : ℝ) < m :=
nat.cast_pos.2 $ m_pos hPα

lemma coe_m_add_one_pos : 0 < (m : ℝ) + 1 := nat.cast_add_one_pos _

lemma one_le_m_coe [nonempty α] (hPα : P.parts.card * 16^P.parts.card ≤ card α) : (1 : ℝ) ≤ m :=
nat.one_le_cast.2 $ m_pos hPα

lemma eps_pow_five_pos (hPε : 100 ≤ 4^P.parts.card * ε^5) : 0 < ε^5 :=
pos_of_mul_pos_left ((by norm_num : (0 : ℝ) < 100).trans_le hPε) $ pow_nonneg (by norm_num) _

lemma eps_pos (hPε : 100 ≤ 4^P.parts.card * ε^5) : 0 < ε :=
pow_bit1_pos_iff.1 $ eps_pow_five_pos hPε

lemma four_pow_pos {n : ℕ} : 0 < (4 : ℝ)^n := pow_pos (by norm_num) n

lemma hundred_div_ε_pow_five_le_m [nonempty α] (hPα : P.parts.card * 16^P.parts.card ≤ card α)
  (hPε : 100 ≤ 4^P.parts.card * ε^5) :
  100 / ε^5 ≤ m :=
(div_le_of_nonneg_of_le_mul (eps_pow_five_pos hPε).le four_pow_pos.le hPε).trans
begin
  norm_cast,
  rwa [nat.le_div_iff_mul_le'(step_bound_pos (P.parts_nonempty $ univ_nonempty.ne_empty).card_pos),
    step_bound, mul_left_comm, ←mul_pow],
end

lemma hundred_le_m [nonempty α] (hPα : P.parts.card * 16^P.parts.card ≤ card α)
  (hPε : 100 ≤ 4^P.parts.card * ε^5) (hε : ε ≤ 1) : 100 ≤ m :=
by exact_mod_cast
  (le_div_self (by norm_num) (eps_pow_five_pos hPε) $ pow_le_one _ (eps_pos hPε).le hε).trans
    (hundred_div_ε_pow_five_le_m hPα hPε)

lemma a_add_one_le_four_pow_parts_card : a + 1 ≤ 4^P.parts.card :=
begin
  have h : 1 ≤ 4^P.parts.card := one_le_pow_of_one_le (by norm_num) _,
  rw [step_bound, ←nat.div_div_eq_div_mul, ←nat.le_sub_iff_right h, tsub_le_iff_left,
    ←nat.add_sub_assoc h],
  exact nat.le_pred_of_lt (nat.lt_div_mul_add h),
end

lemma card_aux₁ (hucard : u.card = m * 4^P.parts.card + a) :
  (4^P.parts.card - a) * m + a * (m + 1) = u.card :=
by rw [hucard, mul_add, mul_one, ←add_assoc, ←add_mul, nat.sub_add_cancel
  ((nat.le_succ _).trans a_add_one_le_four_pow_parts_card), mul_comm]

lemma card_aux₂ (hP : P.is_equipartition) (hu : u ∈ P.parts)
  (hucard : ¬u.card = m * 4^P.parts.card + a) :
  (4^P.parts.card - (a + 1)) * m + (a + 1) * (m + 1) = u.card :=
begin
  have : m * 4 ^ P.parts.card ≤ card α / P.parts.card,
  { rw [step_bound, ←nat.div_div_eq_div_mul],
    exact nat.div_mul_le_self _ _ },
  rw nat.add_sub_of_le this at hucard,
  rw [(hP.card_parts_eq_average hu).resolve_left hucard, mul_add, mul_one, ←add_assoc, ←add_mul,
    nat.sub_add_cancel a_add_one_le_four_pow_parts_card, ←add_assoc, mul_comm,
    nat.add_sub_of_le this, card_univ],
end

lemma pow_mul_m_le_card_part (hP : P.is_equipartition) (hu : u ∈ P.parts) :
  (4 : ℝ) ^ P.parts.card * m ≤ u.card :=
begin
  norm_cast,
  rw [step_bound, ←nat.div_div_eq_div_mul],
  exact (nat.mul_div_le _ _).trans (hP.average_le_card_part hu),
end

variables (P ε) (l : ℕ)

/-- Auxiliary function for Szemerédi's regularity lemma. The size of the partition by which we start
blowing. -/
noncomputable def initial_bound : ℕ := max 7 $ max l $ ⌊log (100 / ε^5) / log 4⌋₊ + 1

lemma le_initial_bound : l ≤ initial_bound ε l := (le_max_left _ _).trans $ le_max_right _ _
lemma seven_le_initial_bound : 7 ≤ initial_bound ε l := le_max_left _ _
lemma initial_bound_pos : 0 < initial_bound ε l :=
nat.succ_pos'.trans_le $ seven_le_initial_bound _ _

lemma hundred_lt_pow_initial_bound_mul {ε : ℝ} (hε : 0 < ε) (l : ℕ) :
  100 < 4^initial_bound ε l * ε^5 :=
begin
  rw [←rpow_nat_cast 4, ←div_lt_iff (pow_pos hε 5), lt_rpow_iff_log_lt _ zero_lt_four,
    ←div_lt_iff, initial_bound, nat.cast_max, nat.cast_max],
  { push_cast, exact lt_max_of_lt_right (lt_max_of_lt_right $ nat.lt_floor_add_one _) },
  { exact log_pos (by norm_num) },
  { exact div_pos (by norm_num) (pow_pos hε 5) }
end

/-- An explicit bound on the size of the equipartition whose existence is given by Szemerédi's
regularity lemma. -/
noncomputable def bound : ℕ :=
(step_bound^[⌊4 / ε^5⌋₊] $ initial_bound ε l) * 16 ^ (step_bound^[⌊4 / ε^5⌋₊] $ initial_bound ε l)

lemma initial_bound_le_bound : initial_bound ε l ≤ bound ε l :=
(id_le_iterate_of_id_le le_step_bound _ _).trans $ nat.le_mul_of_pos_right $ pow_pos (by norm_num) _

lemma le_bound : l ≤ bound ε l := (le_initial_bound ε l).trans $ initial_bound_le_bound ε l
lemma bound_pos : 0 < bound ε l := (initial_bound_pos ε l).trans_le $ initial_bound_le_bound ε l

end szemeredi_regularity


/-
Copyright (c) 2020 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import group_theory.perm.basic
import data.fintype.perm
import group_theory.subgroup.finite
/-!
# Lemmas about subgroups within the permutations (self-equivalences) of a type `α`

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

This file provides extra lemmas about some `subgroup`s that exist within `equiv.perm α`.
`group_theory.subgroup` depends on `group_theory.perm.basic`, so these need to be in a separate
file.

It also provides decidable instances on membership in these subgroups, since
`monoid_hom.decidable_mem_range` cannot be inferred without the help of a lambda.
The presence of these instances induces a `fintype` instance on the `quotient_group.quotient` of
these subgroups.
-/

namespace equiv
namespace perm

universes u

instance sum_congr_hom.decidable_mem_range {α β : Type*}
  [decidable_eq α] [decidable_eq β] [fintype α] [fintype β] :
  decidable_pred (∈ (sum_congr_hom α β).range) :=
λ x, infer_instance

@[simp]
lemma sum_congr_hom.card_range {α β : Type*}
  [fintype (sum_congr_hom α β).range] [fintype (perm α × perm β)] :
  fintype.card (sum_congr_hom α β).range = fintype.card (perm α × perm β) :=
fintype.card_eq.mpr ⟨(of_injective (sum_congr_hom α β) sum_congr_hom_injective).symm⟩

instance sigma_congr_right_hom.decidable_mem_range {α : Type*} {β : α → Type*}
  [decidable_eq α] [∀ a, decidable_eq (β a)] [fintype α] [∀ a, fintype (β a)] :
  decidable_pred (∈ (sigma_congr_right_hom β).range) :=
λ x, infer_instance

@[simp]
lemma sigma_congr_right_hom.card_range {α : Type*} {β : α → Type*}
  [fintype (sigma_congr_right_hom β).range] [fintype (Π a, perm (β a))] :
  fintype.card (sigma_congr_right_hom β).range = fintype.card (Π a, perm (β a)) :=
fintype.card_eq.mpr ⟨(of_injective (sigma_congr_right_hom β) sigma_congr_right_hom_injective).symm⟩

instance subtype_congr_hom.decidable_mem_range {α : Type*} (p : α → Prop) [decidable_pred p]
  [fintype (perm {a // p a} × perm {a // ¬ p a})] [decidable_eq (perm α)] :
  decidable_pred (∈ (subtype_congr_hom p).range) :=
λ x, infer_instance

@[simp]
lemma subtype_congr_hom.card_range {α : Type*} (p : α → Prop) [decidable_pred p]
  [fintype (subtype_congr_hom p).range] [fintype (perm {a // p a} × perm {a // ¬ p a})] :
  fintype.card (subtype_congr_hom p).range = fintype.card (perm {a // p a} × perm {a // ¬ p a}) :=
fintype.card_eq.mpr ⟨(of_injective (subtype_congr_hom p) (subtype_congr_hom_injective p)).symm⟩

/-- **Cayley's theorem**: Every group G is isomorphic to a subgroup of the symmetric group acting on
`G`. Note that we generalize this to an arbitrary "faithful" group action by `G`. Setting `H = G`
recovers the usual statement of Cayley's theorem via `right_cancel_monoid.to_has_faithful_smul` -/
noncomputable def subgroup_of_mul_action (G H : Type*) [group G] [mul_action G H]
  [has_faithful_smul G H] : G ≃* (mul_action.to_perm_hom G H).range :=
mul_equiv.of_left_inverse' _ (classical.some_spec mul_action.to_perm_injective.has_left_inverse)

end perm
end equiv