import category_theory.category category_theory.epi_mono tactic-- this transitively imports

open category_theory

universes v u

variables (C : Type u) [category.{v} C]

/-Prove Lemma 1.2.11 by proving either (i) or (i') and either (ii) or (i'),
then arguing by duality. Conclude that the monomorphisms in any category
define a subcategory of that category and dually that the epimorphisms also
define a subcategory. -/

/-Lemma 1.2.11(i) If f : x ⟶ y and g : y ⟶ z are monomorphisms, then so is
gf : x ⟶ z.-/

lemma mono_comp_mono (X Y Z : C) (f : X ⟶ Y) (g : Y ⟶ Z) [hg : mono g] [hf : mono f]:
mono (f ≫ g) :=
begin
    constructor, --what the heck this is so useful
    intros Z h k hcomp,
    repeat {rw ← category.assoc at hcomp},
    rw cancel_mono g at hcomp,
    rw cancel_mono f at hcomp,
    exact hcomp,
end

/-Lemma 1.2.11(ii) If f : x ⟶ y and g : y ⟶ z are morphisms so that gf is monic,
then f is monic. -/

lemma comp_mono_mono (X Y Z : C) (f : X ⟶ Y) (g : Y ⟶ Z) [hfg : mono (f ≫ g)]:
mono f :=
begin
    constructor,
    intros Z h k hf,
    rw ← cancel_mono (f ≫ g),
    repeat {rw ← category.assoc},
    rw hf,
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 data.nat.lattice
import logic.denumerable
import logic.function.iterate
import order.hom.basic

/-!
# Relation embeddings from the naturals

This file allows translation from monotone functions `ℕ → α` to order embeddings `ℕ ↪ α` and
defines the limit value of an eventually-constant sequence.

## Main declarations

* `nat_lt`/`nat_gt`: Make an order embedding `ℕ ↪ α` from an increasing/decreasing function `ℕ → α`.
* `monotonic_sequence_limit`: The limit of an eventually-constant monotone sequence `ℕ →o α`.
* `monotonic_sequence_limit_index`: The index of the first occurence of `monotonic_sequence_limit`
  in the sequence.
-/
namespace rel_embedding

variables {α : Type*} {r : α → α → Prop} [is_strict_order α r]

/-- If `f` is a strictly `r`-increasing sequence, then this returns `f` as an order embedding. -/
def nat_lt (f : ℕ → α) (H : ∀ n : ℕ, r (f n) (f (n + 1))) :
  ((<) : ℕ → ℕ → Prop) ↪r r :=
of_monotone f $ nat.rel_of_forall_rel_succ_of_lt r H

@[simp]
lemma nat_lt_apply {f : ℕ → α} {H : ∀ n : ℕ, r (f n) (f (n + 1))} {n : ℕ} :
  nat_lt f H n = f n :=
rfl

/-- If `f` is a strictly `r`-decreasing sequence, then this returns `f` as an order embedding. -/
def nat_gt (f : ℕ → α) (H : ∀ n : ℕ, r (f (n + 1)) (f n)) :
  ((>) : ℕ → ℕ → Prop) ↪r r :=
by haveI := is_strict_order.swap r; exact rel_embedding.swap (nat_lt f H)

theorem well_founded_iff_no_descending_seq :
  well_founded r ↔ is_empty (((>) : ℕ → ℕ → Prop) ↪r r) :=
⟨λ ⟨h⟩, ⟨λ ⟨f, o⟩,
  suffices ∀ a, acc r a → ∀ n, a ≠ f n, from this (f 0) (h _) 0 rfl,
  λ a ac, begin
    induction ac with a _ IH,
    rintro n rfl,
    exact IH (f (n+1)) (o.2 (nat.lt_succ_self _)) _ rfl
  end⟩,
λ E, ⟨λ a, classical.by_contradiction $ λ na,
  let ⟨f, h⟩ := classical.axiom_of_choice $
    show ∀ x : {a // ¬ acc r a}, ∃ y : {a // ¬ acc r a}, r y.1 x.1,
    from λ ⟨x, h⟩, classical.by_contradiction $ λ hn, h $
      ⟨_, λ y h, classical.by_contradiction $ λ na, hn ⟨⟨y, na⟩, h⟩⟩ in
  E.elim' (nat_gt (λ n, (f^[n] ⟨a, na⟩).1) $ λ n,
    by { rw [function.iterate_succ'], apply h })⟩⟩

end rel_embedding

namespace nat
variables (s : set ℕ) [decidable_pred (∈ s)] [infinite s]

/-- An order embedding from `ℕ` to itself with a specified range -/
def order_embedding_of_set : ℕ ↪o ℕ :=
(rel_embedding.order_embedding_of_lt_embedding
  (rel_embedding.nat_lt (nat.subtype.of_nat s) (λ n, nat.subtype.lt_succ_self _))).trans
  (order_embedding.subtype s)

/-- `nat.subtype.of_nat` as an order isomorphism between `ℕ` and an infinite decidable subset.
See also `nat.nth` for a version where the subset may be finite. -/
noncomputable def subtype.order_iso_of_nat  :
  ℕ ≃o s :=
rel_iso.of_surjective (rel_embedding.order_embedding_of_lt_embedding
  (rel_embedding.nat_lt (nat.subtype.of_nat s) (λ n, nat.subtype.lt_succ_self _)))
  nat.subtype.of_nat_surjective

variable {s}

@[simp]
lemma coe_order_embedding_of_set : ⇑(order_embedding_of_set s) = coe ∘ subtype.of_nat s := rfl

lemma order_embedding_of_set_apply {n : ℕ} : order_embedding_of_set s n = subtype.of_nat s n := rfl

@[simp]
lemma subtype.order_iso_of_nat_apply {n : ℕ} :
  subtype.order_iso_of_nat s n = subtype.of_nat s n :=
by { simp [subtype.order_iso_of_nat] }

variable (s)

lemma order_embedding_of_set_range : set.range (nat.order_embedding_of_set s) = s :=
subtype.coe_comp_of_nat_range

theorem exists_subseq_of_forall_mem_union {α : Type*} {s t : set α} (e : ℕ → α)
  (he : ∀ n, e n ∈ s ∪ t) :
  ∃ g : ℕ ↪o ℕ, (∀ n, e (g n) ∈ s) ∨ (∀ n, e (g n) ∈ t) :=
begin
  classical,
  have : infinite (e ⁻¹' s) ∨ infinite (e ⁻¹' t),
    by simp only [set.infinite_coe_iff, ← set.infinite_union, ← set.preimage_union,
      set.eq_univ_of_forall (λ n, set.mem_preimage.2 (he n)), set.infinite_univ],
  casesI this,
  exacts [⟨nat.order_embedding_of_set (e ⁻¹' s), or.inl $ λ n, (nat.subtype.of_nat (e ⁻¹' s) _).2⟩,
    ⟨nat.order_embedding_of_set (e ⁻¹' t), or.inr $ λ n, (nat.subtype.of_nat (e ⁻¹' t) _).2⟩]
end

end nat

theorem exists_increasing_or_nonincreasing_subseq' {α : Type*} (r : α → α → Prop) (f : ℕ → α) :
  ∃ (g : ℕ ↪o ℕ), (∀ n : ℕ, r (f (g n)) (f (g (n + 1)))) ∨
    (∀ m n : ℕ, m < n → ¬ r (f (g m)) (f (g n))) :=
begin
  classical,
  let bad : set ℕ := { m | ∀ n, m < n → ¬ r (f m) (f n) },
  by_cases hbad : infinite bad,
  { haveI := hbad,
    refine ⟨nat.order_embedding_of_set bad, or.intro_right _ (λ m n mn, _)⟩,
    have h := set.mem_range_self m,
    rw nat.order_embedding_of_set_range bad at h,
    exact h _ ((order_embedding.lt_iff_lt _).2 mn) },
  { rw [set.infinite_coe_iff, set.infinite, not_not] at hbad,
    obtain ⟨m, hm⟩ : ∃ m, ∀ n, m ≤ n → ¬ n ∈ bad,
    { by_cases he : hbad.to_finset.nonempty,
      { refine ⟨(hbad.to_finset.max' he).succ, λ n hn nbad, nat.not_succ_le_self _
        (hn.trans (hbad.to_finset.le_max' n (hbad.mem_to_finset.2 nbad)))⟩ },
      { exact ⟨0, λ n hn nbad, he ⟨n, hbad.mem_to_finset.2 nbad⟩⟩ } },
    have h : ∀ (n : ℕ), ∃ (n' : ℕ), n < n' ∧ r (f (n + m)) (f (n' + m)),
    { intro n,
      have h := hm _ (le_add_of_nonneg_left n.zero_le),
      simp only [exists_prop, not_not, set.mem_set_of_eq, not_forall] at h,
      obtain ⟨n', hn1, hn2⟩ := h,
      obtain ⟨x, hpos, rfl⟩ := exists_pos_add_of_lt hn1,
      refine ⟨n + x, add_lt_add_left hpos n, _⟩,
      rw [add_assoc, add_comm x m, ← add_assoc],
      exact hn2 },
    let g' : ℕ → ℕ := @nat.rec (λ _, ℕ) m (λ n gn, nat.find (h gn)),
    exact ⟨(rel_embedding.nat_lt (λ n, g' n + m)
      (λ n, nat.add_lt_add_right (nat.find_spec (h (g' n))).1 m)).order_embedding_of_lt_embedding,
      or.intro_left _ (λ n, (nat.find_spec (h (g' n))).2)⟩ }
end

/-- This is the infinitary Erdős–Szekeres theorem, and an important lemma in the usual proof of
    Bolzano-Weierstrass for `ℝ`. -/
theorem exists_increasing_or_nonincreasing_subseq
  {α : Type*} (r : α → α → Prop) [is_trans α r] (f : ℕ → α) :
  ∃ (g : ℕ ↪o ℕ), (∀ m n : ℕ, m < n → r (f (g m)) (f (g n))) ∨
    (∀ m n : ℕ, m < n → ¬ r (f (g m)) (f (g n))) :=
begin
  obtain ⟨g, hr | hnr⟩ := exists_increasing_or_nonincreasing_subseq' r f,
  { refine ⟨g, or.intro_left _ (λ m n mn, _)⟩,
    obtain ⟨x, rfl⟩ := le_iff_exists_add.1 (nat.succ_le_iff.2 mn),
    induction x with x ih,
    { apply hr },
    { apply is_trans.trans _ _ _ _ (hr _),
      exact ih (lt_of_lt_of_le m.lt_succ_self (nat.le_add_right _ _)) } },
  { exact ⟨g, or.intro_right _ hnr⟩ }
end

/-- The "monotone chain condition" below is sometimes a convenient form of well foundedness. -/
lemma well_founded.monotone_chain_condition (α : Type*) [partial_order α] :
  well_founded ((>) : α → α → Prop) ↔ ∀ (a : ℕ →o α), ∃ n, ∀ m, n ≤ m → a n = a m :=
begin
  split; intros h,
  { rw well_founded.well_founded_iff_has_max' at h,
    intros a, have hne : (set.range a).nonempty, { use a 0, simp, },
    obtain ⟨x, ⟨n, hn⟩, range_bounded⟩ := h _ hne,
    use n, intros m hm, rw ← hn at range_bounded, symmetry,
    apply range_bounded (a m) (set.mem_range_self _) (a.monotone hm), },
  { rw rel_embedding.well_founded_iff_no_descending_seq, refine ⟨λ a, _⟩,
    obtain ⟨n, hn⟩ := h (a.swap : ((<) : ℕ → ℕ → Prop) →r ((<) : α → α → Prop)).to_order_hom,
    exact n.succ_ne_self.symm (rel_embedding.to_order_hom_injective _ (hn _ n.le_succ)), },
end

/-- Given an eventually-constant monotone sequence `a₀ ≤ a₁ ≤ a₂ ≤ ...` in a partially-ordered
type, `monotonic_sequence_limit_index a` is the least natural number `n` for which `aₙ` reaches the
constant value. For sequences that are not eventually constant, `monotonic_sequence_limit_index a`
is defined, but is a junk value. -/
noncomputable def monotonic_sequence_limit_index {α : Type*} [preorder α] (a : ℕ →o α) : ℕ :=
Inf { n | ∀ m, n ≤ m → a n = a m }

/-- The constant value of an eventually-constant monotone sequence `a₀ ≤ a₁ ≤ a₂ ≤ ...` in a
partially-ordered type. -/
noncomputable def monotonic_sequence_limit {α : Type*} [preorder α] (a : ℕ →o α) :=
a (monotonic_sequence_limit_index a)

lemma well_founded.supr_eq_monotonic_sequence_limit {α : Type*} [complete_lattice α]
  (h : well_founded ((>) : α → α → Prop)) (a : ℕ →o α) :
  (⨆ m, a m) = monotonic_sequence_limit a :=
begin
  suffices : (⨆ (m : ℕ), a m) ≤ monotonic_sequence_limit a,
  { exact le_antisymm this (le_supr a _), },
  apply supr_le,
  intros m,
  by_cases hm : m ≤ monotonic_sequence_limit_index a,
  { exact a.monotone hm, },
  { replace hm := le_of_not_le hm,
    let S := { n | ∀ m, n ≤ m → a n = a m },
    have hInf : Inf S ∈ S,
    { refine nat.Inf_mem _, rw well_founded.monotone_chain_condition at h, exact h a, },
    change Inf S ≤ m at hm,
    change a m ≤ a (Inf S),
    rw hInf m hm, },
end


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

! This file was ported from Lean 3 source module ring_theory.power_series.well_known
! leanprover-community/mathlib commit 8199f6717c150a7fe91c4534175f4cf99725978f
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.RingTheory.PowerSeries.Basic
import Mathbin.Data.Nat.Parity
import Mathbin.Algebra.BigOperators.NatAntidiagonal

/-!
# Definition of well-known power series

In this file we define the following power series:

* `power_series.inv_units_sub`: given `u : Rˣ`, this is the series for `1 / (u - x)`.
  It is given by `∑ n, x ^ n /ₚ u ^ (n + 1)`.

* `power_series.sin`, `power_series.cos`, `power_series.exp` : power series for sin, cosine, and
  exponential functions.
-/

namespace PowerSeries

section Ring

variable {R S : Type _} [Ring R] [Ring S]

/-- The power series for `1 / (u - x)`. -/
def invUnitsSub (u : Rˣ) : PowerSeries R :=
  mk fun n => 1 /ₚ u ^ (n + 1)
#align power_series.inv_units_sub PowerSeries.invUnitsSub

@[simp]
theorem coeff_invUnitsSub (u : Rˣ) (n : ℕ) : coeff R n (invUnitsSub u) = 1 /ₚ u ^ (n + 1) :=
  coeff_mk _ _
#align power_series.coeff_inv_units_sub PowerSeries.coeff_invUnitsSub

@[simp]
theorem constantCoeff_invUnitsSub (u : Rˣ) : constantCoeff R (invUnitsSub u) = 1 /ₚ u := by
  rw [← coeff_zero_eq_constant_coeff_apply, coeff_inv_units_sub, zero_add, pow_one]
#align power_series.constant_coeff_inv_units_sub PowerSeries.constantCoeff_invUnitsSub

@[simp]
theorem invUnitsSub_mul_x (u : Rˣ) : invUnitsSub u * x = invUnitsSub u * c R u - 1 :=
  by
  ext (_ | n)
  · simp
  · simp [n.succ_ne_zero, pow_succ]
#align power_series.inv_units_sub_mul_X PowerSeries.invUnitsSub_mul_x

@[simp]
theorem invUnitsSub_mul_sub (u : Rˣ) : invUnitsSub u * (c R u - x) = 1 := by
  simp [mul_sub, sub_sub_cancel]
#align power_series.inv_units_sub_mul_sub PowerSeries.invUnitsSub_mul_sub

theorem map_invUnitsSub (f : R →+* S) (u : Rˣ) :
    map f (invUnitsSub u) = invUnitsSub (Units.map (f : R →* S) u) :=
  by
  ext
  simp [← map_pow]
#align power_series.map_inv_units_sub PowerSeries.map_invUnitsSub

end Ring

section Field

variable (A A' : Type _) [Ring A] [Ring A'] [Algebra ℚ A] [Algebra ℚ A']

open Nat

/-- Power series for the exponential function at zero. -/
def exp : PowerSeries A :=
  mk fun n => algebraMap ℚ A (1 / n !)
#align power_series.exp PowerSeries.exp

/-- Power series for the sine function at zero. -/
def sin : PowerSeries A :=
  mk fun n => if Even n then 0 else algebraMap ℚ A ((-1) ^ (n / 2) / n !)
#align power_series.sin PowerSeries.sin

/-- Power series for the cosine function at zero. -/
def cos : PowerSeries A :=
  mk fun n => if Even n then algebraMap ℚ A ((-1) ^ (n / 2) / n !) else 0
#align power_series.cos PowerSeries.cos

variable {A A'} (n : ℕ) (f : A →+* A')

@[simp]
theorem coeff_exp : coeff A n (exp A) = algebraMap ℚ A (1 / n !) :=
  coeff_mk _ _
#align power_series.coeff_exp PowerSeries.coeff_exp

@[simp]
theorem constantCoeff_exp : constantCoeff A (exp A) = 1 :=
  by
  rw [← coeff_zero_eq_constant_coeff_apply, coeff_exp]
  simp
#align power_series.constant_coeff_exp PowerSeries.constantCoeff_exp

@[simp]
theorem coeff_sin_bit0 : coeff A (bit0 n) (sin A) = 0 := by rw [sin, coeff_mk, if_pos (even_bit0 n)]
#align power_series.coeff_sin_bit0 PowerSeries.coeff_sin_bit0

@[simp]
theorem coeff_sin_bit1 : coeff A (bit1 n) (sin A) = (-1) ^ n * coeff A (bit1 n) (exp A) := by
  rw [sin, coeff_mk, if_neg n.not_even_bit1, Nat.bit1_div_two, ← mul_one_div, map_mul, map_pow,
    map_neg, map_one, coeff_exp]
#align power_series.coeff_sin_bit1 PowerSeries.coeff_sin_bit1

@[simp]
theorem coeff_cos_bit0 : coeff A (bit0 n) (cos A) = (-1) ^ n * coeff A (bit0 n) (exp A) := by
  rw [cos, coeff_mk, if_pos (even_bit0 n), Nat.bit0_div_two, ← mul_one_div, map_mul, map_pow,
    map_neg, map_one, coeff_exp]
#align power_series.coeff_cos_bit0 PowerSeries.coeff_cos_bit0

@[simp]
theorem coeff_cos_bit1 : coeff A (bit1 n) (cos A) = 0 := by
  rw [cos, coeff_mk, if_neg n.not_even_bit1]
#align power_series.coeff_cos_bit1 PowerSeries.coeff_cos_bit1

@[simp]
theorem map_exp : map (f : A →+* A') (exp A) = exp A' :=
  by
  ext
  simp
#align power_series.map_exp PowerSeries.map_exp

@[simp]
theorem map_sin : map f (sin A) = sin A' := by
  ext
  simp [sin, apply_ite f]
#align power_series.map_sin PowerSeries.map_sin

@[simp]
theorem map_cos : map f (cos A) = cos A' := by
  ext
  simp [cos, apply_ite f]
#align power_series.map_cos PowerSeries.map_cos

end Field

open RingHom

open Finset Nat

variable {A : Type _} [CommRing A]

/-- Shows that $e^{aX} * e^{bX} = e^{(a + b)X}$ -/
theorem exp_mul_exp_eq_exp_add [Algebra ℚ A] (a b : A) :
    rescale a (exp A) * rescale b (exp A) = rescale (a + b) (exp A) :=
  by
  ext
  simp only [coeff_mul, exp, rescale, coeff_mk, coe_mk, factorial,
    nat.sum_antidiagonal_eq_sum_range_succ_mk, add_pow, sum_mul]
  apply sum_congr rfl
  rintro x hx
  suffices
    a ^ x * b ^ (n - x) *
        (algebraMap ℚ A (1 / ↑x.factorial) * algebraMap ℚ A (1 / ↑(n - x).factorial)) =
      a ^ x * b ^ (n - x) * (↑(n.choose x) * (algebraMap ℚ A) (1 / ↑n.factorial))
    by convert this using 1 <;> ring
  congr 1
  rw [← map_natCast (algebraMap ℚ A) (n.choose x), ← map_mul, ← map_mul]
  refine' RingHom.congr_arg _ _
  rw [mul_one_div ↑(n.choose x) _, one_div_mul_one_div]
  symm
  rw [div_eq_iff, div_mul_eq_mul_div, one_mul, choose_eq_factorial_div_factorial]
  norm_cast
  rw [cast_div_char_zero]
  · apply factorial_mul_factorial_dvd_factorial (mem_range_succ_iff.1 hx)
  · apply mem_range_succ_iff.1 hx
  · rintro h
    apply factorial_ne_zero n
    rw [cast_eq_zero.1 h]
#align power_series.exp_mul_exp_eq_exp_add PowerSeries.exp_mul_exp_eq_exp_add

/-- Shows that $e^{x} * e^{-x} = 1$ -/
theorem exp_mul_exp_neg_eq_one [Algebra ℚ A] : exp A * evalNegHom (exp A) = 1 := by
  convert exp_mul_exp_eq_exp_add (1 : A) (-1) <;> simp
#align power_series.exp_mul_exp_neg_eq_one PowerSeries.exp_mul_exp_neg_eq_one

/-- Shows that $(e^{X})^k = e^{kX}$. -/
theorem exp_pow_eq_rescale_exp [Algebra ℚ A] (k : ℕ) : exp A ^ k = rescale (k : A) (exp A) :=
  by
  induction' k with k h
  ·
    simp only [rescale_zero, constant_coeff_exp, Function.comp_apply, map_one, cast_zero, pow_zero,
      coe_comp]
  simpa only [succ_eq_add_one, cast_add, ← exp_mul_exp_eq_exp_add (k : A), ← h, cast_one, id_apply,
    rescale_one] using pow_succ' (exp A) k
#align power_series.exp_pow_eq_rescale_exp PowerSeries.exp_pow_eq_rescale_exp

/-- Shows that
$\sum_{k = 0}^{n - 1} (e^{X})^k = \sum_{p = 0}^{\infty} \sum_{k = 0}^{n - 1} \frac{k^p}{p!}X^p$. -/
theorem exp_pow_sum [Algebra ℚ A] (n : ℕ) :
    ((Finset.range n).Sum fun k => exp A ^ k) =
      PowerSeries.mk fun p => (Finset.range n).Sum fun k => k ^ p * algebraMap ℚ A p.factorial⁻¹ :=
  by
  simp only [exp_pow_eq_rescale_exp, rescale]
  ext
  simp only [one_div, coeff_mk, coe_mk, coeff_exp, factorial, LinearMap.map_sum]
#align power_series.exp_pow_sum PowerSeries.exp_pow_sum

end PowerSeries


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.limits.shapes.finite_limits
import category_theory.limits.shapes.products

/-!
# Categories with finite (co)products

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

Typeclasses representing categories with (co)products over finite indexing types.
-/

universes w v u

open category_theory
open_locale classical

namespace category_theory.limits

variables (C : Type u) [category.{v} C]

/--
A category has finite products if there is a chosen limit for every diagram
with shape `discrete J`, where we have `[finite J]`.

We require this condition only for `J = fin n` in the definition, then deduce a version for any
`J : Type*` as a corollary of this definition.
-/
class has_finite_products : Prop :=
(out [] (n : ℕ) : has_limits_of_shape (discrete (fin n)) C)

/-- If `C` has finite limits then it has finite products. -/
@[priority 10]
instance has_finite_products_of_has_finite_limits [has_finite_limits C] :
  has_finite_products C :=
⟨λ n, infer_instance⟩

instance has_limits_of_shape_discrete [has_finite_products C] (ι : Type w) [finite ι] :
  has_limits_of_shape (discrete ι) C :=
begin
  rcases finite.exists_equiv_fin ι with ⟨n, ⟨e⟩⟩,
  haveI := has_finite_products.out C n,
  exact has_limits_of_shape_of_equivalence (discrete.equivalence e.symm)
end

/-- We can now write this for powers. -/
noncomputable example [has_finite_products C] (X : C) : C := ∏ (λ (i : fin 5), X)

/--
If a category has all products then in particular it has finite products.
-/
lemma has_finite_products_of_has_products [has_products.{w} C] : has_finite_products C :=
⟨λ n, has_limits_of_shape_of_equivalence (discrete.equivalence equiv.ulift.{w})⟩

/--
A category has finite coproducts if there is a chosen colimit for every diagram
with shape `discrete J`, where we have `[fintype J]`.

We require this condition only for `J = fin n` in the definition, then deduce a version for any
`J : Type*` as a corollary of this definition.
-/
class has_finite_coproducts : Prop :=
(out [] (n : ℕ) : has_colimits_of_shape (discrete (fin n)) C)

attribute [class] has_finite_coproducts

instance has_colimits_of_shape_discrete [has_finite_coproducts C] (ι : Type w) [finite ι] :
  has_colimits_of_shape (discrete ι) C :=
begin
  rcases finite.exists_equiv_fin ι with ⟨n, ⟨e⟩⟩,
  haveI := has_finite_coproducts.out C n,
  exact has_colimits_of_shape_of_equivalence (discrete.equivalence e.symm)
end

/-- If `C` has finite colimits then it has finite coproducts. -/
@[priority 10]
instance has_finite_coproducts_of_has_finite_colimits [has_finite_colimits C] :
  has_finite_coproducts C :=
⟨λ J, by apply_instance⟩

/--
If a category has all coproducts then in particular it has finite coproducts.
-/
lemma has_finite_coproducts_of_has_coproducts [has_coproducts.{w} C] : has_finite_coproducts C :=
⟨λ J, has_colimits_of_shape_of_equivalence (discrete.equivalence (equiv.ulift.{w}))⟩

end category_theory.limits


-- 5.4 Structuring Tactic Proofs

example (p q r : Prop) : p ∧ (q ∨ r) → (p ∧ q) ∨ (p ∧ r) :=
begin
  intro h,
  exact
    have hp : p, from h.left,
    have hqr : q ∨ r, from h.right,
    show (p ∧ q) ∨ (p ∧ r),
    begin
      cases hqr with hq hr,
        left, exact ⟨hp, hq⟩,
      right, exact ⟨hp, hr⟩,
    end
end

example (p q r : Prop) : p ∧ (q ∨ r) ↔ (p ∧ q) ∨ (p ∧ r) :=
begin
  apply iff.intro,
    intro h,
    cases h.right with hq hr,
      exact or.inl ⟨h.left, hq⟩,
    exact or.inr ⟨h.left, hr⟩,
  intro h,
  cases h with hpq hpr,
    exact ⟨hpq.left, or.inl hpq.right⟩,
  exact ⟨hpr.left, or.inr hpr.right⟩,
end

example (p q r : Prop) : p ∧ (q ∨ r) ↔ (p ∧ q) ∨ (p ∧ r) :=
begin
  apply iff.intro,
    intro h,
    cases h.right with hq hr,
      show (p ∧ q) ∨ (p ∧ r),
      from or.inl ⟨h.left, hq⟩,
    show (p ∧ q) ∨ (p ∧ r),
    from or.inr ⟨h.left, hr⟩,
  intro h,
  cases h with hpq hpr,
    show p ∧ (q ∨ r),
    from ⟨hpq.left, or.inl hpq.right⟩,
  show p ∧ (q ∨ r),
  from ⟨hpr.left, or.inr hpr.right⟩,
end

example (p q r : Prop) : p ∧ (q ∨ r) ↔ (p ∧ q) ∨ (p ∧ r) :=
begin
  apply iff.intro,
    intro h,
    cases h.right with hq hr,
      show (p ∧ q) ∨ (p ∧ r),
      { left, split, exact h.left, assumption },
    show (p ∧ q) ∨ (p ∧ r),
    {right, split, exact h.left, assumption },
  intro h,
  cases h with hpq hpr,
    show p ∧ (q ∨ r),
    { cases hpq, split, assumption, left, assumption },
  show p ∧ (q ∨ r),
  { cases hpr, split, assumption, right, assumption }
end

example (n : ℕ) : n + 1 = nat.succ n :=
begin
  show nat.succ n = nat.succ n,
  reflexivity,
end

example (p q : Prop) : p ∧ q → q ∧ p :=
begin
  intro h,
  cases h with hp hq,
  split,
    show q, from hq,
  show p, from hp,
end

example (p q : Prop) : p ∧ q → q ∧ p :=
begin
  intro h,
  cases h with hp hq,
  split,
    show p, from hp,
  show q, from hq,
end

example (p q r : Prop) : p ∧ (q ∨ r) → (p ∧ q) ∨ (p ∧ r) :=
begin
  intro h,
  cases h with hp hqr,
  show (p ∧ q) ∨ (p ∧ r),
  cases hqr with hq hr,
    have hpq : p ∧ q,
      from and.intro hp hq,
    left, exact hpq,
  have hpr : p ∧ r,
    from and.intro hp hr,
  right, exact hpr,
end

example (p q r : Prop) : p ∧ (q ∨ r) → (p ∧ q) ∨ (p ∧ r) :=
begin
  intro h,
  cases h with hp hqr,
  show (p ∧ q) ∨ (p ∧ r),
  cases hqr with hq hr,
    have hpq : p ∧ q,
      split; assumption,
    left, exact hpq,
  have hpr : p ∧ r,
    split; assumption,
  right, exact hpr,
end

example (p q r : Prop) : p ∧ (q ∨ r) → (p ∧ q) ∨ (p ∧ r) :=
begin
  intro h,
  cases h with hp hqr,
  show (p ∧ q) ∨ (p ∧ r),
  cases hqr with hq hr,
    have : p ∧ q,
      split; assumption,
    left, exact this,
  have : p ∧ r,
    split; assumption,
  right, exact this,
end

example (p q r : Prop) : p ∧ (q ∨ r) → (p ∧ q) ∨ (p ∧ r) :=
begin
  intro h,
  have hp : p := h.left,
  have hqr : q ∨ r := h.right,
  show (p ∧ q) ∨ (p ∧ r),
  cases hqr with hq hr,
    exact or.inl ⟨hp, hq⟩,
  exact or.inr ⟨hp, hr⟩,
end

example : ∃ x, x + 2 = 8 :=
begin
  let a : ℕ := 3 * 2,
  existsi a,
  reflexivity,
end

example (p q r : Prop) : p ∧ (q ∨ r) ↔ (p ∧ q) ∨ (p ∧ r) :=
begin
  apply iff.intro,
  begin
    intro h,
    cases h.right with hq hr,
    begin
      show (p ∧ q) ∨ (p ∧ r),
      exact or.inl ⟨h.left, hq⟩
    end,
    show (p ∧ q) ∨ (p ∧ r),
      exact or.inr ⟨h.left, hr⟩
  end,
  intro h,
  cases h with hpq hpr,
  begin
    show p ∧ (q ∨ r),
    exact ⟨hpq.left, or.inl hpq.right⟩
  end,
  show p ∧ (q ∨ r),
  exact ⟨hpr.left, or.inr hpr.right⟩,
end

example (p q r : Prop) : p ∧ (q ∨ r) ↔ (p ∧ q) ∨ (p ∧ r) :=
begin
  apply iff.intro,
  { intro h,
    cases h.right with hq hr,
    { show (p ∧ q) ∨ (p ∧ r),
      exact or.inl ⟨h.left, hq⟩ },
    show (p ∧ q) ∨ (p ∧ r),
      exact or.inr ⟨h.left, hr⟩ },
  intro h,
  cases h with hpq hpr,
  { show p ∧ (q ∨ r),
    exact ⟨hpq.left, or.inl hpq.right⟩ },
  show p ∧ (q ∨ r),
  exact ⟨hpr.left, or.inr hpr.right⟩,
end

example (p q r : Prop) : p ∧ (q ∨ r) ↔ (p ∧ q) ∨ (p ∧ r) :=
begin
  apply iff.intro,
  { intro h,
    cases h.right with hq hr,
    { show (p ∧ q) ∨ (p ∧ r),
      exact or.inl ⟨h.left, hq⟩ },
    { show (p ∧ q) ∨ (p ∧ r),
      exact or.inr ⟨h.left, hr⟩ }},
  { intro h,
    cases h with hpq hpr,
    { show p ∧ (q ∨ r),
      exact ⟨hpq.left, or.inl hpq.right⟩ },
    { show p ∧ (q ∨ r),
      exact ⟨hpr.left, or.inr hpr.right⟩ }},
end

example (p q : Prop) : p ∧ q ↔ q ∧ p :=
begin
  apply iff.intro,
  { intro h,
    have hp : p := h.left,
    have hq : q := h.right,
    show q ∧ p,
    exact ⟨hq, hp⟩ },
  intro h,
  have hp : p := h.right,
  have hq : q := h.left,
  show p ∧ q,
  exact ⟨hp, hq⟩,
end


import Lean4Axiomatic.Rational.Impl.Fraction.Multiplication
import Lean4Axiomatic.Rational.Reciprocation

namespace Lean4Axiomatic.Rational.Impl.Fraction

open Logic (AP)
open Signed (Positive sgn)

variable {ℕ : Type} [Natural ℕ]
variable {ℤ : Type} [Integer (ℕ := ℕ) ℤ]

/-! ## Reciprocation and division on fractions -/

/--
Reciprocal of a fraction.

Requires the fraction to be nonzero because its numerator will become the
denominator of the reciprocal. The new denominator can be made positive by
multiplying it by its own `sgn` value. The nonzero requirement is an instance
argument so that usages of the `·⁻¹` syntax don't need to explicitly pass it.
-/
def reciprocal (p : Fraction ℤ) [AP (p ≄ 0)] : Fraction ℤ := by
  revert p; intro (a//b) (_ : AP (a//b ≄ 0))
  have : Integer.Nonzero a := nonzero_numerator (a//b)
  have : AP (Positive (a * sgn a)) := Integer.positive_mul_sgn_self_inst
  exact (b * sgn a)//(a * sgn a)

instance reciprocation_ops : Reciprocation.Ops (Fraction ℤ) := {
  reciprocal := reciprocal
}

/--
The reciprocal operation preserves equivalence.

**Property intuition**: This must be true for reciprocal to be a valid function
on fractions.

**Proof intuition**: Expand all definitions in the hypotheses and goal until
equivalences involving only integers are reached. Combine these with algebra to
finish the proof.
-/
theorem recip_subst
    {p₁ p₂ : Fraction ℤ} [AP (p₁ ≄ 0)] [AP (p₂ ≄ 0)] : p₁ ≃ p₂ → p₁⁻¹ ≃ p₂⁻¹
    := by
  revert p₁; intro (a//b); revert p₂; intro (c//d)
  intro _ _ (_ : a//b ≃ c//d)
  show (a//b)⁻¹ ≃ (c//d)⁻¹
  have : Integer.Nonzero a := nonzero_numerator (a//b)
  have : Integer.Nonzero c := nonzero_numerator (c//d)
  show (b * sgn a)//(a * sgn a) ≃ (d * sgn c)//(c * sgn c)
  show (b * sgn a) * (c * sgn c) ≃ (d * sgn c) * (a * sgn a)
  have : a * d ≃ c * b := ‹a//b ≃ c//d›
  calc
    (b * sgn a) * (c * sgn c) ≃ _ := AA.expr_xxfxxff_lr_swap_rl
    (b * c) * (sgn a * sgn c) ≃ _ := AA.substL AA.comm
    (c * b) * (sgn a * sgn c) ≃ _ := AA.substL (Rel.symm ‹a * d ≃ c * b›)
    (a * d) * (sgn a * sgn c) ≃ _ := AA.substL AA.comm
    (d * a) * (sgn a * sgn c) ≃ _ := AA.substR AA.comm
    (d * a) * (sgn c * sgn a) ≃ _ := AA.expr_xxfxxff_lr_swap_rl
    (d * sgn c) * (a * sgn a) ≃ _ := Rel.refl

/--
The reciprocal of a nonzero fraction is its left multiplicative inverse.

**Property and proof intuition**: Multiplying a fraction by its reciprocal puts
the same factors in the numerator and denominator. They all cancel, giving the
result `1`.
-/
theorem mul_inverseL {p : Fraction ℤ} [AP (p ≄ 0)] : p⁻¹ * p ≃ 1 := by
  revert p; intro (pn//pd) (_ : AP (pn//pd ≄ 0))
  show (pn//pd)⁻¹ * pn//pd ≃ 1
  have : Integer.Nonzero pn := nonzero_numerator (pn//pd)
  calc
    (pn//pd)⁻¹ * pn//pd
      ≃ _ := eqv_refl
    (pd * sgn pn)//(pn * sgn pn) * pn//pd
      ≃ _ := eqv_refl
    ((pd * sgn pn) * pn)//((pn * sgn pn) * pd)
      ≃ _ := substN AA.assoc
    (pd * (sgn pn * pn))//((pn * sgn pn) * pd)
      ≃ _ := substN (AA.substR AA.comm)
    (pd * (pn * sgn pn))//((pn * sgn pn) * pd)
      ≃ _ := substN AA.comm
    ((pn * sgn pn) * pd)//((pn * sgn pn) * pd)
      ≃ _ := eqv_one_iff_numer_eqv_denom.mpr Rel.refl
    1
      ≃ _ := eqv_refl

/--
The reciprocal of a nonzero fraction is its right multiplicative inverse.

**Property and proof intuition**: Follows from commutativity of multiplication
and the reciprocal being the left multiplicative inverse.
-/
theorem mul_inverseR {p : Fraction ℤ} [AP (p ≄ 0)] : p * p⁻¹ ≃ 1 :=
  eqv_trans mul_comm mul_inverseL

instance reciprocation_props : Reciprocation.Props (Fraction ℤ) := {
  recip_subst := recip_subst
  mul_inverseL := mul_inverseL
  mul_inverseR := mul_inverseR
}

instance reciprocation : Reciprocation (Fraction ℤ) := {
  toOps := reciprocation_ops
  toProps := reciprocation_props
}

/--
A fraction with a positive numerator is not equivalent to zero.

This is a trivial lemma to enable the instance version below.

**Property and proof intuition**: We already know that fractions with nonzero
numerators are not equivalent to zero; a positive numerator is nonzero.
-/
theorem nonzero_from_positive_numer
    {a b : ℤ} [AP (Positive a)] [AP (Positive b)] : a//b ≄ 0
    := by
  have : Integer.Nonzero a := Integer.nonzero_from_positive_inst
  have : a ≄ 0 := Integer.nonzero_iff_neqv_zero.mp this
  have : a//b ≄ 0 := mt eqv_zero_iff_numerator_eqv_zero.mp this
  exact this

/--
This instance exists to allow a clean syntax for the reciprocal in
`recip_positive`.
-/
instance nonzero_from_positive_numer_inst
    {a b : ℤ} [AP (Positive a)] [AP (Positive b)] : AP (a//b ≄ 0)
    :=
  AP.mk nonzero_from_positive_numer

/--
The reciprocal of a fraction with a positive numerator simply swaps the
numerator and denominator.

**Property intuition**: The denominator of our fractions must be positive, so
if the numerator is already positive then no sign correction is needed for it
to become the denominator.

**Proof intuition**: Expand the definition of reciprocal. The `sgn a` terms are
equivalent to `1` and drop out, because `a` is positive.
-/
theorem recip_positive
    {a b : ℤ} [AP (Positive a)] [AP (Positive b)] : (a//b)⁻¹ ≃ b//a
    := by
  have : sgn a ≃ 1 := Integer.sgn_positive.mp ‹AP (Positive a)›.ev
  have x_sgn_a {x : ℤ} : x * sgn a ≃ x := calc
    x * sgn a ≃ _ := AA.substR ‹sgn a ≃ 1›
    x * 1     ≃ _ := AA.identR
    x         ≃ _ := Rel.refl
  calc
    (a//b)⁻¹                 ≃ _ := eqv_refl
    (b * sgn a)//(a * sgn a) ≃ _ := substN x_sgn_a
    b//(a * sgn a)           ≃ _ := substD x_sgn_a
    b//a                     ≃ _ := eqv_refl

/--
Division of fractions.

**Definition intuition**: Multiplying by the reciprocal is the same as
division, e.g. `2 / 3` is the same as `2 * (1 / 3)`.
-/
def div (p q : Fraction ℤ) [AP (q ≄ 0)] : Fraction ℤ := p * q⁻¹

instance division_ops : Division.Ops (Fraction ℤ) := {
  div := div
}

/--
Converting two integers to fractions and then dividing them is equivalent to
forming a fraction directly from the integers.

**Property intuition**: Making this property true is one of the reasons for
introducing formal fractions to begin with: to have a consistent inverse of
multiplication for integers.

**Proof intuition**: Expanding the defintions of fractions and division, and
then simplifying via algebraic identities, gives the result.
-/
theorem div_eqv_fraction
    {a b : ℤ} [AP (Positive b)] : (a : Fraction ℤ) / b ≃ a//b
    := calc
  (a : Fraction ℤ) / b ≃ _ := eqv_refl
  (a//1) / (b//1)      ≃ _ := eqv_refl
  (a//1) * (b//1)⁻¹    ≃ _ := mul_substR recip_positive
  (a//1) * (1//b)      ≃ _ := eqv_refl
  (a * 1)//(1 * b)     ≃ _ := substN AA.identR
  a//(1 * b)           ≃ _ := substD AA.identL
  a//b                 ≃ _ := eqv_refl

/--
Every fraction can be expressed as a ratio of integers.

This is a trivial theorem for fractions, but there may be other rational number
representations for which the proof is much more difficult.

**Property intuition**: Formal fractions satisfy this by definition.

**Proof intuition**: Use the previous result that formal fractions are
equivalent to division of integers, and that the denominator is nonzero because
it's positive.
-/
def as_ratio (p : Fraction ℤ) : AsRatio p := by
  revert p; intro (a//b)
  show AsRatio (a//b)
  have : Integer.Nonzero b := Integer.nonzero_from_positive_inst
  have : a//b ≃ a / b := eqv_symm div_eqv_fraction
  exact AsRatio.intro a b ‹Integer.Nonzero b› this

instance division_props : Division.Props (Fraction ℤ) := {
  div_mul_recip := eqv_refl
  as_ratio := as_ratio
}

instance division : Division (Fraction ℤ) := {
  toOps := division_ops
  toProps := division_props
}

end Lean4Axiomatic.Rational.Impl.Fraction


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

! This file was ported from Lean 3 source module topology.homotopy.equiv
! leanprover-community/mathlib commit 3d7987cda72abc473c7cdbbb075170e9ac620042
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Topology.Homotopy.Basic

/-!

# Homotopy equivalences between topological spaces

In this file, we define homotopy equivalences between topological spaces `X` and `Y` as a pair of
functions `f : C(X, Y)` and `g : C(Y, X)` such that `f.comp g` and `g.comp f` are both homotopic
to `ContinuousMap.id`.

## Main definitions

- `ContinuousMap.HomotopyEquiv` is the type of homotopy equivalences between topological spaces.

## Notation

We introduce the notation `X ≃ₕ Y` for `ContinuousMap.HomotopyEquiv X Y` in the `ContinuousMap`
locale.

-/

universe u v w

variable {X : Type u} {Y : Type v} {Z : Type w}

variable [TopologicalSpace X] [TopologicalSpace Y] [TopologicalSpace Z]

namespace ContinuousMap

/-- A homotopy equivalence between topological spaces `X` and `Y` are a pair of functions
`toFun : C(X, Y)` and `invFun : C(Y, X)` such that `toFun.comp invFun` and `invFun.comp toFun`
are both homotopic to corresponding identity maps.
-/
@[ext]
structure HomotopyEquiv (X : Type u) (Y : Type v) [TopologicalSpace X] [TopologicalSpace Y] where
  toFun : C(X, Y)
  invFun : C(Y, X)
  left_inv : (invFun.comp toFun).Homotopic (ContinuousMap.id X)
  right_inv : (toFun.comp invFun).Homotopic (ContinuousMap.id Y)
#align continuous_map.homotopy_equiv ContinuousMap.HomotopyEquiv

-- mathport name: continuous_map.homotopy_equiv
scoped infixl:25 " ≃ₕ " => ContinuousMap.HomotopyEquiv

namespace HomotopyEquiv

/-- Coercion of a `HomotopyEquiv` to function. While the Lean 4 way is to unfold coercions, this
auxiliary definition will make porting of Lean 3 code easier.

Porting note: TODO: drop this definition. -/
@[coe] def toFun' (e : X ≃ₕ Y) : X → Y := e.toFun

instance : CoeFun (X ≃ₕ Y) fun _ => X → Y := ⟨toFun'⟩

@[simp]
theorem toFun_eq_coe (h : HomotopyEquiv X Y) : (h.toFun : X → Y) = h :=
  rfl
#align continuous_map.homotopy_equiv.to_fun_eq_coe ContinuousMap.HomotopyEquiv.toFun_eq_coe

@[continuity]

end HomotopyEquiv

end ContinuousMap

open ContinuousMap

namespace Homeomorph

/-- Any homeomorphism is a homotopy equivalence.
-/
def toHomotopyEquiv (h : X ≃ₜ Y) : X ≃ₕ Y where
  toFun := h
  invFun := h.symm
  left_inv := by rw [symm_comp_toContinuousMap]
  right_inv := by rw [toContinuousMap_comp_symm]
#align homeomorph.to_homotopy_equiv Homeomorph.toHomotopyEquiv

@[simp]
theorem coe_toHomotopyEquiv (h : X ≃ₜ Y) : (h.toHomotopyEquiv : X → Y) = h :=
  rfl
#align homeomorph.coe_to_homotopy_equiv Homeomorph.coe_toHomotopyEquiv

end Homeomorph

namespace ContinuousMap

namespace HomotopyEquiv

/-- If `X` is homotopy equivalent to `Y`, then `Y` is homotopy equivalent to `X`.
-/
def symm (h : X ≃ₕ Y) : Y ≃ₕ X where
  toFun := h.invFun
  invFun := h.toFun
  left_inv := h.right_inv
  right_inv := h.left_inv
#align continuous_map.homotopy_equiv.symm ContinuousMap.HomotopyEquiv.symm

@[simp]
theorem coe_invFun (h : HomotopyEquiv X Y) : (⇑h.invFun : Y → X) = ⇑h.symm :=
  rfl
#align continuous_map.homotopy_equiv.coe_inv_fun ContinuousMap.HomotopyEquiv.coe_invFun

/-- See Note [custom simps projection]. We need to specify this projection explicitly in this case,
because it is a composition of multiple projections. -/
def Simps.apply (h : X ≃ₕ Y) : X → Y :=
  h
#align continuous_map.homotopy_equiv.simps.apply ContinuousMap.HomotopyEquiv.Simps.apply

/-- See Note [custom simps projection]. We need to specify this projection explicitly in this case,
because it is a composition of multiple projections. -/
def Simps.symm_apply (h : X ≃ₕ Y) : Y → X :=
  h.symm
#align continuous_map.homotopy_equiv.simps.symm_apply ContinuousMap.HomotopyEquiv.Simps.symm_apply

initialize_simps_projections HomotopyEquiv (toFun_toFun → apply, invFun_toFun → symm_apply,
  -toFun, -invFun)

/-- Any topological space is homotopy equivalent to itself.
-/
@[simps!]
def refl (X : Type u) [TopologicalSpace X] : X ≃ₕ X :=
  (Homeomorph.refl X).toHomotopyEquiv
#align continuous_map.homotopy_equiv.refl ContinuousMap.HomotopyEquiv.refl
#align continuous_map.homotopy_equiv.refl_apply ContinuousMap.HomotopyEquiv.refl_apply
#align continuous_map.homotopy_equiv.refl_symm_apply ContinuousMap.HomotopyEquiv.refl_symm_apply

instance : Inhabited (HomotopyEquiv Unit Unit) :=
  ⟨refl Unit⟩

/--
If `X` is homotopy equivalent to `Y`, and `Y` is homotopy equivalent to `Z`, then `X` is homotopy
equivalent to `Z`.
-/
@[simps!]
def trans (h₁ : X ≃ₕ Y) (h₂ : Y ≃ₕ Z) : X ≃ₕ Z where
  toFun := h₂.toFun.comp h₁.toFun
  invFun := h₁.invFun.comp h₂.invFun
  left_inv := by
    refine Homotopic.trans ?_ h₁.left_inv
    exact ((Homotopic.refl _).hcomp h₂.left_inv).hcomp (Homotopic.refl _)
  right_inv := by
    refine Homotopic.trans ?_ h₂.right_inv
    exact ((Homotopic.refl _).hcomp h₁.right_inv).hcomp (Homotopic.refl _)
#align continuous_map.homotopy_equiv.trans ContinuousMap.HomotopyEquiv.trans
#align continuous_map.homotopy_equiv.trans_apply ContinuousMap.HomotopyEquiv.trans_apply
#align continuous_map.homotopy_equiv.trans_symm_apply ContinuousMap.HomotopyEquiv.trans_symm_apply

theorem symm_trans (h₁ : X ≃ₕ Y) (h₂ : Y ≃ₕ Z) : (h₁.trans h₂).symm = h₂.symm.trans h₁.symm := rfl
#align continuous_map.homotopy_equiv.symm_trans ContinuousMap.HomotopyEquiv.symm_trans

end HomotopyEquiv

end ContinuousMap

open ContinuousMap

namespace Homeomorph

@[simp]
theorem refl_toHomotopyEquiv (X : Type u) [TopologicalSpace X] :
    (Homeomorph.refl X).toHomotopyEquiv = HomotopyEquiv.refl X :=
  rfl
#align homeomorph.refl_to_homotopy_equiv Homeomorph.refl_toHomotopyEquiv

@[simp]
theorem symm_toHomotopyEquiv (h : X ≃ₜ Y) : h.symm.toHomotopyEquiv = h.toHomotopyEquiv.symm :=
  rfl
#align homeomorph.symm_to_homotopy_equiv Homeomorph.symm_toHomotopyEquiv

@[simp]
theorem trans_toHomotopyEquiv (h₀ : X ≃ₜ Y) (h₁ : Y ≃ₜ Z) :
    (h₀.trans h₁).toHomotopyEquiv = h₀.toHomotopyEquiv.trans h₁.toHomotopyEquiv :=
  rfl
#align homeomorph.trans_to_homotopy_equiv Homeomorph.trans_toHomotopyEquiv

end Homeomorph


import «smt-lean»

section some_algorithm

open smt.logic_fragment

variables n x n' x' : ℤ
variables Act₀ : n' = n + 1
variables Act₁ : x' = x + 3*n^2 + 3*n + 1
variables J₀ : x = n^3

include J₀ Act₀ Act₁
example : x' = n'^3 :=
by { -- subst n', subst x', norm_num [right_distrib,left_distrib],
     veriT (QF_NIA) }

end some_algorithm


import mynat.definition
import mynat.add
import mynat.mul

lemma example2 (x y : mynat) (h : y = x + 7) : 2 * y = 2 * (x + 7) :=
begin
rw h,
refl,
end


import relatively_prime set_lemmas linear_algebra.projection ring_theory.coprime linear_algebra.basis linear_algebra.direct_sum_module new_file tactic.abel

open_locale classical

/-- Given prime `p : R`, for all `n : ℕ`, `p ^ (n + 1)` isn't a unit.-/
lemma not_unit_of_prime_pow {R : Type*} [comm_ring R] {p : R} (hp : prime p) {n : ℕ} :
  ¬(is_unit (p ^ n.succ)) :=
begin
  intro hu,
  rw is_unit_iff_dvd_one at hu,
  exact hp.2.1 (is_unit_iff_dvd_one.2 $ dvd_trans (⟨p ^ n, by {rw ←pow_succ}⟩) hu)
end

variables (R : Type*) [integral_domain R] [is_principal_ideal_ring R]
  [decidable_eq R] [decidable_eq (associates R)]

namespace coprimes
variable (r : R)

def span := submodule.span R (↑(coprimes' r) : set R)

variables {R} (hr : r ≠ 0) (hu : ¬is_unit r)
include hr hu

lemma span_eq_top : span R r = ⊤ :=
begin
  cases submodule.is_principal.principal (span R r) with x hx,
  erw [hx, ideal.span_singleton_eq_top],
  exact relatively_prime' r hr hu
    (λ y H, by {rw ←ideal.mem_span_singleton, change _ = ideal.span {x} at hx, rw ←hx,
    exact submodule.subset_span H})
end

end coprimes

variables (R) (M : Type*) [add_comm_group M] [module R M] (A : submodule R M)

def Tp := submodule.span R $ ⋃ (p : {p : R // prime p}), (prime_pow_ord A p).1

variables {R} {α : Type*} {β : Type*} [ring α] [add_comm_group β] [module α β]

set_option class.instance_max_depth 50

lemma ord_eq (y : tors R A) : ord R A (y : A) = ord R (tors R A) y :=
submodule.ext $ λ x, ⟨λ (h : _ = _), show _ = _, from subtype.ext_iff.2 $
    by erw ←submodule.coe_smul at h; erw h; refl,
  λ (h : _ = _), show _ = _, from subtype.ext_iff.1 h⟩

variables (R)
lemma tors_gen : Tp R M A = ⊤ :=
begin
  ext,
  split,
    tauto,
  intro,
  cases classical.em (x = 0),
    rw [h, ←submodule.mem_coe], exact (Tp R M A).2,
  cases submodule.is_principal.principal (ord R (tors R A) x) with r hr,
  change _ = ideal.span {r} at hr,
  have hr0 : r ≠ 0, by
    {  assume h,
       rw [h, ideal.span_singleton_eq_bot.2 rfl] at hr,
       rcases x.2 with ⟨s, hs0, hs⟩,
       change s ∈ ord R A (x : A) at hs,
       rw ←ord_eq at hr,
       rw hr at hs,
       exact absurd ((submodule.mem_bot R).1 hs) hs0},
  have hu : ¬is_unit r, by
    {  assume hu,
       rw (ideal.span_singleton_eq_top.2 hu) at hr,
       have h1 : (1 : R) ∈ ord R (tors R A) x, from hr.symm ▸ submodule.mem_top,
       exact absurd (show x = 0, from one_smul R x ▸ set.mem_def.1 h1) h},
  cases exists_repr_of_mem_span (coprimes' r) 1
     (show (1:R) ∈ (coprimes.span R r), by rw coprimes.span_eq_top r hr0 hu; simp) with ι h1,
  rw ←one_smul R x,
  rw h1, rw finset.sum_smul, rw Tp,
  refine sum_mem_span _, intros q hq, rcases finset.mem_image.1 hq with ⟨p, hp, h⟩,
  use p,
  exact (unique_factorization_domain.prime_factors hr0 p (multiset.mem_to_finset.1 hp)),
  have hp0 : (multiset.filter (λ x, associated x p)
   (unique_factorization_domain.factors r)).prod • (ι q * q) • x = 0,
    begin
      rw ←mul_smul, rw mul_comm, rw mul_assoc, rw ←h,
      cases prod_of_dvd_eq' r hr0 p with u hu,
      rw ←units.eq_mul_inv_iff_mul_eq at hu, erw hu,
      rw mul_comm r, rw ←mul_assoc,
      rw mul_smul, convert smul_zero _,
      show r ∈ ord R (tors R A) x, rw hr, exact ideal.mem_span_singleton.2 ⟨1, (mul_one r).symm⟩,
    end,
  have H1 := @associated_pow' _ _ _ _ _ _ (unique_factorization_domain.factors r) rfl p,
  have H2 := @associated_prod _ _ _ _ _ _ (multiset.filter (λ (x : R), associated x p)
    (unique_factorization_domain.factors r))
   (multiset.repeat p (multiset.filter (λ (x : R), associated x p)
     (unique_factorization_domain.factors r)).card) rfl
   (multiset.card_repeat _ _) H1,
  cases associates.mk_eq_mk_iff_associated.1 H2 with v hv,
  rw multiset.prod_repeat at hv,
  cases prime_pow_le _ _ _ _ (by {rw ←hv, rw mul_comm, rw mul_smul, rw hp0, rw smul_zero}) with j hj,
  use j, exact hj.2, exact (unique_factorization_domain.prime_factors
    hr0 p (multiset.mem_to_finset.1 hp)),
end

instance huh {ι : Type*} (s : finset ι) : fintype (↑s : set ι) :=
fintype.of_finset s (λ x, iff.rfl)
local infix ` ~ᵤ ` : 50 := associated
variables {R}

lemma is_coprime_of_prime {p q : R} (hp : prime p) (h : ¬ p ∣ q) : is_coprime p q :=
begin
  cases submodule.is_principal.principal (ideal.span ({p, q} : set R)) with w hw,
  cases ideal.mem_span_singleton.1 (show p ∈ ideal.span {w}, by rw ideal.span;
    rw ←hw; exact submodule.subset_span (show p ∈ {p, q}, by simp only
      [set.mem_insert_iff, true_or, eq_self_iff_true])) with t ht,
  cases ideal.mem_span_singleton.1 (show q ∈ ideal.span {w}, by rw ideal.span;
    rw ←hw; exact submodule.subset_span (show q ∈ {p, q}, by simp only
      [set.mem_insert_iff, set.mem_singleton, or_true])) with r hr,
  have hwp : ¬ p ∣ w := λ hwp, h $ dvd_trans hwp ⟨r, hr⟩,
  have hwu : is_unit w := by {
    refine or.resolve_right ((irreducible_of_prime hp).2 w t ht) _,
    rintro ⟨s, hs⟩, exact hwp ⟨(s⁻¹ : units R), by {rw ht, rw ←hs,
      simp only [units.mul_inv_cancel_right],}⟩},
  rcases ideal.mem_span_pair.1 (show w ∈ ideal.span {p, q}, by rw hw;
  exact ideal.mem_span_singleton.2 (dvd_refl _)) with ⟨a, b, hab⟩,
  cases hwu with u hu,
  rw ←units.mul_right_inj u⁻¹ at hab,
  rw ←hu at hab,
  rw units.inv_mul at hab,
  rw mul_add at hab,rw ←mul_assoc at hab, rw ←mul_assoc at hab,
  use [↑u⁻¹ * a, ↑u⁻¹ * b],
  exact hab,
end

lemma prime_pow_unique {p : {p : R // prime p}} {q1 q2 : @subtype R (λ q, prime q ∧ ¬ associated q ↑p)}
  {m n : ℕ} (h0 : m ≠ 0) (h : ideal.span ({q1.1 ^ m} : set R) = ideal.span {q2.1 ^ n}) :
  associated q1.1 q2.1 ∧ m = n :=
begin
  have h1 := ideal.mem_span_singleton.1 (by rw ←h; exact ideal.mem_span_singleton.2 (dvd_refl _)),
  have h2 := ideal.mem_span_singleton.1 (by rw h; exact ideal.mem_span_singleton.2 (dvd_refl _)),
  have h12 := associated_of_dvd_dvd h1 h2,
  cases m,
  exfalso, exact h0 rfl,
  rcases unique_factorization_domain.exists_mem_factors_of_dvd (ne_zero_of_prime_pow R n q2.2.1)
    (irreducible_of_prime q1.2.1) (dvd_trans ⟨q1.1 ^ m, by rw pow_succ; refl⟩ h2) with ⟨r, hrm, hr⟩,
  have hm2 := factors_prime_pow n q2.2.1,
  have hra : associated r q2.1 := by {rw ←associates.mk_eq_mk_iff_associated,
  suffices : associates.mk r ∈ multiset.map associates.mk
    (unique_factorization_domain.factors (q2.val ^ n)), by
    {rw hm2 at this, exact multiset.eq_of_mem_repeat this},
  exact multiset.mem_map_of_mem _ hrm},
  have := associated.trans hr hra,
  split,
  exact this,
  have hunique := associates.rel_associated_iff_map_eq_map.1
  (unique_factorization_domain.unique (unique_factorization_domain.irreducible_factors $
    ne_zero_of_prime_pow R m.succ q1.2.1)
  (unique_factorization_domain.irreducible_factors $ ne_zero_of_prime_pow R n q2.2.1)
  (associated.trans (unique_factorization_domain.factors_prod (ne_zero_of_prime_pow R m.succ q1.2.1)) $
    associated.trans h12.symm
    (unique_factorization_domain.factors_prod (ne_zero_of_prime_pow R n q2.2.1)).symm)),
  rw hm2 at hunique,
  have hm1 := factors_prime_pow m.succ q1.2.1,
  rw hunique at hm1, rw ←multiset.card_repeat (associates.mk q2.1) n,
  rw ←multiset.card_repeat (associates.mk q1.1) m.succ,
  rw hm1,
end

lemma not_dvd (p : {p : R // prime p})
{l : (tors R A) →₀ R}
(hS : ↑(l.support) ⊆ (⋃ (q : { q // prime q ∧ ¬associated q ↑p}),
  (prime_pow_ord A ⟨(q.1 : R), q.2.1⟩).1))
(H : ∀ (x : (tors R A)), x ∈ l.support →
  (∃ (q : {q // prime q ∧ ¬associated q ↑p}) (n : ℕ), ord R (tors R A) x = ideal.span {(q.1 : R) ^ n})) :
  ¬ p.1 ∣ @finset.prod (↑l.support : set _) _ _
     (@finset.univ (↑l.support : set _) $ huh l.support)(λ x, (classical.some (H x x.2)).1 ^
       (classical.some (classical.some_spec $ H x x.2))) :=
begin
  set Q := @finset.prod (↑l.support : set _) _ _ (@finset.univ (↑l.support : set _) $ huh l.support)
    (λ x, (classical.some (H x x.2)).1 ^ (classical.some (classical.some_spec $ H x x.2))),
  intro hnot,
  rcases exists_mem_multiset_dvd_of_prime p.2 hnot with ⟨a, hma, ha⟩,
  cases multiset.mem_map.1 hma with y hy,
  have h0 : classical.some (classical.some_spec (H y y.2)) ≠ 0 :=
    λ h0, by {rw h0 at hy, rw pow_zero at hy, rw ←hy.2 at ha, exact p.2.2.1 (is_unit_iff_dvd_one.2 ha)},
  cases set.mem_Union.1 (hS y.2) with r hr,
  cases hr with k hk,
  have hreq : associated (classical.some (H y y.2)).1 r.1 :=
  (prime_pow_unique h0 ((classical.some_spec $ classical.some_spec $ H y.1 y.2).symm.trans hk)).1,
  have hkeq : (classical.some (classical.some_spec (H y y.2))) = k :=
  (prime_pow_unique h0 ((classical.some_spec $ classical.some_spec $ H y.1 y.2).symm.trans hk)).2,
  cases hreq.symm with u hu,
  rw hkeq at hy,
  rw ←hu at hy,
  rw ←hy.2 at ha,
  rw ←multiset.prod_repeat at ha,
  rcases exists_associated_mem_of_dvd_prod p.2 (λ b hb, by {have hb' : b = r * u :=
  @multiset.eq_of_mem_repeat _ _ _ k hb, rw hb', exact (prime_iff_of_associated ⟨u, rfl⟩).1 r.2.1,})
    ha with ⟨s, hms, hs⟩,
  rw multiset.eq_of_mem_repeat hms at hs,
  exact r.2.2 (associated.trans (⟨u, rfl⟩) hs.symm),
end

lemma trivial_inter (p : {p : R // prime p}) :
  prime_pow_ord A p ⊓ (submodule.span R $ ⋃ (q : {q : R // prime q ∧ ¬ associated q p}),
    (prime_pow_ord A ⟨q.1, q.2.1⟩).1) = ⊥ :=
begin
  rw eq_bot_iff,
  intros x hx,
  apply (submodule.mem_bot R).2,
  cases hx.1 with m hm,
  have hpm := eq_zero_of_ord_pow m p.2 hm,
  rcases (@finsupp.mem_span_iff_total (tors R A) (tors R A) R _ _ _ (@id (tors R A))
    (⋃ (q : {q : R // prime q ∧ ¬associated q ↑p}), (prime_pow_ord A ⟨q.1, q.2.1⟩).1) x).1
      (by {rw set.image_id, exact hx.2}) with ⟨l, hl, hl'⟩,
  have hS := (finsupp.mem_supported _ _).1 hl,
  cases (classical.em (l.support = ∅)),
  rw finsupp.support_eq_empty.1 h at hl',
  rw ←hl',
  rw finsupp.total_apply,
  exact finset.sum_empty,
 have H : ∀ x ∈ l.support, ∃ (q : {q : R // prime q ∧ ¬ associated q p}) (n : ℕ),
    ord R (tors R A) x = ideal.span ({q.1 ^ n} : set R) := λ y hy, set.mem_Union.1
      (hS (finset.mem_coe.2 hy)),
  cases finset.nonempty_of_ne_empty h with z hz,
  let Q := @finset.prod (↑l.support : set _) _ _ (@finset.univ (↑l.support : set _) $ huh l.support)
    (λ x, (classical.some (H x x.2)).1 ^ (classical.some (classical.some_spec $ H x x.2))),
  have HQ : Q • x = 0, by {rw ←hl', rw finsupp.total_apply, rw finsupp.smul_sum,
  rw ←@finset.sum_const_zero _ _ l.support _,
  apply finset.sum_congr rfl,
  intros y hy, dsimp,
  rw smul_comm,
  let q := classical.some (H y hy),
  let n := classical.some (classical.some_spec $ H y hy),
  let hq := classical.some_spec (classical.some_spec $ H y hy),
  suffices : q.1 ^ n ∣ Q, by {cases this with c hc, rw hc, rw mul_comm, rw mul_smul,
    rw eq_zero_of_ord_pow n q.2.1 hq,
   erw smul_zero, erw smul_zero },
  refine @dvd_prod_finset (↑l.support : set _) _ _ ⟨y, hy⟩ (λ x, (classical.some (H x x.2)).1 ^
    (classical.some (classical.some_spec $ H x x.2)))
      (@finset.univ (↑l.support : set _) $ huh l.support) _,
  exact finset.mem_univ _},
  rcases (show is_coprime (p.1 ^ m) Q, by
    {  apply is_coprime.pow_left,
    apply is_coprime_of_prime p.2,
    exact not_dvd _ _ p hS H
  }) with ⟨a, b, hab⟩,
  rw ←one_smul _ x,
  rw ←hab,
  rw add_smul,
  rw mul_smul, rw mul_smul,
  rw hpm, rw smul_zero, rw HQ, rw smul_zero, rw zero_add,
end

instance noe (Hfg : A.fg) : is_noetherian R (tors R A) :=
is_noetherian_of_submodule_of_noetherian R A (tors R A) (is_noetherian_of_fg_of_noetherian A Hfg)

noncomputable def prime_gen_set (Hfg : A.fg) (p : {p : R // prime p}) : finset (tors R A) :=
classical.some (@is_noetherian.noetherian _ _ _ _ _ (noe M A Hfg) (prime_pow_ord A p))

theorem prime_gen_set_gens (Hfg : A.fg) (p : {p : R // prime p}) :
  submodule.span R (↑(prime_gen_set M A Hfg p) : set _) = prime_pow_ord A p :=
classical.some_spec (@is_noetherian.noetherian _ _ _ _ _ (noe M A Hfg) (prime_pow_ord A p))

lemma smul_zero_of_Inf {x : R}  (Hn : Inf (set.range (ord R M)) = ideal.span ({x} : set R))
  (y : M) : x • y = 0 :=
begin
  show x ∈ ord R M y,
  apply Inf_le (show ord R M y ∈ set.range (ord R M), from ⟨y, rfl⟩),
  rw Hn,
  exact ideal.mem_span_singleton.2 (dvd_refl _),
end

lemma exists_inter (n : ℕ) (h0 : n ≠ 0) (p : R) (hp : prime p)
  (Hn : Inf (set.range (ord R M)) = ideal.span {p ^ n})
  (a : M) (ha : p ^ (n - 1) • a ≠ 0) (hna : ∃ b : M, b ∉ submodule.span R ({a} : set M)) :
  ∃ b : M, b ≠ 0 ∧ ∀ (x : M), x ∈ ((submodule.span R {a}) ⊓ (submodule.span R ({b} : set M))) → x = 0 :=
begin
  cases hna with c hc,
  have hn : p ^ n • c = 0 := by
   {have : p ^ n ∈ Inf (set.range (ord R M)), by rw Hn; exact ideal.mem_span_singleton.2 (dvd_refl _),
  have huh : Inf (set.range (ord R M)) ≤ ord R M c := Inf_le (show ord R M c ∈ set.range (ord R M),
    from ⟨c, rfl⟩),
  exact huh this},
  haveI := classical.dec_pred,
  let j := @nat.find _ (_inst _) (show ∃ n, p ^ n • c ∈ submodule.span R ({a} : set M), from ⟨n,
  by { rw hn, exact submodule.zero_mem (submodule.span R ({a} : set M))}⟩),
  have hj0 : j ≠ 0 := λ hj, absurd (show c ∈ submodule.span R {a}, by
    {rw [←one_smul _ c, ←pow_zero p, ←hj],
  exact @nat.find_spec _ (_inst _) (show ∃ n, p ^ n • c ∈ submodule.span R ({a} : set M), from ⟨n,
  by { rw hn, exact submodule.zero_mem (submodule.span R ({a} : set M)),
  }⟩),
  }) hc,
  have hj : p ^ j • c ∈ submodule.span R {a}, from @nat.find_spec _ (_inst _)
  (show ∃ n, p ^ n • c ∈ submodule.span R ({a} : set M), from ⟨n,
  by { rw hn, exact submodule.zero_mem (submodule.span R ({a} : set M)),
  }⟩),
  cases submodule.mem_span_singleton.1 hj with r₁ hr₁,
  have hjs : p ^ (j - 1) • c ∉ submodule.span R {a} := @nat.find_min _ (_inst _)
  (show ∃ n, p ^ n • c ∈ submodule.span R ({a} : set M), from ⟨n,
  by { rw hn, exact submodule.zero_mem (submodule.span R ({a} : set M)),
  }⟩) (j - 1) (nat.pred_lt hj0),
  cases (classical.em (r₁ = 0)),
  rw h at hr₁, rw zero_smul at hr₁,
  use p ^ (j - 1) • c,
  split,
  intro hpj0,
  rw hpj0 at hjs,
  exact hjs (submodule.zero_mem _),
  intros x hx,
  cases submodule.mem_span_singleton.1 hx.2 with t ht,
  rw ← @classical.not_not (x = 0),
  intro hn,
  have hpt : ¬ p ∣ t := λ ⟨m, hm⟩, by {rw hm at ht, rw mul_comm at ht, rw ←mul_smul at ht,
    rw mul_assoc at ht, rw ←pow_succ at ht, rw nat.sub_add_cancel
      (nat.succ_le_of_lt $ nat.pos_iff_ne_zero.2 hj0) at ht, rw mul_smul at ht,
        rw ←hr₁ at ht, rw smul_zero at ht, exact hn ht.symm
  },
  have hcop : is_coprime t (p ^ n) := is_coprime.symm (is_coprime.pow_left (is_coprime_of_prime hp hpt)),
  rcases hcop with ⟨z, w, hwz⟩,
  have hbeq : p ^ (j - 1) • c = (z * t) • (p ^ (j - 1) • c) + (w * (p ^ n)) • (p ^ (j - 1) • c) :=
    by {rw ←add_smul, rw hwz, rw one_smul},
  have hsb : (z * t) • (p ^ (j - 1) • c) ∈ submodule.span R ({a} : set M) :=
    by {rw mul_smul, refine submodule.smul_mem (submodule.span R ({a} : set M)) z _, rw ht, exact hx.1},
  cases submodule.mem_span_singleton.1 hsb with y hy,
  have hjm : p ^ (j - 1) • c ∈ submodule.span R ({a} : set M) := by {rw ←mul_smul (w * _) at hbeq,
  rw mul_assoc at hbeq, rw ←pow_add at hbeq,
  cases nat.le.dest (nat.succ_le_of_lt (nat.pos_iff_ne_zero.2 h0)) with l hl,
  rw add_comm at hl, rw ←hl at hbeq, rw add_assoc at hbeq, rw add_comm 1 at hbeq,
  rw nat.sub_add_cancel (nat.succ_le_of_lt (nat.pos_iff_ne_zero.2 hj0)) at hbeq,
  rw pow_add at hbeq, rw mul_smul at hbeq, rw mul_smul at hbeq, rw mul_smul at hbeq,
  rw ←hr₁ at hbeq, rw smul_zero at hbeq, rw smul_zero at hbeq, rw add_zero at hbeq,
  rw hbeq, rw ←mul_smul z t, exact hsb  },
  exact hjs hjm,
  let k := @nat.find (λ k, ¬ (p ^ (k + 1) ∣ r₁)) (_inst _)
  (by {use (multiset.filter (λ x, associated x p) (unique_factorization_domain.factors r₁)).card,
  exact fin_pow_dvd h hp }),
  have hk : p ^ k ∣ r₁ := by {
    cases (classical.em (k = 0)),
  rw h_1, rw pow_zero, exact one_dvd _,
  apply classical.not_not.1,
  intro huh,
  rw ←nat.succ_pred_eq_of_pos (nat.pos_iff_ne_zero.2 h_1) at huh,
  exact @nat.find_min _ (_inst _) (by {use (multiset.filter (λ x, associated x p)
    (unique_factorization_domain.factors r₁)).card,
  exact fin_pow_dvd h hp }) _ (nat.pred_lt h_1) huh},
  cases hk with r hr,
  have hpr : ¬ p ∣ r := λ hpr, by {cases hpr with m hm, rw hm at hr,
  rw ←mul_assoc at hr, rw mul_comm _ p at hr, rw ←pow_succ at hr, exact @nat.find_spec
    (λ k, ¬ (p ^ (k + 1) ∣ r₁)) (_inst _) (by {use (multiset.filter (λ x, associated x p)
    (unique_factorization_domain.factors r₁)).card,
  exact fin_pow_dvd h hp }) (show p ^ (k + 1) ∣ r₁, from ⟨m, by rw hr⟩)},
  have hjn :  j ≤ n := @nat.find_min' _ (_inst _) (show ∃ n, p ^ n • c ∈ submodule.span R ({a} : set M),
  from ⟨n,
  by { rw hn, exact submodule.zero_mem (submodule.span R ({a} : set M))}⟩) n
    (hn.symm ▸ (submodule.span R ({a} : set M)).zero_mem),
  have hnjk : n ≤ n - j + k := by {suffices : (p ^ (n - j + k) * r) • a = 0, by
  {rw ←not_lt, intro hnot,
  have hgh : ord R M a = ideal.span ({p ^ n} : set R) := by
    rw ←nat.sub_add_cancel (nat.succ_le_of_lt (nat.pos_iff_ne_zero.2 h0)) at ⊢ Hn;
  exact ord_eq_of_pow hp ha (smul_zero_of_Inf _ Hn a),
  cases ideal.mem_span_singleton.1 (by rw ←hgh; exact this) with w hw,
  cases nat.le.dest (nat.succ_le_of_lt hnot) with m hm,
  conv at hw {to_rhs, rw ←hm},
  rw nat.succ_eq_add_one at hw,
  rw add_assoc at hw,
  rw pow_add p (n - j + k) (1 + m) at hw,
  rw mul_assoc at hw,
  have hhh := mul_left_cancel' (ne_zero_of_prime_pow R (n - j + k) hp) hw,
  exact hpr (by {rw hhh, rw pow_add, rw mul_assoc, rw pow_one, use p ^ m * w, }),
  },
  rw ←nat.sub_add_cancel hjn at hn,
  rw pow_add at hn,
  rw mul_smul at hn,
  rw ←hr₁ at hn,
  rw hr at hn,
  rw ←mul_smul at hn,
  rw ←mul_assoc at hn,
  rw ←pow_add at hn,
  exact hn},
  have hjk : j ≤ k := by {rw ←nat.sub_le_sub_left_iff hjn, apply nat.sub_le_left_of_le_add,
    rw add_comm, exact hnjk },
  have h1j : 1 ≤ j := nat.succ_le_of_lt (nat.pos_iff_ne_zero.2 hj0),
  let b := p ^ (j - 1) • c - (r * p ^ (k - 1)) • a,
  have hpb : p • b = 0 := show p • (_ - _) = (0 : M), by
    {rw smul_sub, rw ←mul_smul, rw ←pow_succ, rw ←mul_smul, rw mul_comm r, rw ←mul_assoc, rw ←pow_succ,
    rw nat.sub_add_cancel h1j, rw nat.sub_add_cancel (le_trans h1j hjk),
   rw ←hr₁, rw hr, rw sub_self },
  use b, split,
    show _ - _ ≠ (0 : M),
    intro hb,
    rw sub_eq_zero at hb,
    apply hjs,
    rw hb,
    exact submodule.mem_span_singleton.2 ⟨r * p ^ (k - 1), rfl⟩,
  intros x hx,
  rw ← @classical.not_not (x = 0),
  intro hn,
  cases submodule.mem_span_singleton.1 hx.2 with s hs,
  have hps : ¬ p ∣ s := λ ⟨q, hq⟩, by {rw hq at hs, rw mul_comm at hs, rw mul_smul at hs,
    rw hpb at hs, rw smul_zero at hs, exact hn hs.symm},
  have hcop : is_coprime s (p ^ n) := is_coprime.symm (is_coprime.pow_left (is_coprime_of_prime hp hps)),
  rcases hcop with ⟨z, w, hwz⟩,
  have hbeq : b = (z * s) • b + (w * (p ^ n)) • b := by {rw ←add_smul, rw hwz, rw one_smul},
  have hsb : (z * s) • b ∈ submodule.span R ({a} : set M) := by {rw mul_smul,
    refine submodule.smul_mem (submodule.span R ({a} : set M)) z _, rw hs, exact hx.1},
  have hjm : p ^ (j - 1) • c ∈ submodule.span R ({a} : set M) := by
    {cases nat.le.dest (le_trans h1j hjn) with l hl,
  rw add_comm at hl, rw ←hl at hbeq, rw mul_smul at hbeq, rw pow_add at hbeq,
    rw pow_one at hbeq, rw mul_smul at hbeq, rw mul_smul at hbeq, rw hpb at hbeq, rw smul_zero at hbeq,
  rw smul_zero at hbeq, rw add_zero at hbeq,
  rw ←mul_smul at hbeq, rw ←hbeq at hsb,
  change _ - _ ∈ _ at hsb,
  rw sub_eq_add_neg at hsb,
  rw ←neg_smul at hsb,
  exact (submodule.add_mem_iff_left _ (submodule.mem_span_singleton.2 ⟨-(r * p ^ (k - 1)), rfl⟩)).1 hsb,
  },
  exact hjs hjm,
end

lemma span_quotient_iff (a : M) : A ⊔ submodule.span R {a} = ⊤ ↔
  submodule.span R ({submodule.quotient.mk a} : set A.quotient) = ⊤ :=
begin
  split,
  intro h,
  rw eq_top_iff,
  intros x hx,
  apply quotient.induction_on' x,
  intro y,
  rcases submodule.mem_sup.1 (show y ∈ A ⊔ submodule.span R ({a} : set M), by rw h;
    exact submodule.mem_top) with ⟨b, hb, c, hc, hbc⟩,
  cases submodule.mem_span_singleton.1 hc with d hd,
  rw ←hd at hbc,
  apply submodule.mem_span_singleton.2,
  use d,
  rw ←hbc,
  apply (submodule.quotient.eq _).2,
  convert (submodule.neg_mem _ hb),
  abel,
  intro h,
  rw eq_top_iff,
  intros x hx,
  apply submodule.mem_sup.2,
  cases submodule.mem_span_singleton.1 (show submodule.quotient.mk x ∈ submodule.span R
    ({submodule.quotient.mk a} : set A.quotient), by rw h; exact submodule.mem_top) with y hy,
  rw ←submodule.quotient.mk_smul at hy,
  have huh := (submodule.quotient.eq _).1 hy,
  use (x - y • a),
  split,
  convert A.neg_mem huh, abel,
  use y • a,
  split,
  exact submodule.mem_span_singleton.2 ⟨y, rfl⟩,
  rw sub_add_cancel,
end

lemma exists_compl (Hfg : A.fg) (n : ℕ) (h0 : n ≠ 0) (p : R) (hp : prime p)
  (Hn : Inf (set.range (ord R A)) = ideal.span {p ^ n})
  (a : A) (ha : p ^ (n - 1) • a ≠ 0) (hna : ∃ b : A, b ∉ submodule.span R ({a} : set A)) :
  ∃ C : submodule R A, C ⊓ submodule.span R ({a} : set A) = ⊥
    ∧ C ⊔ submodule.span R ({a} : set A) = ⊤ :=
begin
  cases (classical.em (submodule.span R ({a} : set A) = ⊤)),
    use ⊥,
    split,
      simp,
    rw h, simp,
  let S := { B : submodule R A | submodule.span R ({a} : set A) ⊓ B = ⊥ },
  have hS : set.nonempty S := by {cases exists_inter _ n h0 p hp Hn a ha hna with b hb,
  use submodule.span R ({b} : set A),
  apply eq_bot_iff.2, intros x hx, apply (submodule.mem_bot R).2, exact hb.2 x hx},
  let C := @well_founded.min (submodule R A) (>)
    (is_noetherian_iff_well_founded.1 $ is_noetherian_of_fg_of_noetherian A Hfg) S hS,
  have hAC : ∀ x : C.quotient, p ^ n • x = 0 := λ x, by {apply quotient.induction_on' x,
    intros y, erw ←submodule.quotient.mk_smul,
  rw smul_zero_of_Inf _ Hn, rw submodule.quotient.mk_zero },
  have haC : p ^ n • (@submodule.quotient.mk _ _ _ _ _ C a) = 0 := hAC _,
  have hC : submodule.span R ({a} : set A) ⊓ C = ⊥ := well_founded.min_mem
    (is_noetherian_iff_well_founded.1 $ is_noetherian_of_fg_of_noetherian A Hfg) S hS,
  have hanC : p ^ (n - 1) • (@submodule.quotient.mk _ _ _ _ _ C a) ≠ 0 :=λ ha0,
  by {rw ←submodule.quotient.mk_smul at ha0, rw submodule.quotient.mk_eq_zero at ha0,
  apply ha,rw ←submodule.mem_bot R, rw ←hC, exact ⟨submodule.mem_span_singleton.2
    ⟨p ^ (n - 1), rfl⟩, ha0⟩,
  },
  have hACn : Inf (set.range (ord R C.quotient)) = ideal.span {p ^ n} :=
  by { apply le_antisymm,
  apply Inf_le _,
  use (submodule.quotient.mk a),
  rw ←nat.sub_add_cancel (nat.succ_le_of_lt $ nat.pos_iff_ne_zero.2 h0) at haC ⊢,
  exact ord_eq_of_pow hp hanC haC,
  apply le_Inf _,
  intros b hb,
  cases hb with c hc,
  revert hc,
  apply quotient.induction_on' c,
  intros d hd,
  rw ←hd,
  intros r hr,
  cases ideal.mem_span_singleton.1 hr with s hs,
  rw hs, show _ • _ = _, rw mul_smul, exact hAC _,},
  use C,
  split,
  rw inf_comm,
  exact hC,
  rw span_quotient_iff,
  apply classical.not_not.1,
  intro HN,
  cases @exists_inter _ _ _ _ _ C.quotient _ _ n h0 p hp hACn (submodule.quotient.mk a) hanC
  (by {rcases submodule.exists_of_lt (lt_top_iff_ne_top.2 HN) with ⟨x, _, hx⟩,
  use x})
  with b hb,
  revert hb,
  apply @quotient.induction_on _ C.quotient_rel _ b,
  intros d hd,
  have hda : submodule.span R {a} ⊓ (submodule.span R {d} ⊔ C) = ⊥ := by
    {rw eq_bot_iff,
    intros x hx, apply (submodule.mem_bot R).2,
    rcases submodule.mem_sup.1 hx.2 with ⟨y, hy, z, hz, hyz⟩,
    have hyx : submodule.quotient.mk x = submodule.quotient.mk y :=
    (submodule.quotient.eq C).2 (by {rw add_comm at hyz, rw ←eq_sub_iff_add_eq at hyz,
      rw ←hyz, exact hz}),
    cases submodule.mem_span_singleton.1 hx.1 with k hk,
    cases submodule.mem_span_singleton.1 hy with j hj,
    have hd' := hd.2 (submodule.quotient.mk x) ⟨submodule.mem_span_singleton.2
      ⟨k, by {rw ←submodule.quotient.mk_smul, rw hk,}⟩, submodule.mem_span_singleton.2 ⟨j,
      by {rw hyx, erw ←submodule.quotient.mk_smul, rw hj}⟩⟩,
    apply (submodule.mem_bot R).1, rw ←hC,
    exact ⟨hx.1, (submodule.quotient.mk_eq_zero _).1 hd'⟩,
        },
  have : ∀ B, B ∈ S → ¬ C < B := λ B, well_founded.not_lt_min (is_noetherian_iff_well_founded.1 $
    is_noetherian_of_fg_of_noetherian A Hfg) S hS,
  refine this (submodule.span R {d} ⊔ C) hda _,
  rw submodule.lt_iff_le_and_exists,
  split,
  exact le_sup_right, use d,
  split,
  exact submodule.le_def.1 le_sup_left (submodule.subset_span $ set.mem_singleton d),
  intro hdC,
  rw ←submodule.quotient.mk_eq_zero at hdC,
  exact hd.1 hdC,
end

lemma Inf_eq (A : submodule R M) (s : finset M) (hs : submodule.span R (↑s : set _) = A)
 (p : R) (hp : prime p)
 (Hp : ∀ (a : M), a ∈ A ∧ a ≠ 0 → (∃! (n : ℕ), p ^ (n + 1) • a = 0 ∧ p ^ n • a ≠ 0))
 (X : M) (N : ℕ) (hN : X ∈ finset.erase s 0 ∧
    (p ^ (N + 1) • X = 0 ∧ ¬p ^ N • X = 0) ∧
      ∀ (b : M) (m : ℕ), b ∈ finset.erase s 0 ∧ p ^ (m + 1) • b = 0 ∧ ¬p ^ m • b = 0 → m ≤ N) :
  Inf (set.range (ord R A)) = ideal.span {p ^ (N + 1)} :=
begin
  have hmem : ∀ x ∈ s, x ∈ A := λ x H, hs ▸ (submodule.subset_span H),
  apply le_antisymm,
  apply Inf_le _,
  use ⟨X, hmem X $ finset.mem_of_mem_erase hN.1⟩,
  have hX : A.subtype ⟨X, hmem X $ finset.mem_of_mem_erase hN.1⟩ = X := rfl,
  exact ord_eq_of_pow hp (λ h, hN.2.1.2 $
  by {rw ←hX, rw ←linear_map.map_smul, rw h, rw linear_map.map_zero })
  (by {
    have h2 : p ^ (N + 1) • X = 0 := hN.2.1.1,
    rw ←hX at h2, rw ←linear_map.map_smul at h2,
    exact linear_map.ker_eq_bot'.1 A.ker_subtype _ h2,
    }) ,
  apply le_Inf _,
  intros c hc,
  cases hc with x hx,
  cases classical.em (x = 0),
  rw h at hx, rw ord_ideal_zero_eq_top at hx,
  rw ←hx,
  exact le_top,
  rw ←hx,
  intros y hy,
  cases ideal.mem_span_singleton.1 hy with r hr,
  cases Hp x ⟨x.2, λ h0, h $ subtype.ext_iff.2 $ h0⟩ with n hn,
  rcases (finsupp.mem_span_iff_total _).1 (show (x : M) ∈ submodule.span R (id '' (↑s : set _)), by
    rw set.image_id; rw hs; exact x.2)
  with ⟨l, hlm, hl⟩,
  rw hr,
  show _ = (0 : A),
  apply subtype.ext_iff.2, rw submodule.coe_smul, rw mul_comm,
  rw mul_smul,
  rw submodule.coe_zero,
  rw ←hl,
  rw finsupp.total_apply,
  rw finsupp.smul_sum,
  have hNs : ∀ x, x ∈ (↑s : set _) → p ^ (N + 1) • x = (0 : M) := λ z hz, by
    {cases classical.em (z = 0),
      rw h_1,
      rw smul_zero,
    cases Hp z ⟨hmem z $ finset.mem_coe.1 hz, h_1⟩ with m hm,
    cases nat.le.dest (hN.2.2 z m ⟨finset.mem_erase.2 ⟨h_1, hz⟩, hm.1⟩) with k hk,
    rw ←hk, rw add_comm m k,
    rw add_assoc,rw pow_add, rw mul_smul, rw hm.1.1, rw smul_zero},
  unfold finsupp.sum,
  convert smul_zero _,
  rw ←@finset.sum_const_zero M _ l.support _,
  apply finset.sum_congr rfl,
  intros z hz,
  rw smul_comm, convert smul_zero _,
  exact hNs z ((finsupp.mem_supported _ l).1 hlm hz),
end

lemma inf_aux {X : M} (hX : X ∈ A) {C : submodule R A}
  (hC : C ⊓ submodule.span R {⟨X, hX⟩} = ⊥ ∧ C ⊔ submodule.span R {⟨X, hX⟩} = ⊤)
{S : finset M} (hS : submodule.span R (↑S : set M) = submodule.map A.subtype C ∧
∀ (a : M), a ∈ S → submodule.span R {a} ⊓ submodule.span R (↑(S.erase a) : set M) = ⊥) :
 submodule.span R {X} ⊓ submodule.span R (↑S : set M) ≤ ⊥ :=
begin
  have := map_inf' C X hX,
  rw ←hS.1 at this,rw this,
  rw hC.1,
  rw submodule.map_bot, exact le_refl _,
end

lemma inf_aux' {X : M} (hX : X ∈ A) (hX0 : X ≠ 0) {C : submodule R A}
  (hC : C ⊓ submodule.span R {⟨X, hX⟩} = ⊥ ∧ C ⊔ submodule.span R {⟨X, hX⟩} = ⊤)
{S : finset M} (hS : submodule.span R (↑S : set _) = submodule.map A.subtype C ∧
∀ (a : M), a ∈ S → submodule.span R {a} ⊓ submodule.span R (↑(S.erase a) : set M) = ⊥)
{b : M} (hb : b ∈ S) :
  submodule.span R ({b} : set M) ⊓ submodule.span R (↑((insert X S).erase b : finset M) : set M) ≤ ⊥ :=
begin
  have H := inf_aux _ _ hX hC hS,
  have := hS.2 b hb,
  rw erase_insert_eq,
  intros z hz,
  rw insert_to_set at hz,
  rcases submodule.mem_span_insert.1 hz.2 with ⟨r, v, hvm, hv⟩,
  cases submodule.mem_span_singleton.1 hz.1 with c hc,
  have H := inf_aux _ _ hX hC hS,
  rw ←hc at hv,
  rw ←sub_eq_iff_eq_add at hv,
  have h0 : r • X = 0 := by {rw ←submodule.mem_bot R,
  apply H,
  split,
  exact submodule.mem_span_singleton.2 ⟨r, rfl⟩,
  rw ←hv,
 rw submodule.mem_coe,
 refine submodule.sub_mem _ _ _,
  apply submodule.span_mono (show {b} ⊆ S, from finset.singleton_subset_iff.2 hb),
  show c • b ∈ submodule.span R (↑({b} : finset M) : set M),
  rw finset.coe_singleton,
  exact submodule.mem_span_singleton.2 ⟨c, rfl⟩,
  exact submodule.span_mono (show S.erase b ⊆ S, from finset.erase_subset _ _) hvm,},
  rw h0 at hv, rw sub_eq_zero at hv,
  rw ←this, split,
  rw ←hc, exact submodule.mem_span_singleton.2 ⟨c, rfl⟩,
  rw ←hc, rw hv, exact hvm,
  exact hb,
  intro hXb,
  have huh := inf_of_le_left (@submodule.span_mono R _ _ _ _ _ _ (show {X} ⊆ S, by rw hXb;
    exact finset.singleton_subset_iff.2 hb)),
  change (submodule.span R (↑({X} : finset M) : set M) ⊓ submodule.span R (↑S : set M) =
    submodule.span R (↑({X} : finset M) : set M)) at huh,
  rw finset.coe_singleton at huh,
  rw huh at H,
  rw ←eq_bot_iff at H,
  erw submodule.span_singleton_eq_bot at H,
  exact hX0 H,
end

theorem gen_le (s : finset A) (hs : submodule.span R (↑s : set A) = ⊤)
  (x : A) (hx : x ∈ s) (h0 : x ≠ 0)
  (C : submodule R A) (h : is_compl C (submodule.span R {x})) :
  C = submodule.span R ((C.subtype.comp (C.linear_proj_of_is_compl (submodule.span R {x}) h) : A → A)''
    (↑(s.erase x) : set A)) :=
begin
  apply le_antisymm,
  intros y hy,
  have : (⟨y, hy⟩ : C) ∈ (C.linear_proj_of_is_compl _ h).range := by
   rw submodule.linear_proj_of_is_compl_range h; exact submodule.mem_top,
  rcases this with ⟨a, hma, ha⟩,
  have hsa : a ∈ submodule.span R (↑s : set _) := by rw hs; exact submodule.mem_top,
  rw ←set.image_id (↑s : set _) at hsa,
  rcases (finsupp.mem_span_iff_total R ).1 hsa with ⟨l, hlm, hl⟩,
  rw ←hl at ha,
  rw linear_map.map_finsupp_total at ha,
  rw finsupp.total_apply at ha,
  cases classical.em (x ∈ l.support) with hxl hxl,
  unfold finsupp.sum at ha,
  rw ←finset.insert_erase hxl at ha,
  rw finset.sum_insert (finset.not_mem_erase x l.support) at ha,
  dsimp at ha,
  rw linear_map.mem_ker.1 (show x ∈ (C.linear_proj_of_is_compl _ h).ker,
    by {rw submodule.linear_proj_of_is_compl_ker h, exact submodule.subset_span rfl}) at ha,
  rw smul_zero at ha, rw zero_add at ha,
  have huh : (⟨y, hy⟩ : C) ∈ submodule.span R ((C.linear_proj_of_is_compl (submodule.span R {x}) h) ''
    (↑(s.erase x) : _)) :=
  by {rw finsupp.mem_span_iff_total, use l.erase x, split,
    rw finsupp.mem_supported,
    rw finsupp.support_erase,
    convert finset.coe_subset.2 (finset.erase_subset_erase x hlm),
    rw finsupp.total_apply, rw ← ha, unfold finsupp.sum,
    rw finsupp.support_erase,
    refine finset.sum_congr (by {convert (eq.refl (l.support.erase x)), }) _,intros z hz,
    rw finsupp.erase_ne (finset.ne_of_mem_erase hz)
    },
  rw submodule.span_image at ⊢ huh,
  rcases huh with ⟨z, hzm, hz⟩,
  use z, split,
  exact hzm, rw subtype.ext_iff at hz, exact hz,
  unfold finsupp.sum at ha,
  rw submodule.span_image,
  rw submodule.map_comp, use ⟨y, hy⟩,
  split,
  rw ←submodule.span_image,
  apply (finsupp.mem_span_iff_total R).2, use l, split,
  intros b hb, apply finset.mem_erase.2,
  split,
  intro hbx,
  rw hbx at hb, exact hxl hb,
  exact hlm hb,
  rw finsupp.total_apply, exact ha, refl,
  intros y hy,
  rw submodule.span_image at hy,
  rcases hy with ⟨z, hzm, hz⟩,
  rw ←set.image_id (↑(s.erase x) : set A) at hzm,
  rcases (finsupp.mem_span_iff_total R).1 hzm with ⟨l, hlm, hl⟩,
  rw ←hl at hz,
  rw linear_map.map_finsupp_total at hz,
  rw finsupp.total_apply at hz, rw ←hz,
  apply submodule.sum_mem,
  intros c hc,
  apply submodule.smul_mem,
  simp only [submodule.subtype_apply, function.comp.right_id, submodule.coe_mem, linear_map.comp_apply],
end

variables {M} {R}

noncomputable def map_erase {C : submodule R A} {s : finset M} {X : M} (h : X ∈ s)
  (hs : submodule.span R (↑s : set M) = A)
(hc : is_compl C (submodule.span R {⟨X, subset_span' hs h⟩})) :=
  finset.image (A.subtype.comp (C.subtype.comp (C.linear_proj_of_is_compl
    (submodule.span R {⟨X, subset_span' hs h⟩}) hc)))
  ((subtype_mk' s (A : set M) $ (subset_span' hs)).erase ⟨X, subset_span' hs h⟩)

lemma card_map_erase {C : submodule R A} {s : finset M} {X : M} (h : X ∈ s)
  (hs : submodule.span R (↑s : set M) = A)
  (hc : is_compl C (submodule.span R {⟨X, subset_span' hs h⟩})) :
  finset.card (map_erase _ h hs hc) ≤ (s.erase X).card :=
begin
  have H : finset.card (map_erase _ h hs hc) ≤ s.card.pred := by
  {have : (map_erase _ h hs hc).card ≤
         ((subtype_mk' s ↑A (subset_span' hs)).erase ⟨X, subset_span' hs h⟩).card :=
          finset.card_image_le,
  have h' : (subtype_mk' s ↑A (subset_span' hs)).card = s.card :=
    by {unfold subtype_mk', rw univ_card s,
      refine finset.card_image_of_injective _ _,
      intros x y hxy, simp only [subtype.mk_eq_mk] at hxy, exact subtype.ext_iff.2 hxy},
  rw ←h',
  have := finset.card_erase_of_mem (show (⟨X, subset_span' hs h⟩ : A) ∈
    subtype_mk' s ↑A (subset_span' hs), from (mem_subtype_mk' (subset_span' hs)).2 $
    by {rw subtype.coe_mk, exact h}),
  rw ←this,
  exact finset.card_image_le},
  apply le_trans H,
  rw finset.card_erase_of_mem h,
end
lemma gen_le2 {C : submodule R A} {s : finset M} {X : M} (h : X ∈ s) (h0 : X ≠ 0)
  (hs : submodule.span R (↑s : set M) = A)
(hc : is_compl C (submodule.span R {⟨X, subset_span' hs h⟩})) :
  C.map A.subtype = submodule.span R (↑(map_erase _ h hs hc) : set M) :=
begin
  have := gen_le M A (subtype_mk' s (A : set M) (subset_span' hs)) (span_subtype hs)
   ⟨X, subset_span' hs h⟩ ((mem_subtype_mk' (subset_span' hs)).2 h)
    (λ hn0, h0 $ subtype.ext_iff.1 hn0) C hc,
  unfold map_erase,
  rw finset.coe_image,
  rw submodule.span_image,
  rw submodule.span_image at this,
  rw submodule.map_comp,
  exact congr_arg (submodule.map A.subtype) this,
end

lemma woohoo (n : ℕ) (s : finset M) (hs : submodule.span R (↑s : set M) = A) (hn : s.card ≤ n) :
 (∃ (p : R), prime p ∧ ∀ a : M, (a ∈ A ∧ a ≠ 0) → ∃ (n : ℕ), p ^ (n + 1) • a = 0 ∧ p ^ n • a ≠ 0) →
 ∃ (S : finset M), submodule.span R (↑S : set _) = A ∧
 ∀ a ∈ S, submodule.span R {a} ⊓ submodule.span R (↑(S.erase a) : set M) = ⊥ :=
begin
  revert A s hs hn,
  induction n with m Hm,
  intros A s hs hn H,
  rw finset.card_eq_zero.1 (nat.le_zero_iff.1 hn) at hs,
  cases H with p hp,
  use ∅,
  split,
  exact hs,
  intros a ha,
  exfalso,
  exact finset.not_mem_empty _ ha,
  intros A s hs hm htors,
  cases htors with p hp,
  have Hp : ∀ a : M, (a ∈ A ∧ a ≠ 0) → ∃! (n : ℕ), p ^ (n + 1) • a = 0 ∧ p ^ n • a ≠ 0 :=
    λ a ha, exists_unique_of_exists_of_unique (hp.2 a ha) (λ y z hy hz, by
    {rw ←(@classical.not_not (y = z)),
    intro hnot,
    wlog hyz : y < z, exact lt_or_gt_of_ne hnot,
    cases nat.le.dest (nat.succ_le_of_lt hyz) with k hk,
    apply hz.2,
    rw ←hk, rw add_comm,
    rw pow_add, rw mul_smul, rw hy.1, rw smul_zero,
    }),
  have hmem : ∀ x ∈ s, x ∈ A := λ x H, hs ▸ (submodule.subset_span H),
  cases classical.em (m = 0),
  use s,
  split,
  exact hs,
  intros a ha,
  rw h at hm,
  have h01 : s.card = 0 ∨ s.card = 1 := by {revert hm, omega},
  cases h01,
  rw finset.card_eq_zero.1 h01, simp only [finset.coe_empty, submodule.span_empty,
    finset.erase_empty, inf_bot_eq],
  cases finset.card_eq_one.1 h01 with b hb,
  rw hb at ha ⊢,
  have hab : a = b := finset.mem_singleton.1 ha,
  rw hab,
  rw singleton_erase,
  erw submodule.span_empty,
  rw inf_bot_eq,
  cases (classical.em (s.card ≤ m)) with hsm hsm,
  cases Hm A s hs hsm ⟨p, hp⟩ with S hS,
  use S, exact hS,
  replace hsm : s.card = m.succ := by omega,
  have hn0 : (s.erase 0).nonempty := by {cases classical.em ((0 : M) ∈ s) with hs0 hs0,
  have hcard := finset.card_erase_of_mem hs0,
  rw hsm at hcard, rw nat.pred_succ at hcard,
  exact finset.card_pos.1 (by {rw hcard, exact nat.pos_iff_ne_zero.2 h}),
  have heq := finset.erase_eq_of_not_mem hs0,
  exact finset.card_pos.1 (by {rw heq, rw hsm, exact nat.succ_pos _})  },
  rcases exists_max hn0 (λ a ha, Hp a ⟨hmem a $ finset.mem_of_mem_erase ha,
    finset.ne_of_mem_erase ha⟩) with ⟨X, N, hN⟩,
  dsimp at hN,
  have hX0 : (⟨X, hmem X $ finset.mem_of_mem_erase hN.1⟩ : A) ≠ 0 := λ hX0,
    finset.ne_of_mem_erase hN.1 $ subtype.ext_iff.1 hX0,
  have hX : A.subtype ⟨X, hmem X $ finset.mem_of_mem_erase hN.1⟩ = X := rfl,
  cases classical.em ((0 : M) ∈ s),
  have he0 : submodule.span R (↑(s.erase 0) : set M) = submodule.span R (↑s : set _) :=
    by {conv {to_rhs, rw ←finset.insert_erase h_1}, rw insert_to_set, rw span_insert_zero_eq, },
  exact Hm A (s.erase 0) (he0.symm ▸ hs)
    (by {rw finset.card_erase_of_mem h_1, rw hsm, rw nat.pred_succ}) ⟨p, hp⟩,
  cases classical.em (∃ b, b ∉ submodule.span R ({⟨X, hmem X $ finset.mem_of_mem_erase hN.1⟩} : set A))
    with hmA hmA,
  cases exists_compl M A ⟨s, hs⟩ (N + 1) (nat.succ_ne_zero N)
   p hp.1 (Inf_eq _ A s hs p hp.1 Hp X N hN)
   ⟨X, hmem X $ finset.mem_of_mem_erase hN.1⟩
    (by rw nat.add_sub_cancel at *; exact (λ h, hN.2.1.2 $
  by {rw ←hX, rw ←linear_map.map_smul, rw h, rw linear_map.map_zero }))
  hmA with C hC,
  have hXs : (s.erase X).card = m :=
  by {rw finset.card_erase_of_mem (finset.erase_subset 0 s hN.1), rw hsm,
      rw nat.pred_succ},
  cases Hm (C.map A.subtype) (map_erase A (finset.erase_subset 0 s hN.1) hs
    ⟨eq_bot_iff.1 hC.1, eq_top_iff.1 hC.2⟩)
    (gen_le2 A (finset.erase_subset 0 s hN.1) (finset.ne_of_mem_erase hN.1) hs
      ⟨eq_bot_iff.1 hC.1, eq_top_iff.1 hC.2⟩).symm
    (by rw ←hXs; exact card_map_erase A (finset.erase_subset 0 s hN.1) hs
      ⟨eq_bot_iff.1 hC.1, eq_top_iff.1 hC.2⟩)
    (⟨p, ⟨hp.1, λ a ha, by {rcases ha.1 with ⟨b, hmb, hb⟩, apply hp.2, split, rw ←hb,
    exact b.2, exact ha.2}⟩⟩) with S hS,
  use insert X S, split,
  rw insert_to_set, rw span_insert', rw hS.1,
 rw sup_comm,
 rw map_sup' _ _ (hmem X $ finset.mem_of_mem_erase hN.1), rw hC.2, exact submodule.map_subtype_top _,
 intros b hb,
  rw finset.mem_insert at hb,
  cases hb,
  rw hb,
  rw eq_bot_iff,
  refine le_trans _ (inf_aux _ _ (hmem X $ finset.mem_of_mem_erase hN.1) hC hS),
  exact (@inf_le_inf_left (submodule R M) _ _ _ _ (submodule.span_mono $
  show (↑((insert X S).erase X : finset M) : set M) ⊆ (↑S : set _), from
    finset.erase_insert_subset X S)),
  rw eq_bot_iff,
  exact inf_aux' _ _ (hmem X $ finset.mem_of_mem_erase hN.1) (finset.mem_erase.1 hN.1).1 hC hS hb,
  use {X},
  split,
  apply le_antisymm,
  exact submodule.span_le.2 (by {rw finset.coe_singleton, exact set.singleton_subset_iff.2
    (hmem X $ finset.mem_of_mem_erase hN.1)}),
  intros Y hY, rw ←@classical.not_not (Y ∈ submodule.span R (↑{X} : set M)),
  intro hnot,
  rw finset.coe_singleton at *,
  exact hmA ⟨⟨Y, hY⟩, λ hmnot, hnot $ (map_singleton (hmem X $ finset.mem_of_mem_erase hN.1) hY).2 hmnot⟩,
  intros a ha, erw finset.mem_singleton at ha,
  rw ha,
  erw singleton_erase,
  show _ ⊓ submodule.span R ∅ = _,
  rw submodule.span_empty,
  rw inf_bot_eq,
end

instance quotient_module (I : ideal R) : module R I.quotient :=
submodule.quotient.semimodule I

variables (R) {M}
lemma ord_eq_ker (a : M) : ord R M a = (linear_map.id.smul_right a).ker :=
begin
  ext,
  rw linear_map.mem_ker,
  refl,
end

variables {R}

def quotient_congr {A B : submodule R M} (H : A = B) : linear_equiv R A.quotient B.quotient :=
(@quotient.congr_right _ A.quotient_rel B.quotient_rel $ λ x y : M, H ▸ iff.rfl).to_linear_equiv
{ map_add := λ x y, quotient.induction_on₂' x y $ λ w z, rfl,
  map_smul := λ x y, quotient.induction_on' y $ λ w, rfl }

lemma smul_range {a : M} : (submodule.span R ({a} : set M)) = (linear_map.id.smul_right a).range :=
begin
  ext,
  rw linear_map.mem_range,
  rw submodule.mem_span_singleton,
  refl,
end

def smul_range_equiv {a : M} : linear_equiv R (submodule.span R ({a} : set M))
((@linear_map.id R R _ _ _).smul_right a).range :=
(equiv.set_congr $ submodule.ext'_iff.1 smul_range).to_linear_equiv $
{ map_add := λ x y, rfl,
  map_smul := λ c x, rfl }

noncomputable def ord_quotient (a : M) : linear_equiv R (ord R M a).quotient
  (submodule.span R ({a} : set M)) :=
(quotient_congr $ ord_eq_ker R a).trans $ (linear_map.quot_ker_equiv_range
  ((@linear_map.id R R _ _ _).smul_right a)).trans
smul_range_equiv.symm


/-
Copyright (c) 2022 Matthias Uschold. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Matthias Uschold.
-/

import .def_amenable
import .aux_lemmas_bounded
import .quotient
import group_theory.free_group

/-!
# Nonamenability of Free groups

We prove that free groups (of rank at least two) are not amenable.

## Main Statements

- `F2_not_amenable`      : The free group on two generators is not amenable
- `not_amenable_of_free` : Free groups on at least two generators are not amenable

## References
* [C. Löh, *Geometric Group Theory*, Proposition 9.1.5][loeh17]
* <https://en.wikipedia.org/wiki/Amenable_group>
* [A.L.T. Paterson, *Amenability*, Example 0.6][Paterson1988]

## Tags
free groups, amenable, amenability

-/

open classical

/--a type with two elements-/
inductive ab
| a
| b

open ab

noncomputable instance ab_dec
  : decidable_eq ab
:= dec_eq ab

local notation `F2` := free_group ab

namespace F2_not_amenable_calc
/--Define a map giving the first letter of an element

We obtain the first letter by first taking the reduced word of the element,
then applying list.head' to this list

Note: This returns `none` on the neutral element -/
noncomputable def first_letter
  : F2 → option (ab × bool)
:= (λ w : F2, list.head' (free_group.to_word w))

/-! ### Characteristic Functions
-/
section indicator

noncomputable def indicator_bcont (p: F2 → Prop)
  : bounded_continuous_function F2 ℝ
:= bounded_continuous_function.mk
        (continuous_map.mk
          (set.indicator {w : F2 | p w} (λ x,1))
          continuous_of_discrete_topology)
        (begin
          rw function_bounded_classical,
          use 1,
          assume x : F2,
          simp,
          by_cases h : p x; finish,
        end)

lemma indicator_bcont_apply
  {p: F2 → Prop}
  {w : F2}
  : indicator_bcont p w = set.indicator {w : F2 | p w} (λ x,1) w
:= by refl

/-! Evaluating indicator functions -/
@[simp]
lemma indicator_bcont_apply1
  {p: F2 → Prop}
  {w : F2}
  (pw: p w)
  : indicator_bcont p w = 1
:= by simp [indicator_bcont_apply]; finish

@[simp]
lemma indicator_bcont_apply0
  {p: F2 → Prop}
  {w : F2}
  (npw: ¬ p w)
  : indicator_bcont p w = 0
:= by simp [indicator_bcont_apply]; finish

/--The sum of indicator functions belonging to disjoint predicates-/
lemma indicator_sum
  {p q: F2 → Prop}
  (pq_disjoint: ∀ (w:F2), p w → q w → false)
  : indicator_bcont p + indicator_bcont q = indicator_bcont (λ w, p w ∨ q w)
:= begin
  ext (x: F2),
  by_cases hp : p x,
  {
    simp,
    rw indicator_bcont_apply1 hp,
    have not_q : ¬ q x:= pq_disjoint x hp,
    rw indicator_bcont_apply0 not_q,
    rw indicator_bcont_apply1,
      linarith,
    left,
    assumption,
  },
  by_cases hq : q x,
  {
    simp,
    rw indicator_bcont_apply0 hp,
    rw indicator_bcont_apply1 hq,
    rw indicator_bcont_apply1,
      by linarith,
    right,
    assumption,
  },
  simp,
  rw indicator_bcont_apply0 hp,
  rw indicator_bcont_apply0 hq,
  rw indicator_bcont_apply0,
    by linarith,
  by tauto,
end

/--Indicator functions are nonnegative -/
lemma indicator_pos
  {p: F2 → Prop}
  : ∀ w : F2, indicator_bcont p w ≥ 0
:= begin
  assume w : F2,
  by_cases p w,
    rw indicator_bcont_apply1,
    linarith,
    assumption,
  rw indicator_bcont_apply0,
  linarith,
  assumption,
end

/--Indicator functions are ≤ 1 -/
lemma indicator_le1
  {p: F2 → Prop}
  : ∀ w : F2, indicator_bcont p w ≤ 1
:= begin
  assume w : F2,
   by_cases p w,
    rw indicator_bcont_apply1 h,
  rw indicator_bcont_apply0 h,
  by linarith,
end

/--Left translate of Indicator functions-/
lemma lefttransl_of_indicator
  {p: F2 → Prop}
  {g : F2}
  : left_translate g (indicator_bcont p) = indicator_bcont (λ x, p (g⁻¹*x))
:= begin
  ext (x:F2),
  rw left_translate_eval,
  tauto,
end

lemma mean_indicator_pos
  {p: F2 → Prop}
  {m: mean F2}
  : m (indicator_bcont p) ≥ 0
:= m.positivity indicator_pos

end indicator

/-!
  ### Main Idea
  The main idea is the following: We partition F2 into five subsets
  (depending on which letter a word starts with).

  We establish how these sets / indicator functions translate into one
  another and conclude that no left invariant mean can exist.
-/

@[simp]
noncomputable def ind_a
  : bounded_continuous_function F2 ℝ
:= indicator_bcont (λ w, first_letter w = some (a,tt))

@[simp]
noncomputable def ind_ainv
  : bounded_continuous_function F2 ℝ
:= indicator_bcont (λ w, first_letter w = some (a,ff))

@[simp]
noncomputable def ind_b
  : bounded_continuous_function F2 ℝ
:= indicator_bcont (λ w, first_letter w = some (b,tt))

@[simp]
noncomputable def ind_binv
  : bounded_continuous_function F2 ℝ
:= indicator_bcont (λ w, first_letter w = some (b,ff))

section aw_starts

/-!
Some technical lemmas establishing which letter
the word a*w starts with
-/

@[simp]
lemma mk_to_word
  {L: list (ab × bool)}
  : (free_group.mk L).to_word = free_group.reduce L
:= by simp [free_group.to_word]

/--A technical lemma -/
lemma reduce_step_reduced
  {x y : ab × bool}
  {L : list (ab × bool)}
  (Lred: free_group.reduce (y :: L) = y :: L)
  : free_group.reduce (x :: y :: L) =
          ite (x.fst = y.fst ∧ x.snd = !y.snd)
            L
            (x :: y :: L)
:= begin
  rw free_group.reduce.cons,
  rw Lred,
end

/-- If L is a reduced list and does not start with a⁻¹,
then a :: L starts with a -/
lemma aw_start_a_lists_reduced
  {a' : ab} -- think of as 'a' when proving but can also be b
  {L : list (ab × bool)}
  (hL: L.head' ≠ some (a', ff))
  (Lred: free_group.reduce L = L)
  : (free_group.reduce ((a', tt) :: L)).head' = some (a',tt)
:= begin
  cases L,
    simp [free_group.reduce],
  simp at hL,
  have : free_group.reduce ((a', tt) :: L_hd :: L_tl)
        = (a', tt) :: L_hd :: L_tl,
  {
    have : ¬((a',tt).fst = L_hd.fst ∧ (a',tt).snd = !L_hd.snd), -- should be easy
    {
      simp,
      assume L_hd_first_a',
      cases L_hd,
      simp,
      simp at L_hd_first_a',
      simp at hL,
      have : L_hd_snd = tt
          := hL L_hd_first_a'.symm,
      rw this,
    },

    calc free_group.reduce ((a',tt) :: L_hd :: L_tl)
      = ite ((a',tt).fst = L_hd.fst ∧ (a',tt).snd = !L_hd.snd) L_tl ((a',tt) :: L_hd :: L_tl)
        : by exact reduce_step_reduced Lred
    ... = (a',tt) :: L_hd :: L_tl
        : by simp [this],
  },
  by simp [this]; dsimp[head']; simp,
end

/-- The same lemma as above for lists-/
lemma aw_start_a_lists
  {a' : ab} -- think of as 'a' when proving but can also be b
  {L : list (ab × bool)}
  (hL: (free_group.reduce L).head' ≠ some (a', ff))
  : (free_group.reduce ((a', tt) :: L)).head' = some (a',tt)
:= begin
  have two_red : free_group.reduce ((a', tt) :: L)
              = free_group.reduce ((a', tt) :: free_group.reduce L),
  {
    have : free_group.red L (free_group.reduce L)
          := free_group.reduce.red,
    have append_red:
           free_group.red ((a', tt) :: L) ((a', tt) :: free_group.reduce L)
          := free_group.red.cons_cons this,
    exact free_group.reduce.eq_of_red append_red,
  },
  have Lred : free_group.reduce (free_group.reduce L) = free_group.reduce L
      := free_group.reduce.idem,
  calc  (free_group.reduce ((a', tt) :: L)).head'
      = (free_group.reduce ((a', tt) :: free_group.reduce L)).head'
        : by rw two_red
  ... = some (a', tt)
        : by exact aw_start_a_lists_reduced hL Lred,
end

/-- The main lemma that will be used : If w is an element of F2
whose reduced word does not start with a⁻¹,
then a*w starts with a (as there will be no cancellation)-/
lemma aw_start_a
  {a' : ab} -- think of as 'a' when proving but can also be b
  {w : F2}
  :  ( first_letter w ≠ some (a', ff))
    → first_letter ((free_group.of a')*w) = some (a',tt)
:= begin
  apply quot.induction_on w,
  assume (L : list (ab × bool)),
  assume first_letter_neq_ainv,
  dsimp[first_letter],
  dsimp[first_letter] at first_letter_neq_ainv,
  --simp only [mk_to_word] at first_letter_neq_ainv,
  simp only[free_group.of, free_group.mul_mk],
  rw mk_to_word,
  show (free_group.reduce ([(a', tt)] ++ L)).head' = some (a', tt),
  by exact aw_start_a_lists first_letter_neq_ainv,
end

end aw_starts

/-- The sum of the following indicator functions is at least 1
  (any word starts with a, or a* this word does)-/
lemma sum_transl_ind_a_ainv
  (a' : ab)
  :  left_translate (free_group.of a')⁻¹ (indicator_bcont (λ w, first_letter w = some (a',tt)))
    + indicator_bcont (λ w, first_letter w = some (a',ff))
    ≥ 1
:= begin
  assume (w:F2),
  by_cases hw : first_letter w = some (a',ff),
    simp,
    have : indicator_bcont (λ w, first_letter w = some (a',ff)) w = 1
      := indicator_bcont_apply1 hw,
    rw this,
    simp,
    exact indicator_pos _,
  rw lefttransl_of_indicator,
  simp,
  have : first_letter (free_group.of a' * w) = some (a', tt)
      := aw_start_a hw,
  have : ⇑(indicator_bcont (λ (x : F2), first_letter (free_group.of a' * x) = some (a', tt))) w
          = 1
      := indicator_bcont_apply1 this,
  rw this,
  simp,
  exact indicator_pos _,
end

/--Lemma that is used in ind_sum -/
lemma ind_sum_lemma
 : ∀ (w : F2), first_letter w = some (a, tt) → first_letter w = some (a, ff) → false
:= begin
  assume w firstw₁ firstw₂,
  by finish,
end

/--Lemma that is used in ind_sum no. 2 -/
lemma ind_sum_lemma'
  : ∀ (w : F2),
    first_letter w = some (a, tt) ∨ first_letter w = some (a, ff)
  → first_letter w = some (b, tt)
  → false
:= begin
   assume w firstw,
    cases firstw,
    {
      by finish,
    },
    {
      by finish,
    },
end

/--The sum of these indicator functions is at most one
(their predicates are disjoint)-/
lemma ind_sum
  : ind_a + ind_ainv + ind_b + ind_binv
   ≤  bounded_continuous_function.const F2 (1:ℝ)
:= begin
  dsimp [ind_a, ind_ainv, ind_b, ind_binv],
  repeat {rw indicator_sum},
    exact indicator_le1,
  --left to prove 'trivial' nonequality statements
  {
    assume w firstw,
    cases firstw,
      cases firstw,
        by finish,
      by finish,
    by finish,
  },
  exact ind_sum_lemma',
  exact ind_sum_lemma,
end

-- this is somehow necessary
lemma invmean_add
  {G: Type*} [group G]
  {m : left_invariant_mean G}
  {f g: bounded_continuous_function G ℝ}
  : m (f+g) = m f + m g
:= m.to_mean.lin_map.map_add' f g

end F2_not_amenable_calc

open mean
open F2_not_amenable_calc

lemma mean_add_four
  {a b c d : bounded_continuous_function F2 ℝ}
  {m : left_invariant_mean F2}
  : m a + m b + m c +  m d = m (a+b) + m (c+d)
:= begin
  rw invmean_add,
  rw invmean_add,
  by ring,
end

/--The free group on two generators is not amenable-/
theorem F2_not_amenable
  : ¬ amenable (free_group ab)
:= begin
  assume h : amenable F2,
  let m : left_invariant_mean F2 := invmean_of_amenable h,

  have sum_le_1 : m ind_a + m ind_ainv + m ind_b + m ind_binv ≤ 1,
  {
    calc  m ind_a + m ind_ainv + m ind_b + m ind_binv
        = m (ind_a +  ind_ainv +  ind_b +  ind_binv)
          : by repeat {rw invmean_add}
    ... ≤ m (bounded_continuous_function.const F2 (1:ℝ))
          : by exact mean_monotone F2 ind_sum
    ... = 1
          : by exact m.normality,
  },

  have sum_ge_2 : m ind_a + m ind_ainv + m ind_b + m ind_binv ≥ 2,
  {
    have inv_ind_a : m (left_translate (free_group.of a)⁻¹ ind_a) = m ind_a
          := m.left_invariance _ _,
    have inv_ind_b : m (left_translate (free_group.of b)⁻¹ ind_b) = m ind_b
          := m.left_invariance _ _,

    calc   m ind_a + m ind_ainv + m ind_b + m ind_binv
         = m (left_translate (free_group.of a)⁻¹ ind_a) + m ind_ainv
         + m (left_translate (free_group.of b)⁻¹ ind_b) + m ind_binv
          : by rw ← inv_ind_a; rw ← inv_ind_b
    ...  = m (left_translate (free_group.of a)⁻¹ ind_a +  ind_ainv)
         + m (left_translate (free_group.of b)⁻¹ ind_b +  ind_binv)
          : by exact mean_add_four
    ...  ≥ m (bounded_continuous_function.const F2 (1:ℝ))
         + m (bounded_continuous_function.const F2 (1:ℝ))
          : by {
            have : m (left_translate (free_group.of a)⁻¹ ind_a +  ind_ainv)
                ≥ m (bounded_continuous_function.const F2 (1:ℝ))
                := mean_monotone F2 (sum_transl_ind_a_ainv a),
            have : m (left_translate (free_group.of b)⁻¹ ind_b +  ind_binv)
                ≥ m (bounded_continuous_function.const F2 (1:ℝ))
                := mean_monotone F2 (sum_transl_ind_a_ainv b),
            by linarith,
          }
    ...  = 2
          : by {
            have : m (bounded_continuous_function.const F2 (1:ℝ)) = 1
                    := m.normality,
            by linarith,
          },
  },

  by linarith only [sum_ge_2, sum_le_1],
end

open function

/-!
We establish that free groups (on at least two generators)
are not amenable because they have F2 as a quotient.
-/

/--Corollary: Free groups are not amenable-/
theorem not_amenable_of_free
  {X : Type*}
  {a' b' : X}
  (hab : a' ≠ b')
  : ¬ amenable (free_group X)
:= begin
  -- Assume that the free group were amenable
  -- and show that then F2 would be amenable
  assume is_amenable : amenable (free_group X),
  classical,
  -- define maps in both directions
  -- to see that F2 is a quotient of free_group X
  let p' : X → ab
    := (λ x, ite (x=a') a b),
  let p : (free_group X) →* (free_group ab)
      := free_group.map p',
  let s' : ab → X
      := (λ x, ab.rec_on x a' b'),
  let s : (free_group ab) →* (free_group X)
      := free_group.map s',
  -- s is a split of p
  have : p ∘ s = id,
  {
    dsimp[p,s],
    ext (w: free_group ab),
    simp,
    rw free_group.map.comp,
    have : p' ∘ s' = id,
    {
      ext (a' : ab),
      dsimp[p',s'],
      cases a',
        by simp,
      simp,
      exact (λ eq', hab eq'.symm),
    },
    rw this,
    exact free_group.map.id _,
  },

  have p_surj : surjective p,
  {
    have : left_inverse p s
      := left_inverse_iff_comp.mpr this,
    exact left_inverse.surjective this,
  },
  have F2_am : amenable (free_group ab)
    := amenable_of_quotient' p p_surj is_amenable,
  exact F2_not_amenable F2_am,
end


/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Jeremy Avigad

Interactions between finset and set.
-/
import data.finset.comb data.set.function
open nat eq.ops set

namespace finset

variable {A : Type}
variable [deceq : decidable_eq A]

definition to_set [coercion] (s : finset A) : set A := λx, x ∈ s
abbreviation ts := @to_set A

variables (s t : finset A) (x y : A)

theorem mem_eq_mem_to_set : x ∈ s = (x ∈ ts s) := rfl

definition to_set.inj {s₁ s₂ : finset A} : to_set s₁ = to_set s₂ → s₁ = s₂ :=
λ h, ext (λ a, iff.of_eq (calc
  (a ∈ s₁) = (a ∈ ts s₁) : mem_eq_mem_to_set
       ... = (a ∈ ts s₂) : h
       ... = (a ∈ s₂)    : mem_eq_mem_to_set))

/- operations -/

theorem mem_to_set_empty : (x ∈ ts ∅) = (x ∈ ∅) := rfl
theorem to_set_empty : ts ∅ = (@set.empty A) := rfl

theorem mem_to_set_univ [h : fintype A] : (x ∈ ts univ) = (x ∈ set.univ) :=
  propext (iff.intro (assume H, trivial) (assume H, !mem_univ))
theorem to_set_univ [h : fintype A] : ts univ = (set.univ : set A) := funext (λ x, !mem_to_set_univ)

theorem mem_to_set_upto (x n : ℕ) : x ∈ ts (upto n) = (x ∈ {a | a < n}) := !mem_upto_eq
theorem to_set_upto (n : ℕ) : ts (upto n) = {a | a < n} := funext (λ x, !mem_to_set_upto)

include deceq

theorem mem_to_set_insert : x ∈ insert y s = (x ∈ set.insert y s) := !mem_insert_eq
theorem to_set_insert : insert y s = set.insert y s := funext (λ x, !mem_to_set_insert)

theorem mem_to_set_union : x ∈ s ∪ t = (x ∈ ts s ∪ ts t) := !mem_union_eq
theorem to_set_union : ts (s ∪ t) = ts s ∪ ts t := funext (λ x, !mem_to_set_union)

theorem mem_to_set_inter : x ∈ s ∩ t = (x ∈ ts s ∩ ts t) := !mem_inter_eq
theorem to_set_inter : ts (s ∩ t) = ts s ∩ ts t := funext (λ x, !mem_to_set_inter)

theorem mem_to_set_diff : x ∈ s \ t = (x ∈ ts s \ ts t) := !mem_diff_eq
theorem to_set_diff : ts (s \ t) = ts s \ ts t := funext (λ x, !mem_to_set_diff)

theorem mem_to_set_sep (p : A → Prop) [h : decidable_pred p] : x ∈ sep p s = (x ∈ set.sep p s) :=
  !finset.mem_sep_eq
theorem to_set_sep (p : A → Prop) [h : decidable_pred p] : sep p s = set.sep p s :=
  funext (λ x, !mem_to_set_sep)

theorem mem_to_set_image {B : Type} [h : decidable_eq B] (f : A → B) {s : finset A} {y : B} :
  y ∈ image f s = (y ∈ set.image f s) := !mem_image_eq
theorem to_set_image {B : Type} [h : decidable_eq B] (f : A → B) (s : finset A) :
  image f s = set.image f s := funext (λ x, !mem_to_set_image)

/- relations -/

definition decidable_mem_to_set [instance] (x : A) (s : finset A) : decidable (x ∈ ts s) :=
decidable_of_decidable_of_eq _ !mem_eq_mem_to_set

theorem eq_of_to_set_eq_to_set {s t : finset A} (H : to_set s = to_set t) : s = t :=
ext (take x, by rewrite [mem_eq_mem_to_set s, H])

theorem eq_eq_to_set_eq : (s = t) = (ts s = ts t) :=
propext (iff.intro (assume H, H ▸ rfl) !eq_of_to_set_eq_to_set)

definition decidable_to_set_eq [instance] (s t : finset A) : decidable (ts s = ts t) :=
decidable_of_decidable_of_eq _ !eq_eq_to_set_eq

theorem subset_eq_to_set_subset (s t : finset A) : (s ⊆ t) = (ts s ⊆ ts t) :=
propext (iff.intro
  (assume H, take x xs, mem_of_subset_of_mem H xs)
  (assume H, subset_of_forall H))

definition decidable_to_set_subset (s t : finset A) : decidable (ts s ⊆ ts t) :=
decidable_of_decidable_of_eq _ !subset_eq_to_set_subset

/- bounded quantifiers -/

definition decidable_bounded_forall (s : finset A) (p : A → Prop) [h : decidable_pred p] :
  decidable (∀₀ x ∈ ts s, p x) :=
decidable_of_decidable_of_iff _ !all_iff_forall

definition decidable_bounded_exists (s : finset A) (p : A → Prop) [h : decidable_pred p] :
  decidable (∃₀ x ∈ ts s, p x) :=
decidable_of_decidable_of_iff _ !any_iff_exists

/- properties -/

theorem inj_on_to_set {B : Type} [h : decidable_eq B] (f : A → B) (s : finset A) :
  inj_on f s = inj_on f (ts s) :=
rfl

end finset