/-
Copyright (c) 2021 Alex Kontorovich and Heather Macbeth and Marc Masdeu. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Alex Kontorovich, Heather Macbeth, Marc Masdeu

! This file was ported from Lean 3 source module number_theory.modular
! leanprover-community/mathlib commit 2196ab363eb097c008d4497125e0dde23fb36db2
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.Complex.UpperHalfPlane.Basic
import Mathbin.Analysis.NormedSpace.FiniteDimension
import Mathbin.LinearAlgebra.GeneralLinearGroup
import Mathbin.LinearAlgebra.Matrix.GeneralLinearGroup

/-!
# The action of the modular group SL(2, ℤ) on the upper half-plane

We define the action of `SL(2,ℤ)` on `ℍ` (via restriction of the `SL(2,ℝ)` action in
`analysis.complex.upper_half_plane`). We then define the standard fundamental domain
(`modular_group.fd`, `𝒟`) for this action and show
(`modular_group.exists_smul_mem_fd`) that any point in `ℍ` can be
moved inside `𝒟`.

## Main definitions

The standard (closed) fundamental domain of the action of `SL(2,ℤ)` on `ℍ`, denoted `𝒟`:
`fd := {z | 1 ≤ (z : ℂ).norm_sq ∧ |z.re| ≤ (1 : ℝ) / 2}`

The standard open fundamental domain of the action of `SL(2,ℤ)` on `ℍ`, denoted `𝒟ᵒ`:
`fdo := {z | 1 < (z : ℂ).norm_sq ∧ |z.re| < (1 : ℝ) / 2}`

These notations are localized in the `modular` locale and can be enabled via `open_locale modular`.

## Main results

Any `z : ℍ` can be moved to `𝒟` by an element of `SL(2,ℤ)`:
`exists_smul_mem_fd (z : ℍ) : ∃ g : SL(2,ℤ), g • z ∈ 𝒟`

If both `z` and `γ • z` are in the open domain `𝒟ᵒ` then `z = γ • z`:
`eq_smul_self_of_mem_fdo_mem_fdo {z : ℍ} {g : SL(2,ℤ)} (hz : z ∈ 𝒟ᵒ) (hg : g • z ∈ 𝒟ᵒ) : z = g • z`

# Discussion

Standard proofs make use of the identity

`g • z = a / c - 1 / (c (cz + d))`

for `g = [[a, b], [c, d]]` in `SL(2)`, but this requires separate handling of whether `c = 0`.
Instead, our proof makes use of the following perhaps novel identity (see
`modular_group.smul_eq_lc_row0_add`):

`g • z = (a c + b d) / (c^2 + d^2) + (d z - c) / ((c^2 + d^2) (c z + d))`

where there is no issue of division by zero.

Another feature is that we delay until the very end the consideration of special matrices
`T=[[1,1],[0,1]]` (see `modular_group.T`) and `S=[[0,-1],[1,0]]` (see `modular_group.S`), by
instead using abstract theory on the properness of certain maps (phrased in terms of the filters
`filter.cocompact`, `filter.cofinite`, etc) to deduce existence theorems, first to prove the
existence of `g` maximizing `(g•z).im` (see `modular_group.exists_max_im`), and then among
those, to minimize `|(g•z).re|` (see `modular_group.exists_row_one_eq_and_min_re`).
-/

/- Disable these instances as they are not the simp-normal form, and having them disabled ensures
we state lemmas in this file without spurious `coe_fn` terms. -/
attribute [-instance] Matrix.SpecialLinearGroup.hasCoeToFun

attribute [-instance] Matrix.GeneralLinearGroup.hasCoeToFun

open Complex hiding abs_two

open Matrix hiding mul_smul

open Matrix.SpecialLinearGroup UpperHalfPlane

noncomputable section

-- mathport name: «exprSL( , )»
local notation "SL(" n ", " R ")" => SpecialLinearGroup (Fin n) R

-- mathport name: «expr↑ₘ »
local prefix:1024 "↑ₘ" => @coe _ (Matrix (Fin 2) (Fin 2) ℤ) _

open UpperHalfPlane ComplexConjugate

attribute [local instance] Fintype.card_fin_even

namespace ModularGroup

variable {g : SL(2, ℤ)} (z : ℍ)

section BottomRow

/-- The two numbers `c`, `d` in the "bottom_row" of `g=[[*,*],[c,d]]` in `SL(2, ℤ)` are coprime. -/
theorem bottom_row_coprime {R : Type _} [CommRing R] (g : SL(2, R)) :
    IsCoprime ((↑g : Matrix (Fin 2) (Fin 2) R) 1 0) ((↑g : Matrix (Fin 2) (Fin 2) R) 1 1) :=
  by
  use -(↑g : Matrix (Fin 2) (Fin 2) R) 0 1, (↑g : Matrix (Fin 2) (Fin 2) R) 0 0
  rw [add_comm, neg_mul, ← sub_eq_add_neg, ← det_fin_two]
  exact g.det_coe
#align modular_group.bottom_row_coprime ModularGroup.bottom_row_coprime

/-- Every pair `![c, d]` of coprime integers is the "bottom_row" of some element `g=[[*,*],[c,d]]`
of `SL(2,ℤ)`. -/
theorem bottom_row_surj {R : Type _} [CommRing R] :
    Set.SurjOn (fun g : SL(2, R) => @coe _ (Matrix (Fin 2) (Fin 2) R) _ g 1) Set.univ
      { cd | IsCoprime (cd 0) (cd 1) } :=
  by
  rintro cd ⟨b₀, a, gcd_eqn⟩
  let A := of ![![a, -b₀], cd]
  have det_A_1 : det A = 1 := by
    convert gcd_eqn
    simp [A, det_fin_two, (by ring : a * cd 1 + b₀ * cd 0 = b₀ * cd 0 + a * cd 1)]
  refine' ⟨⟨A, det_A_1⟩, Set.mem_univ _, _⟩
  ext <;> simp [A]
#align modular_group.bottom_row_surj ModularGroup.bottom_row_surj

end BottomRow

section TendstoLemmas

open Filter ContinuousLinearMap

attribute [local simp] coe_smul

/-- The function `(c,d) → |cz+d|^2` is proper, that is, preimages of bounded-above sets are finite.
-/
theorem tendsto_normSq_coprime_pair :
    Filter.Tendsto (fun p : Fin 2 → ℤ => ((p 0 : ℂ) * z + p 1).normSq) cofinite atTop :=
  by
  -- using this instance rather than the automatic `function.module` makes unification issues in
  -- `linear_equiv.closed_embedding_of_injective` less bad later in the proof.
  letI : Module ℝ (Fin 2 → ℝ) := NormedSpace.toModule
  let π₀ : (Fin 2 → ℝ) →ₗ[ℝ] ℝ := LinearMap.proj 0
  let π₁ : (Fin 2 → ℝ) →ₗ[ℝ] ℝ := LinearMap.proj 1
  let f : (Fin 2 → ℝ) →ₗ[ℝ] ℂ := π₀.smul_right (z : ℂ) + π₁.smul_right 1
  have f_def : ⇑f = fun p : Fin 2 → ℝ => (p 0 : ℂ) * ↑z + p 1 :=
    by
    ext1
    dsimp only [LinearMap.coe_proj, real_smul, LinearMap.coe_smulRight, LinearMap.add_apply]
    rw [mul_one]
  have :
    (fun p : Fin 2 → ℤ => norm_sq ((p 0 : ℂ) * ↑z + ↑(p 1))) =
      norm_sq ∘ f ∘ fun p : Fin 2 → ℤ => (coe : ℤ → ℝ) ∘ p :=
    by
    ext1
    rw [f_def]
    dsimp only [Function.comp]
    rw [of_real_int_cast, of_real_int_cast]
  rw [this]
  have hf : f.ker = ⊥ :=
    by
    let g : ℂ →ₗ[ℝ] Fin 2 → ℝ :=
      LinearMap.pi ![im_lm, im_lm.comp ((z : ℂ) • ((conj_ae : ℂ →ₐ[ℝ] ℂ) : ℂ →ₗ[ℝ] ℂ))]
    suffices ((z : ℂ).im⁻¹ • g).comp f = LinearMap.id by exact LinearMap.ker_eq_bot_of_inverse this
    apply LinearMap.ext
    intro c
    have hz : (z : ℂ).im ≠ 0 := z.2.ne'
    rw [LinearMap.comp_apply, LinearMap.smul_apply, LinearMap.id_apply]
    ext i
    dsimp only [g, Pi.smul_apply, LinearMap.pi_apply, smul_eq_mul]
    fin_cases i
    · show (z : ℂ).im⁻¹ * (f c).im = c 0
      rw [f_def, add_im, of_real_mul_im, of_real_im, add_zero, mul_left_comm, inv_mul_cancel hz,
        mul_one]
    · show (z : ℂ).im⁻¹ * ((z : ℂ) * conj (f c)).im = c 1
      rw [f_def, RingHom.map_add, RingHom.map_mul, mul_add, mul_left_comm, mul_conj, conj_of_real,
        conj_of_real, ← of_real_mul, add_im, of_real_im, zero_add, inv_mul_eq_iff_eq_mul₀ hz]
      simp only [of_real_im, of_real_re, mul_im, zero_add, MulZeroClass.mul_zero]
  have hf' : ClosedEmbedding f :=
    by
    -- for some reason we get a timeout if we try and apply this lemma in a more sensible way
    have := @LinearEquiv.closedEmbedding_of_injective ℝ _ (Fin 2 → ℝ) _ (id _) ℂ _ _ _ _
    rotate_left 2
    exact f
    exact this hf
  have h₂ : tendsto (fun p : Fin 2 → ℤ => (coe : ℤ → ℝ) ∘ p) cofinite (cocompact _) :=
    by
    convert tendsto.pi_map_Coprod fun i => Int.tendsto_coe_cofinite
    · rw [Coprod_cofinite]
    · rw [Coprod_cocompact]
  exact tendsto_norm_sq_cocompact_at_top.comp (hf'.tendsto_cocompact.comp h₂)
#align modular_group.tendsto_norm_sq_coprime_pair ModularGroup.tendsto_normSq_coprime_pair

/-- Given `coprime_pair` `p=(c,d)`, the matrix `[[a,b],[*,*]]` is sent to `a*c+b*d`.
  This is the linear map version of this operation.
-/
def lcRow0 (p : Fin 2 → ℤ) : Matrix (Fin 2) (Fin 2) ℝ →ₗ[ℝ] ℝ :=
  ((p 0 : ℝ) • LinearMap.proj 0 + (p 1 : ℝ) • LinearMap.proj 1 : (Fin 2 → ℝ) →ₗ[ℝ] ℝ).comp
    (LinearMap.proj 0)
#align modular_group.lc_row0 ModularGroup.lcRow0

@[simp]
theorem lcRow0_apply (p : Fin 2 → ℤ) (g : Matrix (Fin 2) (Fin 2) ℝ) :
    lcRow0 p g = p 0 * g 0 0 + p 1 * g 0 1 :=
  rfl
#align modular_group.lc_row0_apply ModularGroup.lcRow0_apply

/-- Linear map sending the matrix [a, b; c, d] to the matrix [ac₀ + bd₀, - ad₀ + bc₀; c, d], for
some fixed `(c₀, d₀)`. -/
@[simps]
def lcRow0Extend {cd : Fin 2 → ℤ} (hcd : IsCoprime (cd 0) (cd 1)) :
    Matrix (Fin 2) (Fin 2) ℝ ≃ₗ[ℝ] Matrix (Fin 2) (Fin 2) ℝ :=
  LinearEquiv.piCongrRight
    ![by
      refine'
        LinearMap.GeneralLinearGroup.generalLinearEquiv ℝ (Fin 2 → ℝ)
          (general_linear_group.to_linear (plane_conformal_matrix (cd 0 : ℝ) (-(cd 1 : ℝ)) _))
      norm_cast
      rw [neg_sq]
      exact hcd.sq_add_sq_ne_zero, LinearEquiv.refl ℝ (Fin 2 → ℝ)]
#align modular_group.lc_row0_extend ModularGroup.lcRow0Extend

/-- The map `lc_row0` is proper, that is, preimages of cocompact sets are finite in
`[[* , *], [c, d]]`.-/
theorem tendsto_lcRow0 {cd : Fin 2 → ℤ} (hcd : IsCoprime (cd 0) (cd 1)) :
    Tendsto (fun g : { g : SL(2, ℤ) // ↑ₘg 1 = cd } => lcRow0 cd ↑(↑g : SL(2, ℝ))) cofinite
      (cocompact ℝ) :=
  by
  let mB : ℝ → Matrix (Fin 2) (Fin 2) ℝ := fun t => of ![![t, (-(1 : ℤ) : ℝ)], coe ∘ cd]
  have hmB : Continuous mB := by
    refine' continuous_matrix _
    simp only [Fin.forall_fin_two, mB, continuous_const, continuous_id', of_apply, cons_val_zero,
      cons_val_one, and_self_iff]
  refine' Filter.Tendsto.of_tendsto_comp _ (comap_cocompact_le hmB)
  let f₁ : SL(2, ℤ) → Matrix (Fin 2) (Fin 2) ℝ := fun g =>
    Matrix.map (↑g : Matrix _ _ ℤ) (coe : ℤ → ℝ)
  have cocompact_ℝ_to_cofinite_ℤ_matrix :
    tendsto (fun m : Matrix (Fin 2) (Fin 2) ℤ => Matrix.map m (coe : ℤ → ℝ)) cofinite
      (cocompact _) :=
    by
    simpa only [Coprod_cofinite, Coprod_cocompact] using
      tendsto.pi_map_Coprod fun i : Fin 2 =>
        tendsto.pi_map_Coprod fun j : Fin 2 => Int.tendsto_coe_cofinite
  have hf₁ : tendsto f₁ cofinite (cocompact _) :=
    cocompact_ℝ_to_cofinite_ℤ_matrix.comp subtype.coe_injective.tendsto_cofinite
  have hf₂ : ClosedEmbedding (lc_row0_extend hcd) :=
    (lc_row0_extend hcd).toContinuousLinearEquiv.toHomeomorph.ClosedEmbedding
  convert hf₂.tendsto_cocompact.comp (hf₁.comp subtype.coe_injective.tendsto_cofinite) using 1
  ext (⟨g, rfl⟩i j) : 3
  fin_cases i <;> [fin_cases j, skip]
  -- the following are proved by `simp`, but it is replaced by `simp only` to avoid timeouts.
  ·
    simp only [mB, mul_vec, dot_product, Fin.sum_univ_two, _root_.coe_coe, coe_matrix_coe,
      Int.coe_castRingHom, lc_row0_apply, Function.comp_apply, cons_val_zero, lc_row0_extend_apply,
      LinearMap.GeneralLinearGroup.coeFn_generalLinearEquiv, general_linear_group.to_linear_apply,
      coe_plane_conformal_matrix, neg_neg, mul_vec_lin_apply, cons_val_one, head_cons, of_apply]
  · convert congr_arg (fun n : ℤ => (-n : ℝ)) g.det_coe.symm using 1
    simp only [f₁, mul_vec, dot_product, Fin.sum_univ_two, Matrix.det_fin_two, Function.comp_apply,
      Subtype.coe_mk, lc_row0_extend_apply, cons_val_zero,
      LinearMap.GeneralLinearGroup.coeFn_generalLinearEquiv, general_linear_group.to_linear_apply,
      coe_plane_conformal_matrix, mul_vec_lin_apply, cons_val_one, head_cons, map_apply, neg_mul,
      Int.cast_sub, Int.cast_mul, neg_sub, of_apply]
    ring
  · rfl
#align modular_group.tendsto_lc_row0 ModularGroup.tendsto_lcRow0

/-- This replaces `(g•z).re = a/c + *` in the standard theory with the following novel identity:
  `g • z = (a c + b d) / (c^2 + d^2) + (d z - c) / ((c^2 + d^2) (c z + d))`
  which does not need to be decomposed depending on whether `c = 0`. -/
theorem smul_eq_lcRow0_add {p : Fin 2 → ℤ} (hp : IsCoprime (p 0) (p 1)) (hg : ↑ₘg 1 = p) :
    ↑(g • z) =
      (lcRow0 p ↑(g : SL(2, ℝ)) : ℂ) / (p 0 ^ 2 + p 1 ^ 2) +
        ((p 1 : ℂ) * z - p 0) / ((p 0 ^ 2 + p 1 ^ 2) * (p 0 * z + p 1)) :=
  by
  have nonZ1 : (p 0 : ℂ) ^ 2 + p 1 ^ 2 ≠ 0 := by exact_mod_cast hp.sq_add_sq_ne_zero
  have : (coe : ℤ → ℝ) ∘ p ≠ 0 := fun h => hp.ne_zero (by ext i <;> simpa using congr_fun h i)
  have nonZ2 : (p 0 : ℂ) * z + p 1 ≠ 0 := by simpa using linear_ne_zero _ z this
  field_simp [nonZ1, nonZ2, denom_ne_zero, -UpperHalfPlane.denom, -denom_apply]
  rw [(by simp : (p 1 : ℂ) * z - p 0 = (p 1 * z - p 0) * ↑(det (↑g : Matrix (Fin 2) (Fin 2) ℤ)))]
  rw [← hg, det_fin_two]
  simp only [Int.coe_castRingHom, coe_matrix_coe, Int.cast_mul, of_real_int_cast, map_apply, denom,
    Int.cast_sub, _root_.coe_coe, coe_GL_pos_coe_GL_coe_matrix]
  ring
#align modular_group.smul_eq_lc_row0_add ModularGroup.smul_eq_lcRow0_add

theorem tendsto_abs_re_smul {p : Fin 2 → ℤ} (hp : IsCoprime (p 0) (p 1)) :
    Tendsto (fun g : { g : SL(2, ℤ) // ↑ₘg 1 = p } => |((g : SL(2, ℤ)) • z).re|) cofinite atTop :=
  by
  suffices
    tendsto (fun g : (fun g : SL(2, ℤ) => ↑ₘg 1) ⁻¹' {p} => ((g : SL(2, ℤ)) • z).re) cofinite
      (cocompact ℝ)
    by exact tendsto_norm_cocompact_at_top.comp this
  have : ((p 0 : ℝ) ^ 2 + p 1 ^ 2)⁻¹ ≠ 0 :=
    by
    apply inv_ne_zero
    exact_mod_cast hp.sq_add_sq_ne_zero
  let f := Homeomorph.mulRight₀ _ this
  let ff := Homeomorph.addRight (((p 1 : ℂ) * z - p 0) / ((p 0 ^ 2 + p 1 ^ 2) * (p 0 * z + p 1))).re
  convert(f.trans ff).ClosedEmbedding.tendsto_cocompact.comp (tendsto_lc_row0 hp)
  ext g
  change
    ((g : SL(2, ℤ)) • z).re =
      lc_row0 p ↑(↑g : SL(2, ℝ)) / (p 0 ^ 2 + p 1 ^ 2) +
        (((p 1 : ℂ) * z - p 0) / ((p 0 ^ 2 + p 1 ^ 2) * (p 0 * z + p 1))).re
  exact_mod_cast congr_arg Complex.re (smul_eq_lc_row0_add z hp g.2)
#align modular_group.tendsto_abs_re_smul ModularGroup.tendsto_abs_re_smul

end TendstoLemmas

section FundamentalDomain

attribute [local simp] coe_smul re_smul

/-- For `z : ℍ`, there is a `g : SL(2,ℤ)` maximizing `(g•z).im` -/
theorem exists_max_im : ∃ g : SL(2, ℤ), ∀ g' : SL(2, ℤ), (g' • z).im ≤ (g • z).im := by
  classical
    let s : Set (Fin 2 → ℤ) := { cd | IsCoprime (cd 0) (cd 1) }
    have hs : s.nonempty := ⟨![1, 1], isCoprime_one_left⟩
    obtain ⟨p, hp_coprime, hp⟩ :=
      Filter.Tendsto.exists_within_forall_le hs (tendsto_norm_sq_coprime_pair z)
    obtain ⟨g, -, hg⟩ := bottom_row_surj hp_coprime
    refine' ⟨g, fun g' => _⟩
    rw [special_linear_group.im_smul_eq_div_norm_sq, special_linear_group.im_smul_eq_div_norm_sq,
      div_le_div_left]
    · simpa [← hg] using hp (↑ₘg' 1) (bottom_row_coprime g')
    · exact z.im_pos
    · exact norm_sq_denom_pos g' z
    · exact norm_sq_denom_pos g z
#align modular_group.exists_max_im ModularGroup.exists_max_im

/-- Given `z : ℍ` and a bottom row `(c,d)`, among the `g : SL(2,ℤ)` with this bottom row, minimize
  `|(g•z).re|`.  -/
theorem exists_row_one_eq_and_min_re {cd : Fin 2 → ℤ} (hcd : IsCoprime (cd 0) (cd 1)) :
    ∃ g : SL(2, ℤ), ↑ₘg 1 = cd ∧ ∀ g' : SL(2, ℤ), ↑ₘg 1 = ↑ₘg' 1 → |(g • z).re| ≤ |(g' • z).re| :=
  by
  haveI : Nonempty { g : SL(2, ℤ) // ↑ₘg 1 = cd } :=
    let ⟨x, hx⟩ := bottom_row_surj hcd
    ⟨⟨x, hx.2⟩⟩
  obtain ⟨g, hg⟩ := Filter.Tendsto.exists_forall_le (tendsto_abs_re_smul z hcd)
  refine' ⟨g, g.2, _⟩
  · intro g1 hg1
    have : g1 ∈ (fun g : SL(2, ℤ) => ↑ₘg 1) ⁻¹' {cd} :=
      by
      rw [Set.mem_preimage, Set.mem_singleton_iff]
      exact Eq.trans hg1.symm (set.mem_singleton_iff.mp (set.mem_preimage.mp g.2))
    exact hg ⟨g1, this⟩
#align modular_group.exists_row_one_eq_and_min_re ModularGroup.exists_row_one_eq_and_min_re

theorem coe_t_zpow_smul_eq {n : ℤ} : (↑(t ^ n • z) : ℂ) = z + n := by simp [coe_T_zpow]
#align modular_group.coe_T_zpow_smul_eq ModularGroup.coe_t_zpow_smul_eq

theorem re_t_zpow_smul (n : ℤ) : (t ^ n • z).re = z.re + n := by
  rw [← coe_re, coe_T_zpow_smul_eq, add_re, int_cast_re, coe_re]
#align modular_group.re_T_zpow_smul ModularGroup.re_t_zpow_smul

theorem im_t_zpow_smul (n : ℤ) : (t ^ n • z).im = z.im := by
  rw [← coe_im, coe_T_zpow_smul_eq, add_im, int_cast_im, add_zero, coe_im]
#align modular_group.im_T_zpow_smul ModularGroup.im_t_zpow_smul

theorem re_t_smul : (t • z).re = z.re + 1 := by simpa using re_T_zpow_smul z 1
#align modular_group.re_T_smul ModularGroup.re_t_smul

theorem im_t_smul : (t • z).im = z.im := by simpa using im_T_zpow_smul z 1
#align modular_group.im_T_smul ModularGroup.im_t_smul

theorem re_t_inv_smul : (t⁻¹ • z).re = z.re - 1 := by simpa using re_T_zpow_smul z (-1)
#align modular_group.re_T_inv_smul ModularGroup.re_t_inv_smul

theorem im_t_inv_smul : (t⁻¹ • z).im = z.im := by simpa using im_T_zpow_smul z (-1)
#align modular_group.im_T_inv_smul ModularGroup.im_t_inv_smul

variable {z}

-- If instead we had `g` and `T` of type `PSL(2, ℤ)`, then we could simply state `g = T^n`.
theorem exists_eq_t_zpow_of_c_eq_zero (hc : ↑ₘg 1 0 = 0) : ∃ n : ℤ, ∀ z : ℍ, g • z = t ^ n • z :=
  by
  have had := g.det_coe
  replace had : ↑ₘg 0 0 * ↑ₘg 1 1 = 1;
  · rw [det_fin_two, hc] at had
    linarith
  rcases Int.eq_one_or_neg_one_of_mul_eq_one' had with (⟨ha, hd⟩ | ⟨ha, hd⟩)
  · use ↑ₘg 0 1
    suffices g = T ^ ↑ₘg 0 1 by
      intro z
      conv_lhs => rw [this]
    ext (i j)
    fin_cases i <;> fin_cases j <;> simp [ha, hc, hd, coe_T_zpow]
  · use -↑ₘg 0 1
    suffices g = -T ^ (-↑ₘg 0 1) by
      intro z
      conv_lhs => rw [this, SL_neg_smul]
    ext (i j)
    fin_cases i <;> fin_cases j <;> simp [ha, hc, hd, coe_T_zpow]
#align modular_group.exists_eq_T_zpow_of_c_eq_zero ModularGroup.exists_eq_t_zpow_of_c_eq_zero

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:73:14: unsupported tactic `congrm #[[expr «expr!![ »(matrix.notation [expr _, ",", expr _, ";", expr _, ",", expr _, "]"] [])]] -/
-- If `c = 1`, then `g` factorises into a product terms involving only `T` and `S`.
theorem g_eq_of_c_eq_one (hc : ↑ₘg 1 0 = 1) : g = t ^ ↑ₘg 0 0 * s * t ^ ↑ₘg 1 1 :=
  by
  have hg := g.det_coe.symm
  replace hg : ↑ₘg 0 1 = ↑ₘg 0 0 * ↑ₘg 1 1 - 1;
  · rw [det_fin_two, hc] at hg
    linarith
  refine' Subtype.ext _
  conv_lhs => rw [Matrix.eta_fin_two ↑ₘg]
  rw [hc, hg]
  simp only [coe_mul, coe_T_zpow, coe_S, mul_fin_two]
  trace
      "./././Mathport/Syntax/Translate/Tactic/Builtin.lean:73:14: unsupported tactic `congrm #[[expr «expr!![ »(matrix.notation [expr _, \",\", expr _, \";\", expr _, \",\", expr _, \"]\"] [])]]" <;>
    ring
#align modular_group.g_eq_of_c_eq_one ModularGroup.g_eq_of_c_eq_one

/-- If `1 < |z|`, then `|S • z| < 1`. -/
theorem normSq_s_smul_lt_one (h : 1 < normSq z) : normSq ↑(s • z) < 1 := by
  simpa [coe_S] using (inv_lt_inv z.norm_sq_pos zero_lt_one).mpr h
#align modular_group.norm_sq_S_smul_lt_one ModularGroup.normSq_s_smul_lt_one

/-- If `|z| < 1`, then applying `S` strictly decreases `im`. -/
theorem im_lt_im_s_smul (h : normSq z < 1) : z.im < (s • z).im :=
  by
  have : z.im < z.im / norm_sq (z : ℂ) :=
    by
    have imz : 0 < z.im := im_pos z
    apply (lt_div_iff z.norm_sq_pos).mpr
    nlinarith
  convert this
  simp only [special_linear_group.im_smul_eq_div_norm_sq]
  field_simp [norm_sq_denom_ne_zero, norm_sq_ne_zero, S]
#align modular_group.im_lt_im_S_smul ModularGroup.im_lt_im_s_smul

/-- The standard (closed) fundamental domain of the action of `SL(2,ℤ)` on `ℍ`. -/
def fd : Set ℍ :=
  { z | 1 ≤ (z : ℂ).normSq ∧ |z.re| ≤ (1 : ℝ) / 2 }
#align modular_group.fd ModularGroup.fd

/-- The standard open fundamental domain of the action of `SL(2,ℤ)` on `ℍ`. -/
def fdo : Set ℍ :=
  { z | 1 < (z : ℂ).normSq ∧ |z.re| < (1 : ℝ) / 2 }
#align modular_group.fdo ModularGroup.fdo

-- mathport name: modular_group.fd
scoped[Modular] notation "𝒟" => ModularGroup.fd

-- mathport name: modular_group.fdo
scoped[Modular] notation "𝒟ᵒ" => ModularGroup.fdo

theorem abs_two_mul_re_lt_one_of_mem_fdo (h : z ∈ 𝒟ᵒ) : |2 * z.re| < 1 :=
  by
  rw [abs_mul, abs_two, ← lt_div_iff' (zero_lt_two' ℝ)]
  exact h.2
#align modular_group.abs_two_mul_re_lt_one_of_mem_fdo ModularGroup.abs_two_mul_re_lt_one_of_mem_fdo

theorem three_lt_four_mul_im_sq_of_mem_fdo (h : z ∈ 𝒟ᵒ) : 3 < 4 * z.im ^ 2 :=
  by
  have : 1 < z.re * z.re + z.im * z.im := by simpa [Complex.normSq_apply] using h.1
  have := h.2
  cases abs_cases z.re <;> nlinarith
#align modular_group.three_lt_four_mul_im_sq_of_mem_fdo ModularGroup.three_lt_four_mul_im_sq_of_mem_fdo

/-- If `z ∈ 𝒟ᵒ`, and `n : ℤ`, then `|z + n| > 1`. -/
theorem one_lt_normSq_t_zpow_smul (hz : z ∈ 𝒟ᵒ) (n : ℤ) : 1 < normSq (t ^ n • z : ℍ) :=
  by
  have hz₁ : 1 < z.re * z.re + z.im * z.im := hz.1
  have hzn := Int.nneg_mul_add_sq_of_abs_le_one n (abs_two_mul_re_lt_one_of_mem_fdo hz).le
  have : 1 < (z.re + ↑n) * (z.re + ↑n) + z.im * z.im := by linarith
  simpa [coe_T_zpow, norm_sq]
#align modular_group.one_lt_norm_sq_T_zpow_smul ModularGroup.one_lt_normSq_t_zpow_smul

theorem eq_zero_of_mem_fdo_of_t_zpow_mem_fdo {n : ℤ} (hz : z ∈ 𝒟ᵒ) (hg : t ^ n • z ∈ 𝒟ᵒ) : n = 0 :=
  by
  suffices |(n : ℝ)| < 1 by
    rwa [← Int.cast_abs, ← Int.cast_one, Int.cast_lt, Int.abs_lt_one_iff] at this
  have h₁ := hz.2
  have h₂ := hg.2
  rw [re_T_zpow_smul] at h₂
  calc
    |(n : ℝ)| ≤ |z.re| + |z.re + (n : ℝ)| := abs_add' (n : ℝ) z.re
    _ < 1 / 2 + 1 / 2 := (add_lt_add h₁ h₂)
    _ = 1 := add_halves 1

#align modular_group.eq_zero_of_mem_fdo_of_T_zpow_mem_fdo ModularGroup.eq_zero_of_mem_fdo_of_t_zpow_mem_fdo

/-- Any `z : ℍ` can be moved to `𝒟` by an element of `SL(2,ℤ)`  -/
theorem exists_smul_mem_fd (z : ℍ) : ∃ g : SL(2, ℤ), g • z ∈ 𝒟 :=
  by
  -- obtain a g₀ which maximizes im (g • z),
  obtain ⟨g₀, hg₀⟩ := exists_max_im z
  -- then among those, minimize re
  obtain ⟨g, hg, hg'⟩ := exists_row_one_eq_and_min_re z (bottom_row_coprime g₀)
  refine' ⟨g, _⟩
  -- `g` has same max im property as `g₀`
  have hg₀' : ∀ g' : SL(2, ℤ), (g' • z).im ≤ (g • z).im :=
    by
    have hg'' : (g • z).im = (g₀ • z).im := by
      rw [special_linear_group.im_smul_eq_div_norm_sq, special_linear_group.im_smul_eq_div_norm_sq,
        denom_apply, denom_apply, hg]
    simpa only [hg''] using hg₀
  constructor
  · -- Claim: `1 ≤ ⇑norm_sq ↑(g • z)`. If not, then `S•g•z` has larger imaginary part
    contrapose! hg₀'
    refine' ⟨S * g, _⟩
    rw [mul_smul]
    exact im_lt_im_S_smul hg₀'
  · show |(g • z).re| ≤ 1 / 2
    -- if not, then either `T` or `T'` decrease |Re|.
    rw [abs_le]
    constructor
    · contrapose! hg'
      refine' ⟨T * g, (T_mul_apply_one _).symm, _⟩
      rw [mul_smul, re_T_smul]
      cases abs_cases ((g • z).re + 1) <;> cases abs_cases (g • z).re <;> linarith
    · contrapose! hg'
      refine' ⟨T⁻¹ * g, (T_inv_mul_apply_one _).symm, _⟩
      rw [mul_smul, re_T_inv_smul]
      cases abs_cases ((g • z).re - 1) <;> cases abs_cases (g • z).re <;> linarith
#align modular_group.exists_smul_mem_fd ModularGroup.exists_smul_mem_fd

section UniqueRepresentative

variable {z}

/-- An auxiliary result en route to `modular_group.c_eq_zero`. -/
theorem abs_c_le_one (hz : z ∈ 𝒟ᵒ) (hg : g • z ∈ 𝒟ᵒ) : |↑ₘg 1 0| ≤ 1 :=
  by
  let c' : ℤ := ↑ₘg 1 0
  let c : ℝ := (c' : ℝ)
  suffices 3 * c ^ 2 < 4
    by
    rw [← Int.cast_pow, ← Int.cast_three, ← Int.cast_four, ← Int.cast_mul, Int.cast_lt] at this
    replace this : c' ^ 2 ≤ 1 ^ 2
    · linarith
    rwa [sq_le_sq, abs_one] at this
  suffices c ≠ 0 → 9 * c ^ 4 < 16
    by
    rcases eq_or_ne c 0 with (hc | hc)
    · rw [hc]
      norm_num
    · refine' (abs_lt_of_sq_lt_sq' _ (by norm_num)).2
      specialize this hc
      linarith
  intro hc
  replace hc : 0 < c ^ 4
  · rw [pow_bit0_pos_iff] <;> trivial
  have h₁ :=
    mul_lt_mul_of_pos_right
      (mul_lt_mul'' (three_lt_four_mul_im_sq_of_mem_fdo hg) (three_lt_four_mul_im_sq_of_mem_fdo hz)
        (by linarith) (by linarith))
      hc
  have h₂ : (c * z.im) ^ 4 / norm_sq (denom (↑g) z) ^ 2 ≤ 1 :=
    div_le_one_of_le
      (pow_four_le_pow_two_of_pow_two_le (UpperHalfPlane.c_mul_im_sq_le_normSq_denom z g))
      (sq_nonneg _)
  let nsq := norm_sq (denom g z)
  calc
    9 * c ^ 4 < c ^ 4 * z.im ^ 2 * (g • z).im ^ 2 * 16 := by linarith
    _ = c ^ 4 * z.im ^ 4 / nsq ^ 2 * 16 :=
      by
      rw [special_linear_group.im_smul_eq_div_norm_sq, div_pow]
      ring
    _ ≤ 16 := by
      rw [← mul_pow]
      linarith

#align modular_group.abs_c_le_one ModularGroup.abs_c_le_one

/-- An auxiliary result en route to `modular_group.eq_smul_self_of_mem_fdo_mem_fdo`. -/
theorem c_eq_zero (hz : z ∈ 𝒟ᵒ) (hg : g • z ∈ 𝒟ᵒ) : ↑ₘg 1 0 = 0 :=
  by
  have hp : ∀ {g' : SL(2, ℤ)} (hg' : g' • z ∈ 𝒟ᵒ), ↑ₘg' 1 0 ≠ 1 :=
    by
    intros
    by_contra hc
    let a := ↑ₘg' 0 0
    let d := ↑ₘg' 1 1
    have had : T ^ (-a) * g' = S * T ^ d :=
      by
      rw [g_eq_of_c_eq_one hc]
      group
    let w := T ^ (-a) • g' • z
    have h₁ : w = S • T ^ d • z := by simp only [w, ← mul_smul, had]
    replace h₁ : norm_sq w < 1 := h₁.symm ▸ norm_sq_S_smul_lt_one (one_lt_norm_sq_T_zpow_smul hz d)
    have h₂ : 1 < norm_sq w := one_lt_norm_sq_T_zpow_smul hg' (-a)
    linarith
  have hn : ↑ₘg 1 0 ≠ -1 := by
    intro hc
    replace hc : ↑ₘ(-g) 1 0 = 1
    · simp [← neg_eq_iff_eq_neg.mpr hc]
    replace hg : -g • z ∈ 𝒟ᵒ := (SL_neg_smul g z).symm ▸ hg
    exact hp hg hc
  specialize hp hg
  rcases int.abs_le_one_iff.mp <| abs_c_le_one hz hg with ⟨⟩ <;> tauto
#align modular_group.c_eq_zero ModularGroup.c_eq_zero

/-- Second Main Fundamental Domain Lemma: if both `z` and `g • z` are in the open domain `𝒟ᵒ`,
where `z : ℍ` and `g : SL(2,ℤ)`, then `z = g • z`. -/
theorem eq_smul_self_of_mem_fdo_mem_fdo (hz : z ∈ 𝒟ᵒ) (hg : g • z ∈ 𝒟ᵒ) : z = g • z :=
  by
  obtain ⟨n, hn⟩ := exists_eq_T_zpow_of_c_eq_zero (c_eq_zero hz hg)
  rw [hn] at hg⊢
  simp [eq_zero_of_mem_fdo_of_T_zpow_mem_fdo hz hg, one_smul]
#align modular_group.eq_smul_self_of_mem_fdo_mem_fdo ModularGroup.eq_smul_self_of_mem_fdo_mem_fdo

end UniqueRepresentative

end FundamentalDomain

end ModularGroup


/-
Copyright (c) 2019 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel

! This file was ported from Lean 3 source module analysis.calculus.formal_multilinear_series
! leanprover-community/mathlib commit f2ce6086713c78a7f880485f7917ea547a215982
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.NormedSpace.Multilinear

/-!
# Formal multilinear series

In this file we define `formal_multilinear_series 𝕜 E F` to be a family of `n`-multilinear maps for
all `n`, designed to model the sequence of derivatives of a function. In other files we use this
notion to define `C^n` functions (called `cont_diff` in `mathlib`) and analytic functions.

## Notations

We use the notation `E [×n]→L[𝕜] F` for the space of continuous multilinear maps on `E^n` with
values in `F`. This is the space in which the `n`-th derivative of a function from `E` to `F` lives.

## Tags

multilinear, formal series
-/

noncomputable section

open Set Fin

open Topology

variable {𝕜 𝕜' E F G : Type _}

section

variable [CommRing 𝕜] [AddCommGroup E] [Module 𝕜 E] [TopologicalSpace E] [TopologicalAddGroup E]
  [ContinuousConstSMul 𝕜 E] [AddCommGroup F] [Module 𝕜 F] [TopologicalSpace F]
  [TopologicalAddGroup F] [ContinuousConstSMul 𝕜 F] [AddCommGroup G] [Module 𝕜 G]
  [TopologicalSpace G] [TopologicalAddGroup G] [ContinuousConstSMul 𝕜 G]

/-- A formal multilinear series over a field `𝕜`, from `E` to `F`, is given by a family of
multilinear maps from `E^n` to `F` for all `n`. -/
@[nolint unused_arguments]
def FormalMultilinearSeries (𝕜 : Type _) (E : Type _) (F : Type _) [Ring 𝕜] [AddCommGroup E]
    [Module 𝕜 E] [TopologicalSpace E] [TopologicalAddGroup E] [ContinuousConstSMul 𝕜 E]
    [AddCommGroup F] [Module 𝕜 F] [TopologicalSpace F] [TopologicalAddGroup F]
    [ContinuousConstSMul 𝕜 F] :=
  ∀ n : ℕ, E[×n]→L[𝕜] F deriving AddCommGroup
#align formal_multilinear_series FormalMultilinearSeries

instance : Inhabited (FormalMultilinearSeries 𝕜 E F) :=
  ⟨0⟩

section Module

/- `derive` is not able to find the module structure, probably because Lean is confused by the
dependent types. We register it explicitly. -/
instance : Module 𝕜 (FormalMultilinearSeries 𝕜 E F) :=
  by
  letI : ∀ n, Module 𝕜 (ContinuousMultilinearMap 𝕜 (fun i : Fin n => E) F) := fun n => by
    infer_instance
  refine' Pi.module _ _ _

end Module

namespace FormalMultilinearSeries

protected theorem ext_iff {p q : FormalMultilinearSeries 𝕜 E F} : p = q ↔ ∀ n, p n = q n :=
  Function.funext_iff
#align formal_multilinear_series.ext_iff FormalMultilinearSeries.ext_iff

protected theorem ne_iff {p q : FormalMultilinearSeries 𝕜 E F} : p ≠ q ↔ ∃ n, p n ≠ q n :=
  Function.ne_iff
#align formal_multilinear_series.ne_iff FormalMultilinearSeries.ne_iff

/-- Killing the zeroth coefficient in a formal multilinear series -/
def removeZero (p : FormalMultilinearSeries 𝕜 E F) : FormalMultilinearSeries 𝕜 E F
  | 0 => 0
  | n + 1 => p (n + 1)
#align formal_multilinear_series.remove_zero FormalMultilinearSeries.removeZero

@[simp]
theorem removeZero_coeff_zero (p : FormalMultilinearSeries 𝕜 E F) : p.removeZero 0 = 0 :=
  rfl
#align formal_multilinear_series.remove_zero_coeff_zero FormalMultilinearSeries.removeZero_coeff_zero

@[simp]
theorem removeZero_coeff_succ (p : FormalMultilinearSeries 𝕜 E F) (n : ℕ) :
    p.removeZero (n + 1) = p (n + 1) :=
  rfl
#align formal_multilinear_series.remove_zero_coeff_succ FormalMultilinearSeries.removeZero_coeff_succ

theorem removeZero_of_pos (p : FormalMultilinearSeries 𝕜 E F) {n : ℕ} (h : 0 < n) :
    p.removeZero n = p n := by
  rw [← Nat.succ_pred_eq_of_pos h]
  rfl
#align formal_multilinear_series.remove_zero_of_pos FormalMultilinearSeries.removeZero_of_pos

/-- Convenience congruence lemma stating in a dependent setting that, if the arguments to a formal
multilinear series are equal, then the values are also equal. -/
theorem congr (p : FormalMultilinearSeries 𝕜 E F) {m n : ℕ} {v : Fin m → E} {w : Fin n → E}
    (h1 : m = n) (h2 : ∀ (i : ℕ) (him : i < m) (hin : i < n), v ⟨i, him⟩ = w ⟨i, hin⟩) :
    p m v = p n w := by
  cases h1
  congr with ⟨i, hi⟩
  exact h2 i hi hi
#align formal_multilinear_series.congr FormalMultilinearSeries.congr

/-- Composing each term `pₙ` in a formal multilinear series with `(u, ..., u)` where `u` is a fixed
continuous linear map, gives a new formal multilinear series `p.comp_continuous_linear_map u`. -/
def compContinuousLinearMap (p : FormalMultilinearSeries 𝕜 F G) (u : E →L[𝕜] F) :
    FormalMultilinearSeries 𝕜 E G := fun n => (p n).compContinuousLinearMap fun i : Fin n => u
#align formal_multilinear_series.comp_continuous_linear_map FormalMultilinearSeries.compContinuousLinearMap

@[simp]
theorem compContinuousLinearMap_apply (p : FormalMultilinearSeries 𝕜 F G) (u : E →L[𝕜] F) (n : ℕ)
    (v : Fin n → E) : (p.compContinuousLinearMap u) n v = p n (u ∘ v) :=
  rfl
#align formal_multilinear_series.comp_continuous_linear_map_apply FormalMultilinearSeries.compContinuousLinearMap_apply

variable (𝕜) [CommRing 𝕜'] [SMul 𝕜 𝕜']

variable [Module 𝕜' E] [ContinuousConstSMul 𝕜' E] [IsScalarTower 𝕜 𝕜' E]

variable [Module 𝕜' F] [ContinuousConstSMul 𝕜' F] [IsScalarTower 𝕜 𝕜' F]

/-- Reinterpret a formal `𝕜'`-multilinear series as a formal `𝕜`-multilinear series. -/
@[simp]
protected def restrictScalars (p : FormalMultilinearSeries 𝕜' E F) :
    FormalMultilinearSeries 𝕜 E F := fun n => (p n).restrictScalars 𝕜
#align formal_multilinear_series.restrict_scalars FormalMultilinearSeries.restrictScalars

end FormalMultilinearSeries

end

namespace FormalMultilinearSeries

variable [NontriviallyNormedField 𝕜] [NormedAddCommGroup E] [NormedSpace 𝕜 E] [NormedAddCommGroup F]
  [NormedSpace 𝕜 F] [NormedAddCommGroup G] [NormedSpace 𝕜 G]

variable (p : FormalMultilinearSeries 𝕜 E F)

/-- Forgetting the zeroth term in a formal multilinear series, and interpreting the following terms
as multilinear maps into `E →L[𝕜] F`. If `p` corresponds to the Taylor series of a function, then
`p.shift` is the Taylor series of the derivative of the function. -/
def shift : FormalMultilinearSeries 𝕜 E (E →L[𝕜] F) := fun n => (p n.succ).curryRight
#align formal_multilinear_series.shift FormalMultilinearSeries.shift

/-- Adding a zeroth term to a formal multilinear series taking values in `E →L[𝕜] F`. This
corresponds to starting from a Taylor series for the derivative of a function, and building a Taylor
series for the function itself. -/
def unshift (q : FormalMultilinearSeries 𝕜 E (E →L[𝕜] F)) (z : F) : FormalMultilinearSeries 𝕜 E F
  | 0 => (continuousMultilinearCurryFin0 𝕜 E F).symm z
  | n + 1 => continuousMultilinearCurryRightEquiv' 𝕜 n E F (q n)
#align formal_multilinear_series.unshift FormalMultilinearSeries.unshift

end FormalMultilinearSeries

namespace ContinuousLinearMap

variable [CommRing 𝕜] [AddCommGroup E] [Module 𝕜 E] [TopologicalSpace E] [TopologicalAddGroup E]
  [ContinuousConstSMul 𝕜 E] [AddCommGroup F] [Module 𝕜 F] [TopologicalSpace F]
  [TopologicalAddGroup F] [ContinuousConstSMul 𝕜 F] [AddCommGroup G] [Module 𝕜 G]
  [TopologicalSpace G] [TopologicalAddGroup G] [ContinuousConstSMul 𝕜 G]

/-- Composing each term `pₙ` in a formal multilinear series with a continuous linear map `f` on the
left gives a new formal multilinear series `f.comp_formal_multilinear_series p` whose general term
is `f ∘ pₙ`. -/
def compFormalMultilinearSeries (f : F →L[𝕜] G) (p : FormalMultilinearSeries 𝕜 E F) :
    FormalMultilinearSeries 𝕜 E G := fun n => f.compContinuousMultilinearMap (p n)
#align continuous_linear_map.comp_formal_multilinear_series ContinuousLinearMap.compFormalMultilinearSeries

@[simp]
theorem compFormalMultilinearSeries_apply (f : F →L[𝕜] G) (p : FormalMultilinearSeries 𝕜 E F)
    (n : ℕ) : (f.compFormalMultilinearSeries p) n = f.compContinuousMultilinearMap (p n) :=
  rfl
#align continuous_linear_map.comp_formal_multilinear_series_apply ContinuousLinearMap.compFormalMultilinearSeries_apply

theorem compFormalMultilinearSeries_apply' (f : F →L[𝕜] G) (p : FormalMultilinearSeries 𝕜 E F)
    (n : ℕ) (v : Fin n → E) : (f.compFormalMultilinearSeries p) n v = f (p n v) :=
  rfl
#align continuous_linear_map.comp_formal_multilinear_series_apply' ContinuousLinearMap.compFormalMultilinearSeries_apply'

end ContinuousLinearMap

namespace FormalMultilinearSeries

section Order

variable [CommRing 𝕜] {n : ℕ} [AddCommGroup E] [Module 𝕜 E] [TopologicalSpace E]
  [TopologicalAddGroup E] [ContinuousConstSMul 𝕜 E] [AddCommGroup F] [Module 𝕜 F]
  [TopologicalSpace F] [TopologicalAddGroup F] [ContinuousConstSMul 𝕜 F]
  {p : FormalMultilinearSeries 𝕜 E F}

/-- The index of the first non-zero coefficient in `p` (or `0` if all coefficients are zero). This
  is the order of the isolated zero of an analytic function `f` at a point if `p` is the Taylor
  series of `f` at that point. -/
noncomputable def order (p : FormalMultilinearSeries 𝕜 E F) : ℕ :=
  infₛ { n | p n ≠ 0 }
#align formal_multilinear_series.order FormalMultilinearSeries.order

@[simp]
theorem order_zero : (0 : FormalMultilinearSeries 𝕜 E F).order = 0 := by simp [order]
#align formal_multilinear_series.order_zero FormalMultilinearSeries.order_zero

theorem ne_zero_of_order_ne_zero (hp : p.order ≠ 0) : p ≠ 0 := fun h => by simpa [h] using hp
#align formal_multilinear_series.ne_zero_of_order_ne_zero FormalMultilinearSeries.ne_zero_of_order_ne_zero

theorem order_eq_find [DecidablePred fun n => p n ≠ 0] (hp : ∃ n, p n ≠ 0) :
    p.order = Nat.find hp := by simp [order, Inf, hp]
#align formal_multilinear_series.order_eq_find FormalMultilinearSeries.order_eq_find

theorem order_eq_find' [DecidablePred fun n => p n ≠ 0] (hp : p ≠ 0) :
    p.order = Nat.find (FormalMultilinearSeries.ne_iff.mp hp) :=
  order_eq_find _
#align formal_multilinear_series.order_eq_find' FormalMultilinearSeries.order_eq_find'

theorem order_eq_zero_iff (hp : p ≠ 0) : p.order = 0 ↔ p 0 ≠ 0 := by
  classical
    have : ∃ n, p n ≠ 0 := formal_multilinear_series.ne_iff.mp hp
    simp [order_eq_find this, hp]
#align formal_multilinear_series.order_eq_zero_iff FormalMultilinearSeries.order_eq_zero_iff

theorem order_eq_zero_iff' : p.order = 0 ↔ p = 0 ∨ p 0 ≠ 0 := by
  by_cases h : p = 0 <;> simp [h, order_eq_zero_iff]
#align formal_multilinear_series.order_eq_zero_iff' FormalMultilinearSeries.order_eq_zero_iff'

theorem apply_order_ne_zero (hp : p ≠ 0) : p p.order ≠ 0 := by
  classical
    let h := formal_multilinear_series.ne_iff.mp hp
    exact (order_eq_find h).symm ▸ Nat.find_spec h
#align formal_multilinear_series.apply_order_ne_zero FormalMultilinearSeries.apply_order_ne_zero

theorem apply_order_ne_zero' (hp : p.order ≠ 0) : p p.order ≠ 0 :=
  apply_order_ne_zero (ne_zero_of_order_ne_zero hp)
#align formal_multilinear_series.apply_order_ne_zero' FormalMultilinearSeries.apply_order_ne_zero'

theorem apply_eq_zero_of_lt_order (hp : n < p.order) : p n = 0 :=
  by
  by_cases p = 0
  · simp [h]
  ·
    classical
      rw [order_eq_find' h] at hp
      simpa using Nat.find_min _ hp
#align formal_multilinear_series.apply_eq_zero_of_lt_order FormalMultilinearSeries.apply_eq_zero_of_lt_order

end Order

section Coef

variable [NontriviallyNormedField 𝕜] [NormedAddCommGroup E] [NormedSpace 𝕜 E] {s : E}
  {p : FormalMultilinearSeries 𝕜 𝕜 E} {f : 𝕜 → E} {n : ℕ} {z z₀ : 𝕜} {y : Fin n → 𝕜}

open BigOperators

/-- The `n`th coefficient of `p` when seen as a power series. -/
def coeff (p : FormalMultilinearSeries 𝕜 𝕜 E) (n : ℕ) : E :=
  p n 1
#align formal_multilinear_series.coeff FormalMultilinearSeries.coeff

theorem mkPiField_coeff_eq (p : FormalMultilinearSeries 𝕜 𝕜 E) (n : ℕ) :
    ContinuousMultilinearMap.mkPiField 𝕜 (Fin n) (p.coeff n) = p n :=
  (p n).mkPiField_apply_one_eq_self
#align formal_multilinear_series.mk_pi_field_coeff_eq FormalMultilinearSeries.mkPiField_coeff_eq

@[simp]
theorem apply_eq_prod_smul_coeff : p n y = (∏ i, y i) • p.coeff n :=
  by
  convert(p n).toMultilinearMap.map_smul_univ y 1
  funext <;> simp only [Pi.one_apply, Algebra.id.smul_eq_mul, mul_one]
#align formal_multilinear_series.apply_eq_prod_smul_coeff FormalMultilinearSeries.apply_eq_prod_smul_coeff

theorem coeff_eq_zero : p.coeff n = 0 ↔ p n = 0 := by
  rw [← mk_pi_field_coeff_eq p, ContinuousMultilinearMap.mkPiField_eq_zero_iff]
#align formal_multilinear_series.coeff_eq_zero FormalMultilinearSeries.coeff_eq_zero

@[simp]
theorem apply_eq_pow_smul_coeff : (p n fun _ => z) = z ^ n • p.coeff n := by simp
#align formal_multilinear_series.apply_eq_pow_smul_coeff FormalMultilinearSeries.apply_eq_pow_smul_coeff

@[simp]
theorem norm_apply_eq_norm_coef : ‖p n‖ = ‖coeff p n‖ := by
  rw [← mk_pi_field_coeff_eq p, ContinuousMultilinearMap.norm_mkPiField]
#align formal_multilinear_series.norm_apply_eq_norm_coef FormalMultilinearSeries.norm_apply_eq_norm_coef

end Coef

section Fslope

variable [NontriviallyNormedField 𝕜] [NormedAddCommGroup E] [NormedSpace 𝕜 E]
  {p : FormalMultilinearSeries 𝕜 𝕜 E} {n : ℕ}

/-- The formal counterpart of `dslope`, corresponding to the expansion of `(f z - f 0) / z`. If `f`
has `p` as a power series, then `dslope f` has `fslope p` as a power series. -/
noncomputable def fslope (p : FormalMultilinearSeries 𝕜 𝕜 E) : FormalMultilinearSeries 𝕜 𝕜 E :=
  fun n => (p (n + 1)).curryLeft 1
#align formal_multilinear_series.fslope FormalMultilinearSeries.fslope

@[simp]
theorem coeff_fslope : p.fslope.coeff n = p.coeff (n + 1) :=
  by
  have : @Fin.cons n (fun _ => 𝕜) 1 (1 : Fin n → 𝕜) = 1 := Fin.cons_self_tail 1
  simp only [fslope, coeff, ContinuousMultilinearMap.curryLeft_apply, this]
#align formal_multilinear_series.coeff_fslope FormalMultilinearSeries.coeff_fslope

@[simp]
theorem coeff_iterate_fslope (k n : ℕ) : ((fslope^[k]) p).coeff n = p.coeff (n + k) := by
  induction' k with k ih generalizing p <;> first |rfl|simpa [ih]
#align formal_multilinear_series.coeff_iterate_fslope FormalMultilinearSeries.coeff_iterate_fslope

end Fslope

end FormalMultilinearSeries

section Const

/-- The formal multilinear series where all terms of positive degree are equal to zero, and the term
of degree zero is `c`. It is the power series expansion of the constant function equal to `c`
everywhere. -/
def constFormalMultilinearSeries (𝕜 : Type _) [NontriviallyNormedField 𝕜] (E : Type _)
    [NormedAddCommGroup E] [NormedSpace 𝕜 E] [ContinuousConstSMul 𝕜 E] [TopologicalAddGroup E]
    {F : Type _} [NormedAddCommGroup F] [TopologicalAddGroup F] [NormedSpace 𝕜 F]
    [ContinuousConstSMul 𝕜 F] (c : F) : FormalMultilinearSeries 𝕜 E F
  | 0 => ContinuousMultilinearMap.curry0 _ _ c
  | _ => 0
#align const_formal_multilinear_series constFormalMultilinearSeries

@[simp]
theorem constFormalMultilinearSeries_apply [NontriviallyNormedField 𝕜] [NormedAddCommGroup E]
    [NormedAddCommGroup F] [NormedSpace 𝕜 E] [NormedSpace 𝕜 F] {c : F} {n : ℕ} (hn : n ≠ 0) :
    constFormalMultilinearSeries 𝕜 E c n = 0 :=
  Nat.casesOn n (fun hn => (hn rfl).elim) (fun _ _ => rfl) hn
#align const_formal_multilinear_series_apply constFormalMultilinearSeries_apply

end Const


class CommAddSemigroup (α : Type u) extends Add α where
    addComm : {a b : α} → a + b = b + a
    addAssoc : {a b c : α} → a + b + c = a + (b + c)

open CommAddSemigroup

theorem addComm3 [CommAddSemigroup α] {a b c : α} : a + b + c = a + c + b := by {
    have h : b + c = c + b := addComm;
    have h' := congrArg (a + ·) h;
    simp at h';
    rw [←addAssoc] at h';
    rw [←addAssoc (a := a)] at h';
    exact h';
}

theorem addComm4 [CommAddSemigroup α] {a b c : α} : a + b + c = a + c + b := by {
    rw [addAssoc, addAssoc];
    rw [addComm (a := b)];
}

theorem addComm5 [CommAddSemigroup α] {a b c : α} : a + b + c = a + c + b := by {
    have h : b + c = c + b := addComm;
    have h' := congrArg (a + ·) h;
    simp at h';
    rw [←addAssoc] at h';
    rw [←@addAssoc (a := a)] at h';
    exact h';
}

theorem addComm6 [CommAddSemigroup α] {a b c : α} : a + b + c = a + c + b := by {
    have h : b + c = c + b := addComm;
    have h' := congrArg (a + ·) h;
    simp at h';
    rw [←addAssoc] at h';
    rw [←addAssoc] at h';
    exact h';
}


/-
Copyright (c) 2021 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot
-/
import analysis.normed.group.hom
import analysis.specific_limits.normed

/-! # Extending a backward bound on a normed group homomorphism from a dense set

Possible TODO (from the PR's review, https://github.com/leanprover-community/mathlib/pull/8498 ):
"This feels a lot like the second step in the proof of the Banach open mapping theorem
(`exists_preimage_norm_le`) ... wonder if it would be possible to refactor it using one of [the
lemmas in this file]."
-/

open filter finset
open_locale topology big_operators

variables {G : Type*} [normed_add_comm_group G] [complete_space G]
variables {H : Type*} [normed_add_comm_group H]

/-- Given `f : normed_add_group_hom G H` for some complete `G` and a subgroup `K` of `H`, if every
element `x` of `K` has a preimage under `f` whose norm is at most `C*‖x‖` then the same holds for
elements of the (topological) closure of `K` with constant `C+ε` instead of `C`, for any
positive `ε`.
-/
lemma controlled_closure_of_complete  {f : normed_add_group_hom G H} {K : add_subgroup H}
  {C ε : ℝ} (hC : 0 < C) (hε : 0 < ε) (hyp : f.surjective_on_with K C) :
  f.surjective_on_with K.topological_closure (C + ε) :=
begin
  rintros (h : H) (h_in : h ∈ K.topological_closure),
  /- We first get rid of the easy case where `h = 0`.-/
  by_cases hyp_h : h = 0,
  { rw hyp_h,
    use 0,
    simp },
  /- The desired preimage will be constructed as the sum of a series. Convergence of
  the series will be guaranteed by completeness of `G`. We first write `h` as the sum
  of a sequence `v` of elements of `K` which starts close to `h` and then quickly goes to zero.
  The sequence `b` below quantifies this. -/
  set b : ℕ → ℝ := λ i, (1/2)^i*(ε*‖h‖/2)/C,
  have b_pos : ∀ i, 0 < b i,
  { intro i,
    field_simp [b, hC],
    exact div_pos (mul_pos hε (norm_pos_iff.mpr hyp_h))
                  (mul_pos (by norm_num : (0 : ℝ) < 2^i*2) hC) },
  obtain ⟨v : ℕ → H, lim_v : tendsto (λ (n : ℕ), ∑ k in range (n + 1), v k) at_top (𝓝 h),
    v_in : ∀ n, v n ∈ K, hv₀ : ‖v 0 - h‖ < b 0, hv : ∀ n > 0, ‖v n‖ < b n⟩ :=
    controlled_sum_of_mem_closure h_in b_pos,
  /- The controlled surjectivity assumption on `f` allows to build preimages `u n` for all
  elements `v n` of the `v` sequence.-/
  have : ∀ n, ∃ m' : G, f m' = v n ∧ ‖m'‖ ≤ C * ‖v n‖ := λ (n : ℕ), hyp (v n) (v_in n),
  choose u hu hnorm_u using this,
  /- The desired series `s` is then obtained by summing `u`. We then check our choice of
  `b` ensures `s` is Cauchy. -/
  set s : ℕ → G := λ n, ∑ k in range (n+1), u k,
  have : cauchy_seq s,
  { apply normed_add_comm_group.cauchy_series_of_le_geometric'' (by norm_num) one_half_lt_one,
    rintro n (hn : n ≥ 1),
    calc ‖u n‖ ≤ C*‖v n‖ : hnorm_u n
    ... ≤ C * b n : mul_le_mul_of_nonneg_left (hv _ $ nat.succ_le_iff.mp hn).le hC.le
    ... = (1/2)^n * (ε * ‖h‖/2) : by simp [b, mul_div_cancel' _ hC.ne.symm]
    ... = (ε * ‖h‖/2) * (1/2)^n : mul_comm _ _ },
  /- We now show that the limit `g` of `s` is the desired preimage. -/
  obtain ⟨g : G, hg⟩ := cauchy_seq_tendsto_of_complete this,
  refine ⟨g, _, _⟩,
  { /- We indeed get a preimage. First note: -/
    have : f ∘ s = λ n, ∑ k in range (n + 1), v k,
    { ext n,
      simp [map_sum, hu] },
    /- In the above equality, the left-hand-side converges to `f g` by continuity of `f` and
       definition of `g` while the right-hand-side converges to `h` by construction of `v` so
       `g` is indeed a preimage of `h`. -/
    rw ← this at lim_v,
    exact tendsto_nhds_unique ((f.continuous.tendsto g).comp hg) lim_v },
  { /- Then we need to estimate the norm of `g`, using our careful choice of `b`. -/
    suffices : ∀ n, ‖s n‖ ≤ (C + ε) * ‖h‖,
      from le_of_tendsto' (continuous_norm.continuous_at.tendsto.comp hg) this,
    intros n,
    have hnorm₀ : ‖u 0‖ ≤ C*b 0 + C*‖h‖,
    { have := calc
      ‖v 0‖ ≤ ‖h‖ + ‖v 0 - h‖ : norm_le_insert' _ _
      ... ≤ ‖h‖ + b 0 : by apply add_le_add_left hv₀.le,
      calc ‖u 0‖ ≤ C*‖v 0‖ : hnorm_u 0
      ... ≤ C*(‖h‖ + b 0) : mul_le_mul_of_nonneg_left this hC.le
      ... = C * b 0 + C * ‖h‖ : by rw [add_comm, mul_add] },
    have : ∑ k in range (n + 1), C * b k ≤ ε * ‖h‖ := calc
      ∑ k in range (n + 1), C * b k = (∑ k in range (n + 1), (1 / 2) ^ k) * (ε * ‖h‖ / 2) :
                     by simp only [b, mul_div_cancel' _ hC.ne.symm, ← sum_mul]
      ... ≤  2 * (ε * ‖h‖ / 2) : mul_le_mul_of_nonneg_right (sum_geometric_two_le _)
                                                            (by nlinarith [hε, norm_nonneg h])
      ... = ε * ‖h‖ : mul_div_cancel' _ two_ne_zero,
    calc ‖s n‖ ≤ ∑ k in range (n+1), ‖u k‖ : norm_sum_le _ _
    ... = ∑ k in range n, ‖u (k + 1)‖ + ‖u 0‖ : sum_range_succ' _ _
    ... ≤ ∑ k in range n, C*‖v (k + 1)‖ + ‖u 0‖ : add_le_add_right (sum_le_sum (λ _ _, hnorm_u _)) _
    ... ≤ ∑ k in range n, C*b (k+1) + (C*b 0 + C*‖h‖) :
      add_le_add (sum_le_sum (λ k _, mul_le_mul_of_nonneg_left (hv _ k.succ_pos).le hC.le)) hnorm₀
    ... = ∑ k in range (n+1), C*b k + C*‖h‖ : by rw [← add_assoc, sum_range_succ']
    ... ≤ (C+ε)*‖h‖ : by { rw [add_comm, add_mul], apply add_le_add_left this } }
end

/-- Given `f : normed_add_group_hom G H` for some complete `G`, if every element `x` of the image of
an isometric immersion `j : normed_add_group_hom K H` has a preimage under `f` whose norm is at most
`C*‖x‖` then the same holds for elements of the (topological) closure of this image with constant
`C+ε` instead of `C`, for any positive `ε`.
This is useful in particular if `j` is the inclusion of a normed group into its completion
(in this case the closure is the full target group).
-/
lemma controlled_closure_range_of_complete {f : normed_add_group_hom G H}
  {K : Type*} [seminormed_add_comm_group K] {j : normed_add_group_hom K H} (hj : ∀ x, ‖j x‖ = ‖x‖)
  {C ε : ℝ} (hC : 0 < C) (hε : 0 < ε) (hyp : ∀ k, ∃ g, f g = j k ∧ ‖g‖ ≤ C*‖k‖) :
  f.surjective_on_with j.range.topological_closure (C + ε) :=
begin
  replace hyp : ∀ h ∈ j.range, ∃ g, f g = h ∧ ‖g‖ ≤ C*‖h‖,
  { intros h h_in,
    rcases (j.mem_range _).mp h_in with ⟨k, rfl⟩,
    rw hj,
    exact hyp k },
  exact controlled_closure_of_complete hC hε hyp
end


/-
Copyright (c) 2021 Manuel Candales. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Manuel Candales
-/
import data.real.basic
import data.set.finite

/-!
# IMO 2008 Q2
(a) Prove that
          ```
          x^2 / (x-1)^2 + y^2 / (y-1)^2 + z^2 / (z-1)^2 ≥ 1
          ```
for all real numbers `x`,`y`, `z`, each different from 1, and satisfying `xyz = 1`.

(b) Prove that equality holds above for infinitely many triples of rational numbers `x`, `y`, `z`,
each different from 1, and satisfying `xyz = 1`.

# Solution
(a) Since `xyz = 1`, we can apply the substitution `x = a/b`, `y = b/c`, `z = c/a`.
Then we define `m = c-b`, `n = b-a` and rewrite the inequality as `LHS - 1 ≥ 0`
using `c`, `m` and `n`. We factor `LHS - 1` as a square, which finishes the proof.

(b) We present a set `W` of rational triples. We prove that `W` is a subset of the
set of rational solutions to the equation, and that `W` is infinite.
-/

lemma subst_abc {x y z : ℝ} (h : x*y*z = 1) :
  ∃ a b c : ℝ, a ≠ 0 ∧ b ≠ 0 ∧ c ≠ 0 ∧ x = a/b ∧ y = b/c ∧ z = c /a :=
begin
  use [x, 1, 1/y],
  obtain ⟨⟨hx, hy⟩, hz⟩ : (x ≠ 0 ∧ y ≠ 0) ∧ z ≠ 0,
    by simpa [not_or_distrib] using trans_rel_right (≠) h one_ne_zero,
  have : z * (y * x) = 1, by { rw ← h, ac_refl },
  field_simp *
end

theorem imo2008_q2a (x y z : ℝ) (h : x*y*z = 1) (hx : x ≠ 1) (hy : y ≠ 1) (hz : z ≠ 1) :
  x^2 / (x-1)^2 + y^2 / (y-1)^2 + z^2 / (z-1)^2 ≥ 1 :=
begin
  obtain ⟨a, b, c, ha, hb, hc, rfl, rfl, rfl⟩ := subst_abc h,
  obtain ⟨m, n, rfl, rfl⟩ : ∃ m n, b = c - m ∧ a = c - m - n,
  { use [c - b, b - a], simp },
  have hm_ne_zero : m ≠ 0,
  { contrapose! hy, field_simp, assumption },
  have hn_ne_zero : n ≠ 0,
  { contrapose! hx, field_simp, assumption },
  have hmn_ne_zero : m + n ≠ 0,
  { contrapose! hz, field_simp, linarith },
  have hc_sub_sub : c - (c - m - n) = m + n, by abel,
  rw [ge_iff_le, ← sub_nonneg],
  convert sq_nonneg ((c*(m^2+n^2+m*n) - m*(m+n)^2) / (m*n*(m+n)) ),
  field_simp *, ring
end

def rational_solutions := { s : ℚ×ℚ×ℚ | ∃ (x y z : ℚ), s = (x, y, z) ∧
  x ≠ 1 ∧ y ≠ 1 ∧ z ≠ 1 ∧ x*y*z = 1 ∧ x^2/(x-1)^2 + y^2/(y-1)^2 + z^2/(z-1)^2 = 1 }

theorem imo2008_q2b : set.infinite rational_solutions :=
begin
  let W := { s : ℚ×ℚ×ℚ | ∃ (x y z : ℚ), s = (x, y, z) ∧
    ∃ t : ℚ, t > 0 ∧ x = -(t+1)/t^2 ∧ y = t/(t+1)^2 ∧ z = -t*(t+1)},

  have hW_sub_S : W ⊆ rational_solutions,
  { intros s hs_in_W,
    rw rational_solutions,
    simp only [set.mem_set_of_eq] at hs_in_W ⊢,
    rcases hs_in_W with ⟨x, y, z, h₁, t, ht_gt_zero, hx_t, hy_t, hz_t⟩,
    use [x, y, z],

    have ht_ne_zero  : t ≠ 0,           exact ne_of_gt ht_gt_zero,
    have ht1_ne_zero : t+1 ≠ 0,         linarith[ht_gt_zero],
    have key_gt_zero : t^2 + t + 1 > 0, linarith[pow_pos ht_gt_zero 2, ht_gt_zero],
    have key_ne_zero : t^2 + t + 1 ≠ 0, exact ne_of_gt key_gt_zero,

    have h₂ : x ≠ 1,      { rw hx_t, field_simp, linarith[key_gt_zero] },
    have h₃ : y ≠ 1,      { rw hy_t, field_simp, linarith[key_gt_zero] },
    have h₄ : z ≠ 1,      { rw hz_t, linarith[key_gt_zero] },
    have h₅ : x*y*z = 1,  { rw [hx_t, hy_t, hz_t], field_simp, ring },

    have h₆ : x^2/(x-1)^2 + y^2/(y-1)^2 + z^2/(z-1)^2 = 1,
    { have hx1 : (x - 1)^2 = (t^2 + t + 1)^2/t^4,     { field_simp, rw hx_t, field_simp, ring },
      have hy1 : (y - 1)^2 = (t^2 + t + 1)^2/(t+1)^4, { field_simp, rw hy_t, field_simp, ring },
      have hz1 : (z - 1)^2 = (t^2 + t + 1)^2,         { rw hz_t, ring },
      calc  x^2/(x-1)^2 + y^2/(y-1)^2 + z^2/(z-1)^2
          = (x^2*t^4 + y^2*(t+1)^4 + z^2)/(t^2 + t + 1)^2 :
            by { rw [hx1, hy1, hz1], field_simp }
      ... = 1 :
            by { rw [hx_t, hy_t, hz_t], field_simp, ring } },

    exact ⟨h₁, h₂, h₃, h₄, h₅, h₆⟩ },

  have hW_inf : set.infinite W,
  { let g : ℚ×ℚ×ℚ → ℚ := (λs, -s.2.2),
    let K := g '' W,

    have hK_not_bdd : ¬bdd_above K,
    { rw not_bdd_above_iff,
      intro q,
      let t : ℚ := max (q+1) 1,
      use t*(t+1),

      have h₁ : t * (t + 1) ∈ K,
      { let x : ℚ := -(t + 1)/t^2,
        let y : ℚ := t/(t+1)^2,
        set z : ℚ := -t*(t+1) with hz_def,

        simp only [set.mem_image, prod.exists],
        use [x, y, z], split,
        simp only [set.mem_set_of_eq],
        { use [x, y, z], split,
          refl,
          { use t, split,
            { simp only [gt_iff_lt, lt_max_iff], right, exact zero_lt_one },
            exact ⟨rfl, rfl, rfl⟩ } },
        { have hg : g(x, y, z) = -z := rfl,
          rw [hg, hz_def], ring } },

      have h₂ : q < t * (t + 1),
      { calc q < q + 1    : by linarith
           ... ≤ t        : le_max_left (q + 1) 1
           ... ≤ t+t^2    : by linarith [sq_nonneg t]
           ... = t*(t+1)  : by ring },

      exact ⟨h₁, h₂⟩ },

    have hK_inf : set.infinite K,
    { intro h, apply hK_not_bdd, exact set.finite.bdd_above h },

    exact hK_inf.of_image g },

  exact hW_inf.mono hW_sub_S,
end


/-
Copyright (c) 2015 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Robert Y. Lewis

! This file was ported from Lean 3 source module algebra.group_power.basic
! leanprover-community/mathlib commit 9b2660e1b25419042c8da10bf411aa3c67f14383
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Divisibility.Basic
import Mathlib.Algebra.Group.Commute
import Mathlib.Algebra.Group.TypeTags

/-!
# Power operations on monoids and groups

The power operation on monoids and groups.
We separate this from group, because it depends on `ℕ`,
which in turn depends on other parts of algebra.

This module contains lemmas about `a ^ n` and `n • a`, where `n : ℕ` or `n : ℤ`.
Further lemmas can be found in `Algebra.GroupPower.Lemmas`.

The analogous results for groups with zero can be found in `Algebra.GroupWithZero.Power`.

## Notation

- `a ^ n` is used as notation for `Pow.pow a n`; in this file `n : ℕ` or `n : ℤ`.
- `n • a` is used as notation for `SMul.smul n a`; in this file `n : ℕ` or `n : ℤ`.

## Implementation details

We adopt the convention that `0^0 = 1`.
-/

universe u v w x y z u₁ u₂

variable {α : Type _} {M : Type u} {N : Type v} {G : Type w} {H : Type x} {A : Type y} {B : Type z}
  {R : Type u₁} {S : Type u₂}

/-!
### Commutativity

First we prove some facts about `SemiconjBy` and `Commute`. They do not require any theory about
`pow` and/or `nsmul` and will be useful later in this file.
-/

section Pow

variable [Pow M ℕ]

@[simp]
theorem pow_ite (P : Prop) [Decidable P] (a : M) (b c : ℕ) :
    (a ^ if P then b else c) = if P then a ^ b else a ^ c := by split_ifs <;> rfl
#align pow_ite pow_ite

@[simp]
theorem ite_pow (P : Prop) [Decidable P] (a b : M) (c : ℕ) :
    (if P then a else b) ^ c = if P then a ^ c else b ^ c := by split_ifs <;> rfl
#align ite_pow ite_pow

end Pow

/-!
### Monoids
-/

section Monoid

variable [Monoid M] [AddMonoid A]

theorem nsmul_zero (n : ℕ) : n • (0 : A) = 0 := by
  induction' n with n ih
  · exact zero_nsmul _
  · rw [succ_nsmul, ih, add_zero]
#align nsmul_zero nsmul_zero

@[simp]
theorem one_nsmul (a : A) : 1 • a = a := by rw [succ_nsmul, zero_nsmul, add_zero]
#align one_nsmul one_nsmul

theorem add_nsmul (a : A) (m n : ℕ) : (m + n) • a = m • a + n • a := by
  induction m with
  | zero => rw [Nat.zero_add, zero_nsmul, zero_add]
  | succ m ih => rw [Nat.succ_add, Nat.succ_eq_add_one, succ_nsmul, ih, succ_nsmul, add_assoc]
#align add_nsmul add_nsmul

-- the attributes are intentionally out of order.
@[to_additive existing nsmul_zero, simp]
theorem one_pow (n : ℕ) : (1 : M) ^ n = 1 := by
  induction' n with n ih
  · exact pow_zero _
  · rw [pow_succ, ih, one_mul]
#align one_pow one_pow

@[to_additive existing (attr := simp) one_nsmul]
theorem pow_one (a : M) : a ^ 1 = a := by rw [pow_succ, pow_zero, mul_one]
#align pow_one pow_one

/-- Note that most of the lemmas about powers of two refer to it as `sq`. -/
@[to_additive two_nsmul ""]
theorem pow_two (a : M) : a ^ 2 = a * a := by rw [pow_succ, pow_one]
#align pow_two pow_two
#align two_nsmul two_nsmul

alias pow_two ← sq
#align sq sq

theorem pow_three' (a : M) : a ^ 3 = a * a * a := by rw [pow_succ', pow_two]
#align pow_three' pow_three'

theorem pow_three (a : M) : a ^ 3 = a * (a * a) := by rw [pow_succ, pow_two]
#align pow_three pow_three

@[to_additive existing add_nsmul]
theorem pow_add (a : M) (m n : ℕ) : a ^ (m + n) = a ^ m * a ^ n := by
  induction' n with n ih
  · rw [Nat.add_zero, pow_zero, mul_one]
  · rw [pow_succ', ← mul_assoc, ← ih, ← pow_succ', Nat.add_assoc]
#align pow_add pow_add

@[to_additive mul_nsmul]
theorem pow_mul (a : M) (m n : ℕ) : a ^ (m * n) = (a ^ m) ^ n := by
  induction' n with n ih
  · rw [Nat.mul_zero, pow_zero, pow_zero]
  · rw [Nat.mul_succ, pow_add, pow_succ', ih]
-- Porting note: we are taking the opportunity to swap the names `mul_nsmul` and `mul_nsmul'`
-- using #align, so that in mathlib4 they will match the multiplicative ones.
#align pow_mul pow_mul
#align mul_nsmul' mul_nsmul

@[to_additive mul_nsmul']
theorem pow_mul' (a : M) (m n : ℕ) : a ^ (m * n) = (a ^ n) ^ m := by rw [Nat.mul_comm, pow_mul]
#align pow_mul' pow_mul'
#align mul_nsmul mul_nsmul'

@[to_additive]
theorem Commute.mul_pow {a b : M} (h : Commute a b) (n : ℕ) : (a * b) ^ n = a ^ n * b ^ n := by
  induction' n with n ih
  · rw [pow_zero, pow_zero, pow_zero, one_mul]
  · simp only [pow_succ, ih, ← mul_assoc, (h.pow_left n).right_comm]
#align commute.mul_pow Commute.mul_pow
#align add_commute.add_nsmul AddCommute.add_nsmul

@[to_additive]
theorem pow_mul_comm' (a : M) (n : ℕ) : a ^ n * a = a * a ^ n :=
  Commute.pow_self a n
#align pow_mul_comm' pow_mul_comm'
#align nsmul_add_comm' nsmul_add_comm'

theorem pow_boole (P : Prop) [Decidable P] (a : M) :
    (a ^ if P then 1 else 0) = if P then a else 1 := by simp
#align pow_boole pow_boole

@[to_additive nsmul_left_comm]
theorem pow_right_comm (a : M) (m n : ℕ) : (a ^ m) ^ n = (a ^ n) ^ m := by
  rw [← pow_mul, Nat.mul_comm, pow_mul]
#align pow_right_comm pow_right_comm
#align nsmul_left_comm nsmul_left_comm

@[to_additive nsmul_add_sub_nsmul]
theorem pow_mul_pow_sub (a : M) {m n : ℕ} (h : m ≤ n) : a ^ m * a ^ (n - m) = a ^ n := by
  rw [← pow_add, Nat.add_comm, Nat.sub_add_cancel h]
#align pow_mul_pow_sub pow_mul_pow_sub
#align nsmul_add_sub_nsmul nsmul_add_sub_nsmul

@[to_additive sub_nsmul_nsmul_add]
theorem pow_sub_mul_pow (a : M) {m n : ℕ} (h : m ≤ n) : a ^ (n - m) * a ^ m = a ^ n := by
  rw [← pow_add, Nat.sub_add_cancel h]
#align pow_sub_mul_pow pow_sub_mul_pow
#align sub_nsmul_nsmul_add sub_nsmul_nsmul_add

/-- If `x ^ n = 1`, then `x ^ m` is the same as `x ^ (m % n)` -/
@[to_additive nsmul_eq_mod_nsmul "If `n • x = 0`, then `m • x` is the same as `(m % n) • x`"]
theorem pow_eq_pow_mod {M : Type _} [Monoid M] {x : M} (m : ℕ) {n : ℕ} (h : x ^ n = 1) :
    x ^ m = x ^ (m % n) := by
  have t : x ^ m = x ^ (n * (m / n) + m % n) :=
    congr_arg (fun a => x ^ a) ((Nat.add_comm _ _).trans (Nat.mod_add_div _ _)).symm
  dsimp at t
  rw [t, pow_add, pow_mul, h, one_pow, one_mul]
#align pow_eq_pow_mod pow_eq_pow_mod
#align nsmul_eq_mod_nsmul nsmul_eq_mod_nsmul

@[to_additive]
theorem pow_mul_comm (a : M) (m n : ℕ) : a ^ m * a ^ n = a ^ n * a ^ m :=
  Commute.pow_pow_self a m n
#align pow_mul_comm pow_mul_comm
#align nsmul_add_comm nsmul_add_comm

section Bit

set_option linter.deprecated false

@[to_additive bit0_nsmul]
theorem pow_bit0 (a : M) (n : ℕ) : a ^ bit0 n = a ^ n * a ^ n :=
  pow_add _ _ _
#align pow_bit0 pow_bit0
#align bit0_nsmul bit0_nsmul

@[to_additive bit1_nsmul]
theorem pow_bit1 (a : M) (n : ℕ) : a ^ bit1 n = a ^ n * a ^ n * a := by
  rw [bit1, pow_succ', pow_bit0]
#align pow_bit1 pow_bit1
#align bit1_nsmul bit1_nsmul

@[to_additive bit0_nsmul']
theorem pow_bit0' (a : M) (n : ℕ) : a ^ bit0 n = (a * a) ^ n := by
  rw [pow_bit0, (Commute.refl a).mul_pow]
#align pow_bit0' pow_bit0'
#align bit0_nsmul' bit0_nsmul'

@[to_additive bit1_nsmul']
theorem pow_bit1' (a : M) (n : ℕ) : a ^ bit1 n = (a * a) ^ n * a := by
  rw [bit1, pow_succ', pow_bit0']
#align pow_bit1' pow_bit1'
#align bit1_nsmul' bit1_nsmul'

end Bit

@[to_additive]
theorem pow_mul_pow_eq_one {a b : M} (n : ℕ) (h : a * b = 1) : a ^ n * b ^ n = 1 := by
  induction' n with n hn
  · simp
  · calc
      a ^ n.succ * b ^ n.succ = a ^ n * a * (b * b ^ n) := by rw [pow_succ', pow_succ]
      _ = a ^ n * (a * b) * b ^ n := by simp only [mul_assoc]
      _ = 1 := by simp [h, hn]
#align pow_mul_pow_eq_one pow_mul_pow_eq_one
#align nsmul_add_nsmul_eq_zero nsmul_add_nsmul_eq_zero

theorem dvd_pow {x y : M} (hxy : x ∣ y) : ∀ {n : ℕ} (_ : n ≠ 0), x ∣ y ^ n
  | 0,     hn => (hn rfl).elim
  | n + 1, _  => by
    rw [pow_succ]
    exact hxy.mul_right _
#align dvd_pow dvd_pow

alias dvd_pow ← Dvd.dvd.pow

theorem dvd_pow_self (a : M) {n : ℕ} (hn : n ≠ 0) : a ∣ a ^ n :=
  dvd_rfl.pow hn
#align dvd_pow_self dvd_pow_self

end Monoid

/-!
### Commutative (additive) monoid
-/

section CommMonoid

variable [CommMonoid M] [AddCommMonoid A]

@[to_additive nsmul_add]
theorem mul_pow (a b : M) (n : ℕ) : (a * b) ^ n = a ^ n * b ^ n :=
  (Commute.all a b).mul_pow n
#align mul_pow mul_pow
#align nsmul_add nsmul_add

/-- The `n`th power map on a commutative monoid for a natural `n`, considered as a morphism of
monoids. -/
@[to_additive (attr := simps)
      "Multiplication by a natural `n` on a commutative additive
       monoid, considered as a morphism of additive monoids."]
def powMonoidHom (n : ℕ) : M →* M where
  toFun := (· ^ n)
  map_one' := one_pow _
  map_mul' a b := mul_pow a b n
#align pow_monoid_hom powMonoidHom
#align nsmul_add_monoid_hom nsmulAddMonoidHom
#align pow_monoid_hom_apply powMonoidHom_apply
#align nsmul_add_monoid_hom_apply nsmulAddMonoidHom_apply

end CommMonoid

section DivInvMonoid

variable [DivInvMonoid G]

open Int

@[to_additive (attr := simp) one_zsmul]
theorem zpow_one (a : G) : a ^ (1 : ℤ) = a := by
  convert pow_one a using 1
  exact zpow_ofNat a 1
#align zpow_one zpow_one
#align one_zsmul one_zsmul

@[to_additive two_zsmul]
theorem zpow_two (a : G) : a ^ (2 : ℤ) = a * a := by
  convert pow_two a using 1
  exact zpow_ofNat a 2
#align zpow_two zpow_two
#align two_zsmul two_zsmul

@[to_additive neg_one_zsmul]
theorem zpow_neg_one (x : G) : x ^ (-1 : ℤ) = x⁻¹ :=
  (zpow_negSucc x 0).trans <| congr_arg Inv.inv (pow_one x)
#align zpow_neg_one zpow_neg_one
#align neg_one_zsmul neg_one_zsmul

@[to_additive]
theorem zpow_neg_coe_of_pos (a : G) : ∀ {n : ℕ}, 0 < n → a ^ (-(n : ℤ)) = (a ^ n)⁻¹
  | _ + 1, _ => zpow_negSucc _ _
#align zpow_neg_coe_of_pos zpow_neg_coe_of_pos
#align zsmul_neg_coe_of_pos zsmul_neg_coe_of_pos

end DivInvMonoid

section DivisionMonoid

variable [DivisionMonoid α] {a b : α}

@[to_additive (attr := simp)]
theorem inv_pow (a : α) : ∀ n : ℕ, a⁻¹ ^ n = (a ^ n)⁻¹
  | 0 => by rw [pow_zero, pow_zero, inv_one]
  | n + 1 => by rw [pow_succ', pow_succ, inv_pow _ n, mul_inv_rev]
#align inv_pow inv_pow
#align neg_nsmul neg_nsmul

-- the attributes are intentionally out of order. `smul_zero` proves `zsmul_zero`.
@[to_additive zsmul_zero, simp]
theorem one_zpow : ∀ n : ℤ, (1 : α) ^ n = 1
  | (n : ℕ)       => by rw [zpow_ofNat, one_pow]
  | .negSucc n => by rw [zpow_negSucc, one_pow, inv_one]
#align one_zpow one_zpow
#align zsmul_zero zsmul_zero

@[to_additive (attr := simp) neg_zsmul]
theorem zpow_neg (a : α) : ∀ n : ℤ, a ^ (-n) = (a ^ n)⁻¹
  | (n + 1 : ℕ) => DivInvMonoid.zpow_neg' _ _
  | 0 => by
    change a ^ (0 : ℤ) = (a ^ (0 : ℤ))⁻¹
    simp
  | Int.negSucc n => by
    rw [zpow_negSucc, inv_inv, ← zpow_ofNat]
    rfl
#align zpow_neg zpow_neg
#align neg_zsmul neg_zsmul

@[to_additive neg_one_zsmul_add]
theorem mul_zpow_neg_one (a b : α) : (a * b) ^ (-1 : ℤ) = b ^ (-1 : ℤ) * a ^ (-1 : ℤ) := by
  simp only [zpow_neg, zpow_one, mul_inv_rev]
#align mul_zpow_neg_one mul_zpow_neg_one
#align neg_one_zsmul_add neg_one_zsmul_add

@[to_additive zsmul_neg]
theorem inv_zpow (a : α) : ∀ n : ℤ, a⁻¹ ^ n = (a ^ n)⁻¹
  | (n : ℕ)    => by rw [zpow_ofNat, zpow_ofNat, inv_pow]
  | .negSucc n => by rw [zpow_negSucc, zpow_negSucc, inv_pow]
#align inv_zpow inv_zpow
#align zsmul_neg zsmul_neg

@[to_additive (attr := simp) zsmul_neg']
theorem inv_zpow' (a : α) (n : ℤ) : a⁻¹ ^ n = a ^ (-n) := by rw [inv_zpow, zpow_neg]
#align inv_zpow' inv_zpow'
#align zsmul_neg' zsmul_neg'

@[to_additive nsmul_zero_sub]
theorem one_div_pow (a : α) (n : ℕ) : (1 / a) ^ n = 1 / a ^ n := by simp only [one_div, inv_pow]
#align one_div_pow one_div_pow
#align nsmul_zero_sub nsmul_zero_sub

@[to_additive zsmul_zero_sub]
theorem one_div_zpow (a : α) (n : ℤ) : (1 / a) ^ n = 1 / a ^ n := by simp only [one_div, inv_zpow]
#align one_div_zpow one_div_zpow
#align zsmul_zero_sub zsmul_zero_sub

@[to_additive AddCommute.zsmul_add]
protected theorem Commute.mul_zpow (h : Commute a b) : ∀ i : ℤ, (a * b) ^ i = a ^ i * b ^ i
  | (n : ℕ)    => by simp [zpow_ofNat, h.mul_pow n]
  | .negSucc n => by simp [h.mul_pow, (h.pow_pow _ _).eq, mul_inv_rev]
#align commute.mul_zpow Commute.mul_zpow
#align add_commute.zsmul_add AddCommute.zsmul_add

end DivisionMonoid

section DivisionCommMonoid

variable [DivisionCommMonoid α]

@[to_additive zsmul_add]
theorem mul_zpow (a b : α) : ∀ n : ℤ, (a * b) ^ n = a ^ n * b ^ n :=
  (Commute.all a b).mul_zpow
#align mul_zpow mul_zpow
#align zsmul_add zsmul_add

@[to_additive (attr := simp) nsmul_sub]
theorem div_pow (a b : α) (n : ℕ) : (a / b) ^ n = a ^ n / b ^ n := by
  simp only [div_eq_mul_inv, mul_pow, inv_pow]
#align div_pow div_pow
#align nsmul_sub nsmul_sub

@[to_additive (attr := simp) zsmul_sub]
theorem div_zpow (a b : α) (n : ℤ) : (a / b) ^ n = a ^ n / b ^ n := by
  simp only [div_eq_mul_inv, mul_zpow, inv_zpow]
#align div_zpow div_zpow
#align zsmul_sub zsmul_sub

/-- The `n`-th power map (for an integer `n`) on a commutative group, considered as a group
homomorphism. -/
@[to_additive (attr := simps)
      "Multiplication by an integer `n` on a commutative additive group, considered as an
       additive group homomorphism."]
def zpowGroupHom (n : ℤ) : α →* α where
  toFun := (· ^ n)
  map_one' := one_zpow n
  map_mul' a b := mul_zpow a b n
#align zpow_group_hom zpowGroupHom
#align zsmul_add_group_hom zsmulAddGroupHom
#align zpow_group_hom_apply zpowGroupHom_apply
#align zsmul_add_group_hom_apply zsmulAddGroupHom_apply

end DivisionCommMonoid

section Group

variable [Group G] [Group H] [AddGroup A] [AddGroup B]

@[to_additive sub_nsmul]
theorem pow_sub (a : G) {m n : ℕ} (h : n ≤ m) : a ^ (m - n) = a ^ m * (a ^ n)⁻¹ :=
  eq_mul_inv_of_mul_eq <| by rw [← pow_add, Nat.sub_add_cancel h]
#align pow_sub pow_sub
#align sub_nsmul sub_nsmul

@[to_additive]
theorem pow_inv_comm (a : G) (m n : ℕ) : a⁻¹ ^ m * a ^ n = a ^ n * a⁻¹ ^ m :=
  (Commute.refl a).inv_left.pow_pow _ _
#align pow_inv_comm pow_inv_comm
#align nsmul_neg_comm nsmul_neg_comm

@[to_additive sub_nsmul_neg]
theorem inv_pow_sub (a : G) {m n : ℕ} (h : n ≤ m) : a⁻¹ ^ (m - n) = (a ^ m)⁻¹ * a ^ n := by
  rw [pow_sub a⁻¹ h, inv_pow, inv_pow, inv_inv]
#align inv_pow_sub inv_pow_sub
#align sub_nsmul_neg sub_nsmul_neg

end Group

theorem pow_dvd_pow [Monoid R] (a : R) {m n : ℕ} (h : m ≤ n) : a ^ m ∣ a ^ n :=
  ⟨a ^ (n - m), by rw [← pow_add, Nat.add_comm, Nat.sub_add_cancel h]⟩
#align pow_dvd_pow pow_dvd_pow

theorem ofAdd_nsmul [AddMonoid A] (x : A) (n : ℕ) :
    Multiplicative.ofAdd (n • x) = Multiplicative.ofAdd x ^ n :=
  rfl
#align of_add_nsmul ofAdd_nsmul

theorem ofAdd_zsmul [SubNegMonoid A] (x : A) (n : ℤ) :
    Multiplicative.ofAdd (n • x) = Multiplicative.ofAdd x ^ n :=
  rfl
#align of_add_zsmul ofAdd_zsmul

theorem ofMul_pow [Monoid A] (x : A) (n : ℕ) : Additive.ofMul (x ^ n) = n • Additive.ofMul x :=
  rfl
#align of_mul_pow ofMul_pow

theorem ofMul_zpow [DivInvMonoid G] (x : G) (n : ℤ) :
    Additive.ofMul (x ^ n) = n • Additive.ofMul x :=
  rfl
#align of_mul_zpow ofMul_zpow

@[to_additive (attr := simp)]
theorem SemiconjBy.zpow_right [Group G] {a x y : G} (h : SemiconjBy a x y) :
    ∀ m : ℤ, SemiconjBy a (x ^ m) (y ^ m)
  | (n : ℕ)    => by simp [zpow_ofNat, h.pow_right n]
  | .negSucc n => by
    simp only [zpow_negSucc, inv_right_iff]
    apply pow_right h
#align semiconj_by.zpow_right SemiconjBy.zpow_right
#align add_semiconj_by.zsmul_right AddSemiconjBy.zsmul_right

namespace Commute

variable [Group G] {a b : G}

@[to_additive (attr := simp)]
theorem zpow_right (h : Commute a b) (m : ℤ) : Commute a (b ^ m) :=
  SemiconjBy.zpow_right h m
#align commute.zpow_right Commute.zpow_right
#align add_commute.zsmul_right AddCommute.zsmul_right

@[to_additive (attr := simp)]
theorem zpow_left (h : Commute a b) (m : ℤ) : Commute (a ^ m) b :=
  (h.symm.zpow_right m).symm
#align commute.zpow_left Commute.zpow_left
#align add_commute.zsmul_left AddCommute.zsmul_left

@[to_additive]
theorem zpow_zpow (h : Commute a b) (m n : ℤ) : Commute (a ^ m) (b ^ n) :=
  (h.zpow_left m).zpow_right n
#align commute.zpow_zpow Commute.zpow_zpow
#align add_commute.zsmul_zsmul AddCommute.zsmul_zsmul

variable (a) (m n : ℤ)

@[to_additive]
theorem self_zpow : Commute a (a ^ n) :=
  (Commute.refl a).zpow_right n
#align commute.self_zpow Commute.self_zpow
#align add_commute.self_zsmul AddCommute.self_zsmul

@[to_additive]
theorem zpow_self : Commute (a ^ n) a :=
  (Commute.refl a).zpow_left n
#align commute.zpow_self Commute.zpow_self
#align add_commute.zsmul_self AddCommute.zsmul_self

@[to_additive]
theorem zpow_zpow_self : Commute (a ^ m) (a ^ n) :=
  (Commute.refl a).zpow_zpow m n
#align commute.zpow_zpow_self Commute.zpow_zpow_self
#align add_commute.zsmul_zsmul_self AddCommute.zsmul_zsmul_self

end Commute


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

Disjointed sets
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.set.lattice
import Mathlib.tactic.wlog
import Mathlib.PostPort

universes u_1 u v

namespace Mathlib

/-- A relation `p` holds pairwise if `p i j` for all `i ≠ j`. -/
def pairwise {α : Type u_1} (p : α → α → Prop) :=
  ∀ (i j : α), i ≠ j → p i j

theorem set.pairwise_on_univ {α : Type u} {r : α → α → Prop} : set.pairwise_on set.univ r ↔ pairwise r := sorry

theorem set.pairwise_on.on_injective {α : Type u} {β : Type v} {s : set α} {r : α → α → Prop} (hs : set.pairwise_on s r) {f : β → α} (hf : function.injective f) (hfs : ∀ (x : β), f x ∈ s) : pairwise (r on f) :=
  fun (i j : β) (hij : i ≠ j) => hs (f i) (hfs i) (f j) (hfs j) (function.injective.ne hf hij)

theorem pairwise.mono {α : Type u} {p : α → α → Prop} {q : α → α → Prop} (h : ∀ {i j : α}, p i j → q i j) (hp : pairwise p) : pairwise q :=
  fun (i j : α) (hij : i ≠ j) => h (hp i j hij)

theorem pairwise_on_bool {α : Type u} {r : α → α → Prop} (hr : symmetric r) {a : α} {b : α} : pairwise (r on fun (c : Bool) => cond c a b) ↔ r a b := sorry

theorem pairwise_disjoint_on_bool {α : Type u} [semilattice_inf_bot α] {a : α} {b : α} : pairwise (disjoint on fun (c : Bool) => cond c a b) ↔ disjoint a b :=
  pairwise_on_bool disjoint.symm

theorem pairwise.pairwise_on {α : Type u} {p : α → α → Prop} (h : pairwise p) (s : set α) : set.pairwise_on s p :=
  fun (x : α) (hx : x ∈ s) (y : α) (hy : y ∈ s) => h x y

theorem pairwise_disjoint_fiber {α : Type u} {β : Type v} (f : α → β) : pairwise (disjoint on fun (y : β) => f ⁻¹' singleton y) :=
  iff.mp set.pairwise_on_univ (set.pairwise_on_disjoint_fiber f set.univ)

namespace set

/-- If `f : ℕ → set α` is a sequence of sets, then `disjointed f` is
  the sequence formed with each set subtracted from the later ones
  in the sequence, to form a disjoint sequence. -/
def disjointed {α : Type u} (f : ℕ → set α) (n : ℕ) : set α :=
  f n ∩ Inter fun (i : ℕ) => Inter fun (H : i < n) => f iᶜ

theorem disjoint_disjointed {α : Type u} {f : ℕ → set α} : pairwise (disjoint on disjointed f) := sorry

theorem disjoint_disjointed' {α : Type u} {f : ℕ → set α} (i : ℕ) (j : ℕ) : i ≠ j → disjointed f i ∩ disjointed f j = ∅ :=
  fun (hij : i ≠ j) => iff.mp disjoint_iff (disjoint_disjointed i j hij)

theorem disjointed_subset {α : Type u} {f : ℕ → set α} {n : ℕ} : disjointed f n ⊆ f n :=
  inter_subset_left (f n) (Inter fun (i : ℕ) => Inter fun (H : i < n) => f iᶜ)

theorem Union_lt_succ {α : Type u} {f : ℕ → set α} {n : ℕ} : (Union fun (i : ℕ) => Union fun (H : i < Nat.succ n) => f i) = f n ∪ Union fun (i : ℕ) => Union fun (H : i < n) => f i := sorry

theorem Inter_lt_succ {α : Type u} {f : ℕ → set α} {n : ℕ} : (Inter fun (i : ℕ) => Inter fun (H : i < Nat.succ n) => f i) = f n ∩ Inter fun (i : ℕ) => Inter fun (H : i < n) => f i := sorry

theorem subset_Union_disjointed {α : Type u} {f : ℕ → set α} {n : ℕ} : f n ⊆ Union fun (i : ℕ) => Union fun (H : i < Nat.succ n) => disjointed f i := sorry

theorem Union_disjointed {α : Type u} {f : ℕ → set α} : (Union fun (n : ℕ) => disjointed f n) = Union fun (n : ℕ) => f n := sorry

theorem disjointed_induct {α : Type u} {f : ℕ → set α} {n : ℕ} {p : set α → Prop} (h₁ : p (f n)) (h₂ : ∀ (t : set α) (i : ℕ), p t → p (t \ f i)) : p (disjointed f n) := sorry

theorem disjointed_of_mono {α : Type u} {f : ℕ → set α} {n : ℕ} (hf : monotone f) : disjointed f (n + 1) = f (n + 1) \ f n := sorry

theorem Union_disjointed_of_mono {α : Type u} {f : ℕ → set α} (hf : monotone f) (n : ℕ) : (Union fun (i : ℕ) => Union fun (H : i < Nat.succ n) => disjointed f i) = f n := sorry


/-
Copyright (c) 2022 Junyan Xu. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Junyan Xu
-/
import data.dfinsupp.lex
import order.game_add
import order.antisymmetrization
import set_theory.ordinal.basic

/-!
# Well-foundedness of the lexicographic and product orders on `dfinsupp` and `pi`

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

The primary results are `dfinsupp.lex.well_founded` and the two variants that follow it,
which essentially say that if `(>)` is a well order on `ι`, `(<)` is well-founded on each
`α i`, and `0` is a bottom element in `α i`, then the lexicographic `(<)` is well-founded
on `Π₀ i, α i`. The proof is modelled on the proof of `well_founded.cut_expand`.

The results are used to prove `pi.lex.well_founded` and two variants, which say that if
`ι` is finite and equipped with a linear order and `(<)` is well-founded on each `α i`,
then the lexicographic `(<)` is well-founded on `Π i, α i`, and the same is true for
`Π₀ i, α i` (`dfinsupp.lex.well_founded_of_finite`), because `dfinsupp` is order-isomorphic
to `pi` when `ι` is finite.

Finally, we deduce `dfinsupp.well_founded_lt`, `pi.well_founded_lt`,
`dfinsupp.well_founded_lt_of_finite` and variants, which concern the product order
rather than the lexicographic one. An order on `ι` is not required in these results,
but we deduce them from the well-foundedness of the lexicographic order by choosing
a well order on `ι` so that the product order `(<)` becomes a subrelation
of the lexicographic `(<)`.

All results are provided in two forms whenever possible: a general form where the relations
can be arbitrary (not the `(<)` of a preorder, or not even transitive, etc.) and a specialized
form provided as `well_founded_lt` instances where the `(d)finsupp/pi` type (or their `lex`
type synonyms) carries a natural `(<)`.

Notice that the definition of `dfinsupp.lex` says that `x < y` according to `dfinsupp.lex r s`
iff there exists a coordinate `i : ι` such that `x i < y i` according to `s i`, and at all
`r`-smaller coordinates `j` (i.e. satisfying `r j i`), `x` remains unchanged relative to `y`;
in other words, coordinates `j` such that `¬ r j i` and `j ≠ i` are exactly where changes
can happen arbitrarily. This explains the appearance of `rᶜ ⊓ (≠)` in
`dfinsupp.acc_single` and `dfinsupp.well_founded`. When `r` is trichotomous (e.g. the `(<)`
of a linear order), `¬ r j i ∧ j ≠ i` implies `r i j`, so it suffices to require `r.swap`
to be well-founded.
-/

variables {ι : Type*} {α : ι → Type*}

namespace dfinsupp

variables [hz : Π i, has_zero (α i)] (r : ι → ι → Prop) (s : Π i, α i → α i → Prop)
include hz

open relation prod

/-- This key lemma says that if a finitely supported dependent function `x₀` is obtained by merging
  two such functions `x₁` and `x₂`, and if we evolve `x₀` down the `dfinsupp.lex` relation one
  step and get `x`, we can always evolve one of `x₁` and `x₂` down the `dfinsupp.lex` relation
  one step while keeping the other unchanged, and merge them back (possibly in a different way)
  to get back `x`. In other words, the two parts evolve essentially independently under
  `dfinsupp.lex`. This is used to show that a function `x` is accessible if
  `dfinsupp.single i (x i)` is accessible for each `i` in the (finite) support of `x`
  (`dfinsupp.lex.acc_of_single`). -/
lemma lex_fibration [Π i (s : set ι), decidable (i ∈ s)] : fibration
  (inv_image (game_add (dfinsupp.lex r s) (dfinsupp.lex r s)) snd)
  (dfinsupp.lex r s)
  (λ x, piecewise x.2.1 x.2.2 x.1) :=
begin
  rintro ⟨p, x₁, x₂⟩ x ⟨i, hr, hs⟩,
  simp_rw [piecewise_apply] at hs hr,
  split_ifs at hs, classical,
  work_on_goal 1
  { refine ⟨⟨{j | r j i → j ∈ p}, piecewise x₁ x {j | r j i}, x₂⟩, game_add.fst ⟨i, _⟩, _⟩ },
  work_on_goal 3
  { refine ⟨⟨{j | r j i ∧ j ∈ p}, x₁, piecewise x₂ x {j | r j i}⟩, game_add.snd ⟨i, _⟩, _⟩ },
  swap 3, iterate 2
  { simp_rw piecewise_apply,
    refine ⟨λ j h, if_pos h, _⟩,
    convert hs,
    refine ite_eq_right_iff.2 (λ h', (hr i h').symm ▸ _),
    rw if_neg h <|> rw if_pos h },
  all_goals { ext j, simp_rw piecewise_apply, split_ifs with h₁ h₂ },
  { rw [hr j h₂, if_pos (h₁ h₂)] },
  { refl },
  { rw [set.mem_set_of, not_imp] at h₁, rw [hr j h₁.1, if_neg h₁.2] },
  { rw [hr j h₁.1, if_pos h₁.2] },
  { rw [hr j h₂, if_neg (λ h', h₁ ⟨h₂, h'⟩)] },
  { refl },
end

variables {r s}

lemma lex.acc_of_single_erase [decidable_eq ι] {x : Π₀ i, α i} (i : ι)
  (hs : acc (dfinsupp.lex r s) $ single i (x i))
  (hu : acc (dfinsupp.lex r s) $ x.erase i) : acc (dfinsupp.lex r s) x :=
begin
  classical,
  convert ← @acc.of_fibration _ _ _ _ _
    (lex_fibration r s) ⟨{i}, _⟩ (inv_image.accessible snd $ hs.prod_game_add hu),
  convert piecewise_single_erase x i,
end

variable (hbot : ∀ ⦃i a⦄, ¬ s i a 0)
include hbot

lemma lex.acc_zero : acc (dfinsupp.lex r s) 0 := acc.intro 0 $ λ x ⟨_, _, h⟩, (hbot h).elim

lemma lex.acc_of_single [decidable_eq ι] [Π i (x : α i), decidable (x ≠ 0)] (x : Π₀ i, α i) :
  (∀ i ∈ x.support, acc (dfinsupp.lex r s) $ single i (x i)) → acc (dfinsupp.lex r s) x :=
begin
  generalize ht : x.support = t, revert x, classical,
  induction t using finset.induction with b t hb ih,
  { intros x ht, rw support_eq_empty.1 ht, exact λ _, lex.acc_zero hbot },
  refine λ x ht h, lex.acc_of_single_erase b (h b $ t.mem_insert_self b) _,
  refine ih _ (by rw [support_erase, ht, finset.erase_insert hb]) (λ a ha, _),
  rw [erase_ne (ha.ne_of_not_mem hb)],
  exact h a (finset.mem_insert_of_mem ha),
end

variable (hs : ∀ i, well_founded (s i))
include hs

lemma lex.acc_single [decidable_eq ι] {i : ι} (hi : acc (rᶜ ⊓ (≠)) i) :
  ∀ a, acc (dfinsupp.lex r s) (single i a) :=
begin
  induction hi with i hi ih,
  refine λ a, (hs i).induction a (λ a ha, _),
  refine acc.intro _ (λ x, _),
  rintro ⟨k, hr, hs⟩, classical,
  rw single_apply at hs,
  split_ifs at hs with hik,
  swap, { exact (hbot hs).elim }, subst hik,
  refine lex.acc_of_single hbot x (λ j hj, _),
  obtain rfl | hij := eq_or_ne i j, { exact ha _ hs },
  by_cases r j i,
  { rw [hr j h, single_eq_of_ne hij, single_zero], exact lex.acc_zero hbot },
  { exact ih _ ⟨h, hij.symm⟩ _ },
end

lemma lex.acc [decidable_eq ι] [Π i (x : α i), decidable (x ≠ 0)] (x : Π₀ i, α i)
  (h : ∀ i ∈ x.support, acc (rᶜ ⊓ (≠)) i) : acc (dfinsupp.lex r s) x :=
lex.acc_of_single hbot x $ λ i hi, lex.acc_single hbot hs (h i hi) _

theorem lex.well_founded (hr : well_founded $ rᶜ ⊓ (≠)) : well_founded (dfinsupp.lex r s) :=
⟨λ x, by classical; exact lex.acc hbot hs x (λ i _, hr.apply i)⟩

theorem lex.well_founded' [is_trichotomous ι r]
  (hr : well_founded r.swap) : well_founded (dfinsupp.lex r s) :=
lex.well_founded hbot hs $ subrelation.wf
  (λ i j h, ((@is_trichotomous.trichotomous ι r _ i j).resolve_left h.1).resolve_left h.2) hr

omit hz hbot hs

instance lex.well_founded_lt [has_lt ι] [is_trichotomous ι (<)]
  [hι : well_founded_gt ι] [Π i, canonically_ordered_add_monoid (α i)]
  [hα : ∀ i, well_founded_lt (α i)] : well_founded_lt (lex (Π₀ i, α i)) :=
⟨lex.well_founded' (λ i a, (zero_le a).not_lt) (λ i, (hα i).wf) hι.wf⟩

end dfinsupp

open dfinsupp

variables (r : ι → ι → Prop) {s : Π i, α i → α i → Prop}

theorem pi.lex.well_founded [is_strict_total_order ι r] [finite ι]
  (hs : ∀ i, well_founded (s i)) : well_founded (pi.lex r s) :=
begin
  obtain h | ⟨⟨x⟩⟩ := is_empty_or_nonempty (Π i, α i),
  { convert empty_wf, ext1 x, exact (h.1 x).elim },
  letI : Π i, has_zero (α i) := λ i, ⟨(hs i).min ⊤ ⟨x i, trivial⟩⟩,
  haveI := is_trans.swap r, haveI := is_irrefl.swap r, haveI := fintype.of_finite ι,
  refine inv_image.wf equiv_fun_on_fintype.symm (lex.well_founded' (λ i a, _) hs _),
  exacts [(hs i).not_lt_min ⊤ _ trivial, finite.well_founded_of_trans_of_irrefl r.swap],
end

instance pi.lex.well_founded_lt [linear_order ι] [finite ι] [Π i, has_lt (α i)]
  [hwf : ∀ i, well_founded_lt (α i)] : well_founded_lt (lex (Π i, α i)) :=
⟨pi.lex.well_founded (<) (λ i, (hwf i).1)⟩

instance function.lex.well_founded_lt {α} [linear_order ι] [finite ι] [has_lt α]
  [well_founded_lt α] : well_founded_lt (lex (ι → α)) := pi.lex.well_founded_lt

theorem dfinsupp.lex.well_founded_of_finite [is_strict_total_order ι r] [finite ι]
  [Π i, has_zero (α i)] (hs : ∀ i, well_founded (s i)) : well_founded (dfinsupp.lex r s) :=
have _ := fintype.of_finite ι,
  by exactI inv_image.wf equiv_fun_on_fintype (pi.lex.well_founded r hs)

instance dfinsupp.lex.well_founded_lt_of_finite [linear_order ι] [finite ι] [Π i, has_zero (α i)]
  [Π i, has_lt (α i)] [hwf : ∀ i, well_founded_lt (α i)] : well_founded_lt (lex (Π₀ i, α i)) :=
⟨dfinsupp.lex.well_founded_of_finite (<) $ λ i, (hwf i).1⟩

protected theorem dfinsupp.well_founded_lt [Π i, has_zero (α i)] [Π i, preorder (α i)]
  [∀ i, well_founded_lt (α i)] (hbot : ∀ ⦃i⦄ ⦃a : α i⦄, ¬ a < 0) : well_founded_lt (Π₀ i, α i) :=
⟨begin
  letI : Π i, has_zero (antisymmetrization (α i) (≤)) := λ i, ⟨to_antisymmetrization (≤) 0⟩,
  let f := map_range (λ i, @to_antisymmetrization (α i) (≤) _) (λ i, rfl),
  refine subrelation.wf (λ x y h, _) (inv_image.wf f $ lex.well_founded' _ (λ i, _) _),
  { exact well_ordering_rel.swap }, { exact λ i, (<) },
  { haveI := is_strict_order.swap (@well_ordering_rel ι),
    obtain ⟨i, he, hl⟩ := lex_lt_of_lt_of_preorder well_ordering_rel.swap h,
    exact ⟨i, λ j hj, quot.sound (he j hj), hl⟩ },
  { rintro i ⟨a⟩, apply hbot },
  exacts [is_well_founded.wf, is_trichotomous.swap _, is_well_founded.wf],
end⟩

instance dfinsupp.well_founded_lt' [Π i, canonically_ordered_add_monoid (α i)]
  [∀ i, well_founded_lt (α i)] : well_founded_lt (Π₀ i, α i) :=
dfinsupp.well_founded_lt $ λ i a, (zero_le a).not_lt

instance pi.well_founded_lt [finite ι] [Π i, preorder (α i)]
  [hw : ∀ i, well_founded_lt (α i)] : well_founded_lt (Π i, α i) :=
⟨begin
  obtain h | ⟨⟨x⟩⟩ := is_empty_or_nonempty (Π i, α i),
  { convert empty_wf, ext1 x, exact (h.1 x).elim },
  letI : Π i, has_zero (α i) := λ i, ⟨(hw i).wf.min ⊤ ⟨x i, trivial⟩⟩,
  haveI := fintype.of_finite ι,
  refine inv_image.wf equiv_fun_on_fintype.symm (dfinsupp.well_founded_lt $ λ i a, _).wf,
  exact (hw i).wf.not_lt_min ⊤ _ trivial,
end⟩

instance function.well_founded_lt {α} [finite ι] [preorder α]
  [well_founded_lt α] : well_founded_lt (ι → α) := pi.well_founded_lt

instance dfinsupp.well_founded_lt_of_finite [finite ι] [Π i, has_zero (α i)] [Π i, preorder (α i)]
  [∀ i, well_founded_lt (α i)] : well_founded_lt (Π₀ i, α i) :=
have _ := fintype.of_finite ι,
  by exactI ⟨inv_image.wf equiv_fun_on_fintype pi.well_founded_lt.wf⟩


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.multiset.nodup

/-!
# Erasing duplicates in a multiset.

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

namespace multiset
open list

variables {α β : Type*} [decidable_eq α]

/-! ### dedup -/

/-- `dedup s` removes duplicates from `s`, yielding a `nodup` multiset. -/
def dedup (s : multiset α) : multiset α :=
quot.lift_on s (λ l, (l.dedup : multiset α))
  (λ s t p, quot.sound p.dedup)

@[simp] theorem coe_dedup (l : list α) : @dedup α _ l = l.dedup := rfl

@[simp] theorem dedup_zero : @dedup α _ 0 = 0 := rfl

@[simp] theorem mem_dedup {a : α} {s : multiset α} : a ∈ dedup s ↔ a ∈ s :=
quot.induction_on s $ λ l, mem_dedup

@[simp] theorem dedup_cons_of_mem {a : α} {s : multiset α} : a ∈ s →
  dedup (a ::ₘ s) = dedup s :=
quot.induction_on s $ λ l m, @congr_arg _ _ _ _ coe $ dedup_cons_of_mem m

@[simp] theorem dedup_cons_of_not_mem {a : α} {s : multiset α} : a ∉ s →
  dedup (a ::ₘ s) = a ::ₘ dedup s :=
quot.induction_on s $ λ l m, congr_arg coe $ dedup_cons_of_not_mem m

theorem dedup_le (s : multiset α) : dedup s ≤ s :=
quot.induction_on s $ λ l, (dedup_sublist _).subperm

theorem dedup_subset (s : multiset α) : dedup s ⊆ s :=
subset_of_le $ dedup_le _

theorem subset_dedup (s : multiset α) : s ⊆ dedup s :=
λ a, mem_dedup.2

@[simp] theorem dedup_subset' {s t : multiset α} : dedup s ⊆ t ↔ s ⊆ t :=
⟨subset.trans (subset_dedup _), subset.trans (dedup_subset _)⟩

@[simp] theorem subset_dedup' {s t : multiset α} : s ⊆ dedup t ↔ s ⊆ t :=
⟨λ h, subset.trans h (dedup_subset _), λ h, subset.trans h (subset_dedup _)⟩

@[simp] theorem nodup_dedup (s : multiset α) : nodup (dedup s) :=
quot.induction_on s nodup_dedup

theorem dedup_eq_self {s : multiset α} : dedup s = s ↔ nodup s :=
⟨λ e, e ▸ nodup_dedup s,
 quot.induction_on s $ λ l h, congr_arg coe h.dedup⟩

alias dedup_eq_self ↔ _ nodup.dedup

lemma count_dedup (m : multiset α) (a : α) :
  m.dedup.count a = if a ∈ m then 1 else 0 :=
quot.induction_on m $ λ l, count_dedup _ _

@[simp]

@[simp] lemma dedup_bind_dedup [decidable_eq β] (m : multiset α) (f : α → multiset β) :
  (m.dedup.bind f).dedup = (m.bind f).dedup :=
by { ext x, simp_rw [count_dedup, mem_bind, mem_dedup], }

theorem dedup_eq_zero {s : multiset α} : dedup s = 0 ↔ s = 0 :=
⟨λ h, eq_zero_of_subset_zero $ h ▸ subset_dedup _,
 λ h, h.symm ▸ dedup_zero⟩

@[simp] theorem dedup_singleton {a : α} : dedup ({a} : multiset α) = {a} :=
(nodup_singleton _).dedup

theorem le_dedup {s t : multiset α} : s ≤ dedup t ↔ s ≤ t ∧ nodup s :=
⟨λ h, ⟨le_trans h (dedup_le _), nodup_of_le h (nodup_dedup _)⟩,
 λ ⟨l, d⟩, (le_iff_subset d).2 $ subset.trans (subset_of_le l) (subset_dedup _)⟩

theorem le_dedup_self {s : multiset α} : s ≤ dedup s ↔ nodup s :=
by rw [le_dedup, and_iff_right le_rfl]

theorem dedup_ext {s t : multiset α} : dedup s = dedup t ↔ ∀ a, a ∈ s ↔ a ∈ t :=
by simp [nodup.ext]

theorem dedup_map_dedup_eq [decidable_eq β] (f : α → β) (s : multiset α) :
  dedup (map f (dedup s)) = dedup (map f s) := by simp [dedup_ext]

@[simp]
lemma dedup_nsmul {s : multiset α} {n : ℕ} (h0 : n ≠ 0) :
  (n • s).dedup = s.dedup :=
begin
  ext a,
  by_cases h : a ∈ s;
  simp [h,h0]
end

lemma nodup.le_dedup_iff_le {s t : multiset α} (hno : s.nodup) :
  s ≤ t.dedup ↔ s ≤ t :=
by simp [le_dedup, hno]

end multiset

lemma multiset.nodup.le_nsmul_iff_le {α : Type*} {s t : multiset α}
  {n : ℕ} (h : s.nodup) (hn : n ≠ 0) :
  s ≤ n • t ↔ s ≤ t :=
begin
  classical,
  rw [← h.le_dedup_iff_le, iff.comm, ← h.le_dedup_iff_le],
  simp [hn]
end


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import tactic.basic
import data.fintype.basic

/-!
# Erdős–Szekeres theorem

This file proves Theorem 73 from the [100 Theorems List](https://www.cs.ru.nl/~freek/100/), also
known as the Erdős–Szekeres theorem: given a sequence of more than `r * s` distinct
values, there is an increasing sequence of length longer than `r` or a decreasing sequence of length
longer than `s`.

We use the proof outlined at
https://en.wikipedia.org/wiki/Erdos-Szekeres_theorem#Pigeonhole_principle.

## Tags

sequences, increasing, decreasing, Ramsey, Erdos-Szekeres, Erdős–Szekeres, Erdős-Szekeres
-/

variables {α : Type*} [linear_order α] {β : Type*}

open function finset
open_locale classical

/--
**Erdős–Szekeres Theorem**: Given a sequence of more than `r * s` distinct values, there is an
increasing sequence of length longer than `r` or a decreasing sequence of length longer than `s`.

Proof idea:
We label each value in the sequence with two numbers specifying the longest increasing
subsequence ending there, and the longest decreasing subsequence ending there.
We then show the pair of labels must be unique. Now if there is no increasing sequence longer than
`r` and no decreasing sequence longer than `s`, then there are at most `r * s` possible labels,
which is a contradiction if there are more than `r * s` elements.
-/
theorem erdos_szekeres {r s n : ℕ} {f : fin n → α} (hn : r * s < n) (hf : injective f) :
  (∃ (t : finset (fin n)), r < t.card ∧ strict_mono_on f ↑t) ∨
  (∃ (t : finset (fin n)), s < t.card ∧ strict_anti_on f ↑t) :=
begin
  -- Given an index `i`, produce the set of increasing (resp., decreasing) subsequences which ends
  -- at `i`.
  let inc_sequences_ending_in : fin n → finset (finset (fin n)) :=
    λ i, univ.powerset.filter (λ t, finset.max t = some i ∧ strict_mono_on f ↑t),
  let dec_sequences_ending_in : fin n → finset (finset (fin n)) :=
    λ i, univ.powerset.filter (λ t, finset.max t = some i ∧ strict_anti_on f ↑t),
  -- The singleton sequence is in both of the above collections.
  -- (This is useful to show that the maximum length subsequence is at least 1, and that the set
  -- of subsequences is nonempty.)
  have inc_i : ∀ i, {i} ∈ inc_sequences_ending_in i := λ i, by simp [strict_mono_on],
  have dec_i : ∀ i, {i} ∈ dec_sequences_ending_in i := λ i, by simp [strict_anti_on],
  -- Define the pair of labels: at index `i`, the pair is the maximum length of an increasing
  -- subsequence ending at `i`, paired with the maximum length of a decreasing subsequence ending
  -- at `i`.
  -- We call these labels `(a_i, b_i)`.
  let ab : fin n → ℕ × ℕ,
  { intro i,
    apply (max' ((inc_sequences_ending_in i).image card) (nonempty.image ⟨{i}, inc_i i⟩ _),
           max' ((dec_sequences_ending_in i).image card) (nonempty.image ⟨{i}, dec_i i⟩ _)) },
  -- It now suffices to show that one of the labels is 'big' somewhere. In particular, if the
  -- first in the pair is more than `r` somewhere, then we have an increasing subsequence in our
  -- set, and if the second is more than `s` somewhere, then we have a decreasing subsequence.
  suffices : ∃ i, r < (ab i).1 ∨ s < (ab i).2,
  { obtain ⟨i, hi⟩ := this,
    apply or.imp _ _ hi,
    work_on_goal 0 { have : (ab i).1 ∈ _ := max'_mem _ _ },
    work_on_goal 1 { have : (ab i).2 ∈ _ := max'_mem _ _ },
    all_goals
    { intro hi,
      rw mem_image at this,
      obtain ⟨t, ht₁, ht₂⟩ := this,
      refine ⟨t, by rwa ht₂, _⟩,
      rw mem_filter at ht₁,
      apply ht₁.2.2 } },
  -- Show first that the pair of labels is unique.
  have : injective ab,
  { apply injective_of_lt_imp_ne,
    intros i j k q,
    injection q with q₁ q₂,
    -- We have two cases: `f i < f j` or `f j < f i`.
    -- In the former we'll show `a_i < a_j`, and in the latter we'll show `b_i < b_j`.
    cases lt_or_gt_of_ne (λ _, ne_of_lt ‹i < j› (hf ‹f i = f j›)),
    work_on_goal 0 { apply ne_of_lt _ q₁, have : (ab i).1 ∈ _ := max'_mem _ _ },
    work_on_goal 1 { apply ne_of_lt _ q₂, have : (ab i).2 ∈ _ := max'_mem _ _ },
    all_goals
    { -- Reduce to showing there is a subsequence of length `a_i + 1` which ends at `j`.
      rw nat.lt_iff_add_one_le,
      apply le_max',
      rw mem_image at this ⊢,
      -- In particular we take the subsequence `t` of length `a_i` which ends at `i`, by definition
      -- of `a_i`
      rcases this with ⟨t, ht₁, ht₂⟩,
      rw mem_filter at ht₁,
      -- Ensure `t` ends at `i`.
      have : i ∈ t.max,
        simp [ht₁.2.1],
      -- Now our new subsequence is given by adding `j` at the end of `t`.
      refine ⟨insert j t, _, _⟩,
      -- First make sure it's valid, i.e., that this subsequence ends at `j` and is increasing
      { rw mem_filter,
        refine ⟨_, _, _⟩,
        { rw mem_powerset, apply subset_univ },
        -- It ends at `j` since `i < j`.
        { convert max_insert,
          rw [ht₁.2.1, option.lift_or_get_some_some, max_eq_left, with_top.some_eq_coe],
          apply le_of_lt ‹i < j› },
        -- To show it's increasing (i.e., `f` is monotone increasing on `t.insert j`), we do cases
        -- on what the possibilities could be - either in `t` or equals `j`.
        simp only [strict_mono_on, strict_anti_on, coe_insert, set.mem_insert_iff,
          mem_coe],
        -- Most of the cases are just bashes.
        rintros x ⟨rfl | _⟩ y ⟨rfl | _⟩ _,
        { apply (irrefl _ ‹j < j›).elim },
        { exfalso,
          apply not_le_of_lt (trans ‹i < j› ‹j < y›) (le_max_of_mem ‹y ∈ t› ‹i ∈ t.max›) },
        { apply lt_of_le_of_lt _ ‹f i < f j› <|> apply lt_of_lt_of_le ‹f j < f i› _,
          rcases lt_or_eq_of_le (le_max_of_mem ‹x ∈ t› ‹i ∈ t.max›) with _ | rfl,
          { apply le_of_lt (ht₁.2.2 ‹x ∈ t› (mem_of_max ‹i ∈ t.max›) ‹x < i›) },
          { refl } },
        { apply ht₁.2.2 ‹x ∈ t› ‹y ∈ t› ‹x < y› } },
      -- Finally show that this new subsequence is one longer than the old one.
      { rw [card_insert_of_not_mem, ht₂],
        intro _,
        apply not_le_of_lt ‹i < j› (le_max_of_mem ‹j ∈ t› ‹i ∈ t.max›) } } },
      -- Finished both goals!
  -- Now that we have uniqueness of each label, it remains to do some counting to finish off.
  -- Suppose all the labels are small.
  by_contra q,
  push_neg at q,
  -- Then the labels `(a_i, b_i)` all fit in the following set: `{ (x,y) | 1 ≤ x ≤ r, 1 ≤ y ≤ s }`
  let ran : finset (ℕ × ℕ) := ((range r).image nat.succ).product ((range s).image nat.succ),
  -- which we prove here.
  have : image ab univ ⊆ ran,
  -- First some logical shuffling
  { rintro ⟨x₁, x₂⟩,
    simp only [mem_image, exists_prop, mem_range, mem_univ, mem_product, true_and, prod.mk.inj_iff],
    rintros ⟨i, rfl, rfl⟩,
    specialize q i,
    -- Show `1 ≤ a_i` and `1 ≤ b_i`, which is easy from the fact that `{i}` is a increasing and
    -- decreasing subsequence which we did right near the top.
    have z : 1 ≤ (ab i).1 ∧ 1 ≤ (ab i).2,
    { split;
      { apply le_max',
        rw mem_image,
        refine ⟨{i}, by solve_by_elim, card_singleton i⟩ } },
    refine ⟨_, _⟩,
    -- Need to get `a_i ≤ r`, here phrased as: there is some `a < r` with `a+1 = a_i`.
    { refine ⟨(ab i).1 - 1, _, nat.succ_pred_eq_of_pos z.1⟩,
      rw tsub_lt_iff_right z.1,
      apply nat.lt_succ_of_le q.1 },
    { refine ⟨(ab i).2 - 1, _, nat.succ_pred_eq_of_pos z.2⟩,
      rw tsub_lt_iff_right z.2,
      apply nat.lt_succ_of_le q.2 } },
  -- To get our contradiction, it suffices to prove `n ≤ r * s`
  apply not_le_of_lt hn,
  -- Which follows from considering the cardinalities of the subset above, since `ab` is injective.
  simpa [nat.succ_injective, card_image_of_injective, ‹injective ab›] using card_le_of_subset this,
end