/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import measure_theory.measure.measure_space

/-!
# Measure preserving maps

We say that `f : α → β` is a measure preserving map w.r.t. measures `μ : measure α` and
`ν : measure β` if `f` is measurable and `map f μ = ν`. In this file we define the predicate
`measure_theory.measure_preserving` and prove its basic properties.

We use the term "measure preserving" because in many applications `α = β` and `μ = ν`.

## References

Partially based on
[this](https://www.isa-afp.org/browser_info/current/AFP/Ergodic_Theory/Measure_Preserving_Transformations.html)
Isabelle formalization.

## Tags

measure preserving map, measure
-/

variables {α β γ δ : Type*} [measurable_space α] [measurable_space β] [measurable_space γ]
  [measurable_space δ]

namespace measure_theory

open measure function set

variables {μa : measure α} {μb : measure β} {μc : measure γ} {μd : measure δ}

/-- `f` is a measure preserving map w.r.t. measures `μa` and `μb` if `f` is measurable
and `map f μa = μb`. -/
@[protect_proj]
structure measure_preserving (f : α → β) (μa : measure α . volume_tac)
  (μb : measure β . volume_tac) : Prop :=
(measurable : measurable f)
(map_eq : map f μa = μb)

protected lemma _root_.measurable.measure_preserving {f : α → β}
  (h : measurable f) (μa : measure α) :
  measure_preserving f μa (map f μa) :=
⟨h, rfl⟩

namespace measure_preserving

protected lemma id (μ : measure α) : measure_preserving id μ μ :=
⟨measurable_id, map_id⟩

lemma symm {e : α ≃ᵐ β} {μa : measure α} {μb : measure β} (h : measure_preserving e μa μb) :
  measure_preserving e.symm μb μa :=
⟨e.symm.measurable,
  by rw [← h.map_eq, map_map e.symm.measurable e.measurable, e.symm_comp_self, map_id]⟩

lemma restrict_preimage {f : α → β} (hf : measure_preserving f μa μb) {s : set β}
  (hs : measurable_set s) : measure_preserving f (μa.restrict (f ⁻¹' s)) (μb.restrict s) :=
⟨hf.measurable, by rw [← hf.map_eq, restrict_map hf.measurable hs]⟩

lemma restrict_image_emb {f : α → β} (hf : measure_preserving f μa μb) (h₂ : measurable_embedding f)
  (s : set α) : measure_preserving f (μa.restrict s) (μb.restrict (f '' s)) :=
by simpa only [preimage_image_eq _ h₂.injective] using hf.restrict_preimage_emb h₂ (f '' s)

lemma ae_measurable_comp_iff {f : α → β} (hf : measure_preserving f μa μb)
  (h₂ : measurable_embedding f) {g : β → γ} :
  ae_measurable (g ∘ f) μa ↔ ae_measurable g μb :=
by rw [← hf.map_eq, h₂.ae_measurable_map_iff]

protected lemma quasi_measure_preserving {f : α → β} (hf : measure_preserving f μa μb) :
  quasi_measure_preserving f μa μb :=
⟨hf.1, hf.2.absolutely_continuous⟩

lemma comp {g : β → γ} {f : α → β} (hg : measure_preserving g μb μc)
  (hf : measure_preserving f μa μb) :
  measure_preserving (g ∘ f) μa μc :=
⟨hg.1.comp hf.1, by rw [← map_map hg.1 hf.1, hf.2, hg.2]⟩

protected lemma sigma_finite {f : α → β} (hf : measure_preserving f μa μb) [sigma_finite μb] :
  sigma_finite μa :=
sigma_finite.of_map μa hf.1 (by rwa hf.map_eq)

lemma measure_preimage {f : α → β} (hf : measure_preserving f μa μb)
  {s : set β} (hs : measurable_set s) :
  μa (f ⁻¹' s) = μb s :=
by rw [← hf.map_eq, map_apply hf.1 hs]

lemma measure_preimage_emb {f : α → β} (hf : measure_preserving f μa μb)
  (hfe : measurable_embedding f) (s : set β) :
  μa (f ⁻¹' s) = μb s :=
by rw [← hf.map_eq, hfe.map_apply]

protected lemma iterate {f : α → α} (hf : measure_preserving f μa μa) :
  ∀ n, measure_preserving (f^[n]) μa μa
| 0 := measure_preserving.id μa
| (n + 1) := (iterate n).comp hf

variables {μ : measure α} {f : α → α} {s : set α}

/-- If `μ univ < n * μ s` and `f` is a map preserving measure `μ`,
then for some `x ∈ s` and `0 < m < n`, `f^[m] x ∈ s`. -/
lemma exists_mem_image_mem_of_volume_lt_mul_volume (hf : measure_preserving f μ μ)
  (hs : measurable_set s) {n : ℕ} (hvol : μ (univ : set α) < n * μ s) :
  ∃ (x ∈ s) (m ∈ Ioo 0 n), f^[m] x ∈ s :=
begin
  have A : ∀ m, measurable_set (f^[m] ⁻¹' s) := λ m, (hf.iterate m).measurable hs,
  have B : ∀ m, μ (f^[m] ⁻¹' s) = μ s, from λ m, (hf.iterate m).measure_preimage hs,
  have : μ (univ : set α) < (finset.range n).sum (λ m, μ (f^[m] ⁻¹' s)),
    by simpa only [B, nsmul_eq_mul, finset.sum_const, finset.card_range],
  rcases exists_nonempty_inter_of_measure_univ_lt_sum_measure μ (λ m hm, A m) this
    with ⟨i, hi, j, hj, hij, x, hxi, hxj⟩,
  -- without `tactic.skip` Lean closes the extra goal but it takes a long time; not sure why
  wlog hlt : i < j := hij.lt_or_lt using [i j, j i] tactic.skip,
  { simp only [set.mem_preimage, finset.mem_range] at hi hj hxi hxj,
    refine ⟨f^[i] x, hxi, j - i, ⟨tsub_pos_of_lt hlt, lt_of_le_of_lt (j.sub_le i) hj⟩, _⟩,
    rwa [← iterate_add_apply, tsub_add_cancel_of_le hlt.le] },
  { exact λ hi hj hij hxi hxj, this hj hi hij.symm hxj hxi }
end

/-- A self-map preserving a finite measure is conservative: if `μ s ≠ 0`, then at least one point
`x ∈ s` comes back to `s` under iterations of `f`. Actually, a.e. point of `s` comes back to `s`
infinitely many times, see `measure_theory.measure_preserving.conservative` and theorems about
`measure_theory.conservative`. -/
lemma exists_mem_image_mem [is_finite_measure μ] (hf : measure_preserving f μ μ)
  (hs : measurable_set s) (hs' : μ s ≠ 0) :
  ∃ (x ∈ s) (m ≠ 0), f^[m] x ∈ s :=
begin
  rcases ennreal.exists_nat_mul_gt hs' (measure_ne_top μ (univ : set α)) with ⟨N, hN⟩,
  rcases hf.exists_mem_image_mem_of_volume_lt_mul_volume hs hN with ⟨x, hx, m, hm, hmx⟩,
  exact ⟨x, hx, m, hm.1.ne', hmx⟩
end

end measure_preserving

end measure_theory


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import analysis.box_integral.box.basic
import analysis.specific_limits.basic

/-!
# Induction on subboxes

In this file we prove the following induction principle for `box_integral.box`, see
`box_integral.box.subbox_induction_on`. Let `p` be a predicate on `box_integral.box ι`, let `I` be a
box. Suppose that the following two properties hold true.

* Consider a smaller box `J ≤ I`. The hyperplanes passing through the center of `J` split it into
  `2 ^ n` boxes. If `p` holds true on each of these boxes, then it is true on `J`.
* For each `z` in the closed box `I.Icc` there exists a neighborhood `U` of `z` within `I.Icc` such
  that for every box `J ≤ I` such that `z ∈ J.Icc ⊆ U`, if `J` is homothetic to `I` with a
  coefficient of the form `1 / 2 ^ m`, then `p` is true on `J`.

Then `p I` is true.

## Tags

rectangular box, induction
-/

open set finset function filter metric
open_locale classical topology filter ennreal
noncomputable theory

namespace box_integral

namespace box

variables {ι : Type*} {I J : box ι}

/-- For a box `I`, the hyperplanes passing through its center split `I` into `2 ^ card ι` boxes.
`box_integral.box.split_center_box I s` is one of these boxes. See also
`box_integral.partition.split_center` for the corresponding `box_integral.partition`. -/
def split_center_box (I : box ι) (s : set ι) : box ι :=
{ lower := s.piecewise (λ i, (I.lower i + I.upper i) / 2) I.lower,
  upper := s.piecewise I.upper (λ i, (I.lower i + I.upper i) / 2),
  lower_lt_upper := λ i, by { dunfold set.piecewise, split_ifs;
    simp only [left_lt_add_div_two, add_div_two_lt_right, I.lower_lt_upper] } }

lemma mem_split_center_box {s : set ι} {y : ι → ℝ} :
  y ∈ I.split_center_box s ↔ y ∈ I ∧ ∀ i, (I.lower i + I.upper i) / 2 < y i ↔ i ∈ s :=
begin
  simp only [split_center_box, mem_def, ← forall_and_distrib],
  refine forall_congr (λ i, _),
  dunfold set.piecewise,
  split_ifs with hs; simp only [hs, iff_true, iff_false, not_lt],
  exacts [⟨λ H, ⟨⟨(left_lt_add_div_two.2 (I.lower_lt_upper i)).trans H.1, H.2⟩, H.1⟩,
    λ H, ⟨H.2, H.1.2⟩⟩,
    ⟨λ H, ⟨⟨H.1, H.2.trans (add_div_two_lt_right.2 (I.lower_lt_upper i)).le⟩, H.2⟩,
      λ H, ⟨H.1.1, H.2⟩⟩]
end

lemma split_center_box_le (I : box ι) (s : set ι) : I.split_center_box s ≤ I :=
λ x hx, (mem_split_center_box.1 hx).1

lemma disjoint_split_center_box (I : box ι) {s t : set ι} (h : s ≠ t) :
  disjoint (I.split_center_box s : set (ι → ℝ)) (I.split_center_box t) :=
begin
  rw disjoint_iff_inf_le,
  rintro y ⟨hs, ht⟩, apply h,
  ext i,
  rw [mem_coe, mem_split_center_box] at hs ht,
  rw [← hs.2, ← ht.2]
end

lemma injective_split_center_box (I : box ι) : injective I.split_center_box :=
λ s t H, by_contra $ λ Hne, (I.disjoint_split_center_box Hne).ne (nonempty_coe _).ne_empty (H ▸ rfl)

@[simp] lemma exists_mem_split_center_box {I : box ι} {x : ι → ℝ} :
  (∃ s, x ∈ I.split_center_box s) ↔ x ∈ I :=
⟨λ ⟨s, hs⟩, I.split_center_box_le s hs,
  λ hx, ⟨{i | (I.lower i + I.upper i) / 2 < x i}, mem_split_center_box.2 ⟨hx, λ i, iff.rfl⟩⟩⟩

/-- `box_integral.box.split_center_box` bundled as a `function.embedding`. -/
@[simps] def split_center_box_emb (I : box ι) : set ι ↪ box ι :=
⟨split_center_box I, injective_split_center_box I⟩

@[simp]

@[simp] lemma upper_sub_lower_split_center_box (I : box ι) (s : set ι) (i : ι) :
  (I.split_center_box s).upper i - (I.split_center_box s).lower i = (I.upper i - I.lower i) / 2 :=
by by_cases hs : i ∈ s; field_simp [split_center_box, hs, mul_two, two_mul]

/-- Let `p` be a predicate on `box ι`, let `I` be a box. Suppose that the following two properties
hold true.

* `H_ind` : Consider a smaller box `J ≤ I`. The hyperplanes passing through the center of `J` split
  it into `2 ^ n` boxes. If `p` holds true on each of these boxes, then it true on `J`.

* `H_nhds` : For each `z` in the closed box `I.Icc` there exists a neighborhood `U` of `z` within
  `I.Icc` such that for every box `J ≤ I` such that `z ∈ J.Icc ⊆ U`, if `J` is homothetic to `I`
  with a coefficient of the form `1 / 2 ^ m`, then `p` is true on `J`.

Then `p I` is true. See also `box_integral.box.subbox_induction_on` for a version using
`box_integral.prepartition.split_center` instead of `box_integral.box.split_center_box`.

The proof still works if we assume `H_ind` only for subboxes `J ≤ I` that are homothetic to `I` with
a coefficient of the form `2⁻ᵐ` but we do not need this generalization yet. -/
@[elab_as_eliminator]
lemma subbox_induction_on' {p : box ι → Prop} (I : box ι)
  (H_ind : ∀ J ≤ I, (∀ s, p (split_center_box J s)) → p J)
  (H_nhds : ∀ z ∈ I.Icc, ∃ (U ∈ 𝓝[I.Icc] z), ∀ (J ≤ I) (m : ℕ), z ∈ J.Icc → J.Icc ⊆ U →
    (∀ i, J.upper i - J.lower i = (I.upper i - I.lower i) / 2 ^ m) → p J) :
  p I :=
begin
  by_contra hpI,
  -- First we use `H_ind` to construct a decreasing sequence of boxes such that `∀ m, ¬p (J m)`.
  replace H_ind := λ J hJ, not_imp_not.2 (H_ind J hJ),
  simp only [exists_imp_distrib, not_forall] at H_ind,
  choose! s hs using H_ind,
  set J : ℕ → box ι := λ m, (λ J, split_center_box J (s J))^[m] I,
  have J_succ : ∀ m, J (m + 1) = split_center_box (J m) (s $ J m) := λ m, iterate_succ_apply' _ _ _,
  -- Now we prove some properties of `J`
  have hJmono : antitone J,
    from antitone_nat_of_succ_le (λ n, by simpa [J_succ] using split_center_box_le _ _),
  have hJle : ∀ m, J m ≤ I, from λ m, hJmono (zero_le m),
  have hJp : ∀ m, ¬p (J m),
    from λ m, nat.rec_on m hpI (λ m, by simpa only [J_succ] using hs (J m) (hJle m)),
  have hJsub : ∀ m i, (J m).upper i - (J m).lower i = (I.upper i - I.lower i) / 2 ^ m,
  { intros m i, induction m with m ihm, { simp [J] },
    simp only [pow_succ', J_succ, upper_sub_lower_split_center_box, ihm, div_div] },
  have h0 : J 0 = I, from rfl,
  -- Now we clear unneeded assumptions
  clear_value J, clear hpI hs J_succ s,
  -- Let `z` be the unique common point of all `(J m).Icc`. Then `H_nhds` proves `p (J m)` for
  -- sufficiently large `m`. This contradicts `hJp`.
  set z : ι → ℝ := ⨆ m, (J m).lower,
  have hzJ : ∀ m, z ∈ (J m).Icc,
    from mem_Inter.1 (csupr_mem_Inter_Icc_of_antitone_Icc
      ((@box.Icc ι).monotone.comp_antitone hJmono) (λ m, (J m).lower_le_upper)),
  have hJl_mem : ∀ m, (J m).lower ∈ I.Icc, from λ m, le_iff_Icc.1 (hJle m) (J m).lower_mem_Icc,
  have hJu_mem : ∀ m, (J m).upper ∈ I.Icc, from λ m, le_iff_Icc.1 (hJle m) (J m).upper_mem_Icc,
  have hJlz : tendsto (λ m, (J m).lower) at_top (𝓝 z),
    from tendsto_at_top_csupr (antitone_lower.comp hJmono)
      ⟨I.upper, λ x ⟨m, hm⟩, hm ▸ (hJl_mem m).2⟩,
  have hJuz : tendsto (λ m, (J m).upper) at_top (𝓝 z),
  { suffices : tendsto (λ m, (J m).upper - (J m).lower) at_top (𝓝 0), by simpa using hJlz.add this,
    refine tendsto_pi_nhds.2 (λ i, _),
    simpa [hJsub] using tendsto_const_nhds.div_at_top
      (tendsto_pow_at_top_at_top_of_one_lt one_lt_two) },
  replace hJlz : tendsto (λ m, (J m).lower) at_top (𝓝[Icc I.lower I.upper] z),
    from tendsto_nhds_within_of_tendsto_nhds_of_eventually_within _ hJlz
      (eventually_of_forall hJl_mem),
  replace hJuz : tendsto (λ m, (J m).upper) at_top (𝓝[Icc I.lower I.upper] z),
    from tendsto_nhds_within_of_tendsto_nhds_of_eventually_within _ hJuz
      (eventually_of_forall hJu_mem),
  rcases H_nhds z (h0 ▸ hzJ 0) with ⟨U, hUz, hU⟩,
  rcases (tendsto_lift'.1 (hJlz.Icc hJuz) U hUz).exists with ⟨m, hUm⟩,
  exact hJp m (hU (J m) (hJle m) m (hzJ m) hUm (hJsub m))
end

end box

end box_integral


import Mathlib.Init.Data.Int.Basic
import Mathlib.Algebra.GroupWithZero.Defs
import Mathlib.Algebra.Group.Basic
import Mathlib.Tactic.Spread
import Mathlib.Util.WhatsNew

/-
# Semirings and rings
-/

/-- A typeclass stating that multiplication is left and right distributive
over addition. -/
class Distrib (R : Type u) extends Mul R, Add R where
  left_distrib : ∀ a b c : R, a * (b + c) = (a * b) + (a * c)
  right_distrib : ∀ a b c : R, (a + b) * c = (a * c) + (b * c)

export Distrib (left_distrib right_distrib)

section
variable {R} [Distrib R]
theorem mul_add (a b c : R) : a * (b + c) = a * b + a * c := Distrib.left_distrib a b c
theorem add_mul (a b c : R) : (a + b) * c = a * c + b * c := Distrib.right_distrib a b c
end

/-- A not-necessarily-unital, not-necessarily-associative semiring. -/
class NonUnitalNonAssocSemiring (R : Type u) extends
  AddCommMonoid R, Distrib R, MulZeroClass R, AddMonoidWithOne R

/-- An associative but not-necessarily unital semiring. -/
class NonUnitalSemiring (α : Type u) extends NonUnitalNonAssocSemiring α, SemigroupWithZero α

/-- A unital but not-necessarily-associative semiring. -/
class NonAssocSemiring (α : Type u) extends NonUnitalNonAssocSemiring α, MulZeroOneClass α

class Semiring (R : Type u) extends NonUnitalSemiring R, NonAssocSemiring R, MonoidWithZero R

section Semiring

@[simp]
lemma Nat.cast_mul [Semiring R] {m n : ℕ} : (m * n).cast = (m.cast * n.cast : R) := by
  induction n generalizing m <;> simp_all [mul_succ, mul_add]

@[simp]
lemma Nat.cast_pow [Semiring R] {m n : ℕ} : (m ^ n).cast = (m.cast ^ n : R) := by
  induction n generalizing m <;> simp_all [Nat.pow_succ', _root_.pow_succ', pow_zero]

end Semiring

class CommSemiring (R : Type u) extends Semiring R, CommMonoid R where
  -- TODO: doesn't work
  right_distrib a b c := (by rw [mul_comm, mul_add, mul_comm c, mul_comm c])

class Ring (R : Type u) extends Semiring R, AddCommGroup R, AddGroupWithOne R

theorem neg_mul_eq_neg_mul {R} [Ring R] (a b : R) : -(a * b) = (-a) * b :=
  Eq.symm <| eq_of_sub_eq_zero' <| by
    rw [sub_eq_add_neg, neg_neg (a * b) /- TODO: why is arg necessary? -/]
    rw [← add_mul, neg_add_self a /- TODO: why is arg necessary? -/, zero_mul]

class CommRing (R : Type u) extends Ring R, CommSemiring R

/- Instances -/

namespace Nat

instance : CommSemiring ℕ where
  mul_comm := Nat.mul_comm
  left_distrib := Nat.left_distrib
  right_distrib := Nat.right_distrib
  mul_one := Nat.mul_one
  one_mul := Nat.one_mul
  npow (n x) := x ^ n
  npow_zero' := Nat.pow_zero
  npow_succ' n x := by simp [Nat.pow_succ, Nat.mul_comm]
  mul_assoc := Nat.mul_assoc
  add_comm := Nat.add_comm
  add_assoc := Nat.add_assoc
  add_zero := Nat.add_zero
  zero_add := Nat.zero_add
  nsmul := (·*·)
  nsmul_zero' := Nat.zero_mul
  nsmul_succ' n x := by simp [Nat.add_comm, (Nat.succ_mul n x)]
  zero_mul := Nat.zero_mul
  mul_zero := Nat.mul_zero
  natCast := (·)
  natCast_zero := rfl
  natCast_succ _ := rfl

@[simp, norm_cast] lemma cast_id : Nat.cast n = n := rfl

end Nat

namespace Int

instance : CommRing ℤ where
  zero_mul := Int.zero_mul
  mul_zero := Int.mul_zero
  mul_comm := Int.mul_comm
  left_distrib := Int.distrib_left
  right_distrib := Int.distrib_right
  mul_one := Int.mul_one
  one_mul := Int.one_mul
  npow (n x) := x ^ n
  npow_zero' n := rfl
  npow_succ' n x := by rw [Int.mul_comm]; rfl
  mul_assoc := Int.mul_assoc
  add_comm := Int.add_comm
  add_assoc := Int.add_assoc
  add_zero := Int.add_zero
  zero_add := Int.zero_add
  add_left_neg := Int.add_left_neg
  nsmul := (·*·)
  nsmul_zero' := Int.zero_mul
  nsmul_succ' n x := by
    show ofNat (Nat.succ n) * x = x + ofNat n * x
    rw [Int.ofNat_succ, Int.distrib_right, Int.add_comm, Int.one_mul]
  sub_eq_add_neg a b := Int.sub_eq_add_neg
  gsmul := HMul.hMul
  gsmul_zero' := Int.zero_mul
  gsmul_succ' n x := by rw [Int.ofNat_succ, Int.distrib_right, Int.add_comm, Int.one_mul]
  gsmul_neg' n x := by
    cases x with
    | ofNat m =>
      rw [Int.negSucc_ofNat_ofNat, Int.ofNat_mul_ofNat]
      exact rfl
    | negSucc m =>
      rw [Int.mul_negSucc_ofNat_negSucc_ofNat, Int.ofNat_mul_negSucc_ofNat]
      exact rfl
  natCast := (·)
  natCast_zero := rfl
  natCast_succ _ := rfl
  intCast := (·)
  intCast_ofNat _ := rfl
  intCast_negSucc _ := rfl

@[simp, norm_cast] lemma cast_id : Int.cast n = n := rfl

@[simp] lemma ofNat_eq_cast : Int.ofNat n = n := rfl

@[simp, norm_cast]
lemma cast_Nat_cast [AddGroupWithOne R] : (Int.cast (Nat.cast n) : R) = Nat.cast n :=
  Int.cast_ofNat

@[simp, norm_cast]
lemma cast_eq_cast_iff_Nat (m n : ℕ) : (m : ℤ) = (n : ℤ) ↔ m = n :=
  ofNat_eq_ofNat_iff _ _

@[simp, norm_cast]
lemma natAbs_cast (n : ℕ) : natAbs ↑n = n := rfl

@[norm_cast]
protected lemma coe_nat_sub {n m : ℕ} : n ≤ m → (↑(m - n) : ℤ) = ↑m - ↑n := ofNat_sub

end Int


import group_theory.subgroup
import group_theory.finiteness
import group_theory.quotient_group
import algebra.group.hom
import tactic
import init.function

variables (G H: Type*)[group G][group H](N : subgroup G)[subgroup.normal N](f : monoid_hom G H)(S : set G)
variables (A : Type*)[add_comm_group A](B : add_subgroup A)

@[to_additive add_fg_surj_image_fg]
theorem fg_surj_image_fg: (function.surjective f)
   → (group.fg G) → (group.fg H):= begin
  intros hsurj hfg,
  rw group.fg_iff at *,
  rcases hfg with ⟨S, ⟨hSclosure, hSfinite⟩⟩,
  use f '' S,
  split,
  { rw ← monoid_hom.map_closure,
    rw hSclosure,
    rw ← monoid_hom.range_eq_map,
    rw monoid_hom.range_top_iff_surjective,
    exact hsurj },
  { apply set.finite.image,
    exact hSfinite }
end

@[to_additive add_quotient_surj]
theorem quotient_surj:
function.surjective (quotient_group.mk' N) :=
quotient.surjective_quotient_mk'

@[to_additive add_fg_quotient_of_fg]
theorem fg_quotient_of_fg: (group.fg G)
   → (group.fg (quotient_group.quotient N)) := begin
  apply fg_surj_image_fg G (quotient_group.quotient N) (quotient_group.mk' N),
  apply quotient_surj,
end


variables p q : Prop

example (h : p ∧ q) : p := and.elim_left h
example (h : p ∧ q) : q := and.elim_right h


variable U : Type
variables R : U → Prop

example (P : (forall x, R x)) : not(exists x, not(R x)):=

assume H1 : (exists x, not(R x)),
obtain (x : U) (H2 : not(R x)), from H1,
have H3 : (R x), from P x,
show false, from H2 H3.


import tactic
import lovelib

--Define a game
/-! A game is defines as <N, Aᵢ, ≿ᵢ> (Osborne, 1994) where:
N is the set of players
Aᵢ is the set of action for each player i∈N
≿ᵢ is the preference relation for each player i∈N

For this project we'll consider the prisoner's dilemma where the bigraph of utilities looks like

    c         d
  c (3, 3)    (0, 5)
  d (5, 0)    (1, 1)

N will be {A, B}
Aᵢ will be {c, d} ∀i ∈ N
We will define a utility function u: A₋ᵢ× Aᵢ → ℕ (should be reals, but this is all that's needed),
and our preference relation will be higher utilities are better

-/

-- Define the set of players
inductive Player
  | A    : Player
  | B    : Player

-- Define the set of actions
inductive Action
  | c    : Action
  | d    : Action

-- Define the utility function as a function of player (you), opponent's action, and your action
def pris_dil : Player → Action → Action → ℕ
| Player.A   Action.c   Action.c   := 3
| Player.A   Action.c   Action.d   := 5
| Player.A   Action.d   Action.c   := 0
| Player.A   Action.d   Action.d   := 1
| Player.B   Action.c   Action.c   := 3
| Player.B   Action.c   Action.d   := 5
| Player.B   Action.d   Action.c   := 0
| Player.B   Action.d   Action.d   := 1

-- Test it
#eval pris_dil Player.A Action.c Action.c
#eval pris_dil Player.A Action.c Action.d

-- Show that it is bounded
lemma pris_dil_bounded : ∃ u : ℕ,  ∀ b c : Action, ∀a : Player, pris_dil a b c ≤ u :=
begin
  apply exists.intro 5,
  intros a b c,
  induction' a,
  induction' b,
  induction' c,
  rw pris_dil,
  linarith,
  rw pris_dil,
  linarith,
  induction' c,
  rw pris_dil,
  rw pris_dil,
  induction' c,
  induction' b,
  rw pris_dil,
  linarith,
  rw pris_dil,
  linarith,
  induction' b,
  rw pris_dil,
  linarith,
  rw pris_dil,
  linarith,
end

-- Show that for a given player and opponent action, there's a best response
lemma best_response_exists  (f : Player → Action → Action → ℕ)  (a : Player)(b : Action):
∃ o : Action, ∀ c : Action,
  pris_dil a b o ≥ pris_dil a b c  :=
begin
  apply exists.intro Action.d,
  intro action,
  induction a,
  induction b,
  induction action,
  rw pris_dil,
  rw pris_dil,
  linarith,
  rw pris_dil,
  linarith,
  induction action,
  rw pris_dil,
  rw pris_dil,
  linarith,
  rw pris_dil,
  linarith,
  induction b,
  induction action,
  rw pris_dil,
  rw pris_dil,
  linarith,
  rw pris_dil,
  linarith,
  induction action,
  rw pris_dil,
  rw pris_dil,
  linarith,
  rw pris_dil,
  linarith,
end

-- Find the function that returns a best action
noncomputable def best_action (f : Player → Action → Action → ℕ)(a : Player)(b : Action) :=
classical.some (best_response_exists f a b)

-- Sanity check the type
#check best_action

/-!
Fixed point theorem.
1) If the range of a set-valued function is compact, convex (it's not convex, but this is a
special case. Mixed stratgeis would be convex), and nonempty
2) A function, f, is nonempty (this is true because we can use axiom of choice)
3) The funciton is upper hemicontinuous (this is true because utility function is continuous and compact)
4) The function is convex (this is true since if two strategies are equally good, the convec combination
is also equally good)
Then it has a fixed point
-/
lemma kakutani_fixed_point (f : (Player → Action → Action → ℕ) → Player → Action → Action)
(u : Player → Action → Action → ℕ ) (a b : Player)(c : Action):
-- f bound (pris_dil_bounded) → f (x) is nonempty (best_response_exists)
-- → range f convex (not true for this case, but will be for the mixed strategy case)
  (∃ v : ℕ, ∀ x y : Action, ∀ p : Player,  u p x y ≤ v) →
  (∃ m : Action, ∀ o : Action, u a c m ≥ u a c o) →
  (∃ l m : Action, f u a m = l  ∧ f u b l = m) :=
begin
  intro h1,
  intro h2,
  apply exists.intro c,
  sorry,
end

--Proof that NE exists
lemma NE_exists (a b : Player) (x y : Action):
∃ l m : Action, best_action pris_dil Player.A m = l ∧ best_action pris_dil Player.B l = m :=
begin
  apply kakutani_fixed_point,
  apply pris_dil_bounded,
  apply best_response_exists,
  apply pris_dil,
  exact x,
end


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.order
import Mathlib.order.lattice
import Mathlib.PostPort

universes u v

namespace Mathlib

/-!
# `max` and `min`

This file proves basic properties about maxima and minima on a `linear_order`.

## Tags

min, max
-/

-- translate from lattices to linear orders (sup → max, inf → min)

@[simp] theorem le_min_iff {α : Type u} [linear_order α] {a : α} {b : α} {c : α} :
    c ≤ min a b ↔ c ≤ a ∧ c ≤ b :=
  le_inf_iff

@[simp] theorem max_le_iff {α : Type u} [linear_order α] {a : α} {b : α} {c : α} :
    max a b ≤ c ↔ a ≤ c ∧ b ≤ c :=
  sup_le_iff

theorem max_le_max {α : Type u} [linear_order α] {a : α} {b : α} {c : α} {d : α} :
    a ≤ c → b ≤ d → max a b ≤ max c d :=
  sup_le_sup

theorem min_le_min {α : Type u} [linear_order α] {a : α} {b : α} {c : α} {d : α} :
    a ≤ c → b ≤ d → min a b ≤ min c d :=
  inf_le_inf

theorem le_max_left_of_le {α : Type u} [linear_order α] {a : α} {b : α} {c : α} :
    a ≤ b → a ≤ max b c :=
  le_sup_left_of_le

theorem le_max_right_of_le {α : Type u} [linear_order α] {a : α} {b : α} {c : α} :
    a ≤ c → a ≤ max b c :=
  le_sup_right_of_le

theorem min_le_left_of_le {α : Type u} [linear_order α] {a : α} {b : α} {c : α} :
    a ≤ c → min a b ≤ c :=
  inf_le_left_of_le

theorem min_le_right_of_le {α : Type u} [linear_order α] {a : α} {b : α} {c : α} :
    b ≤ c → min a b ≤ c :=
  inf_le_right_of_le

theorem max_min_distrib_left {α : Type u} [linear_order α] {a : α} {b : α} {c : α} :
    max a (min b c) = min (max a b) (max a c) :=
  sup_inf_left

theorem max_min_distrib_right {α : Type u} [linear_order α] {a : α} {b : α} {c : α} :
    max (min a b) c = min (max a c) (max b c) :=
  sup_inf_right

theorem min_max_distrib_left {α : Type u} [linear_order α] {a : α} {b : α} {c : α} :
    min a (max b c) = max (min a b) (min a c) :=
  inf_sup_left

theorem min_max_distrib_right {α : Type u} [linear_order α] {a : α} {b : α} {c : α} :
    min (max a b) c = max (min a c) (min b c) :=
  inf_sup_right

theorem min_le_max {α : Type u} [linear_order α] {a : α} {b : α} : min a b ≤ max a b :=
  le_trans (min_le_left a b) (le_max_left a b)

@[simp] theorem min_eq_left_iff {α : Type u} [linear_order α] {a : α} {b : α} :
    min a b = a ↔ a ≤ b :=
  inf_eq_left

@[simp] theorem min_eq_right_iff {α : Type u} [linear_order α] {a : α} {b : α} :
    min a b = b ↔ b ≤ a :=
  inf_eq_right

@[simp] theorem max_eq_left_iff {α : Type u} [linear_order α] {a : α} {b : α} :
    max a b = a ↔ b ≤ a :=
  sup_eq_left

@[simp] theorem max_eq_right_iff {α : Type u} [linear_order α] {a : α} {b : α} :
    max a b = b ↔ a ≤ b :=
  sup_eq_right

/-- An instance asserting that `max a a = a` -/
protected instance max_idem {α : Type u} [linear_order α] : is_idempotent α max :=
  Mathlib.sup_is_idempotent

/-- An instance asserting that `min a a = a` -/
protected instance min_idem {α : Type u} [linear_order α] : is_idempotent α min :=
  Mathlib.inf_is_idempotent

@[simp] theorem max_lt_iff {α : Type u} [linear_order α] {a : α} {b : α} {c : α} :
    max a b < c ↔ a < c ∧ b < c :=
  sup_lt_iff

@[simp] theorem lt_min_iff {α : Type u} [linear_order α] {a : α} {b : α} {c : α} :
    a < min b c ↔ a < b ∧ a < c :=
  lt_inf_iff

@[simp] theorem lt_max_iff {α : Type u} [linear_order α] {a : α} {b : α} {c : α} :
    a < max b c ↔ a < b ∨ a < c :=
  lt_sup_iff

@[simp] theorem min_lt_iff {α : Type u} [linear_order α] {a : α} {b : α} {c : α} :
    min a b < c ↔ a < c ∨ b < c :=
  lt_max_iff

@[simp] theorem min_le_iff {α : Type u} [linear_order α] {a : α} {b : α} {c : α} :
    min a b ≤ c ↔ a ≤ c ∨ b ≤ c :=
  inf_le_iff

@[simp] theorem le_max_iff {α : Type u} [linear_order α] {a : α} {b : α} {c : α} :
    a ≤ max b c ↔ a ≤ b ∨ a ≤ c :=
  min_le_iff

theorem max_lt_max {α : Type u} [linear_order α] {a : α} {b : α} {c : α} {d : α} (h₁ : a < c)
    (h₂ : b < d) : max a b < max c d :=
  sorry

theorem min_lt_min {α : Type u} [linear_order α] {a : α} {b : α} {c : α} {d : α} (h₁ : a < c)
    (h₂ : b < d) : min a b < min c d :=
  max_lt_max h₁ h₂

theorem min_right_comm {α : Type u} [linear_order α] (a : α) (b : α) (c : α) :
    min (min a b) c = min (min a c) b :=
  right_comm min min_comm min_assoc a b c

theorem max.left_comm {α : Type u} [linear_order α] (a : α) (b : α) (c : α) :
    max a (max b c) = max b (max a c) :=
  left_comm max max_comm max_assoc a b c

theorem max.right_comm {α : Type u} [linear_order α] (a : α) (b : α) (c : α) :
    max (max a b) c = max (max a c) b :=
  right_comm max max_comm max_assoc a b c

theorem monotone.map_max {α : Type u} {β : Type v} [linear_order α] [linear_order β] {f : α → β}
    {a : α} {b : α} (hf : monotone f) : f (max a b) = max (f a) (f b) :=
  sorry

theorem monotone.map_min {α : Type u} {β : Type v} [linear_order α] [linear_order β] {f : α → β}
    {a : α} {b : α} (hf : monotone f) : f (min a b) = min (f a) (f b) :=
  monotone.map_max (monotone.order_dual hf)

theorem min_choice {α : Type u} [linear_order α] (a : α) (b : α) : min a b = a ∨ min a b = b :=
  sorry

theorem max_choice {α : Type u} [linear_order α] (a : α) (b : α) : max a b = a ∨ max a b = b :=
  min_choice a b

theorem le_of_max_le_left {α : Type u} [linear_order α] {a : α} {b : α} {c : α} (h : max a b ≤ c) :
    a ≤ c :=
  le_trans (le_max_left a b) h

theorem le_of_max_le_right {α : Type u} [linear_order α] {a : α} {b : α} {c : α} (h : max a b ≤ c) :
    b ≤ c :=
  le_trans (le_max_right a b) h

end Mathlib


namespace Hidden

open Nat

theorem zero_add (n : Nat) : 0 + n = n :=
  Nat.recOn (motive := fun x => 0 + x = x)
   n
   (show 0 + 0 = 0 from rfl)
   (fun (n : Nat) (ih : 0 + n = n) =>
    show 0 + succ n = succ n from
    calc
       0 + succ n = succ (0 + n) := rfl
                _ = succ n       := by rw [ih])

end Hidden


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

! This file was ported from Lean 3 source module order.directed
! leanprover-community/mathlib commit 18a5306c091183ac90884daa9373fa3b178e8607
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Set.Image
import Mathlib.Order.Lattice
import Mathlib.Order.Max

/-!
# Directed indexed families and sets

This file defines directed indexed families and directed sets. An indexed family/set is
directed iff each pair of elements has a shared upper bound.

## Main declarations

* `Directed r f`: Predicate stating that the indexed family `f` is `r`-directed.
* `DirectedOn r s`: Predicate stating that the set `s` is `r`-directed.
* `IsDirected α r`: Prop-valued mixin stating that `α` is `r`-directed. Follows the style of the
  unbundled relation classes such as `IsTotal`.
-/

open Function

universe u v w

variable {α : Type u} {β : Type v} {ι : Sort w} (r r' s : α → α → Prop)

/-- Local notation for a relation -/
local infixl:50 " ≼ " => r

/-- A family of elements of α is directed (with respect to a relation `≼` on α)
  if there is a member of the family `≼`-above any pair in the family.  -/
def Directed (f : ι → α) :=
  ∀ x y, ∃ z, f x ≼ f z ∧ f y ≼ f z
#align directed Directed

/-- A subset of α is directed if there is an element of the set `≼`-above any
  pair of elements in the set. -/
def DirectedOn (s : Set α) :=
  ∀ x ∈ s, ∀ y ∈ s, ∃ z ∈ s, x ≼ z ∧ y ≼ z
#align directed_on DirectedOn

variable {r r'}

theorem directedOn_iff_directed {s} : @DirectedOn α r s ↔ Directed r (Subtype.val : s → α) := by
  simp [Directed, DirectedOn] ; refine' ball_congr fun x _ => by simp [And.comm, and_assoc]
#align directed_on_iff_directed directedOn_iff_directed

alias directedOn_iff_directed ↔ DirectedOn.directed_val _
#align directed_on.directed_coe DirectedOn.directed_val

theorem directedOn_range {f : β → α} : Directed r f ↔ DirectedOn r (Set.range f) := by
  simp_rw [Directed, DirectedOn, Set.forall_range_iff, Set.exists_range_iff]
#align directed_on_range directedOn_range

theorem directedOn_image {s : Set β} {f : β → α} :
    DirectedOn r (f '' s) ↔ DirectedOn (f ⁻¹'o r) s := by
  simp only [DirectedOn, Set.mem_image, exists_exists_and_eq_and, forall_exists_index, and_imp,
    forall_apply_eq_imp_iff₂, Order.Preimage]
#align directed_on_image directedOn_image

theorem DirectedOn.mono' {s : Set α} (hs : DirectedOn r s)
    (h : ∀ ⦃a⦄, a ∈ s → ∀ ⦃b⦄, b ∈ s → r a b → r' a b) : DirectedOn r' s := fun _ hx _ hy =>
  let ⟨z, hz, hxz, hyz⟩ := hs _ hx _ hy
  ⟨z, hz, h hx hz hxz, h hy hz hyz⟩
#align directed_on.mono' DirectedOn.mono'

theorem DirectedOn.mono {s : Set α} (h : DirectedOn r s) (H : ∀ {a b}, r a b → r' a b) :
    DirectedOn r' s :=
  h.mono' fun _ _ _ _ => H
#align directed_on.mono DirectedOn.mono

theorem directed_comp {ι} {f : ι → β} {g : β → α} : Directed r (g ∘ f) ↔ Directed (g ⁻¹'o r) f :=
  Iff.rfl
#align directed_comp directed_comp

theorem Directed.mono {s : α → α → Prop} {ι} {f : ι → α} (H : ∀ a b, r a b → s a b)
    (h : Directed r f) : Directed s f := fun a b =>
  let ⟨c, h₁, h₂⟩ := h a b
  ⟨c, H _ _ h₁, H _ _ h₂⟩
#align directed.mono Directed.mono

-- Porting note: due to some interaction with the local notation, `r` became explicit here in lean3
theorem Directed.mono_comp (r : α → α → Prop) {ι} {rb : β → β → Prop} {g : α → β} {f : ι → α}
    (hg : ∀ ⦃x y⦄, r x y → rb (g x) (g y)) (hf : Directed r f) : Directed rb (g ∘ f) :=
  directed_comp.2 <| hf.mono hg
#align directed.mono_comp Directed.mono_comp

/-- A monotone function on a sup-semilattice is directed. -/
theorem directed_of_sup [SemilatticeSup α] {f : α → β} {r : β → β → Prop}
    (H : ∀ ⦃i j⦄, i ≤ j → r (f i) (f j)) : Directed r f := fun a b =>
  ⟨a ⊔ b, H le_sup_left, H le_sup_right⟩
#align directed_of_sup directed_of_sup

theorem Monotone.directed_le [SemilatticeSup α] [Preorder β] {f : α → β} :
    Monotone f → Directed (· ≤ ·) f :=
  directed_of_sup
#align monotone.directed_le Monotone.directed_le

theorem Antitone.directed_ge [SemilatticeSup α] [Preorder β] {f : α → β} (hf : Antitone f) :
    Directed (· ≥ ·) f :=
  directed_of_sup hf
#align antitone.directed_ge Antitone.directed_ge

/-- A set stable by supremum is `≤`-directed. -/
theorem directedOn_of_sup_mem [SemilatticeSup α] {S : Set α}
    (H : ∀ ⦃i j⦄, i ∈ S → j ∈ S → i ⊔ j ∈ S) : DirectedOn (· ≤ ·) S := fun a ha b hb =>
  ⟨a ⊔ b, H ha hb, le_sup_left, le_sup_right⟩
#align directed_on_of_sup_mem directedOn_of_sup_mem

theorem Directed.extend_bot [Preorder α] [OrderBot α] {e : ι → β} {f : ι → α}
    (hf : Directed (· ≤ ·) f) (he : Function.Injective e) :
    Directed (· ≤ ·) (Function.extend e f ⊥) := by
  intro a b
  rcases(em (∃ i, e i = a)).symm with (ha | ⟨i, rfl⟩)
  · use b
    simp [Function.extend_apply' _ _ _ ha]
  rcases(em (∃ i, e i = b)).symm with (hb | ⟨j, rfl⟩)
  · use e i
    simp [Function.extend_apply' _ _ _ hb]
  rcases hf i j with ⟨k, hi, hj⟩
  use e k
  simp only [he.extend_apply, *, true_and_iff]
#align directed.extend_bot Directed.extend_bot

/-- An antitone function on an inf-semilattice is directed. -/
theorem directed_of_inf [SemilatticeInf α] {r : β → β → Prop} {f : α → β}
    (hf : ∀ a₁ a₂, a₁ ≤ a₂ → r (f a₂) (f a₁)) : Directed r f := fun x y =>
  ⟨x ⊓ y, hf _ _ inf_le_left, hf _ _ inf_le_right⟩
#align directed_of_inf directed_of_inf

theorem Monotone.directed_ge [SemilatticeInf α] [Preorder β] {f : α → β} (hf : Monotone f) :
    Directed (· ≥ ·) f :=
  directed_of_inf hf
#align monotone.directed_ge Monotone.directed_ge

theorem Antitone.directed_le [SemilatticeInf α] [Preorder β] {f : α → β} (hf : Antitone f) :
    Directed (· ≤ ·) f :=
  directed_of_inf hf
#align antitone.directed_le Antitone.directed_le

/-- A set stable by infimum is `≥`-directed. -/
theorem directedOn_of_inf_mem [SemilatticeInf α] {S : Set α}
    (H : ∀ ⦃i j⦄, i ∈ S → j ∈ S → i ⊓ j ∈ S) : DirectedOn (· ≥ ·) S := fun a ha b hb =>
  ⟨a ⊓ b, H ha hb, inf_le_left, inf_le_right⟩
#align directed_on_of_inf_mem directedOn_of_inf_mem

/-- `IsDirected α r` states that for any elements `a`, `b` there exists an element `c` such that
`r a c` and `r b c`. -/
class IsDirected (α : Type _) (r : α → α → Prop) : Prop where
  /-- For every pair of elements `a` and `b` there is a `c` such that `r a c` and `r b c` -/
  directed (a b : α) : ∃ c, r a c ∧ r b c
#align is_directed IsDirected
#align is_directed.directed IsDirected.directed

theorem directed_of (r : α → α → Prop) [IsDirected α r] (a b : α) : ∃ c, r a c ∧ r b c :=
  IsDirected.directed _ _
#align directed_of directed_of

theorem directed_id [IsDirected α r] : Directed r id := by convert directed_of r
#align directed_id directed_id

theorem directed_id_iff : Directed r id ↔ IsDirected α r :=
  ⟨fun h => ⟨h⟩, @directed_id _ _⟩
#align directed_id_iff directed_id_iff

theorem directedOn_univ [IsDirected α r] : DirectedOn r Set.univ := fun a _ b _ =>
  let ⟨c, hc⟩ := directed_of r a b
  ⟨c, trivial, hc⟩
#align directed_on_univ directedOn_univ

theorem directedOn_univ_iff : DirectedOn r Set.univ ↔ IsDirected α r :=
  ⟨fun h =>
    ⟨fun a b =>
      let ⟨c, _, hc⟩ := h a trivial b trivial
      ⟨c, hc⟩⟩,
    @directedOn_univ _ _⟩
#align directed_on_univ_iff directedOn_univ_iff

-- see Note [lower instance priority]
instance (priority := 100) IsTotal.to_isDirected [IsTotal α r] : IsDirected α r :=
  ⟨fun a b => Or.casesOn (total_of r a b) (fun h => ⟨b, h, refl _⟩) fun h => ⟨a, refl _, h⟩⟩
#align is_total.to_is_directed IsTotal.to_isDirected

theorem isDirected_mono [IsDirected α r] (h : ∀ ⦃a b⦄, r a b → s a b) : IsDirected α s :=
  ⟨fun a b =>
    let ⟨c, ha, hb⟩ := IsDirected.directed a b
    ⟨c, h ha, h hb⟩⟩
#align is_directed_mono isDirected_mono

theorem exists_ge_ge [LE α] [IsDirected α (· ≤ ·)] (a b : α) : ∃ c, a ≤ c ∧ b ≤ c :=
  directed_of (· ≤ ·) a b
#align exists_ge_ge exists_ge_ge

theorem exists_le_le [LE α] [IsDirected α (· ≥ ·)] (a b : α) : ∃ c, c ≤ a ∧ c ≤ b :=
  directed_of (· ≥ ·) a b
#align exists_le_le exists_le_le

instance OrderDual.isDirected_ge [LE α] [IsDirected α (· ≤ ·)] : IsDirected αᵒᵈ (· ≥ ·) := by
  assumption
#align order_dual.is_directed_ge OrderDual.isDirected_ge

instance OrderDual.isDirected_le [LE α] [IsDirected α (· ≥ ·)] : IsDirected αᵒᵈ (· ≤ ·) := by
  assumption
#align order_dual.is_directed_le OrderDual.isDirected_le

section Preorder

variable [Preorder α] {a : α}

protected theorem IsMin.isBot [IsDirected α (· ≥ ·)] (h : IsMin a) : IsBot a := fun b =>
  let ⟨_, hca, hcb⟩ := exists_le_le a b
  (h hca).trans hcb
#align is_min.is_bot IsMin.isBot

protected theorem IsMax.isTop [IsDirected α (· ≤ ·)] (h : IsMax a) : IsTop a :=
  h.toDual.isBot
#align is_max.is_top IsMax.isTop

lemma DirectedOn.is_bot_of_is_min {s : Set α} (hd : DirectedOn (· ≥ ·) s)
    {m} (hm : m ∈ s) (hmin : ∀ a ∈ s, a ≤ m → m ≤ a) : ∀ a ∈ s, m ≤ a := fun a as =>
  let ⟨x, xs, xm, xa⟩ := hd m hm a as
  (hmin x xs xm).trans xa
#align directed_on.is_bot_of_is_min DirectedOn.is_bot_of_is_min

lemma DirectedOn.is_top_of_is_max {s : Set α} (hd : DirectedOn (· ≤ ·) s)
    {m} (hm : m ∈ s) (hmax : ∀ a ∈ s, m ≤ a → a ≤ m) : ∀ a ∈ s, a ≤ m :=
  @DirectedOn.is_bot_of_is_min αᵒᵈ _ s hd m hm hmax
#align directed_on.is_top_of_is_max DirectedOn.is_top_of_is_max

theorem isTop_or_exists_gt [IsDirected α (· ≤ ·)] (a : α) : IsTop a ∨ ∃ b, a < b :=
  (em (IsMax a)).imp IsMax.isTop not_isMax_iff.mp
#align is_top_or_exists_gt isTop_or_exists_gt

theorem isBot_or_exists_lt [IsDirected α (· ≥ ·)] (a : α) : IsBot a ∨ ∃ b, b < a :=
  @isTop_or_exists_gt αᵒᵈ _ _ a
#align is_bot_or_exists_lt isBot_or_exists_lt

theorem isBot_iff_isMin [IsDirected α (· ≥ ·)] : IsBot a ↔ IsMin a :=
  ⟨IsBot.isMin, IsMin.isBot⟩
#align is_bot_iff_is_min isBot_iff_isMin

theorem isTop_iff_isMax [IsDirected α (· ≤ ·)] : IsTop a ↔ IsMax a :=
  ⟨IsTop.isMax, IsMax.isTop⟩
#align is_top_iff_is_max isTop_iff_isMax

variable (β) [PartialOrder β]

theorem exists_lt_of_directed_ge [IsDirected β (· ≥ ·)] [Nontrivial β] : ∃ a b : β, a < b := by
  rcases exists_pair_ne β with ⟨a, b, hne⟩
  rcases isBot_or_exists_lt a with (ha | ⟨c, hc⟩)
  exacts[⟨a, b, (ha b).lt_of_ne hne⟩, ⟨_, _, hc⟩]
#align exists_lt_of_directed_ge exists_lt_of_directed_ge

theorem exists_lt_of_directed_le [IsDirected β (· ≤ ·)] [Nontrivial β] : ∃ a b : β, a < b :=
  let ⟨a, b, h⟩ := exists_lt_of_directed_ge βᵒᵈ
  ⟨b, a, h⟩
#align exists_lt_of_directed_le exists_lt_of_directed_le

end Preorder

-- see Note [lower instance priority]
instance (priority := 100) SemilatticeSup.to_isDirected_le [SemilatticeSup α] :
    IsDirected α (· ≤ ·) :=
  ⟨fun a b => ⟨a ⊔ b, le_sup_left, le_sup_right⟩⟩
#align semilattice_sup.to_is_directed_le SemilatticeSup.to_isDirected_le

-- see Note [lower instance priority]
instance (priority := 100) SemilatticeInf.to_isDirected_ge [SemilatticeInf α] :
    IsDirected α (· ≥ ·) :=
  ⟨fun a b => ⟨a ⊓ b, inf_le_left, inf_le_right⟩⟩
#align semilattice_inf.to_is_directed_ge SemilatticeInf.to_isDirected_ge

-- see Note [lower instance priority]
instance (priority := 100) OrderTop.to_isDirected_le [LE α] [OrderTop α] : IsDirected α (· ≤ ·) :=
  ⟨fun _ _ => ⟨⊤, le_top _, le_top _⟩⟩
#align order_top.to_is_directed_le OrderTop.to_isDirected_le

-- see Note [lower instance priority]
instance (priority := 100) OrderBot.to_isDirected_ge [LE α] [OrderBot α] : IsDirected α (· ≥ ·) :=
  ⟨fun _ _ => ⟨⊥, bot_le _, bot_le _⟩⟩
#align order_bot.to_is_directed_ge OrderBot.to_isDirected_ge


/-
Copyright (c) 2021 Kevin Buzzard. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kevin Buzzard, Ines Wright, Joachim Breitner
-/

import group_theory.general_commutator
import group_theory.quotient_group
import group_theory.solvable
import group_theory.p_group

/-!

# Nilpotent groups

An API for nilpotent groups, that is, groups for which the upper central series
reaches `⊤`.

## Main definitions

Recall that if `H K : subgroup G` then `⁅H, K⁆ : subgroup G` is the subgroup of `G` generated
by the commutators `hkh⁻¹k⁻¹`. Recall also Lean's conventions that `⊤` denotes the
subgroup `G` of `G`, and `⊥` denotes the trivial subgroup `{1}`.

* `upper_central_series G : ℕ → subgroup G` : the upper central series of a group `G`.
     This is an increasing sequence of normal subgroups `H n` of `G` with `H 0 = ⊥` and
     `H (n + 1) / H n` is the centre of `G / H n`.
* `lower_central_series G : ℕ → subgroup G` : the lower central series of a group `G`.
     This is a decreasing sequence of normal subgroups `H n` of `G` with `H 0 = ⊤` and
     `H (n + 1) = ⁅H n, G⁆`.
* `is_nilpotent` : A group G is nilpotent if its upper central series reaches `⊤`, or
    equivalently if its lower central series reaches `⊥`.
* `nilpotency_class` : the length of the upper central series of a nilpotent group.
* `is_ascending_central_series (H : ℕ → subgroup G) : Prop` and
* `is_descending_central_series (H : ℕ → subgroup G) : Prop` : Note that in the literature
    a "central series" for a group is usually defined to be a *finite* sequence of normal subgroups
    `H 0`, `H 1`, ..., starting at `⊤`, finishing at `⊥`, and with each `H n / H (n + 1)`
    central in `G / H (n + 1)`. In this formalisation it is convenient to have two weaker predicates
    on an infinite sequence of subgroups `H n` of `G`: we say a sequence is a *descending central
    series* if it starts at `G` and `⁅H n, ⊤⁆ ⊆ H (n + 1)` for all `n`. Note that this series
    may not terminate at `⊥`, and the `H i` need not be normal. Similarly a sequence is an
    *ascending central series* if `H 0 = ⊥` and `⁅H (n + 1), ⊤⁆ ⊆ H n` for all `n`, again with no
    requirement that the series reaches `⊤` or that the `H i` are normal.

## Main theorems

`G` is *defined* to be nilpotent if the upper central series reaches `⊤`.
* `nilpotent_iff_finite_ascending_central_series` : `G` is nilpotent iff some ascending central
    series reaches `⊤`.
* `nilpotent_iff_finite_descending_central_series` : `G` is nilpotent iff some descending central
    series reaches `⊥`.
* `nilpotent_iff_lower` : `G` is nilpotent iff the lower central series reaches `⊥`.
* The `nilpotency_class` can likeways be obtained from these equivalent
  definitions, see `least_ascending_central_series_length_eq_nilpotency_class`,
  `least_descending_central_series_length_eq_nilpotency_class` and
  `lower_central_series_length_eq_nilpotency_class`.
* If `G` is nilpotent, then so are its subgroups, images, quotients and preimages.
  Corresponding lemmas about the `nilpotency_class` are provided.
* The `nilpotency_class` of `G ⧸ center G` is given explicitly, and an induction principle
  is derived from that.
* `is_nilpotent.to_is_solvable`: If `G` is nilpotent, it is solvable.

## Warning

A "central series" is usually defined to be a finite sequence of normal subgroups going
from `⊥` to `⊤` with the property that each subquotient is contained within the centre of
the associated quotient of `G`. This means that if `G` is not nilpotent, then
none of what we have called `upper_central_series G`, `lower_central_series G` or
the sequences satisfying `is_ascending_central_series` or `is_descending_central_series`
are actually central series. Note that the fact that the upper and lower central series
are not central series if `G` is not nilpotent is a standard abuse of notation.

-/

open subgroup

variables {G : Type*} [group G] (H : subgroup G) [normal H]

/-- If `H` is a normal subgroup of `G`, then the set `{x : G | ∀ y : G, x*y*x⁻¹*y⁻¹ ∈ H}`
is a subgroup of `G` (because it is the preimage in `G` of the centre of the
quotient group `G/H`.)
-/
def upper_central_series_step : subgroup G :=
{ carrier := {x : G | ∀ y : G, x * y * x⁻¹ * y⁻¹ ∈ H},
  one_mem' := λ y, by simp [subgroup.one_mem],
  mul_mem' := λ a b ha hb y, begin
    convert subgroup.mul_mem _ (ha (b * y * b⁻¹)) (hb y) using 1,
    group,
  end,
  inv_mem' := λ x hx y, begin
    specialize hx y⁻¹,
    rw [mul_assoc, inv_inv] at ⊢ hx,
    exact subgroup.normal.mem_comm infer_instance hx,
  end }

lemma mem_upper_central_series_step (x : G) :
  x ∈ upper_central_series_step H ↔ ∀ y, x * y * x⁻¹ * y⁻¹ ∈ H := iff.rfl

open quotient_group

/-- The proof that `upper_central_series_step H` is the preimage of the centre of `G/H` under
the canonical surjection. -/
lemma upper_central_series_step_eq_comap_center :
  upper_central_series_step H = subgroup.comap (mk' H) (center (G ⧸ H)) :=
begin
  ext,
  rw [mem_comap, mem_center_iff, forall_coe],
  apply forall_congr,
  intro y,
  rw [coe_mk', ←quotient_group.coe_mul, ←quotient_group.coe_mul, eq_comm, eq_iff_div_mem,
    div_eq_mul_inv, mul_inv_rev, mul_assoc],
end

instance : normal (upper_central_series_step H) :=
begin
  rw upper_central_series_step_eq_comap_center,
  apply_instance,
end

variable (G)

/-- An auxiliary type-theoretic definition defining both the upper central series of
a group, and a proof that it is normal, all in one go. -/
def upper_central_series_aux : ℕ → Σ' (H : subgroup G), normal H
| 0 := ⟨⊥, infer_instance⟩
| (n + 1) := let un := upper_central_series_aux n, un_normal := un.2 in
   by exactI ⟨upper_central_series_step un.1, infer_instance⟩

/-- `upper_central_series G n` is the `n`th term in the upper central series of `G`. -/
def upper_central_series (n : ℕ) : subgroup G := (upper_central_series_aux G n).1

instance (n : ℕ) : normal (upper_central_series G n) := (upper_central_series_aux G n).2

@[simp] lemma upper_central_series_zero : upper_central_series G 0 = ⊥ := rfl

@[simp] lemma upper_central_series_one : upper_central_series G 1 = center G :=
begin
  ext,
  simp only [upper_central_series, upper_central_series_aux, upper_central_series_step, center,
    set.center, mem_mk, mem_bot, set.mem_set_of_eq],
  exact forall_congr (λ y, by rw [mul_inv_eq_one, mul_inv_eq_iff_eq_mul, eq_comm]),
end

/-- The `n+1`st term of the upper central series `H i` has underlying set equal to the `x` such
that `⁅x,G⁆ ⊆ H n`-/
lemma mem_upper_central_series_succ_iff (n : ℕ) (x : G) :
  x ∈ upper_central_series G (n + 1) ↔
  ∀ y : G, x * y * x⁻¹ * y⁻¹ ∈ upper_central_series G n := iff.rfl

-- is_nilpotent is already defined in the root namespace (for elements of rings).
/-- A group `G` is nilpotent if its upper central series is eventually `G`. -/
class group.is_nilpotent (G : Type*) [group G] : Prop :=
(nilpotent [] : ∃ n : ℕ, upper_central_series G n = ⊤)

open group

variable {G}

/-- A sequence of subgroups of `G` is an ascending central series if `H 0` is trivial and
  `⁅H (n + 1), G⁆ ⊆ H n` for all `n`. Note that we do not require that `H n = G` for some `n`. -/
def is_ascending_central_series (H : ℕ → subgroup G) : Prop :=
  H 0 = ⊥ ∧ ∀ (x : G) (n : ℕ), x ∈ H (n + 1) → ∀ g, x * g * x⁻¹ * g⁻¹ ∈ H n

/-- A sequence of subgroups of `G` is a descending central series if `H 0` is `G` and
  `⁅H n, G⁆ ⊆ H (n + 1)` for all `n`. Note that we do not requre that `H n = {1}` for some `n`. -/
def is_descending_central_series (H : ℕ → subgroup G) := H 0 = ⊤ ∧
  ∀ (x : G) (n : ℕ), x ∈ H n → ∀ g, x * g * x⁻¹ * g⁻¹ ∈ H (n + 1)

/-- Any ascending central series for a group is bounded above by the upper central series. -/
lemma ascending_central_series_le_upper (H : ℕ → subgroup G) (hH : is_ascending_central_series H) :
  ∀ n : ℕ, H n ≤ upper_central_series G n
| 0 := hH.1.symm ▸ le_refl ⊥
| (n + 1) := begin
  intros x hx,
  rw mem_upper_central_series_succ_iff,
  exact λ y, ascending_central_series_le_upper n (hH.2 x n hx y),
end

variable (G)

/-- The upper central series of a group is an ascending central series. -/
lemma upper_central_series_is_ascending_central_series :
  is_ascending_central_series (upper_central_series G) :=
⟨rfl, λ x n h, h⟩

lemma upper_central_series_mono : monotone (upper_central_series G) :=
begin
  refine monotone_nat_of_le_succ _,
  intros n x hx y,
  rw [mul_assoc, mul_assoc, ← mul_assoc y x⁻¹ y⁻¹],
  exact mul_mem (upper_central_series G n) hx
    (normal.conj_mem (upper_central_series.subgroup.normal G n) x⁻¹ (inv_mem _ hx) y),
end

/-- A group `G` is nilpotent iff there exists an ascending central series which reaches `G` in
  finitely many steps. -/
theorem nilpotent_iff_finite_ascending_central_series :
  is_nilpotent G ↔ ∃ n : ℕ, ∃ H : ℕ → subgroup G, is_ascending_central_series H ∧ H n = ⊤ :=
begin
  split,
  { rintro ⟨n, nH⟩,
    refine ⟨_, _, upper_central_series_is_ascending_central_series G, nH⟩ },
  { rintro ⟨n, H, hH, hn⟩,
    use n,
    rw [eq_top_iff, ←hn],
    exact ascending_central_series_le_upper H hH n }
end

lemma is_decending_rev_series_of_is_ascending
  {H: ℕ → subgroup G} {n : ℕ} (hn : H n = ⊤) (hasc : is_ascending_central_series H) :
  is_descending_central_series (λ (m : ℕ), H (n - m)) :=
begin
  cases hasc with h0 hH,
  refine ⟨hn, λ x m hx g, _⟩,
  dsimp at hx,
  by_cases hm : n ≤ m,
  { rw [tsub_eq_zero_of_le hm, h0, subgroup.mem_bot] at hx,
    subst hx,
    convert subgroup.one_mem _,
    group },
  { push_neg at hm,
    apply hH,
    convert hx,
    rw [tsub_add_eq_add_tsub (nat.succ_le_of_lt hm), nat.succ_sub_succ] },
end

lemma is_ascending_rev_series_of_is_descending
  {H: ℕ → subgroup G} {n : ℕ} (hn : H n = ⊥) (hdesc : is_descending_central_series H) :
  is_ascending_central_series (λ (m : ℕ), H (n - m)) :=
begin
  cases hdesc with h0 hH,
  refine ⟨hn, λ x m hx g, _⟩,
  dsimp only at hx ⊢,
  by_cases hm : n ≤ m,
  { have hnm : n - m = 0 := tsub_eq_zero_iff_le.mpr hm,
    rw [hnm, h0],
    exact mem_top _ },
  { push_neg at hm,
    convert hH x _ hx g,
    rw [tsub_add_eq_add_tsub (nat.succ_le_of_lt hm), nat.succ_sub_succ] },
end

/-- A group `G` is nilpotent iff there exists a descending central series which reaches the
  trivial group in a finite time. -/
theorem nilpotent_iff_finite_descending_central_series :
  is_nilpotent G ↔ ∃ n : ℕ, ∃ H : ℕ → subgroup G, is_descending_central_series H ∧ H n = ⊥ :=
begin
  rw nilpotent_iff_finite_ascending_central_series,
  split,
  { rintro ⟨n, H, hH, hn⟩,
    refine ⟨n, λ m, H (n - m), is_decending_rev_series_of_is_ascending G hn hH, _⟩,
    rw tsub_self,
    exact hH.1 },
  { rintro ⟨n, H, hH, hn⟩,
    refine ⟨n, λ m, H (n - m), is_ascending_rev_series_of_is_descending G hn hH, _⟩,
    rw tsub_self,
    exact hH.1 },
end

/-- The lower central series of a group `G` is a sequence `H n` of subgroups of `G`, defined
  by `H 0` is all of `G` and for `n≥1`, `H (n + 1) = ⁅H n, G⁆` -/
def lower_central_series (G : Type*) [group G] : ℕ → subgroup G
| 0 := ⊤
| (n+1) := ⁅lower_central_series n, ⊤⁆

variable {G}

@[simp] lemma lower_central_series_zero : lower_central_series G 0 = ⊤ := rfl

@[simp] lemma lower_central_series_one : lower_central_series G 1 = commutator G :=
by simp [lower_central_series]

lemma mem_lower_central_series_succ_iff (n : ℕ) (q : G) :
  q ∈ lower_central_series G (n + 1) ↔
  q ∈ closure {x | ∃ (p ∈ lower_central_series G n) (q ∈ (⊤ : subgroup G)), p * q * p⁻¹ * q⁻¹ = x}
:= iff.rfl

lemma lower_central_series_succ (n : ℕ) :
  lower_central_series G (n + 1) =
  closure {x | ∃ (p ∈ lower_central_series G n) (q ∈ (⊤ : subgroup G)), p * q * p⁻¹ * q⁻¹ = x} :=
rfl

instance (n : ℕ) : normal (lower_central_series G n) :=
begin
  induction n with d hd,
  { exact (⊤ : subgroup G).normal_of_characteristic },
  { exactI general_commutator_normal (lower_central_series G d) ⊤ },
end

lemma lower_central_series_antitone :
  antitone (lower_central_series G) :=
begin
  refine antitone_nat_of_succ_le (λ n x hx, _),
  simp only [mem_lower_central_series_succ_iff, exists_prop, mem_top, exists_true_left, true_and]
    at hx,
  refine closure_induction hx _ (subgroup.one_mem _) (@subgroup.mul_mem _ _ _)
    (@subgroup.inv_mem _ _ _),
  rintros y ⟨z, hz, a, ha⟩,
  rw [← ha, mul_assoc, mul_assoc, ← mul_assoc a z⁻¹ a⁻¹],
  exact mul_mem (lower_central_series G n) hz
    (normal.conj_mem (lower_central_series.subgroup.normal n) z⁻¹ (inv_mem _ hz) a),
end

/-- The lower central series of a group is a descending central series. -/
theorem lower_central_series_is_descending_central_series :
  is_descending_central_series (lower_central_series G) :=
begin
  split, refl,
  intros x n hxn g,
  exact general_commutator_containment _ _ hxn (subgroup.mem_top g),
end

/-- Any descending central series for a group is bounded below by the lower central series. -/
lemma descending_central_series_ge_lower (H : ℕ → subgroup G)
  (hH : is_descending_central_series H) : ∀ n : ℕ, lower_central_series G n ≤ H n
| 0 := hH.1.symm ▸ le_refl ⊤
| (n + 1) := begin
  specialize descending_central_series_ge_lower n,
  apply (general_commutator_le _ _ _).2,
  intros x hx q _,
  exact hH.2 x n (descending_central_series_ge_lower hx) q,
end

/-- A group is nilpotent if and only if its lower central series eventually reaches
  the trivial subgroup. -/
theorem nilpotent_iff_lower_central_series : is_nilpotent G ↔ ∃ n, lower_central_series G n = ⊥ :=
begin
  rw nilpotent_iff_finite_descending_central_series,
  split,
  { rintro ⟨n, H, ⟨h0, hs⟩, hn⟩,
    use n,
    rw [eq_bot_iff, ←hn],
    exact descending_central_series_ge_lower H ⟨h0, hs⟩ n },
  { rintro ⟨n, hn⟩,
    exact ⟨n, lower_central_series G, lower_central_series_is_descending_central_series, hn⟩ },
end

section classical

open_locale classical

variables [hG : is_nilpotent G]
include hG

variable (G)

/-- The nilpotency class of a nilpotent group is the smallest natural `n` such that
the `n`'th term of the upper central series is `G`. -/
noncomputable def group.nilpotency_class : ℕ :=
nat.find (is_nilpotent.nilpotent G)

variable {G}

@[simp]
lemma upper_central_series_nilpotency_class :
  upper_central_series G (group.nilpotency_class G) = ⊤ :=
nat.find_spec (is_nilpotent.nilpotent G)

lemma upper_central_series_eq_top_iff_nilpotency_class_le {n : ℕ} :
  (upper_central_series G n = ⊤) ↔ (group.nilpotency_class G ≤ n) :=
begin
  split,
  { intro h,
    exact (nat.find_le h), },
  { intro h,
    apply eq_top_iff.mpr,
    rw ← upper_central_series_nilpotency_class,
    exact (upper_central_series_mono _ h), }
end

/-- The nilpotency class of a nilpotent `G` is equal to the smallest `n` for which an ascending
central series reaches `G` in its `n`'th term. -/
lemma least_ascending_central_series_length_eq_nilpotency_class :
  nat.find ((nilpotent_iff_finite_ascending_central_series G).mp hG) = group.nilpotency_class G :=
begin
  refine le_antisymm (nat.find_mono _) (nat.find_mono _),
  { intros n hn,
    exact ⟨upper_central_series G, upper_central_series_is_ascending_central_series G, hn ⟩, },
  { rintros n ⟨H, ⟨hH, hn⟩⟩,
    rw [←top_le_iff, ←hn],
    exact ascending_central_series_le_upper H hH n, }
end

/-- The nilpotency class of a nilpotent `G` is equal to the smallest `n` for which the descending
central series reaches `⊥` in its `n`'th term. -/
lemma least_descending_central_series_length_eq_nilpotency_class :
  nat.find ((nilpotent_iff_finite_descending_central_series G).mp hG) = group.nilpotency_class G :=
begin
  rw ← least_ascending_central_series_length_eq_nilpotency_class,
  refine le_antisymm (nat.find_mono _) (nat.find_mono _),
  { rintros n ⟨H, ⟨hH, hn⟩⟩,
    refine ⟨(λ m, H (n - m)), is_decending_rev_series_of_is_ascending G hn hH, _⟩,
    rw tsub_self,
    exact hH.1 },
  { rintros n ⟨H, ⟨hH, hn⟩⟩,
    refine ⟨(λ m, H (n - m)), is_ascending_rev_series_of_is_descending G hn hH, _⟩,
    rw tsub_self,
    exact hH.1 },
end

/-- The nilpotency class of a nilpotent `G` is equal to the length of the lower central series. -/
lemma lower_central_series_length_eq_nilpotency_class :
  nat.find (nilpotent_iff_lower_central_series.mp hG) = @group.nilpotency_class G _ _ :=
begin
  rw ← least_descending_central_series_length_eq_nilpotency_class,
  refine le_antisymm (nat.find_mono _) (nat.find_mono _),
  { rintros n ⟨H, ⟨hH, hn⟩⟩,
    rw [←le_bot_iff, ←hn],
    exact (descending_central_series_ge_lower H hH n), },
  { rintros n h,
    exact ⟨lower_central_series G, ⟨lower_central_series_is_descending_central_series, h⟩⟩ },
end

@[simp]
lemma lower_central_series_nilpotency_class :
  lower_central_series G (group.nilpotency_class G) = ⊥ :=
begin
  rw ← lower_central_series_length_eq_nilpotency_class,
  exact (nat.find_spec (nilpotent_iff_lower_central_series.mp _))
end

lemma lower_central_series_eq_bot_iff_nilpotency_class_le {n : ℕ} :
  (lower_central_series G n = ⊥) ↔ (group.nilpotency_class G ≤ n) :=
begin
  split,
  { intro h,
    rw ← lower_central_series_length_eq_nilpotency_class,
    exact (nat.find_le h), },
  { intro h,
    apply eq_bot_iff.mpr,
    rw ← lower_central_series_nilpotency_class,
    exact (lower_central_series_antitone h), }
end

end classical

lemma lower_central_series_map_subtype_le (H : subgroup G) (n : ℕ) :
  (lower_central_series H n).map H.subtype ≤ lower_central_series G n :=
begin
  induction n with d hd,
  { simp },
  { rw [lower_central_series_succ, lower_central_series_succ, monoid_hom.map_closure],
    apply subgroup.closure_mono,
    rintros x1 ⟨x2, ⟨x3, hx3, x4, hx4, rfl⟩, rfl⟩,
    exact ⟨x3, (hd (mem_map.mpr ⟨x3, hx3, rfl⟩)), x4, by simp⟩ }
end

/-- A subgroup of a nilpotent group is nilpotent -/
instance subgroup.is_nilpotent (H : subgroup G) [hG : is_nilpotent G] :
  is_nilpotent H :=
begin
  rw nilpotent_iff_lower_central_series at *,
  rcases hG with ⟨n, hG⟩,
  use n,
  have := lower_central_series_map_subtype_le H n,
  simp only [hG, set_like.le_def, mem_map, forall_apply_eq_imp_iff₂, exists_imp_distrib] at this,
  exact eq_bot_iff.mpr (λ x hx, subtype.ext (this x hx)),
end

/-- A the nilpotency class of a subgroup is less or equal the the nilpotency class of the group -/
lemma subgroup.nilpotency_class_le (H : subgroup G) [hG : is_nilpotent G] :
  group.nilpotency_class H ≤ group.nilpotency_class G :=
begin
  repeat { rw ← lower_central_series_length_eq_nilpotency_class },
  apply nat.find_mono,
  intros n hG,
  have := lower_central_series_map_subtype_le H n,
  simp only [hG, set_like.le_def, mem_map, forall_apply_eq_imp_iff₂, exists_imp_distrib] at this,
  exact eq_bot_iff.mpr (λ x hx, subtype.ext (this x hx)),
end

@[priority 100]
instance is_nilpotent_of_subsingleton [subsingleton G] : is_nilpotent G :=
nilpotent_iff_lower_central_series.2 ⟨0, subsingleton.elim ⊤ ⊥⟩

lemma upper_central_series.map {H : Type*} [group H] {f : G →* H} (h : function.surjective f)
  (n : ℕ) : subgroup.map f (upper_central_series G n) ≤ upper_central_series H n :=
begin
  induction n with d hd,
  { simp },
  { rintros _ ⟨x, hx : x ∈ upper_central_series G d.succ, rfl⟩ y',
    rcases h y' with ⟨y, rfl⟩,
    simpa using hd (mem_map_of_mem f (hx y)) }
end

lemma lower_central_series.map {H : Type*} [group H] (f : G →* H) (n : ℕ) :
  subgroup.map f (lower_central_series G n) ≤ lower_central_series H n :=
begin
  induction n with d hd,
  { simp [nat.nat_zero_eq_zero] },
  { rintros a ⟨x, hx : x ∈ lower_central_series G d.succ, rfl⟩,
    refine closure_induction hx _ (by simp [f.map_one, subgroup.one_mem _])
      (λ y z hy hz, by simp [monoid_hom.map_mul, subgroup.mul_mem _ hy hz])
      (λ y hy, by simp [f.map_inv, subgroup.inv_mem _ hy]),
    rintros a ⟨y, hy, z, ⟨-, rfl⟩⟩,
    apply mem_closure.mpr,
    exact λ K hK, hK ⟨f y, hd (mem_map_of_mem f hy), by simp⟩ }
end

lemma lower_central_series_succ_eq_bot {n : ℕ} (h : lower_central_series G n ≤ center G) :
  lower_central_series G (n + 1) = ⊥ :=
begin
  rw [lower_central_series_succ, closure_eq_bot_iff, set.subset_singleton_iff],
  rintro x ⟨y, hy1, z, ⟨⟩, rfl⟩,
  rw [mul_assoc, ←mul_inv_rev, mul_inv_eq_one, eq_comm],
  exact mem_center_iff.mp (h hy1) z,
end

/-- The preimage of a nilpotent group is nilpotent if the kernel of the homomorphism is contained
in the center -/
lemma is_nilpotent_of_ker_le_center {H : Type*} [group H] (f : G →* H)
  (hf1 : f.ker ≤ center G) (hH : is_nilpotent H) : is_nilpotent G :=
begin
  rw nilpotent_iff_lower_central_series at *,
  rcases hH with ⟨n, hn⟩,
  use (n + 1),
  refine lower_central_series_succ_eq_bot (le_trans ((map_eq_bot_iff _).mp _) hf1),
  exact eq_bot_iff.mpr (hn ▸ (lower_central_series.map f n)),
end

lemma nilpotency_class_le_of_ker_le_center {H : Type*} [group H] (f : G →* H)
  (hf1 : f.ker ≤ center G) (hH : is_nilpotent H) :
  @group.nilpotency_class G _ (is_nilpotent_of_ker_le_center f hf1 hH) ≤
    group.nilpotency_class H + 1 :=
begin
  rw ← lower_central_series_length_eq_nilpotency_class,
  apply nat.find_min',
  refine lower_central_series_succ_eq_bot (le_trans ((map_eq_bot_iff _).mp _) hf1),
  apply eq_bot_iff.mpr,
  apply (le_trans (lower_central_series.map f _)),
  simp only [lower_central_series_nilpotency_class, le_bot_iff],
end

/-- The range of a surejctive homomorphism from a nilpotent group is nilpotent -/
lemma nilpotent_of_surjective {G' : Type*} [group G'] [h : is_nilpotent G]
  (f : G →* G') (hf : function.surjective f) :
  is_nilpotent G' :=
begin
  unfreezingI { rcases h with ⟨n, hn⟩ },
  use n,
  apply eq_top_iff.mpr,
  calc ⊤ = f.range : symm (f.range_top_of_surjective hf)
    ... = subgroup.map f ⊤ : monoid_hom.range_eq_map _
    ... = subgroup.map f (upper_central_series G n) : by rw hn
    ... ≤ upper_central_series G' n : upper_central_series.map hf n,
end

/-- The nilpotency class of the range of a surejctive homomorphism from a
nilpotent group is less or equal the nilpotency class of the domain -/
lemma nilpotency_class_le_of_surjective
  {G' : Type*} [group G'] (f : G →* G') (hf : function.surjective f) [h : is_nilpotent G] :
  @group.nilpotency_class G' _ (nilpotent_of_surjective _ hf) ≤
    group.nilpotency_class G :=
begin
  apply nat.find_mono,
  intros n hn,
  apply eq_top_iff.mpr,
  calc ⊤ = f.range : symm (f.range_top_of_surjective hf)
    ... = subgroup.map f ⊤ : monoid_hom.range_eq_map _
    ... = subgroup.map f (upper_central_series G n) : by rw hn
    ... ≤ upper_central_series G' n : upper_central_series.map hf n,
end

/-- A quotient of a nilpotent group is nilpotent -/
instance nilpotent_quotient_of_nilpotent (H : subgroup G) [H.normal] [h : is_nilpotent G] :
  is_nilpotent (G ⧸ H) :=
 nilpotent_of_surjective _ (show function.surjective (quotient_group.mk' H), by tidy)

/-- The nilpotency class of a quotient of `G` is less or equal the nilpotency class of `G` -/
lemma nilpotency_class_quotient_le (H : subgroup G) [H.normal] [h : is_nilpotent G] :
  group.nilpotency_class (G ⧸ H) ≤ group.nilpotency_class G := nilpotency_class_le_of_surjective _ _

-- This technical lemma helps with rewriting the subgroup, which occurs in indices
private lemma comap_center_subst {H₁ H₂ : subgroup G} [normal H₁] [normal H₂] (h : H₁ = H₂) :
  comap (mk' H₁) (center (G ⧸ H₁)) = comap (mk' H₂) (center (G ⧸ H₂)) :=
by unfreezingI { subst h }

lemma comap_upper_central_series_quotient_center (n : ℕ) :
  comap (mk' (center G)) (upper_central_series (G ⧸ center G) n) = upper_central_series G n.succ :=
begin
  induction n with n ih,
  { simp, },
  { let Hn := upper_central_series (G ⧸ center G) n,
    calc comap (mk' (center G)) (upper_central_series_step Hn)
        = comap (mk' (center G)) (comap (mk' Hn) (center ((G ⧸ center G) ⧸ Hn))) :
        by rw upper_central_series_step_eq_comap_center
    ... = comap (mk' (comap (mk' (center G)) Hn)) (center (G ⧸ (comap (mk' (center G)) Hn))) :
        quotient_group.comap_comap_center
    ... = comap (mk' (upper_central_series G n.succ)) (center (G ⧸ upper_central_series G n.succ)) :
        comap_center_subst ih
    ... = upper_central_series_step (upper_central_series G n.succ) :
        symm (upper_central_series_step_eq_comap_center _), }
end

lemma nilpotency_class_zero_iff_subsingleton [is_nilpotent G] :
  group.nilpotency_class G = 0 ↔ subsingleton G :=
by simp [group.nilpotency_class, nat.find_eq_zero, subsingleton_iff_bot_eq_top]

/-- Quotienting the `center G` reduces the nilpotency class by 1 -/
lemma nilpotency_class_quotient_center [hH : is_nilpotent G] :
  group.nilpotency_class (G ⧸ center G) = group.nilpotency_class G - 1 :=
begin
  generalize hn : group.nilpotency_class G = n,
  rcases n with rfl | n,
  { simp [nilpotency_class_zero_iff_subsingleton] at *,
    haveI := hn,
    apply_instance, },
  { suffices : group.nilpotency_class (G ⧸ center G) = n, by simpa,
    apply le_antisymm,
    { apply upper_central_series_eq_top_iff_nilpotency_class_le.mp,
      apply (@comap_injective G _ _ _ (mk' (center G)) (surjective_quot_mk _)),
      rw [ comap_upper_central_series_quotient_center, comap_top, ← hn],
      exact upper_central_series_nilpotency_class, },
    { apply le_of_add_le_add_right,
      calc n + 1 = n.succ : rfl
        ... = group.nilpotency_class G : symm hn
        ... ≤ group.nilpotency_class (G ⧸ center G) + 1
            : nilpotency_class_le_of_ker_le_center _ (le_of_eq (ker_mk _)) _, } }
end

/-- The nilpotency class of a non-trivial group is one more than its quotient by the center -/
lemma nilpotency_class_eq_quotient_center_plus_one [hH : is_nilpotent G] [nontrivial G] :
  group.nilpotency_class G = group.nilpotency_class (G ⧸ center G) + 1 :=
begin
  rw nilpotency_class_quotient_center,
  rcases h : group.nilpotency_class G,
  { exfalso,
    rw nilpotency_class_zero_iff_subsingleton at h, resetI,
    apply (false_of_nontrivial_of_subsingleton G), },
  { simp }
end

/-- If the quotient by `center G` is nilpotent, then so is G. -/
lemma of_quotient_center_nilpotent (h : is_nilpotent (G ⧸ center G)) : is_nilpotent G :=
begin
  obtain ⟨n, hn⟩ := h.nilpotent,
  use n.succ,
  simp [← comap_upper_central_series_quotient_center, hn],
end

/-- A custom induction principle for nilpotent groups. The base case is a trivial group
(`subsingleton G`), and in the induction step, one can assume the hypothesis for
the group quotiented by its center. -/
@[elab_as_eliminator]
lemma nilpotent_center_quotient_ind
  {P : Π G [group G], by exactI ∀ [is_nilpotent G], Prop}
  (G : Type*) [group G] [is_nilpotent G]
  (hbase : ∀ G [group G] [subsingleton G], by exactI P G)
  (hstep : ∀ G [group G], by exactI ∀ [is_nilpotent G], by exactI ∀ (ih : P (G ⧸ center G)), P G) :
  P G :=
begin
  obtain ⟨n, h⟩ : ∃ n, group.nilpotency_class G = n := ⟨ _, rfl⟩,
  unfreezingI { induction n with n ih generalizing G },
  { haveI := nilpotency_class_zero_iff_subsingleton.mp h,
    exact hbase _, },
  { have hn : group.nilpotency_class (G ⧸ center G) = n :=
      by simp [nilpotency_class_quotient_center, h],
    exact hstep _ (ih _ hn), },
end

lemma derived_le_lower_central (n : ℕ) : derived_series G n ≤ lower_central_series G n :=
by { induction n with i ih, { simp }, { apply general_commutator_mono ih, simp } }

/-- Abelian groups are nilpotent -/
@[priority 100]
instance comm_group.is_nilpotent {G : Type*} [comm_group G] : is_nilpotent G :=
begin
  use 1,
  rw upper_central_series_one,
  apply comm_group.center_eq_top,
end

/-- Abelian groups have nilpotency class at most one -/
lemma comm_group.nilpotency_class_le_one {G : Type*} [comm_group G] :
  group.nilpotency_class G ≤ 1 :=
begin
  apply upper_central_series_eq_top_iff_nilpotency_class_le.mp,
  rw upper_central_series_one,
  apply comm_group.center_eq_top,
end

/-- Groups with nilpotency class at most one are abelian -/
def comm_group_of_nilpotency_class [is_nilpotent G] (h : group.nilpotency_class G ≤ 1) :
  comm_group G :=
group.comm_group_of_center_eq_top $
begin
  rw ← upper_central_series_one,
  exact upper_central_series_eq_top_iff_nilpotency_class_le.mpr h,
end

/-- A nilpotent subgroup is solvable -/
@[priority 100]
instance is_nilpotent.to_is_solvable [h : is_nilpotent G]: is_solvable G :=
begin
  obtain ⟨n, hn⟩ := nilpotent_iff_lower_central_series.1 h,
  use n,
  rw [eq_bot_iff, ←hn],
  exact derived_le_lower_central n,
end

section classical

open_locale classical -- to get the fintype instance for quotient groups

/-- A p-group is nilpotent -/
lemma is_p_group.is_nilpotent {G : Type*} [hG : group G] [hf : fintype G]
  {p : ℕ} (hp : fact (nat.prime p)) (h : is_p_group p G) :
  is_nilpotent G :=
begin
  unfreezingI
  { revert hG,
    induction hf using fintype.induction_subsingleton_or_nontrivial with G hG hS G hG hN ih },
  { apply_instance, },
  { introI _, intro h,
    have hc : center G > ⊥ := gt_iff_lt.mp h.bot_lt_center,
    have hcq : fintype.card (G ⧸ center G) < fintype.card G,
    { rw card_eq_card_quotient_mul_card_subgroup (center G),
      apply lt_mul_of_one_lt_right,
      exact (fintype.card_pos_iff.mpr has_one.nonempty),
      exact ((subgroup.one_lt_card_iff_ne_bot _).mpr (ne_of_gt hc)), },
    have hnq : is_nilpotent (G ⧸ center G) := ih _ hcq (h.to_quotient (center G)),
    exact (of_quotient_center_nilpotent hnq), }
end

end classical


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

import data.nat.digits

/-!
# IMO 1962 Q1

Find the smallest natural number $n$ which has the following properties:

(a) Its decimal representation has 6 as the last digit.

(b) If the last digit 6 is erased and placed in front of the remaining digits,
the resulting number is four times as large as the original number $n$.

Since Lean does not explicitly express problems of the form "find the smallest number satisfying X",
we define the problem as a predicate, and then prove a particular number is the smallest member
of a set satisfying it.
-/

namespace imo1962_q1

open nat

def problem_predicate (n : ℕ) : Prop :=
(digits 10 n).head = 6 ∧ of_digits 10 ((digits 10 n).tail.concat 6) = 4 * n

/-!
First, it's inconvenient to work with digits, so let's simplify them out of the problem.
-/

abbreviation problem_predicate' (c n : ℕ) : Prop :=
n = 10 * c + 6 ∧ 6 * 10 ^ (digits 10 c).length + c = 4 * n

lemma without_digits {n : ℕ} (h1 : problem_predicate n) :
∃ c : ℕ, problem_predicate' c n :=
begin
  use n / 10,
  cases n,
  { have h2 : ¬ problem_predicate 0, by norm_num [problem_predicate],
    contradiction },
  { rw [problem_predicate, digits_def' (dec_trivial : 2 ≤ 10) n.succ_pos,
        list.head, list.tail_cons, list.concat_eq_append] at h1,
    split,
    { rw [← h1.left, div_add_mod (n+1) 10], },
    { rw [← h1.right, of_digits_append, of_digits_digits,
          of_digits_singleton, add_comm, mul_comm], }, },
end

/-!
Now we can eliminate possibilities for `(digits 10 c).length` until we get to the one that works.
-/

lemma case_0_digit {c n : ℕ} (h1 : (digits 10 c).length = 0) : ¬ problem_predicate' c n :=
begin
  intro h2,
  have h3 : 6 * 10 ^ 0 + c = 6 * 10 ^ (digits 10 c).length + c, by rw h1,
  have h4 : 6 * 10 ^ 0 + c = 4 * (10 * c + 6), by rw [h3, h2.right, h2.left],
  linarith,
end

lemma case_1_digit {c n : ℕ} (h1 : (digits 10 c).length = 1) : ¬ problem_predicate' c n :=
begin
  intro h2,
  have h3 : 6 * 10 ^ 1 + c = 6 * 10 ^ (digits 10 c).length + c, by rw h1,
  have h4 : 6 * 10 ^ 1 + c = 4 * (10 * c + 6), by rw [h3, h2.right, h2.left],
  have h6 : c > 0, by linarith,
  linarith,
end

lemma case_2_digit {c n : ℕ} (h1 : (digits 10 c).length = 2) : ¬ problem_predicate' c n :=
begin
  intro h2,
  have h3 : 6 * 10 ^ 2 + c = 6 * 10 ^ (digits 10 c).length + c, by rw h1,
  have h4 : 6 * 10 ^ 2 + c = 4 * (10 * c + 6), by rw [h3, h2.right, h2.left],
  have h5 : c > 14, by linarith,
  linarith
end

lemma case_3_digit {c n : ℕ} (h1 : (digits 10 c).length = 3) : ¬ problem_predicate' c n :=
begin
  intro h2,
  have h3 : 6 * 10 ^ 3 + c = 6 * 10 ^ (digits 10 c).length + c, by rw h1,
  have h4 : 6 * 10 ^ 3 + c = 4 * (10 * c + 6), by rw [h3, h2.right, h2.left],
  have h5 : c > 153, by linarith,
  linarith
end

lemma case_4_digit {c n : ℕ} (h1 : (digits 10 c).length = 4) : ¬ problem_predicate' c n :=
begin
  intro h2,
  have h3 : 6 * 10 ^ 4 + c = 6 * 10 ^ (digits 10 c).length + c, by rw h1,
  have h4 : 6 * 10 ^ 4 + c = 4 * (10 * c + 6), by rw [h3, h2.right, h2.left],
  have h5 : c > 1537, by linarith,
  linarith
end

/-- Putting this inline causes a deep recursion error, so we separate it out. -/
lemma helper_5_digit {c : ℤ} (h : 6 * 10 ^ 5 + c = 4 * (10 * c + 6)) : c = 15384 := by linarith

lemma case_5_digit {c n : ℕ} (h1 : (digits 10 c).length = 5) (h2 : problem_predicate' c n) :
  c = 15384 :=
begin
  have h3 : 6 * 10 ^ 5 + c = 6 * 10 ^ (digits 10 c).length + c, by rw h1,
  have h4 : 6 * 10 ^ 5 + c = 4 * (10 * c + 6), by rw [h3, h2.right, h2.left],
  zify at *,
  exact helper_5_digit h4
end

/--
`linarith` fails on numbers this large, so this lemma spells out some of the arithmetic
that normally would be automated.
-/
lemma case_more_digits {c n : ℕ} (h1 : (digits 10 c).length ≥ 6) (h2 : problem_predicate' c n) :
  n ≥ 153846 :=
begin
  have h3 : c ≠ 0,
  { intro h4,
    have h5 : (digits 10 c).length = 0, by simp [h4],
    exact case_0_digit h5 h2 },
  have h6 : 2 ≤ 10, from dec_trivial,
  calc
    n ≥ 10 * c                    : le.intro h2.left.symm
  ... ≥ 10 ^ (digits 10 c).length : base_pow_length_digits_le 10 c h6 h3
  ... ≥ 10 ^ 6                    : (pow_le_iff_le_right h6).mpr h1
  ... ≥ 153846                    : by norm_num,
end

/-!
Now we combine these cases to show that 153846 is the smallest solution.
-/

lemma satisfied_by_153846 : problem_predicate 153846 :=
by norm_num [problem_predicate, digits_def', of_digits]

lemma no_smaller_solutions (n : ℕ) (h1 : problem_predicate n) : n ≥ 153846 :=
begin
  cases without_digits h1 with c h2,
  have h3 : (digits 10 c).length < 6 ∨ (digits 10 c).length ≥ 6, by apply lt_or_ge,
  cases h3,
  case or.inr
  { exact case_more_digits h3 h2, },
  case or.inl
  { interval_cases (digits 10 c).length with h,
    { exfalso, exact case_0_digit h h2 },
    { exfalso, exact case_1_digit h h2 },
    { exfalso, exact case_2_digit h h2 },
    { exfalso, exact case_3_digit h h2 },
    { exfalso, exact case_4_digit h h2 },
    { have h4 : c = 15384, from case_5_digit h h2,
      have h5 : n = 10 * 15384 + 6, from h4 ▸ h2.left,
      norm_num at h5,
      exact h5.ge, }, },
end

end imo1962_q1

open imo1962_q1

theorem imo1962_q1 : is_least {n | problem_predicate n} 153846 :=
⟨satisfied_by_153846, no_smaller_solutions⟩


/-
This is for experimentation with free objects. Given the type X, we construct
a free "Nat-module" with basis X.
-/

variable (X: Type)[DecidableEq X]

abbrev FormalSum : Type := List (Nat × X)

inductive BasicRel : FormalSum X  → FormalSum X   →  Prop where
| zeroCoeff (tail: FormalSum X)(x: X)(a : Nat)(h: a = 0):
        BasicRel  ((a, x):: tail) tail
| addCoeffs (a b: Nat)(x: X)(tail: FormalSum X):
        BasicRel  ((a, x) :: (b, x) :: tail) ((a + b, x) :: tail)
| cons (a: Nat)(x: X)(s₁ s₂ : FormalSum X):
        BasicRel  s₁ s₂ → BasicRel ((a, x) :: s₁) ((a, x) ::  s₂)
| swap (a₁ a₂: Nat)(x₁ x₂: X)(tail : FormalSum X):
        BasicRel  ((a₁, x₁) :: (a₂, x₂) :: tail)
                    ((a₂, x₂) :: (a₁, x₁) :: tail)

def FreeNatModuleAux := Quot (BasicRel X)

namespace FormalSum

def sum {X: Type} [DecidableEq X] (s: FormalSum X): FreeNatModuleAux X :=
      Quot.mk (BasicRel X) s

def equiv {X: Type} [DecidableEq X] (s₁ s₂: FormalSum X): Prop :=
      s₁.sum = s₂.sum

end FormalSum

infix:65 " ≃ " => FormalSum.equiv

open FormalSum

theorem cons_equiv_of_equiv{X: Type}[DecidableEq X] (s₁ s₂ : FormalSum X) (a: Nat) (x: X):
      s₁ ≃ s₂ → (a, x) :: s₁ ≃ (a, x) :: s₂  := by
        intro h
        let f : FormalSum X → FreeNatModuleAux X :=
            fun s => sum <| (a, x) :: s
        let wit : (s₁ s₂ : FormalSum X) → (BasicRel X s₁ s₂) → f s₁ = f s₂ :=
            by
            intro s₁ s₂ hyp
            apply Quot.sound
            apply BasicRel.cons
            assumption
        let g := Quot.lift f wit
        let factorizes :
            (s : FormalSum X) → g (s.sum) =
              sum ((a, x) :: s) := Quot.liftBeta f wit
        rw[equiv]
        rw [← factorizes]
        rw [← factorizes]
        rw [h]

def monomCoeff {X: Type}[DecidableEq X](x₀ : X) (nx : Nat × X) : Nat :=
  match  (nx.2 == x₀) with
  | true => nx.1
  | false => 0

theorem monom_coeff_hom (x₀ x : X)(a b : Nat) :
    monomCoeff x₀ (a + b, x) = monomCoeff x₀ (a, x) + monomCoeff x₀ (b, x) := by
    repeat (rw [monomCoeff])
    cases x==x₀ <;> rfl

theorem monom_coeff_at_zero (x₀ x : X) : monomCoeff x₀ (0, x) = 0 :=
    by
      rw [monomCoeff]
      cases x==x₀ <;> rfl

def FormalSum.coeff{X: Type}[DecidableEq X](x₀ : X) : FormalSum X → Nat
| [] => 0
| h :: l => (monomCoeff x₀ h) + (coeff x₀ l)

def FormalSum.coords{X: Type}[DecidableEq X](s: FormalSum X):
        X → Nat := fun x => s.coeff x

theorem coeff_move_invariant (x₀ : X)(s₁ s₂: FormalSum X)(h: BasicRel X s₁ s₂):
        coeff  x₀  s₁ = coeff  x₀ s₂ := by
          induction h with
          | zeroCoeff tail x a hyp => simp [coeff, hyp, monom_coeff_at_zero]
          | addCoeffs a b x tail =>
            simp [coeff, monom_coeff_at_zero, ← Nat.add_assoc, monom_coeff_hom]
          | cons a x s₁ s₂ r step =>
            simp [coeff, step]
          | swap a₁ a₂ x₁ x₂ tail =>
            simp [coeff, ← Nat.add_assoc, Nat.add_comm]

def FreeNatModuleAux.coeff (x₀ : X) : FreeNatModuleAux X → Nat :=
      Quot.lift (FormalSum.coeff  x₀) (coeff_move_invariant X x₀)

theorem coeff_factors (x: X)(s: FormalSum X):
      FreeNatModuleAux.coeff X x (sum s) = coeff x s := by
      simp [FreeNatModuleAux.coeff]
      apply Quot.liftBeta
      apply coeff_move_invariant

theorem coeff_well_defined (x: X)(s₁ s₂: FormalSum X):
      s₁ ≃ s₂ → (coeff x s₁) = (coeff x s₂) := by
        intro hyp
        simp [← coeff_factors, FreeNatModuleAux.coeff]
        rw [hyp]

theorem pos_coeff_has_complement (x₀ : X)(s : FormalSum X) :
        0 < s.coeff x₀  →
          (∃ ys: FormalSum X,
            (((s.coeff x₀, x₀) :: ys) ≃ s) ∧
            (List.length ys < s.length))  := by
            induction s with
            | nil =>
              intro contra
              contradiction
            | cons head tail hyp =>
              let (a, x) := head
              intro pos
              cases c:x == x₀ with
              | true =>
                let k := coeff x₀ tail
                have lem : a + k =
                      coeff x₀ ((a, x) :: tail) :=
                        by rw [coeff, monomCoeff, c]
                have c'' : x = x₀ :=
                        of_decide_eq_true c
                rw [c'']
                rw [c''] at lem
                cases c':k with
                | zero =>
                  have lIneq : tail.length < List.length ((a, x) :: tail) :=
                    by
                      simp [List.length_cons]
                      apply Nat.le_refl
                  rw [c', Nat.add_zero] at lem
                  rw [← lem]
                  exact ⟨tail, rfl, lIneq⟩
                | succ k' =>
                  have pos : 0  < k := by
                    rw [c']
                    apply Nat.zero_lt_succ
                  let ⟨ys, eqnStep, lIneqStep⟩ := hyp pos
                  have eqn₁ :
                    (a, x₀) :: (k, x₀) :: ys ≃ (a + k, x₀) :: ys := by
                    apply Quot.sound
                    apply BasicRel.addCoeffs
                  have eqn₂ :
                  (a, x₀) :: (k, x₀) :: ys ≃ (a, x₀) :: tail :=
                    by
                      apply cons_equiv_of_equiv
                      assumption
                  have eqn : (a + k, x₀) :: ys ≃
                          (a, x₀) :: tail :=
                      Eq.trans (Eq.symm eqn₁) eqn₂
                  rw [← lem]
                  have lIneq : ys.length < List.length ((a, x₀) :: tail) :=
                    by
                    apply Nat.le_trans lIneqStep
                    simp [List.length_cons, Nat.le_succ]
                  exact ⟨ys, eqn, lIneq⟩
              | false =>
                let k := coeff x₀ tail
                have lem : k =
                      coeff x₀ ((a, x) :: tail) :=
                        by
                          simp [coeff, monomCoeff, c, Nat.zero_add]
                rw [← lem] at pos
                let ⟨ys', eqnStep, lIneqStep⟩ := hyp pos
                rw [← lem]
                let ys := (a, x) :: ys'
                have lIneq : ys.length < ((a, x) :: tail).length :=
                  by
                    simp [List.length_cons]
                    apply Nat.succ_lt_succ
                    exact lIneqStep
                have eqn₁ :
                  (k, x₀) :: ys ≃ (a, x) :: (k, x₀) :: ys' := by
                    apply Quot.sound
                    apply BasicRel.swap
                have eqn₂ :
                  (a, x) :: (k, x₀) :: ys' ≃ (a, x) :: tail :=
                    by
                      apply cons_equiv_of_equiv
                      assumption
                have eqn : (k, x₀) :: ys ≃ (a, x) :: tail := by
                    exact Eq.trans eqn₁ eqn₂
                exact ⟨ys, eqn, lIneq⟩
termination_by _ s => s.length

theorem equiv_e_of_zero_coeffs{X: Type}[DecidableEq X](s: FormalSum X)
               (hyp :∀ x: X, s.coeff x = 0) : s ≃ [] :=
               match s with
               | [] => rfl
               | h :: t => by
                let (a₀, x₀) := h
                let hyp₀ := hyp x₀
                rw [coeff] at hyp₀
                have c₀ : monomCoeff x₀ (a₀, x₀) = a₀ := by
                    simp [monomCoeff]
                rw [c₀] at hyp₀
                have hyp₁ : a₀ + coeff x₀ t
                    - (coeff x₀ t ) = 0 - coeff x₀ t  :=
                      congrArg (fun m => m - coeff x₀ t ) hyp₀
                simp [Nat.add_sub_cancel] at hyp₁
                rw [hyp₁]
                let tailCoeffs : (x: X) → coeff x t = 0 :=
                      by
                        intro x
                        let hx := hyp x
                        rw [coeff, Nat.add_comm] at hx
                        let hx' :=
                          congrArg (fun m => m - (monomCoeff x (a₀, x₀)) ) hx
                        simp [Nat.add_sub_cancel] at hx'
                        exact hx'
                let step := equiv_e_of_zero_coeffs t tailCoeffs
                let l₀ : (0, x₀) :: t ≃ t :=
                   Quot.sound <| BasicRel.zeroCoeff  t x₀ 0 rfl
                exact Eq.trans l₀ step

theorem equiv_of_equal_coeffs{X: Type}[DecidableEq X](s₁ s₂: FormalSum X)
               (hyp :∀ x: X, s₁.coeff x = s₂.coeff x) : s₁ ≃ s₂ :=
               match mt:s₁ with
               | [] =>
                have coeffs : ∀ x: X, s₂.coeff x = 0 := by
                  intro x
                  let h := hyp x
                  rw [← h]
                  rfl
                let zl := equiv_e_of_zero_coeffs s₂ coeffs
                Eq.symm zl
               | h :: t =>
                  let (a₀, x₀):= h
                  by
                  cases Nat.eq_zero_or_pos a₀ with
                  | inr p =>
                    let a₁ := coeff x₀ t
                    cases Nat.eq_zero_or_pos a₁ with
                    | inr p₁ =>
                        let ⟨ys, eqn, ineqn⟩ :=
                          pos_coeff_has_complement X x₀ t p₁
                        let s₃ := (a₀ + a₁, x₀) :: ys
                        have eq₁ : (a₀, x₀) :: (a₁ , x₀) :: ys ≃ s₃ := by
                          apply Quot.sound
                          let lem := BasicRel.addCoeffs a₀ a₁ x₀ ys
                          exact lem
                        have eq₂ : (a₀, x₀) :: (a₁ , x₀) :: ys ≃
                            (a₀, x₀) :: t := by
                              apply cons_equiv_of_equiv
                              assumption
                        have eq₃ : s₃ ≃ s₂ := by
                          have bd : ys.length + 1 < t.length + 1 :=
                            by
                              apply Nat.succ_lt_succ
                              exact ineqn
                          apply equiv_of_equal_coeffs
                          intro x
                          rw [← hyp x]
                          simp [coeff]
                          let d := coeff_well_defined X x _ _ eqn
                          rw [coeff] at d
                          rw [← d]
                          simp [monom_coeff_hom, coeff, Nat.add_assoc]
                        apply Eq.trans (Eq.trans (Eq.symm eq₂) eq₁) eq₃
                    | inl p₁' =>
                        have cf₂ : s₂.coeff x₀ = a₀ := by
                          rw [← hyp]
                          simp [coeff, p₁', Nat.add_zero, monomCoeff]
                        let ⟨ys, eqn, ineqn⟩ :=
                          pos_coeff_has_complement X x₀ s₂ (by
                            rw [cf₂]
                            assumption)
                        let cfs := fun x =>
                          coeff_well_defined X x _ _ eqn
                        rw [cf₂] at cfs
                        let cfs' := fun (x: X) =>
                          Eq.trans (hyp x) (Eq.symm (cfs x))
                        simp [coeff] at cfs'
                        let cs'' : ∀ x: X,
                            coeff x t = ys.coeff x := by
                              intro x
                              apply Nat.add_left_cancel (cfs' x)
                        let step :=
                          equiv_of_equal_coeffs t ys cs''
                        let step' := cons_equiv_of_equiv t ys a₀ x₀ step
                        rw [cf₂] at eqn
                        exact Eq.trans step' eqn
                  | inl p' =>
                    have eq₁ : (a₀, x₀) :: t ≃ t := by
                        apply Quot.sound
                        rw [p']
                        apply BasicRel.zeroCoeff
                        rfl
                    have eq₂ : t ≃ s₂ := by
                      apply equiv_of_equal_coeffs t s₂
                      intro x
                      let ceq := coeff_well_defined X x ((a₀, x₀) :: t) t eq₁
                      simp [← ceq, hyp]
                    exact Eq.trans eq₁ eq₂
termination_by _ X s _ _  => s.length

def FormalSum.support{X: Type}[DecidableEq X](s: FormalSum X) : List X :=
        s.map <| fun (_, x) => x

theorem pos_coeff_in_support{X: Type}[DecidableEq X](s: FormalSum X) :
        ∀ x: X, 0 < s.coeff x  → x ∈ s.support  :=
          match s with
          | [] => fun x hyp =>
            by
              have d : coeff x [] = 0 := by rfl
              rw [d] at hyp
              contradiction
          | h :: t =>
            by
            intro x hyp
            let (a₀, x₀) := h
            have d : support ((a₀, x₀) :: t) =
              x₀ :: (support t) := by rfl
            rw [d]
            match p:x₀ == x with
            | true =>
                have eqn : x₀ = x := of_decide_eq_true p
                rw [eqn]
                apply List.mem_of_elem_eq_true
                simp [List.elem]
            | false =>
                rw [coeff, monomCoeff, p, Nat.zero_add] at hyp
                let step := pos_coeff_in_support t x hyp
                apply List.mem_of_elem_eq_true
                simp [List.elem]
                have p' : (x == x₀) = false :=
                      by
                        have eqn := of_decide_eq_false p
                        have eqn' : ¬ (x = x₀) := by
                            intro contra
                            let contra' := Eq.symm contra
                            contradiction
                        exact decide_eq_false eqn'
                rw [p']
                apply List.elem_eq_true_of_mem
                exact step

def equalOnSupport{X: Type}[DecidableEq X](l: List X)(f g : X → Nat) : Prop :=
  match l with
  | [] => true
  | h :: t =>
    (f h = g h) ∧ (equalOnSupport t f g)

theorem equal_on_support_of_equal{X: Type}[DecidableEq X]
  (l: List X)(f g : X → Nat):
    f = g → equalOnSupport l f g := by
    intro hyp
    induction l with
    | nil =>
      rw [equalOnSupport]
    | cons h t step =>
      rw [equalOnSupport]
      apply And.intro
      rw [hyp]
      exact step

theorem mem_of_equal_on_support{X: Type}[DecidableEq X](l: List X)
    (f g : X → Nat)(x : X)(mhyp: x ∈ l) :
      equalOnSupport l f g →  f x = g x :=
    match l with
    | [] => by contradiction
    | h :: t => by
      intro hyp
      simp [equalOnSupport] at hyp
      cases mhyp
      exact hyp.left
      have inTail : x ∈ t := by assumption
      have step := mem_of_equal_on_support t f g x inTail hyp.right
      exact step

def decideEqualOnSupport{X: Type}[DecidableEq X](l: List X)(f g : X → Nat) :
      Decidable (equalOnSupport l f g) :=
  match l with
  | [] =>
    Decidable.isTrue (by simp [equalOnSupport])
  | h :: t => by
    simp [equalOnSupport]
    cases (decideEqualOnSupport t f g) with
    | isTrue hs =>
        exact (
          if c:f h = g h then (Decidable.isTrue ⟨c, hs⟩)
          else by
            apply Decidable.isFalse
            intro contra
            have contra' := contra.left
            contradiction
        )
    | isFalse hs =>
       apply Decidable.isFalse
       intro contra
       have contra' := contra.right
       contradiction

instance {X: Type}[DecidableEq X]{l: List X}{f g : X → Nat} :
    Decidable (equalOnSupport l f g) := decideEqualOnSupport l f g

-- Setoid using coordinate equality
def eqlCoords(s₁ s₂ : FormalSum X) : Prop :=
        s₁.coords = s₂.coords

namespace eqlCoords

theorem refl{X: Type}[DecidableEq X](s: FormalSum X) :
      eqlCoords X s s := by
        rfl

theorem symm{X: Type}[DecidableEq X]{s₁ s₂ : FormalSum X} :
    eqlCoords X s₁ s₂ → eqlCoords X s₂ s₁ := by
    intro hyp
    apply funext
    intro x
    apply Eq.symm
    exact congrFun hyp x

theorem trans{X: Type}[DecidableEq X]{s₁ s₂ s₃ : FormalSum X}:
    eqlCoords X s₁ s₂ → eqlCoords X s₂ s₃ → eqlCoords X s₁ s₃ := by
    intro hyp₁ hyp₂
    apply funext
    intro x
    have l₁ := congrFun hyp₁ x
    have l₂ := congrFun hyp₂ x
    exact Eq.trans l₁ l₂

theorem is_equivalence{X: Type}[DecidableEq X] :
      Equivalence (eqlCoords X) :=
      {refl := refl, symm := symm, trans := trans}

end eqlCoords

instance formalSumSetoid:
    Setoid (FormalSum X) := ⟨eqlCoords X, eqlCoords.is_equivalence⟩

def FreeNatModule := Quotient (formalSumSetoid X)

theorem func_eql_of_move_equiv{X: Type}[DecidableEq X]{β : Sort u}
  (f : FormalSum X → β):
  (∀ s₁ s₂ : FormalSum X, ∀ mv : BasicRel X s₁ s₂, f s₁ = f s₂) →
  (∀ s₁ s₂ : FormalSum X, s₁ ≈ s₂ →  f s₁ = f s₂) := by
  intro hyp
  let fbar : FreeNatModuleAux X → β :=
      Quot.lift f hyp
  let fct : ∀ s : FormalSum X, f s = fbar (sum s) := by
      apply Quot.liftBeta
      apply hyp
  intro s₁ s₂ sim
  have ec : eqlCoords X s₁ s₂ := sim
  rw [eqlCoords] at ec
  have pullback: sum s₁ = sum s₂ := by
    apply equiv_of_equal_coeffs
    intro x
    exact congrFun ec x
  simp [fct, pullback]

def linear_extension{X: Type}[DecidableEq X](f₀ : X → Nat) : FormalSum X → Nat
| [] => 0
| h :: t =>
      let (a, x) := h
      a * f₀ x + (linear_extension f₀ t)
termination_by _ _ s => s.length

open BasicRel
theorem invariance_of_linear_extension{X: Type}[DecidableEq X](f₀ : X → Nat) :
    (∀ s₁ s₂ : FormalSum X, ∀ rel : BasicRel X s₁ s₂, linear_extension f₀ s₁ = linear_extension f₀ s₂) :=
    fun s₁ s₂ rel =>
  match rel with
  | zeroCoeff tail x a hyp => by
    rw [hyp]
    simp [linear_extension]
  | addCoeffs a b x tail   => by
    simp [linear_extension, ← Nat.add_assoc]
    have step : a * f₀ x + b * f₀ x = (a + b) * f₀ x :=
      by simp [Nat.right_distrib]
    rw [← step]
  | cons a x t₁ t₂ r       => by
    simp [linear_extension, ← Nat.add_assoc]
    let ih := invariance_of_linear_extension f₀ t₁ t₂ r
    rw [ih]
  | swap a₁ a₂ x₁ x₂ tail  => by
    simp [linear_extension, ← Nat.add_assoc]
    have step : a₁ * f₀ x₁ + a₂ * f₀ x₂ = a₂ * f₀ x₂ + a₁ * f₀ x₁ :=
        by simp [Nat.add_comm]
    rw [step]

def miniUniversalProperty{X: Type}[DecidableEq X](f₀ : X → Nat) :
    FreeNatModule X → Nat := by
      apply Quotient.lift (linear_extension f₀)
      apply func_eql_of_move_equiv
      apply invariance_of_linear_extension

notation "⟦" a "⟧" => Quotient.mk' a

def decideEqualQuotient{X: Type}[DecidableEq X](s₁ s₂ : FormalSum X) :
  Decidable ( ⟦ s₁ ⟧ = ⟦ s₂ ⟧ )  :=
        if ch₁ : equalOnSupport s₁.support s₁.coords s₂.coords then
          if ch₂ : equalOnSupport s₂.support s₁.coords s₂.coords then
            Decidable.isTrue (
              by
              apply Quotient.sound
              apply funext
              intro x
              cases (Nat.eq_zero_or_pos <| s₁.coords x) with
              | inl hz₁ =>
                  cases (Nat.eq_zero_or_pos <| s₂.coords x) with
                | inl hz₂ =>
                    rw [hz₁, hz₂]
                | inr hp =>
                  have lem : x ∈ s₂.support := by
                      apply pos_coeff_in_support
                      assumption
                  let lem' :=
                    mem_of_equal_on_support s₂.support s₁.coords s₂.coords x lem ch₂
                  exact lem'
              | inr hp =>
                have lem : x ∈ s₁.support := by
                    apply pos_coeff_in_support
                    assumption
                let lem' :=
                  mem_of_equal_on_support s₁.support s₁.coords s₂.coords x lem ch₁
                exact lem'
              )
          else
            Decidable.isFalse (
              by
                intro contra
                let lem :=
                  equal_on_support_of_equal
                    s₂.support s₁.coords s₂.coords (Quotient.exact contra)
                contradiction
            )
        else
          Decidable.isFalse (
            by
              intro contra
              let lem :=
                  equal_on_support_of_equal
                    s₁.support s₁.coords s₂.coords (Quotient.exact contra)
              contradiction
          )

instance {X: Type}[DecidableEq X]{s₁ s₂ : FormalSum X} :
  Decidable ( ⟦ s₁ ⟧ = ⟦ s₂ ⟧ ) := decideEqualQuotient s₁ s₂

def FreeNatModule.beq?{X: Type}[DecidableEq X]
    (x₁ x₂ : FreeNatModule X) : Bool := by
    apply Quotient.lift₂ (fun (s₁ s₂ : FormalSum X) =>
          decide ( ⟦ s₁ ⟧ = ⟦ s₂ ⟧))
    intro a₁ b₁ a₂ b₂ eqv₁ eqv₂
    let eq₁ : ⟦ a₁ ⟧ = ⟦ a₂ ⟧ := Quot.sound eqv₁
    let eq₂ : ⟦ b₁⟧ = ⟦ b₂ ⟧ := Quot.sound eqv₂
    simp [eq₁, eq₂]
    exact x₁
    exact x₂

def FreeNatModule.eq_of_beq_true{X: Type}[DecidableEq X]:
    ∀ x₁ x₂ : FreeNatModule X,  x₁.beq? x₂ = true → x₁ = x₂ := by
    let f := @Quotient.ind₂ (FormalSum X) (FormalSum X)
              (formalSumSetoid X) (formalSumSetoid X)
              (fun (x₁ x₂ : FreeNatModule X) =>   x₁.beq? x₂ = true → x₁ = x₂)
    apply f
    intro s₁ s₂ eqv
    let eql := of_decide_eq_true eqv
    assumption

def FreeNatModule.neq_of_beq_false{X: Type}[DecidableEq X]:
    ∀ x₁ x₂ : FreeNatModule X,  x₁.beq? x₂ = false → Not (x₁ = x₂) := by
    let f := @Quotient.ind₂ (FormalSum X) (FormalSum X)
              (formalSumSetoid X) (formalSumSetoid X)
              (fun (x₁ x₂ : FreeNatModule X) =>   x₁.beq? x₂ = false →
                Not (x₁ = x₂))
    apply f
    intro s₁ s₂ neqv
    let neql := of_decide_eq_false neqv
    assumption

def FreeNatModule.decEq{X: Type}[DecidableEq X]
    (x₁ x₂ : FreeNatModule X) : Decidable (x₁ = x₂) := by
    match p:x₁.beq? x₂ with
    | true =>
      apply Decidable.isTrue
      apply FreeNatModule.eq_of_beq_true
      assumption
    | false =>
      apply Decidable.isFalse
      apply FreeNatModule.neq_of_beq_false
      assumption

instance {X: Type}[DecidableEq X]: DecidableEq (FreeNatModule X) :=
  fun x₁ x₂ => x₁.decEq x₂