/-
Copyright (c) 2021 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import algebra.lie.submodule
import algebra.lie.of_associative
import linear_algebra.isomorphisms

/-!
# Quotients of Lie algebras and Lie modules

Given a Lie submodule of a Lie module, the quotient carries a natural Lie module structure. In the
special case that the Lie module is the Lie algebra itself via the adjoint action, the submodule
is a Lie ideal and the quotient carries a natural Lie algebra structure.

We define these quotient structures here. A notable omission at the time of writing (February 2021)
is a statement and proof of the universal property of these quotients.

## Main definitions

  * `lie_submodule.quotient.lie_quotient_lie_module`
  * `lie_submodule.quotient.lie_quotient_lie_algebra`

## Tags

lie algebra, quotient
-/

universes u v w w₁ w₂

namespace lie_submodule

variables {R : Type u} {L : Type v} {M : Type w}
variables [comm_ring R] [lie_ring L] [lie_algebra R L] [add_comm_group M] [module R M]
variables [lie_ring_module L M] [lie_module R L M]
variables (N N' : lie_submodule R L M) (I J : lie_ideal R L)

/-- The quotient of a Lie module by a Lie submodule. It is a Lie module. -/
instance : has_quotient M (lie_submodule R L M) :=
⟨λ N, M ⧸ N.to_submodule⟩

namespace quotient

variables {N I}

instance add_comm_group : add_comm_group (M ⧸ N) := submodule.quotient.add_comm_group _
instance module' {S : Type*} [semiring S] [has_smul S R] [module S M] [is_scalar_tower S R M] :
  module S (M ⧸ N) := submodule.quotient.module' _
instance module : module R (M ⧸ N) := submodule.quotient.module _
instance is_central_scalar {S : Type*} [semiring S]
  [has_smul S R] [module S M] [is_scalar_tower S R M]
  [has_smul Sᵐᵒᵖ R] [module Sᵐᵒᵖ M] [is_scalar_tower Sᵐᵒᵖ R M]
  [is_central_scalar S M] : is_central_scalar S (M ⧸ N) :=
submodule.quotient.is_central_scalar _
instance inhabited : inhabited (M ⧸ N) := ⟨0⟩

/-- Map sending an element of `M` to the corresponding element of `M/N`, when `N` is a
lie_submodule of the lie_module `N`. -/
abbreviation mk : M → M ⧸ N := submodule.quotient.mk

lemma is_quotient_mk (m : M) : quotient.mk' m = (mk m : M ⧸ N) := rfl

/-- Given a Lie module `M` over a Lie algebra `L`, together with a Lie submodule `N ⊆ M`, there
is a natural linear map from `L` to the endomorphisms of `M` leaving `N` invariant. -/
def lie_submodule_invariant : L →ₗ[R] submodule.compatible_maps N.to_submodule N.to_submodule :=
linear_map.cod_restrict _ (lie_module.to_endomorphism R L M) $ λ _ _, N.lie_mem

variables (N)

/-- Given a Lie module `M` over a Lie algebra `L`, together with a Lie submodule `N ⊆ M`, there
is a natural Lie algebra morphism from `L` to the linear endomorphism of the quotient `M/N`. -/
def action_as_endo_map : L →ₗ⁅R⁆ module.End R (M ⧸ N) :=
{ map_lie' := λ x y, submodule.linear_map_qext _ $ linear_map.ext $ λ m,
    congr_arg mk $ lie_lie _ _ _,
  ..linear_map.comp (submodule.mapq_linear (N : submodule R M) ↑N) lie_submodule_invariant }

/-- Given a Lie module `M` over a Lie algebra `L`, together with a Lie submodule `N ⊆ M`, there is
a natural bracket action of `L` on the quotient `M/N`. -/
instance action_as_endo_map_bracket : has_bracket L (M ⧸ N) := ⟨λ x n, action_as_endo_map N x n⟩

instance lie_quotient_lie_ring_module : lie_ring_module L (M ⧸ N) :=
{ bracket := has_bracket.bracket,
  ..lie_ring_module.comp_lie_hom _ (action_as_endo_map N) }

/-- The quotient of a Lie module by a Lie submodule, is a Lie module. -/
instance lie_quotient_lie_module : lie_module R L (M ⧸ N) :=
lie_module.comp_lie_hom _ (action_as_endo_map N)

instance lie_quotient_has_bracket : has_bracket (L ⧸ I) (L ⧸ I) :=
⟨begin
  intros x y,
  apply quotient.lift_on₂' x y (λ x' y', mk ⁅x', y'⁆),
  intros x₁ x₂ y₁ y₂ h₁ h₂,
  apply (submodule.quotient.eq I.to_submodule).2,
  rw submodule.quotient_rel_r_def at h₁ h₂,
  have h : ⁅x₁, x₂⁆ - ⁅y₁, y₂⁆ = ⁅x₁, x₂ - y₂⁆ + ⁅x₁ - y₁, y₂⁆,
    by simp [-lie_skew, sub_eq_add_neg, add_assoc],
  rw h,
  apply submodule.add_mem,
  { apply lie_mem_right R L I x₁ (x₂ - y₂) h₂, },
  { apply lie_mem_left R L I (x₁ - y₁) y₂ h₁, },
end⟩

@[simp] lemma mk_bracket (x y : L) :
  mk ⁅x, y⁆ = ⁅(mk x : L ⧸ I), (mk y : L ⧸ I)⁆ := rfl

instance lie_quotient_lie_ring : lie_ring (L ⧸ I) :=
{ add_lie  := by { intros x' y' z', apply quotient.induction_on₃' x' y' z', intros x y z,
                   repeat { rw is_quotient_mk <|>
                            rw ←mk_bracket <|>
                            rw ←submodule.quotient.mk_add, },
                   apply congr_arg, apply add_lie, },
  lie_add  := by { intros x' y' z', apply quotient.induction_on₃' x' y' z', intros x y z,
                   repeat { rw is_quotient_mk <|>
                            rw ←mk_bracket <|>
                            rw ←submodule.quotient.mk_add, },
                   apply congr_arg, apply lie_add, },
  lie_self := by { intros x', apply quotient.induction_on' x', intros x,
                   rw [is_quotient_mk, ←mk_bracket],
                   apply congr_arg, apply lie_self, },
  leibniz_lie := by { intros x' y' z', apply quotient.induction_on₃' x' y' z', intros x y z,
                   repeat { rw is_quotient_mk <|>
                            rw ←mk_bracket <|>
                            rw ←submodule.quotient.mk_add, },
                   apply congr_arg, apply leibniz_lie, } }

instance lie_quotient_lie_algebra : lie_algebra R (L ⧸ I) :=
{ lie_smul := by { intros t x' y', apply quotient.induction_on₂' x' y', intros x y,
                   repeat { rw is_quotient_mk <|>
                            rw ←mk_bracket <|>
                            rw ←submodule.quotient.mk_smul, },
                   apply congr_arg, apply lie_smul, } }

/-- `lie_submodule.quotient.mk` as a `lie_module_hom`. -/
@[simps]
def mk' : M →ₗ⁅R,L⁆ M ⧸ N :=
{ to_fun := mk, map_lie' := λ r m, rfl, ..N.to_submodule.mkq}

@[simp] lemma mk_eq_zero {m : M} : mk' N m = 0 ↔ m ∈ N :=
submodule.quotient.mk_eq_zero N.to_submodule

@[simp] lemma mk'_ker : (mk' N).ker = N :=
by { ext, simp, }

@[simp] lemma map_mk'_eq_bot_le : map (mk' N) N' = ⊥ ↔ N' ≤ N :=
by rw [← lie_module_hom.le_ker_iff_map, mk'_ker]

/-- Two `lie_module_hom`s from a quotient lie module are equal if their compositions with
`lie_submodule.quotient.mk'` are equal.

See note [partially-applied ext lemmas]. -/
@[ext]
lemma lie_module_hom_ext ⦃f g : M ⧸ N →ₗ⁅R,L⁆ M⦄ (h : f.comp (mk' N) = g.comp (mk' N)) :
  f = g :=
lie_module_hom.ext $ λ x, quotient.induction_on' x $ lie_module_hom.congr_fun h

end quotient

end lie_submodule

namespace lie_hom

variables {R L L' : Type*}
variables [comm_ring R] [lie_ring L] [lie_algebra R L] [lie_ring L'] [lie_algebra R L']
variables (f : L →ₗ⁅R⁆ L')

/-- The first isomorphism theorem for morphisms of Lie algebras. -/
@[simps] noncomputable def quot_ker_equiv_range : L ⧸ f.ker ≃ₗ⁅R⁆ f.range :=
{ to_fun := (f : L →ₗ[R] L').quot_ker_equiv_range,
  map_lie' :=
  begin
    rintros ⟨x⟩ ⟨y⟩,
    rw [← set_like.coe_eq_coe, lie_subalgebra.coe_bracket],
    simp only [submodule.quotient.quot_mk_eq_mk, linear_map.quot_ker_equiv_range_apply_mk,
      ← lie_submodule.quotient.mk_bracket, coe_to_linear_map, map_lie],
  end,
  .. (f : L →ₗ[R] L').quot_ker_equiv_range, }

end lie_hom


variables (a b c d e : ℕ)
variable h1 : a = b
variable h2 : b = c + 1
variable h3 : c = d
variable h4 : e = 1 + d

include h1 h2 h3 h4
theorem T : a = e :=
  by simp [h1, h2, h3, h4, add_comm]
-- lean 3.6 removes simp attributes from add_comm
-- i.e., now it is required to provide that lemma to solve this theorem.


import topology.instances.real

open filter real
open_locale topological_space

theorem part_i_a :
  ∃ b : ℝ, ∀ n, abs (n^3 / (n^3 - 1) : ℝ) ≤ b :=
begin
  sorry,
end

theorem part_i_c (n : ℕ) :
  (n : ℝ)^3 / (n^3 - 1) ≥ (n + 1)^3 / ((n + 1)^3 - 1) :=
begin
  sorry,
end

theorem part_i_d (a : ℕ → ℝ) (h : ∀ n : ℕ, a n = n^3 / (n^3 - 1)) :
  ∃ l : ℝ, tendsto a at_top (𝓝 l) :=
begin
  sorry
end

theorem part_ii_a :
  ∃ M : ℝ, ∀ m : ℕ, abs (2 ^ (1 / m)) ≤ M :=
begin
  sorry
end

theorem part_ii_c (n : ℕ) :
  2^(1/n) ≥ 2^(1/(n+1)) :=
begin
  sorry
end

theorem part_ii_d (a : ℕ → ℝ) (h : ∀ n : ℕ, a n = 2 ^ (1 / n)) :
  ∃ l : ℝ, tendsto a at_top (𝓝 l) :=
begin
  sorry
end

theorem part_iii_a :
  ∃ b : ℝ, ∀ n : ℕ, abs (1 - (-1)^n / ↑n) ≤ b :=
begin
  sorry
end

theorem part_iii_b (n : ℕ) :
  ¬ (∀ n : ℕ, (1 : ℝ) - (-1)^n / n ≤ 1 - (-1)^(n+1) / (n+1)) :=
begin
  sorry
end

theorem part_iii_c (n : ℕ) :
  ¬ (∀ m : ℕ, (1 - (-1)^n / n.cast : ℝ) ≥ (1 - (-1)^(n+m) / (n+m).cast : ℝ)) :=
begin
  sorry
end

theorem part_iii_d (f : ℕ → ℝ) (hf : ∀ n : ℕ, f n = 1 - (-1)^n / n) :
  ∃ r : ℝ, tendsto f at_top (𝓝 r) :=
begin
  sorry
end

theorem part_iv_a :
  ∀ m : ℕ, ∃ N : ℕ, ∀ n ≥ N, abs (5*n - n^2 : ℝ) ≥ m :=
begin
  sorry
end

theorem part_iv_b :
  ¬ (∀ n : ℕ, abs (5*n - n^2 : ℝ) ≤ abs (5*(n+1) - (n+1)^2 : ℝ)) :=
begin
  sorry
end

theorem part_iv_c :
  ¬ (∀ n : ℕ, abs (5*n - n^2 : ℝ) ≥ abs (5*(n+1) - (n+1)^2 : ℝ)) :=
begin
  sorry
end

theorem part_iv_d :
  tendsto (λ n : ℕ, abs (5*n - n^2 : ℝ)) at_top at_top :=
begin
  sorry
end


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

! This file was ported from Lean 3 source module group_theory.specific_groups.quaternion
! leanprover-community/mathlib commit 879155bff5af618b9062cbb2915347dafd749ad6
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Zmod.Basic
import Mathbin.Data.Nat.Basic
import Mathbin.Tactic.IntervalCases
import Mathbin.GroupTheory.SpecificGroups.Dihedral
import Mathbin.GroupTheory.SpecificGroups.Cyclic

/-!
# Quaternion Groups

We define the (generalised) quaternion groups `quaternion_group n` of order `4n`, also known as
dicyclic groups, with elements `a i` and `xa i` for `i : zmod n`. The (generalised) quaternion
groups can be defined by the presentation
$\langle a, x | a^{2n} = 1, x^2 = a^n, x^{-1}ax=a^{-1}\rangle$. We write `a i` for
$a^i$ and `xa i` for $x * a^i$. For `n=2` the quaternion group `quaternion_group 2` is isomorphic to
the unit integral quaternions `(quaternion ℤ)ˣ`.

## Main definition

`quaternion_group n`: The (generalised) quaternion group of order `4n`.

## Implementation notes

This file is heavily based on `dihedral_group` by Shing Tak Lam.

In mathematics, the name "quaternion group" is reserved for the cases `n ≥ 2`. Since it would be
inconvenient to carry around this condition we define `quaternion_group` also for `n = 0` and
`n = 1`. `quaternion_group 0` is isomorphic to the infinite dihedral group, while
`quaternion_group 1` is isomorphic to a cyclic group of order `4`.

## References

* https://en.wikipedia.org/wiki/Dicyclic_group
* https://en.wikipedia.org/wiki/Quaternion_group

## TODO

Show that `quaternion_group 2 ≃* (quaternion ℤ)ˣ`.

-/

/-- The (generalised) quaternion group `quaternion_group n` of order `4n`. It can be defined by the
presentation $\langle a, x | a^{2n} = 1, x^2 = a^n, x^{-1}ax=a^{-1}\rangle$. We write `a i` for
$a^i$ and `xa i` for $x * a^i$.
-/
inductive QuaternionGroup (n : ℕ) : Type
  | a : ZMod (2 * n) → QuaternionGroup
  | xa : ZMod (2 * n) → QuaternionGroup
  deriving DecidableEq
#align quaternion_group QuaternionGroup

namespace QuaternionGroup

variable {n : ℕ}

/-- Multiplication of the dihedral group.
-/
private def mul : QuaternionGroup n → QuaternionGroup n → QuaternionGroup n
  | a i, a j => a (i + j)
  | a i, xa j => xa (j - i)
  | xa i, a j => xa (i + j)
  | xa i, xa j => a (n + j - i)
#align quaternion_group.mul quaternion_group.mul

/-- The identity `1` is given by `aⁱ`.
-/
private def one : QuaternionGroup n :=
  a 0
#align quaternion_group.one quaternion_group.one

instance : Inhabited (QuaternionGroup n) :=
  ⟨one⟩

/-- The inverse of an element of the quaternion group.
-/
private def inv : QuaternionGroup n → QuaternionGroup n
  | a i => a (-i)
  | xa i => xa (n + i)
#align quaternion_group.inv quaternion_group.inv

/-- The group structure on `quaternion_group n`.
-/
instance : Group (QuaternionGroup n) where
  mul := mul
  mul_assoc := by
    rintro (i | i) (j | j) (k | k) <;> simp only [mul] <;> abel
    simp only [neg_mul, one_mul, Int.cast_one, zsmul_eq_mul, Int.cast_neg, add_right_inj]
    calc
      -(n : ZMod (2 * n)) = 0 - n := by rw [zero_sub]
      _ = 2 * n - n := by
        norm_cast
        simp
      _ = n := by ring

  one := one
  one_mul := by
    rintro (i | i)
    · exact congr_arg a (zero_add i)
    · exact congr_arg xa (sub_zero i)
  mul_one := by
    rintro (i | i)
    · exact congr_arg a (add_zero i)
    · exact congr_arg xa (add_zero i)
  inv := inv
  mul_left_inv := by
    rintro (i | i)
    · exact congr_arg a (neg_add_self i)
    · exact congr_arg a (sub_self (n + i))

variable {n}

@[simp]
theorem a_mul_a (i j : ZMod (2 * n)) : a i * a j = a (i + j) :=
  rfl
#align quaternion_group.a_mul_a QuaternionGroup.a_mul_a

@[simp]
theorem a_mul_xa (i j : ZMod (2 * n)) : a i * xa j = xa (j - i) :=
  rfl
#align quaternion_group.a_mul_xa QuaternionGroup.a_mul_xa

@[simp]
theorem xa_mul_a (i j : ZMod (2 * n)) : xa i * a j = xa (i + j) :=
  rfl
#align quaternion_group.xa_mul_a QuaternionGroup.xa_mul_a

@[simp]
theorem xa_mul_xa (i j : ZMod (2 * n)) : xa i * xa j = a (n + j - i) :=
  rfl
#align quaternion_group.xa_mul_xa QuaternionGroup.xa_mul_xa

theorem one_def : (1 : QuaternionGroup n) = a 0 :=
  rfl
#align quaternion_group.one_def QuaternionGroup.one_def

private def fintype_helper : Sum (ZMod (2 * n)) (ZMod (2 * n)) ≃ QuaternionGroup n
    where
  invFun i :=
    match i with
    | a j => Sum.inl j
    | xa j => Sum.inr j
  toFun i :=
    match i with
    | Sum.inl j => a j
    | Sum.inr j => xa j
  left_inv := by rintro (x | x) <;> rfl
  right_inv := by rintro (x | x) <;> rfl
#align quaternion_group.fintype_helper quaternion_group.fintype_helper

/-- The special case that more or less by definition `quaternion_group 0` is isomorphic to the
infinite dihedral group. -/
def quaternionGroupZeroEquivDihedralGroupZero : QuaternionGroup 0 ≃* DihedralGroup 0
    where
  toFun i := QuaternionGroup.recOn i DihedralGroup.r DihedralGroup.sr
  invFun i :=
    match i with
    | DihedralGroup.r j => a j
    | DihedralGroup.sr j => xa j
  left_inv := by rintro (k | k) <;> rfl
  right_inv := by rintro (k | k) <;> rfl
  map_mul' := by
    rintro (k | k) (l | l) <;>
      · dsimp
        simp
#align quaternion_group.quaternion_group_zero_equiv_dihedral_group_zero QuaternionGroup.quaternionGroupZeroEquivDihedralGroupZero

/-- If `0 < n`, then `quaternion_group n` is a finite group.
-/
instance [NeZero n] : Fintype (QuaternionGroup n) :=
  Fintype.ofEquiv _ fintypeHelper

instance : Nontrivial (QuaternionGroup n) :=
  ⟨⟨a 0, xa 0, by decide⟩⟩

/-- If `0 < n`, then `quaternion_group n` has `4n` elements.
-/
theorem card [NeZero n] : Fintype.card (QuaternionGroup n) = 4 * n :=
  by
  rw [← fintype.card_eq.mpr ⟨fintype_helper⟩, Fintype.card_sum, ZMod.card, two_mul]
  ring
#align quaternion_group.card QuaternionGroup.card

@[simp]
theorem a_one_pow (k : ℕ) : (a 1 : QuaternionGroup n) ^ k = a k :=
  by
  induction' k with k IH
  · rw [Nat.cast_zero]
    rfl
  · rw [pow_succ, IH, a_mul_a]
    congr 1
    norm_cast
    rw [Nat.one_add]
#align quaternion_group.a_one_pow QuaternionGroup.a_one_pow

@[simp]
theorem a_one_pow_n : (a 1 : QuaternionGroup n) ^ (2 * n) = 1 :=
  by
  rw [a_one_pow, one_def]
  congr 1
  exact ZMod.nat_cast_self _
#align quaternion_group.a_one_pow_n QuaternionGroup.a_one_pow_n

@[simp]
theorem xa_sq (i : ZMod (2 * n)) : xa i ^ 2 = a n := by simp [sq]
#align quaternion_group.xa_sq QuaternionGroup.xa_sq

@[simp]
theorem xa_pow_four (i : ZMod (2 * n)) : xa i ^ 4 = 1 :=
  by
  simp only [pow_succ, sq, xa_mul_xa, xa_mul_a, add_sub_cancel, add_sub_assoc, add_sub_cancel',
    sub_self, add_zero]
  norm_cast
  rw [← two_mul]
  simp [one_def]
#align quaternion_group.xa_pow_four QuaternionGroup.xa_pow_four

/-- If `0 < n`, then `xa i` has order 4.
-/
@[simp]
theorem orderOf_xa [NeZero n] (i : ZMod (2 * n)) : orderOf (xa i) = 4 :=
  by
  change _ = 2 ^ 2
  haveI : Fact (Nat.Prime 2) := Fact.mk Nat.prime_two
  apply orderOf_eq_prime_pow
  · intro h
    simp only [pow_one, xa_sq] at h
    injection h with h'
    apply_fun ZMod.val  at h'
    apply_fun (· / n)  at h'
    simp only [ZMod.val_nat_cast, ZMod.val_zero, Nat.zero_div, Nat.mod_mul_left_div_self,
      Nat.div_self (NeZero.pos n)] at h'
    norm_num at h'
  · norm_num
#align quaternion_group.order_of_xa QuaternionGroup.orderOf_xa

/-- In the special case `n = 1`, `quaternion 1` is a cyclic group (of order `4`). -/
theorem quaternionGroup_one_isCyclic : IsCyclic (QuaternionGroup 1) :=
  by
  apply isCyclic_of_orderOf_eq_card
  rw [card, mul_one]
  exact order_of_xa 0
#align quaternion_group.quaternion_group_one_is_cyclic QuaternionGroup.quaternionGroup_one_isCyclic

/-- If `0 < n`, then `a 1` has order `2 * n`.
-/
@[simp]
theorem orderOf_a_one : orderOf (a 1 : QuaternionGroup n) = 2 * n :=
  by
  cases' eq_zero_or_neZero n with hn hn
  · subst hn
    simp_rw [MulZeroClass.mul_zero, orderOf_eq_zero_iff']
    intro n h
    rw [one_def, a_one_pow]
    apply mt a.inj
    haveI : CharZero (ZMod (2 * 0)) := ZMod.charZero
    simpa using h.ne'
  apply
    (Nat.le_of_dvd (NeZero.pos _)
          (orderOf_dvd_of_pow_eq_one (@a_one_pow_n n))).lt_or_eq.resolve_left
  intro h
  have h1 : (a 1 : QuaternionGroup n) ^ orderOf (a 1) = 1 := pow_orderOf_eq_one _
  rw [a_one_pow] at h1
  injection h1 with h2
  rw [← ZMod.val_eq_zero, ZMod.val_nat_cast, Nat.mod_eq_of_lt h] at h2
  exact absurd h2.symm (orderOf_pos _).Ne
#align quaternion_group.order_of_a_one QuaternionGroup.orderOf_a_one

/-- If `0 < n`, then `a i` has order `(2 * n) / gcd (2 * n) i`.
-/
theorem orderOf_a [NeZero n] (i : ZMod (2 * n)) : orderOf (a i) = 2 * n / Nat.gcd (2 * n) i.val :=
  by
  conv_lhs => rw [← ZMod.nat_cast_zmod_val i]
  rw [← a_one_pow, orderOf_pow, order_of_a_one]
#align quaternion_group.order_of_a QuaternionGroup.orderOf_a

theorem exponent : Monoid.exponent (QuaternionGroup n) = 2 * lcm n 2 :=
  by
  rw [← normalize_eq 2, ← lcm_mul_left, normalize_eq]
  norm_num
  cases' eq_zero_or_neZero n with hn hn
  · subst hn
    simp only [lcm_zero_left, MulZeroClass.mul_zero]
    exact Monoid.exponent_eq_zero_of_order_zero order_of_a_one
  apply Nat.dvd_antisymm
  · apply Monoid.exponent_dvd_of_forall_pow_eq_one
    rintro (m | m)
    · rw [← orderOf_dvd_iff_pow_eq_one, order_of_a]
      refine' Nat.dvd_trans ⟨gcd (2 * n) m.val, _⟩ (dvd_lcm_left (2 * n) 4)
      exact (Nat.div_mul_cancel (Nat.gcd_dvd_left (2 * n) m.val)).symm
    · rw [← orderOf_dvd_iff_pow_eq_one, order_of_xa]
      exact dvd_lcm_right (2 * n) 4
  · apply lcm_dvd
    · convert Monoid.order_dvd_exponent (a 1)
      exact order_of_a_one.symm
    · convert Monoid.order_dvd_exponent (xa 0)
      exact (order_of_xa 0).symm
#align quaternion_group.exponent QuaternionGroup.exponent

end QuaternionGroup


macro_rules
  | `(ℕ) => `(Nat)

section ProvingQuestion

open Nat

@[reducible] def natsum : Nat → Nat
  | zero => zero
  | succ n => succ n + natsum n

theorem nat_sum_closed_form : ∀ n : ℕ, (succ (succ zero)) * (natsum n) = n * (succ n) := by
  intro n
  induction n with
    | zero => rfl
    | succ _ ih => rw [Nat.mul_add, ih, ← Nat.add_mul, Nat.mul_comm, Nat.succ_add, Nat.succ_add, Nat.zero_add]

end ProvingQuestion

section ProgrammingQuestion

variable {α : Type _} [LE α] [∀ a b : α, Decidable (a ≤ b)]

@[reducible] def List.isIncreasing : List α → Bool
  | [] => true
  | a :: [] => true
  | a :: b :: tail =>
    if h : a ≤ b then
      isIncreasing (b :: tail)
    else
      false

abbrev IncreasingList (α : Type _) [LE α] [∀ a b : α, Decidable (a ≤ b)] := { l : List α // List.isIncreasing l }

-- splits a list `ℓ` into an initial increasing stretch (possibly empty) and the rest of the list
def firstIncreasingStretch : (ℓ : List α) → {listpair : IncreasingList α × List α // ℓ = listpair.fst ++ listpair.snd}
  | [] => { val := (⟨[], rfl⟩ , []), property := rfl }
  | a :: [] => { val := (⟨[a], rfl⟩, []), property := rfl }
  | a :: b :: tail =>
    if h : a ≤ b then
      match firstIncreasingStretch (b :: tail) with
        | ⟨(⟨lInc, incPrf⟩, lTail), prf⟩ =>
          { val := (⟨a :: lInc, by admit⟩, lTail), property := by simp [prf] }
    else
      { val := (⟨[], rfl⟩, (a :: b :: tail)), property := rfl }

-- iteratively fetches maximal increasing stretches
partial def maximalIncreasingStretches : List α → List (IncreasingList α)
  | [] => []
  | a :: [] => []
  | a :: b :: tail =>
    if a ≤ b then
      match firstIncreasingStretch (a :: b :: tail) with
        | ⟨(lInc, lTail), _⟩ =>
          lInc :: (maximalIncreasingStretches lTail)
    else
      maximalIncreasingStretches (b :: tail)
-- termination_by

section Misc

def IncreasingList.LE (l₁ l₂ : IncreasingList α) := l₁.val.length ≤ l₂.val.length

instance inclLE : LE (IncreasingList α) := ⟨IncreasingList.LE⟩

instance [listDec : ∀ ℓ₁ ℓ₂ : List α, Decidable (ℓ₁.length ≤ ℓ₂.length)]
: ∀ l₁ l₂ : IncreasingList α, Decidable (l₁ ≤ l₂) := λ l₁ l₂ => by apply listDec

class Zero (α : Type _) where
  zero : α

instance : Zero Nat := ⟨Nat.zero⟩

instance : Zero Int := ⟨(0 : Int)⟩

def List.sum {α : Type _} [Add α] [Zero α] : List α → α :=
  List.foldl Add.add Zero.zero

prefix:100 "[∑]" => List.sum

class Min (α : Type _) where
  min : α

instance {α : Type _} : Min (List α) := ⟨List.nil⟩

instance : Min (IncreasingList α) := ⟨⟨[], rfl⟩⟩

def List.min {α : Type _} [LE α] [∀ a b : α, Decidable (a ≤ b)] [Min α] : List α → α :=
  List.foldl (λ a b => if a ≤ b then a else b) Min.min

def List.max {α : Type _} [LE α] [∀ a b : α, Decidable (a ≤ b)] [Min α] : List α → α :=
  List.foldl (λ a b => if b ≤ a then a else b) Min.min

end Misc

def ConsecutiveIncreasing : List Nat → Bool
  | [] => false
  | [a] => false
  | [a, b] => a ≤ b
  | a :: b :: tail =>
    if (b = Nat.succ a) then
      ConsecutiveIncreasing (b :: tail)
    else
      false

def LongestIncreasingStretchSum : List Nat → Nat :=
  λ l =>
  List.sum $ Subtype.val $ List.max $ (List.filter (ConsecutiveIncreasing ∘ Subtype.val) $ maximalIncreasingStretches l)

end ProgrammingQuestion


import .indep

noncomputable theory
open_locale classical
-- open_locale big_operators

open set

variables {E : Type*} [finite E] {M : matroid E} {B X Y X' Y' Z I J : set E} {e f x y z : E}

namespace matroid

/-- The rank function of a matroid. This is defined using `ncard`, to avoid a fintype instance
  so as not to carry around data (it has the junk value `0` if `X` is infinite) -/
noncomputable def r {E : Type*} (M : matroid E) : set E → ℕ :=
  λ X, nat.find_greatest (λ n, ∃ I, I ⊆ X ∧ M.indep I ∧ n = I.ncard) X.ncard

/-- The rank `M.rk` of a matroid `M` is the rank of its ground set -/
@[reducible] noncomputable def rk (M : matroid E) := M.r univ

lemma rk_def (M : matroid E) :
  M.rk = M.r univ :=
rfl

/-- This is the useful definition of rank -/
lemma eq_r_iff {n : ℕ} : M.r X = n ↔ ∃ I, M.basis I X ∧ I.ncard = n :=
begin
  simp_rw [matroid.r, nat.find_greatest_eq_iff, ne.def, ←or_iff_not_imp_left, not_exists], push_neg,
  split,
  { rintros ⟨hnX, rfl | ⟨I, hIX, hI, rfl⟩, h⟩,
    { simp_rw [pos_iff_ne_zero, ←or_iff_not_imp_left] at h,
      obtain ⟨I, hI⟩ := M.exists_basis X,
      exact ⟨I, hI, (@h I.ncard).elim id
        (λ h', false.elim (h' (ncard_le_of_subset hI.subset) _ hI.subset hI.indep rfl))⟩},
    refine ⟨I, ⟨hI, hIX, λ J hJ hIJ hJX,
      (eq_or_ssubset_of_subset hIJ).elim id (λ hIssJ, false.elim _)⟩, rfl⟩,
    exact h (ncard_lt_ncard hIssJ) (ncard_mono hJX) J hJX hJ rfl},
  rintros ⟨I, ⟨hIX, rfl⟩⟩,
  refine ⟨ncard_mono (by simpa using hIX.subset),or.inr ⟨I,hIX.subset,hIX.indep,rfl⟩,_⟩,
  rintro n hIn hnX J hJX hJ rfl,
  exact hIn.not_le (hJ.le_card_basis hJX hIX),
end

lemma le_r_iff {X : set E} {n : ℕ} : n ≤ M.r X ↔ ∃ I, M.indep I ∧ I ⊆ X ∧ I.ncard = n :=
begin
  obtain ⟨J, hJ⟩ := eq_r_iff.mp (@rfl _ (M.r X)),
  refine ⟨λ h, _, λ h, _⟩,
  { obtain ⟨I', hI', rfl⟩ := exists_smaller_set _ _ (h.trans_eq hJ.2.symm),
    exact ⟨I', hJ.1.indep.subset hI', hI'.trans hJ.1.subset, by simp⟩},
  obtain ⟨I, hI, hIX, rfl⟩ := h,
  rw ←hJ.2,
  exact hI.le_card_basis hIX hJ.1,
end

lemma r_le_iff {X : set E} {n : ℕ} :
  M.r X ≤ n ↔ (∀ I, M.indep I → I ⊆ X → I.ncard ≤ n) :=
begin
  obtain ⟨I, hIX, hI⟩ := eq_r_iff.mp (@rfl _ (M.r X)),
  refine ⟨λ h J hJ hJX, (hJ.le_card_basis hJX hIX).trans (by rwa hI), λ h, _⟩,
  have := h I hIX.indep hIX.subset, rwa ←hI,
end

lemma r_mono (M : matroid E) {X Y : set E} (hXY : X ⊆ Y) :
  M.r X ≤ M.r Y :=
by {simp_rw [r_le_iff, le_r_iff], exact λ I hI hIX, ⟨I,hI,hIX.trans hXY,rfl⟩}

lemma basis.card (hIX : M.basis I X) :
  I.ncard = M.r X :=
by {rw [eq_comm, eq_r_iff], exact ⟨_, hIX, rfl⟩}

lemma indep.r (hI : M.indep I) :
  M.r I = I.ncard :=
eq_r_iff.mpr ⟨I, ⟨hI, subset_refl _, λ _ _, subset_antisymm⟩, rfl⟩

lemma basis.r (hIX : M.basis I X) :
  M.r I = M.r X :=
by rw [←hIX.card, hIX.indep.r]

lemma base.r (hB : M.base B) :
  M.r B = M.rk :=
by {rw base_iff_basis_univ at hB, rw hB.r}

lemma base.card (hB : M.base B) :
  B.ncard = M.rk :=
by {rw base_iff_basis_univ at hB, rw hB.card}

lemma indep_iff_r_eq_card :
  M.indep I ↔ M.r I = I.ncard :=
begin
  refine ⟨indep.r ,λ h, _⟩,
  obtain ⟨J, hJ, hJI, hJcard⟩ := le_r_iff.mp h.symm.le,
  suffices hIJ : J = I, rwa ←hIJ,
  exact eq_of_subset_of_ncard_le hJI hJcard.symm.le,
end

lemma basis_iff_indep_card :
  M.basis I X ↔ M.indep I ∧ I ⊆ X ∧ I.ncard = M.r X :=
begin
  refine ⟨λ hI, ⟨hI.indep, hI.subset, hI.card⟩, _⟩,
  rintro ⟨hI, hIX, hIcard⟩,
  obtain ⟨I', hII', hI'X⟩ := hI.subset_basis_of_subset hIX,
  rw [eq_comm, ←hI.r] at hIcard,
  have h := ((M.r_mono hI'X.subset).trans_eq hIcard).antisymm (M.r_mono hII'),
  rw [hI.r, hI'X.indep.r] at h,
  rwa [eq_of_subset_of_ncard_le hII' h.le],
end

@[simp] lemma r_empty (M : matroid E) :
  M.r ∅ = 0 :=
by rw [M.empty_indep.r, ncard_empty]

lemma r_le_card (M : matroid E) (X : set E) :
  M.r X ≤ X.ncard :=
r_le_iff.mpr (λ I hI, ncard_le_of_subset)

lemma rk_le_card (M : matroid E) :
  M.rk ≤ nat.card E :=
by {rw [←ncard_univ], exact M.r_le_card univ}

lemma r_lt_card_of_dep (hX : ¬ M.indep X) :
  M.r X < X.ncard :=
lt_of_le_of_ne (M.r_le_card X) (by rwa indep_iff_r_eq_card at hX)

lemma r_lt_card_iff_dep :
  M.r X < X.ncard ↔ ¬M.indep X :=
⟨λ h hI, (h.ne hI.r),r_lt_card_of_dep⟩

lemma r_le_rk (M : matroid E) (X : set E) :
  M.r X ≤ M.rk :=
M.r_mono (subset_univ _)

lemma indep.card_le_rk (hI : M.indep I) :
  I.ncard ≤ M.rk :=
by {rw [←hI.r], exact M.r_mono (subset_univ I)}

lemma base_iff_indep_r :
  M.base B ↔ M.indep B ∧ M.r B = M.rk :=
begin
  refine ⟨λ h, ⟨h.indep, h.r⟩, λ h, base_iff_maximal_indep.mpr ⟨h.1, λ I hI hBI, _⟩⟩,
  refine eq_of_le_of_not_lt hBI (λ hBI' : B ⊂ I, _),
  cases h with hB hB',
  rw [hB.r] at hB',
  have := ncard_lt_ncard hBI',
  rw [←hI.r, hB'] at this,
  exact (M.r_mono (subset_univ _)).not_lt this,
end

lemma base_iff_indep_card :
  M.base B ↔ M.indep B ∧ B.ncard = M.rk :=
⟨λ h, ⟨h.indep, by rw ←h.card⟩, λ h, base_iff_indep_r.mpr ⟨h.1, by rw [←h.2, ←h.1.r]⟩⟩

lemma indep.base_of_rk_le_card (hI : M.indep I) (h : M.rk ≤ I.ncard) :
  M.base I :=
base_iff_indep_card.mpr ⟨hI, h.antisymm' (by {rw ←hI.r, apply r_le_rk})⟩

lemma basis.r_eq_r_union (hIX : M.basis I X) (Y : set E) :
  M.r (I ∪ Y) = M.r (X ∪ Y) :=
begin
  refine (M.r_mono (union_subset_union_left _ hIX.subset)).antisymm _,
  obtain ⟨I', hII', hI'⟩ :=
    hIX.indep.subset_basis_of_subset (hIX.subset.trans (subset_union_left _ Y)),
  rw [←hI'.r],
  refine M.r_mono (λ z hz, by_contra (λ hz', _)),
  rw [mem_union, decidable.not_or_iff_and_not] at hz',
  have hzX : z ∈ X, {cases (mem_of_mem_of_subset hz hI'.subset); tauto},

  have := hIX.eq_of_subset_indep
    (hI'.indep.subset (insert_subset.mpr ⟨hz,hII'⟩))
    (subset_insert z I) (insert_subset.mpr ⟨hzX, hIX.subset⟩),
  rw [eq_comm, insert_eq_self] at this,
  exact hz'.1 this,
end

lemma basis.r_eq_r_insert (hIX : M.basis I X) (e : E) :
  M.r (insert e I) = M.r (insert e X) :=
by simp_rw [←union_singleton, hIX.r_eq_r_union]

lemma indep.basis_of_subset_of_r_le (hI : M.indep I) (hIX : I ⊆ X) (h : M.r X ≤ M.r I) :
  M.basis I X :=
begin
  refine ⟨hI, hIX, λ J hJ hIJ hJX, eq_of_subset_of_ncard_le hIJ _⟩,
  rw [←hI.r, ←hJ.r],
  exact (M.r_mono hJX).trans h,
end

/-- The submodularity axiom for the rank function -/
lemma r_inter_add_r_union_le_r_add_r (M : matroid E) (X Y : set E) :
  M.r (X ∩ Y) + M.r (X ∪ Y) ≤ M.r X + M.r Y :=
begin
  obtain ⟨Ii, hIi⟩ := M.exists_basis (X ∩ Y),
  obtain ⟨IX, hIX, hIX'⟩ :=
    hIi.indep.subset_basis_of_subset (hIi.subset.trans (inter_subset_left _ _)),
  obtain ⟨IY, hIY, hIY'⟩ :=
    hIi.indep.subset_basis_of_subset (hIi.subset.trans (inter_subset_right _ _)),
  rw [←hIX'.r_eq_r_union, union_comm, ←hIY'.r_eq_r_union, ←hIi.card, ←hIX'.card, ←hIY'.card,
    union_comm, ←ncard_union_add_ncard_inter, add_comm],
  exact add_le_add (M.r_le_card _) (ncard_mono (subset_inter hIX hIY)),
end

lemma eq_of_r_eq_r_forall {M₁ M₂ : matroid E} (h : ∀ X, M₁.r X = M₂.r X) :
  M₁ = M₂ :=
eq_of_indep_iff_indep_forall (λ I, by simp_rw [indep_iff_r_eq_card,h I])

lemma r_le_r_of_subset (M : matroid E) (hXY : X ⊆ Y) :
  M.r X ≤ M.r Y :=
M.r_mono hXY

lemma r_submod (M : matroid E) (X Y : set E) :
  M.r (X ∪ Y) + M.r (X ∩ Y) ≤ M.r X + M.r Y :=
by {rw add_comm, exact M.r_inter_add_r_union_le_r_add_r X Y}

lemma r_submod' (M : matroid E) (X Y : set E) :
  M.r (X ∩ Y) + M.r (X ∪ Y) ≤ M.r X + M.r Y :=
M.r_inter_add_r_union_le_r_add_r _ _

lemma r_inter_left_le_r (M : matroid E) (X Y : set E) :
  M.r (X ∩ Y) ≤ M.r X :=
M.r_mono (inter_subset_left X Y)

lemma r_inter_right_le_r (M : matroid E) (X Y : set E) :
  M.r (X ∩ Y) ≤ M.r Y :=
M.r_mono (inter_subset_right X Y)

lemma r_le_r_union_left (M : matroid E) (X Y : set E) :
  M.r X ≤ M.r (X ∪ Y) :=
M.r_mono (subset_union_left X Y)

lemma r_le_r_union_right (M : matroid E) (X Y : set E) :
  M.r Y ≤ M.r (X ∪ Y) :=
M.r_mono (subset_union_right X Y)

lemma r_diff_le_r (M : matroid E) (X Y : set E) :
  M.r (X \ Y) ≤ M.r X :=
by {rw diff_eq, apply r_inter_left_le_r}

lemma r_zero_of_subset_r_zero (hXY : X ⊆ Y) (hY : M.r Y = 0) :
  M.r X = 0 :=
nat.eq_zero_of_le_zero ((M.r_mono hXY).trans_eq hY)

lemma r_zero_of_inter_r_zero (X : set E) :
  M.r Y = 0 → M.r (X ∩ Y) = 0 :=
λ hY, by {apply r_zero_of_subset_r_zero _ hY, simp }

lemma r_lt_card_iff_not_indep :
  (M.r X < X.ncard) ↔ ¬M.indep X :=
begin
  rw [lt_iff_not_le, not_iff_not, indep_iff_r_eq_card],
  exact ⟨(M.r_le_card X).antisymm, λ h, by rw h⟩,
end

lemma nonempty_of_r_lt_card (hX : M.r X < X.ncard) :
  X.nonempty :=
by {rw r_lt_card_iff_not_indep at hX, rw nonempty_iff_ne_empty, rintro rfl, exact hX M.empty_indep}

lemma nonempty_of_r_nonzero (hX : M.r X ≠ 0):
  X.nonempty :=
by {rw nonempty_iff_ne_empty, rintro rfl, exact hX M.r_empty}

lemma r_single_ub (M : matroid E) (e : E) :
  M.r {e} ≤ 1 :=
by {convert M.r_le_card _, simp}

lemma r_le_univ (M : matroid E) (X : set E) :
  M.r X ≤ M.r univ :=
M.r_mono (subset_univ X)

lemma r_compl_univ (M : matroid E) :
  M.r (univᶜ) = 0 :=
by rw [compl_univ, r_empty]

lemma r_eq_r_of_subset_le (hXY : X ⊆ Y) (hYX : M.r Y ≤ M.r X) :
  M.r X = M.r Y :=
(M.r_mono hXY).antisymm hYX

lemma r_eq_of_r_union_le (hle : M.r (X ∪ Y) ≤ M.r X):
  M.r (X ∪ Y) = M.r X :=
((r_eq_r_of_subset_le ((subset_union_left _ _))) hle).symm

lemma r_eq_of_r_le_inter (hle : M.r X ≤ M.r (X ∩ Y)):
   M.r (X ∩ Y) = M.r X :=
(r_eq_r_of_subset_le (inter_subset_left _ _) hle)

-- lemma r_eq_of_not_lt_supset :
--   X ⊆ Y → ¬(M.r X < M.r Y) → M.r X = M.r Y :=
-- λ h h', r_eq_of_le_supset h (int.le_of_not_gt' h')

-- lemma r_eq_of_not_lt_union :
--   ¬ (M.r X < M.r (X ∪ Y)) → M.r (X ∪ Y) = M.r X :=
-- λ h', r_eq_of_le_union (int.le_of_not_gt' h')

lemma r_eq_r_union_r_zero (X : set E) (hY : M.r Y = 0) :
  M.r (X ∪ Y) = M.r X :=
r_eq_of_r_union_le (by linarith [M.r_submod X Y])

lemma r_eq_r_diff_r_zero (X : set E) (hY : M.r Y = 0) :
  M.r (X \ Y) = M.r X :=
begin
  refine le_antisymm (r_diff_le_r _ _ _) _,
  rw ←r_eq_r_union_r_zero (X \ Y) hY,
   exact r_mono _ (λ x hx, by {rw [mem_union, mem_diff], tauto,}),
end

lemma r_zero_of_union_r_zero (hX : M.r X = 0) (hY : M.r Y = 0):
  M.r (X ∪ Y) = 0 :=
by rwa (r_eq_r_union_r_zero _ hY)

lemma r_union_eq_of_subset_of_r_eq (Z : set E) (hXY : X ⊆ Y) (hr : M.r X = M.r Y):
  M.r (X ∪ Z) = M.r (Y ∪ Z) :=
begin
  apply r_eq_r_of_subset_le (union_subset_union_left Z hXY),
  have : M.r ((X ∪ Z) ∩ Y) = _ := by rw [inter_distrib_right, inter_eq_left_iff_subset.mpr hXY] ,
  have : M.r ((X ∪ Z) ∪ Y) = _ := by rw [union_assoc, union_comm Z Y, ←union_assoc,
                                      union_eq_right_iff_subset.mpr hXY ],
  linarith [M.r_submod (X ∪ Z) Y , M.r_le_r_union_left X (Z ∩ Y) ],
end

lemma r_union_eq_of_subset_of_r_eqs (hX : X ⊆ X') (hY : Y ⊆ Y')
(hXX' : M.r X = M.r X') (hYY' : M.r Y = M.r Y') :
  M.r (X ∪ Y) = M.r (X' ∪ Y') :=
by rw [r_union_eq_of_subset_of_r_eq Y hX hXX', union_comm, union_comm _ Y',
       r_union_eq_of_subset_of_r_eq _ hY hYY']

lemma r_eq_of_inter_union (X Y A : set E) :
  M.r (X ∩ A) = M.r X → M.r ((X ∩ A) ∪ Y) = M.r (X ∪ Y) :=
λ h, r_union_eq_of_subset_of_r_eq _ (inter_subset_left _ _) h

lemma r_eq_of_union_r_diff_eq (Z : set E) (hX : M.r (X \ Y) = M.r X) :
  M.r (Z ∪ (X \ Y)) = M.r (Z ∪ X) :=
by {rw diff_eq at *, rw [union_comm _ X, ← r_eq_of_inter_union _ Z _ hX, union_comm Z]}

lemma r_union_le_add_r (M : matroid E) (X Y : set E) :
  M.r (X ∪ Y) ≤ M.r X + M.r Y :=
by linarith [M.r_submod X Y]

lemma r_union_le_card_add_r (M : matroid E) (X Y : set E) :
  M.r (X ∪ Y) ≤ X.ncard + M.r Y :=
(M.r_union_le_add_r X Y).trans (add_le_add_right (M.r_le_card _) _)

lemma r_union_le_r_add_card (M : matroid E) (X Y : set E) :
  M.r (X ∪ Y) ≤ M.r X + Y.ncard :=
(M.r_union_le_add_r X Y).trans (add_le_add_left (M.r_le_card _) _)

lemma rk_le_card_add_r_compl (M : matroid E) (X : set E) :
  M.rk ≤ X.ncard + M.r Xᶜ :=
begin
  rw [rk_def, ←union_compl_self X],
  exact (M.r_union_le_add_r _ _).trans (add_le_add_right (M.r_le_card _) _),
end

lemma rank_eq_of_le_supset (h : X ⊆ Y) (hr : M.r Y ≤ M.r X) :
  M.r X = M.r Y :=
hr.antisymm' (M.r_mono h)

lemma rank_eq_of_le_union :
  M.r (X ∪ Y) ≤ M.r X → M.r (X ∪ Y) = M.r X :=
λ h, ((rank_eq_of_le_supset ((subset_union_left _ _))) h).symm

lemma rank_eq_of_le_inter :
  M.r X ≤ M.r (X ∩ Y) →  M.r (X ∩ Y) = M.r X :=
λ h, (rank_eq_of_le_supset (inter_subset_left _ _) h)

/- Probably `finsum` is fight for this  -/

-- lemma r_union_le_add_r_sUnion (M : matroid E) (S : finset (set E)) :
--   M.r (S.bUnion id) ≤ ∑ x in s, f x :=
-- begin
--   set P := λ (S : set (set E)), M.r (⋃₀ S) ≤ ∑ᶠ X in S, M.r X with hP,
--   refine induction_set_size_insert P (by {rw hP, simp}) (λ X A hA hX, _) _,
--   rw [hP, sUnion_insert, fin.finsum_in_insert _ hA],
--   exact le_trans (r_union_le_add_r M _ _) (int.add_le_add_left hX _),
-- end

lemma r_le_r_insert (M : matroid E) (X : set E) (e : E) :
  M.r X ≤ M.r (insert e X) :=
M.r_mono (subset_insert _ _)

lemma r_insert_le_add_one (M : matroid E) (X : set E) (e : E) :
  M.r (insert e X) ≤ M.r X + 1 :=
by {rw ←union_singleton, linarith [r_union_le_add_r M X {e}, r_single_ub M e]}

lemma r_insert_eq_add_one_of_r_ne (h : M.r (insert e X) ≠ M.r X):
  M.r (insert e X) = M.r X + 1 :=
(r_insert_le_add_one M X e).antisymm
  (nat.add_one_le_iff.mpr ((M.r_mono (subset_insert _ _)).lt_of_ne h.symm))

lemma r_eq_of_le_insert (h : M.r (insert e X) ≤ M.r X):
  M.r (insert e X) = M.r X :=
by {rw ←union_singleton at *, exact le_antisymm h (r_le_r_union_left _ _ _) }

lemma r_le_r_add_r_diff (M : matroid E) (X Y : set E) :
  M.r Y ≤ M.r X + M.r (Y \ X) :=
le_trans (M.r_mono (by simp)) (r_union_le_add_r M X (Y \ X))

lemma r_le_r_diff_singleton_add_one (M : matroid E) (X : set E) (e : E) :
  M.r X ≤ M.r (X \ {e}) + 1 :=
by linarith [r_le_r_add_r_diff M {e} X, r_single_ub M e]

lemma r_diff_singleton_add_one_eq_r_of_ne (h_ne : M.r X ≠ M.r (X \ {e})) :
  M.r (X \ {e}) + 1 = M.r X :=
(nat.add_one_le_iff.mpr (lt_of_le_of_ne (M.r_diff_le_r X {e}) h_ne.symm)).antisymm
    (M.r_le_r_diff_singleton_add_one _ _)

lemma r_le_r_add_card_diff_of_subset (M : matroid E) (hXY : X ⊆ Y) :
  M.r Y ≤ M.r X + (Y \ X).ncard :=
(M.r_le_r_add_r_diff X Y).trans (add_le_add_left (by convert M.r_le_card (Y \ X)) _)

lemma r_add_card_le_r_add_card_of_subset (M : matroid E) (hXY : X ⊆ Y) :
  M.r Y + X.ncard ≤ M.r X + Y.ncard :=
begin
  have := M.r_le_r_add_card_diff_of_subset hXY,
  linarith [ncard_diff_add_ncard_eq_ncard hXY],
end

lemma submod_three (M : matroid E) (X Y Y' : set E) :
  M.r (X ∪ (Y ∪ Y')) + M.r (X ∪ (Y ∩ Y')) ≤ M.r (X ∪ Y) + M.r (X ∪ Y') :=
begin
  have := M.r_submod (X ∪ Y) (X ∪ Y'),
  rwa [←union_distrib_left, ←union_union_distrib_left] at this,
end

lemma submod_three_right (M : matroid E) (X Y Y' : set E) :
  M.r ((Y ∪ Y') ∪ X) + M.r ((Y ∩ Y') ∪ X) ≤ M.r (Y ∪ X) + M.r (Y' ∪ X) :=
by {simp_rw ←(union_comm X), apply submod_three}

lemma submod_three_disj (M : matroid E) (X Y Y' : set E) (hYY' : Y ∩ Y' = ∅) :
  M.r (X ∪ (Y ∪ Y')) + M.r (X) ≤ M.r (X ∪ Y) + M.r (X ∪ Y') :=
by {have := submod_three M X Y Y', rwa [hYY', union_empty] at this}

theorem r_augment (h : M.r X < M.r Z) :
  ∃ z ∈ Z, M.r X < M.r (insert z X) :=
begin
  obtain ⟨I, hI⟩ := M.exists_basis X,
  obtain ⟨J, hIJ, hJ⟩ := hI.indep.subset_basis_of_subset (hI.subset.trans (subset_union_left X Z)),
  have hXZ := h.trans_le (M.r_mono (subset_union_right X Z)),

  rw [←hI.card, ←hJ.card] at hXZ,
  obtain ⟨e,heJ,heI⟩ := exists_mem_not_mem_of_ncard_lt_ncard hXZ,

  have hlt : M.r X < M.r (insert e X),
  { refine lt_of_lt_of_le _ (M.r_mono (@insert_subset_insert _ e _ _ hI.subset)),
    rw [←hI.card, (hJ.indep.subset (insert_subset.mpr ⟨heJ,hIJ⟩)).r, ncard_insert_of_not_mem heI,
      nat.lt_iff_add_one_le]},
  have heX : e ∉ X,
  { refine λ heX, hlt.ne _, rw [insert_eq_of_mem heX], },
  have heZ : e ∈ Z,
    from or.resolve_left (hJ.subset heJ) heX,
  exact ⟨e,heZ,hlt⟩,
end

lemma r_union_eq_of_r_union_subset_le (hXY : X ⊆ Y) (h : M.r (X ∪ Z) ≤ M.r X) :
  M.r (Y ∪ Z) = M.r Y :=
begin
  have hsm := M.r_submod Y (X ∪ Z),
  rw [←union_assoc, union_eq_left_iff_subset.mpr hXY, inter_distrib_left,
    inter_eq_right_iff_subset.mpr hXY] at hsm,
  linarith [M.r_le_r_union_left X (Y ∩ Z), M.r_le_r_union_left Y Z],
end

lemma r_insert_eq_of_r_insert_subset_le (hXY : X ⊆ Y) (h : M.r (insert e X) ≤ M.r X) :
  M.r (insert e Y) = M.r Y :=
by {rw [←union_singleton] at *, rw [r_union_eq_of_r_union_subset_le hXY h],}

lemma r_eq_of_r_all_insert_le (hXY : X ⊆ Y) (hY : ∀ e ∈ Y, M.r (insert e X) ≤ M.r X) :
   M.r X = M.r Y :=
begin
  refine (M.r_mono hXY).antisymm (le_of_not_lt (λ hlt, _)),
  obtain ⟨e,he,hlt'⟩ := r_augment hlt,
  exact hlt'.not_le (hY _ he),
end

lemma r_union_eq_of_r_all_insert_le (hY : ∀ e ∈ Y, M.r (insert e X) ≤ M.r X) :
  M.r (X ∪ Y) = M.r X :=
begin
  refine (r_eq_of_r_all_insert_le (subset_union_left X Y) _).symm,
  rintro e (heX | heY),
  { rw [insert_eq_of_mem heX]},
  exact hY _ heY,
end

lemma r_eq_of_r_all_insert_eq (hXY : X ⊆ Y) (hY : ∀ e ∈ Y, M.r X = M.r (insert e X)) :
   M.r X = M.r Y :=
r_eq_of_r_all_insert_le hXY (λ e h, (hY e h).symm.le)

lemma r_eq_zero_of_loopy (he : (∀ e ∈ X, M.r {e} = 0)) :
  M.r X = 0 :=
begin
  rw [←M.r_empty, eq_comm],
  exact r_eq_of_r_all_insert_eq (empty_subset _)
    (λ e heX, by {rw [M.r_empty, eq_comm, insert_emptyc_eq], exact he e heX}),
end

lemma indep_inter_r_zero_eq_empty (hI : M.indep I) (hX : M.r X = 0) :
   I ∩ X = ∅ :=
begin
  have h := hI.subset (inter_subset_left _ X),
  rwa [indep_iff_r_eq_card, r_zero_of_subset_r_zero (inter_subset_right _ _) hX, eq_comm,
    ncard_eq_zero] at h,
end

lemma base_iff_indep_card_eq_r :
  M.base B ↔ M.indep B ∧ B.ncard = M.rk :=
begin
  refine ⟨λ hB, ⟨hB.indep, hB.card⟩ ,
    λ h, base_iff_maximal_indep.mpr ⟨h.1, λ I hI hBI, eq_of_subset_of_ncard_le hBI _⟩⟩,
  rw [h.2], exact hI.card_le_rk,
end

/- Nullity -/

/-- The nullity of a set is its cardinality minus its rank. Maybe not needed... -/
def nullity (M : matroid E) (X : set E) : ℕ :=
  X.ncard - M.r X

lemma nullity_add_rank_eq (M : matroid E) (X : set E) :
  M.nullity X + M.r X = X.ncard :=
by rw [nullity, tsub_add_cancel_of_le (M.r_le_card X)]

lemma cast_nullity (M : matroid E) (X : set E) :
  (M.nullity X : ℤ) = X.ncard - M.r X :=
by rw [←M.nullity_add_rank_eq, nat.cast_add, add_tsub_cancel_right]

lemma nullity_supermod (X Y : set E) :
  M.nullity X + M.nullity Y ≤ M.nullity (X ∩ Y) + M.nullity (X ∪ Y) :=
begin
  zify,
  simp_rw [cast_nullity],
  linarith [M.r_submod X Y, ncard_inter_add_ncard_union X Y],
end

lemma nullity_le_card (M : matroid E) (X : set E) :
  M.nullity X ≤ X.ncard :=
nat.sub_le _ _

lemma nullity_mono (hXY : X ⊆ Y) :
  M.nullity X ≤ M.nullity Y :=
by {zify, simp_rw [cast_nullity], linarith [M.r_add_card_le_r_add_card_of_subset hXY]}

/- -/

end matroid

section from_axioms

lemma r_eq_card_of_subset_of_r_le_card_submod
(r : set E → ℕ) (r_le_card : ∀ X, r X ≤ X.ncard)
(r_submod : ∀ X Y, r (X ∩ Y) + r (X ∪ Y) ≤ r X + r Y)
{I J : set E} (hIJ : I ⊆ J) (hJ : r J = J.ncard) :
  r I = I.ncard :=
begin
  refine le_antisymm (r_le_card I) _,
  have rdiff := r_le_card (J \ I),

  have h := r_submod I (J \ I),
  have r_empt : r ∅ = 0, simpa using ((r_le_card ∅).antisymm (by simp)),
  rw [inter_diff_self, r_empt, zero_add, union_diff_cancel hIJ, hJ] at h,
  have := ncard_diff_add_ncard_eq_ncard hIJ,
  linarith,
end

lemma extend_to_basis_of_r (r : set E → ℕ) (r_le_card : ∀ X, r X ≤ X.ncard)
(r_mono : ∀ X Y, X ⊆ Y → r X ≤ r Y) (r_submod : ∀ X Y, r (X ∩ Y) + r (X ∪ Y) ≤ r X + r Y)
(I X : set E) (hI : r I = I.ncard) (hIX : I ⊆ X) :
  ∃ J, I ⊆ J ∧ J ⊆ X ∧ r J = J.ncard ∧ r J = r X :=
begin

  obtain ⟨J, ⟨hIJ, hJX, hJ₀⟩, hJ'⟩ :=
   finite.exists_maximal (λ J, I ⊆ J ∧ J ⊆ X ∧ J.ncard ≤ r J) (⟨I, rfl.subset, hIX, hI.symm.le⟩),
  have hJ := hJ₀.antisymm' (r_le_card _),
  refine ⟨J, hIJ, hJX, hJ, hJX.ssubset_or_eq.elim (λ hJX', _) (congr_arg _)⟩,
  obtain ⟨Y, ⟨hJY,hYX,hYr⟩, hYmax⟩ :=
   finite.exists_maximal (λ Y, J ⊆ Y ∧ Y ⊆ X ∧ r Y ≤ r J) ⟨J, rfl.subset, hJX, rfl.le⟩,
  refine hYX.ssubset_or_eq.elim (λ hYX, false.elim _)
    (by {rintro rfl, exact (r_mono _  _ hJX).antisymm hYr,}),
  obtain ⟨e,heX,heY⟩ := exists_of_ssubset hYX,
  have heJ : e ∉ J := λ heJ, heY (mem_of_mem_of_subset heJ hJY),
  have hsm := r_submod (J ∪ {e}) Y,

  rw [inter_distrib_right, singleton_inter_eq_empty.mpr heY, union_empty,
    inter_eq_self_of_subset_left hJY, union_right_comm, union_eq_self_of_subset_left hJY] at hsm,

  have hYe : r Y < r (Y ∪ {e}),
  { rw [lt_iff_not_le],
    intro hYe,
    rw  hYmax (Y ∪ {e})
     ⟨hJY.trans (subset_union_left _ _),union_subset hYX.subset (singleton_subset_iff.mpr heX),
     (hYe.trans hYr)⟩ (subset_union_left _ _) at heY,
    simpa using heY},
  have hJe : r (J ∪ {e}) ≤ r J,
  { refine le_of_not_lt (λ h',  h'.ne _),
    rw ←(hJ' (J ∪ {e}) ⟨subset_union_of_subset_left hIJ _,union_subset hJX (by simpa),_⟩
      (subset_union_left _ _)),
    rwa [union_singleton, ncard_insert_of_not_mem heJ, nat.add_one_le_iff, ←hJ, ←union_singleton]},
  linarith,
end

/-- A function `r` satisfying the rank axioms determines a matroid -/
def matroid_of_r (r : set E → ℕ) (r_le_card : ∀ X, r X ≤ X.ncard)
(r_mono : ∀ X Y, X ⊆ Y → r X ≤ r Y) (r_submod : ∀ X Y, r (X ∩ Y) + r (X ∪ Y) ≤ r X + r Y) :
  matroid E :=
matroid_of_indep (λ I, r I = I.ncard)
⟨∅, (r_le_card _).antisymm (by simp)⟩
(λ _ _, r_eq_card_of_subset_of_r_le_card_submod r r_le_card r_submod)
(begin
  intros I J hI hJ hIJ,
  obtain ⟨K,hIK, hKIJ, hK, hrK⟩ :=
   extend_to_basis_of_r r r_le_card r_mono r_submod _ _ hI (subset_union_left _ J),
  refine (ssubset_or_eq_of_subset hIK).elim (λ hss, _) _,
  { refine (exists_of_ssubset hss).imp _,
    rintro e ⟨heK,heI⟩,
    have heJ : e ∈ J, { by_contra, cases (hKIJ heK); tauto },
    refine ⟨heJ, heI, _⟩,
    exact r_eq_card_of_subset_of_r_le_card_submod r r_le_card r_submod
      (insert_subset.mpr ⟨heK, hIK⟩) hK},
  rintro rfl,
  simp_rw [←hI, ←hJ, hrK] at hIJ,
  exact (hIJ.not_le (r_mono _ _ (subset_union_right _ _))).elim,
end)

@[simp] lemma matroid_of_r_apply (r : set E → ℕ) (r_le_card : ∀ X, r X ≤ X.ncard)
(r_mono : ∀ X Y, X ⊆ Y → r X ≤ r Y) (r_submod : ∀ X Y, r (X ∩ Y) + r (X ∪ Y) ≤ r X + r Y) :
  (matroid_of_r r r_le_card r_mono r_submod).r = r :=
begin
  ext X,
  simp_rw [matroid_of_r, matroid.eq_r_iff, matroid.basis_iff, matroid_of_indep_apply],
  obtain ⟨I,-,hIX,hI,hIX'⟩ :=
   extend_to_basis_of_r r r_le_card r_mono r_submod ∅ X (by simpa using r_le_card ∅)
    (empty_subset _),
  refine ⟨I, ⟨⟨hI,hIX,λJ hJ hIJ hJX,
    (ssubset_or_eq_of_subset hIJ).elim (λ hIJ',false.elim _) id⟩,
      by rwa [←hIX', eq_comm]⟩⟩,

  have h' := r_mono _ _ hJX,
  have hlt := ncard_lt_ncard hIJ',
  rw [←hI, ←hJ] at hlt,
  linarith,
end

/-- Construction of a matroid from an `int`-valued rank function that is everywhere nonnegative,
  rather than a `nat`-valued one. Useful for defining matroids whose rank function involves
  subtraction. -/
def matroid_of_int_r (r : set E → ℤ) (r_nonneg : ∀ X, 0 ≤ r X) (r_le_card : ∀ X, r X ≤ X.ncard)
(r_mono : ∀ X Y, X ⊆ Y → r X ≤ r Y) (r_submod : ∀ X Y, r (X ∩ Y) + r (X ∪ Y) ≤ r X + r Y) :
matroid E :=
matroid_of_r (int.nat_abs ∘ r)
  (λ X, by {zify, convert r_le_card X, rw abs_eq_self, apply r_nonneg})
  (λ X Y hXY, by {zify, convert r_mono X Y hXY, all_goals {rw abs_eq_self, apply r_nonneg}})
  (λ X Y, by {zify, convert r_submod X Y, all_goals {rw abs_eq_self, apply r_nonneg}})

@[simp] lemma matroid_of_int_r_apply (r : set E → ℤ) (r_nonneg : ∀ X, 0 ≤ r X)
(r_le_card : ∀ X, r X ≤ X.ncard) (r_mono : ∀ X Y, X ⊆ Y → r X ≤ r Y)
(r_submod : ∀ X Y, r (X ∩ Y) + r (X ∪ Y) ≤ r X + r Y) (X : set E) :
  ((matroid_of_int_r r r_nonneg r_le_card r_mono r_submod).r X : ℤ) = r X :=
by simpa [matroid_of_int_r] using r_nonneg _

end from_axioms


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

! This file was ported from Lean 3 source module combinatorics.hales_jewett
! leanprover-community/mathlib commit 1126441d6bccf98c81214a0780c73d499f6721fe
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Fintype.Option
import Mathlib.Data.Fintype.Pi
import Mathlib.Data.Fintype.Sum
import Mathlib.Algebra.BigOperators.Basic

/-!
# The Hales-Jewett theorem

We prove the Hales-Jewett theorem and deduce Van der Waerden's theorem as a corollary.

The Hales-Jewett theorem is a result in Ramsey theory dealing with *combinatorial lines*. Given
an 'alphabet' `α : Type*` and `a b : α`, an example of a combinatorial line in `α^5` is
`{ (a, x, x, b, x) | x : α }`. See `Combinatorics.Line` for a precise general definition. The
Hales-Jewett theorem states that for any fixed finite types `α` and `κ`, there exists a (potentially
huge) finite type `ι` such that whenever `ι → α` is `κ`-colored (i.e. for any coloring
`C : (ι → α) → κ`), there exists a monochromatic line. We prove the Hales-Jewett theorem using
the idea of *color focusing* and a *product argument*. See the proof of
`Combinatorics.Line.exists_mono_in_high_dimension'` for details.

The version of Van der Waerden's theorem in this file states that whenever a commutative monoid `M`
is finitely colored and `S` is a finite subset, there exists a monochromatic homothetic copy of `S`.
This follows from the Hales-Jewett theorem by considering the map `(ι → S) → M` sending `v`
to `∑ i : ι, v i`, which sends a combinatorial line to a homothetic copy of `S`.

## Main results

- `Combinatorics.Line.exists_mono_in_high_dimension`: the Hales-Jewett theorem.
- `Combinatorics.exists_mono_homothetic_copy`: a generalization of Van der Waerden's theorem.

## Implementation details

For convenience, we work directly with finite types instead of natural numbers. That is, we write
`α, ι, κ` for (finite) types where one might traditionally use natural numbers `n, H, c`. This
allows us to work directly with `α`, `Option α`, `(ι → α) → κ`, and `ι ⊕ ι'` instead of `Fin n`,
`Fin (n+1)`, `Fin (c^(n^H))`, and `Fin (H + H')`.

## Todo

- Prove a finitary version of Van der Waerden's theorem (either by compactness or by modifying the
current proof).

- One could reformulate the proof of Hales-Jewett to give explicit upper bounds on the number of
coordinates needed.

## Tags

combinatorial line, Ramsey theory, arithmetic progession

### References

* https://en.wikipedia.org/wiki/Hales%E2%80%93Jewett_theorem

-/

open Classical

open BigOperators

universe u v

namespace Combinatorics

/-- The type of combinatorial lines. A line `l : Line α ι` in the hypercube `ι → α` defines a
function `α → ι → α` from `α` to the hypercube, such that for each coordinate `i : ι`, the function
`fun x ↦ l x i` is either `id` or constant. We require lines to be nontrivial in the sense that
`fun x ↦ l x i` is `id` for at least one `i`.

Formally, a line is represented by a word `l.idxFun : ι → Option α` which says whether
`fun x ↦ l x i` is `id` (corresponding to `l.idxFun i = none`) or constantly `y` (corresponding to
`l.idxFun i = some y`).

When `α` has size `1` there can be many elements of `Line α ι` defining the same function. -/
structure Line (α ι : Type _) where
  /-- The word representing a combinatorial line. `l.idxfun i = none` means that
  `l x i = x` for all `x` and `l.idxfun i = some y` means that `l x i = y`. -/
  idxFun : ι → Option α
  /-- We require combinatorial lines to be nontrivial in the sense that `fun x ↦ l x i` is `id` for
  at least one coordinate `i`. -/
  proper : ∃ i, idxFun i = none
#align combinatorics.line Combinatorics.Line

namespace Line

-- This lets us treat a line `l : Line α ι` as a function `α → ι → α`.
instance (α ι) : CoeFun (Line α ι) fun _ => α → ι → α :=
  ⟨fun l x i => (l.idxFun i).getD x⟩

/-- A line is monochromatic if all its points are the same color. -/
def IsMono {α ι κ} (C : (ι → α) → κ) (l : Line α ι) : Prop :=
  ∃ c, ∀ x, C (l x) = c
#align combinatorics.line.is_mono Combinatorics.Line.IsMono

/-- The diagonal line. It is the identity at every coordinate. -/
def diagonal (α ι) [Nonempty ι] : Line α ι
    where
  idxFun _ := none
  proper := ⟨Classical.arbitrary ι, rfl⟩
#align combinatorics.line.diagonal Combinatorics.Line.diagonal

instance (α ι) [Nonempty ι] : Inhabited (Line α ι) :=
  ⟨diagonal α ι⟩

/-- The type of lines that are only one color except possibly at their endpoints. -/
structure AlmostMono {α ι κ : Type _} (C : (ι → Option α) → κ) where
  /-- The underlying line of an almost monochromatic line, where the coordinate dimension `α` is
  extended by an additional symbol `none`, thought to be marking the endpoint of the line. -/
  line : Line (Option α) ι
  /-- The main color of an almost monochromatic line. -/
  color : κ
  /-- The proposition that the underlying line of an almost monochromatic line assumes its main
  color except possibly at the endpoints. -/
  has_color : ∀ x : α, C (line (some x)) = color
#align combinatorics.line.almost_mono Combinatorics.Line.AlmostMono

instance {α ι κ : Type _} [Nonempty ι] [Inhabited κ] :
    Inhabited (AlmostMono fun _ : ι → Option α => (default : κ)) :=
  ⟨{  line := default
      color := default
      has_color := fun _ ↦ rfl}⟩

/-- The type of collections of lines such that
- each line is only one color except possibly at its endpoint
- the lines all have the same endpoint
- the colors of the lines are distinct.
Used in the proof `exists_mono_in_high_dimension`. -/
structure ColorFocused {α ι κ : Type _} (C : (ι → Option α) → κ) where
  /-- The underlying multiset of almost monochromatic lines of a color-focused collection. -/
  lines : Multiset (AlmostMono C)
  /-- The common endpoint of the lines in the color-focused collection. -/
  focus : ι → Option α
  /-- The proposition that all lines in a color-focused collection have the same endpoint. -/
  is_focused : ∀ p ∈ lines, p.line none = focus
  /-- The proposition that all lines in a color-focused collection of lines have distinct colors. -/
  distinct_colors : (lines.map AlmostMono.color).Nodup
#align combinatorics.line.color_focused Combinatorics.Line.ColorFocused

instance {α ι κ} (C : (ι → Option α) → κ) : Inhabited (ColorFocused C) := by
  refine' ⟨⟨0, fun _ => none, fun h => _, Multiset.nodup_zero⟩⟩
  simp only [Multiset.not_mem_zero, IsEmpty.forall_iff]

/-- A function `f : α → α'` determines a function `line α ι → line α' ι`. For a coordinate `i`,
`l.map f` is the identity at `i` if `l` is, and constantly `f y` if `l` is constantly `y` at `i`. -/
def map {α α' ι} (f : α → α') (l : Line α ι) : Line α' ι
    where
  idxFun i := (l.idxFun i).map f
  proper := ⟨l.proper.choose, by simp only [l.proper.choose_spec, Option.map_none']⟩
#align combinatorics.line.map Combinatorics.Line.map

/-- A point in `ι → α` and a line in `ι' → α` determine a line in `ι ⊕ ι' → α`. -/
def vertical {α ι ι'} (v : ι → α) (l : Line α ι') : Line α (Sum ι ι')
    where
  idxFun := Sum.elim (some ∘ v) l.idxFun
  proper := ⟨Sum.inr l.proper.choose, l.proper.choose_spec⟩
#align combinatorics.line.vertical Combinatorics.Line.vertical

/-- A line in `ι → α` and a point in `ι' → α` determine a line in `ι ⊕ ι' → α`. -/
def horizontal {α ι ι'} (l : Line α ι) (v : ι' → α) : Line α (Sum ι ι')
    where
  idxFun := Sum.elim l.idxFun (some ∘ v)
  proper := ⟨Sum.inl l.proper.choose, l.proper.choose_spec⟩
#align combinatorics.line.horizontal Combinatorics.Line.horizontal

/-- One line in `ι → α` and one in `ι' → α` together determine a line in `ι ⊕ ι' → α`. -/
def prod {α ι ι'} (l : Line α ι) (l' : Line α ι') : Line α (Sum ι ι')
    where
  idxFun := Sum.elim l.idxFun l'.idxFun
  proper := ⟨Sum.inl l.proper.choose, l.proper.choose_spec⟩
#align combinatorics.line.prod Combinatorics.Line.prod

theorem apply {α ι} (l : Line α ι) (x : α) : l x = fun i => (l.idxFun i).getD x :=
  rfl
#align combinatorics.line.apply Combinatorics.Line.apply

theorem apply_none {α ι} (l : Line α ι) (x : α) (i : ι) (h : l.idxFun i = none) : l x i = x := by
  simp only [Option.getD_none, h, l.apply]
#align combinatorics.line.apply_none Combinatorics.Line.apply_none

theorem apply_of_ne_none {α ι} (l : Line α ι) (x : α) (i : ι) (h : l.idxFun i ≠ none) :
    some (l x i) = l.idxFun i := by rw [l.apply, Option.getD_of_ne_none h]
#align combinatorics.line.apply_of_ne_none Combinatorics.Line.apply_of_ne_none

@[simp]
theorem map_apply {α α' ι} (f : α → α') (l : Line α ι) (x : α) : l.map f (f x) = f ∘ l x := by
  simp only [Line.apply, Line.map, Option.getD_map]
  rfl

#align combinatorics.line.map_apply Combinatorics.Line.map_apply

@[simp]
theorem vertical_apply {α ι ι'} (v : ι → α) (l : Line α ι') (x : α) :
    l.vertical v x = Sum.elim v (l x) := by
  funext i
  cases i <;> rfl
#align combinatorics.line.vertical_apply Combinatorics.Line.vertical_apply

@[simp]
theorem horizontal_apply {α ι ι'} (l : Line α ι) (v : ι' → α) (x : α) :
    l.horizontal v x = Sum.elim (l x) v := by
  funext i
  cases i <;> rfl
#align combinatorics.line.horizontal_apply Combinatorics.Line.horizontal_apply

@[simp]
theorem prod_apply {α ι ι'} (l : Line α ι) (l' : Line α ι') (x : α) :
    l.prod l' x = Sum.elim (l x) (l' x) := by
  funext i
  cases i <;> rfl
#align combinatorics.line.prod_apply Combinatorics.Line.prod_apply

@[simp]
theorem diagonal_apply {α ι} [Nonempty ι] (x : α) : Line.diagonal α ι x = fun _ => x := by
  simp_rw [Line.apply, Line.diagonal, Option.getD_none]
#align combinatorics.line.diagonal_apply Combinatorics.Line.diagonal_apply

/-- The Hales-Jewett theorem. This version has a restriction on universe levels which is necessary
for the proof. See `exists_mono_in_high_dimension` for a fully universe-polymorphic version. -/
private theorem exists_mono_in_high_dimension' :
    ∀ (α : Type u) [Finite α] (κ : Type max v u) [Finite κ],
      ∃ (ι : Type) (_ : Fintype ι), ∀ C : (ι → α) → κ, ∃ l : Line α ι, l.IsMono C :=
-- The proof proceeds by induction on `α`.
  Finite.induction_empty_option
  (-- We have to show that the theorem is invariant under `α ≃ α'` for the induction to work.
  @fun α α' e =>
    forall_imp fun κ =>
      forall_imp fun _ =>
        Exists.imp fun ι =>
          Exists.imp fun _ h C =>
            let ⟨l, c, lc⟩ := h fun v => C (e ∘ v)
            ⟨l.map e, c, e.forall_congr_left.mp fun x => by rw [← lc x, Line.map_apply]⟩)
  (by
    -- This deals with the degenerate case where `α` is empty.
    intro κ _
    by_cases h : Nonempty κ
    · refine' ⟨Unit, inferInstance, fun C => ⟨default, Classical.arbitrary _, PEmpty.rec⟩⟩
    · exact ⟨Empty, inferInstance, fun C => (h ⟨C (Empty.rec)⟩).elim⟩)
  (by
    -- Now we have to show that the theorem holds for `Option α` if it holds for `α`.
    intro α _ ihα κ _
    cases nonempty_fintype κ
    -- Later we'll need `α` to be nonempty. So we first deal with the trivial case where `α` is
    -- empty.
    -- Then `Option α` has only one element, so any line is monochromatic.
    by_cases h : Nonempty α
    on_goal 2 =>
      refine' ⟨Unit, inferInstance, fun C => ⟨diagonal _ Unit, C fun _ => none, ?_⟩⟩
      rintro (_ | ⟨a⟩)
      · rfl
      · exact (h ⟨a⟩).elim
    -- The key idea is to show that for every `r`, in high dimension we can either find
    -- `r` color focused lines or a monochromatic line.
    suffices key :
      ∀ r : ℕ,
        ∃ (ι : Type)(_ : Fintype ι),
          ∀ C : (ι → Option α) → κ,
            (∃ s : ColorFocused C, Multiset.card s.lines = r) ∨ ∃ l, IsMono C l
    -- Given the key claim, we simply take `r = |κ| + 1`. We cannot have this many distinct colors
    -- so we must be in the second case, where there is a monochromatic line.
    · obtain ⟨ι, _inst, hι⟩ := key (Fintype.card κ + 1)
      refine' ⟨ι, _inst, fun C => (hι C).resolve_left _⟩
      rintro ⟨s, sr⟩
      apply Nat.not_succ_le_self (Fintype.card κ)
      rw [← Nat.add_one, ← sr, ← Multiset.card_map, ← Finset.card_mk]
      exact Finset.card_le_univ ⟨_, s.distinct_colors⟩
    -- We now prove the key claim, by induction on `r`.
    intro r
    induction' r with r ihr
    -- The base case `r = 0` is trivial as the empty collection is color-focused.
    · exact ⟨Empty, inferInstance, fun C => Or.inl ⟨default, Multiset.card_zero⟩⟩
    -- Supposing the key claim holds for `r`, we need to show it for `r+1`. First pick a high
    -- enough dimension `ι` for `r`.
    obtain ⟨ι, _inst, hι⟩ := ihr
    -- Then since the theorem holds for `α` with any number of colors, pick a dimension `ι'` such
    -- that `ι' → α` always has a monochromatic line whenever it is `(ι → Option α) → κ`-colored.
    specialize ihα ((ι → Option α) → κ)
    obtain ⟨ι', _inst, hι'⟩ := ihα
    -- We claim that `ι ⊕ ι'` works for `Option α` and `κ`-coloring.
    refine' ⟨Sum ι ι', inferInstance, _⟩
    intro C
    -- A `κ`-coloring of `ι ⊕ ι' → Option α` induces an `(ι → Option α) → κ`-coloring of `ι' → α`.
    specialize hι' fun v' v => C (Sum.elim v (some ∘ v'))
    -- By choice of `ι'` this coloring has a monochromatic line `l'` with color class `C'`, where
    -- `C'` is a `κ`-coloring of `ι → α`.
    obtain ⟨l', C', hl'⟩ := hι'
    -- If `C'` has a monochromatic line, then so does `C`. We use this in two places below.
    have mono_of_mono : (∃ l, IsMono C' l) → ∃ l, IsMono C l := by
      rintro ⟨l, c, hl⟩
      refine' ⟨l.horizontal (some ∘ l' (Classical.arbitrary α)), c, fun x => _⟩
      rw [Line.horizontal_apply, ← hl, ← hl']
    -- By choice of `ι`, `C'` either has `r` color-focused lines or a monochromatic line.
    specialize hι C'
    rcases hι with (⟨s, sr⟩ | h)
    on_goal 2 => exact Or.inr (mono_of_mono h)
    -- Here we assume `C'` has `r` color focused lines. We split into cases depending on whether
    -- one of these `r` lines has the same color as the focus point.
    by_cases h : ∃ p ∈ s.lines, (p : AlmostMono _).color = C' s.focus
    -- If so then this is a `C'`-monochromatic line and we are done.
    · obtain ⟨p, p_mem, hp⟩ := h
      refine' Or.inr (mono_of_mono ⟨p.line, p.color, _⟩)
      rintro (_ | _)
      rw [hp, s.is_focused p p_mem]
      apply p.has_color
    -- If not, we get `r+1` color focused lines by taking the product of the `r` lines with `l'`
    -- and adding to this the vertical line obtained by the focus point and `l`.
    refine' Or.inl ⟨⟨(s.lines.map _).cons ⟨(l'.map some).vertical s.focus, C' s.focus, fun x => _⟩,
            Sum.elim s.focus (l'.map some none), _, _⟩, _⟩
    -- Porting note: Needed to reorder the following two goals
    -- The product lines are almost monochromatic.
    · refine' fun p => ⟨p.line.prod (l'.map some), p.color, fun x => _⟩
      rw [Line.prod_apply, Line.map_apply, ← p.has_color, ← congr_fun (hl' x)]
    -- The vertical line is almost monochromatic.
    · rw [vertical_apply, ← congr_fun (hl' x), Line.map_apply]
    -- Our `r+1` lines have the same endpoint.
    · simp_rw [Multiset.mem_cons, Multiset.mem_map]
      rintro _ (rfl | ⟨q, hq, rfl⟩)
      · simp only [vertical_apply]
      · simp only [prod_apply, s.is_focused q hq]
    -- Our `r+1` lines have distinct colors (this is why we needed to split into cases above).
    · rw [Multiset.map_cons, Multiset.map_map, Multiset.nodup_cons, Multiset.mem_map]
      exact ⟨fun ⟨q, hq, he⟩ => h ⟨q, hq, he⟩, s.distinct_colors⟩
    -- Finally, we really do have `r+1` lines!
    · rw [Multiset.card_cons, Multiset.card_map, sr])
-- Porting note: Remove align on private declas
#noalign combinatorics.line.exists_mono_in_high_dimension'

/-- The Hales-Jewett theorem: for any finite types `α` and `κ`, there exists a finite type `ι` such
that whenever the hypercube `ι → α` is `κ`-colored, there is a monochromatic combinatorial line. -/
theorem exists_mono_in_high_dimension (α : Type u) [Finite α] (κ : Type v) [Finite κ] :
    ∃ (ι : Type) (_ : Fintype ι), ∀ C : (ι → α) → κ, ∃ l : Line α ι, l.IsMono C :=
  let ⟨ι, ιfin, hι⟩ := exists_mono_in_high_dimension'.{u,v} α (ULift.{u,v} κ)
  ⟨ι, ιfin, fun C =>
    let ⟨l, c, hc⟩ := hι (ULift.up ∘ C)
    ⟨l, c.down, fun x => by rw [← hc x, Function.comp_apply]⟩⟩
#align
  combinatorics.line.exists_mono_in_high_dimension
  Combinatorics.Line.exists_mono_in_high_dimension

end Line

/-- A generalization of Van der Waerden's theorem: if `M` is a finitely colored commutative
monoid, and `S` is a finite subset, then there exists a monochromatic homothetic copy of `S`. -/
theorem exists_mono_homothetic_copy {M κ : Type _} [AddCommMonoid M] (S : Finset M) [Finite κ]
    (C : M → κ) : ∃ a > 0, ∃ (b : M)(c : κ), ∀ s ∈ S, C (a • s + b) = c := by
  obtain ⟨ι, _inst, hι⟩ := Line.exists_mono_in_high_dimension S κ
  skip
  specialize hι fun v => C <| ∑ i, v i
  obtain ⟨l, c, hl⟩ := hι
  set s : Finset ι :=  Finset.univ.filter (fun i => l.idxFun i = none ) with hs
  refine'
    ⟨s.card, Finset.card_pos.mpr ⟨l.proper.choose, _⟩, ∑ i in sᶜ, ((l.idxFun i).map _).getD 0,
      c, _⟩
  · rw [hs, Finset.mem_filter]
    exact ⟨Finset.mem_univ _, l.proper.choose_spec⟩
  · exact fun m => m
  intro x xs
  rw [← hl ⟨x, xs⟩]
  clear hl; congr
  rw [← Finset.sum_add_sum_compl s]
  congr 1
  · rw [← Finset.sum_const]
    apply Finset.sum_congr rfl
    intro i hi
    rw [hs, Finset.mem_filter] at hi
    rw [l.apply_none _ _ hi.right, Subtype.coe_mk]
  · apply Finset.sum_congr rfl
    intro i hi
    rw [hs, Finset.compl_filter, Finset.mem_filter] at hi
    obtain ⟨y, hy⟩ := Option.ne_none_iff_exists.mp hi.right
    simp_rw [Line.apply, ← hy, Option.map_some', Option.getD]
#align combinatorics.exists_mono_homothetic_copy Combinatorics.exists_mono_homothetic_copy

end Combinatorics


/-
Copyright (c) 2019 Calle Sönne. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Calle Sönne
-/
import analysis.special_functions.trigonometric.basic

/-!
# The type of angles

In this file we define `real.angle` to be the quotient group `ℝ/2πℤ` and prove a few simple lemmas
about trigonometric functions and angles.
-/

open_locale real

noncomputable theory

namespace real

/-- The type of angles -/
def angle : Type :=
ℝ ⧸ (add_subgroup.zmultiples (2 * π))

namespace angle

instance angle.add_comm_group : add_comm_group angle :=
quotient_add_group.add_comm_group _

instance : inhabited angle := ⟨0⟩

instance : has_coe ℝ angle := ⟨quotient_add_group.mk' _⟩

/-- Coercion `ℝ → angle` as an additive homomorphism. -/
def coe_hom : ℝ →+ angle := quotient_add_group.mk' _

@[simp] lemma coe_coe_hom : (coe_hom : ℝ → angle) = coe := rfl

@[simp] lemma coe_zero : ↑(0 : ℝ) = (0 : angle) := rfl
@[simp] lemma coe_add (x y : ℝ) : ↑(x + y : ℝ) = (↑x + ↑y : angle) := rfl
@[simp] lemma coe_neg (x : ℝ) : ↑(-x : ℝ) = -(↑x : angle) := rfl
@[simp] lemma coe_sub (x y : ℝ) : ↑(x - y : ℝ) = (↑x - ↑y : angle) := rfl

@[simp, norm_cast] lemma coe_nat_mul_eq_nsmul (x : ℝ) (n : ℕ) :
  ↑((n : ℝ) * x) = n • (↑x : angle) :=
by simpa only [nsmul_eq_mul] using coe_hom.map_nsmul x n

@[simp, norm_cast] lemma coe_int_mul_eq_zsmul (x : ℝ) (n : ℤ) :
  ↑((n : ℝ) * x : ℝ) = n • (↑x : angle) :=
by simpa only [zsmul_eq_mul] using coe_hom.map_zsmul x n

lemma angle_eq_iff_two_pi_dvd_sub {ψ θ : ℝ} : (θ : angle) = ψ ↔ ∃ k : ℤ, θ - ψ = 2 * π * k :=
by simp only [quotient_add_group.eq, add_subgroup.zmultiples_eq_closure,
  add_subgroup.mem_closure_singleton, zsmul_eq_mul', (sub_eq_neg_add _ _).symm, eq_comm]

@[simp] lemma coe_two_pi : ↑(2 * π : ℝ) = (0 : angle) :=
angle_eq_iff_two_pi_dvd_sub.2 ⟨1, by rw [sub_zero, int.cast_one, mul_one]⟩

theorem cos_eq_iff_eq_or_eq_neg {θ ψ : ℝ} : cos θ = cos ψ ↔ (θ : angle) = ψ ∨ (θ : angle) = -ψ :=
begin
  split,
  { intro Hcos,
    rw [← sub_eq_zero, cos_sub_cos, mul_eq_zero, mul_eq_zero, neg_eq_zero,
        eq_false_intro two_ne_zero, false_or, sin_eq_zero_iff, sin_eq_zero_iff] at Hcos,
    rcases Hcos with ⟨n, hn⟩ | ⟨n, hn⟩,
    { right,
      rw [eq_div_iff_mul_eq (@two_ne_zero ℝ _ _), ← sub_eq_iff_eq_add] at hn,
      rw [← hn, coe_sub, eq_neg_iff_add_eq_zero, sub_add_cancel, mul_assoc,
          coe_int_mul_eq_zsmul, mul_comm, coe_two_pi, zsmul_zero] },
    { left,
      rw [eq_div_iff_mul_eq (@two_ne_zero ℝ _ _), eq_sub_iff_add_eq] at hn,
      rw [← hn, coe_add, mul_assoc,
          coe_int_mul_eq_zsmul, mul_comm, coe_two_pi, zsmul_zero, zero_add] },
    apply_instance, },
  { rw [angle_eq_iff_two_pi_dvd_sub, ← coe_neg, angle_eq_iff_two_pi_dvd_sub],
    rintro (⟨k, H⟩ | ⟨k, H⟩),
    rw [← sub_eq_zero, cos_sub_cos, H, mul_assoc 2 π k,
        mul_div_cancel_left _ (@two_ne_zero ℝ _ _), mul_comm π _, sin_int_mul_pi, mul_zero],
    rw [← sub_eq_zero, cos_sub_cos, ← sub_neg_eq_add, H, mul_assoc 2 π k,
        mul_div_cancel_left _ (@two_ne_zero ℝ _ _), mul_comm π _, sin_int_mul_pi, mul_zero,
        zero_mul] }
end

theorem sin_eq_iff_eq_or_add_eq_pi {θ ψ : ℝ} :
  sin θ = sin ψ ↔ (θ : angle) = ψ ∨ (θ : angle) + ψ = π :=
begin
  split,
  { intro Hsin, rw [← cos_pi_div_two_sub, ← cos_pi_div_two_sub] at Hsin,
    cases cos_eq_iff_eq_or_eq_neg.mp Hsin with h h,
    { left, rw [coe_sub, coe_sub] at h, exact sub_right_inj.1 h },
      right, rw [coe_sub, coe_sub, eq_neg_iff_add_eq_zero, add_sub,
      sub_add_eq_add_sub, ← coe_add, add_halves, sub_sub, sub_eq_zero] at h,
    exact h.symm },
  { rw [angle_eq_iff_two_pi_dvd_sub, ←eq_sub_iff_add_eq, ←coe_sub, angle_eq_iff_two_pi_dvd_sub],
    rintro (⟨k, H⟩ | ⟨k, H⟩),
    rw [← sub_eq_zero, sin_sub_sin, H, mul_assoc 2 π k,
         mul_div_cancel_left _ (@two_ne_zero ℝ _ _), mul_comm π _, sin_int_mul_pi, mul_zero,
         zero_mul],
    have H' : θ + ψ = (2 * k) * π + π := by rwa [←sub_add, sub_add_eq_add_sub, sub_eq_iff_eq_add,
      mul_assoc, mul_comm π _, ←mul_assoc] at H,
    rw [← sub_eq_zero, sin_sub_sin, H', add_div, mul_assoc 2 _ π,
        mul_div_cancel_left _ (@two_ne_zero ℝ _ _), cos_add_pi_div_two, sin_int_mul_pi, neg_zero,
        mul_zero] }
end

theorem cos_sin_inj {θ ψ : ℝ} (Hcos : cos θ = cos ψ) (Hsin : sin θ = sin ψ) : (θ : angle) = ψ :=
begin
  cases cos_eq_iff_eq_or_eq_neg.mp Hcos with hc hc, { exact hc },
  cases sin_eq_iff_eq_or_add_eq_pi.mp Hsin with hs hs, { exact hs },
  rw [eq_neg_iff_add_eq_zero, hs] at hc,
  cases quotient.exact' hc with n hn, change n • _ = _ at hn,
  rw [← neg_one_mul, add_zero, ← sub_eq_zero, zsmul_eq_mul, ← mul_assoc, ← sub_mul,
      mul_eq_zero, eq_false_intro (ne_of_gt pi_pos), or_false, sub_neg_eq_add,
      ← int.cast_zero, ← int.cast_one, ← int.cast_bit0, ← int.cast_mul, ← int.cast_add,
      int.cast_inj] at hn,
  have : (n * 2 + 1) % (2:ℤ) = 0 % (2:ℤ) := congr_arg (%(2:ℤ)) hn,
  rw [add_comm, int.add_mul_mod_self] at this,
  exact absurd this one_ne_zero
end

end angle

end real