/-
Copyright (c) 2020 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen, Kexing Ying, Eric Wieser

! This file was ported from Lean 3 source module linear_algebra.quadratic_form.complex
! leanprover-community/mathlib commit 32b08ef840dd25ca2e47e035c5da03ce16d2dc3c
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.LinearAlgebra.QuadraticForm.Isometry
import Mathbin.Analysis.SpecialFunctions.Pow

/-!
# Quadratic forms over the complex numbers

`equivalent_sum_squares`: A nondegenerate quadratic form over the complex numbers is equivalent to
a sum of squares.

-/

namespace QuadraticForm

open BigOperators

open Finset

variable {ι : Type _} [Fintype ι]

/-- The isometry between a weighted sum of squares on the complex numbers and the
sum of squares, i.e. `weighted_sum_squares` with weights 1 or 0. -/
noncomputable def isometrySumSquares [DecidableEq ι] (w' : ι → ℂ) :
    Isometry (weightedSumSquares ℂ w')
      (weightedSumSquares ℂ (fun i => if w' i = 0 then 0 else 1 : ι → ℂ)) :=
  by
  let w i := if h : w' i = 0 then (1 : Units ℂ) else Units.mk0 (w' i) h
  have hw' : ∀ i : ι, (w i : ℂ) ^ (-(1 / 2 : ℂ)) ≠ 0 :=
    by
    intro i hi
    exact (w i).NeZero ((Complex.cpow_eq_zero_iff _ _).1 hi).1
  convert(weighted_sum_squares ℂ w').isometryBasisRepr
      ((Pi.basisFun ℂ ι).units_smul fun i => (isUnit_iff_ne_zero.2 <| hw' i).Unit)
  ext1 v
  erw [basis_repr_apply, weighted_sum_squares_apply, weighted_sum_squares_apply]
  refine' sum_congr rfl fun j hj => _
  have hsum :
    (∑ i : ι, v i • ((isUnit_iff_ne_zero.2 <| hw' i).Unit : ℂ) • (Pi.basisFun ℂ ι) i) j =
      v j • w j ^ (-(1 / 2 : ℂ)) :=
    by
    rw [Finset.sum_apply, sum_eq_single j, Pi.basisFun_apply, IsUnit.unit_spec,
      LinearMap.stdBasis_apply, Pi.smul_apply, Pi.smul_apply, Function.update_same, smul_eq_mul,
      smul_eq_mul, smul_eq_mul, mul_one]
    intro i _ hij
    rw [Pi.basisFun_apply, LinearMap.stdBasis_apply, Pi.smul_apply, Pi.smul_apply,
      Function.update_noteq hij.symm, Pi.zero_apply, smul_eq_mul, smul_eq_mul,
      MulZeroClass.mul_zero, MulZeroClass.mul_zero]
    intro hj'
    exact False.elim (hj' hj)
  simp_rw [Basis.unitsSmul_apply]
  erw [hsum, smul_eq_mul]
  split_ifs
  · simp only [h, zero_smul, MulZeroClass.zero_mul]
  have hww' : w' j = w j := by simp only [w, dif_neg h, Units.val_mk0]
  simp only [hww', one_mul]
  change v j * v j = ↑(w j) * (v j * ↑(w j) ^ (-(1 / 2 : ℂ)) * (v j * ↑(w j) ^ (-(1 / 2 : ℂ))))
  suffices v j * v j = w j ^ (-(1 / 2 : ℂ)) * w j ^ (-(1 / 2 : ℂ)) * w j * v j * v j
    by
    rw [this]
    ring
  rw [← Complex.cpow_add _ _ (w j).NeZero, show -(1 / 2 : ℂ) + -(1 / 2) = -1 by simp [← two_mul],
    Complex.cpow_neg_one, inv_mul_cancel (w j).NeZero, one_mul]
#align quadratic_form.isometry_sum_squares QuadraticForm.isometrySumSquares

/-- The isometry between a weighted sum of squares on the complex numbers and the
sum of squares, i.e. `weighted_sum_squares` with weight `λ i : ι, 1`. -/
noncomputable def isometrySumSquaresUnits [DecidableEq ι] (w : ι → Units ℂ) :
    Isometry (weightedSumSquares ℂ w) (weightedSumSquares ℂ (1 : ι → ℂ)) :=
  by
  have hw1 : (fun i => if (w i : ℂ) = 0 then 0 else 1 : ι → ℂ) = 1 :=
    by
    ext i : 1
    exact dif_neg (w i).NeZero
  have := isometry_sum_squares (coe ∘ w)
  rw [hw1] at this
  exact this
#align quadratic_form.isometry_sum_squares_units QuadraticForm.isometrySumSquaresUnits

/-- A nondegenerate quadratic form on the complex numbers is equivalent to
the sum of squares, i.e. `weighted_sum_squares` with weight `λ i : ι, 1`. -/
theorem equivalentSumSquares {M : Type _} [AddCommGroup M] [Module ℂ M] [FiniteDimensional ℂ M]
    (Q : QuadraticForm ℂ M) (hQ : (associated Q).Nondegenerate) :
    Equivalent Q (weightedSumSquares ℂ (1 : Fin (FiniteDimensional.finrank ℂ M) → ℂ)) :=
  let ⟨w, ⟨hw₁⟩⟩ := Q.equivalent_weightedSumSquares_units_of_nondegenerate' hQ
  ⟨hw₁.trans (isometrySumSquaresUnits w)⟩
#align quadratic_form.equivalent_sum_squares QuadraticForm.equivalentSumSquares

/-- All nondegenerate quadratic forms on the complex numbers are equivalent. -/
theorem complexEquivalent {M : Type _} [AddCommGroup M] [Module ℂ M] [FiniteDimensional ℂ M]
    (Q₁ Q₂ : QuadraticForm ℂ M) (hQ₁ : (associated Q₁).Nondegenerate)
    (hQ₂ : (associated Q₂).Nondegenerate) : Equivalent Q₁ Q₂ :=
  (Q₁.equivalentSumSquares hQ₁).trans (Q₂.equivalentSumSquares hQ₂).symm
#align quadratic_form.complex_equivalent QuadraticForm.complexEquivalent

end QuadraticForm


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

import field_theory.is_alg_closed.basic
import linear_algebra.finsupp
import linear_algebra.matrix.to_lin
import order.preorder_hom
import linear_algebra.charpoly.basic

/-!
# Eigenvectors and eigenvalues

This file defines eigenspaces, eigenvalues, and eigenvalues, as well as their generalized
counterparts. We follow Axler's approach [axler2015] because it allows us to derive many properties
without choosing a basis and without using matrices.

An eigenspace of a linear map `f` for a scalar `μ` is the kernel of the map `(f - μ • id)`. The
nonzero elements of an eigenspace are eigenvectors `x`. They have the property `f x = μ • x`. If
there are eigenvectors for a scalar `μ`, the scalar `μ` is called an eigenvalue.

There is no consensus in the literature whether `0` is an eigenvector. Our definition of
`has_eigenvector` permits only nonzero vectors. For an eigenvector `x` that may also be `0`, we
write `x ∈ f.eigenspace μ`.

A generalized eigenspace of a linear map `f` for a natural number `k` and a scalar `μ` is the kernel
of the map `(f - μ • id) ^ k`. The nonzero elements of a generalized eigenspace are generalized
eigenvectors `x`. If there are generalized eigenvectors for a natural number `k` and a scalar `μ`,
the scalar `μ` is called a generalized eigenvalue.

## References

* [Sheldon Axler, *Linear Algebra Done Right*][axler2015]
* https://en.wikipedia.org/wiki/Eigenvalues_and_eigenvectors

## Tags

eigenspace, eigenvector, eigenvalue, eigen
-/

universes u v w

namespace module
namespace End

open module principal_ideal_ring polynomial finite_dimensional

variables {K R : Type v} {V M : Type w}
  [comm_ring R] [add_comm_group M] [module R M] [field K] [add_comm_group V] [module K V]

/-- The submodule `eigenspace f μ` for a linear map `f` and a scalar `μ` consists of all vectors `x`
    such that `f x = μ • x`. (Def 5.36 of [axler2015])-/
def eigenspace (f : End R M) (μ : R) : submodule R M :=
(f - algebra_map R (End R M) μ).ker

/-- A nonzero element of an eigenspace is an eigenvector. (Def 5.7 of [axler2015]) -/
def has_eigenvector (f : End R M) (μ : R) (x : M) : Prop :=
x ∈ eigenspace f μ ∧ x ≠ 0

/-- A scalar `μ` is an eigenvalue for a linear map `f` if there are nonzero vectors `x`
    such that `f x = μ • x`. (Def 5.5 of [axler2015]) -/
def has_eigenvalue (f : End R M) (a : R) : Prop :=
eigenspace f a ≠ ⊥

/-- The eigenvalues of the endomorphism `f`, as a subtype of `R`. -/
def eigenvalues (f : End R M) : Type* := {μ : R // f.has_eigenvalue μ}

instance (f : End R M) : has_coe f.eigenvalues R := coe_subtype

lemma has_eigenvalue_of_has_eigenvector {f : End R M} {μ : R} {x : M} (h : has_eigenvector f μ x) :
  has_eigenvalue f μ :=
begin
  rw [has_eigenvalue, submodule.ne_bot_iff],
  use x, exact h,
end

lemma mem_eigenspace_iff {f : End R M} {μ : R} {x : M} : x ∈ eigenspace f μ ↔ f x = μ • x :=
by rw [eigenspace, linear_map.mem_ker, linear_map.sub_apply, algebra_map_End_apply,
  sub_eq_zero]

lemma has_eigenvalue.exists_has_eigenvector {f : End R M} {μ : R} (hμ : f.has_eigenvalue μ) :
  ∃ v, f.has_eigenvector μ v :=
submodule.exists_mem_ne_zero_of_ne_bot hμ

lemma eigenspace_div (f : End K V) (a b : K) (hb : b ≠ 0) :
  eigenspace f (a / b) = (b • f - algebra_map K (End K V) a).ker :=
calc
  eigenspace f (a / b) = eigenspace f (b⁻¹ * a) : by { rw [div_eq_mul_inv, mul_comm] }
  ... = (f - (b⁻¹ * a) • linear_map.id).ker : rfl
  ... = (f - b⁻¹ • a • linear_map.id).ker : by rw smul_smul
  ... = (f - b⁻¹ • algebra_map K (End K V) a).ker : rfl
  ... = (b • (f - b⁻¹ • algebra_map K (End K V) a)).ker : by rw linear_map.ker_smul _ b hb
  ... = (b • f - algebra_map K (End K V) a).ker : by rw [smul_sub, smul_inv_smul₀ hb]

lemma eigenspace_aeval_polynomial_degree_1
  (f : End K V) (q : polynomial K) (hq : degree q = 1) :
  eigenspace f (- q.coeff 0 / q.leading_coeff) = (aeval f q).ker :=
calc
  eigenspace f (- q.coeff 0 / q.leading_coeff)
      = (q.leading_coeff • f - algebra_map K (End K V) (- q.coeff 0)).ker
    : by { rw eigenspace_div, intro h, rw leading_coeff_eq_zero_iff_deg_eq_bot.1 h at hq, cases hq }
  ... = (aeval f (C q.leading_coeff * X + C (q.coeff 0))).ker
    : by { rw [C_mul', aeval_def], simp [algebra_map, algebra.to_ring_hom], }
  ... = (aeval f q).ker
     : by { congr, apply (eq_X_add_C_of_degree_eq_one hq).symm }

lemma ker_aeval_ring_hom'_unit_polynomial
  (f : End K V) (c : units (polynomial K)) :
  (aeval f (c : polynomial K)).ker = ⊥ :=
begin
  rw polynomial.eq_C_of_degree_eq_zero (degree_coe_units c),
  simp only [aeval_def, eval₂_C],
  apply ker_algebra_map_End,
  apply coeff_coe_units_zero_ne_zero c
end

theorem aeval_apply_of_has_eigenvector {f : End K V}
  {p : polynomial K} {μ : K} {x : V} (h : f.has_eigenvector μ x) :
  aeval f p x = (p.eval μ) • x :=
begin
  apply p.induction_on,
  { intro a, simp [module.algebra_map_End_apply] },
  { intros p q hp hq, simp [hp, hq, add_smul] },
  { intros n a hna,
    rw [mul_comm, pow_succ, mul_assoc, alg_hom.map_mul, linear_map.mul_apply, mul_comm, hna],
    simp [algebra_map_End_apply, mem_eigenspace_iff.1 h.1, smul_smul, mul_comm] }
end

section minpoly

theorem is_root_of_has_eigenvalue {f : End K V} {μ : K} (h : f.has_eigenvalue μ) :
  (minpoly K f).is_root μ :=
begin
  rcases (submodule.ne_bot_iff _).1 h with ⟨w, ⟨H, ne0⟩⟩,
  refine or.resolve_right (smul_eq_zero.1 _) ne0,
  simp [← aeval_apply_of_has_eigenvector ⟨H, ne0⟩, minpoly.aeval K f],
end

variables [finite_dimensional K V] (f : End K V)

variables {f} {μ : K}

theorem has_eigenvalue_of_is_root (h : (minpoly K f).is_root μ) :
  f.has_eigenvalue μ :=
begin
  cases dvd_iff_is_root.2 h with p hp,
  rw [has_eigenvalue, eigenspace],
  intro con,
  cases (linear_map.is_unit_iff _).2 con with u hu,
  have p_ne_0 : p ≠ 0,
  { intro con,
    apply minpoly.ne_zero f.is_integral,
    rw [hp, con, mul_zero] },
  have h_deg := minpoly.degree_le_of_ne_zero K f p_ne_0 _,
  { rw [hp, degree_mul, degree_X_sub_C, polynomial.degree_eq_nat_degree p_ne_0] at h_deg,
    norm_cast at h_deg,
    linarith, },
  { have h_aeval := minpoly.aeval K f,
    revert h_aeval,
    simp [hp, ← hu] },
end

theorem has_eigenvalue_iff_is_root :
  f.has_eigenvalue μ ↔ (minpoly K f).is_root μ :=
⟨is_root_of_has_eigenvalue, has_eigenvalue_of_is_root⟩

/-- An endomorphism of a finite-dimensional vector space has finitely many eigenvalues. -/
noncomputable instance (f : End K V) : fintype f.eigenvalues :=
set.finite.fintype
begin
  have h : minpoly K f ≠ 0 := minpoly.ne_zero f.is_integral,
  convert (minpoly K f).root_set_finite K,
  ext μ,
  have : (μ ∈ {μ : K | f.eigenspace μ = ⊥ → false}) ↔ ¬f.eigenspace μ = ⊥ := by tauto,
  convert rfl.mpr this,
  simp [polynomial.root_set_def, polynomial.mem_roots h, ← has_eigenvalue_iff_is_root,
    has_eigenvalue]
end

end minpoly

/-- Every linear operator on a vector space over an algebraically closed field has
    an eigenvalue. -/
-- This is Lemma 5.21 of [axler2015], although we are no longer following that proof.
lemma exists_eigenvalue [is_alg_closed K] [finite_dimensional K V] [nontrivial V] (f : End K V) :
  ∃ (c : K), f.has_eigenvalue c :=
begin
  obtain ⟨c, nu⟩ := exists_spectrum_of_is_alg_closed_of_finite_dimensional K f,
  use c,
  rw linear_map.is_unit_iff at nu,
  exact has_eigenvalue_of_has_eigenvector (submodule.exists_mem_ne_zero_of_ne_bot nu).some_spec,
end

noncomputable instance [is_alg_closed K] [finite_dimensional K V] [nontrivial V] (f : End K V) :
  inhabited f.eigenvalues :=
⟨⟨f.exists_eigenvalue.some, f.exists_eigenvalue.some_spec⟩⟩

/-- The eigenspaces of a linear operator form an independent family of subspaces of `V`.  That is,
any eigenspace has trivial intersection with the span of all the other eigenspaces. -/
lemma eigenspaces_independent (f : End K V) : complete_lattice.independent f.eigenspace :=
begin
  classical,
  -- Define an operation from `Π₀ μ : K, f.eigenspace μ`, the vector space of of finitely-supported
  -- choices of an eigenvector from each eigenspace, to `V`, by sending a collection to its sum.
  let S : @linear_map K K _ _ (ring_hom.id K) (Π₀ μ : K, f.eigenspace μ) V
    (@dfinsupp.add_comm_monoid K (λ μ, f.eigenspace μ) _) _
    (@dfinsupp.module K _ (λ μ, f.eigenspace μ) _ _ _) _ :=
    @dfinsupp.lsum K K ℕ _ V _ _ _ _ _ _ _ _ _
    (λ μ, (f.eigenspace μ).subtype),
  -- We need to show that if a finitely-supported collection `l` of representatives of the
  -- eigenspaces has sum `0`, then it itself is zero.
  suffices : ∀ l : Π₀ μ, f.eigenspace μ, S l = 0 → l = 0,
  { rw complete_lattice.independent_iff_dfinsupp_lsum_injective,
    change function.injective S,
    rw ← @linear_map.ker_eq_bot K K (Π₀ μ, (f.eigenspace μ)) V _ _
      (@dfinsupp.add_comm_group K (λ μ, f.eigenspace μ) _),
    rw eq_bot_iff,
    exact this },
  intros l hl,
  -- We apply induction on the finite set of eigenvalues from which `l` selects a nonzero
  -- eigenvector, i.e. on the support of `l`.
  induction h_l_support : l.support using finset.induction with μ₀ l_support' hμ₀ ih generalizing l,
  -- If the support is empty, all coefficients are zero and we are done.
  { exact dfinsupp.support_eq_empty.1 h_l_support },
  -- Now assume that the support of `l` contains at least one eigenvalue `μ₀`. We define a new
  -- collection of representatives `l'` to apply the induction hypothesis on later. The collection
  -- of representatives `l'` is derived from `l` by multiplying the coefficient of the eigenvector
  -- with eigenvalue `μ` by `μ - μ₀`.
  { let l' := dfinsupp.map_range.linear_map
      (λ μ, (μ - μ₀) • @linear_map.id K (f.eigenspace μ) _ _ _) l,
    -- The support of `l'` is the support of `l` without `μ₀`.
    have h_l_support' : l'.support = l_support',
    { have : l_support' = finset.erase l.support μ₀,
      { rw [h_l_support, finset.erase_insert hμ₀] },
      rw this,
      ext a,
      have : ¬(a = μ₀ ∨ l a = 0) ↔ ¬a = μ₀ ∧ ¬l a = 0 := by tauto,
      simp only [l', dfinsupp.map_range.linear_map_apply, dfinsupp.map_range_apply,
        dfinsupp.mem_support_iff, finset.mem_erase, id.def, linear_map.id_coe,
        linear_map.smul_apply, ne.def, smul_eq_zero, sub_eq_zero, this] },
    -- The entries of `l'` add up to `0`.
    have total_l' : S l' = 0,
    { let g := f - algebra_map K (End K V) μ₀,
      let a : Π₀ μ : K, V := dfinsupp.map_range.linear_map (λ μ, (f.eigenspace μ).subtype) l,
      calc S l'
          = dfinsupp.lsum ℕ (λ μ, (f.eigenspace μ).subtype.comp ((μ - μ₀) • linear_map.id)) l : _
      ... = dfinsupp.lsum ℕ (λ μ, g.comp (f.eigenspace μ).subtype) l : _
      ... = dfinsupp.lsum ℕ (λ μ, g) a : _
      ... = g (dfinsupp.lsum ℕ (λ μ, (linear_map.id : V →ₗ[K] V)) a) : _
      ... = g (S l) : _
      ... = 0 : by rw [hl, g.map_zero],
      { rw dfinsupp.sum_map_range_index.linear_map },
      { congr,
        ext μ v,
        simp only [g, eq_self_iff_true, function.comp_app, id.def, linear_map.coe_comp,
          linear_map.id_coe, linear_map.smul_apply, linear_map.sub_apply,
          module.algebra_map_End_apply, sub_left_inj, sub_smul, submodule.coe_smul_of_tower,
          submodule.coe_sub, submodule.subtype_apply, mem_eigenspace_iff.1 v.prop], },
      { rw dfinsupp.sum_map_range_index.linear_map },
      { simp only [dfinsupp.sum_add_hom_apply, linear_map.id_coe, linear_map.map_dfinsupp_sum,
          id.def, linear_map.to_add_monoid_hom_coe, dfinsupp.lsum_apply_apply], },
      { congr,
        simp only [S, a, dfinsupp.sum_map_range_index.linear_map, linear_map.id_comp] } },
    -- Therefore, by the induction hypothesis, all entries of `l'` are zero.
    have l'_eq_0 := ih l' total_l' h_l_support',
    -- By the definition of `l'`, this means that `(μ - μ₀) • l μ = 0` for all `μ`.
    have h_smul_eq_0 : ∀ μ, (μ - μ₀) • l μ = 0,
    { intro μ,
      calc (μ - μ₀) • l μ = l' μ : by simp only [l', linear_map.id_coe, id.def,
        linear_map.smul_apply, dfinsupp.map_range_apply, dfinsupp.map_range.linear_map_apply]
      ... = 0 : by { rw [l'_eq_0], refl } },
    -- Thus, the eigenspace-representatives in `l` for all `μ ≠ μ₀` are `0`.
    have h_lμ_eq_0 : ∀ μ : K, μ ≠ μ₀ → l μ = 0,
    { intros μ hμ,
      apply or_iff_not_imp_left.1 (smul_eq_zero.1 (h_smul_eq_0 μ)),
      rwa [sub_eq_zero] },
    -- So if we sum over all these representatives, we obtain `0`.
    have h_sum_l_support'_eq_0 : finset.sum l_support' (λ μ, (l μ : V)) = 0,
    { rw ←finset.sum_const_zero,
      apply finset.sum_congr rfl,
      intros μ hμ,
      norm_cast,
      rw h_lμ_eq_0,
      intro h,
      rw h at hμ,
      contradiction },
    -- The only potentially nonzero eigenspace-representative in `l` is the one corresponding to
    -- `μ₀`. But since the overall sum is `0` by assumption, this representative must also be `0`.
    have : l μ₀ = 0,
    { simp only [S, dfinsupp.lsum_apply_apply, dfinsupp.sum_add_hom_apply,
        linear_map.to_add_monoid_hom_coe, dfinsupp.sum, h_l_support, submodule.subtype_apply,
        submodule.coe_eq_zero, finset.sum_insert hμ₀, h_sum_l_support'_eq_0, add_zero] at hl,
      exact_mod_cast hl },
    -- Thus, all coefficients in `l` are `0`.
    show l = 0,
    { ext μ,
      by_cases h_cases : μ = μ₀,
      { rw h_cases,
        exact_mod_cast this },
      exact congr_arg (coe : _ → V) (h_lμ_eq_0 μ h_cases) }}
end

/-- Eigenvectors corresponding to distinct eigenvalues of a linear operator are linearly
    independent. (Lemma 5.10 of [axler2015])

    We use the eigenvalues as indexing set to ensure that there is only one eigenvector for each
    eigenvalue in the image of `xs`. -/
lemma eigenvectors_linear_independent (f : End K V) (μs : set K) (xs : μs → V)
  (h_eigenvec : ∀ μ : μs, f.has_eigenvector μ (xs μ)) :
  linear_independent K xs :=
complete_lattice.independent.linear_independent _
  (f.eigenspaces_independent.comp (coe : μs → K) subtype.coe_injective)
  (λ μ, (h_eigenvec μ).1) (λ μ, (h_eigenvec μ).2)

/-- The generalized eigenspace for a linear map `f`, a scalar `μ`, and an exponent `k ∈ ℕ` is the
kernel of `(f - μ • id) ^ k`. (Def 8.10 of [axler2015]). Furthermore, a generalized eigenspace for
some exponent `k` is contained in the generalized eigenspace for exponents larger than `k`. -/
def generalized_eigenspace (f : End R M) (μ : R) : ℕ →ₘ submodule R M :=
{ to_fun    := λ k, ((f - algebra_map R (End R M) μ) ^ k).ker,
  monotone' := λ k m hm,
  begin
    simp only [← pow_sub_mul_pow _ hm],
    exact linear_map.ker_le_ker_comp
      ((f - algebra_map R (End R M) μ) ^ k) ((f - algebra_map R (End R M) μ) ^ (m - k)),
  end }

@[simp] lemma mem_generalized_eigenspace (f : End R M) (μ : R) (k : ℕ) (m : M) :
  m ∈ f.generalized_eigenspace μ k ↔ ((f - μ • 1)^k) m = 0 :=
iff.rfl

/-- A nonzero element of a generalized eigenspace is a generalized eigenvector.
    (Def 8.9 of [axler2015])-/
def has_generalized_eigenvector (f : End R M) (μ : R) (k : ℕ) (x : M) : Prop :=
x ≠ 0 ∧ x ∈ generalized_eigenspace f μ k

/-- A scalar `μ` is a generalized eigenvalue for a linear map `f` and an exponent `k ∈ ℕ` if there
    are generalized eigenvectors for `f`, `k`, and `μ`. -/
def has_generalized_eigenvalue (f : End R M) (μ : R) (k : ℕ) : Prop :=
generalized_eigenspace f μ k ≠ ⊥

/-- The generalized eigenrange for a linear map `f`, a scalar `μ`, and an exponent `k ∈ ℕ` is the
    range of `(f - μ • id) ^ k`. -/
def generalized_eigenrange (f : End R M) (μ : R) (k : ℕ) : submodule R M :=
((f - algebra_map R (End R M) μ) ^ k).range

/-- The exponent of a generalized eigenvalue is never 0. -/
lemma exp_ne_zero_of_has_generalized_eigenvalue {f : End R M} {μ : R} {k : ℕ}
  (h : f.has_generalized_eigenvalue μ k) : k ≠ 0 :=
begin
  rintro rfl,
  exact h linear_map.ker_id
end

/-- The union of the kernels of `(f - μ • id) ^ k` over all `k`. -/
def maximal_generalized_eigenspace (f : End R M) (μ : R) : submodule R M :=
⨆ k, f.generalized_eigenspace μ k

lemma generalized_eigenspace_le_maximal (f : End R M) (μ : R) (k : ℕ) :
  f.generalized_eigenspace μ k ≤ f.maximal_generalized_eigenspace μ :=
le_supr _ _

@[simp] lemma mem_maximal_generalized_eigenspace (f : End R M) (μ : R) (m : M) :
  m ∈ f.maximal_generalized_eigenspace μ ↔ ∃ (k : ℕ), ((f - μ • 1)^k) m = 0 :=
by simp only [maximal_generalized_eigenspace, ← mem_generalized_eigenspace,
  submodule.mem_supr_of_chain]

/-- If there exists a natural number `k` such that the kernel of `(f - μ • id) ^ k` is the
maximal generalized eigenspace, then this value is the least such `k`. If not, this value is not
meaningful. -/
noncomputable def maximal_generalized_eigenspace_index (f : End R M) (μ : R) :=
monotonic_sequence_limit_index (f.generalized_eigenspace μ)

/-- For an endomorphism of a Noetherian module, the maximal eigenspace is always of the form kernel
`(f - μ • id) ^ k` for some `k`. -/
lemma maximal_generalized_eigenspace_eq [h : is_noetherian R M] (f : End R M) (μ : R) :
  maximal_generalized_eigenspace f μ =
  f.generalized_eigenspace μ (maximal_generalized_eigenspace_index f μ) :=
begin
  rw is_noetherian_iff_well_founded at h,
  exact (well_founded.supr_eq_monotonic_sequence_limit h (f.generalized_eigenspace μ) : _),
end

/-- A generalized eigenvalue for some exponent `k` is also
    a generalized eigenvalue for exponents larger than `k`. -/
lemma has_generalized_eigenvalue_of_has_generalized_eigenvalue_of_le
  {f : End R M} {μ : R} {k : ℕ} {m : ℕ} (hm : k ≤ m) (hk : f.has_generalized_eigenvalue μ k) :
  f.has_generalized_eigenvalue μ m :=
begin
  unfold has_generalized_eigenvalue at *,
  contrapose! hk,
  rw [←le_bot_iff, ←hk],
  exact (f.generalized_eigenspace μ).monotone hm,
end

/-- The eigenspace is a subspace of the generalized eigenspace. -/
lemma eigenspace_le_generalized_eigenspace {f : End R M} {μ : R} {k : ℕ} (hk : 0 < k) :
  f.eigenspace μ ≤ f.generalized_eigenspace μ k :=
(f.generalized_eigenspace μ).monotone (nat.succ_le_of_lt hk)

/-- All eigenvalues are generalized eigenvalues. -/
lemma has_generalized_eigenvalue_of_has_eigenvalue
  {f : End R M} {μ : R} {k : ℕ} (hk : 0 < k) (hμ : f.has_eigenvalue μ) :
  f.has_generalized_eigenvalue μ k :=
begin
  apply has_generalized_eigenvalue_of_has_generalized_eigenvalue_of_le hk,
  rw [has_generalized_eigenvalue, generalized_eigenspace, preorder_hom.coe_fun_mk, pow_one],
  exact hμ,
end

/-- All generalized eigenvalues are eigenvalues. -/
lemma has_eigenvalue_of_has_generalized_eigenvalue
  {f : End R M} {μ : R} {k : ℕ} (hμ : f.has_generalized_eigenvalue μ k) :
  f.has_eigenvalue μ :=
begin
  intros contra, apply hμ,
  erw linear_map.ker_eq_bot at ⊢ contra, rw linear_map.coe_pow,
  exact function.injective.iterate contra k,
end

/-- Generalized eigenvalues are actually just eigenvalues. -/
@[simp] lemma has_generalized_eigenvalue_iff_has_eigenvalue
  {f : End R M} {μ : R} {k : ℕ} (hk : 0 < k) :
  f.has_generalized_eigenvalue μ k ↔ f.has_eigenvalue μ :=
⟨has_eigenvalue_of_has_generalized_eigenvalue, has_generalized_eigenvalue_of_has_eigenvalue hk⟩

/-- Every generalized eigenvector is a generalized eigenvector for exponent `finrank K V`.
    (Lemma 8.11 of [axler2015]) -/
lemma generalized_eigenspace_le_generalized_eigenspace_finrank
  [finite_dimensional K V] (f : End K V) (μ : K) (k : ℕ) :
  f.generalized_eigenspace μ k ≤ f.generalized_eigenspace μ (finrank K V) :=
ker_pow_le_ker_pow_finrank _ _

/-- Generalized eigenspaces for exponents at least `finrank K V` are equal to each other. -/
lemma generalized_eigenspace_eq_generalized_eigenspace_finrank_of_le [finite_dimensional K V]
  (f : End K V) (μ : K) {k : ℕ} (hk : finrank K V ≤ k) :
  f.generalized_eigenspace μ k = f.generalized_eigenspace μ (finrank K V) :=
ker_pow_eq_ker_pow_finrank_of_le hk

/-- If `f` maps a subspace `p` into itself, then the generalized eigenspace of the restriction
    of `f` to `p` is the part of the generalized eigenspace of `f` that lies in `p`. -/
lemma generalized_eigenspace_restrict
  (f : End R M) (p : submodule R M) (k : ℕ) (μ : R) (hfp : ∀ (x : M), x ∈ p → f x ∈ p) :
  generalized_eigenspace (linear_map.restrict f hfp) μ k =
    submodule.comap p.subtype (f.generalized_eigenspace μ k) :=
begin
  simp only [generalized_eigenspace, preorder_hom.coe_fun_mk, ← linear_map.ker_comp],
  induction k with k ih,
  { rw [pow_zero, pow_zero, linear_map.one_eq_id],
    apply (submodule.ker_subtype _).symm },
  { erw [pow_succ', pow_succ', linear_map.ker_comp, linear_map.ker_comp, ih,
      ← linear_map.ker_comp, ← linear_map.ker_comp, linear_map.comp_assoc] },
end

/-- If `p` is an invariant submodule of an endomorphism `f`, then the `μ`-eigenspace of the
restriction of `f` to `p` is a submodule of the `μ`-eigenspace of `f`. -/
lemma eigenspace_restrict_le_eigenspace (f : End R M) {p : submodule R M}
  (hfp : ∀ x ∈ p, f x ∈ p) (μ : R) :
  (eigenspace (f.restrict hfp) μ).map p.subtype ≤ f.eigenspace μ :=
begin
  rintros a ⟨x, hx, rfl⟩,
  simp only [set_like.mem_coe, mem_eigenspace_iff, linear_map.restrict_apply] at hx ⊢,
  exact congr_arg coe hx
end

/-- Generalized eigenrange and generalized eigenspace for exponent `finrank K V` are disjoint. -/
lemma generalized_eigenvec_disjoint_range_ker [finite_dimensional K V] (f : End K V) (μ : K) :
  disjoint (f.generalized_eigenrange μ (finrank K V)) (f.generalized_eigenspace μ (finrank K V))  :=
begin
  have h := calc
    submodule.comap ((f - algebra_map _ _ μ) ^ finrank K V)
        (f.generalized_eigenspace μ (finrank K V))
      = ((f - algebra_map _ _ μ) ^ finrank K V *
          (f - algebra_map K (End K V) μ) ^ finrank K V).ker :
        by { simpa only [generalized_eigenspace, preorder_hom.coe_fun_mk, ← linear_map.ker_comp] }
  ... = f.generalized_eigenspace μ (finrank K V + finrank K V) :
        by { rw ←pow_add, refl }
  ... = f.generalized_eigenspace μ (finrank K V) :
        by { rw generalized_eigenspace_eq_generalized_eigenspace_finrank_of_le, linarith },
  rw [disjoint, generalized_eigenrange, linear_map.range_eq_map, submodule.map_inf_eq_map_inf_comap,
    top_inf_eq, h],
  apply submodule.map_comap_le
end

/-- If an invariant subspace `p` of an endomorphism `f` is disjoint from the `μ`-eigenspace of `f`,
then the restriction of `f` to `p` has trivial `μ`-eigenspace. -/
lemma eigenspace_restrict_eq_bot {f : End R M} {p : submodule R M}
  (hfp : ∀ x ∈ p, f x ∈ p) {μ : R} (hμp : disjoint (f.eigenspace μ) p) :
  eigenspace (f.restrict hfp) μ = ⊥ :=
begin
  rw eq_bot_iff,
  intros x hx,
  simpa using hμp ⟨eigenspace_restrict_le_eigenspace f hfp μ ⟨x, hx, rfl⟩, x.prop⟩,
end

/-- The generalized eigenspace of an eigenvalue has positive dimension for positive exponents. -/
lemma pos_finrank_generalized_eigenspace_of_has_eigenvalue [finite_dimensional K V]
  {f : End K V} {k : ℕ} {μ : K} (hx : f.has_eigenvalue μ) (hk : 0 < k):
  0 < finrank K (f.generalized_eigenspace μ k) :=
calc
    0 = finrank K (⊥ : submodule K V) : by rw finrank_bot
  ... < finrank K (f.eigenspace μ) : submodule.finrank_lt_finrank_of_lt (bot_lt_iff_ne_bot.2 hx)
  ... ≤ finrank K (f.generalized_eigenspace μ k) :
    submodule.finrank_mono ((f.generalized_eigenspace μ).monotone (nat.succ_le_of_lt hk))

/-- A linear map maps a generalized eigenrange into itself. -/
lemma map_generalized_eigenrange_le {f : End K V} {μ : K} {n : ℕ} :
  submodule.map f (f.generalized_eigenrange μ n) ≤ f.generalized_eigenrange μ n :=
calc submodule.map f (f.generalized_eigenrange μ n)
       = (f * ((f - algebra_map _ _ μ) ^ n)).range : (linear_map.range_comp _ _).symm
   ... = (((f - algebra_map _ _ μ) ^ n) * f).range : by rw algebra.mul_sub_algebra_map_pow_commutes
   ... = submodule.map ((f - algebra_map _ _ μ) ^ n) f.range : linear_map.range_comp _ _
   ... ≤ f.generalized_eigenrange μ n : linear_map.map_le_range

/-- The generalized eigenvectors span the entire vector space (Lemma 8.21 of [axler2015]). -/
lemma supr_generalized_eigenspace_eq_top [is_alg_closed K] [finite_dimensional K V] (f : End K V) :
  (⨆ (μ : K) (k : ℕ), f.generalized_eigenspace μ k) = ⊤ :=
begin
  tactic.unfreeze_local_instances,
  -- We prove the claim by strong induction on the dimension of the vector space.
  induction h_dim : finrank K V using nat.strong_induction_on with n ih generalizing V,
  cases n,
  -- If the vector space is 0-dimensional, the result is trivial.
  { rw ←top_le_iff,
    simp only [finrank_eq_zero.1 (eq.trans finrank_top h_dim), bot_le] },
  -- Otherwise the vector space is nontrivial.
  { haveI : nontrivial V := finrank_pos_iff.1 (by { rw h_dim, apply nat.zero_lt_succ }),
    -- Hence, `f` has an eigenvalue `μ₀`.
    obtain ⟨μ₀, hμ₀⟩ : ∃ μ₀, f.has_eigenvalue μ₀ := exists_eigenvalue f,
    -- We define `ES` to be the generalized eigenspace
    let ES := f.generalized_eigenspace μ₀ (finrank K V),
    -- and `ER` to be the generalized eigenrange.
    let ER := f.generalized_eigenrange μ₀ (finrank K V),
    -- `f` maps `ER` into itself.
    have h_f_ER : ∀ (x : V), x ∈ ER → f x ∈ ER,
      from λ x hx, map_generalized_eigenrange_le (submodule.mem_map_of_mem hx),
    -- Therefore, we can define the restriction `f'` of `f` to `ER`.
    let f' : End K ER := f.restrict h_f_ER,
    -- The dimension of `ES` is positive
    have h_dim_ES_pos : 0 < finrank K ES,
    { dsimp only [ES],
      rw h_dim,
      apply pos_finrank_generalized_eigenspace_of_has_eigenvalue hμ₀ (nat.zero_lt_succ n) },
    -- and the dimensions of `ES` and `ER` add up to `finrank K V`.
    have h_dim_add : finrank K ER + finrank K ES = finrank K V,
    { apply linear_map.finrank_range_add_finrank_ker },
    -- Therefore the dimension `ER` mus be smaller than `finrank K V`.
    have h_dim_ER : finrank K ER < n.succ, by linarith,
    -- This allows us to apply the induction hypothesis on `ER`:
    have ih_ER : (⨆ (μ : K) (k : ℕ), f'.generalized_eigenspace μ k) = ⊤,
      from ih (finrank K ER) h_dim_ER f' rfl,
    -- The induction hypothesis gives us a statement about subspaces of `ER`. We can transfer this
    -- to a statement about subspaces of `V` via `submodule.subtype`:
    have ih_ER' : (⨆ (μ : K) (k : ℕ), (f'.generalized_eigenspace μ k).map ER.subtype) = ER,
      by simp only [(submodule.map_supr _ _).symm, ih_ER, submodule.map_subtype_top ER],
    -- Moreover, every generalized eigenspace of `f'` is contained in the corresponding generalized
    -- eigenspace of `f`.
    have hff' : ∀ μ k,
        (f'.generalized_eigenspace μ k).map ER.subtype ≤ f.generalized_eigenspace μ k,
    { intros,
      rw generalized_eigenspace_restrict,
      apply submodule.map_comap_le },
    -- It follows that `ER` is contained in the span of all generalized eigenvectors.
    have hER : ER ≤ ⨆ (μ : K) (k : ℕ), f.generalized_eigenspace μ k,
    { rw ← ih_ER',
      apply supr_le_supr _,
      exact λ μ, supr_le_supr (λ k, hff' μ k), },
    -- `ES` is contained in this span by definition.
    have hES : ES ≤ ⨆ (μ : K) (k : ℕ), f.generalized_eigenspace μ k,
      from le_trans
        (le_supr (λ k, f.generalized_eigenspace μ₀ k) (finrank K V))
        (le_supr (λ (μ : K), ⨆ (k : ℕ), f.generalized_eigenspace μ k) μ₀),
    -- Moreover, we know that `ER` and `ES` are disjoint.
    have h_disjoint : disjoint ER ES,
      from generalized_eigenvec_disjoint_range_ker f μ₀,
    -- Since the dimensions of `ER` and `ES` add up to the dimension of `V`, it follows that the
    -- span of all generalized eigenvectors is all of `V`.
    show (⨆ (μ : K) (k : ℕ), f.generalized_eigenspace μ k) = ⊤,
    { rw [←top_le_iff, ←submodule.eq_top_of_disjoint ER ES h_dim_add h_disjoint],
      apply sup_le hER hES } }
end

end End
end module


/-
Copyright (c) 2022 Yaël Dillies, Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Bhavik Mehta

! This file was ported from Lean 3 source module combinatorics.simple_graph.regularity.uniform
! leanprover-community/mathlib commit 32b08ef840dd25ca2e47e035c5da03ce16d2dc3c
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Combinatorics.SimpleGraph.Density
import Mathlib.SetTheory.Ordinal.Basic

/-!
# Graph uniformity and uniform partitions

In this file we define uniformity of a pair of vertices in a graph and uniformity of a partition of
vertices of a graph. Both are also known as ε-regularity.

Finsets of vertices `s` and `t` are `ε`-uniform in a graph `G` if their edge density is at most
`ε`-far from the density of any big enough `s'` and `t'` where `s' ⊆ s`, `t' ⊆ t`.
The definition is pretty technical, but it amounts to the edges between `s` and `t` being "random"
The literature contains several definitions which are equivalent up to scaling `ε` by some constant
when the partition is equitable.

A partition `P` of the vertices is `ε`-uniform if the proportion of non `ε`-uniform pairs of parts
is less than `ε`.

## Main declarations

* `SimpleGraph.IsUniform`: Graph uniformity of a pair of finsets of vertices.
* `SimpleGraph.nonuniformWitness`: `G.nonuniformWitness ε s t` and `G.nonuniformWitness ε t s`
  together witness the non-uniformity of `s` and `t`.
* `Finpartition.nonUniforms`: Non uniform pairs of parts of a partition.
* `Finpartition.IsUniform`: Uniformity of a partition.
* `Finpartition.nonuniformWitnesses`: For each non-uniform pair of parts of a partition, pick
  witnesses of non-uniformity and dump them all together.
-/

open Finset

variable {α 𝕜 : Type _} [LinearOrderedField 𝕜]

/-! ###  Graph uniformity -/

namespace SimpleGraph

variable (G : SimpleGraph α) [DecidableRel G.Adj] (ε : 𝕜) {s t : Finset α} {a b : α}

/-- A pair of finsets of vertices is `ε`-uniform (aka `ε`-regular) iff their edge density is close
to the density of any big enough pair of subsets. Intuitively, the edges between them are
random-like. -/
def IsUniform (s t : Finset α) : Prop :=
  ∀ ⦃s'⦄, s' ⊆ s → ∀ ⦃t'⦄, t' ⊆ t → (s.card : 𝕜) * ε ≤ s'.card →
    (t.card : 𝕜) * ε ≤ t'.card → |(G.edgeDensity s' t' : 𝕜) - (G.edgeDensity s t : 𝕜)| < ε
#align simple_graph.is_uniform SimpleGraph.IsUniform

variable {G ε}

theorem IsUniform.mono {ε' : 𝕜} (h : ε ≤ ε') (hε : IsUniform G ε s t) : IsUniform G ε' s t :=
  fun s' hs' t' ht' hs ht => by
  refine' (hε hs' ht' (le_trans _ hs) (le_trans _ ht)).trans_le h <;>
    exact mul_le_mul_of_nonneg_left h (Nat.cast_nonneg _)
#align simple_graph.is_uniform.mono SimpleGraph.IsUniform.mono

theorem IsUniform.symm : Symmetric (IsUniform G ε) := fun s t h t' ht' s' hs' ht hs => by
  rw [edgeDensity_comm _ t', edgeDensity_comm _ t]
  exact h hs' ht' hs ht
#align simple_graph.is_uniform.symm SimpleGraph.IsUniform.symm

variable (G)

theorem isUniform_comm : IsUniform G ε s t ↔ IsUniform G ε t s :=
  ⟨fun h => h.symm, fun h => h.symm⟩
#align simple_graph.is_uniform_comm SimpleGraph.isUniform_comm

theorem isUniform_singleton (hε : 0 < ε) : G.IsUniform ε {a} {b} := by
  intro s' hs' t' ht' hs ht
  rw [card_singleton, Nat.cast_one, one_mul] at hs ht
  obtain rfl | rfl := Finset.subset_singleton_iff.1 hs'
  · replace hs : ε ≤ 0 := by simpa using hs
    exact (hε.not_le hs).elim
  obtain rfl | rfl := Finset.subset_singleton_iff.1 ht'
  · replace ht : ε ≤ 0 := by simpa using ht
    exact (hε.not_le ht).elim
  · rwa [sub_self, abs_zero]
#align simple_graph.is_uniform_singleton SimpleGraph.isUniform_singleton

theorem not_isUniform_zero : ¬G.IsUniform (0 : 𝕜) s t := fun h =>
  (abs_nonneg _).not_lt <| h (empty_subset _) (empty_subset _) (by simp) (by simp)
#align simple_graph.not_is_uniform_zero SimpleGraph.not_isUniform_zero

theorem isUniform_one : G.IsUniform (1 : 𝕜) s t := by
  intro s' hs' t' ht' hs ht
  rw [mul_one] at hs ht
  rw [eq_of_subset_of_card_le hs' (Nat.cast_le.1 hs),
    eq_of_subset_of_card_le ht' (Nat.cast_le.1 ht), sub_self, abs_zero]
  exact zero_lt_one
#align simple_graph.is_uniform_one SimpleGraph.isUniform_one

variable {G}

theorem not_isUniform_iff :
    ¬G.IsUniform ε s t ↔ ∃ s', s' ⊆ s ∧ ∃ t', t' ⊆ t ∧ ↑s.card * ε ≤ s'.card ∧
      ↑t.card * ε ≤ t'.card ∧ ε ≤ |G.edgeDensity s' t' - G.edgeDensity s t| := by
  unfold IsUniform
  simp only [not_forall, not_lt, exists_prop, exists_and_left, Rat.cast_abs, Rat.cast_sub]
#align simple_graph.not_is_uniform_iff SimpleGraph.not_isUniform_iff

open Classical

variable (G)

/-- An arbitrary pair of subsets witnessing the non-uniformity of `(s, t)`. If `(s, t)` is uniform,
returns `(s, t)`. Witnesses for `(s, t)` and `(t, s)` don't necessarily match. See
`SimpleGraph.nonuniformWitness`. -/
noncomputable def nonuniformWitnesses (ε : 𝕜) (s t : Finset α) : Finset α × Finset α :=
  if h : ¬G.IsUniform ε s t then
    ((not_isUniform_iff.1 h).choose, (not_isUniform_iff.1 h).choose_spec.2.choose)
  else (s, t)
#align simple_graph.nonuniform_witnesses SimpleGraph.nonuniformWitnesses

theorem left_nonuniformWitnesses_subset (h : ¬G.IsUniform ε s t) :
    (G.nonuniformWitnesses ε s t).1 ⊆ s := by
  rw [nonuniformWitnesses, dif_pos h]
  exact (not_isUniform_iff.1 h).choose_spec.1
#align simple_graph.left_nonuniform_witnesses_subset SimpleGraph.left_nonuniformWitnesses_subset

theorem left_nonuniformWitnesses_card (h : ¬G.IsUniform ε s t) :
    (s.card : 𝕜) * ε ≤ (G.nonuniformWitnesses ε s t).1.card := by
  rw [nonuniformWitnesses, dif_pos h]
  exact (not_isUniform_iff.1 h).choose_spec.2.choose_spec.2.1
#align simple_graph.left_nonuniform_witnesses_card SimpleGraph.left_nonuniformWitnesses_card

theorem right_nonuniformWitnesses_subset (h : ¬G.IsUniform ε s t) :
    (G.nonuniformWitnesses ε s t).2 ⊆ t := by
  rw [nonuniformWitnesses, dif_pos h]
  exact (not_isUniform_iff.1 h).choose_spec.2.choose_spec.1
#align simple_graph.right_nonuniform_witnesses_subset SimpleGraph.right_nonuniformWitnesses_subset

theorem right_nonuniformWitnesses_card (h : ¬G.IsUniform ε s t) :
    (t.card : 𝕜) * ε ≤ (G.nonuniformWitnesses ε s t).2.card := by
  rw [nonuniformWitnesses, dif_pos h]
  exact (not_isUniform_iff.1 h).choose_spec.2.choose_spec.2.2.1
#align simple_graph.right_nonuniform_witnesses_card SimpleGraph.right_nonuniformWitnesses_card

theorem nonuniformWitnesses_spec (h : ¬G.IsUniform ε s t) :
    ε ≤
      |G.edgeDensity (G.nonuniformWitnesses ε s t).1 (G.nonuniformWitnesses ε s t).2 -
          G.edgeDensity s t| := by
  rw [nonuniformWitnesses, dif_pos h]
  exact (not_isUniform_iff.1 h).choose_spec.2.choose_spec.2.2.2
#align simple_graph.nonuniform_witnesses_spec SimpleGraph.nonuniformWitnesses_spec

/-- Arbitrary witness of non-uniformity. `G.nonuniformWitness ε s t` and
`G.nonuniformWitness ε t s` form a pair of subsets witnessing the non-uniformity of `(s, t)`. If
`(s, t)` is uniform, returns `s`. -/
noncomputable def nonuniformWitness (ε : 𝕜) (s t : Finset α) : Finset α :=
  if WellOrderingRel s t then (G.nonuniformWitnesses ε s t).1 else (G.nonuniformWitnesses ε t s).2
#align simple_graph.nonuniform_witness SimpleGraph.nonuniformWitness

theorem nonuniformWitness_subset (h : ¬G.IsUniform ε s t) : G.nonuniformWitness ε s t ⊆ s := by
  unfold nonuniformWitness
  split_ifs
  · exact G.left_nonuniformWitnesses_subset h
  · exact G.right_nonuniformWitnesses_subset fun i => h i.symm
#align simple_graph.nonuniform_witness_subset SimpleGraph.nonuniformWitness_subset

theorem nonuniformWitness_card_le (h : ¬G.IsUniform ε s t) :
    (s.card : 𝕜) * ε ≤ (G.nonuniformWitness ε s t).card := by
  unfold nonuniformWitness
  split_ifs
  · exact G.left_nonuniformWitnesses_card h
  · exact G.right_nonuniformWitnesses_card fun i => h i.symm
#align simple_graph.nonuniform_witness_card_le SimpleGraph.nonuniformWitness_card_le

theorem nonuniformWitness_spec (h₁ : s ≠ t) (h₂ : ¬G.IsUniform ε s t) :
    ε ≤
      |G.edgeDensity (G.nonuniformWitness ε s t) (G.nonuniformWitness ε t s) - G.edgeDensity s t| :=
  by
  unfold nonuniformWitness
  rcases trichotomous_of WellOrderingRel s t with (lt | rfl | gt)
  · rw [if_pos lt, if_neg (asymm lt)]
    exact G.nonuniformWitnesses_spec h₂
  · cases h₁ rfl
  · rw [if_neg (asymm gt), if_pos gt, edgeDensity_comm, edgeDensity_comm _ s]
    apply G.nonuniformWitnesses_spec fun i => h₂ i.symm
#align simple_graph.nonuniform_witness_spec SimpleGraph.nonuniformWitness_spec

end SimpleGraph

/-! ### Uniform partitions -/

variable [DecidableEq α] {A : Finset α} (P : Finpartition A) (G : SimpleGraph α)
  [DecidableRel G.Adj] {ε : 𝕜}

namespace Finpartition

open Classical

/-- The pairs of parts of a partition `P` which are not `ε`-uniform in a graph `G`. Note that we
dismiss the diagonal. We do not care whether `s` is `ε`-uniform with itself. -/
noncomputable def nonUniforms (ε : 𝕜) : Finset (Finset α × Finset α) :=
  P.parts.offDiag.filter fun uv => ¬G.IsUniform ε uv.1 uv.2
#align finpartition.non_uniforms Finpartition.nonUniforms

theorem mk_mem_nonUniforms_iff (u v : Finset α) (ε : 𝕜) :
    (u, v) ∈ P.nonUniforms G ε ↔ u ∈ P.parts ∧ v ∈ P.parts ∧ u ≠ v ∧ ¬G.IsUniform ε u v := by
  rw [nonUniforms, mem_filter, mem_offDiag, and_assoc, and_assoc]
#align finpartition.mk_mem_non_uniforms_iff Finpartition.mk_mem_nonUniforms_iff

theorem nonUniforms_mono {ε ε' : 𝕜} (h : ε ≤ ε') : P.nonUniforms G ε' ⊆ P.nonUniforms G ε :=
  monotone_filter_right _ fun _ => mt <| SimpleGraph.IsUniform.mono h
#align finpartition.non_uniforms_mono Finpartition.nonUniforms_mono

theorem nonUniforms_bot (hε : 0 < ε) : (⊥ : Finpartition A).nonUniforms G ε = ∅ := by
  rw [eq_empty_iff_forall_not_mem]
  rintro ⟨u, v⟩
  simp only [Finpartition.mk_mem_nonUniforms_iff, Finpartition.parts_bot, mem_map, not_and,
    Classical.not_not, exists_imp]; dsimp
  rintro x ⟨_,xu⟩  y ⟨_,yv⟩ _
  rw [←xu, ←yv]
  exact G.isUniform_singleton hε
#align finpartition.non_uniforms_bot Finpartition.nonUniforms_bot

/-- A finpartition of a graph's vertex set is `ε`-uniform (aka `ε`-regular) iff the proportion of
its pairs of parts that are not `ε`-uniform is at most `ε`. -/
def IsUniform (ε : 𝕜) : Prop :=
  ((P.nonUniforms G ε).card : 𝕜) ≤ (P.parts.card * (P.parts.card - 1) : ℕ) * ε
#align finpartition.is_uniform Finpartition.IsUniform

theorem botIsUniform (hε : 0 < ε) : (⊥ : Finpartition A).IsUniform G ε := by
  rw [Finpartition.IsUniform, Finpartition.card_bot, nonUniforms_bot _ hε, Finset.card_empty,
    Nat.cast_zero]
  exact mul_nonneg (Nat.cast_nonneg _) hε.le
#align finpartition.bot_is_uniform Finpartition.botIsUniform

theorem isUniformOne : P.IsUniform G (1 : 𝕜) := by
  rw [IsUniform, mul_one, Nat.cast_le]
  refine' (card_filter_le _
    (fun uv => ¬SimpleGraph.IsUniform G 1 (Prod.fst uv) (Prod.snd uv))).trans _
  rw [offDiag_card, Nat.mul_sub_left_distrib, mul_one]
#align finpartition.is_uniform_one Finpartition.isUniformOne

variable {P G}

theorem IsUniform.mono {ε ε' : 𝕜} (hP : P.IsUniform G ε) (h : ε ≤ ε') : P.IsUniform G ε' :=
  ((Nat.cast_le.2 <| card_le_of_subset <| P.nonUniforms_mono G h).trans hP).trans <|
    mul_le_mul_of_nonneg_left h <| Nat.cast_nonneg _
#align finpartition.is_uniform.mono Finpartition.IsUniform.mono

theorem isUniformOfEmpty (hP : P.parts = ∅) : P.IsUniform G ε := by
  simp [IsUniform, hP, nonUniforms]
#align finpartition.is_uniform_of_empty Finpartition.isUniformOfEmpty

theorem nonempty_of_not_uniform (h : ¬P.IsUniform G ε) : P.parts.Nonempty :=
  nonempty_of_ne_empty fun h₁ => h <| isUniformOfEmpty h₁
#align finpartition.nonempty_of_not_uniform Finpartition.nonempty_of_not_uniform

variable (P G ε) (s : Finset α)

/-- A choice of witnesses of non-uniformity among the parts of a finpartition. -/
noncomputable def nonuniformWitnesses : Finset (Finset α) :=
  (P.parts.filter fun t => s ≠ t ∧ ¬G.IsUniform ε s t).image (G.nonuniformWitness ε s)
#align finpartition.nonuniform_witnesses Finpartition.nonuniformWitnesses

variable {P G ε s} {t : Finset α}

theorem nonuniformWitness_mem_nonuniformWitnesses (h : ¬G.IsUniform ε s t) (ht : t ∈ P.parts)
    (hst : s ≠ t) : G.nonuniformWitness ε s t ∈ P.nonuniformWitnesses G ε s :=
  mem_image_of_mem _ <| mem_filter.2 ⟨ht, hst, h⟩
#align finpartition.nonuniform_witness_mem_nonuniform_witnesses Finpartition.nonuniformWitness_mem_nonuniformWitnesses

end Finpartition


import tactic

/-

# Solution to the "friends" problem in Lean

## The question

Let `Z` be a set. If `f : X → Z` and `g : Y → Z` are injective functions, let’s say that `f` is
friends with `g` if there is a bijection `h : X → Y` such that `f = g ∘ h`.

Prove that f is friends with g if and only if the range of f equals the range of g.

NB: by the range of f : X → Z I mean the subset of Z consisting of things “hit” by f ,
in other words the set `{z : Z | ∃ x : X, f x = z}`. Some people call this the “image” of f ,
and some people use “range” to mean the same thing as “codomain” :-|

-/

-- Let Z be a set, fixed throughout this question
constant Z : Type

-- Let S be the set of collections of a set `X` and an injective function `X → Z`
structure S :=
(X : Type)
(f : X → Z)
(hf : f.injective)

-- Implementation detail:
-- The way `S` works internally is is that an element `a` of `S` is a triple consisting
-- of a set `a.X`, a function `a.f : a.X → Z` and a proof `a.hf` that `a.f` is injective.

-- However we really would like to think of an element of `S` as a function! So let's tell Lean
-- that if we have an element `a` of `S`, to treat it as the function `a.f` from `a.X` to `Z`
instance : has_coe_to_fun S (λ a, a.X → Z) := ⟨λ a, a.f⟩

-- Say elements `f : X → Z` and `g : Y → Z` of `S` are *friends* if there's a bijection
-- `h` from `X` to `Y` such that forall `x` in `X`, `f(x)=g(h(x))`
def friends (f g : S) : Prop :=
-- take f and g apart into their triples
let ⟨X, f, hf⟩ := f, ⟨Y, g, hg⟩ := g in
-- and now write the definition
∃ h : X ≃ Y, ∀ x : X, f x = g (h x)

open set

-- Before we start on the theorem, let's prove some helpful lemmas.

-- First let's first prove that if `f` is friends with `g` then `g` is friends with `f`
lemma friends_symmetric : ∀ f g : S, friends f g → friends g f :=
begin
  -- let's say `f` is represented by `f : X → Z`, with proof `hf` that `f` is injective
  rintro ⟨X, f, hf⟩,
  -- and let's say `g` is represented by `g : Y → Z`
  rintro ⟨Y, g, hg⟩,
  -- Let `h` be the function showing that `f` and `g` are friends
  rintro ⟨h, hfriends⟩,
  -- h is bijective so it has a two-sided inverse; let's use that to show that
  -- `g` and `f` are friends
  use h.symm,
  -- Our hypotheses `hfriends` is that `∀ x, f(x)=g(h(x))`, and we have to show
  -- that `∀ y, g(y)=f(h⁻¹(y))`. So let y ∈ Y be arbitrary
  intro y,
  -- Apply `hfriends` with `x=h⁻¹(y)
  rw hfriends,
  -- We now have to prove that g(y)=g(h(h⁻¹(y))) but the h and h⁻¹ now cancel
  -- because h⁻¹ is a two-sided inverse of h, so we're done
  simp,
end

-- Now let's prove that if `f` is friends with `g` then the range of `f` is a
-- subset of the range of `g`
lemma friends_implies_subset : ∀ f g : S, friends f g → range f ⊆ range g :=
begin
  -- Let f : X → Z and g : Y → Z be friends and let `h : X → Y` be the bijection
  rintro ⟨X, f, hf⟩ ⟨Y, g, hg⟩ ⟨h, hfriends⟩,
  -- We need to prove range(f) ⊆ range(g), so say z ∈ range(f)
  rintro z (hz : z ∈ range f),
  -- Because `z` is in the range of `f`, there exists `x ∈ X` with `f(x)=z`.
  obtain ⟨x, rfl⟩ := hz,
  -- The goal is to prove that f(x) is in the range of g. Let's show that it
  -- equals g(h(x)).
  refine ⟨h x, (_ : g (h x) = f x)⟩,
  -- But this follows immediately from the fact that `f` and `g` are friends.
  rw hfriends,
end

-- The big theorem: two injective functions f and g are friends iff they have
-- the same range
theorem friends_iff_same_range (f g : S) : friends f g ↔ range f = range g :=
begin
  -- This is an iff so let's first go one way and then the other
  -- First let's prove that if a and b are friends then their ranges are the same
  split,
  { -- Assume f and g are friends
    intro hfriends,
    -- To prove that two sets are equal, it suffices to prove that each one
    -- is a subset of the other
    apply subset_antisymm,
    { -- One inclusion follows from the lemma `friends_implies_subset`
      apply friends_implies_subset,
      assumption, },
    { -- and the other also follows from the lemma `friends_implies_subset`,
      apply friends_implies_subset,
      -- and the fact that g is friends with f, which follows from the lemma `friends_symmetric`
      apply friends_symmetric,
      assumption, } },
  { -- Now let's go the other way
    -- Say f : X → Z and g : Y → Z are injective functions with the same range
    rcases f with ⟨X, f, hf⟩,
    rcases g with ⟨Y, g, hg⟩,
    rintro (hrange : range f = range g),
    -- Let's prove that `f` and `g` are friends.
    -- We need to construct a bijection from X to Y.
    -- First let's show that for all x in X, there exists y in Y with g(y)=f(x)
    have hxy : ∀ x : X, ∃ y : Y, g y = f x,
    { -- so let x ∈ X be arbitrary
      intro x,
      -- Then by definition, f(x) ∈ range f
      have hx : f x ∈ range f := ⟨x, rfl⟩,
      -- so f(x) ∈ range g, because hypothesis `hrange` says that `f` and `g` have the same range
      rw hrange at hx,
      -- and hence there exists y ∈ Y with g(y)=f(x)
      exact hx, },
    -- Using this fact let's define h : X → Y by, for all x in X, letting h(x) be an
    -- arbitrary element `y` of `Y` with `g(y)=f(x)`.
    -- We note that this definition shows that `∀ x, g(h(x))=f(x)`.
    -- Let's call this hypothesis `hyp1`
    choose h hyp1 using hxy,
    -- The same construction with X and Y reversed
    -- shows that for all y in Y, there exists x in X with f(x)=g(y)
    have hyx : ∀ y : Y, ∃ x : X, f x = g y,
    { intro y,
      have hy : g y ∈ range g := ⟨y, rfl⟩,
      rwa ← hrange at hy, },
    -- So we can define j : Y → X by, for all y ∈ Y, letting j(y) ∈ X be an arbitrary
    -- element of X with f(x)=g(y). In other words, we know that for all y, `f(j(y))=g(y)`
    -- Let's let `hyp2` be the statement `∀ y, f(j(y))=g(y)`.
    choose j hyp2 using hyx,
    -- I claim is that ``h` and `j` are two-sided inverses of one another,
    -- and hence `h` is a bijection.
    -- Let's first check that the claim implies that f and g are friends.
    suffices : j.left_inverse h ∧ j.right_inverse h,
    { -- What needs to be done to check that `h : X → Y` works?
      refine ⟨⟨h, j, this.1, this.2⟩, _⟩,
      -- We just need to prove that ∀ x, f(x)=g(h(x))
      show ∀ x, f x = g (h x),
      -- But this is just `hyp1`,
      intro x, rw hyp1,
    },
    -- It suffices to prove that `j` is both a left and right inverse of `h`.
    split,
    { -- Let's first show that j(h(x))=x for all x. So let x in X be arbitrary
      intro x,
      -- By injectivity of f, it suffices to prove that f(j(h(x)))=f(x)
      apply hf,
      -- Now use hyp2, which says f ∘ j = g
      rw hyp2,
      -- and now the goal is ∀ x, g(h(x))=f(x), which is hypothesis `hyp1`
      rw hyp1,
    },
    { -- The other way is pretty much the same. We need to show h(j(y))=y for all y.
      -- So let y be arbitrary
      intro y,
      -- By injectivity of g, it suffice to prove g(h(j(y)))=g(y)
      apply hg,
      -- but g∘h=f by hyp1
      rw hyp1,
      -- and f(j(y))=g(y) by hype
      rw hyp2,
      -- and we're done!
    } },

end


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

Tuples are lists of a fixed size.
It is implemented as a subtype.
-/
import logic data.list data.fin
open nat list subtype function

definition tuple [reducible] (A : Type) (n : nat) := {l : list A | length l = n}

namespace tuple
  variables {A B C : Type}

  theorem induction_on [recursor 4] {P : ∀ {n}, tuple A n → Prop}
                       : ∀ {n} (v : tuple A n), (∀ (l : list A) {n : nat} (h : length l = n), P (tag l h)) → P v
  | n (tag l h) H := @H l n h

  definition nil : tuple A 0 :=
  tag [] rfl

  lemma length_succ {n : nat} {l : list A} (a : A) : length l = n → length (a::l) = succ n :=
  λ h, congr_arg succ h

  definition cons {n : nat} : A → tuple A n → tuple A (succ n)
  | a (tag v h) := tag (a::v) (length_succ a h)

  notation a :: b := cons a b

  protected definition is_inhabited [instance] [h : inhabited A] : ∀ (n : nat), inhabited (tuple A n)
  | 0        := inhabited.mk nil
  | (succ n) := inhabited.mk (inhabited.value h :: inhabited.value (is_inhabited n))

  protected definition has_decidable_eq [instance] [h : decidable_eq A] : ∀ (n : nat), decidable_eq (tuple A n) :=
  λ n, subtype.has_decidable_eq

  definition head {n : nat} : tuple A (succ n) → A
  | (tag []     h) := by contradiction
  | (tag (a::v) h) := a

  definition tail {n : nat} : tuple A (succ n) → tuple A n
  | (tag []     h) := by contradiction
  | (tag (a::v) h) := tag v (succ.inj h)

  theorem head_cons {n : nat} (a : A) (v : tuple A n) : head (a :: v) = a :=
  by induction v; reflexivity

  theorem tail_cons {n : nat} (a : A) (v : tuple A n) : tail (a :: v) = v :=
  by induction v; reflexivity

  theorem head_lcons {n : nat} (a : A) (l : list A) (h : length (a::l) = succ n) : head (tag (a::l) h) = a :=
  rfl

  theorem tail_lcons {n : nat} (a : A) (l : list A) (h : length (a::l) = succ n) : tail (tag (a::l) h) = tag l (succ.inj h) :=
  rfl

  definition last {n : nat} : tuple A (succ n) → A
  | (tag l h) := list.last l (ne_nil_of_length_eq_succ h)

  theorem eta : ∀ {n : nat} (v : tuple A (succ n)), head v :: tail v = v
  | 0     (tag [] h)     := by contradiction
  | 0     (tag (a::l) h) := rfl
  | (n+1) (tag [] h)     := by contradiction
  | (n+1) (tag (a::l) h) := rfl

  definition of_list (l : list A) : tuple A (list.length l) :=
  tag l rfl

  definition to_list {n : nat} : tuple A n → list A
  | (tag l h) := l

  theorem to_list_of_list (l : list A) : to_list (of_list l) = l :=
  rfl

  theorem to_list_nil : to_list nil = ([] : list A) :=
  rfl

  theorem length_to_list {n : nat} : ∀ (v : tuple A n), list.length (to_list v) = n
  | (tag l h) := h

  theorem heq_of_list_eq {n m} : ∀ {v₁ : tuple A n} {v₂ : tuple A m}, to_list v₁ = to_list v₂ → n = m → v₁ == v₂
  | (tag l₁ h₁) (tag l₂ h₂) e₁ e₂ := begin
      clear heq_of_list_eq,
      subst e₂, subst h₁,
      unfold to_list at e₁,
      subst l₁
    end

  theorem list_eq_of_heq {n m} {v₁ : tuple A n} {v₂ : tuple A m} : v₁ == v₂ → n = m → to_list v₁ = to_list v₂ :=
  begin
    intro h₁ h₂, revert v₁ v₂ h₁,
    subst n, intro v₁ v₂ h₁, rewrite [eq_of_heq h₁]
  end

  theorem of_list_to_list {n : nat} (v : tuple A n) : of_list (to_list v) == v :=
  begin
    apply heq_of_list_eq, rewrite to_list_of_list, rewrite length_to_list
  end

  /- append -/

  definition append {n m : nat} : tuple A n → tuple A m → tuple A (n + m)
  | (tag l₁ h₁) (tag l₂ h₂) := tag (list.append l₁ l₂) (by rewrite [length_append, h₁, h₂])

  infix ++ := append

  open eq.ops

  lemma push_eq_rec : ∀ {n m : nat} {l : list A} (h₁ : n = m) (h₂ : length l = n), h₁ ▹ (tag l h₂) = tag l (h₁ ▹ h₂)
  | n n l (eq.refl n) h₂ := rfl

  theorem append_nil_right {n : nat} (v : tuple A n) : v ++ nil = v :=
  induction_on v (λ l n h, by unfold [tuple.append, tuple.nil]; congruence; apply list.append_nil_right)

  theorem append_nil_left {n : nat} (v : tuple A n) : !zero_add ▹ (nil ++ v) = v :=
  induction_on v (λ l n h, begin unfold [tuple.append, tuple.nil], rewrite [push_eq_rec] end)

  theorem append_nil_left_heq {n : nat} (v : tuple A n) : nil ++ v == v :=
  heq_of_eq_rec_left !zero_add (append_nil_left v)

  theorem append.assoc {n₁ n₂ n₃} : ∀ (v₁ : tuple A n₁) (v₂ : tuple A n₂) (v₃ : tuple A n₃), !add.assoc ▹ ((v₁ ++ v₂) ++ v₃) = v₁ ++ (v₂ ++ v₃)
  | (tag l₁ h₁) (tag l₂ h₂) (tag l₃ h₃) := begin
    unfold tuple.append, rewrite push_eq_rec,
    congruence,
    apply list.append.assoc
  end

  theorem append.assoc_heq {n₁ n₂ n₃} (v₁ : tuple A n₁) (v₂ : tuple A n₂) (v₃ : tuple A n₃) : (v₁ ++ v₂) ++ v₃ == v₁ ++ (v₂ ++ v₃) :=
  heq_of_eq_rec_left !add.assoc (append.assoc v₁ v₂ v₃)

  /- reverse -/

  definition reverse {n : nat} : tuple A n → tuple A n
  | (tag l h) := tag (list.reverse l) (by rewrite [length_reverse, h])

  theorem reverse_reverse {n : nat} (v : tuple A n) : reverse (reverse v) = v :=
  induction_on v (λ l n h, begin unfold reverse, congruence, apply list.reverse_reverse end)

  theorem tuple0_eq_nil : ∀ (v : tuple A 0), v = nil
  | (tag []     h) := rfl
  | (tag (a::l) h) := by contradiction

  /- mem -/

  definition mem {n : nat} (a : A) (v : tuple A n) : Prop :=
  a ∈ elt_of v

  notation e ∈ s := mem e s
  notation e ∉ s := ¬ e ∈ s

  theorem not_mem_nil (a : A) : a ∉ nil :=
  list.not_mem_nil a

  theorem mem_cons [simp] {n : nat} (a : A) (v : tuple A n) : a ∈ a :: v :=
  induction_on v (λ l n h, !list.mem_cons)

  theorem mem_cons_of_mem {n : nat} (y : A) {x : A} {v : tuple A n} : x ∈ v → x ∈ y :: v :=
  induction_on v (λ l n h₁ h₂, list.mem_cons_of_mem y h₂)

  theorem eq_or_mem_of_mem_cons {n : nat} {x y : A} {v : tuple A n} : x ∈ y::v → x = y ∨ x ∈ v :=
  induction_on v (λ l n h₁ h₂, eq_or_mem_of_mem_cons h₂)

  theorem mem_singleton {n : nat} {x a : A} : x ∈ (a::nil : tuple A 1) → x = a :=
  assume h, list.mem_singleton h

  /- map -/

  definition map {n : nat} (f : A → B) : tuple A n → tuple B n
  | (tag l h) := tag (list.map f l) (by clear map; substvars; rewrite length_map)

  theorem map_nil (f : A → B) : map f nil = nil :=
  rfl

  theorem map_cons {n : nat} (f : A → B) (a : A) (v : tuple A n) : map f (a::v) = f a :: map f v :=
  by induction v; reflexivity

  theorem map_tag {n : nat} (f : A → B) (l : list A) (h : length l = n)
                   : map f (tag l h) = tag (list.map f l) (by substvars; rewrite length_map) :=
  by reflexivity

  theorem map_map {n : nat} (g : B → C) (f : A → B) (v : tuple A n) : map g (map f v) = map (g ∘ f) v :=
  begin cases v, rewrite *map_tag, apply subtype.eq, apply list.map_map end

  theorem map_id {n : nat} (v : tuple A n) : map id v = v :=
  begin induction v, unfold map, congruence, apply list.map_id end

  theorem mem_map {n : nat} {a : A} {v : tuple A n} (f : A → B) : a ∈ v → f a ∈ map f v :=
  begin induction v, unfold map, apply list.mem_map end

  theorem exists_of_mem_map {n : nat} {f : A → B} {b : B} {v : tuple A n} : b ∈ map f v → ∃a, a ∈ v ∧ f a = b :=
  begin induction v, unfold map, apply list.exists_of_mem_map end

  theorem eq_of_map_const {n : nat} {b₁ b₂ : B} {v : tuple A n} : b₁ ∈ map (const A b₂) v → b₁ = b₂ :=
  begin induction v, unfold map, apply list.eq_of_map_const end

  /- product -/

  definition product {n m : nat} : tuple A n → tuple B m → tuple (A × B) (n * m)
  | (tag l₁ h₁) (tag l₂ h₂) := tag (list.product l₁ l₂) (by rewrite [length_product, h₁, h₂])

  theorem nil_product {m : nat} (v : tuple B m) : !zero_mul ▹ product (@nil A) v = nil :=
  begin induction v, unfold [nil, product], rewrite push_eq_rec end

  theorem nil_product_heq {m : nat} (v : tuple B m) : product (@nil A) v == (@nil (A × B)) :=
  heq_of_eq_rec_left _ (nil_product v)

  theorem product_nil {n : nat} (v : tuple A n) : product v (@nil B) = nil :=
  begin induction v, unfold [nil, product], congruence, apply list.product_nil end

  theorem mem_product {n m : nat} {a : A} {b : B} {v₁ : tuple A n} {v₂ : tuple B m} : a ∈ v₁ → b ∈ v₂ → (a, b) ∈ product v₁ v₂ :=
  begin cases v₁, cases v₂, unfold product, apply list.mem_product end

  theorem mem_of_mem_product_left {n m : nat} {a : A} {b : B} {v₁ : tuple A n} {v₂ : tuple B m} : (a, b) ∈ product v₁ v₂ → a ∈ v₁ :=
  begin cases v₁, cases v₂, unfold product, apply list.mem_of_mem_product_left end

  theorem mem_of_mem_product_right {n m : nat} {a : A} {b : B} {v₁ : tuple A n} {v₂ : tuple B m} : (a, b) ∈ product v₁ v₂ → b ∈ v₂ :=
  begin cases v₁, cases v₂, unfold product, apply list.mem_of_mem_product_right end

  /- ith -/
  open fin

  definition ith {n : nat} : tuple A n → fin n → A
  | (tag l h₁) (mk i h₂) := list.ith l i (by rewrite h₁; exact h₂)

  lemma ith_zero {n : nat} (a : A) (v : tuple A n) (h : 0 < succ n) : ith (a::v) (mk 0 h) = a :=
  by induction v; reflexivity

  lemma ith_fin_zero {n : nat} (a : A) (v : tuple A n) : ith (a::v) (fin.zero n) = a :=
  by unfold fin.zero; apply ith_zero

  lemma ith_succ {n : nat} (a : A) (v : tuple A n) (i : nat) (h : succ i < succ n)
                 : ith (a::v) (mk (succ i) h) = ith v (mk_pred i h) :=
  by induction v; reflexivity

  lemma ith_fin_succ {n : nat} (a : A) (v : tuple A n) (i : fin n)
                     : ith (a::v) (succ i) = ith v i :=
  begin cases i, unfold fin.succ, rewrite ith_succ end

  lemma ith_zero_eq_head {n : nat} (v : tuple A (nat.succ n)) : ith v (fin.zero n) = head v :=
  by rewrite [-eta v, ith_fin_zero, head_cons]

  lemma ith_succ_eq_ith_tail {n : nat} (v : tuple A (nat.succ n)) (i : fin n) : ith v (succ i) = ith (tail v) i :=
  by rewrite [-eta v, ith_fin_succ, tail_cons]

  protected lemma ext {n : nat} (v₁ v₂ : tuple A n) (h : ∀ i : fin n, ith v₁ i = ith v₂ i) : v₁ = v₂ :=
  begin
    induction n with n ih,
      rewrite [tuple0_eq_nil v₁, tuple0_eq_nil v₂],
      rewrite [-eta v₁, -eta v₂], congruence,
        show head v₁ = head v₂, by rewrite [-ith_zero_eq_head, -ith_zero_eq_head]; apply h,
        have ∀ i : fin n, ith (tail v₁) i = ith (tail v₂) i, from
          take i, by rewrite [-ith_succ_eq_ith_tail, -ith_succ_eq_ith_tail]; apply h,
        show tail v₁ = tail v₂, from ih _ _ this
  end

  /- tabulate -/

  definition tabulate : Π {n : nat}, (fin n → A) → tuple A n
  | 0     f := nil
  | (n+1) f := f (fin.zero n) :: tabulate (λ i : fin n, f (succ i))

  theorem ith_tabulate {n : nat} (f : fin n → A) (i : fin n) : ith (tabulate f) i = f i :=
  begin
    induction n with n ih,
      apply elim0 i,
      cases i with v hlt, cases v,
        {unfold tabulate, rewrite ith_zero},
        {unfold tabulate, rewrite [ith_succ, ih]}
  end

  variable {n : ℕ}

  definition replicate (n : ℕ) : A → tuple A n
  | a := tag (list.replicate n a) (length_replicate n a)

  definition dropn : Π (i:ℕ), tuple A n → tuple A (n - i)
  | i (tag l p) := tag (list.dropn i l) (p ▸ list.length_dropn i l)

  definition firstn : Π (i:ℕ), tuple A n → tuple A (min i n)
  | i (tag l p) :=
    let q := calc list.length (list.firstn i l)
                     = min i (list.length l)  : list.length_firstn_eq
                 ... = min i n : p in
    tag (list.firstn i l) q

  definition map₂ : (A → B → C) → tuple A n → tuple B n → tuple C n
  | f (tag x px) (tag y py) :=
    let z : list C := list.map₂ f x y in
    let p : list.length z = n := calc
         list.length z = min (list.length x) (list.length y) : list.length_map₂
                   ... = min n n                             : by rewrite [px, py]
                   ... = n                                   : min_self in
    tag z p

  section accum
  open prod
  variable {S : Type}

  definition mapAccumR
  : (A → S → S × B) → tuple A n → S → S × tuple B n
  | f (tag x px) c :=
    let z := list.mapAccumR f x c in
    let p := calc
          list.length (pr₂ (list.mapAccumR f x c))
                  = length x                   : length_mapAccumR
              ... = n                          : px in
    (pr₁ z, tag (pr₂ z) p)

  definition mapAccumR₂
  : (A → B → S → S × C) → tuple A n → tuple B n → S → S × tuple C n
  | f (tag x px) (tag y py) c :=
    let z := list.mapAccumR₂ f x y c in
    let p := calc
          list.length (pr₂ (list.mapAccumR₂ f x y c))
                  = min (length x) (length y)  : length_mapAccumR₂
              ... = n                          : by rewrite [ px, py, min_self ] in
    (pr₁ z, tag (pr₂ z) p)
  end accum
end tuple


import tools.super
open nat set

section nat

theorem lt_succ_iff_le (m n : nat) : m < succ n ↔ m ≤ n :=
iff.intro le_of_lt_succ lt_succ_of_le

private theorem or_resolve_right {a b : Prop} (H₁ : a ∨ b) (H₂ : ¬a) : b :=
by super

theorem eq_zero_or_eq_succ_pred (n : ℕ) : n = 0 ∨ n = succ (pred n) :=
nat.rec_on n
  (or.inl rfl)
  (take m IH, or.inr
(show succ m = succ (pred (succ m)), from congr_arg succ (eq.symm $ pred_succ m)))

theorem succ_pred_of_pos {n : ℕ} (H : n > 0) : succ (pred n) = n :=
eq.symm (or_resolve_right (eq_zero_or_eq_succ_pred n) (ne.symm (ne_of_lt H)))

end nat

theorem ext {X : Type} {a b : set X} (H : ∀x, x ∈ a ↔ x ∈ b) : a = b :=
funext (take x, propext (H x))

theorem not_mem_empty {X : Type} (x : X) : ¬ (x ∈ (∅ : set X)) :=
assume H : x ∈ ∅, H

section
/- universal set -/
variable {α : Type}

theorem mem_univ (x : α) : x ∈ @univ α := trivial

theorem mem_univ_iff (x : α) : x ∈ @univ α ↔ true := iff.rfl

@[simp]
theorem mem_univ_eq (x : α) : x ∈ @univ α = true := rfl

theorem empty_ne_univ [h : inhabited α] : (∅ : set α) ≠ univ :=
assume H : ∅ = univ,
absurd (mem_univ (inhabited.default α)) (eq.rec_on H (not_mem_empty _))

@[simp]
theorem subset_univ (s : set α) : s ⊆ univ := λ x H, trivial

end

theorem eq_sep_of_subset {X : Type} {s t : set X} (ssubt : s ⊆ t) : s = {x ∈ t | x ∈ s} :=
ext (take x, iff.intro
  (suppose x ∈ s, and.intro (ssubt this) this)
(suppose x ∈ {x ∈ t | x ∈ s}, and.right this))

theorem subset_insert {X : Type} (x : X) (a : set X) : a ⊆ insert x a :=
take y, assume ys, or.inr ys

theorem not_mem_of_mem_diff {A : Type} {s t : set A} {x : A} (H : x ∈ s \ t) : x ∉ t :=
and.right H

theorem mem_insert {X : Type} (x : X) (s : set X) : x ∈ insert x s :=
or.inl rfl

theorem mem_singleton {X : Type} (a : X) : a ∈ insert a (∅ : set X) := mem_insert _ _

theorem eq_of_mem_singleton {X : Type} {x y : X} (h : x ∈ insert y (∅ : set X)) : x = y :=
or.elim (h)
  (suppose x = y, this)
(suppose x ∈ ∅, absurd this (not_mem_empty _))

theorem mem_singleton_iff {X : Type} (a b : X) : a ∈ insert b (∅ : set X) ↔ a = b :=
iff.intro
  (assume ainb, or.elim ainb (λ aeqb, aeqb) (λ f, false.elim f))
(assume aeqb, or.inl aeqb)

theorem eq_empty_of_forall_not_mem {X : Type} {s : set X} (H : ∀ x, x ∉ s) : s = ∅ :=
ext (take x, iff.intro
  (assume xs, absurd xs (H x))
(assume xe, absurd xe (not_mem_empty _)))

section
  open classical
  variable {X : Type}

  theorem exists_mem_of_ne_empty {s : set X} (H : s ≠ ∅) : ∃ x, x ∈ s :=
  by_contradiction (assume H', H (eq_empty_of_forall_not_mem (forall_not_of_not_exists H')))

end

definition eq_on {X Y : Type} (f1 f2 : X → Y) (a : set X) : Prop :=
∀ x ∈ a, f1 x = f2 x

attribute [reducible]
definition maps_to {X Y : Type} (f : X → Y) (a : set X) (b : set Y) : Prop := ∀⦃x⦄, x ∈ a → f x ∈ b

attribute [reducible]
definition surj_on {X Y : Type} (f : X → Y) (a : set X) (b : set Y) : Prop := b ⊆ image f a

attribute [reducible]
definition inj_on {X Y: Type} (f : X → Y) (a : set X) : Prop :=
∀⦃x1 x2 : X⦄, x1 ∈ a → x2 ∈ a → f x1 = f x2 → x1 = x2

section function

variables {X Y Z: Type}
/- left inverse -/

-- g is a left inverse to f on a
attribute [reducible]
definition left_inv_on  (g : Y → X) (f : X → Y) (a : set X) : Prop :=
∀ x ∈ a, g (f x) = x

theorem left_inv_on_of_eq_on_left {g1 g2 : Y → X} {f : X → Y} {a : set X} {b : set Y}
  (fab : maps_to f a b) (eqg : eq_on g1 g2 b) (H : left_inv_on g1 f a) : left_inv_on g2 f a :=
take x,
assume xa : x ∈ a,
calc
  g2 (f x) = g1 (f x) : eq.symm (eqg _ (fab xa))
  ... = x : H _ xa

theorem left_inv_on_of_eq_on_right {g : Y → X} {f1 f2 : X → Y} {a : set X}
  (eqf : eq_on f1 f2 a) (H : left_inv_on g f1 a) : left_inv_on g f2 a :=
take x,
assume xa : x ∈ a,
calc
  g (f2 x) = g (f1 x) : by rw eq.symm (eqf _ xa)
... = x : H _ xa

theorem inj_on_of_left_inv_on {g : Y → X} {f : X → Y} {a : set X} (H : left_inv_on g f a) :
  inj_on f a :=
take x1 x2,
assume x1a : x1 ∈ a,
assume x2a : x2 ∈ a,
assume H1 : f x1 = f x2,
calc
  x1     = g (f x1) : eq.symm (H _ x1a)
     ... = g (f x2) : by rw H1
     ... = x2 : H _ x2a

theorem left_inv_on_comp {f' : Y → X} {g' : Z → Y} {g : Y → Z} {f : X → Y}
   {a : set X} {b : set Y} (fab : maps_to f a b)
    (Hf : left_inv_on f' f a) (Hg : left_inv_on g' g b) : left_inv_on (f' ∘ g') (g ∘ f) a :=
take x : X,
assume xa : x ∈ a,
have fxb : f x ∈ b, from fab xa,
calc
  f' (g' (g (f x))) = f' (f x) : by rw Hg _ fxb
  ... = x : Hf _ xa

/- right inverse -/

-- g is a right inverse to f on a
attribute [reducible]
definition right_inv_on (g : Y → X) (f : X → Y) (b : set Y) : Prop :=
left_inv_on f g b

theorem right_inv_on_of_eq_on_left {g1 g2 : Y → X} {f : X → Y} {a : set X} {b : set Y}
  (eqg : eq_on g1 g2 b) (H : right_inv_on g1 f b) : right_inv_on g2 f b :=
left_inv_on_of_eq_on_right eqg H

theorem right_inv_on_of_eq_on_right {g : Y → X} {f1 f2 : X → Y} {a : set X} {b : set Y}
  (gba : maps_to g b a) (eqf : eq_on f1 f2 a) (H : right_inv_on g f1 b) : right_inv_on g f2 b :=
left_inv_on_of_eq_on_left gba eqf H

theorem surj_on_of_right_inv_on {g : Y → X} {f : X → Y} {a : set X} {b : set Y}
    (gba : maps_to g b a) (H : right_inv_on g f b) :
  surj_on f a b :=
take y,
assume yb : y ∈ b,
have gya : g y ∈ a, from gba yb,
have H1 : f (g y) = y, from H _ yb,
exists.intro (g y) (and.intro gya H1)

end function

-- section

-- -- classical inverse

-- open classical
-- variables {X Y : Type}

-- noncomputable instance dec_prop (p : Prop) : decidable p := prop_decidable p

-- noncomputable definition inv_fun (f : X → Y) (a : set X) (dflt : X) (y : Y) : X :=
-- if H : ∃ x ∈ a, f x = y then some H else dflt

-- theorem inv_fun_pos {f : X → Y} {a : set X} {dflt : X} {y : Y}
--   (H : ∃ x ∈ a, f x = y) : (inv_fun f a dflt y ∈ a) ∧ (f (inv_fun f a dflt y) = y) :=
-- have H1 : inv_fun f a dflt y = some H, from dif_pos H,
-- let ⟨x,ina⟩ := some_spec H in
-- ⟨by rw H1; assumption,by rw H1; assumption⟩

-- theorem inv_fun_neg {f : X → Y} {a : set X} {dflt : X} {y : Y}
--   (H : ¬ ∃ x ∈ a, f x = y) : inv_fun f a dflt y = dflt :=
-- dif_neg H

-- variables {f : X → Y} {a : set X} {b : set Y}

-- theorem maps_to_inv_fun {dflt : X} (dflta : dflt ∈ a) :
--   maps_to (inv_fun f a dflt) b a :=
-- let f' := inv_fun f a dflt in
-- take y,
-- assume yb : y ∈ b,
-- show f' y ∈ a, from
--   by_cases
--     (assume H : ∃ x ∈ a, f x = y,
--       and.left (inv_fun_pos H))
--     (assume H : ¬ ∃ x ∈ a, f x = y,
-- begin dsimp, rw (inv_fun_neg H), assumption end)

-- theorem left_inv_on_inv_fun_of_inj_on (dflt : X) (H : inj_on f a) :
--   left_inv_on (inv_fun f a dflt) f a :=
-- let f' := inv_fun f a dflt in
-- take x,
-- assume xa : x ∈ a,
-- have H1 : ∃ x' ∈ a, f x' = f x, from ⟨x,xa,rfl⟩,
-- have H2 : f' (f x) ∈ a ∧ f (f' (f x)) = f x, from inv_fun_pos H1,
-- show f' (f x) = x, from H (and.left H2) xa (and.right H2)

-- theorem surj_on_inv_fun_of_inj_on (dflt : X) (mapsto : maps_to f a b) (H : inj_on f a) :
--   surj_on (inv_fun f a dflt) b a :=
-- surj_on_of_right_inv_on mapsto (left_inv_on_inv_fun_of_inj_on dflt H)

-- end


/-
Copyright (c) 2022 Eric Rodriguez. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Rodriguez

! This file was ported from Lean 3 source module set_theory.cardinal.divisibility
! leanprover-community/mathlib commit 92ca63f0fb391a9ca5f22d2409a6080e786d99f7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.IsPrimePow
import Mathlib.SetTheory.Cardinal.Ordinal
import Mathlib.Tactic.WLOG

/-!
# Cardinal Divisibility

We show basic results about divisibility in the cardinal numbers. This relation can be characterised
in the following simple way: if `a` and `b` are both less than `ℵ₀`, then `a ∣ b` iff they are
divisible as natural numbers. If `b` is greater than `ℵ₀`, then `a ∣ b` iff `a ≤ b`. This
furthermore shows that all infinite cardinals are prime; recall that `a * b = max a b` if
`ℵ₀ ≤ a * b`; therefore `a ∣ b * c = a ∣ max b c` and therefore clearly either `a ∣ b` or `a ∣ c`.
Note furthermore that no infinite cardinal is irreducible
(`Cardinal.not_irreducible_of_aleph0_le`), showing that the cardinal numbers do not form a
`CancelCommMonoidWithZero`.

## Main results

* `Cardinal.prime_of_aleph0_le`: a `Cardinal` is prime if it is infinite.
* `Cardinal.is_prime_iff`: a `Cardinal` is prime iff it is infinite or a prime natural number.
* `Cardinal.isPrimePow_iff`: a `Cardinal` is a prime power iff it is infinite or a natural number
  which is itself a prime power.

-/

namespace Cardinal

open Cardinal

universe u

variable {a b : Cardinal.{u}} {n m : ℕ}

@[simp]
theorem isUnit_iff : IsUnit a ↔ a = 1 := by
  refine'
    ⟨fun h => _, by
      rintro rfl
      exact isUnit_one⟩
  rcases eq_or_ne a 0 with (rfl | ha)
  · exact (not_isUnit_zero h).elim
  rw [isUnit_iff_forall_dvd] at h
  cases' h 1 with t ht
  rw [eq_comm, mul_eq_one_iff'] at ht
  · exact ht.1
  · exact one_le_iff_ne_zero.mpr ha
  · apply one_le_iff_ne_zero.mpr
    intro h
    rw [h, mul_zero] at ht
    exact zero_ne_one ht
#align cardinal.is_unit_iff Cardinal.isUnit_iff

instance : Unique Cardinal.{u}ˣ where
  default := 1
  uniq a := Units.val_eq_one.mp <| isUnit_iff.mp a.isUnit

theorem le_of_dvd : ∀ {a b : Cardinal}, b ≠ 0 → a ∣ b → a ≤ b
  | a, x, b0, ⟨b, hab⟩ => by
    simpa only [hab, mul_one] using
      mul_le_mul_left' (one_le_iff_ne_zero.2 fun h : b = 0 => b0 (by rwa [h, mul_zero] at hab)) a
#align cardinal.le_of_dvd Cardinal.le_of_dvd

theorem dvd_of_le_of_aleph0_le (ha : a ≠ 0) (h : a ≤ b) (hb : ℵ₀ ≤ b) : a ∣ b :=
  ⟨b, (mul_eq_right hb h ha).symm⟩
#align cardinal.dvd_of_le_of_aleph_0_le Cardinal.dvd_of_le_of_aleph0_le

@[simp]
theorem prime_of_aleph0_le (ha : ℵ₀ ≤ a) : Prime a := by
  refine' ⟨(aleph0_pos.trans_le ha).ne', _, fun b c hbc => _⟩
  · rw [isUnit_iff]
    exact (one_lt_aleph0.trans_le ha).ne'
  cases' eq_or_ne (b * c) 0 with hz hz
  · rcases mul_eq_zero.mp hz with (rfl | rfl) <;> simp
  wlog h : c ≤ b
  · cases le_total c b <;> [skip, rw [or_comm]] <;> apply_assumption
    assumption'
    all_goals rwa [mul_comm]
  left
  have habc := le_of_dvd hz hbc
  rwa [mul_eq_max' <| ha.trans <| habc, max_def', if_pos h] at hbc
#align cardinal.prime_of_aleph_0_le Cardinal.prime_of_aleph0_le

theorem not_irreducible_of_aleph0_le (ha : ℵ₀ ≤ a) : ¬Irreducible a := by
  rw [irreducible_iff, not_and_or]
  refine' Or.inr fun h => _
  simpa [mul_aleph0_eq ha, isUnit_iff, (one_lt_aleph0.trans_le ha).ne', one_lt_aleph0.ne'] using
    h a ℵ₀
#align cardinal.not_irreducible_of_aleph_0_le Cardinal.not_irreducible_of_aleph0_le

@[simp, norm_cast]
theorem nat_coe_dvd_iff : (n : Cardinal) ∣ m ↔ n ∣ m := by
  refine' ⟨_, fun ⟨h, ht⟩ => ⟨h, by exact_mod_cast ht⟩⟩
  rintro ⟨k, hk⟩
  have : ↑m < ℵ₀ := nat_lt_aleph0 m
  rw [hk, mul_lt_aleph0_iff] at this
  rcases this with (h | h | ⟨-, hk'⟩)
  iterate 2 simp only [h, mul_zero, zero_mul, Nat.cast_eq_zero] at hk; simp [hk]
  lift k to ℕ using hk'
  exact ⟨k, by exact_mod_cast hk⟩
#align cardinal.nat_coe_dvd_iff Cardinal.nat_coe_dvd_iff

@[simp]
theorem nat_is_prime_iff : Prime (n : Cardinal) ↔ n.Prime := by
  simp only [Prime, Nat.prime_iff]
  refine' and_congr (by simp) (and_congr _ ⟨fun h b c hbc => _, fun h b c hbc => _⟩)
  · simp only [isUnit_iff, Nat.isUnit_iff]
    exact_mod_cast Iff.rfl
  · exact_mod_cast h b c (by exact_mod_cast hbc)
  cases' lt_or_le (b * c) ℵ₀ with h' h'
  · rcases mul_lt_aleph0_iff.mp h' with (rfl | rfl | ⟨hb, hc⟩)
    · simp
    · simp
    lift b to ℕ using hb
    lift c to ℕ using hc
    exact_mod_cast h b c (by exact_mod_cast hbc)
  rcases aleph0_le_mul_iff.mp h' with ⟨hb, hc, hℵ₀⟩
  have hn : (n : Cardinal) ≠ 0 := by
    intro h
    rw [h, zero_dvd_iff, mul_eq_zero] at hbc
    cases hbc <;> contradiction
  wlog hℵ₀b : ℵ₀ ≤ b
  refine' (this h c b _ _ hc hb hℵ₀.symm hn (hℵ₀.resolve_left hℵ₀b)).symm <;> try assumption
  rwa [mul_comm] at hbc
  rwa [mul_comm] at h'
  exact Or.inl (dvd_of_le_of_aleph0_le hn ((nat_lt_aleph0 n).le.trans hℵ₀b) hℵ₀b)
#align cardinal.nat_is_prime_iff Cardinal.nat_is_prime_iff

theorem is_prime_iff {a : Cardinal} : Prime a ↔ ℵ₀ ≤ a ∨ ∃ p : ℕ, a = p ∧ p.Prime := by
  cases' le_or_lt ℵ₀ a with h h
  · simp [h]
  lift a to ℕ using id h
  simp [not_le.mpr h]
#align cardinal.is_prime_iff Cardinal.is_prime_iff

theorem isPrimePow_iff {a : Cardinal} : IsPrimePow a ↔ ℵ₀ ≤ a ∨ ∃ n : ℕ, a = n ∧ IsPrimePow n := by
  by_cases h : ℵ₀ ≤ a
  · simp [h, (prime_of_aleph0_le h).isPrimePow]
  simp only [h, Nat.cast_inj, exists_eq_left', false_or_iff, isPrimePow_nat_iff]
  lift a to ℕ using not_le.mp h
  rw [isPrimePow_def]
  refine'
    ⟨_, fun ⟨n, han, p, k, hp, hk, h⟩ =>
          ⟨p, k, nat_is_prime_iff.2 hp, hk, by rw [han]; exact_mod_cast h⟩⟩
  rintro ⟨p, k, hp, hk, hpk⟩
  have key : p ^ 1 ≤ ↑a := by rw [←hpk]; apply power_le_power_left hp.ne_zero; exact_mod_cast hk
  rw [power_one] at key
  lift p to ℕ using key.trans_lt (nat_lt_aleph0 a)
  exact ⟨a, rfl, p, k, nat_is_prime_iff.mp hp, hk, by exact_mod_cast hpk⟩
#align cardinal.is_prime_pow_iff Cardinal.isPrimePow_iff

end Cardinal


-- Introducción de la implicación en Lean
-- ======================================

-- Demostrar que
--    P → P

import tactic
variables (P : Prop)

-- 1ª demostración
example : P → P :=
begin
  intro h,
  exact h,
end

-- 2ª demostración
example : P → P :=
λ h, h

-- 3ª demostración
example : P → P :=
id

-- 4ª demostración
example : P → P :=
begin
  assume h : P,
  show P, from h,
end

-- 5ª demostración
example : P → P :=
assume h, h

-- 6ª demostración
example : P → P :=
-- by hint
by tauto

-- 7ª demostración
example : P → P :=
by finish

-- 8ª demostración
example : P → P :=
by simp


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

import algebra.direct_sum.module
import tactic.fin_cases

/-!
# Not all complementary decompositions of a module over a semiring make up a direct sum

This shows that while `ℤ≤0` and `ℤ≥0` are complementary `ℕ`-submodules of `ℤ`, which in turn
implies as a collection they are `complete_lattice.independent` and that they span all of `ℤ`, they
do not form a decomposition into a direct sum.

This file demonstrates why `direct_sum.submodule_is_internal_of_independent_of_supr_eq_top` must
take `ring R` and not `semiring R`.
-/

lemma units_int.one_ne_neg_one : (1 : units ℤ) ≠ -1 := dec_trivial

/-- Submodules of positive and negative integers, keyed by sign. -/
def with_sign (i : units ℤ) : submodule ℕ ℤ :=
add_submonoid.to_nat_submodule $ show add_submonoid ℤ, from
  { carrier := {z | 0 ≤ i • z},
    zero_mem' := show 0 ≤ i • (0 : ℤ), from (smul_zero _).ge,
    add_mem' := λ x y (hx : 0 ≤ i • x) (hy : 0 ≤ i • y), show _ ≤ _, begin
      rw smul_add,
      exact add_nonneg hx hy
    end }

local notation `ℤ≥0` := with_sign 1
local notation `ℤ≤0` := with_sign (-1)

lemma mem_with_sign_one {x : ℤ} : x ∈ ℤ≥0 ↔ 0 ≤ x :=
show _ ≤ _ ↔ _, by rw one_smul

lemma mem_with_sign_neg_one {x : ℤ} : x ∈ ℤ≤0 ↔ x ≤ 0 :=
show _ ≤ _ ↔ _, by rw [units.neg_smul, le_neg, one_smul, neg_zero]

/-- The two submodules are complements. -/
lemma with_sign.is_compl : is_compl (ℤ≥0) (ℤ≤0) :=
begin
  split,
  { apply submodule.disjoint_def.2,
    intros x hx hx',
    exact le_antisymm (mem_with_sign_neg_one.mp hx') (mem_with_sign_one.mp hx), },
  { intros x hx,
    obtain hp | hn := (le_refl (0 : ℤ)).le_or_le x,
    exact submodule.mem_sup_left (mem_with_sign_one.mpr hp),
    exact submodule.mem_sup_right (mem_with_sign_neg_one.mpr hn), }
end

def with_sign.independent : complete_lattice.independent with_sign :=
begin
  intros i,
  rw [←finset.sup_univ_eq_supr, units_int.univ, finset.sup_insert, finset.sup_singleton],
  fin_cases i,
  { convert with_sign.is_compl.disjoint,
    convert bot_sup_eq,
    { exact supr_neg (not_not_intro rfl), },
    { rw supr_pos units_int.one_ne_neg_one.symm } },
  { convert with_sign.is_compl.disjoint.symm,
    convert sup_bot_eq,
    { exact supr_neg (not_not_intro rfl), },
    { rw supr_pos units_int.one_ne_neg_one } },
end

lemma with_sign.supr : supr with_sign = ⊤ :=
begin
  rw [←finset.sup_univ_eq_supr, units_int.univ, finset.sup_insert, finset.sup_singleton],
  exact with_sign.is_compl.sup_eq_top,
end

/-- But there is no embedding into `ℤ` from the direct sum. -/
lemma with_sign.not_injective :
  ¬function.injective (direct_sum.to_module ℕ (units ℤ) ℤ (λ i, (with_sign i).subtype)) :=
begin
  intro hinj,
  let p1 : ℤ≥0 := ⟨1, mem_with_sign_one.2 zero_le_one⟩,
  let n1 : ℤ≤0 := ⟨-1, mem_with_sign_neg_one.2 $ neg_nonpos.2 zero_le_one⟩,
  let z := direct_sum.lof ℕ _ (λ i, with_sign i) 1 p1 +
           direct_sum.lof ℕ _ (λ i, with_sign i) (-1) n1,
  have : z ≠ 0,
  { intro h,
    dsimp [z, direct_sum.lof_eq_of, direct_sum.of] at h,
    replace h := dfinsupp.ext_iff.mp h 1,
    rw [dfinsupp.zero_apply, dfinsupp.add_apply, dfinsupp.single_eq_same,
      dfinsupp.single_eq_of_ne (units_int.one_ne_neg_one.symm), add_zero, subtype.ext_iff,
      submodule.coe_zero] at h,
    apply zero_ne_one h.symm, },
  apply hinj.ne this,
  rw [linear_map.map_zero, linear_map.map_add, direct_sum.to_module_lof, direct_sum.to_module_lof],
  simp,
end

/-- And so they do not represent an internal direct sum. -/
lemma with_sign.not_internal : ¬direct_sum.submodule_is_internal with_sign :=
with_sign.not_injective ∘ and.elim_left


import data.matrix.notation

example (x : ℕ) (h : x = 3) : x + x + x = 9 :=
begin
  set y := x with ←h_xy,
  guard_hyp y := ℕ,
  guard_hyp h_xy := x = y,
  guard_hyp h := y = 3,
  guard_target y + y + y = 9,
  set! z : ℕ := y,
  guard_target y + y + y = 9, -- target stay the same
  simp [h],
end