/-
Credit to Markus Himmel for the corresponding file about `Module` in mathlib
-/
import for_mathlib.AddCommGroup.epi

open category_theory
open category_theory.limits
open category_theory.limits.walking_parallel_pair

universes u

namespace AddCommGroup

variables {M N : AddCommGroup.{u}} (f : M ⟶ N)

/-- The kernel cone induced by the concrete kernel. -/
def kernel_cone : kernel_fork f :=
@kernel_fork.of_ι AddCommGroup _ _ M N f (of f.ker) (f.ker.subtype : of f.ker ⟶ M) $
by { ext1, cases x, assumption }

/-- The kernel of a linear map is a kernel in the categorical sense. -/
def kernel_is_limit : is_limit (kernel_cone f) :=
fork.is_limit.mk _
  (λ s : fork f 0, add_monoid_hom.cod_restrict (fork.ι s) f.ker $
    λ c, (add_monoid_hom.mem_ker _).2 $
    by { rw [←@function.comp_apply _ _ _ f s.ι c, ←coe_comp, fork.condition,
      has_zero_morphisms.comp_zero (fork.ι s) N], refl })
  (λ s, by { ext, simp only [comp_apply, add_monoid_hom.cod_restrict_apply], refl })
  (λ s m h, add_monoid_hom.ext $ λ x, subtype.ext_iff_val.2 $
    have h₁ : (m ≫ (kernel_cone f).π.app zero).to_fun = (s.π.app zero).to_fun,
      by { congr, exact h },
    by convert @congr_fun _ _ _ _ h₁ x )

/-- The cokernel cocone induced by the projection onto the quotient. -/
def cokernel_cocone : cokernel_cofork f :=
@cokernel_cofork.of_π AddCommGroup _ _ M N f (of $ N ⧸ f.range) (quotient_add_group.mk' f.range) $
by { ext1, simp only [comp_apply, quotient_add_group.mk'_apply, zero_apply,
  quotient_add_group.eq_zero_iff, add_monoid_hom.mem_range, exists_apply_eq_apply], }

/-- The projection onto the quotient is a cokernel in the categorical sense. -/
def cokernel_is_colimit : is_colimit (cokernel_cocone f) :=
cofork.is_colimit.mk _
  (λ s : cofork f 0, quotient_add_group.lift _ s.π $
  by { rintro _ ⟨x, rfl⟩, have := add_monoid_hom.congr_fun s.condition x,
    simpa only [comp_apply, zero_apply, map_zero] using this, })
  (λ s, by { ext, simp only [comp_apply], refl })
  (λ s m h,
  begin
    let g : N ⟶ (of $ N ⧸ f.range) := (quotient_add_group.mk' f.range),
    haveI : epi g := (epi_iff_range_eq_top _).mpr _,
    swap, { ext ⟨x⟩, simp only [add_monoid_hom.mem_range, quotient_add_group.mk'_apply,
      add_subgroup.mem_top, iff_true], exact ⟨x, rfl⟩ },
    apply (cancel_epi g).1,
    convert h,
    ext, refl,
  end)

-- We now show this isomorphism commutes with the inclusion of the kernel into the source.

-- TODO: the next two already exist: add `elementwise` to those lemmas in mathlib

@[simp, elementwise] lemma kernel_iso_ker_inv_kernel_ι :
  (kernel_iso_ker f).inv ≫ kernel.ι f = f.ker.subtype :=
kernel_iso_ker_inv_comp_ι _

@[simp, elementwise] lemma kernel_iso_ker_hom_ker_subtype :
  (kernel_iso_ker f).hom ≫ f.ker.subtype = kernel.ι f :=
kernel_iso_ker_hom_comp_subtype _

/--
The categorical cokernel of a morphism in `Module`
agrees with the usual module-theoretical quotient.
-/
noncomputable def cokernel_iso_range_quotient : cokernel f ≅ of (N ⧸ f.range) :=
colimit.iso_colimit_cocone ⟨_, cokernel_is_colimit f⟩

-- We now show this isomorphism commutes with the projection of target to the cokernel.

@[simp, elementwise] lemma cokernel_π_cokernel_iso_range_quotient_hom :
  cokernel.π f ≫ (cokernel_iso_range_quotient f).hom = quotient_add_group.mk' f.range :=
by { convert colimit.iso_colimit_cocone_ι_hom _ _; refl, }

@[simp, elementwise] lemma range_mkq_cokernel_iso_range_quotient_inv :
  (by exact quotient_add_group.mk' f.range : _) ≫ (cokernel_iso_range_quotient f).inv = cokernel.π f :=
by { convert colimit.iso_colimit_cocone_ι_inv ⟨_, cokernel_is_colimit f⟩ _; refl, }

end AddCommGroup


import game.world_08_advanced_addition
namespace mynat

theorem mul_pos (a b : mynat) : a ≠ 0 → b ≠ 0 → a * b ≠ 0 := begin[nat_num_game]
  intros anz bnz f,
  cases b, {
    apply bnz,
    refl
  }, {
    rw mul_succ at f,
    apply anz,
    induction a,
    refl, {
      apply add_left_eq_zero,
      rwa f,
    }
  }
end

theorem eq_zero_or_eq_zero_of_mul_eq_zero (a b : mynat) (h : a * b = 0) : a = 0 ∨ b = 0 := begin[nat_num_game]
  induction b, {
    right,
    refl
  }, {
    left,
    rw mul_succ at h,
    apply add_left_eq_zero,
    apply h
  }
end

theorem mul_eq_zero_iff (a b : mynat): a * b = 0 ↔ a = 0 ∨ b = 0 := begin[nat_num_game]
  split,
  apply eq_zero_or_eq_zero_of_mul_eq_zero, {
    intro or_eq_zero,
    cases or_eq_zero,
    rwa [or_eq_zero, zero_mul],
    rwa [or_eq_zero, mul_zero],
  }
end

theorem mul_left_cancel (a b c : mynat) (ha : a ≠ 0) : a * b = a * c → b = c := begin[nat_num_game]
  induction c generalizing b, {
    rw mul_zero,
    intro h,
    cases eq_zero_or_eq_zero_of_mul_eq_zero _ _ h, {
      exfalso,
      exact ha h_1
    }, exact h_1
  }, {
    intro eq,
    cases b, {
      rw mul_zero at eq,
      exfalso,
      apply ha,
      symmetry at eq,
      cases eq_zero_or_eq_zero_of_mul_eq_zero _ _ eq,
      exact h, {
        exfalso,
        exact succ_ne_zero _ h,
      }
    },{
      have hyp : b = c_n, {
        apply c_ih,
        rw mul_succ at eq,
        rw mul_succ at eq,
        apply add_right_cancel _ _ _ eq,
      },
      rwa hyp,
    }
  }
end

end mynat


import data.polynomial.basic
import data.polynomial.eval
import data.real.basic
import algebra.ring.basic
import ring_theory.derivation

noncomputable theory
open finset
open_locale big_operators polynomial
universes u v
variables {R : Type} {a b : R} {m n : ℕ} [field R] [nontrivial R]

namespace umbral_calculus

  -- Describe binomial polynomial sequences
  class binomial_polynomial_sequence (ps : ℕ → R[X]) :=
    (to_poly : ℕ → R[X])
    (degree_matches : ∀ (n : ℕ), ↑n = (to_poly n).degree)
    (is_binomial : ∀ (n : ℕ) (x y : R), (ps n).eval (x + y) =
      ∑ (k : ℕ) in range (n + 1), ((ps k).eval x) * ((ps (n - k)).eval y) * n.choose k)

  -- Define the shift operator
  def shift_operator (ps : R[X]) : R[X] :=
    polynomial.comp ps (polynomial.X + polynomial.C 1)

  def shift_a_operator (a : R) (ps : R[X]) : R[X] :=
    polynomial.comp ps (polynomial.X + polynomial.C a)

  @[simp] lemma shift_x_by_a {a : R} :
    shift_a_operator a polynomial.X = polynomial.X + polynomial.C a :=
      by rw [shift_a_operator, polynomial.X_comp]

  @[simp] lemma shift_monomial_by_a {a : R} :
    shift_a_operator a ((polynomial.X) ^ n) = (polynomial.X + polynomial.C a) ^ n :=
    by rw [shift_a_operator, polynomial.X_pow_comp]

  def shift_one_op_eq_shift_op :
    (shift_operator : R[X] → R[X]) = shift_a_operator 1 :=
  begin
    ext,
    rw [shift_operator, shift_a_operator],
  end

  theorem shift_ab_operator_add (a b : R) (p : R[X]) :
    (shift_a_operator a) ((shift_a_operator b) p) = shift_a_operator (a + b) p :=
  begin
    repeat {rw shift_a_operator},
    ext,
    rw [polynomial.comp_assoc, polynomial.add_comp],
    simp,
    rw add_assoc,
  end

  def shift_ring_hom (a : R) : ring_hom R[X] R[X] :=
  {
    to_fun := shift_a_operator a,
    map_one' := by rw [shift_a_operator, polynomial.one_comp],
    map_mul' := begin
      intros a b,
      repeat {rw shift_a_operator},
      simp,
    end,
    map_zero' := by rw [shift_a_operator, polynomial.zero_comp],
    map_add' := begin
      intros a b,
      repeat {rw shift_a_operator},
      simp,
    end,
  }

  def shift_linear_map (a : R) : linear_map (shift_ring_hom a : R[X] →+* R[X]) R[X] R[X] :=
  {
    to_fun := shift_ring_hom a,
    map_add' := begin
      intros x y,
      repeat {rw shift_a_operator},
      have := (shift_ring_hom a).map_add' x y,
      simp,
    end,
    map_smul' := begin
      intros x y,
      repeat {rw shift_a_operator},
      have := (shift_ring_hom a).map_mul' x y,
      simp,
    end,
  }

  -- Show that the single variable monomials indexed by power are a binomial polynomial sequence
  instance monomial_is_bps : binomial_polynomial_sequence (λ (n : ℕ), polynomial.monomial n (1 : ℝ)) :=
  {
    to_poly := (λ (n : ℕ), polynomial.monomial n (1 : ℝ)),
    degree_matches := begin
      intro n,
      simp,
    end,
    is_binomial := begin
      intros n x y,
      simp,
      exact add_pow x y n,
    end
  }

  class shift_invariant_op (op : R[X] →+* R[X]) :=
    (is_shift_invariant : ∀ (a : R), ring_hom.comp
      op (shift_ring_hom a) = ring_hom.comp (shift_ring_hom a) op)

  -- The shift operators are shift invariant
  instance shift_a_operator_is_shift_invariant_op (a : R) :
    shift_invariant_op (shift_ring_hom a) :=
  {
    is_shift_invariant := begin
      intros b,
      repeat {rw shift_ring_hom},
      repeat {rw ring_hom.comp},
      simp,
      repeat {rw function.comp},
      ext,
      repeat {rw shift_a_operator},
      repeat {rw polynomial.comp_assoc},
      repeat {rw polynomial.add_comp},
      simp,
      rw [add_assoc, add_comm (polynomial.C a), ← add_assoc],
    end,
  }

  class delta_op (op : R[X] →+* R[X]) extends shift_invariant_op op :=
    (is_delta : ∃ (c : R), op polynomial.X = polynomial.C c ∧ c ≠ 0)

  /- This lemma specifically requires a ring structure on R
     so that we can use the additive group property add_right_inj.
     The previous theorems only require a semiring.
  -/
  lemma delta_constant_is_zero (op : R[X] →+* R[X]) [delta_op op] :
    ∀ (a : R), op (polynomial.C a) = 0 :=
  begin
    intro a,
    have q₁ := _inst_3.is_shift_invariant a,
    have q₂ := _inst_3.is_delta,
    cases q₂ with c q₃,
    repeat {rw ring_hom.comp at q₁},
    simp at q₁,
    repeat {rw function.comp at q₁},
    replace q₁ : (λ (x : R[X]), op ((shift_ring_hom a) x)) (polynomial.X) =
      (λ (x : R[X]), (shift_ring_hom a) (op x)) (polynomial.X) := by rw q₁,
    simp at q₁,
    repeat {rw shift_ring_hom at q₁},
    simp at q₁,
    repeat {rw shift_a_operator at q₁},
    rw q₃.1 at q₁,
    rw polynomial.C_comp at q₁,
    nth_rewrite_rhs 0 ← add_zero (polynomial.C c) at q₁,
    rw add_right_inj at q₁,
    exact q₁,
  end

  lemma delta_op_comm_shift_pow (n : ℕ)
    (op : R[X] →+* R[X])
    [delta_op op]
    (a : R) :
    op ((polynomial.X + polynomial.C a) ^ (n + 1)) =
      shift_a_operator a (op polynomial.X ^ (n + 1)) :=
  begin
    have q' := _inst_3.is_shift_invariant a,
    repeat {rw ring_hom.comp at q'},
    simp at q',
    repeat {rw function.comp at q'},
    replace q' : (λ (x : R[X]), op ((shift_ring_hom a) x)) (polynomial.X ^ (n + 1)) =
      (λ (x : R[X]), (shift_ring_hom a) (op x)) (polynomial.X ^ (n + 1)) := by rw q',
    dsimp at q',
    rw ← shift_monomial_by_a,
    repeat {rw shift_ring_hom at q'},
    simp at q',
    simp,
    exact q',
  end

  lemma delta_op_is_linear_map (op : R[X] →+* R[X]) [delta_op op] :
    linear_map op R[X] R[X] :=
  {
    to_fun := op,
    map_add' := begin
      intros x y,
      simp,
    end,
    map_smul' := begin
      intros r x,
      simp,
    end,
  }

  instance delta_op.has_smul (op : R[X] →+* R[X]) [delta_op op] : has_smul R R[X] :=
  {
    smul := (λ (r: R) (x : R[X]), polynomial.C r * op x),
  }

  theorem delta_op.is_derivation (op : R[X] →+* R[X]) [delta_op op]
    (n : ℕ) : (op (polynomial.X ^ (n + 1))).degree =
    ((op polynomial.X ^ n) * polynomial.X + polynomial.X ^ (n + 1) * op polynomial.X).degree
    :=
  begin
    have q₁ := _inst_3.is_delta,
    cases q₁ with a q₁,
    cases q₁ with b c,
  /-
    induction n with n ih,
    {
      simp,
      have q₁ := _inst_3.is_delta,
      cases q₁ with a h,
      have q₂ : (polynomial.X : R[X]).degree = 1 := polynomial.degree_X,
      rw h.1,
      rw polynomial.degree_C h.2,

      /-
      have : (0 : with_bot ℕ) < (polynomial.X : R[X]).degree :=
      begin
        have : 0 < 1, by norm_num,
        rw ← with_bot.coe_lt_coe at this,
        simp,
        exact this,
      end,
      rw [h.1, polynomial.degree_add_C this],
      -/
    },
    {

    },
  -/
  end

  lemma delta_decreases_degree (n : ℕ) (op : R[X] →+* R[X]) [delta_op op]
    : (op (polynomial.X ^ (n + 1))).degree = ↑n :=
  begin
    induction n with n ih,
    {
      simp,
      have q₁ := _inst_3.is_delta,
      cases q₁ with a q₁,
      have q₂ := q₁.1,
      have := congr_arg polynomial.degree q₂,
      rw polynomial.degree_C q₁.2 at this,
      exact this,
    },
    {

    },

/-
    have q₁ := _inst_3.is_delta,
    cases q₁ with a q₁,
    have := add_pow (polynomial.C a) polynomial.X (n + 1),
    have q₂ : op ((polynomial.X + polynomial.C a) ^ (n + 1)) = op (∑ (m : ℕ) in range (n + 1 + 1), polynomial.C a ^ m * polynomial.X ^ (n + 1 - m) * ↑((n + 1).choose m)) := begin
      rw add_comm,
      rw this,
    end,
    clear this,
    -- linearity of ring homomorphisms
    rw ring_hom.map_sum at q₂,
    /-simp at q₂,
    have : a = (polynomial.X : R[X]).eval a, by simp,
    rw this at q₂,-/

    have := delta_op_comm_shift_pow n op a,
    rw this at q₂,
-/
  /-
    have q₃ : ((op polynomial.X + op (polynomial.C a)) ^ (n + 1)).eval 0 = (∑ (x : ℕ) in range (n + 1 + 1), op polynomial.X ^ x * op (polynomial.C a) ^ (n + 1 - x) * ↑((n + 1).choose x)).eval 0, by rw q₂,
    simp at q₃,
    rw [q₁.1, polynomial.eval_C, delta_constant_is_zero, polynomial.eval_zero, add_zero] at q₃,
  -/

/-
    rw delta_constant_is_zero at q₂,
    simp at q₂,
-/
/-
    have := add_pow polynomial.X (polynomial.C a) (n + 1),
    have q₂ : op ((polynomial.X + polynomial.C a) ^ (n + 1)) = op (∑ (m : ℕ) in range (n + 1 + 1), polynomial.X ^ m * polynomial.C a ^ (n + 1 - m) * ↑((n + 1).choose m)), by rw this,
    clear this,
    -- linearity of ring homomorphisms
    rw ring_hom.map_sum at q₂,
    simp at q₂,
    rw delta_constant_is_zero at q₂,
    simp at q₂,

    have q₃ := delta_op_comm_shift_pow n op a,
    have q₄ : (0 : R[X]) ^ 0 = 1, by norm_num,
-/
  end

end umbral_calculus


/-
Copyright (c) 2019 Neil Strickland. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Neil Strickland
-/
import tactic.ring
import data.pnat.prime

/-!
# Euclidean algorithm for ℕ

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

This file sets up a version of the Euclidean algorithm that only works with natural numbers.
Given `0 < a, b`, it computes the unique `(w, x, y, z, d)` such that the following identities hold:
* `a = (w + x) d`
* `b = (y + z) d`
* `w * z = x * y + 1`
`d` is then the gcd of `a` and `b`, and `a' := a / d = w + x` and `b' := b / d = y + z` are coprime.

This story is closely related to the structure of SL₂(ℕ) (as a free monoid on two generators) and
the theory of continued fractions.

## Main declarations

* `xgcd_type`: Helper type in defining the gcd. Encapsulates `(wp, x, y, zp, ap, bp)`. where `wp`
  `zp`, `ap`, `bp` are the variables getting changed through the algorithm.
* `is_special`: States `wp * zp = x * y + 1`
* `is_reduced`: States `ap = a ∧ bp = b`

## Notes

See `nat.xgcd` for a very similar algorithm allowing values in `ℤ`.
-/

open nat

namespace pnat

/-- A term of xgcd_type is a system of six naturals.  They should
 be thought of as representing the matrix
 [[w, x], [y, z]] = [[wp + 1, x], [y, zp + 1]]
 together with the vector [a, b] = [ap + 1, bp + 1].
-/
@[derive inhabited]
structure xgcd_type :=
(wp x y zp ap bp : ℕ)

namespace xgcd_type

variable (u : xgcd_type)

instance : has_sizeof xgcd_type := ⟨λ u, u.bp⟩

/-- The has_repr instance converts terms to strings in a way that
 reflects the matrix/vector interpretation as above. -/
instance : has_repr xgcd_type :=
⟨λ u, "[[[" ++ (repr (u.wp + 1)) ++ ", " ++ (repr u.x) ++
      "], [" ++ (repr u.y) ++ ", " ++ (repr (u.zp + 1)) ++ "]], [" ++
      (repr (u.ap + 1)) ++ ", " ++ (repr (u.bp + 1)) ++ "]]"⟩

def mk' (w : ℕ+) (x : ℕ) (y : ℕ) (z : ℕ+) (a : ℕ+) (b : ℕ+) : xgcd_type :=
mk w.val.pred x y z.val.pred a.val.pred b.val.pred

def w : ℕ+ := succ_pnat u.wp
def z : ℕ+ := succ_pnat u.zp
def a : ℕ+ := succ_pnat u.ap
def b : ℕ+ := succ_pnat u.bp
def r : ℕ := (u.ap + 1) % (u.bp + 1)
def q : ℕ := (u.ap + 1) / (u.bp + 1)
def qp : ℕ := u.q - 1

/-- The map v gives the product of the matrix
 [[w, x], [y, z]] = [[wp + 1, x], [y, zp + 1]]
 and the vector [a, b] = [ap + 1, bp + 1].  The map
 vp gives [sp, tp] such that v = [sp + 1, tp + 1].
-/
def vp : ℕ × ℕ :=
⟨ u.wp + u.x + u.ap + u.wp * u.ap + u.x * u.bp,
  u.y + u.zp + u.bp + u.y * u.ap + u.zp * u.bp ⟩

def v : ℕ × ℕ := ⟨u.w * u.a + u.x * u.b, u.y * u.a + u.z * u.b⟩
def succ₂ (t : ℕ × ℕ) : ℕ × ℕ := ⟨t.1.succ, t.2.succ⟩

theorem v_eq_succ_vp : u.v = succ₂ u.vp :=
by { ext; dsimp [v, vp, w, z, a, b, succ₂];
     repeat { rw [nat.succ_eq_add_one] }; ring }

/-- is_special holds if the matrix has determinant one. -/
def is_special : Prop := u.wp + u.zp + u.wp * u.zp = u.x * u.y
def is_special' : Prop := u.w * u.z = succ_pnat (u.x * u.y)

theorem is_special_iff : u.is_special ↔ u.is_special' :=
begin
  dsimp [is_special, is_special'],
  split; intro h,
  { apply eq, dsimp [w, z, succ_pnat], rw [← h],
    repeat { rw [nat.succ_eq_add_one] }, ring },
  { apply nat.succ.inj,
    replace h := congr_arg (coe : ℕ+ → ℕ) h,
    rw [mul_coe, w, z] at h,
    repeat { rw [succ_pnat_coe, nat.succ_eq_add_one] at h },
    repeat { rw [nat.succ_eq_add_one] }, rw [← h], ring }
end

/-- is_reduced holds if the two entries in the vector are the
 same.  The reduction algorithm will produce a system with this
 property, whose product vector is the same as for the original
 system. -/
def is_reduced : Prop := u.ap = u.bp
def is_reduced' : Prop := u.a = u.b

theorem is_reduced_iff : u.is_reduced ↔ u.is_reduced' := succ_pnat_inj.symm

def flip : xgcd_type :=
{ wp := u.zp, x := u.y, y := u.x, zp := u.wp, ap := u.bp, bp := u.ap }

@[simp] theorem flip_w : (flip u).w = u.z := rfl
@[simp] theorem flip_x : (flip u).x = u.y := rfl
@[simp] theorem flip_y : (flip u).y = u.x := rfl
@[simp] theorem flip_z : (flip u).z = u.w := rfl
@[simp] theorem flip_a : (flip u).a = u.b := rfl
@[simp] theorem flip_b : (flip u).b = u.a := rfl

theorem flip_is_reduced : (flip u).is_reduced ↔ u.is_reduced :=
by { dsimp [is_reduced, flip], split; intro h; exact h.symm }

theorem flip_is_special : (flip u).is_special ↔ u.is_special :=
by { dsimp [is_special, flip], rw[mul_comm u.x, mul_comm u.zp, add_comm u.zp] }

theorem flip_v : (flip u).v = (u.v).swap :=
by { dsimp [v], ext, { simp only, ring }, { simp only, ring } }

/-- Properties of division with remainder for a / b.  -/
theorem rq_eq : u.r + (u.bp + 1) * u.q = u.ap + 1 :=
nat.mod_add_div (u.ap + 1) (u.bp + 1)

theorem qp_eq (hr : u.r = 0) : u.q = u.qp + 1 :=
begin
  by_cases hq : u.q = 0,
  { let h := u.rq_eq, rw [hr, hq, mul_zero, add_zero] at h, cases h },
  { exact (nat.succ_pred_eq_of_pos (nat.pos_of_ne_zero hq)).symm }
end

/-- The following function provides the starting point for
 our algorithm.  We will apply an iterative reduction process
 to it, which will produce a system satisfying is_reduced.
 The gcd can be read off from this final system.
-/
def start (a b : ℕ+) : xgcd_type := ⟨0, 0, 0, 0, a - 1, b - 1⟩

theorem start_is_special (a b : ℕ+) : (start a b).is_special :=
by { dsimp [start, is_special], refl }

theorem start_v (a b : ℕ+) : (start a b).v = ⟨a, b⟩ :=
begin
  dsimp [start, v, xgcd_type.a, xgcd_type.b, w, z],
  rw [one_mul, one_mul, zero_mul, zero_mul, zero_add, add_zero],
  rw [← nat.pred_eq_sub_one, ← nat.pred_eq_sub_one],
  rw [nat.succ_pred_eq_of_pos a.pos, nat.succ_pred_eq_of_pos b.pos]
end

def finish : xgcd_type :=
xgcd_type.mk u.wp ((u.wp + 1) * u.qp + u.x) u.y (u.y * u.qp + u.zp) u.bp u.bp

theorem finish_is_reduced : u.finish.is_reduced :=
by { dsimp [is_reduced], refl }

theorem finish_is_special (hs : u.is_special) : u.finish.is_special :=
begin
  dsimp [is_special, finish] at hs ⊢,
  rw [add_mul _ _ u.y, add_comm _ (u.x * u.y), ← hs],
  ring
end

theorem finish_v (hr : u.r = 0) : u.finish.v = u.v :=
begin
  let ha : u.r + u.b * u.q = u.a := u.rq_eq,
  rw [hr, zero_add] at ha,
  ext,
  { change (u.wp + 1) * u.b + ((u.wp + 1) * u.qp + u.x) * u.b = u.w * u.a + u.x * u.b,
    have : u.wp + 1 = u.w := rfl, rw [this, ← ha, u.qp_eq hr], ring },
  { change u.y * u.b + (u.y * u.qp + u.z) * u.b = u.y * u.a + u.z * u.b,
    rw [← ha, u.qp_eq hr], ring }
end

/-- This is the main reduction step, which is used when u.r ≠ 0, or
 equivalently b does not divide a. -/
def step : xgcd_type :=
xgcd_type.mk (u.y * u.q + u.zp) u.y ((u.wp + 1) * u.q + u.x) u.wp u.bp (u.r - 1)

/-- We will apply the above step recursively.  The following result
 is used to ensure that the process terminates. -/
theorem step_wf (hr : u.r ≠ 0) : sizeof u.step < sizeof u :=
begin
  change u.r - 1 < u.bp,
  have h₀ : (u.r - 1) + 1 = u.r := nat.succ_pred_eq_of_pos (nat.pos_of_ne_zero hr),
  have h₁ : u.r < u.bp + 1 := nat.mod_lt (u.ap + 1) u.bp.succ_pos,
  rw[← h₀] at h₁,
  exact lt_of_succ_lt_succ h₁,
end

theorem step_is_special (hs : u.is_special) : u.step.is_special :=
begin
  dsimp [is_special, step] at hs ⊢,
  rw [mul_add, mul_comm u.y u.x, ← hs],
  ring
end

/-- The reduction step does not change the product vector. -/
theorem step_v (hr : u.r ≠ 0) : u.step.v = (u.v).swap :=
begin
  let ha : u.r + u.b * u.q = u.a := u.rq_eq,
  let hr : (u.r - 1) + 1 = u.r :=
    (add_comm _ 1).trans (add_tsub_cancel_of_le (nat.pos_of_ne_zero hr)),
  ext,
  { change ((u.y * u.q + u.z) * u.b + u.y * (u.r - 1 + 1) : ℕ) = u.y * u.a + u.z * u.b,
    rw [← ha, hr], ring },
  { change ((u.w * u.q + u.x) * u.b + u.w * (u.r - 1 + 1) : ℕ) = u.w * u.a + u.x * u.b,
    rw [← ha, hr], ring }
end

/-- We can now define the full reduction function, which applies
 step as long as possible, and then applies finish. Note that the
 "have" statement puts a fact in the local context, and the
 equation compiler uses this fact to help construct the full
 definition in terms of well-founded recursion.  The same fact
 needs to be introduced in all the inductive proofs of properties
 given below. -/
def reduce : xgcd_type → xgcd_type
| u := dite (u.r = 0)
    (λ h, u.finish)
    (λ h, have sizeof u.step < sizeof u, from u.step_wf h,
     flip (reduce u.step))

theorem reduce_a {u : xgcd_type} (h : u.r = 0) :
u.reduce = u.finish := by { rw [reduce], simp only, rw [if_pos h] }

theorem reduce_b {u : xgcd_type} (h : u.r ≠ 0) :
u.reduce = u.step.reduce.flip := by { rw [reduce], simp only, rw [if_neg h, step] }

theorem reduce_reduced : ∀ (u : xgcd_type), u.reduce.is_reduced
| u := dite (u.r = 0) (λ h, by { rw [reduce_a h], exact u.finish_is_reduced })
    (λ h,  have sizeof u.step < sizeof u, from u.step_wf h,
     by { rw [reduce_b h, flip_is_reduced], apply reduce_reduced })

theorem reduce_reduced' (u : xgcd_type) : u.reduce.is_reduced' :=
(is_reduced_iff _).mp u.reduce_reduced

theorem reduce_special : ∀ (u : xgcd_type), u.is_special → u.reduce.is_special
| u := dite (u.r = 0)
    (λ h hs, by { rw [reduce_a h], exact u.finish_is_special hs })
    (λ h hs, have sizeof u.step < sizeof u, from u.step_wf h,
     by { rw [reduce_b h],
          exact (flip_is_special _).mpr (reduce_special _ (u.step_is_special hs)) })

theorem reduce_special' (u : xgcd_type) (hs : u.is_special) : u.reduce.is_special' :=
(is_special_iff _).mp (u.reduce_special hs)

theorem reduce_v : ∀ (u : xgcd_type), u.reduce.v = u.v
| u := dite (u.r = 0)
 (λ h, by {rw[reduce_a h, finish_v u h]})
 (λ h, have sizeof u.step < sizeof u, from u.step_wf h,
       by { rw[reduce_b h, flip_v, reduce_v (step u), step_v u h, prod.swap_swap] })

end xgcd_type

section gcd

variables (a b : ℕ+)

def xgcd : xgcd_type := (xgcd_type.start a b).reduce

def gcd_d : ℕ+ := (xgcd a b).a
def gcd_w : ℕ+ := (xgcd a b).w
def gcd_x : ℕ  := (xgcd a b).x
def gcd_y : ℕ  := (xgcd a b).y
def gcd_z : ℕ+ := (xgcd a b).z

def gcd_a' : ℕ+ := succ_pnat ((xgcd a b).wp + (xgcd a b).x)
def gcd_b' : ℕ+ := succ_pnat ((xgcd a b).y + (xgcd a b).zp)

theorem gcd_a'_coe : ((gcd_a' a b) : ℕ) = (gcd_w a b) + (gcd_x a b) :=
by { dsimp [gcd_a', gcd_x, gcd_w, xgcd_type.w],
     rw [nat.succ_eq_add_one, nat.succ_eq_add_one, add_right_comm] }

theorem gcd_b'_coe : ((gcd_b' a b) : ℕ) = (gcd_y a b) + (gcd_z a b) :=
by { dsimp [gcd_b', gcd_y, gcd_z, xgcd_type.z],
     rw [nat.succ_eq_add_one, nat.succ_eq_add_one, add_assoc] }

theorem gcd_props :
 let d := gcd_d a b,
  w := gcd_w a b, x := gcd_x a b, y := gcd_y a b, z := gcd_z a b,
  a' := gcd_a' a b, b' := gcd_b' a b in
 (w * z = succ_pnat (x * y) ∧
  (a = a' * d) ∧ (b = b' * d) ∧
  z * a' = succ_pnat (x * b') ∧ w * b' = succ_pnat (y * a') ∧
  (z * a : ℕ) = x * b + d ∧ (w * b : ℕ) = y * a + d
 ) :=
begin
  intros,
  let u := (xgcd_type.start a b),
  let ur := u.reduce,
  have ha : d = ur.a := rfl,
  have hb : d = ur.b := u.reduce_reduced',
  have ha' : (a' : ℕ) = w + x := gcd_a'_coe a b,
  have hb' : (b' : ℕ) = y + z := gcd_b'_coe a b,
  have hdet : w * z = succ_pnat (x * y) := u.reduce_special' rfl,
  split, exact hdet,
  have hdet' : ((w * z) : ℕ) = x * y + 1 :=
    by { rw [← mul_coe, hdet, succ_pnat_coe] },
  have huv : u.v = ⟨a, b⟩ := (xgcd_type.start_v a b),
  let hv : prod.mk (w * d + x * ur.b : ℕ) (y * d + z * ur.b : ℕ) = ⟨a, b⟩ :=
   u.reduce_v.trans (xgcd_type.start_v a b),
  rw [← hb, ← add_mul, ← add_mul, ← ha', ← hb'] at hv,
  have ha'' : (a : ℕ) = a' * d := (congr_arg prod.fst hv).symm,
  have hb'' : (b : ℕ) = b' * d := (congr_arg prod.snd hv).symm,
  split, exact eq ha'', split, exact eq hb'',
  have hza' : (z * a' : ℕ) = x * b' + 1,
  by { rw [ha', hb', mul_add, mul_add, mul_comm (z : ℕ), hdet'], ring },
  have hwb' : (w * b' : ℕ) = y * a' + 1,
  by { rw [ha', hb', mul_add, mul_add, hdet'], ring },
  split,
  { apply eq, rw [succ_pnat_coe, nat.succ_eq_add_one, mul_coe, hza'] },
  split,
  { apply eq, rw [succ_pnat_coe, nat.succ_eq_add_one, mul_coe, hwb'] },
  rw [ha'', hb''], repeat { rw [← mul_assoc] }, rw [hza', hwb'],
  split; ring,
end

theorem gcd_eq : gcd_d a b = gcd a b :=
begin
  rcases gcd_props a b with ⟨h₀, h₁, h₂, h₃, h₄, h₅, h₆⟩,
  apply dvd_antisymm,
  { apply dvd_gcd,
    exact dvd.intro (gcd_a' a b) (h₁.trans (mul_comm _ _)).symm,
    exact dvd.intro (gcd_b' a b) (h₂.trans (mul_comm _ _)).symm},
  { have h₇ : (gcd a b : ℕ) ∣ (gcd_z a b) * a :=
      (nat.gcd_dvd_left a b).trans (dvd_mul_left _ _),
    have h₈ : (gcd a b : ℕ) ∣ (gcd_x a b) * b :=
      (nat.gcd_dvd_right a b).trans (dvd_mul_left _ _),
    rw[h₅] at h₇, rw dvd_iff,
    exact (nat.dvd_add_iff_right h₈).mpr h₇,}
end

theorem gcd_det_eq :
  (gcd_w a b) * (gcd_z a b) = succ_pnat ((gcd_x a b) * (gcd_y a b)) :=
(gcd_props a b).1

theorem gcd_b_eq : b = (gcd_b' a b) * (gcd a b) :=
(gcd_eq a b) ▸ (gcd_props a b).2.2.1

theorem gcd_rel_left' :
  (gcd_z a b) * (gcd_a' a b) = succ_pnat ((gcd_x a b) * (gcd_b' a b)) :=
(gcd_props a b).2.2.2.1

theorem gcd_rel_right' :
  (gcd_w a b) * (gcd_b' a b) = succ_pnat ((gcd_y a b) * (gcd_a' a b)) :=
(gcd_props a b).2.2.2.2.1

theorem gcd_rel_left :
  ((gcd_z a b) * a : ℕ) = (gcd_x a b) * b + (gcd a b) :=
(gcd_eq a b) ▸ (gcd_props a b).2.2.2.2.2.1

theorem gcd_rel_right :
  ((gcd_w a b) * b : ℕ) = (gcd_y a b) * a + (gcd a b) :=
(gcd_eq a b) ▸ (gcd_props a b).2.2.2.2.2.2

end gcd
end pnat


/-
Copyright (c) 2020 David Wärn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: David Wärn
-/
import category_theory.elements
import category_theory.is_connected
import category_theory.single_obj
import group_theory.group_action.quotient
import group_theory.semidirect_product

/-!
# Actions as functors and as categories

From a multiplicative action M ↻ X, we can construct a functor from M to the category of
types, mapping the single object of M to X and an element `m : M` to map `X → X` given by
multiplication by `m`.
  This functor induces a category structure on X -- a special case of the category of elements.
A morphism `x ⟶ y` in this category is simply a scalar `m : M` such that `m • x = y`. In the case
where M is a group, this category is a groupoid -- the `action groupoid'.
-/

open mul_action semidirect_product
namespace category_theory

universes u

variables (M : Type*) [monoid M] (X : Type u) [mul_action M X]

/-- A multiplicative action M ↻ X viewed as a functor mapping the single object of M to X
  and an element `m : M` to the map `X → X` given by multiplication by `m`. -/
@[simps]
def action_as_functor : single_obj M ⥤ Type u :=
{ obj := λ _, X,
  map := λ _ _, (•),
  map_id' := λ _, funext $ mul_action.one_smul,
  map_comp' := λ _ _ _ f g, funext $ λ x, (smul_smul g f x).symm }

/-- A multiplicative action M ↻ X induces a category strucure on X, where a morphism
 from x to y is a scalar taking x to y. Due to implementation details, the object type
 of this category is not equal to X, but is in bijection with X. -/
@[derive category]
def action_category := (action_as_functor M X).elements

namespace action_category

/-- The projection from the action category to the monoid, mapping a morphism to its
  label. -/
def π : action_category M X ⥤ single_obj M :=
category_of_elements.π _

@[simp]
lemma π_map (p q : action_category M X) (f : p ⟶ q) : (π M X).map f = f.val := rfl

@[simp]
lemma π_obj (p : action_category M X) : (π M X).obj p = single_obj.star M :=
unit.ext

variables {M X}
/-- The canonical map `action_category M X → X`. It is given by `λ x, x.snd`, but
  has a more explicit type. -/
protected def back : action_category M X → X :=
λ x, x.snd

instance : has_coe_t X (action_category M X) :=
⟨λ x, ⟨(), x⟩⟩

@[simp] lemma coe_back (x : X) : (↑x : action_category M X).back = x := rfl
@[simp] lemma back_coe (x : action_category M X) : ↑(x.back) = x := by ext; refl

variables (M X)

/-- An object of the action category given by M ↻ X corresponds to an element of X. -/
def obj_equiv : X ≃ action_category M X :=
{ to_fun := coe,
  inv_fun := λ x, x.back,
  left_inv := coe_back,
  right_inv := back_coe }

lemma hom_as_subtype (p q : action_category M X) :
  (p ⟶ q) = { m : M // m • p.back = q.back } := rfl

instance [inhabited X] : inhabited (action_category M X) := ⟨show X, from default⟩

instance [nonempty X] : nonempty (action_category M X) :=
nonempty.map (obj_equiv M X) infer_instance

variables {X} (x : X)
/-- The stabilizer of a point is isomorphic to the endomorphism monoid at the
  corresponding point. In fact they are definitionally equivalent. -/
def stabilizer_iso_End : stabilizer.submonoid M x ≃* End (↑x : action_category M X) :=
mul_equiv.refl _

@[simp]
lemma stabilizer_iso_End_apply (f : stabilizer.submonoid M x) :
  (stabilizer_iso_End M x).to_fun f = f := rfl

@[simp]
lemma stabilizer_iso_End_symm_apply (f : End _) :
  (stabilizer_iso_End M x).inv_fun f = f := rfl

variables {M X}

@[simp] protected

@[simp] protected lemma comp_val {x y z : action_category M X}
  (f : x ⟶ y) (g : y ⟶ z) : (f ≫ g).val = g.val * f.val := rfl

instance [is_pretransitive M X] [nonempty X] : is_connected (action_category M X) :=
zigzag_is_connected $ λ x y, relation.refl_trans_gen.single $ or.inl $
  nonempty_subtype.mpr (show _, from exists_smul_eq M x.back y.back)

section group

variables {G : Type*} [group G] [mul_action G X]

noncomputable instance : groupoid (action_category G X) :=
category_theory.groupoid_of_elements _

/-- Any subgroup of `G` is a vertex group in its action groupoid. -/
def End_mul_equiv_subgroup (H : subgroup G) :
  End (obj_equiv G (G ⧸ H) ↑(1 : G)) ≃* H :=
mul_equiv.trans
  (stabilizer_iso_End G ((1 : G) : G ⧸ H)).symm
  (mul_equiv.subgroup_congr $ stabilizer_quotient H)

/-- A target vertex `t` and a scalar `g` determine a morphism in the action groupoid. -/
def hom_of_pair (t : X) (g : G) : ↑(g⁻¹ • t) ⟶ (t : action_category G X) :=
subtype.mk g (smul_inv_smul g t)

@[simp] lemma hom_of_pair.val (t : X) (g : G) : (hom_of_pair t g).val = g := rfl

/-- Any morphism in the action groupoid is given by some pair. -/
protected def cases {P : Π ⦃a b : action_category G X⦄, (a ⟶ b) → Sort*}
  (hyp : ∀ t g, P (hom_of_pair t g)) ⦃a b⦄ (f : a ⟶ b) : P f :=
begin
  refine cast _ (hyp b.back f.val),
  rcases a with ⟨⟨⟩, a : X⟩,
  rcases b with ⟨⟨⟩, b : X⟩,
  rcases f with ⟨g : G, h : g • a = b⟩,
  cases (inv_smul_eq_iff.mpr h.symm),
  refl
end

variables {H : Type*} [group H]

/-- Given `G` acting on `X`, a functor from the corresponding action groupoid to a group `H`
    can be curried to a group homomorphism `G →* (X → H) ⋊ G`. -/
@[simps] def curry (F : action_category G X ⥤ single_obj H) :
  G →* (X → H) ⋊[mul_aut_arrow] G :=
have F_map_eq : ∀ {a b} {f : a ⟶ b}, F.map f = (F.map (hom_of_pair b.back f.val) : H) :=
  action_category.cases (λ _ _, rfl),
{ to_fun := λ g, ⟨λ b, F.map (hom_of_pair b g), g⟩,
  map_one' := by { congr, funext, exact F_map_eq.symm.trans (F.map_id b) },
  map_mul' := begin
    intros g h,
    congr, funext,
    exact F_map_eq.symm.trans (F.map_comp (hom_of_pair (g⁻¹ • b) h) (hom_of_pair b g)),
  end }

/-- Given `G` acting on `X`, a group homomorphism `φ : G →* (X → H) ⋊ G` can be uncurried to
    a functor from the action groupoid to `H`, provided that `φ g = (_, g)` for all `g`. -/
@[simps] def uncurry (F : G →* (X → H) ⋊[mul_aut_arrow] G) (sane : ∀ g, (F g).right = g) :
  action_category G X ⥤ single_obj H :=
{ obj := λ _, (),
  map := λ a b f, ((F f.val).left b.back),
  map_id' := by { intro x, rw [action_category.id_val, F.map_one], refl },
  map_comp' := begin
    intros x y z f g, revert y z g,
    refine action_category.cases _,
    simp [single_obj.comp_as_mul, sane],
  end }

end group

end action_category
end category_theory


structure Category :=
  ( Obj : Type )
  ( Hom : Obj → Obj → Type )
  ( identity : Π X : Obj, Hom X X )
  ( compose  : Π { X Y Z : Obj }, Hom X Y → Hom Y Z → Hom X Z )

structure Functor (C : Category) (D : Category) :=
  (onObjects   : C.Obj → D.Obj)
  (onMorphisms : Π { X Y : C.Obj },
                C.Hom X Y → D.Hom (onObjects X) (onObjects Y))

definition ProductCategory (C D : Category) :
  Category :=
  {
    Obj      := C.Obj × D.Obj,
    Hom      := (λ X Y : C.Obj × D.Obj, C.Hom (X.fst) (Y.fst) × D.Hom (X.snd) (Y.snd)),
    identity := λ X, ⟨ C.identity (X.fst), D.identity (X.snd) ⟩,
    compose  := λ _ _ _ f g, (C.compose (f.fst) (g.fst), D.compose (f.snd) (g.snd))
  }

lemma Bifunctor_diagonal_identities_1
  { C : Category }
  ( F : Functor (ProductCategory C C) C )
  ( X : C.Obj )
  ( f g : C.Hom X X )
  : C.compose (@Functor.onMorphisms _ _ F (X, X) (X, X) (C.identity X, g)) (@Functor.onMorphisms _ _ F (X, X) (X, X) (f, C.identity X)) =
   @Functor.onMorphisms _ _ F (X, X) (X, X) (f, g) :=
begin
  -- simp {single_pass := tt}, -- fails with 'simplify tactic failed to simplify'
  simp {max_steps := 20},   -- fails with 'simplify failed, maximum number of steps exceeded'

  -- neither should not suffice to finish the proof!
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
-/
import algebra.order.module
import linear_algebra.affine_space.affine_map
import tactic.field_simp

/-!
# Slope of a function

In this file we define the slope of a function `f : k → PE` taking values in an affine space over
`k` and prove some basic theorems about `slope`. The `slope` function naturally appears in the Mean
Value Theorem, and in the proof of the fact that a function with nonnegative second derivative on an
interval is convex on this interval.

## Tags

affine space, slope
-/

open affine_map
variables {k E PE : Type*} [field k] [add_comm_group E] [module k E] [add_torsor E PE]

include E

/-- `slope f a b = (b - a)⁻¹ • (f b -ᵥ f a)` is the slope of a function `f` on the interval
`[a, b]`. Note that `slope f a a = 0`, not the derivative of `f` at `a`. -/
def slope (f : k → PE) (a b : k) : E := (b - a)⁻¹ • (f b -ᵥ f a)

lemma slope_fun_def (f : k → PE) : slope f = λ a b, (b - a)⁻¹ • (f b -ᵥ f a) := rfl

omit E

lemma slope_def_field (f : k → k) (a b : k) : slope f a b = (f b - f a) / (b - a) :=
(div_eq_inv_mul _ _).symm

@[simp] lemma slope_same (f : k → PE) (a : k) : (slope f a a : E) = 0 :=
by rw [slope, sub_self, inv_zero, zero_smul]

include E

lemma slope_def_module (f : k → E) (a b : k) : slope f a b = (b - a)⁻¹ • (f b - f a) := rfl

@[simp] lemma sub_smul_slope (f : k → PE) (a b : k) : (b - a) • slope f a b = f b -ᵥ f a :=
begin
  rcases eq_or_ne a b with rfl | hne,
  { rw [sub_self, zero_smul, vsub_self] },
  { rw [slope, smul_inv_smul₀ (sub_ne_zero.2 hne.symm)] }
end

lemma sub_smul_slope_vadd (f : k → PE) (a b : k) : (b - a) • slope f a b +ᵥ f a = f b :=
by rw [sub_smul_slope, vsub_vadd]

@[simp] lemma slope_vadd_const (f : k → E) (c : PE) :
  slope (λ x, f x +ᵥ c) = slope f :=
begin
  ext a b,
  simp only [slope, vadd_vsub_vadd_cancel_right, vsub_eq_sub]
end

@[simp] lemma slope_sub_smul (f : k → E) {a b : k} (h : a ≠ b):
  slope (λ x, (x - a) • f x) a b = f b :=
by simp [slope, inv_smul_smul₀ (sub_ne_zero.2 h.symm)]

lemma eq_of_slope_eq_zero {f : k → PE} {a b : k} (h : slope f a b = (0:E)) : f a = f b :=
by rw [← sub_smul_slope_vadd f a b, h, smul_zero, zero_vadd]

lemma affine_map.slope_comp {F PF : Type*} [add_comm_group F] [module k F] [add_torsor F PF]
  (f : PE →ᵃ[k] PF) (g : k → PE) (a b : k) :
  slope (f ∘ g) a b = f.linear (slope g a b) :=
by simp only [slope, (∘), f.linear.map_smul, f.linear_map_vsub]

lemma linear_map.slope_comp {F : Type*} [add_comm_group F] [module k F]
  (f : E →ₗ[k] F) (g : k → E) (a b : k) :
  slope (f ∘ g) a b = f (slope g a b) :=
f.to_affine_map.slope_comp g a b

lemma slope_comm (f : k → PE) (a b : k) : slope f a b = slope f b a :=
by rw [slope, slope, ← neg_vsub_eq_vsub_rev, smul_neg, ← neg_smul, neg_inv, neg_sub]

/-- `slope f a c` is a linear combination of `slope f a b` and `slope f b c`. This version
explicitly provides coefficients. If `a ≠ c`, then the sum of the coefficients is `1`, so it is
actually an affine combination, see `line_map_slope_slope_sub_div_sub`. -/
lemma sub_div_sub_smul_slope_add_sub_div_sub_smul_slope (f : k → PE) (a b c : k) :
  ((b - a) / (c - a)) • slope f a b + ((c - b) / (c - a)) • slope f b c = slope f a c :=
begin
  by_cases hab : a = b,
  { subst hab,
    rw [sub_self, zero_div, zero_smul, zero_add],
    by_cases hac : a = c,
    { simp [hac] },
    { rw [div_self (sub_ne_zero.2 $ ne.symm hac), one_smul] } },
  by_cases hbc : b = c, { subst hbc, simp [sub_ne_zero.2 (ne.symm hab)] },
  rw [add_comm],
  simp_rw [slope, div_eq_inv_mul, mul_smul, ← smul_add,
    smul_inv_smul₀ (sub_ne_zero.2 $ ne.symm hab), smul_inv_smul₀ (sub_ne_zero.2 $ ne.symm hbc),
    vsub_add_vsub_cancel],
end

/-- `slope f a c` is an affine combination of `slope f a b` and `slope f b c`. This version uses
`line_map` to express this property. -/
lemma line_map_slope_slope_sub_div_sub (f : k → PE) (a b c : k) (h : a ≠ c) :
  line_map (slope f a b) (slope f b c) ((c - b) / (c - a)) = slope f a c :=
by  field_simp [sub_ne_zero.2 h.symm, ← sub_div_sub_smul_slope_add_sub_div_sub_smul_slope f a b c,
  line_map_apply_module]

/-- `slope f a b` is an affine combination of `slope f a (line_map a b r)` and
`slope f (line_map a b r) b`. We use `line_map` to express this property. -/
lemma line_map_slope_line_map_slope_line_map (f : k → PE) (a b r : k) :
  line_map (slope f (line_map a b r) b) (slope f a (line_map a b r)) r = slope f a b :=
begin
  obtain (rfl|hab) : a = b ∨ a ≠ b := classical.em _, { simp },
  rw [slope_comm _ a, slope_comm _ a, slope_comm _ _ b],
  convert line_map_slope_slope_sub_div_sub f b (line_map a b r) a hab.symm using 2,
  rw [line_map_apply_ring, eq_div_iff (sub_ne_zero.2 hab), sub_mul, one_mul, mul_sub, ← sub_sub,
    sub_sub_cancel]
end


import tactic.finish
import algebra.group algebra.big_operators

noncomputable theory
local attribute [instance] classical.prop_decidable
local attribute [simp] mul_assoc

open list

variables {α β : Type} [group α] [group β] {a b g h : α}

-- Conjuguation in a group
--------------------------

def conj (a b : α) := a*b*a⁻¹

@[simp] lemma conj_action : conj (g * h) a = conj g (conj h a) :=
by simp[conj]

@[simp] lemma conj_by_one : conj 1 a = a :=
by simp[conj]

instance conj.is_group_hom : is_group_hom (conj a) :=
⟨λ x y, by simp [conj, mul_assoc]⟩

lemma inv_conj : conj a (b⁻¹) = (conj a b)⁻¹ :=
is_group_hom.inv (conj a) b

lemma conj_mul : conj g (a * b) = conj g a * conj g b :=
is_group_hom.mul _ _ _

@[simp] lemma conj_one : conj a 1 = 1 :=
is_group_hom.one (conj a)

-- Products
-----------

/- "is_product S n a" means a can be written as a product of n elements of S or S⁻¹ -/
def is_product (S : set α) (n : ℕ) (g : α) : Prop :=
∃ l : list α, g = prod l ∧ (∀ x ∈ l, x ∈ S ∨ x⁻¹ ∈ S) ∧ l.length = n

lemma is_product_mul {S : set α} {m n a b}
  (h₁ : is_product S m a) (h₂ : is_product S n b) : is_product S (m + n) (a * b) :=
begin
  rcases h₁ with ⟨l₁, prod₁, inS₁, len₁⟩,
  rcases h₂ with ⟨l₂, prod₂, inS₂, len₂⟩,

  existsi l₁ ++ l₂, -- denoted by l in comments
  repeat {split},
  { -- prove a*b = prod l
    simp [prod₁,prod₂] },
  { -- prove elements of l are in S or S⁻¹
    simpa,
    intros x x_in_l₁_or_l₂,
    cases x_in_l₁_or_l₂,
    { apply inS₁ x, assumption },
    { apply inS₂ x, assumption },
  },
  { -- prove length l is m + n
  simp [len₁, len₂] }
end

lemma is_product_inv (S : set α) {n a} (h : is_product S n a) : is_product S n (a⁻¹) :=
begin
  rcases h with ⟨l, product, inS, len⟩,
  existsi map (λ x, x⁻¹) (reverse l),
  repeat {split},
  { rw product,
    apply inv_prod },
  { simpa,
    intros,
    have H := (inS x_1) a_1,
    have H' : x_1 = x⁻¹ := eq_inv_of_eq_inv (eq.symm a_2),
    simp[H'] at H,
    exact or.symm H },
  { simpa }
end

lemma is_product_conj {S T : set α} (g) (H : ∀ a, a ∈ S → conj g a ∈ T)
  {n a} (h : is_product S n a) : is_product T n (conj g a) :=
begin
  rcases h with ⟨l, prod, inS, len⟩,
  existsi (map (conj g) l),
  repeat {split},
  { rw prod,
    apply is_group_hom.prod },
  { clear prod a len n,
    intros x x_in_conj_l,
    rw mem_map at x_in_conj_l,
    rcases x_in_conj_l with ⟨b, b_in_l, conj_b_x⟩,
    specialize inS b b_in_l, clear b_in_l l,
    cases inS,
    { have conj_in_T := H b inS,
      rw conj_b_x at conj_in_T,
      exact or.inl conj_in_T},
    { have conj_in_T := H b⁻¹ inS,
      rw [inv_conj, conj_b_x] at conj_in_T,
      exact or.inr conj_in_T } },
  { simp[len] }
end

--- Generating sets
-------------------

def is_generating (S : set α) : Prop :=
∀ g : α, ∃ n : ℕ, is_product S n g

structure generating_set :=
(set : set α)
(gen : is_generating set)

-- Invariant norms on a group
-----------------------------

structure is_invariant_norm (ν : α → ℕ) : Prop :=
  (nonneg : ∀ g : α, 0 ≤ ν g) -- this is silly but ultimately the target will be ℝ
  (eq_zero : ∀ g : α, ν g = 0 → g = 1)
  (mul : ∀ g h : α, ν (g*h) ≤ ν g + ν h)
  (inv : ∀ g : α, ν g⁻¹ = ν g)
  (conj : ∀ g h : α, ν (conj h g) = ν g)

def is_conj_invariant_set (S : set α) : Prop :=
   ∀ g s : α, s ∈ S → conj g s ∈ S

/- Given a generating set S and an alement a,
   gen_norm S a is the minimal number of elements of S or S⁻¹
   required to write a as a product.
   The next two lemma prove the definition is what it should be -/
def gen_norm (S : generating_set) (a : α) := nat.find (S.gen a)

lemma is_product_norm (S : generating_set) (g : α) :
is_product S.set (gen_norm S g) g :=
nat.find_spec (S.gen g)

lemma norm_min (S : generating_set) {a : α} {n} :
is_product S.set n a → gen_norm S a ≤ n :=
by apply nat.find_min' (S.gen a)

lemma inv_norm_of_inv_set [str : group α] (S : @generating_set α str) :
is_conj_invariant_set S.set → is_invariant_norm (gen_norm S) :=
begin
  intro inv_hyp,
  constructor; intros,
  { apply nat.zero_le },
  { have H' := is_product_norm S g,
    rw a at H',
    rcases H' with ⟨l, prod, inS, len⟩,
    rw [eq_nil_of_length_eq_zero len] at prod,
    simp at prod,
    assumption },
  { have g_prod := is_product_norm S g,
    have h_prod := is_product_norm S h,
    have estimate := is_product_mul g_prod h_prod,
    exact norm_min S estimate },
  { apply le_antisymm,
    { apply norm_min,
      exact is_product_inv S.set (is_product_norm S g) },
    { apply norm_min,
      simpa using is_product_inv S.set  (is_product_norm S g⁻¹) } },
  { apply le_antisymm ; apply norm_min,
    { exact is_product_conj h (inv_hyp h) (is_product_norm S g) },
    { have prod := is_product_conj h⁻¹ (inv_hyp h⁻¹) (is_product_norm S (conj h g)),
      rw [←conj_action] at prod,
      simp[conj_by_one] at prod,
      exact prod } },
end

-- Commutators
--------------

def comm (a b : α) := a*b*a⁻¹*b⁻¹
local notation `[[`a, b`]]` := comm a b

lemma commuting : [[a, b]] = 1 ↔ a*b = b*a :=
by simp [comm, -mul_assoc, mul_inv_eq_iff_eq_mul]

lemma commutator_trading (comm_hyp : [[a, conj g b]] = 1) :
∃ c d e f : α, [[a, b]] = (conj c g⁻¹)*(conj d g)*(conj e g⁻¹)*(conj f g) :=
begin
  unfold conj at comm_hyp,
  let b':= g*b*g⁻¹,

  exact ⟨_, _, _, _, calc
   [[a, b]] = a * b * a⁻¹ * b⁻¹ : rfl
      ...  = a * (g⁻¹  * b' * g)  * a⁻¹ * (g⁻¹ * b'⁻¹ * g)  : by simp
      ...  = a * g⁻¹ * (a⁻¹ * a) * b' * g  * a⁻¹ * (b'⁻¹ * b') * g⁻¹ * b'⁻¹ * g  : by simp
      ...  = a * g⁻¹ * (a⁻¹ * a) * b' * g  * (b'*a)⁻¹ * b' * g⁻¹ * b'⁻¹ * g  : by simp
      ...  = a * g⁻¹ * (a⁻¹ * a) * b' * g  * (a*b')⁻¹ * b' * g⁻¹ * b'⁻¹ * g  : by simp [commuting.1 comm_hyp]
      ...  = (conj a g⁻¹) * (conj (a*b') g) * (conj b' g⁻¹) * (conj 1 g) : by simp [conj]⟩
end


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

import algebra.module.basic
import linear_algebra.finsupp
import linear_algebra.free_module.basic

/-!

# Projective modules

This file contains a definition of a projective module, the proof that
our definition is equivalent to a lifting property, and the
proof that all free modules are projective.

## Main definitions

Let `R` be a ring (or a semiring) and let `M` be an `R`-module.

* `is_projective R M` : the proposition saying that `M` is a projective `R`-module.

## Main theorems

* `is_projective.lifting_property` : a map from a projective module can be lifted along
  a surjection.

* `is_projective.of_lifting_property` : If for all R-module surjections `A →ₗ B`, all
  maps `M →ₗ B` lift to `M →ₗ A`, then `M` is projective.

* `is_projective.of_free` : Free modules are projective

## Implementation notes

The actual definition of projective we use is that the natural R-module map
from the free R-module on the type M down to M splits. This is more convenient
than certain other definitions which involve quantifying over universes,
and also universe-polymorphic (the ring and module can be in different universes).

We require that the module sits in at least as high a universe as the ring:
without this, free modules don't even exist,
and it's unclear if projective modules are even a useful notion.

## References

https://en.wikipedia.org/wiki/Projective_module

## TODO

- Direct sum of two projective modules is projective.
- Arbitrary sum of projective modules is projective.

All of these should be relatively straightforward.

## Tags

projective module

-/

universes u v

open linear_map finsupp

/- The actual implementation we choose: `P` is projective if the natural surjection
   from the free `R`-module on `P` to `P` splits. -/
/-- An R-module is projective if it is a direct summand of a free module, or equivalently
  if maps from the module lift along surjections. There are several other equivalent
  definitions. -/
class module.projective (R : Type*) [semiring R] (P : Type*) [add_comm_monoid P]
  [module R P] : Prop :=
(out : ∃ s : P →ₗ[R] (P →₀ R), function.left_inverse (finsupp.total P P R id) s)

namespace module

section semiring

variables {R : Type*} [semiring R] {P : Type*} [add_comm_monoid P] [module R P]
  {M : Type*} [add_comm_monoid M] [module R M] {N : Type*} [add_comm_monoid N] [module R N]

lemma projective_def : projective R P ↔
  (∃ s : P →ₗ[R] (P →₀ R), function.left_inverse (finsupp.total P P R id) s) :=
⟨λ h, h.1, λ h, ⟨h⟩⟩

theorem projective_def' : projective R P ↔
  (∃ s : P →ₗ[R] (P →₀ R), (finsupp.total P P R id) ∘ₗ s = id) :=
by simp_rw [projective_def, fun_like.ext_iff, function.left_inverse, coe_comp, id_coe, id.def]

/-- A projective R-module has the property that maps from it lift along surjections. -/
theorem projective_lifting_property [h : projective R P] (f : M →ₗ[R] N) (g : P →ₗ[R] N)
  (hf : function.surjective f) : ∃ (h : P →ₗ[R] M), f.comp h = g :=
begin
  /-
  Here's the first step of the proof.
  Recall that `X →₀ R` is Lean's way of talking about the free `R`-module
  on a type `X`. The universal property `finsupp.total` says that to a map
  `X → N` from a type to an `R`-module, we get an associated R-module map
  `(X →₀ R) →ₗ N`. Apply this to a (noncomputable) map `P → M` coming from the map
  `P →ₗ N` and a random splitting of the surjection `M →ₗ N`, and we get
  a map `φ : (P →₀ R) →ₗ M`.
  -/
  let φ : (P →₀ R) →ₗ[R] M := finsupp.total _ _ _ (λ p, function.surj_inv hf (g p)),
  -- By projectivity we have a map `P →ₗ (P →₀ R)`;
  cases h.out with s hs,
  -- Compose to get `P →ₗ M`. This works.
  use φ.comp s,
  ext p,
  conv_rhs {rw ← hs p},
  simp [φ, finsupp.total_apply, function.surj_inv_eq hf],
end

variables {Q : Type*} [add_comm_monoid Q] [module R Q]

instance [hP : projective R P] [hQ : projective R Q] : projective R (P × Q) :=
begin
  rw module.projective_def',
  cases hP.out with sP hsP,
  cases hQ.out with sQ hsQ,
  use coprod (lmap_domain R R (inl R P Q)) (lmap_domain R R (inr R P Q)) ∘ₗ sP.prod_map sQ,
  ext; simp only [coe_inl, coe_inr, coe_comp, function.comp_app, prod_map_apply, map_zero,
    coprod_apply, lmap_domain_apply, map_domain_zero, add_zero, zero_add, id_comp,
    total_map_domain],

  { rw [←fst_apply _, apply_total R], exact hsP x, },
  { rw [←snd_apply _, apply_total R], exact finsupp.total_zero_apply _ (sP x), },
  { rw [←fst_apply _, apply_total R], exact finsupp.total_zero_apply _ (sQ x), },
  { rw [←snd_apply _, apply_total R], exact hsQ x, },
end

variables {ι : Type*} (A : ι → Type*) [Π (i : ι), add_comm_monoid (A i)]
  [Π (i : ι), module R (A i)]

instance [h : Π (i : ι), projective R (A i)] : projective R (Π₀ i, A i) :=
begin
  classical,
  rw module.projective_def',
  simp_rw projective_def at h, choose s hs using h,

  letI : Π (i : ι), add_comm_monoid (A i →₀ R) := λ i, by apply_instance,
  letI : Π (i : ι), module R (A i →₀ R) := λ i, by apply_instance,
  letI : add_comm_monoid (Π₀ (i : ι), A i →₀ R) := @dfinsupp.add_comm_monoid ι (λ i, A i →₀ R) _,
  letI : module R (Π₀ (i : ι), A i →₀ R) := @dfinsupp.module ι R (λ i, A i →₀ R) _ _ _,

  let f := λ i, lmap_domain R R (dfinsupp.single i : A i → Π₀ i, A i),
  use dfinsupp.coprod_map f ∘ₗ dfinsupp.map_range.linear_map s,

  ext i x j,
  simp only [dfinsupp.coprod_map, direct_sum.lof, total_map_domain,
    coe_comp, coe_lsum, id_coe, linear_equiv.coe_to_linear_map, finsupp_lequiv_dfinsupp_symm_apply,
    function.comp_app, dfinsupp.lsingle_apply, dfinsupp.map_range.linear_map_apply,
    dfinsupp.map_range_single, lmap_domain_apply, dfinsupp.to_finsupp_single,
    finsupp.sum_single_index, id.def, function.comp.left_id, dfinsupp.single_apply],
  rw [←dfinsupp.lapply_apply j, apply_total R],

  obtain rfl | hij := eq_or_ne i j,

  { convert (hs i) x,
    { ext, simp },
    { simp } },
  { convert finsupp.total_zero_apply _ ((s i) x),
    { ext, simp [hij] },
    { simp [hij] } }
end

end semiring

section ring

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

/-- Free modules are projective. -/
theorem projective_of_basis {ι : Type*} (b : basis ι R P) : projective R P :=
begin
  -- need P →ₗ (P →₀ R) for definition of projective.
  -- get it from `ι → (P →₀ R)` coming from `b`.
  use b.constr ℕ (λ i, finsupp.single (b i) (1 : R)),
  intro m,
  simp only [b.constr_apply, mul_one, id.def, finsupp.smul_single', finsupp.total_single,
    linear_map.map_finsupp_sum],
  exact b.total_repr m,
end

@[priority 100]
instance projective_of_free [module.free R P] : module.projective R P :=
projective_of_basis $ module.free.choose_basis R P

end ring

--This is in a different section because special universe restrictions are required.
section of_lifting_property

/-- A module which satisfies the universal property is projective. Note that the universe variables
in `huniv` are somewhat restricted. -/
theorem projective_of_lifting_property'
  {R : Type u} [semiring R] {P : Type (max u v)} [add_comm_monoid P] [module R P]
  -- If for all surjections of `R`-modules `M →ₗ N`, all maps `P →ₗ N` lift to `P →ₗ M`,
  (huniv : ∀ {M : Type (max v u)} {N : Type (max u v)} [add_comm_monoid M] [add_comm_monoid N],
    by exactI
    ∀ [module R M] [module R N],
    by exactI
    ∀ (f : M →ₗ[R] N) (g : P →ₗ[R] N),
  function.surjective f → ∃ (h : P →ₗ[R] M), f.comp h = g) :
  -- then `P` is projective.
  projective R P :=
begin
  -- let `s` be the universal map `(P →₀ R) →ₗ P` coming from the identity map `P →ₗ P`.
  obtain ⟨s, hs⟩ : ∃ (s : P →ₗ[R] P →₀ R),
    (finsupp.total P P R id).comp s = linear_map.id :=
    huniv (finsupp.total P P R (id : P → P)) (linear_map.id : P →ₗ[R] P) _,
  -- This `s` works.
  { use s,
    rwa linear_map.ext_iff at hs },
  { intro p,
    use finsupp.single p 1,
    simp },
end

/-- A variant of `of_lifting_property'` when we're working over a `[ring R]`,
which only requires quantifying over modules with an `add_comm_group` instance. -/
theorem projective_of_lifting_property
  {R : Type u} [ring R] {P : Type (max u v)} [add_comm_group P] [module R P]
  -- If for all surjections of `R`-modules `M →ₗ N`, all maps `P →ₗ N` lift to `P →ₗ M`,
  (huniv : ∀ {M : Type (max v u)} {N : Type (max u v)} [add_comm_group M] [add_comm_group N],
    by exactI
    ∀ [module R M] [module R N],
    by exactI
    ∀ (f : M →ₗ[R] N) (g : P →ₗ[R] N),
  function.surjective f → ∃ (h : P →ₗ[R] M), f.comp h = g) :
  -- then `P` is projective.
  projective R P :=
-- We could try and prove this *using* `of_lifting_property`,
-- but this quickly leads to typeclass hell,
-- so we just prove it over again.
begin
  -- let `s` be the universal map `(P →₀ R) →ₗ P` coming from the identity map `P →ₗ P`.
  obtain ⟨s, hs⟩ : ∃ (s : P →ₗ[R] P →₀ R),
    (finsupp.total P P R id).comp s = linear_map.id :=
    huniv (finsupp.total P P R (id : P → P)) (linear_map.id : P →ₗ[R] P) _,
  -- This `s` works.
  { use s,
    rwa linear_map.ext_iff at hs },
  { intro p,
    use finsupp.single p 1,
    simp },
end

end of_lifting_property

end module


import tactic

/-!
# Dirichlet density of primes ≡ 1 and primes ≡ 3 mod 4

The goal of this project is to prove

**Theorem.** The sets of primes p ≡ 1 mod 4 and of primes p ≡ 3 mod 4 both have
Dirichlet density 1/2.

This is covered in Ireland-Rosen, §16.1-2:

## §1 The Zeta Function

The Riemann zeta function ζ(s) is defined by ζ(s) = ∑_{n=1}^∞ n⁻ˢ.
It converges for s > 1 and converges uniformly for s ≥ 1 + δ > 1, for each δ > O.

**Proposition 16.1.1.** For s > 1.
  ζ(s) = ∏ₚ (1 - p⁻ˢ)⁻¹,
where the product is over all primes p > 0.

PROOF. For s > 1, p⁻ˢ < 1, so we have (1 - p⁻ˢ)⁻¹ = ∑_{m=0}^∞ p⁻ᵐˢ.
By the theorem of unique factorization
  ∏_{p ≤ N} (1 - p⁻ˢ)⁻¹ = ∑_{n ≤ N} n⁻ˢ + R_N(s) .
Clearly, R_N(s) ≤ ∑_{n=N+1}^∞ n⁻ˢ. Since ζ(s) converges, R_N(s) → 0 as N → ∞. The
result follows. QED

The behavior of ζ(s) as s → 1 is very important. Since ∑_{n=1}^∞ n⁻¹ diverges,
we, of course, suspect ζ(s) → ∞ as s → 1. In fact,

**Proposition 16.1.2.** Assume s > 1. Then
  lim_{s → 1} (s - l) ζ(s) = 1.

PROOF. For fixed s, t⁻ˢ is a monotone decreasing function of t. Thus,
  (n + 1)⁻ˢ < ∫_n^{n+1} t⁻ˢ dt < n⁻ˢ .
Summing from n = 1 to ∞,
  ζ(s) - 1 < ∫_1^∞ t⁻ˢ dt < ζ(s) .
The value of the integral is (s - 1)⁻¹. It follows that 1 < (s - 1) ζ(s) < s.
Taking the limit as s → 1 gives the result. QED

**Corollary.** As s → 1 we have
  (ln ζ(s))/(ln (s-1)⁻¹) → 1 .

PROOF. Let (s - 1) ζ(s) = ρ(s). Then ln(s - 1) + ln ζ(s) = ln ρ(s), so we have
ln ζ(s)/ln(s - 1)⁻¹ = 1 + (ln ρ(s))/ln(s - 1)^⁻¹.
As s → 1, ρ(s) → 1 by the proposition. Therefore, ln ρ(s) → 0, and the
result follows. QED

**Proposition 16.1.3.** ln ζ(s) = ∑ₚ p⁻ˢ + R(s), where R(s) remains bounded as
s → 1.

PROOF. We use the formula -ln(1 - x) = x + x²/2 + x³/3 + ..., which is
valid for -1 < x < 1.
By Proposition 16.1.1 we have
  ζ(s) = ∏_{p ≤ N} (1 - p⁻ˢ)⁻¹ λ_N(s) ,
where λ_N(S) → 1 as N → ∞. Taking the logarithm of both sides yields
ln ζ(s) = ∑_{p ≤ N} ∑_{m=1}^∞ m⁻¹ p⁻ᵐˢ + ln λ_N(s).
Taking the limit as N → ∞
  ln ζ(s) = ∑ₚ ∑_{m=1}^∞ m⁻¹ p⁻ᵐˢ = ∑ₚ p⁻ˢ + ∑ₚ ∑_{m=2}^∞ m⁻¹ p⁻ᵐˢ .
The second sum is less than
  ∑ₚ ∑_{m=2}^∞ p⁻ᵐˢ = ∑ₚ p⁻²ˢ (1 - p⁻ˢ)⁻¹ ≤ (1 - 2⁻ˢ)⁻¹ ∑ₚ p⁻²ˢ ≤ 2 ζ(2).
Throughout we have used the assumption that s > 1. QED

**Definition.** A set of positive primes 𝒫 is said to have *Dirichlet density* if
  lim_{s → 1} (∑_{p ∈ 𝒫} p⁻ˢ)/ln (s-1)⁻¹
exists. If the limit exists we set it equal to d(𝒫) and call d(𝒫) the
*Dirichlet density* of 𝒫.

**Proposition 16.1.4.** Let 𝒫 be a set of positive prime numbers. Then
(a) If 𝒫 is finite, then d(𝒫) = 0.
(b) If 𝒫 consists of all but finitely many positive primes, then d(𝒫) = 1.
(c) If 𝒫 = 𝒫₁ ∪ 𝒫₂ where 𝒫₁ and 𝒫₂ are disjoint and d(𝒫₁) and d(𝒫₂) both
exist, then d(𝒫) = d(𝒫₁) + d(𝒫₂).

PROOF. Parts (a) and (c) are clear from the definition of Dirichlet density.
Part (b) follows quickly from the corollary to Proposition 16.1.2 and Proposition 16.1.3.
QED

We are now in a position to state the main theorem of this chapter. The
proof will be spread out over the next three sections.

**Theorem 1** (L. Dirichlet). Suppose a, m ∈ ℤ, with gcd(a, m) = 1. Let 𝒫(a; m) be the
set of positive primes p such that p ≡ a mod m. Then d(𝒫(a; m)) = 1/ϕ(m).

Note that Theorem 1 certainly implies 𝒫(a; m) is infinite, since if it were
finite, its density would be zero.

## §2 A Special Case

We will first prove Theorem 1 in the case where m = 4. The basic ideas of the
proof are all present in this special case, but the details are more transparent.
Define a function χ from ℤ to {0, ±1} as follows; χ(n) = 0 if n is even,
χ(n) = 1 if n ≡ 1 mod 4, and χ(n) = -1 if n ≡ 3 mod 4. It is easily seen that
χ(m n) = χ(m) χ(n) for all m, n ∈ ℤ.

Define L(s, χ) = ∑_{n=1}^∞ χ(n) n⁻ˢ = 1 - 3⁻ˢ + 5⁻ˢ - 7⁻ˢ + ... . For all n
we have |χ(n) n⁻ˢ| ≤ n⁻ˢ. It follows that the terms of L(s, χ) are dominated in
absolute value by the terms of ζ(s). Thus L(s, χ) converges and is continuous
for s > 1. Since χ is completely multiplicative, the proof of Proposition 16.1.1.
shows that
  L(s, χ) = ∏ₚ (1 - χ(p) p⁻ˢ)^⁻¹ .
It is useful to modify ζ(s) so as to suppress the even terms. Define ζ*(s) = ∑{n odd} n⁻ˢ.
Since
  ζ(s) = ∑_{n=1}^∞ n⁻ˢ = ∑_{n odd} n⁻ˢ + ∑_{n even} n⁻ˢ = ζ*(s) + 2⁻ˢ ζ(s)
we have ζ*(s) = (1 - 2⁻ˢ) ζ(s) and so
  ζ*(s) = ∏_{p odd} (1 - p⁻ˢ)⁻¹ .
Using the method of proof of Proposition 16.1.3 we find
  ln L(s, χ) = ∑_{p odd} χ(p) p⁻ˢ + R₁(s)                            (i)
    ln ζ*(s) = ∑_{p odd} p⁻ˢ + R₂(s)                                (ii)
where R₁(s) and R₂(s) remain bounded as s → 1.

We have 1 + χ(p) = 2 if p ≡ 1 mod 4 and 1 + χ(p) = 0 if p ≡ 3 mod 4. Similarly,
1 - χ(p) = 2 if p ≡ 3 mod 4 and 1 - χ(p) = 0 if p ≡ 1 mod 4.  From (i) and (ii) we
deduce
  ln ζ*(s) + ln L(s, χ) = 2 ∑_{p ≡ 1 mod 4} p⁻ˢ + R₃(s)            (iii)
  ln ζ*(s) - ln L(s, χ) = 2 ∑_{p ≡ 3 mod 4} p⁻ˢ + R₄(s)             (iv)
 where R₃(s) and R₄(s) remain bounded as s → 1.

The next step is to show that ln L(s, χ) remains bounded as s → 1. To see
this, write
  L(s, χ) = (1 - 3⁻ˢ) + (5⁻ˢ - 7⁻ˢ) + ... = 1 - (3⁻ˢ - 5⁻ˢ) - (7⁻ˢ - 9⁻ˢ) - ... .
It follows that for all s > 1 we have 2/3 < L(s, χ) < 1. Thus, for s > 1 we have
ln 2/3 < ln L(s, χ) < ln 1 = 0.

As a final preparatory step we note that ln ζ*(s) = ln(1 - 2⁻ˢ) + ln ζ(s), so
by the corollary to Proposition 16.1.2. we have ln ζ*(s)/ln(s - 1)⁻¹ → 1 as s → 1.

Now divide each term of Equations (iii) and (iv) by ln(s - 1)⁻¹ and take
the limit as s → 1. The result is

**Proposition 16.2.1.** d(𝒫(1; 4)) = 1/2 and d(𝒫(3; 4)) = 1/2.

-/


/-
Copyright (c) 2016 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad
-/
import data.list.of_fn
import data.list.perm

/-!
# Sorting algorithms on lists

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

In this file we define `list.sorted r l` to be an alias for `pairwise r l`. This alias is preferred
in the case that `r` is a `<` or `≤`-like relation. Then we define two sorting algorithms:
`list.insertion_sort` and `list.merge_sort`, and prove their correctness.
-/

open list.perm

universe uu

namespace list

/-!
### The predicate `list.sorted`
-/

section sorted

variables {α : Type uu} {r : α → α → Prop} {a : α} {l : list α}

/-- `sorted r l` is the same as `pairwise r l`, preferred in the case that `r`
  is a `<` or `≤`-like relation (transitive and antisymmetric or asymmetric) -/
def sorted := @pairwise

instance decidable_sorted [decidable_rel r] (l : list α) : decidable (sorted r l) :=
list.decidable_pairwise _

@[simp] theorem sorted_nil : sorted r [] := pairwise.nil

lemma sorted.of_cons : sorted r (a :: l) → sorted r l := pairwise.of_cons

theorem sorted.tail {r : α → α → Prop} {l : list α} (h : sorted r l) : sorted r l.tail :=
h.tail

theorem rel_of_sorted_cons {a : α} {l : list α} : sorted r (a :: l) →
  ∀ b ∈ l, r a b :=
rel_of_pairwise_cons

@[simp] theorem sorted_cons {a : α} {l : list α} :
  sorted r (a :: l) ↔ (∀ b ∈ l, r a b) ∧ sorted r l :=
pairwise_cons

protected theorem sorted.nodup {r : α → α → Prop} [is_irrefl α r] {l : list α} (h : sorted r l) :
  nodup l :=
h.nodup

theorem eq_of_perm_of_sorted [is_antisymm α r]
  {l₁ l₂ : list α} (p : l₁ ~ l₂) (s₁ : sorted r l₁) (s₂ : sorted r l₂) : l₁ = l₂ :=
begin
  induction s₁ with a l₁ h₁ s₁ IH generalizing l₂,
  { exact p.nil_eq },
  { have : a ∈ l₂ := p.subset (mem_cons_self _ _),
    rcases mem_split this with ⟨u₂, v₂, rfl⟩,
    have p' := (perm_cons a).1 (p.trans perm_middle),
    obtain rfl := IH p' (s₂.sublist $ by simp),
    change a::u₂ ++ v₂ = u₂ ++ ([a] ++ v₂), rw ← append_assoc, congr,
    have : ∀ (x : α) (h : x ∈ u₂), x = a := λ x m,
      antisymm ((pairwise_append.1 s₂).2.2 _ m a (mem_cons_self _ _))
        (h₁ _ (by simp [m])),
    rw [(@eq_replicate _ a (length u₂ + 1) (a::u₂)).2,
        (@eq_replicate _ a (length u₂ + 1) (u₂++[a])).2];
    split; simp [iff_true_intro this, or_comm] }
end

theorem sublist_of_subperm_of_sorted [is_antisymm α r]
  {l₁ l₂ : list α} (p : l₁ <+~ l₂) (s₁ : l₁.sorted r) (s₂ : l₂.sorted r) : l₁ <+ l₂ :=
let ⟨_, h, h'⟩ := p in by rwa ←eq_of_perm_of_sorted h (s₂.sublist h') s₁

@[simp] theorem sorted_singleton (a : α) : sorted r [a] := pairwise_singleton _ _

lemma sorted.rel_nth_le_of_lt {l : list α}
  (h : l.sorted r) {a b : ℕ} (ha : a < l.length) (hb : b < l.length) (hab : a < b) :
  r (l.nth_le a ha) (l.nth_le b hb) :=
list.pairwise_iff_nth_le.1 h a b hb hab

lemma sorted.rel_nth_le_of_le [is_refl α r] {l : list α}
  (h : l.sorted r) {a b : ℕ} (ha : a < l.length) (hb : b < l.length) (hab : a ≤ b) :
  r (l.nth_le a ha) (l.nth_le b hb) :=
begin
  cases eq_or_lt_of_le hab with H H,
  { subst H, exact refl _ },
  { exact h.rel_nth_le_of_lt _ _ H }
end

lemma sorted.rel_of_mem_take_of_mem_drop {l : list α} (h : list.sorted r l)
  {k : ℕ} {x y : α} (hx : x ∈ list.take k l) (hy : y ∈ list.drop k l) :
  r x y :=
begin
  obtain ⟨iy, hiy, rfl⟩ := nth_le_of_mem hy,
  obtain ⟨ix, hix, rfl⟩ := nth_le_of_mem hx,
  rw [nth_le_take', nth_le_drop'],
  rw length_take at hix,
  exact h.rel_nth_le_of_lt _ _ (ix.lt_add_right _ _ (lt_min_iff.mp hix).left)
end

end sorted

section monotone

variables {n : ℕ} {α : Type uu} [preorder α] {f : fin n → α}

/-- A tuple is monotone if and only if the list obtained from it is sorted. -/
lemma monotone_iff_of_fn_sorted : monotone f ↔ (of_fn f).sorted (≤) :=
begin
  simp_rw [sorted, pairwise_iff_nth_le, length_of_fn, nth_le_of_fn', monotone_iff_forall_lt],
  exact ⟨λ h i j hj hij, h $ fin.mk_lt_mk.mpr hij, λ h ⟨i, _⟩ ⟨j, hj⟩ hij, h i j hj hij⟩,
end

/-- The list obtained from a monotone tuple is sorted. -/
lemma monotone.of_fn_sorted (h : monotone f) : (of_fn f).sorted (≤) :=
monotone_iff_of_fn_sorted.1 h

end monotone

section sort
variables {α : Type uu} (r : α → α → Prop) [decidable_rel r]
local infix ` ≼ ` : 50 := r

/-! ### Insertion sort -/

section insertion_sort

/-- `ordered_insert a l` inserts `a` into `l` at such that
  `ordered_insert a l` is sorted if `l` is. -/
@[simp] def ordered_insert (a : α) : list α → list α
| []       := [a]
| (b :: l) := if a ≼ b then a :: b :: l else b :: ordered_insert l

/-- `insertion_sort l` returns `l` sorted using the insertion sort algorithm. -/
@[simp] def insertion_sort : list α → list α
| []       := []
| (b :: l) := ordered_insert r b (insertion_sort l)

@[simp] lemma ordered_insert_nil (a : α) : [].ordered_insert r a = [a] := rfl

theorem ordered_insert_length : Π (L : list α) (a : α), (L.ordered_insert r a).length = L.length + 1
| [] a := rfl
| (hd :: tl) a := by { dsimp [ordered_insert], split_ifs; simp [ordered_insert_length], }

/-- An alternative definition of `ordered_insert` using `take_while` and `drop_while`. -/
lemma ordered_insert_eq_take_drop (a : α) : ∀ l : list α,
  l.ordered_insert r a = l.take_while (λ b, ¬(a ≼ b)) ++ (a :: l.drop_while (λ b, ¬(a ≼ b)))
| [] := rfl
| (b :: l) := by { dsimp only [ordered_insert], split_ifs; simp [take_while, drop_while, *] }

lemma insertion_sort_cons_eq_take_drop (a : α) (l : list α) :
  insertion_sort r (a :: l) = (insertion_sort r l).take_while (λ b, ¬(a ≼ b)) ++
    (a :: (insertion_sort r l).drop_while (λ b, ¬(a ≼ b))) :=
ordered_insert_eq_take_drop r a _

section correctness
open perm

theorem perm_ordered_insert (a) : ∀ l : list α, ordered_insert r a l ~ a :: l
| []       := perm.refl _
| (b :: l) := by by_cases a ≼ b; [simp [ordered_insert, h],
  simpa [ordered_insert, h] using
    ((perm_ordered_insert l).cons _).trans (perm.swap _ _ _)]

theorem ordered_insert_count [decidable_eq α] (L : list α) (a b : α) :
  count a (L.ordered_insert r b) = count a L + if (a = b) then 1 else 0 :=
begin
  rw [(L.perm_ordered_insert r b).count_eq, count_cons],
  split_ifs; simp only [nat.succ_eq_add_one, add_zero],
end

theorem perm_insertion_sort : ∀ l : list α, insertion_sort r l ~ l
| []       := perm.nil
| (b :: l) := by simpa [insertion_sort] using
  (perm_ordered_insert _ _ _).trans ((perm_insertion_sort l).cons b)

variable {r}

/-- If `l` is already `list.sorted` with respect to `r`, then `insertion_sort` does not change
it. -/
lemma sorted.insertion_sort_eq : ∀ {l : list α} (h : sorted r l), insertion_sort r l = l
| [] _ := rfl
| [a] _ := rfl
| (a :: b :: l) h :=
  begin
    rw [insertion_sort, sorted.insertion_sort_eq, ordered_insert, if_pos],
    exacts [rel_of_sorted_cons h _ (or.inl rfl), h.tail]
  end

section total_and_transitive
variables [is_total α r] [is_trans α r]

theorem sorted.ordered_insert (a : α) : ∀ l, sorted r l → sorted r (ordered_insert r a l)
| []       h := sorted_singleton a
| (b :: l) h := begin
  by_cases h' : a ≼ b,
  { simpa [ordered_insert, h', h] using λ b' bm, trans h' (rel_of_sorted_cons h _ bm) },
  { suffices : ∀ (b' : α), b' ∈ ordered_insert r a l → r b b',
    { simpa [ordered_insert, h', h.of_cons.ordered_insert l] },
    intros b' bm,
    cases (show b' = a ∨ b' ∈ l, by simpa using
      (perm_ordered_insert _ _ _).subset bm) with be bm,
    { subst b', exact (total_of r _ _).resolve_left h' },
    { exact rel_of_sorted_cons h _ bm } }
end

variable (r)

/-- The list `list.insertion_sort r l` is `list.sorted` with respect to `r`. -/
theorem sorted_insertion_sort : ∀ l, sorted r (insertion_sort r l)
| []       := sorted_nil
| (a :: l) := (sorted_insertion_sort l).ordered_insert a _

end total_and_transitive
end correctness
end insertion_sort

/-! ### Merge sort -/

section merge_sort

-- TODO(Jeremy): observation: if instead we write (a :: (split l).1, b :: (split l).2), the
-- equation compiler can't prove the third equation

/-- Split `l` into two lists of approximately equal length.

     split [1, 2, 3, 4, 5] = ([1, 3, 5], [2, 4]) -/
@[simp] def split : list α → list α × list α
| []       := ([], [])
| (a :: l) := let (l₁, l₂) := split l in (a :: l₂, l₁)

theorem split_cons_of_eq (a : α) {l l₁ l₂ : list α} (h : split l = (l₁, l₂)) :
  split (a :: l) = (a :: l₂, l₁) :=
by rw [split, h]; refl

theorem length_split_le : ∀ {l l₁ l₂ : list α},
  split l = (l₁, l₂) → length l₁ ≤ length l ∧ length l₂ ≤ length l
| []     ._  ._  rfl := ⟨nat.le_refl 0, nat.le_refl 0⟩
| (a::l) l₁' l₂' h   := begin
  cases e : split l with l₁ l₂,
  injection (split_cons_of_eq _ e).symm.trans h, substs l₁' l₂',
  cases length_split_le e with h₁ h₂,
  exact ⟨nat.succ_le_succ h₂, nat.le_succ_of_le h₁⟩
end

theorem length_split_lt {a b} {l l₁ l₂ : list α} (h : split (a::b::l) = (l₁, l₂)) :
  length l₁ < length (a::b::l) ∧ length l₂ < length (a::b::l) :=
begin
  cases e : split l with l₁' l₂',
  injection (split_cons_of_eq _ (split_cons_of_eq _ e)).symm.trans h, substs l₁ l₂,
  cases length_split_le e with h₁ h₂,
  exact ⟨nat.succ_le_succ (nat.succ_le_succ h₁), nat.succ_le_succ (nat.succ_le_succ h₂)⟩
end

theorem perm_split : ∀ {l l₁ l₂ : list α}, split l = (l₁, l₂) → l ~ l₁ ++ l₂
| []     ._  ._  rfl := perm.refl _
| (a::l) l₁' l₂' h   := begin
  cases e : split l with l₁ l₂,
  injection (split_cons_of_eq _ e).symm.trans h, substs l₁' l₂',
  exact ((perm_split e).trans perm_append_comm).cons a,
end

/-- Merge two sorted lists into one in linear time.

     merge [1, 2, 4, 5] [0, 1, 3, 4] = [0, 1, 1, 2, 3, 4, 4, 5] -/
def merge : list α → list α → list α
| []       l'        := l'
| l        []        := l
| (a :: l) (b :: l') := if a ≼ b then a :: merge l (b :: l') else b :: merge (a :: l) l'

include r
/-- Implementation of a merge sort algorithm to sort a list. -/
def merge_sort : list α → list α
| []        := []
| [a]       := [a]
| (a::b::l) := begin
  cases e : split (a::b::l) with l₁ l₂,
  cases length_split_lt e with h₁ h₂,
  exact merge r (merge_sort l₁) (merge_sort l₂)
end
using_well_founded
{ rel_tac := λ_ _, `[exact ⟨_, inv_image.wf length nat.lt_wf⟩],
  dec_tac := tactic.assumption }

theorem merge_sort_cons_cons {a b} {l l₁ l₂ : list α}
  (h : split (a::b::l) = (l₁, l₂)) :
  merge_sort r (a::b::l) = merge r (merge_sort r l₁) (merge_sort r l₂) :=
begin
  suffices : ∀ (L : list α) h1, @@and.rec
    (λ a a (_ : length l₁ < length l + 1 + 1 ∧
      length l₂ < length l + 1 + 1), L) h1 h1 = L,
  { simp [merge_sort, h], apply this },
  intros, cases h1, refl
end

section correctness

theorem perm_merge : ∀ (l l' : list α), merge r l l' ~ l ++ l'
| []       []        := by simp [merge]
| []       (b :: l') := by simp [merge]
| (a :: l) []        := by simp [merge]
| (a :: l) (b :: l') := begin
  by_cases a ≼ b,
  { simpa [merge, h] using perm_merge _ _ },
  { suffices : b :: merge r (a :: l) l' ~ a :: (l ++ b :: l'), {simpa [merge, h]},
    exact ((perm_merge _ _).cons _).trans ((swap _ _ _).trans (perm_middle.symm.cons _)) }
end

theorem perm_merge_sort : ∀ l : list α, merge_sort r l ~ l
| []        := by simp [merge_sort]
| [a]       := by simp [merge_sort]
| (a::b::l) := begin
  cases e : split (a::b::l) with l₁ l₂,
  cases length_split_lt e with h₁ h₂,
  rw [merge_sort_cons_cons r e],
  apply (perm_merge r _ _).trans,
  exact ((perm_merge_sort l₁).append (perm_merge_sort l₂)).trans (perm_split e).symm
end
using_well_founded
{ rel_tac := λ_ _, `[exact ⟨_, inv_image.wf length nat.lt_wf⟩],
  dec_tac := tactic.assumption }

@[simp] lemma length_merge_sort (l : list α) : (merge_sort r l).length = l.length :=
(perm_merge_sort r _).length_eq

section total_and_transitive
variables {r} [is_total α r] [is_trans α r]

theorem sorted.merge : ∀ {l l' : list α}, sorted r l → sorted r l' → sorted r (merge r l l')
| []       []        h₁ h₂ := by simp [merge]
| []       (b :: l') h₁ h₂ := by simpa [merge] using h₂
| (a :: l) []        h₁ h₂ := by simpa [merge] using h₁
| (a :: l) (b :: l') h₁ h₂ := begin
  by_cases a ≼ b,
  { suffices : ∀ (b' : α) (_ : b' ∈ merge r l (b :: l')), r a b',
    { simpa [merge, h, h₁.of_cons.merge h₂] },
    intros b' bm,
    rcases (show b' = b ∨ b' ∈ l ∨ b' ∈ l', by simpa [or.left_comm] using
      (perm_merge _ _ _).subset bm) with be | bl | bl',
    { subst b', assumption },
    { exact rel_of_sorted_cons h₁ _ bl },
    { exact trans h (rel_of_sorted_cons h₂ _ bl') } },
  { suffices : ∀ (b' : α) (_ : b' ∈ merge r (a :: l) l'), r b b',
    { simpa [merge, h, h₁.merge h₂.of_cons] },
    intros b' bm,
    have ba : b ≼ a := (total_of r _ _).resolve_left h,
    rcases (show b' = a ∨ b' ∈ l ∨ b' ∈ l', by simpa using
      (perm_merge _ _ _).subset bm) with be | bl | bl',
    { subst b', assumption },
    { exact trans ba (rel_of_sorted_cons h₁ _ bl) },
    { exact rel_of_sorted_cons h₂ _ bl' } }
end

variable (r)

theorem sorted_merge_sort : ∀ l : list α, sorted r (merge_sort r l)
| []        := by simp [merge_sort]
| [a]       := by simp [merge_sort]
| (a::b::l) := begin
  cases e : split (a::b::l) with l₁ l₂,
  cases length_split_lt e with h₁ h₂,
  rw [merge_sort_cons_cons r e],
  exact (sorted_merge_sort l₁).merge (sorted_merge_sort l₂)
end
using_well_founded
{ rel_tac := λ_ _, `[exact ⟨_, inv_image.wf length nat.lt_wf⟩],
  dec_tac := tactic.assumption }

theorem merge_sort_eq_self [is_antisymm α r] {l : list α} : sorted r l → merge_sort r l = l :=
eq_of_perm_of_sorted (perm_merge_sort _ _) (sorted_merge_sort _ _)

theorem merge_sort_eq_insertion_sort [is_antisymm α r] (l : list α) :
  merge_sort r l = insertion_sort r l :=
eq_of_perm_of_sorted ((perm_merge_sort r l).trans (perm_insertion_sort r l).symm)
  (sorted_merge_sort r l) (sorted_insertion_sort r l)

end total_and_transitive
end correctness

@[simp] theorem merge_sort_nil : [].merge_sort r = [] :=
by rw list.merge_sort

@[simp] theorem merge_sort_singleton (a : α) : [a].merge_sort r = [a] :=
by rw list.merge_sort

end merge_sort
end sort

/- try them out! -/

--#eval insertion_sort (λ m n : ℕ, m ≤ n) [5, 27, 221, 95, 17, 43, 7, 2, 98, 567, 23, 12]

--#eval merge_sort     (λ m n : ℕ, m ≤ n) [5, 27, 221, 95, 17, 43, 7, 2, 98, 567, 23, 12]

end list


/-
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 topology.continuous_function.bounded
import topology.continuous_function.basic

/-!
# Quotients of Amenable groups

In this file, we prove that quotients of amenable groups are again amenable

## Main Statements
- `amenable_of_quotient'`  : If G →* H is a surjective group homomorphism and G is amenable,
                            then so is H.
- `amenable_of_quotient`   : If G is amenable, then so is G/N for every normal subgroup N.
- `amenable_of_iso`        : Amenability is preserved under (multiplicative) isomorphisms.

## References
* [C. Löh, *Geometric Group Theory*, Proposition 9.1.6 (2)][loeh17]
* [A.L.T. Paterson, *Amenability*, Proposition 0.16 (2)][Paterson1988]

## Tags
quotients, amenable, amenability
-/

open classical
open function

variables
{G:Type*}
[group G]

{H:Type*}
[group H]

(π: G →* H)
(pi_surj : surjective π)

namespace amenable_quotient

open mean

/--The pushforward mean is left-invariant if the
map is surjective-/
lemma mean_pushforward_leftinv
  (m : left_invariant_mean G)
  (pi_surj : surjective π)
  : ∀(h:H), ∀(f: bounded_continuous_function H ℝ),
        (mean_pushforward π m) (left_translate h f)
      = (mean_pushforward π m) f
:= begin
  assume h : H,
  assume f : bounded_continuous_function H ℝ,

  -- h has a preimage under π
  have : ∃ (g:G), π g = h
        := by tauto,
  rcases this with ⟨g, pi_gh⟩,

  --main step: The pullback of (left_translate h f)
  -- is the left_translate of (via g) the pullback of f
  have translate_pullback:
      pull_bcont π (left_translate h f) = left_translate g (pull_bcont π f),
  {
    ext (x:G),
    calc  pull_bcont π (left_translate h f) x
        = (left_translate h f) (π x)
          : by tauto
    ... = f (h⁻¹*(π x))
          : by tauto
    ... = f ((π g)⁻¹ * (π x))
          : by rw pi_gh
    ... = f ((π (g⁻¹)) * (π x))
          : by norm_num
    ... = f (π (g⁻¹ * x))
          : by simp[mul_hom.map_mul]
    ... = (pull_bcont π f) (g⁻¹ * x)
          : by tauto
    ... = (left_translate g (pull_bcont π f)) x
          : by tauto,
  },

  calc  (mean_pushforward π m) (left_translate h f)
      = m (pull_bcont π (left_translate h f))
        : by tauto
  ... = m (left_translate g (pull_bcont π f))
        : by rw translate_pullback
  ... = m (pull_bcont π f)
        : by exact m.left_invariance _ _
  ... = (mean_pushforward π m) f
        : by tauto,
end

/-- pushforward invariant mean-/
@[simp]
noncomputable def inv_mean_pushforward
  (m : left_invariant_mean G)
  (pi_surj : surjective π)
  : left_invariant_mean H
:= left_invariant_mean.mk (mean_pushforward π m)
                  (mean_pushforward_leftinv π  m pi_surj)

end amenable_quotient

/--The target group is amenable if π is surjective -/
theorem amenable_of_quotient'
  (pi_surj : surjective π)
  (G_am: amenable G)
  : amenable H
:= amenable_of_invmean (amenable_quotient.inv_mean_pushforward π (invmean_of_amenable G_am) pi_surj)

/--Formulation with quotients-/
theorem amenable_of_quotient
  {N : subgroup G}
  (nN : N.normal)
  (G_am: amenable G)
  : amenable (G⧸N)
:= amenable_of_quotient' _ (quotient_group.mk'_surjective N) G_am

-- preparations for amenable of iso

/--a multiplicative homomorphism between groups is a monoid homomorphism-/
def monoidhom_of_mulhom
  (f: mul_hom G H)
  : G →* H
:= monoid_hom.mk f.to_fun
      (begin
        have : f.to_fun 1 * f.to_fun 1 = f.to_fun 1,
        {
          calc  f.to_fun 1 * f.to_fun 1
              = f.to_fun (1*1)
                : by rw f.map_mul'
          ... = f.to_fun 1
                : by congr'; by group,
        },
        by finish,
      end)
    f.map_mul'

@[simp]
lemma monoidhom_of_mulhom_to_fun
   {f: mul_hom G H}
  : (monoidhom_of_mulhom f).to_fun = f.to_fun
:= by refl

/--Amenability is preserved under (multiplicative) isomorphisms-/
theorem amenable_of_iso
  {H : Type*} [group H]
  (i : G ≃* H)
  (G_am : amenable G)
  : amenable H
:= begin
  -- we obtain a surjective group hom G →* H
  let p: G →* H := monoidhom_of_mulhom i.to_mul_hom,
  have p_surj : surjective p,
  {
    dsimp[p],
    change surjective (monoidhom_of_mulhom i.to_mul_hom).to_fun,
    rw monoidhom_of_mulhom_to_fun,
    exact mul_equiv.surjective i,
  },
  exact amenable_of_quotient' p p_surj G_am,
end


import data.list.basic data.list.big_operators logic.embedding
import tactic.squeeze

namespace list
universes u v w x
variables {α : Type u} {β : Type v} {γ : Type w} {δ : Type x}

open list

def all_prop {α : Type*} (p : α → Prop) : ∀ (l : list α), Prop
| nil := true
| (a :: l) := (p a) ∧ (all_prop l)

lemma all_prop_iff {α : Type*} {p : α → Prop} : ∀ {l : list α},
 all_prop p l ↔ ∀ a, a ∈ l → p a
| nil := by {rw[all_prop,true_iff],intros a ha,cases ha,}
| (cons m l) :=
by {rw[all_prop],split,
 {rintro ⟨hm,hl⟩ a ha,rcases ha,exact ha.symm ▸ hm,
  exact (all_prop_iff.mp hl) a ha},
 {intro h,split,
  exact h m (mem_cons_self m l),
  apply all_prop_iff.mpr,intros a ha,
  exact h a (mem_cons_of_mem m ha),
 }
}

def cons_embedding (a : α) : list α ↪ list α := ⟨cons a,cons_injective⟩

def concat_embedding (a : α) : list α ↪ list α :=
 ⟨λ l, l ++ [a],λ l₁ l₂ e, append_right_cancel e⟩

def rtake (n : ℕ) (l : list α) := l.drop (l.length - n)

def rdrop (n : ℕ) (l : list α) := l.take (l.length - n)

lemma eq_singleton : ∀ (l : list α) (h : l.length = 1),
 l = [l.nth_le 0 (by {rw[h],exact nat.lt_succ_self 0})]
| [] h := by {cases h}
| [a] h := rfl
| (_ :: _ :: _) h := by {cases h}

lemma nth_le_congr (l : list α) {n₁ n₂ : ℕ} (h₁ : n₁ < l.length) (e : n₁ = n₂) :
 l.nth_le n₁ h₁ = l.nth_le n₂ (e ▸ h₁) := by {cases e,refl}

lemma nth_le_append' : ∀ (l₁ : list α) {l₂ : list α} {n : ℕ} (hn : n < l₂.length),
 (l₁ ++ l₂).nth_le (l₁.length + n) ((list.length_append l₁ l₂).symm ▸ (nat.add_lt_add_left hn l₁.length)) = l₂.nth_le n hn
| list.nil l₂ n hn := by {congr,dsimp[length],rw[zero_add]}
| (a :: l₁) l₂ n hn := begin
 let h := nth_le_append' l₁ hn,
 dsimp[append],rw[h.symm],
 have : l₁.length + 1 + n = (l₁.length + n) + 1 := by {rw[add_assoc,add_comm 1,← add_assoc],},
 rw[nth_le_congr _ _ this,nth_le],refl,
end

#check list.nth_le_take

lemma nth_le_take_old : ∀ {n m : ℕ} {l : list α} (hn : n < m) (hm : m ≤ l.length),
 (l.take m).nth_le n (by {rw[length_take,min_eq_left hm], exact hn}) =
   l.nth_le n (lt_of_lt_of_le hn hm)
| n 0 l hn hm := by {cases hn}
| n (m + 1) [] hn hm := by {cases hm}
| 0 (m + 1) (a :: l) hn hm := rfl
| (n + 1) (m + 1) (a :: l) hn hm :=
   nth_le_take_old (nat.lt_of_succ_lt_succ hn) (nat.le_of_succ_le_succ hm)

#check list.nth_le_drop

lemma nth_le_drop_old : ∀ {n m : ℕ} {l : list α} (h : m + n < l.length),
 (l.drop m).nth_le n (by {rw[length_drop],rw[add_comm] at h,exact lt_tsub_iff_right.mpr h}) =
  l.nth_le (m + n) h
| n 0 l h := (nth_le_congr l h (zero_add n)).symm
| n (m + 1) [] h := by {cases h}
| n (m + 1) (a :: l) h := begin
   dsimp[drop],
   have : m + 1 + n = (m + n) + 1 := by {rw[add_assoc,add_comm 1,← add_assoc],},
   rw[this] at h,
   rw[nth_le_congr _ _ this],dsimp[nth_le],apply nth_le_drop_old,
end

lemma drop_eq_last {n : ℕ} {l : list α} (h : l.length = n + 1) :
  (l.drop n) = [l.nth_le n (h.symm ▸ n.lt_succ_self)] :=
begin
 let t := l.drop n,
 let a := l.nth_le n (h.symm ▸ n.lt_succ_self),
 change t = [a],
 let a' := t.nth_le 0 _,
 have : a = a' := begin
  dsimp[a,a',last],
  let h := @list.nth_le_drop_old α 0 n l (by {rw[h,add_zero],exact n.lt_succ_self}),
  rw[list.nth_le_congr _ _ (add_zero n)] at h,
  exact h.symm,
 end,
 rw[this],
 have t_len : t.length = 1 := by { rw[list.length_drop,h,nat.add_sub_cancel_left]},
 exact eq_singleton t t_len,
end

#check list.sum_singleton

lemma sum_singleton_old [add_monoid α] (a : α) : [a].sum = a :=
 by {rw[list.sum_cons,sum_nil,add_zero]}

end list


import data.real.basic

def odd_fun (f : ℝ → ℝ) := ∀ x, f (-x) = -f x

example (f g : ℝ → ℝ) : odd_fun f → odd_fun g →  odd_fun (g ∘ f) :=
begin
  intros hf hg x,
  calc (g ∘ f) (-x)
      = g (f (-x)) : rfl
  ... = g (-f x)   : by rw hf
  ... =-g (f x)    : by rw hg
  ... = -(g ∘ f) x : rfl,
end


variables x y z w : ℕ

example (h₁ : x = y) (h₂ : y = z) (h₃ : z = w) : x = w :=
begin
  apply eq.trans h₁,
  apply eq.trans h₂,
  assumption
end